@@ -0,0 +1,97 @@
1+module Idris.Compiler where
9+import Control.Monad.State
11+import Epic.Epic hiding (Term, Type, Name, fn, compile)
12+import qualified Epic.Epic as E
14+compile :: FilePath -> Idris ()
15+compile f = do ds <- mkDecls
16+ lift $ E.compile (mkProgram ds) f
18+mkDecls :: Idris [EpicDecl]
19+mkDecls = do i <- getIState
20+ decls <- mapM build (toAlist (tt_ctxt i))
21+ return $ basic_defs ++ EpicFn (name "main") epicMain : decls
23+ename x = name ("idris_" ++ show x)
24+aname x = name ("a_" ++ show x)
26+epicMain = ref (ename (UN ["main"]))
29+ epic :: a -> Idris E.Term
31+build :: (Name, Def) -> Idris EpicDecl
32+build (n, d) = do i <- getIState
33+ case lookup n (idris_prims i) of
34+ Just opDef -> return $ EpicFn (ename n) opDef
35+ _ -> do def <- epic d
36+ return $ EpicFn (ename n) def
38+impossible = int 42424242
40+instance ToEpic Def where
41+ epic (Function (Fun _ _ tm _)) = epic tm
42+ epic (CaseOp _ pats args sc) = epic (args, sc) -- TODO: redo case comp after optimising
43+ epic _ = return impossible
45+instance ToEpic (TT Name) where
46+ epic tm = epic' [] tm where
47+ epic' env tm@(App f a)
48+ | (P _ (UN ["mkForeign"]) _, args) <- unApply tm
50+ epic' env (P _ n _) = return $ ref (ename n)
51+ epic' env (Bind n (Lam _) sc)
52+ = do sc' <- epic' (aname n : env) sc
53+ return $ term ([aname n], sc')
54+ epic' env (Bind _ _ _) = return impossible
55+ epic' env (App f a) = do liftM2 (@@) (epic' env f) (epic' env a)
56+ epic' env (Constant c) = epic c
57+ epic' env (Set _) = return impossible
59+doForeign :: [TT Name] -> Idris E.Term
60+doForeign (_ : fgn : args)
61+ | (_, (Constant (Str fgnName) : fgnArgTys : P _ (UN [ret]) _ : [])) <- unApply fgn
62+ = let tys = getFTypes fgnArgTys
64+ 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
67+ | otherwise = fail "Badly formed foreign function call"
69+getFTypes :: TT Name -> [E.Type]
70+getFTypes tm = case unApply tm of
72+ (cons, [a, (P _ (UN [ty]) _), xs]) ->
73+ let rest = getFTypes xs in
77+mkEty "FFloat" = tyFloat
78+mkEty "FChar" = tyChar
79+mkEty "FString" = tyString
81+mkEty "FUnit" = tyUnit
83+instance ToEpic Const where
84+ epic (I i) = return (int i)
85+-- epic (Fl f) = return (float f)
86+ epic (Str s) = return (str s)
87+ epic (Ch c) = return (char c)
88+ epic _ = return impossible
90+instance ToEpic ([Name], SC) where
91+ epic (args, tree) = do tree' <- epic tree
92+ return $ term (map ename args, tree')
94+instance ToEpic SC where
95+ epic (STerm t) = epic t
96+ epic (Case n alts) = return $ case_ (ref (ename n)) undefined