module Language.CalDims.Expression
( parseExpr
, parseName
, parseExistingName
, parseBindE
, parseEinh
, parseBind
, brackets
, parseNonRecursiveExpr
, parseColon
, parseComma
, flush) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Prim
import Text.ParserCombinators.Parsec.Expr
import Ratio ((%))
import Control.Monad.Error
import Control.Monad.State
import Control.Monad
import qualified Data.Map as Map
#ifdef DEBUG
import Debug.Trace
#endif
import Language.CalDims.Expr ()
import Language.CalDims.Types
import Language.CalDims.Action
import Language.CalDims.State as State
import Language.CalDims.Helpers
requireEntry :: Name -> MyParser StateEntry
requireEntry n = do
state <- getState
case Map.lookup n (getScope state) of
Nothing -> fail $ "No such object: " ++ pretty n
Just sth -> return sth
hnn, hasNotName :: Expr -> Name -> MyParser Bool
#ifdef DEBUG
hasNotName e n = do
res <- hnn e n
return $ trace (show e ++ " `hasNotName` " ++ show n ++ " -> " ++ show res) res
#else
hasNotName = hnn
#endif
(Bin _ e1 e2) `hnn` n = (e1 `hasNotName` n) #&&# (e2 `hasNotName` n)
(Uni _ e) `hnn` n = e `hasNotName` n
(ArgRef _) `hnn` _ = return True
(Call fn args) `hnn` n = do
e_ <- requireEntry fn
case e_ of
Function _ e -> (return (fn /= n)) #&&# (liftM and) (sequence (map (`hasNotName` n) args)) #&&# (e `hasNotName` n)
_ -> return True
(Evaled (_, Dims m)) `hnn` n = do
state <- getState
let exprs = Map.elems $ Map.mapMaybeWithKey (\k v -> if_
(k `Map.member` m)
(case v of Dimension e -> Just e; _ -> Nothing)
Nothing) (getScope state)
(return $ not (n `Map.member` m)) #&&# (liftM and) (sequence (map (`hasNotName` n) exprs))
flush :: GenParser Char State.State (IO(), State.State)
flush = do
many $ noneOf []
eof
s <- getState
return (return (), s)
binary :: String -> (Expr -> Expr -> Expr) -> Assoc -> Operator Char State.State Expr
binary s f assoc = Infix (do
string s
spaces
return f) assoc
parseExpr :: MyParser Expr
parseExpr = do
buildExpressionParser table factor
<?> "expression"
parseNonRecursiveExpr :: Name -> MyParser Expr
parseNonRecursiveExpr n = do
e <- parseExpr
t <- e `hasNotName` n
case t of
True -> return e
False -> fail "No recursion supported."
table :: OperatorTable Char State.State Expr
table = [
[Prefix (do
parseMinus
return $ Uni Negate)],
[binary "^" (Bin Exp) AssocRight],
[Postfix (do
d <- parseEinh
return $ mulMerge (Evaled (1, d)))],
[binary "~" (Bin LogBase) AssocLeft],
[binary "*" (Bin Mul) AssocLeft, binary "/" (Bin Div) AssocLeft],
[binary "+" (Bin Add) AssocLeft, binary "-" (Bin Sub) AssocLeft]
]
mulMerge :: Expr -> Expr -> Expr
mulMerge (Evaled (ra, da)) (Evaled (rb, db)) = Evaled (ra*rb, f da db) where
f a b = Dims $ Map.unionWith (+) (Map.filter (/=0) $ unDims a) (Map.filter (/=0) $ unDims b)
mulMerge e1 e2 = Bin Mul e1 e2
parseArgRef, factor, call :: MyParser Expr
factor = brackets parseExpr <|> number <|> try parseArgRef <|> call
call = (do
(n, e) <- parseExistingName
args <- option [] (brackets (parseExpr `sepBy` parseComma))
case e of
(Function _ _) -> test n args
(Builtin _ _) -> test n args
_ -> fail $ pretty n ++ " is not a function"
) <?> "function application"
where
test :: Name -> [Expr] -> MyParser Expr
test n args = do
state <- getState
case (runState $ runErrorT (do
args' <- mapM eval args
doCall n args')) state of
(Left e, _) -> fail e
(Right _, _) -> return (Call n args)
parseArgRef = (do
n' <- parseName
let n = unName n'
state <- getState
case constrArgRef 0 n (getArgs state) of
Left s -> fail s
Right e -> return e
) <?> "argument reference"
where
constrArgRef :: Int -> String -> Args -> Either String Expr
constrArgRef _ s [] = Left $ "no such argument in definition list: " ++ pretty s
constrArgRef i s (a:as)
| getArgName a == s = Right $ ArgRef (Arg s i (getArgType a))
| otherwise = constrArgRef (i+1) s as
parseEinh :: MyParser Dims
parseEinh = do
res <- many1 eh0
state <- getState
case (runState $ runErrorT (mergeDims res)) state of
(Left e, _) -> fail e
(Right dims, _) -> return dims
mergeDims :: [(Mon Dims -> Mon Dims)] -> Mon Dims
mergeDims [] = return noDims
mergeDims [a] = a (return noDims)
mergeDims (a:as) = a (mergeDims as)
eh0 :: MyParser (Mon Dims -> Mon Dims)
eh0 = try (do
op <- option (#*#) (do
spaces
char '/'
return (#/#))
spaces
r <- eh1
return ((flip op) (return r)))
eh1 :: MyParser Dims
eh1 = try (do spaces; char '('; spaces; r <- parseEinh ; spaces; char ')'; return r;) <|> (do
n <- eh2
option (Dims $ Map.singleton n 1) (do
spaces
char '^'
spaces
i <- fractOrInt
spaces
return $ Dims $ Map.singleton n i))
eh2 :: MyParser Name
eh2 = try (do
(name, entry) <- parseExistingName
case entry of
BasicDimension -> return name
Dimension _ -> return name
_ -> fail (pretty name ++ " is not a unit")
) <?> "unit name"
parseName :: MyParser Name
parseName = do
r1 <- letter
r2 <- many (oneOf "_'" <|> digit <|> letter)
spaces
return $ Name (r1:r2)
parseExistingName :: MyParser (Name, StateEntry)
parseExistingName = do
n <- parseName
e <- requireEntry n
return $! (n, e)
int :: MyParser Integer
int = do
o <- option ' ' $ char '-'
spaces
n <- many1 digit
spaces
return $ ((read $ o:n)::Integer)
number :: MyParser Expr
number = do
n <- (try fract) <|> real
spaces
return $ Evaled (n, noDims)
fractOrInt :: MyParser R
fractOrInt = (try fract) <|> intF
intF :: MyParser R
intF = do
spaces
r <- int
spaces
return (r % 1)
fract :: MyParser R
fract = do
spaces
r1 <- many1 digit
spaces
char '%'
spaces
r2 <- many1 digit
spaces
return $ ((read r1)::Integer)%((read r2)::Integer)
real :: MyParser R
real = do
r1 <- many1 digit
res <- option (fromInteger ((read r1)::Integer)) (do
char '.'
r2 <- many1 digit
spaces
let
rr1 = ((read r1)::Integer)
rr2 = ((read r2)::Integer)
l = 10^length r2
return $ (rr1 * l + rr2) % l)
res' <- option res (try (do
spaces
char 'e'
spaces
f <- option id (do {char '-'; return negate})
spaces
exp_ <- many1 digit
spaces
return (res * (10 ^^ f (read exp_ :: Integer)))))
return res'
<?> "real"
parseMinus, parseColon, parseBind, parseBindE, parseLB, parseRB, parseComma :: MyParser String
parseMinus = addSpace (string "-")
parseColon = addSpace (string ":")
parseBind = addSpace (string "=")
parseBindE = addSpace (string ":=")
parseLB = addSpace (string "(")
parseRB = addSpace (string ")")
parseComma = addSpace (string ",")
brackets, addSpace :: MyParser a -> MyParser a
brackets p = try (do
parseLB
r <- p
parseRB
return r)
addSpace a = do
r <- a
spaces
return r