{-# LANGUAGE RebindableSyntax #-}
{- |
Convert a human readable string to a physical value.
-}

module Number.Physical.Read where

import qualified Number.Physical        as Value
import qualified Number.Physical.UnitDatabase as Db
import qualified Algebra.VectorSpace as VectorSpace
import qualified Algebra.Field       as Field
import qualified Data.Map as Map
import Data.Map (Map)
import Text.ParserCombinators.Parsec
import Control.Monad(liftM)

import NumericPrelude.Base
import NumericPrelude.Numeric

mulPrec :: Int
mulPrec :: Int
mulPrec = Int
7

-- How to handle the 'prec' argument?
readsNat :: (Enum i, Ord i, Read v, VectorSpace.C a v) =>
   Db.T i a -> Int -> ReadS (Value.T i v)
readsNat :: T i a -> Int -> ReadS (T i v)
readsNat T i a
db Int
prec =
   Bool -> ReadS (T i v) -> ReadS (T i v)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
precInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
mulPrec)
      (((v, String) -> (T i v, String))
-> [(v, String)] -> [(T i v, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(v
x, String
rest) ->
             let (Value.Cons T i
cu a
c, String
rest') = Map String (T i a) -> String -> (T i a, String)
forall i a.
(Ord i, C a) =>
Map String (T i a) -> String -> (T i a, String)
readUnitPart (T i a -> Map String (T i a)
forall i a. T i a -> Map String (T i a)
createDict T i a
db) String
rest
             in  (T i -> v -> T i v
forall i a. T i -> a -> T i a
Value.Cons T i
cu (a
c a -> v -> v
forall a v. C a v => a -> v -> v
*> v
x), String
rest'))
       ([(v, String)] -> [(T i v, String)])
-> (String -> [(v, String)]) -> ReadS (T i v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
       Int -> String -> [(v, String)]
forall a. Read a => Int -> ReadS a
readsPrec Int
mulPrec)

readUnitPart :: (Ord i, Field.C a) =>
   Map String (Value.T i a)
      -> String -> (Value.T i a, String)
readUnitPart :: Map String (T i a) -> String -> (T i a, String)
readUnitPart Map String (T i a)
dict String
str =
   let parseUnit :: ParsecT String () Identity (T i a, String)
parseUnit =
          do [(String, Integer)]
p    <- Parser [(String, Integer)]
parseProduct
             String
rest <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
             (T i a, String) -> ParsecT String () Identity (T i a, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([T i a] -> T i a
forall a. C a => [a] -> a
product (((String, Integer) -> T i a) -> [(String, Integer)] -> [T i a]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
unit,Integer
n) ->
                        T i a -> String -> Map String (T i a) -> T i a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
                           (String -> T i a
forall a. HasCallStack => String -> a
error (String
"unknown unit '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
unit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'")) String
unit Map String (T i a)
dict
                           T i a -> Integer -> T i a
forall a. C a => a -> Integer -> a
^ Integer
n) [(String, Integer)]
p),
                     String
rest)
   in  case ParsecT String () Identity (T i a, String)
-> String -> String -> Either ParseError (T i a, String)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse ParsecT String () Identity (T i a, String)
parseUnit String
"unit" String
str of
          Left  ParseError
msg -> String -> (T i a, String)
forall a. HasCallStack => String -> a
error (ParseError -> String
forall a. Show a => a -> String
show ParseError
msg)
          Right (T i a, String)
val -> (T i a, String)
val


{-| This function could also return the value,
    but a list of pairs (String, Integer) is easier for testing. -}
parseProduct :: Parser [(String, Integer)]
parseProduct :: Parser [(String, Integer)]
parseProduct =
   ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT String () Identity ()
-> Parser [(String, Integer)] -> Parser [(String, Integer)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      ((do (String, Integer)
p <- Parser (String, Integer) -> Parser (String, Integer)
forall a. Parser a -> Parser a
ignoreSpace Parser (String, Integer)
parsePower
           [(String, Integer)]
t <- Parser [(String, Integer)]
parseProductTail
           [(String, Integer)] -> Parser [(String, Integer)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Integer)
p (String, Integer) -> [(String, Integer)] -> [(String, Integer)]
forall a. a -> [a] -> [a]
: [(String, Integer)]
t)) Parser [(String, Integer)]
-> Parser [(String, Integer)] -> Parser [(String, Integer)]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       Parser [(String, Integer)]
parseProductTail)

parseProductTail :: Parser [(String, Integer)]
parseProductTail :: Parser [(String, Integer)]
parseProductTail =
   let parseTail :: Char
-> ((String, Integer) -> (String, Integer))
-> Parser [(String, Integer)]
parseTail Char
c (String, Integer) -> (String, Integer)
f = 
         do Char
_ <- ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
ignoreSpace (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
c)
            (String, Integer)
p <- Parser (String, Integer) -> Parser (String, Integer)
forall a. Parser a -> Parser a
ignoreSpace Parser (String, Integer)
parsePower
            [(String, Integer)]
t <- Parser [(String, Integer)]
parseProductTail
            [(String, Integer)] -> Parser [(String, Integer)]
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, Integer) -> (String, Integer)
f (String, Integer)
p (String, Integer) -> [(String, Integer)] -> [(String, Integer)]
forall a. a -> [a] -> [a]
: [(String, Integer)]
t)
   in  Char
-> ((String, Integer) -> (String, Integer))
-> Parser [(String, Integer)]
parseTail Char
'*' (String, Integer) -> (String, Integer)
forall a. a -> a
id Parser [(String, Integer)]
-> Parser [(String, Integer)] -> Parser [(String, Integer)]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       Char
-> ((String, Integer) -> (String, Integer))
-> Parser [(String, Integer)]
parseTail Char
'/' (\(String
x,Integer
n) -> (String
x,-Integer
n)) Parser [(String, Integer)]
-> Parser [(String, Integer)] -> Parser [(String, Integer)]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
       [(String, Integer)] -> Parser [(String, Integer)]
forall (m :: * -> *) a. Monad m => a -> m a
return []

parsePower :: Parser (String, Integer)
parsePower :: Parser (String, Integer)
parsePower =
   do String
w <- ParsecT String () Identity String
-> ParsecT String () Identity String
forall a. Parser a -> Parser a
ignoreSpace (ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\181'))
      Integer
e <- (String -> Integer)
-> ParsecT String () Identity String
-> ParsecT String () Identity Integer
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Integer
forall a. Read a => String -> a
read (ParsecT String () Identity Char -> ParsecT String () Identity Char
forall a. Parser a -> Parser a
ignoreSpace (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'^') ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) ParsecT String () Identity Integer
-> ParsecT String () Identity Integer
-> ParsecT String () Identity Integer
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Integer -> ParsecT String () Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
1
      (String, Integer) -> Parser (String, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
w,Integer
e)

{- Turns a parser into one that ignores subsequent whitespaces. -}
ignoreSpace :: Parser a -> Parser a
ignoreSpace :: Parser a -> Parser a
ignoreSpace Parser a
p =
   do a
x <- Parser a
p
      ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
      a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x


createDict :: Db.T i a -> Map String (Value.T i a)
createDict :: T i a -> Map String (T i a)
createDict T i a
db =
   [(String, T i a)] -> Map String (T i a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((UnitSet i a -> [(String, T i a)]) -> T i a -> [(String, T i a)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\Db.UnitSet {unit :: forall i a. UnitSet i a -> T i
Db.unit = T i
xu, scales :: forall i a. UnitSet i a -> [Scale a]
Db.scales = [Scale a]
s}
           -> (Scale a -> (String, T i a)) -> [Scale a] -> [(String, T i a)]
forall a b. (a -> b) -> [a] -> [b]
map (\Db.Scale {symbol :: forall a. Scale a -> String
Db.symbol = String
sym, magnitude :: forall a. Scale a -> a
Db.magnitude = a
x}
                       -> (String
sym, T i -> a -> T i a
forall i a. T i -> a -> T i a
Value.Cons T i
xu a
x)) [Scale a]
s) T i a
db)