git.iko.soy/elk
on 5e77639 help sign in
elk/src/Transform/Declaration.hs
149 lines 5.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Transform.Declaration (combineAnnotations, toExpr) where
4import Control.Applicative ((<$>))
6import qualified AST.Annotation as A
7import qualified AST.Declaration as D
8import qualified AST.Expression.General as E
9import qualified AST.Expression.Source as Source
10import qualified AST.Expression.Valid as Valid
11import qualified AST.Expression.Canonical as Canonical
12import qualified AST.Module as Module
13import qualified AST.Pattern as P
14import qualified AST.Type as T
15import qualified AST.Variable as Var
17import qualified Transform.Expression as Expr
18import qualified Transform.Definition as Def
21combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]
22combineAnnotations =
23 go
24 where
25 msg x = "Syntax Error: The type annotation for '" ++ x ++
26 "' must be directly above its definition."
28 exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
30 go decls =
31 case decls of
32 -- simple cases, pass them through with no changes
33 [] -> return []
35 D.Datatype name tvars ctors : rest ->
36 (:) (D.Datatype name tvars ctors) <$> go rest
38 D.TypeAlias name tvars alias : rest ->
39 (:) (D.TypeAlias name tvars alias) <$> go rest
41 D.Fixity assoc prec op : rest ->
42 (:) (D.Fixity assoc prec op) <$> go rest
44 -- combine definitions
45 D.Definition def : defRest ->
46 case def of
47 Source.Definition pat expr ->
48 do expr' <- exprCombineAnnotations expr
49 let def' = Valid.Definition pat expr' Nothing
50 (:) (D.Definition def') <$> go defRest
52 Source.TypeAnnotation name tipe ->
53 case defRest of
54 D.Definition (Source.Definition pat@(P.Var name') expr) : rest
55 | name == name' ->
56 do expr' <- exprCombineAnnotations expr
57 let def' = Valid.Definition pat expr' (Just tipe)
58 (:) (D.Definition def') <$> go rest
60 _ -> Left (msg name)
62 -- combine ports
63 D.Port port : portRest ->
64 case port of
65 D.InputAnnotation name tipe ->
66 (:) (D.Port (D.In name tipe)) <$> go portRest
68 D.OutputDef name _ ->
69 Left (msg name)
71 D.OutputAnnotation name tipe ->
72 case portRest of
73 D.Port (D.OutputDef name' expr) : rest | name == name' ->
74 do expr' <- exprCombineAnnotations expr
75 (:) (D.Port (D.Out name expr' tipe)) <$> go rest
77 _ ->
78 Left (msg name)
81toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
82toExpr moduleName =
83 concatMap (toDefs moduleName)
86toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
87toDefs moduleName decl =
88 let typeVar = Var.Canonical (Var.Module moduleName) in
89 case decl of
90 D.Definition def ->
91 [def]
93 D.Datatype name tvars constructors ->
94 concatMap toDefs' constructors
95 where
96 toDefs' (ctor, tipes) =
97 let vars = take (length tipes) arguments
98 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
99 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
100 in
101 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
103 D.TypeAlias name _ tipe@(T.Record fields ext) ->
104 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
105 where
106 result = T.Aliased (typeVar name) tipe
108 args = map snd fields ++ maybe [] (:[]) ext
110 var = A.none . E.localVar
111 vars = take (length args) arguments
113 efields = zip (map fst fields) (map var vars)
114 record =
115 case ext of
116 Nothing -> A.none $ E.Record efields
117 Just _ ->
118 foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
120 -- Type aliases must be added to an extended equality dictionary,
121 -- but they do not require any basic constraints.
122 D.TypeAlias _ _ _ ->
123 []
125 D.Port port ->
126 case port of
127 D.Out name expr@(A.A s _) tipe ->
128 [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
129 D.In name tipe ->
130 [ definition name (A.none $ E.PortIn name tipe) tipe ]
132 -- no constraints are needed for fixity declarations
133 D.Fixity _ _ _ ->
134 []
137arguments :: [String]
138arguments =
139 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
142buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
143buildFunction body@(A.A s _) vars =
144 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
147definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
148definition name expr tipe =
149 Canonical.Definition (P.Var name) expr (Just tipe)