module Data.Metrology.Parser.Internal (
UnitExp(..), parseUnit,
parseUnitExp, parseUnitType,
SymbolTable(..), mkSymbolTable,
lex, unitStringParser
) where
import Prelude hiding ( lex, div )
import Text.Parsec hiding ( tab )
import Text.Parsec.String
import Text.Parsec.Pos
import qualified Data.Map.Strict as Map
import qualified Data.MultiMap as MM
import Control.Monad.Reader
import Control.Arrow hiding ( app)
import Data.Maybe
import Data.Char
import Data.Metrology
import Language.Haskell.TH hiding ( Pred )
partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
partitionWith _ [] = ([],[])
partitionWith f (x:xs) = case f x of
Left b -> (b:bs, cs)
Right c -> (bs, c:cs)
where (bs,cs) = partitionWith f xs
experiment :: Stream s m t => ParsecT s u m a -> ParsecT s u m (Maybe a)
experiment = lookAhead . optionMaybe . try
consumeAll :: (Stream s m t, Show t) => ParsecT s u m a -> ParsecT s u m a
consumeAll p = do
result <- p
eof
return result
nochar :: Stream s m Char => Char -> ParsecT s u m ()
nochar = void . char
data Op = NegO | MultO | DivO | PowO | OpenP | CloseP
instance Show Op where
show NegO = "-"
show MultO = "*"
show DivO = "/"
show PowO = "^"
show OpenP = "("
show CloseP = ")"
data Token = UnitT String
| NumberT Integer
| OpT Op
instance Show Token where
show (UnitT s) = s
show (NumberT i) = show i
show (OpT op) = show op
data UnitExp pre u = Unity
| Unit (Maybe pre) u
| Mult (UnitExp pre u) (UnitExp pre u)
| Div (UnitExp pre u) (UnitExp pre u)
| Pow (UnitExp pre u) Integer
instance (Show pre, Show u) => Show (UnitExp pre u) where
show Unity = "1"
show (Unit (Just pre) u) = show pre ++ " :@ " ++ show u
show (Unit Nothing u) = show u
show (Mult e1 e2) = "(" ++ show e1 ++ " :* " ++ show e2 ++ ")"
show (Div e1 e2) = "(" ++ show e1 ++ " :/ " ++ show e2 ++ ")"
show (Pow e i) = show e ++ " :^ " ++ show i
type Lexer = Parser
unitL :: Lexer Token
unitL = UnitT `fmap` (many1 letter)
opL :: Lexer Token
opL = fmap OpT $
do { nochar '-'; return NegO }
<|> do { nochar '*'; return MultO }
<|> do { nochar '/'; return DivO }
<|> do { nochar '^'; return PowO }
<|> do { nochar '('; return OpenP }
<|> do { nochar ')'; return CloseP }
numberL :: Lexer Token
numberL = (NumberT . read) `fmap` (many1 digit)
lexer1 :: Lexer Token
lexer1 = unitL <|> opL <|> numberL
lexer :: Lexer [Token]
lexer = do
spaces
choice
[ do eof <?> ""
return []
, do tok <- lexer1
spaces
toks <- lexer
return (tok : toks)
]
lex :: String -> Either ParseError [Token]
lex = parse lexer ""
type PrefixTable pre = Map.Map String pre
type UnitTable u = Map.Map String u
data SymbolTable pre u = SymbolTable { prefixTable :: PrefixTable pre
, unitTable :: UnitTable u
}
deriving Show
unambFromList :: (Ord a, Show b) => [(a,b)] -> Either [(a,[String])] (Map.Map a b)
unambFromList list =
let multimap = MM.fromList list
assocs = MM.assocs multimap
(errs, goods) = partitionWith (\(key, vals) ->
case vals of
[val] -> Right (key, val)
_ -> Left (key, map show vals)) assocs
result = Map.fromList goods
in
if null errs then Right result else Left errs
mkSymbolTable :: (Show pre, Show u)
=> [(String, pre)]
-> [(String, u)]
-> Either String (SymbolTable pre u)
mkSymbolTable prefixes units =
let bad_strings = filter (not . all isLetter) (map fst prefixes ++ map fst units) in
if not (null bad_strings)
then Left $ "All prefixes and units must be composed entirely of letters.\nThe following are illegal: " ++ show bad_strings
else
let result = do
prefixTab <- unambFromList prefixes
unitTab <- unambFromList units
return $ SymbolTable { prefixTable = prefixTab, unitTable = unitTab }
in left ((++ error_suffix) . concatMap mk_error_string) result
where
mk_error_string :: Show x => (String, [x]) -> String
mk_error_string (k, vs) =
"The label `" ++ k ++ "' is assigned to the following meanings:\n" ++
show vs ++ "\n"
error_suffix = "This is ambiguous. Please fix before building a unit parser."
type GenUnitStringParser pre u = ParsecT String () (Reader (SymbolTable pre u))
type UnitStringParser_UnitExp =
forall pre u. (Show pre, Show u) => GenUnitStringParser pre u (UnitExp pre u)
justUnitP :: GenUnitStringParser pre u u
justUnitP = do
full_string <- getInput
units <- asks unitTable
case Map.lookup full_string units of
Nothing -> fail (full_string ++ " does not match any known unit")
Just u -> return u
prefixUnitP :: UnitStringParser_UnitExp
prefixUnitP = do
prefixTab <- asks prefixTable
let assocs = Map.assocs prefixTab
results <- catMaybes `liftM` mapM (experiment . parse_one) assocs
full_string <- getInput
case results of
[] -> fail $ "No known interpretation for " ++ full_string
[(pre_name, unit_name)] ->
return $ Unit (Just pre_name) unit_name
lots -> fail $ "Multiple possible interpretations for " ++ full_string ++ ":\n" ++
(concatMap (\(pre_name, unit_name) ->
" " ++ show pre_name ++
" :@ " ++ show unit_name ++ "\n") lots)
where
parse_one :: (String, pre) -> GenUnitStringParser pre u (pre, u)
parse_one (pre, name) = do
void $ string pre
unit_name <- justUnitP
return (name, unit_name)
unitStringParser :: UnitStringParser_UnitExp
unitStringParser = try (Unit Nothing `liftM` justUnitP) <|> prefixUnitP
type GenUnitParser pre u = ParsecT [Token] () (Reader (SymbolTable pre u))
type UnitParser a = forall pre u. GenUnitParser pre u a
type UnitParser_UnitExp =
forall pre u. (Show pre, Show u) => GenUnitParser pre u (UnitExp pre u)
updatePosToken :: SourcePos -> Token -> [Token] -> SourcePos
updatePosToken pos (UnitT unit_str) _ = updatePosString pos unit_str
updatePosToken pos (NumberT i) _ = updatePosString pos (show i)
updatePosToken pos (OpT _) _ = incSourceColumn pos 1
uToken :: (Token -> Maybe a) -> UnitParser a
uToken = tokenPrim show updatePosToken
lparenP :: UnitParser ()
lparenP = uToken $ \case
OpT OpenP -> Just ()
_ -> Nothing
rparenP :: UnitParser ()
rparenP = uToken $ \case
OpT CloseP -> Just ()
_ -> Nothing
unitStringP :: String -> UnitParser_UnitExp
unitStringP str = do
symbolTable <- ask
case flip runReader symbolTable $ runParserT unitStringParser () "" str of
Left err -> fail (show err)
Right e -> return e
numP :: UnitParser Integer
numP =
do lparenP
n <- numP
rparenP
return n
<|>
do uToken $ \case
OpT NegO -> Just ()
_ -> Nothing
negate `liftM` numP
<|>
do uToken $ \case
NumberT i -> Just i
_ -> Nothing
powP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u)
powP = option id $ do
uToken $ \case
OpT PowO -> Just ()
_ -> Nothing
n <- numP
return $ flip Pow n
unitP :: UnitParser_UnitExp
unitP =
do n <- numP
case n of
1 -> return Unity
_ -> unexpected $ "number " ++ show n
<|>
do unit_str <- uToken $ \case
UnitT unit_str -> Just unit_str
_ -> Nothing
u <- unitStringP unit_str
maybe_pow <- powP
return $ maybe_pow u
unitFactorP :: UnitParser_UnitExp
unitFactorP =
do lparenP
unitExp <- parser
rparenP
return unitExp
<|>
(foldl1 Mult `liftM` many1 unitP)
opP :: GenUnitParser pre u (UnitExp pre u -> UnitExp pre u -> UnitExp pre u)
opP = uToken $ \case
OpT MultO -> Just Mult
OpT DivO -> Just Div
_ -> Nothing
parser :: UnitParser_UnitExp
parser = chainl unitFactorP opP Unity
parseUnit :: (Show pre, Show u)
=> SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit tab s = left show $ do
toks <- lex s
flip runReader tab $ runParserT (consumeAll parser) () "" toks
parseUnitExp :: SymbolTable Name Name -> String -> Either String Exp
parseUnitExp tab s = to_exp `liftM` parseUnit tab s
where
to_exp Unity = ConE 'Number
to_exp (Unit (Just pre) unit) = ConE '(:@) `AppE` of_type pre `AppE` of_type unit
to_exp (Unit Nothing unit) = of_type unit
to_exp (Mult e1 e2) = ConE '(:*) `AppE` to_exp e1 `AppE` to_exp e2
to_exp (Div e1 e2) = ConE '(:/) `AppE` to_exp e1 `AppE` to_exp e2
to_exp (Pow e i) = ConE '(:^) `AppE` to_exp e `AppE` mk_sing i
of_type :: Name -> Exp
of_type n = (VarE 'undefined) `SigE` (ConT n)
mk_sing :: Integer -> Exp
mk_sing n
| n < 0 = VarE 'sPred `AppE` mk_sing (n + 1)
| n > 0 = VarE 'sSucc `AppE` mk_sing (n 1)
| otherwise = VarE 'sZero
parseUnitType :: SymbolTable Name Name -> String -> Either String Type
parseUnitType tab s = to_type `liftM` parseUnit tab s
where
to_type Unity = ConT ''Number
to_type (Unit (Just pre) unit) = ConT ''(:@) `AppT` ConT pre `AppT` ConT unit
to_type (Unit Nothing unit) = ConT unit
to_type (Mult e1 e2) = ConT ''(:*) `AppT` to_type e1 `AppT` to_type e2
to_type (Div e1 e2) = ConT ''(:/) `AppT` to_type e1 `AppT` to_type e2
to_type (Pow e i) = ConT ''(:^) `AppT` to_type e `AppT` mk_z i
mk_z :: Integer -> Type
mk_z n
| n < 0 = ConT ''Pred `AppT` mk_z (n + 1)
| n > 0 = ConT ''Succ `AppT` mk_z (n 1)
| otherwise = ConT 'Zero