{-# LANGUAGE LambdaCase #-}

-- | Parse a token stream to an expression tree
--
-- Examples:
--
-- >>> parse [Number 1.0,Operator "+",Number 2.0]
-- Right (1.0 + 2.0)
--
-- >>> parse [OpenParen,Number 3.0,Operator "/",Number 2.0,Operator "+",OpenParen,Number 1.5,Operator "*",Number 2.0,CloseParen,CloseParen,Operator "+",Number 4.95]
-- Right (((3.0 / 2.0) + (1.5 * 2.0)) + 4.95)
--
-- >>> parse [Number 9001.0,Operator "*",Number 29.12]
-- Right (9001.0 * 29.12)
--
-- >>> parse [Number 2.0,Identifier "km",OpenBracket,Identifier "m",CloseBracket]
-- Right 2.0 km[m]
--
-- >>> parse [Identifier "a",Equal,Number 3.0,Comma,Identifier "b",Equal,Number 2.0,Arrow,Identifier "a",Operator "+",Identifier "b"]
-- Right (a = 3.0, b = 2.0 -> (a + b))
--
-- >>> parse [Number 2.0,Operator "*",OpenParen,Number 3,Operator "+",Number 4,CloseParen,Operator "/", Number 7.0]
-- Right ((2.0 * (3.0 + 4.0)) / 7.0)
--
-- >>> parse [Number 2.0,OpenParen,Number 3,Operator "+",Number 4,CloseParen,Operator "/", Number 7.0]
-- Right ((2.0 * (3.0 + 4.0)) / 7.0)

module Math.Haskellator.Internal.Parser (parse) where

import Control.Applicative
import Control.Monad
import Control.Monad.Identity
import Control.Monad.State

import Data.Bifunctor

import Math.Haskellator.Internal.AstProcessingSteps.Evaluate
import Math.Haskellator.Internal.AstProcessingSteps.Normalize
import Math.Haskellator.Internal.DerivedUnits
import Math.Haskellator.Internal.Expr
import Math.Haskellator.Internal.Lexer
import Math.Haskellator.Internal.Operators
import Math.Haskellator.Internal.Units
import Math.Haskellator.Internal.Utils.Composition
import Math.Haskellator.Internal.Utils.Error

newtype ParserT m a = ParserT { forall (m :: * -> *) a.
ParserT m a -> Tokens -> m (Either String (a, Tokens))
runParserT :: Tokens -> m (Either String (a, Tokens)) }

type Parser = ParserT Identity

runParser :: Parser a -> Tokens -> Either String (a, Tokens)
runParser :: forall a. Parser a -> Tokens -> Either String (a, Tokens)
runParser Parser a
p Tokens
ts = Identity (Either String (a, Tokens)) -> Either String (a, Tokens)
forall a. Identity a -> a
runIdentity (Identity (Either String (a, Tokens)) -> Either String (a, Tokens))
-> Identity (Either String (a, Tokens))
-> Either String (a, Tokens)
forall a b. (a -> b) -> a -> b
$ Parser a -> Tokens -> Identity (Either String (a, Tokens))
forall (m :: * -> *) a.
ParserT m a -> Tokens -> m (Either String (a, Tokens))
runParserT Parser a
p Tokens
ts


instance Functor m => Functor (ParserT m) where
    fmap :: forall a b. (a -> b) -> ParserT m a -> ParserT m b
fmap a -> b
f (ParserT Tokens -> m (Either String (a, Tokens))
p) = (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (b, Tokens))) -> ParserT m b)
-> (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> ((a, Tokens) -> (b, Tokens))
-> Either String (a, Tokens) -> Either String (b, Tokens)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (a, Tokens) -> (b, Tokens)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f) (Either String (a, Tokens) -> Either String (b, Tokens))
-> m (Either String (a, Tokens)) -> m (Either String (b, Tokens))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tokens -> m (Either String (a, Tokens))
p Tokens
input

instance Monad m => Applicative (ParserT m) where
    pure :: forall a. a -> ParserT m a
pure a
a = (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (a, Tokens))) -> ParserT m a)
-> (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (a, Tokens) -> m (Either String (a, Tokens)))
-> Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a b. (a -> b) -> a -> b
$ (a, Tokens) -> Either String (a, Tokens)
forall a b. b -> Either a b
Right (a
a, Tokens
input)
    (ParserT Tokens -> m (Either String (a -> b, Tokens))
lhs) <*> :: forall a b. ParserT m (a -> b) -> ParserT m a -> ParserT m b
<*> (ParserT Tokens -> m (Either String (a, Tokens))
rhs) = (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (b, Tokens))) -> ParserT m b)
-> (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> do
        Tokens -> m (Either String (a -> b, Tokens))
lhs Tokens
input m (Either String (a -> b, Tokens))
-> (Either String (a -> b, Tokens)
    -> m (Either String (b, Tokens)))
-> m (Either String (b, Tokens))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left String
err      -> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (b, Tokens) -> m (Either String (b, Tokens)))
-> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a b. (a -> b) -> a -> b
$ String -> Either String (b, Tokens)
forall a b. a -> Either a b
Left String
err
            Right (a -> b
f, Tokens
ts) -> Tokens -> m (Either String (a, Tokens))
rhs Tokens
ts m (Either String (a, Tokens))
-> (Either String (a, Tokens) -> m (Either String (b, Tokens)))
-> m (Either String (b, Tokens))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left String
err         -> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (b, Tokens) -> m (Either String (b, Tokens)))
-> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a b. (a -> b) -> a -> b
$ String -> Either String (b, Tokens)
forall a b. a -> Either a b
Left String
err
                Right (a
res, Tokens
ts') -> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (b, Tokens) -> m (Either String (b, Tokens)))
-> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a b. (a -> b) -> a -> b
$ (b, Tokens) -> Either String (b, Tokens)
forall a b. b -> Either a b
Right (a -> b
f a
res, Tokens
ts')

instance Monad m => Monad (ParserT m) where
    (ParserT Tokens -> m (Either String (a, Tokens))
p) >>= :: forall a b. ParserT m a -> (a -> ParserT m b) -> ParserT m b
>>= a -> ParserT m b
f = (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (b, Tokens))) -> ParserT m b)
-> (Tokens -> m (Either String (b, Tokens))) -> ParserT m b
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> do
        Tokens -> m (Either String (a, Tokens))
p Tokens
input m (Either String (a, Tokens))
-> (Either String (a, Tokens) -> m (Either String (b, Tokens)))
-> m (Either String (b, Tokens))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left String
err        -> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (b, Tokens) -> m (Either String (b, Tokens)))
-> Either String (b, Tokens) -> m (Either String (b, Tokens))
forall a b. (a -> b) -> a -> b
$ String -> Either String (b, Tokens)
forall a b. a -> Either a b
Left String
err
            Right (a
res, Tokens
ts) -> ParserT m b -> Tokens -> m (Either String (b, Tokens))
forall (m :: * -> *) a.
ParserT m a -> Tokens -> m (Either String (a, Tokens))
runParserT (a -> ParserT m b
f a
res) Tokens
ts

instance Monad m => MonadFail (ParserT m) where
    fail :: forall a. String -> ParserT m a
fail = (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (a, Tokens))) -> ParserT m a)
-> (String -> Tokens -> m (Either String (a, Tokens)))
-> String
-> ParserT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either String (a, Tokens))
-> Tokens -> m (Either String (a, Tokens))
forall a b. a -> b -> a
const (m (Either String (a, Tokens))
 -> Tokens -> m (Either String (a, Tokens)))
-> (String -> m (Either String (a, Tokens)))
-> String
-> Tokens
-> m (Either String (a, Tokens))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (a, Tokens) -> m (Either String (a, Tokens)))
-> (String -> Either String (a, Tokens))
-> String
-> m (Either String (a, Tokens))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String (a, Tokens)
forall a b. a -> Either a b
Left

instance Monad m => Alternative (ParserT m) where
    empty :: forall a. ParserT m a
empty = (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (a, Tokens))) -> ParserT m a)
-> (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall a b. (a -> b) -> a -> b
$ m (Either String (a, Tokens))
-> Tokens -> m (Either String (a, Tokens))
forall a b. a -> b -> a
const (m (Either String (a, Tokens))
 -> Tokens -> m (Either String (a, Tokens)))
-> m (Either String (a, Tokens))
-> Tokens
-> m (Either String (a, Tokens))
forall a b. (a -> b) -> a -> b
$ Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (a, Tokens) -> m (Either String (a, Tokens)))
-> Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a b. (a -> b) -> a -> b
$ String -> Either String (a, Tokens)
forall a b. a -> Either a b
Left String
"Empty parser"
    (ParserT Tokens -> m (Either String (a, Tokens))
p1) <|> :: forall a. ParserT m a -> ParserT m a -> ParserT m a
<|> (ParserT Tokens -> m (Either String (a, Tokens))
p2) = (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (a, Tokens))) -> ParserT m a)
-> (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> do
        Either String (a, Tokens)
result <- Tokens -> m (Either String (a, Tokens))
p1 Tokens
input
        case Either String (a, Tokens)
result of
            Left String
_  -> Tokens -> m (Either String (a, Tokens))
p2 Tokens
input
            Right (a, Tokens)
_ -> Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either String (a, Tokens)
result

instance MonadTrans ParserT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> ParserT m a
lift m a
op = (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> m (Either String (a, Tokens))) -> ParserT m a)
-> (Tokens -> m (Either String (a, Tokens))) -> ParserT m a
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> do
        a
result <- m a
op
        Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (a, Tokens) -> m (Either String (a, Tokens)))
-> Either String (a, Tokens) -> m (Either String (a, Tokens))
forall a b. (a -> b) -> a -> b
$ (a, Tokens) -> Either String (a, Tokens)
forall a b. b -> Either a b
Right (a
result, Tokens
input)

instance MonadIO m => MonadIO (ParserT m) where
    liftIO :: forall a. IO a -> ParserT m a
liftIO = m a -> ParserT m a
forall (m :: * -> *) a. Monad m => m a -> ParserT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ParserT m a) -> (IO a -> m a) -> IO a -> ParserT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | Parse a token stream to an expression tree
parse :: Tokens            -- ^ input token stream
      -> Either Error Expr -- ^ the parsed expression tree or an error
parse :: Tokens -> Either Error Expr
parse Tokens
tokens = case Parser Expr -> Tokens -> Either String (Expr, Tokens)
forall a. Parser a -> Tokens -> Either String (a, Tokens)
runParser Parser Expr
parseExpr Tokens
tokens of
    Right (Expr
result, []) -> Expr -> Either Error Expr
forall a b. b -> Either a b
Right Expr
result
    Right (Expr
_, Tokens
ts)      -> Error -> Either Error Expr
forall a b. a -> Either a b
Left (Error -> Either Error Expr) -> Error -> Either Error Expr
forall a b. (a -> b) -> a -> b
$ Kind -> String -> Error
Error Kind
ParseError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"Parser was unable to parse the full input. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tokens -> String
forall a. Show a => a -> String
show Tokens
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" remains in the token stream."
    Left String
err           -> Error -> Either Error Expr
forall a b. a -> Either a b
Left (Error -> Either Error Expr) -> Error -> Either Error Expr
forall a b. (a -> b) -> a -> b
$ Kind -> String -> Error
Error Kind
ParseError String
err

atLeastOne :: Parser a -> Token -> Parser [a]
atLeastOne :: forall a. Parser a -> Token -> Parser [a]
atLeastOne Parser a
p Token
sep = do
    a
x <- Parser a
p
    [a]
xs <- do {
        Token -> Parser ()
requireToken Token
sep;
        Parser a -> Token -> Parser [a]
forall a. Parser a -> Token -> Parser [a]
atLeastOne Parser a
p Token
sep
    } Parser [a] -> Parser [a] -> Parser [a]
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [a] -> Parser [a]
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    [a] -> Parser [a]
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Parser [a]) -> [a] -> Parser [a]
forall a b. (a -> b) -> a -> b
$ a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs

satisfy :: (Token -> Bool) -> Parser Token
satisfy :: (Token -> Bool) -> Parser Token
satisfy Token -> Bool
predicate = (Tokens -> Identity (Either String (Token, Tokens)))
-> Parser Token
forall (m :: * -> *) a.
(Tokens -> m (Either String (a, Tokens))) -> ParserT m a
ParserT ((Tokens -> Identity (Either String (Token, Tokens)))
 -> Parser Token)
-> (Tokens -> Identity (Either String (Token, Tokens)))
-> Parser Token
forall a b. (a -> b) -> a -> b
$ \Tokens
input -> Either String (Token, Tokens)
-> Identity (Either String (Token, Tokens))
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Token, Tokens)
 -> Identity (Either String (Token, Tokens)))
-> Either String (Token, Tokens)
-> Identity (Either String (Token, Tokens))
forall a b. (a -> b) -> a -> b
$ case Tokens
input of
    (Token
x:Tokens
xs) | Token -> Bool
predicate Token
x -> (Token, Tokens) -> Either String (Token, Tokens)
forall a b. b -> Either a b
Right (Token
x, Tokens
xs)
           | Bool
otherwise   -> String -> Either String (Token, Tokens)
forall a b. a -> Either a b
Left (String -> Either String (Token, Tokens))
-> String -> Either String (Token, Tokens)
forall a b. (a -> b) -> a -> b
$ String
"Unexpected token " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Token -> String
forall a. Show a => a -> String
show Token
x
    Tokens
_                    -> String -> Either String (Token, Tokens)
forall a b. a -> Either a b
Left String
"Reached unexpected end of token stream"

isOperator :: Token -> Bool
isOperator :: Token -> Bool
isOperator (Operator String
_) = Bool
True
isOperator Token
_            = Bool
False

isNumber :: Token -> Bool
isNumber :: Token -> Bool
isNumber (Number Double
_) = Bool
True
isNumber Token
_          = Bool
False

isIdentifier :: Token -> Bool
isIdentifier :: Token -> Bool
isIdentifier (Identifier String
_) = Bool
True
isIdentifier Token
_              = Bool
False

requireToken :: Token -> Parser ()
requireToken :: Token -> Parser ()
requireToken Token
t = Parser Token -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Token -> Parser ()) -> Parser Token -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Token -> Bool) -> Parser Token
satisfy (Token -> Token -> Bool
forall a. Eq a => a -> a -> Bool
==Token
t)

parseOperator :: Parser String
parseOperator :: Parser String
parseOperator = do
    Operator String
op <- (Token -> Bool) -> Parser Token
satisfy Token -> Bool
isOperator
    String -> Parser String
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
op

parseNumber :: Parser Double
parseNumber :: Parser Double
parseNumber = do
    Number Double
n <- (Token -> Bool) -> Parser Token
satisfy Token -> Bool
isNumber
    Double -> Parser Double
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
n

requireOperator :: String -> Parser ()
requireOperator :: String -> Parser ()
requireOperator String
op = do
    String
parsedOp <- Parser String
parseOperator
    Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String
parsedOp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
op) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Expected operator " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parsedOp

parseIdentifier :: Parser String
parseIdentifier :: Parser String
parseIdentifier = do
    Identifier String
i <- (Token -> Bool) -> Parser Token
satisfy Token -> Bool
isIdentifier
    String -> Parser String
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
i

parseDimension :: Parser Dimension
parseDimension :: Parser Dimension
parseDimension = Parser Dimension
parseUnitExp Parser Dimension
-> (Dimension -> Parser Dimension) -> Parser Dimension
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dimension -> Parser Dimension
dim'
    where dim' :: Dimension -> Parser Dimension
dim' Dimension
parsedLhs = do {
        Op
op <- Parser Op
parseFactorOp;
        Dimension
parsedRhs <- Parser Dimension
parseUnitExp;
        case Op
op of
            Op
Mult -> Dimension -> Parser Dimension
dim' (Dimension -> Parser Dimension) -> Dimension -> Parser Dimension
forall a b. (a -> b) -> a -> b
$ Dimension -> Dimension -> Dimension
mergeUnits Dimension
parsedLhs Dimension
parsedRhs
            Op
Div  -> Dimension -> Parser Dimension
dim' (Dimension -> Parser Dimension) -> Dimension -> Parser Dimension
forall a b. (a -> b) -> a -> b
$ Dimension -> Dimension -> Dimension
subtractUnits Dimension
parsedLhs Dimension
parsedRhs
            Op
_    -> String -> Parser Dimension
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid factor operator"
    } Parser Dimension -> Parser Dimension -> Parser Dimension
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Dimension -> Parser Dimension
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Dimension
parsedLhs


parseUnitExp :: Parser Dimension
parseUnitExp :: Parser Dimension
parseUnitExp = do
    String
i <- Parser String
parseIdentifier
    (String -> Parser Dimension)
-> (Dimension -> Parser Dimension)
-> Either String Dimension
-> Parser Dimension
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
x -> String -> Parser Dimension
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Dimension) -> String -> Parser Dimension
forall a b. (a -> b) -> a -> b
$ String
"Invalid unit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x) (\Dimension
dim -> do {
        String -> Parser ()
requireOperator String
"^";
        Expr
expr <- Parser Expr
parsePrimary;
        case Expr -> Either Error Expr
normalize Expr
expr Either Error Expr
-> (Expr -> Either Error EvalValue) -> Either Error EvalValue
forall a b.
Either Error a -> (a -> Either Error b) -> Either Error b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Either Error EvalValue
execute of
            Right (Value Double
v []) -> let e :: Int
e = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Double
v :: Int in Dimension -> Parser Dimension
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ((\(UnitExp Unit
u Int
e') -> Unit -> Int -> UnitExp
UnitExp Unit
u (Int -> UnitExp) -> Int -> UnitExp
forall a b. (a -> b) -> a -> b
$ Int
e' Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
e) (UnitExp -> UnitExp) -> Dimension -> Dimension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dimension
dim)
            Either Error EvalValue
_                  -> String -> Parser Dimension
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Exponentiation of units is not supported"
    } Parser Dimension -> Parser Dimension -> Parser Dimension
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Dimension -> Parser Dimension
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Dimension
dim) (Either String Dimension -> Parser Dimension)
-> Either String Dimension -> Parser Dimension
forall a b. (a -> b) -> a -> b
$ String -> Either String Dimension
parseUnitSymbol String
i

parseUnitSymbol :: String -> Either String Dimension
parseUnitSymbol :: String -> Either String Dimension
parseUnitSymbol String
i = do {
    Unit
simpleUnit <- String -> Either String Unit
unitFromString String
i;
    Dimension -> Either String Dimension
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return [Unit -> Int -> UnitExp
UnitExp Unit
simpleUnit Int
1]
  } Either String Dimension
-> Either String Dimension -> Either String Dimension
forall a. Semigroup a => a -> a -> a
<> String -> Either String Dimension
derivedUnitFromString String
i

parseConversion :: Parser Dimension
parseConversion :: Parser Dimension
parseConversion = Token -> Parser ()
requireToken Token
OpenBracket Parser () -> Parser Dimension -> Parser Dimension
forall a b.
ParserT Identity a -> ParserT Identity b -> ParserT Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Dimension
parseDimension Parser Dimension -> Parser () -> Parser Dimension
forall a b.
ParserT Identity a -> ParserT Identity b -> ParserT Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token -> Parser ()
requireToken Token
CloseBracket

parseExprInParens :: Parser Expr
parseExprInParens :: Parser Expr
parseExprInParens = Token -> Parser ()
requireToken Token
OpenParen Parser () -> Parser Expr -> Parser Expr
forall a b.
ParserT Identity a -> ParserT Identity b -> ParserT Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Expr
parseExpr Parser Expr -> Parser () -> Parser Expr
forall a b.
ParserT Identity a -> ParserT Identity b -> ParserT Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token -> Parser ()
requireToken Token
CloseParen

parseUnaryOp :: Parser Op
parseUnaryOp :: Parser Op
parseUnaryOp = do
    String -> Parser ()
requireOperator String
"-"
    Op -> Parser Op
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Op
UnaryMinus

parseTermOp :: Parser Op
parseTermOp :: Parser Op
parseTermOp = do
    String
op <- Parser String
parseOperator
    case String
op of
      String
"+" -> Op -> Parser Op
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Op
Plus
      String
"-" -> Op -> Parser Op
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Op
Minus
      String
x   -> String -> Parser Op
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Op) -> String -> Parser Op
forall a b. (a -> b) -> a -> b
$ String
"Invalid binary operator " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

parseFactorOp :: Parser Op
parseFactorOp :: Parser Op
parseFactorOp = do
    String
op <- Parser String
parseOperator
    case String
op of
        String
"*" -> Op -> Parser Op
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Op
Mult
        String
"/" -> Op -> Parser Op
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Op
Div
        String
x   -> String -> Parser Op
forall a. String -> ParserT Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Op) -> String -> Parser Op
forall a b. (a -> b) -> a -> b
$ String
"Invalid binary operator " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x

parseExpr :: Parser Expr
parseExpr :: Parser Expr
parseExpr = do
    Expr
term <- Parser Expr
parseVarBindings;
    Expr -> Dimension -> Expr
Conversion Expr
term (Dimension -> Expr) -> Parser Dimension -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Dimension
parseConversion Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr -> Parser Expr
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
term


parseVarBindings :: Parser Expr
parseVarBindings :: Parser Expr
parseVarBindings = do {
    [(String, Expr)]
bs <- Parser (String, Expr) -> Token -> Parser [(String, Expr)]
forall a. Parser a -> Token -> Parser [a]
atLeastOne Parser (String, Expr)
parseVarBindingHead Token
Comma;
    Token -> Parser ()
requireToken Token
Arrow;
    Expr
expr <- Parser Expr
parseVarBindings;
    Expr -> Parser Expr
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ [(String, Expr)] -> Expr -> Expr
VarBindings [(String, Expr)]
bs Expr
expr
  } Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr
parseTerm

parseVarBindingHead :: Parser (String, Expr)
parseVarBindingHead :: Parser (String, Expr)
parseVarBindingHead = do {
    String
lhs <- Parser String
parseIdentifier;
    Token -> Parser ()
requireToken Token
Equal;
    Expr
rhs <- Parser Expr
parseTerm;
    (String, Expr) -> Parser (String, Expr)
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
lhs, Expr
rhs)
  }

parseTerm :: Parser Expr
parseTerm :: Parser Expr
parseTerm = Parser Expr
parseFactor Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
expr'
    where expr' :: Expr -> Parser Expr
expr' Expr
parsedLhs = do {
         (Op -> Expr -> Expr) -> Parser Op -> Parser Expr -> Parser Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Expr -> Op -> Expr -> Expr
BinOp Expr
parsedLhs) Parser Op
parseTermOp Parser Expr
parseFactor Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
expr'
    } Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr -> Parser Expr
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
parsedLhs

parseFactor :: Parser Expr
parseFactor :: Parser Expr
parseFactor = Parser Expr
parsePower Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
factor'
    where factor' :: Expr -> Parser Expr
factor' Expr
parsedLhs = do {
        (Op -> Expr -> Expr) -> Parser Op -> Parser Expr -> Parser Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Expr -> Op -> Expr -> Expr
BinOp Expr
parsedLhs) Parser Op
parseFactorOp Parser Expr
parsePower Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
factor'
    } Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Expr -> Op -> Expr -> Expr
BinOp Expr
parsedLhs Op
Mult (Expr -> Expr) -> Parser Expr -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Expr
parseExprInParens Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
factor') Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr -> Parser Expr
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
parsedLhs

parsePower :: Parser Expr
parsePower :: Parser Expr
parsePower = Parser Expr
parseUnary Parser Expr -> (Expr -> Parser Expr) -> Parser Expr
forall a b.
ParserT Identity a
-> (a -> ParserT Identity b) -> ParserT Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Expr -> Parser Expr
power'
    where power' :: Expr -> Parser Expr
power' Expr
parsedLhs = do {
        String -> Parser ()
requireOperator String
"^";
        Expr
parsedRhs <- Parser Expr
parseUnary;
        Expr -> Parser Expr
power' (Expr -> Parser Expr) -> Expr -> Parser Expr
forall a b. (a -> b) -> a -> b
$ Expr -> Op -> Expr -> Expr
BinOp Expr
parsedLhs Op
Pow Expr
parsedRhs
    } Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Expr -> Parser Expr
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Expr
parsedLhs

parseUnary :: Parser Expr
parseUnary :: Parser Expr
parseUnary = (Op -> Expr -> Expr) -> Parser Op -> Parser Expr -> Parser Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Op -> Expr -> Expr
UnaryOp Parser Op
parseUnaryOp Parser Expr
parsePrimary Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr
parsePrimary

parsePrimary :: Parser Expr
parsePrimary :: Parser Expr
parsePrimary = Parser Expr
parseExprInParens Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Expr
parseValue

parseValue :: Parser Expr
parseValue :: Parser Expr
parseValue = (Double -> Dimension -> Expr)
-> Parser Double -> Parser Dimension -> Parser Expr
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (EvalValue -> Expr
Val (EvalValue -> Expr)
-> (Double -> Dimension -> EvalValue)
-> Double
-> Dimension
-> Expr
forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.: Double -> Dimension -> EvalValue
forall u. Double -> u -> Value u
Value) Parser Double
parseNumber (Parser Dimension
parseDimension Parser Dimension -> Parser Dimension -> Parser Dimension
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Dimension -> Parser Dimension
forall a. a -> ParserT Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Dimension
multiplier Int
1)) Parser Expr -> Parser Expr -> Parser Expr
forall a.
ParserT Identity a -> ParserT Identity a -> ParserT Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Expr
Var (String -> Expr) -> Parser String -> Parser Expr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
parseIdentifier