git.iko.soy/elk
on ffe32c7 help sign in
elk/src/Transform/Declaration.hs
101 lines 3.0 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Declaration (toExpr) where
4import qualified AST.Declaration as D
5import qualified AST.Expression.General as E
6import qualified AST.Expression.Canonical as Canonical
7import qualified AST.Module as Module
8import qualified AST.Pattern as P
9import qualified AST.Type as T
10import qualified AST.Variable as Var
11import qualified Reporting.Annotation as A
14toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
15toExpr moduleName decls =
16 concatMap (toDefs moduleName) decls
19toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
20toDefs moduleName (A.A region decl) =
21 let typeVar = Var.fromModule moduleName
23 loc expr =
24 A.A region expr
25 in
26 case decl of
27 D.Definition def ->
28 [def]
30 D.Datatype name tvars constructors ->
31 concatMap toDefs' constructors
32 where
33 toDefs' (ctor, tipes) =
34 let vars = take (length tipes) infiniteArgs
35 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
36 body = loc . E.Data ctor $ map (loc . E.localVar) vars
37 in
38 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
40 D.TypeAlias name tvars tipe@(T.Record fields ext) ->
41 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
42 where
43 result =
44 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)
46 args =
47 map snd fields ++ maybe [] (:[]) ext
49 var = loc . E.localVar
50 vars = take (length args) infiniteArgs
52 efields =
53 zip (map fst fields) (map var vars)
55 record =
56 case ext of
57 Nothing ->
58 loc (E.Record efields)
60 Just _ ->
61 foldl (\r (f,v) -> loc (E.Insert r f v)) (var (last vars)) efields
63 -- Type aliases must be added to an extended equality dictionary,
64 -- but they do not require any basic constraints.
65 D.TypeAlias _ _ _ ->
66 []
68 D.Port (D.CanonicalPort impl) ->
69 let body = loc (E.Port impl)
70 in
71 case impl of
72 E.In name tipe ->
73 [ definition name body (T.portType tipe) ]
75 E.Out name _expr tipe ->
76 [ definition name body (T.portType tipe) ]
78 E.Task name _expr tipe ->
79 [ definition name body (T.portType tipe) ]
81 -- no constraints are needed for fixity declarations
82 D.Fixity _ _ _ ->
83 []
86infiniteArgs :: [String]
87infiniteArgs =
88 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
91buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
92buildFunction body@(A.A ann _) vars =
93 foldr
94 (\pattern expr -> A.A ann (E.Lambda pattern expr))
95 body
96 (map (A.A ann . P.Var) vars)
99definition :: String -> Canonical.Expr -> T.Canonical -> Canonical.Def
100definition name expr@(A.A ann _) tipe =
101 Canonical.Definition (A.A ann (P.Var name)) expr (Just tipe)