@@ -1,3 +1,5 @@
1+{-# LANGUAGE PatternGuards #-}
2+
13module Idris.Compiler where
24
35import Idris.AbsSyntax
@@ -13,7 +15,7 @@ import qualified Epic.Epic as E
1315
1416compile :: FilePath -> Idris ()
1517compile f = do ds <- mkDecls
16− lift $ E.compile (mkProgram ds) f
18+ lift $ compileWith [Debug] (mkProgram ds) f
1719
1820mkDecls :: Idris [EpicDecl]
1921mkDecls = do i <- getIState
@@ -47,12 +49,18 @@ instance ToEpic (TT Name) where
4749 epic' env tm@(App f a)
4850 | (P _ (UN ["mkForeign"]) _, args) <- unApply tm
4951 = doForeign args
52+ epic' env (P (DCon t a) n _) = return $ con_ t
53+ epic' env (P (TCon _) _ _) = return impossible
5054 epic' env (P _ n _) = return $ ref (ename n)
55+ epic' env (V i) = return $ ref (env!!i)
5156 epic' env (Bind n (Lam _) sc)
5257 = do sc' <- epic' (aname n : env) sc
5358 return $ term ([aname n], sc')
5459 epic' env (Bind _ _ _) = return impossible
55− epic' env (App f a) = do liftM2 (@@) (epic' env f) (epic' env a)
60+ epic' env (App f a) = do f' <- epic' env f
61+ a' <- epic' env a
62+ logLvl 3 $ "Compiled " ++ show f ++ " @@ " ++ show a
63+ return (f' @@ a')
5664 epic' env (Constant c) = epic c
5765 epic' env (Set _) = return impossible
5866
@@ -62,8 +70,7 @@ doForeign (_ : fgn : args)
6270 = let tys = getFTypes fgnArgTys
6371 rty = mkEty ret in
6472 do args' <- mapM epic args
65− return $ foreign_ rty fgnName (zip args' tys)
66−-- fail $ "Got to " ++ fgnName ++ show (length args) ++ show tys ++ show rty
73+ return $ con_ 0 @@ impossible @@ foreign_ rty fgnName (zip args' tys)
6774 | otherwise = fail "Badly formed foreign function call"
6875
6976getFTypes :: TT Name -> [E.Type]
@@ -82,16 +89,28 @@ mkEty "FUnit" = tyUnit
8289
8390instance ToEpic Const where
8491 epic (I i) = return (int i)
85−-- epic (Fl f) = return (float f)
92+ epic (Fl f) = return (float f)
8693 epic (Str s) = return (str s)
8794 epic (Ch c) = return (char c)
8895 epic _ = return impossible
8996
9097instance ToEpic ([Name], SC) where
91− epic (args, tree) = do tree' <- epic tree
98+ epic (args, tree) = do logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
99+ tree' <- epic tree
92100 return $ term (map ename args, tree')
93101
94102instance ToEpic SC where
95103 epic (STerm t) = epic t
96− epic (Case n alts) = return $ case_ (ref (ename n)) undefined
104+ epic (UnmatchedCase str) = return $ error_ str
105+ epic (Case n alts) = do alts' <- mapM mkEpicAlt alts
106+ return $ case_ (ref (ename n)) alts'
107+ where
108+ mkEpicAlt (ConCase n t args rhs) = do rhs' <- epic rhs
109+ return $ con t (map ename args, rhs')
110+ mkEpicAlt (ConstCase (I i) rhs) = do rhs' <- epic rhs
111+ return $ constcase i rhs'
112+ mkEpicAlt (ConstCase _ rhs) = fail "Can only pattern match on integer constants"
113+ mkEpicAlt (DefaultCase rhs) = do rhs' <- epic rhs
114+ return $ defaultcase rhs'
115+
97116