git.iko.soy/elk
on 552becc help sign in
elk/src/Transform/Declaration.hs
182 lines 6.6 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 errorMessage kind name =
26 "Syntax Error: The type annotation for " ++ kind ++ " '" ++
27 name ++ "' must be directly above its definition."
29 exprCombineAnnotations =
30 Expr.crawlLet Def.combineAnnotations
32 go decls =
33 case decls of
34 -- simple cases, pass them through with no changes
35 [] ->
36 return []
38 D.Datatype name tvars ctors : rest ->
39 (:) (D.Datatype name tvars ctors) <$> go rest
41 D.TypeAlias name tvars alias : rest ->
42 (:) (D.TypeAlias name tvars alias) <$> go rest
44 D.Fixity assoc prec op : rest ->
45 (:) (D.Fixity assoc prec op) <$> go rest
47 -- combine definitions
48 D.Definition def : defRest ->
49 case def of
50 Source.Definition pat expr ->
51 do expr' <- exprCombineAnnotations expr
52 let def' = Valid.Definition pat expr' Nothing
53 (:) (D.Definition def') <$> go defRest
55 Source.TypeAnnotation name tipe ->
56 case defRest of
57 D.Definition (Source.Definition pat@(P.Var name') expr) : rest
58 | name == name' ->
59 do expr' <- exprCombineAnnotations expr
60 let def' = Valid.Definition pat expr' (Just tipe)
61 (:) (D.Definition def') <$> go rest
63 _ -> Left (errorMessage "value" name)
65 -- combine wires
66 D.Wire wire : wireRest ->
67 case wire of
68 D.InputAnnotation name tipe ->
69 (:) (D.Wire (D.Input name tipe)) <$> go wireRest
71 D.OutputDefinition name _ ->
72 Left (errorMessage "foreign output" name)
74 D.OutputAnnotation name tipe ->
75 case wireRest of
76 D.Wire (D.OutputDefinition name' expr) : rest | name == name' ->
77 do expr' <- exprCombineAnnotations expr
78 (:) (D.Wire (D.Output name expr' tipe)) <$> go rest
80 _ ->
81 Left (errorMessage "foreign output" name)
83 D.LoopbackDefinition name _tipe ->
84 Left (errorMessage "input" name)
86 D.LoopbackAnnotation name tipe ->
87 case wireRest of
88 D.Wire (D.LoopbackDefinition name' expr) : rest | name == name' ->
89 do expr' <- exprCombineAnnotations expr
90 let loop = D.ValidLoopback name (Just expr') tipe
91 (:) (D.Wire (D.Loopback loop)) <$> go rest
93 _ ->
94 do let loop = D.ValidLoopback name Nothing tipe
95 (:) (D.Wire (D.Loopback loop)) <$> go wireRest
98toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
99toExpr moduleName =
100 concatMap (toDefs moduleName)
103toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
104toDefs moduleName decl =
105 let typeVar = Var.Canonical (Var.Module moduleName) in
106 case decl of
107 D.Definition def ->
108 [def]
110 D.Datatype name tvars constructors ->
111 concatMap toDefs' constructors
112 where
113 toDefs' (ctor, tipes) =
114 let vars = take (length tipes) arguments
115 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
116 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
117 in
118 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
120 D.TypeAlias name tvars tipe@(T.Record fields ext) ->
121 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
122 where
123 result =
124 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) tipe
126 args =
127 map snd fields ++ maybe [] (:[]) ext
129 var = A.none . E.localVar
130 vars = take (length args) arguments
132 efields = zip (map fst fields) (map var vars)
133 record =
134 case ext of
135 Nothing -> A.none $ E.Record efields
136 Just _ ->
137 foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
139 -- Type aliases must be added to an extended equality dictionary,
140 -- but they do not require any basic constraints.
141 D.TypeAlias _ _ _ ->
142 []
144 D.Wire wire ->
145 case wire of
146 D.Output name expr@(A.A s _) tipe ->
147 [ definition name (A.A s $ E.Output name tipe expr) tipe ]
149 D.Input name tipe ->
150 [ definition name (A.none $ E.Input name tipe) tipe ]
152 D.Loopback input ->
153 case input of
154 D.Address name tipe ->
155 [ definition name (A.none $ E.LoopbackIn name E.Address) tipe ]
157 D.Promise name promiseType expr resultType ->
158 let dummyName =
159 "$" ++ name ++ "$effect"
160 in
161 [ definition name (A.none $ E.LoopbackIn name E.PromiseStream) resultType
162 , definition dummyName (A.none $ E.LoopbackOut name expr) promiseType
163 ]
165 -- no constraints are needed for fixity declarations
166 D.Fixity _ _ _ ->
167 []
170arguments :: [String]
171arguments =
172 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
175buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
176buildFunction body@(A.A s _) vars =
177 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
180definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
181definition name expr tipe =
182 Canonical.Definition (P.Var name) expr (Just tipe)