module Language.Noodle.Evaluation
( compile
, compileFile
, compute
, declare
, extfun
, extop
, extenv
, extmod
, showAst
, rtError
, srtError
, Error(BadParse)
, Env(..)
, Name
, Val(..)) where
import System.FilePath
import Data.Unique
import Data.Maybe
import Data.Ratio
import Data.Dynamic
import Language.Noodle.Syntax
import Language.Noodle.Parsing.String
import Language.Noodle.Parsing.Noodle
import Language.Noodle.DepTree
instance Show Val where
show (Function _) = "<function>"
show (Error e) = show e
show (Number i) = let n = numerator i
d = denominator i
in if (d == 1)
then show n
else show n ++ "/" ++ show d
show (Module _) = "<module>"
show (Symbol s) = s
show (Str s) = show s
show (Thunk _) = "<Thunk (this should never be reachable)>"
show (Prod v1 v2) = "(" ++ show v1 ++ "," ++ subprod v2 ++ ")" where
subprod (Prod v v2) = show v ++ "," ++ subprod v2
subprod v = show v
show (Extern _) = "<haskell value>"
show (Abst _ _) = "<abstract>"
show (Nil) = "nil"
type Name = String
data Val
= Function (Val -> IO Val)
| Thunk (IO Val)
| Module (IO Env)
| Error Error
| Number Rational
| Symbol String
| Str String
| Prod Val Val
| Extern Dynamic
| Abst (Maybe Unique) Val
| Nil
data Error
= RtErr Val
| ErrAt String Error
| HeadMatch
| MDMod
| MDDiffForm
| NotDef String
| WithNoMod
| ModRefFail String
| DepLoadFail String String
| PatFail Pattern
| BadParse String Int Int String
instance Show Error where
show (ErrAt s e) = " in " ++ s ++ ":\n" ++ show e
show (RtErr v) = " " ++ show v
show (HeadMatch) =
" non-exhaustive pattern match in declaration head"
show (MDMod) =
" you can only declare a module once"
show (MDDiffForm) =
" mult-declarations must all have the same form"
show (NotDef n) =
" referenced undefined identifier '" ++ n ++ "'"
show (WithNoMod) =
" with clause used with non-module value"
show (ModRefFail n) =
" module reference '" ++ n ++ "' applied to non-module value"
show (DepLoadFail dep reason) =
" dependency '" ++ dep ++ "' failed to load with reason:\n" ++
" " ++ reason
show (PatFail p) =
" pattern '" ++ show p ++ "' failed to match right had side of clause"
show (BadParse input line pos message) =
" parse error on line " ++ show line ++ ":\n" ++
" " ++ getline line (lines input) ++ " - " ++ message ++ "\n" ++
" " ++ pointer pos ++ "\n\n"
where
getline 1 (l:ls) = l
getline n (l:ls) = getline (n1) ls
pointer 1 = "^"
pointer n = " " ++ pointer (n1)
rtError :: Val -> Val
rtError v = Error $ RtErr v
srtError s = rtError $ Str s
hmError :: Val
hmError = Error HeadMatch
errAt :: String -> Error -> Val
errAt s e = Error $ ErrAt s e
unwindErr :: Error -> Error
unwindErr (ErrAt n e) = unwindErr e
unwindErr other = other
instance Eq Val where
(Number i1) == (Number i2) = i1 == i2
(Symbol s1) == (Symbol s2) = s1 == s2
(Str s1) == (Str s2) = s1 == s2
(Nil) == (Nil) = True
(Prod v11 v12) == (Prod v21 v22) = (v11 == v21) && (v12 == v22)
_ == _ = False
data Env
= Env Unique Env [(Name, Val)]
| Bar Env
| Top
instance Eq Env where
e == e2 = True
nlookup :: Env -> Name -> Val
nlookup Top n = Error $ NotDef n
nlookup (Env _ next table) n
= case lookup n table of
Just v -> v
Nothing -> nlookup next n
nlookup (Bar e) n = nlookup e n
funbuild :: String -> Env -> Pattern -> (Env -> IO Val) -> Val
funbuild n e p f = Function (\v -> do menv <- match e p v
case menv of
Just e2 -> f e2
Nothing -> return $ errAt n HeadMatch)
extfun :: (Val -> IO Val) -> Val
extop :: (Val -> Val -> IO Val) -> Val
extfun f = Function f
extop f = Function (\v -> return $ Function (\v2 -> f v v2))
extenv :: [(String,Val)] -> Env
extenv ds = Bar $ Env undefined Top ds
extmod :: Env -> Val
extmod e = Module $ return e
declare :: Env -> Decls -> IO (Either String Env)
declare e (Decls ds) =
do u <- newUnique
let fds = (sanity $ composeDecs $ makeblock e u
(case fds of
Left s -> [("error",srtError s)]
Right vds -> vds)
ds )
in case fds of
Right declist -> return $ Right $ Bar $ Env u e declist
Left s -> return $ Left s
where
sanity [] = Right []
sanity ((_,Error err):_) = Left (show err)
sanity (d:ds) = case sanity ds of
Left s -> Left s
Right dds -> Right (d:ds)
makeblock e u vds ds = declist where
thisEnv = Env u e vds
declist = map declare' ds
declare' (IntThunk n c)
= (n, Thunk ( do r <- compute thisEnv c
return $ case r of
Error err -> errAt n err
v -> v))
declare' (IntFun p n c)
= (n, funbuild n thisEnv p
(\newenv -> do r <- compute newenv c
return $ case r of
Error err -> errAt n err
v -> v))
declare' (IntMod n modecls)
= (n,Module $ (do eenv <- declare thisEnv modecls
case eenv of
Left s -> fail $
" in module '" ++ n ++ "':\n " ++ s
Right e -> return e))
declare' (IntOp p1 n p2 c)
= (n, funbuild n thisEnv p2
(\newenv -> return $ funbuild n newenv p1
(\nnenv -> do r <- compute nnenv c
return $ case r of
Error err -> errAt n err
v -> v)))
composeDecs :: [(String,Val)] -> [(String,Val)]
composeDecs [] = []
composeDecs [d] = [d]
composeDecs (cur@(name,val1):rest)
= let restc = composeDecs rest
matchesMe = lookup name restc
restcSans = filter (\(n,_) -> n /= name) restc
in case matchesMe of
Nothing -> cur:restc
Just val2 -> (name,composeDecVals val1 val2):restcSans
composeDecVals (Thunk a1) (Thunk a2) = Thunk $
do firstVal <- a1
case firstVal of
Error e -> let err = unwindErr e
in case err of
RtErr _ -> a2
_ -> return firstVal
_ -> return firstVal
composeDecVals (Function f1) (Function f2) = Function $
\arg ->
do firstVal <- f1 arg
case firstVal of
Error e -> let err = unwindErr e
in case err of
HeadMatch -> f2 arg
_ -> return firstVal
_ -> return firstVal
composeDecVals (Module _) (Module _) = Error MDMod
composeDecVals (Error e) _ = Error e
composeDecVals _ (Error e) = Error e
composeDecVals _ _ = Error MDDiffForm
match :: Env -> Pattern -> Val -> IO (Maybe Env)
match e (Pat (Ident s)) v
= case e of
(Env u _ _) -> return $ Just $ Env u e [(s,v)]
(Bar e2) -> do u <- newUnique
return $ Just $ Env u e2 [(s,v)]
(Top) -> do u <- newUnique
return $ Just $ Env u e [(s,v)]
match e (Pat (Numb i)) (Number r)
= return $ if (toRational i) == r
then Just e
else Nothing
match e (Pat (Symb s)) (Symbol s2)
= return $ if s == s2
then Just e
else Nothing
match e (Pat (StrLit s)) (Str s2)
= return $ if s == s2
then Just e
else Nothing
match e@(Env u _ _) (Pat (Abs p)) (Abst mu v)
= case mu of
Nothing -> return Nothing
Just u2 ->
if u == u2
then match e p v
else return $ Nothing
match e (Pat (ProdLit p1 p2 [])) (Prod v1 v2)
= do menva <- match e p1 v1
menvb <- match e p2 v2
case (menva,menvb) of
(Just e,Just (Env u _ ds)) -> return $ Just (Env u e ds)
(Nothing,_) -> return Nothing
(_,Nothing) -> return Nothing
match e (Pat (ProdLit p1 p2 ps)) (Prod v1 v2)
= do if length vals /= length pats
then return Nothing
else do menvs <- sequence $ zipWith (match e) pats vals
if Nothing `elem` menvs
then return Nothing
else let envs = map fromJust menvs
in return $ Just $ foldr foldenv e envs
where foldenv e (Env u _ ds) = (Env u e ds)
foldenv e (Bar _) = e
foldenv e Top = e
pats = p1:p2:ps
vals = v1 : unprod v2
unprod (Prod vv vvs) = vv : unprod vvs
match e (Pat (Paren p)) v
= match e p v
match _ _ _ = return Nothing
compute :: Env -> Comp -> IO Val
compute e (In ds c)
= do eenv <- declare e ds
case eenv of
Left s -> return $ srtError s
Right env -> compute env c
compute e (With cm c) =
do v <- compute e cm
case v of
(Module doenv) ->
do env <- doenv
compute (case env of
(Bar (Env u _ ds)) -> (Bar (Env u e ds))
(Top) -> error "Module should never reference TOP (bug)"
(Env u _ ds) -> (Bar (Env u e ds))) c
Error err -> return $ Error err
other -> return $ Error WithNoMod
compute e (PatMatch p c1 c2)
= do c1v <- compute e c1
menv <- match e p c1v
case menv of
Just e2 -> compute e2 c2
Nothing -> return $ Error $ PatFail p
compute e (Handler handler c2)
= do val <- compute e c2
case val of
Error err -> handle err handler val
_ -> return val
where
handle (ErrAt _ err) handler val = handle err handler val
handle (RtErr v) handler val
= do hval <- compute e handler
case hval of
(Function f) -> f v
_ -> return hval
handle _ _ val = return val
compute e (ExprComp ex)
= eval e ex
eval :: Env -> Expr -> IO Val
eval e (ExprApp e1 e2)
= do arg <- eval e e1
case arg of
Error s -> return $ Error s
_ ->
do fun <- eval e e2
case fun of
Function f -> f arg
other -> return fun
eval e (ExprOp e1 o e2)
= case nlookup e o of
Error err -> return $ Error err
Function f ->
do v1 <- eval e e1
case v1 of
Error err -> return $ Error err
_ ->
do vf <- f v1
case vf of
Error err -> return $ Error err
Function f2 ->
do v2 <- eval e e2
case v2 of
Error err -> return $ Error err
_ -> f2 v2
notfunction -> return vf
other ->
do _ <- eval e e1
return other
eval e (Lit l) = expand e l
eval e (ModRef s) = return $ extfun mref where
mref (Module doenv) = do env <- doenv
case nlookup env s of
Thunk io -> io
other -> return other
mref _ = return $ Error $ ModRefFail s
expand :: Env -> Literal Comp -> IO Val
expand e (Numb i) = return $ Number (i % 1)
expand e (Ident s) = case nlookup e s of
(Thunk io) -> io
other -> return other
expand e (Symb s) = return $ Symbol s
expand e (StrLit s) = return $ Str s
expand e (ProdLit c1 c2 (c:cs))
= do v <- compute e c1
rest <- expand e (ProdLit c2 c cs)
return $ Prod v rest
expand e (Abs c)
= do v <- compute e c
case e of
(Env u _ _) -> return $ Abst (Just u) v
(Bar _) -> return $ Abst Nothing v
(Top) -> return $ Abst Nothing v
expand e (ProdLit c1 c2 [])
= do v1 <- compute e c1
v2 <- compute e c2
case (v1,v2) of
(Error s,_) -> return $ Error s
(_,Error s) -> return $ Error s
_ -> return $ Prod v1 v2
expand e (Paren c) = compute e c
modl :: NParser Decls
modl = do m <- topDecls
notcode
inputEnd
return m
compileFile :: Env -> FilePath -> IO Val
compileFile e fp
= do eSf <- parseDeps [] fp
case eSf of
Left s -> return $ srtError s
Right src -> compileFile' e src
compileFile' :: Env -> SourceFile -> IO Val
compileFile' e src
= do let name = srcName src
dir = srcDir src
body = srcBody src
deps = srcDeps src
mods <- mapM (compileFile' e) deps
eenvs <- valsToEnvs mods
case eenvs of
Left s -> return $ Error $ DepLoadFail name s
Right envs -> do let newenv = squashEnvs (reverse (e:envs))
prog = compile newenv body
case prog of
Error err -> return $ errAt ("file " ++ name) err
v -> return v
where
squashEnvs [] = Top
squashEnvs (Env u _ ds:es) = Bar $ Env u (squashEnvs es) ds
squashEnvs (Bar e:es) = squashEnvs (e:es)
squashEnvs (Top:es) = squashEnvs es
valsToEnvs :: [Val] -> IO (Either String [Env])
valsToEnvs [] = return $ Right $ []
valsToEnvs (v:vs)
= case v of
Error err -> return $ Left $ "this shouldnt happen: " ++ (show err)
Module ioe ->
do e <- ioe
ees <- valsToEnvs vs
case ees of
Left s -> return $ Left s
Right es -> return $ Right (e:es)
_ -> return $ Left $
"somehow one of the dependencies in '" ++ (srcName src) ++
"' resolved to something other than a module (bug)"
compile :: Env -> String -> Val
compile e input
= case parsed of
Failure s ((_,rel,line),_) -> Error $ BadParse input line rel s
Success res _ _ ->
Module $ do eenv <- declare e res
case eenv of
Left s -> error s
Right env -> return env
where
parsed = runp modl (startPos,()) input
showAst :: String -> String
showAst input
= case parsed of
Failure s _ -> s
Success res _ _ ->
case res of
Left p -> show p
Right m -> show m
where
parsed = runp (pEither comp modl) (startPos,()) input