git.iko.soy/elk
on 5cf1074 help sign in
elk/src/Transform/Declaration.hs
144 lines 4.8 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 D.Port name tipe : rest ->
48 (:) (D.Port name tipe) <$> go rest
50 D.Perform line expr : rest ->
51 do expr' <- exprCombineAnnotations expr
52 (:) (D.Perform line expr') <$> go rest
54 -- combine definitions
55 D.Definition def : defRest ->
56 case def of
57 Source.Definition pat expr ->
58 do expr' <- exprCombineAnnotations expr
59 let def' = Valid.Definition pat expr' Nothing
60 (:) (D.Definition def') <$> go defRest
62 Source.TypeAnnotation name tipe ->
63 case defRest of
64 D.Definition (Source.Definition pat@(P.Var name') expr) : rest
65 | name == name' ->
66 do expr' <- exprCombineAnnotations expr
67 let def' = Valid.Definition pat expr' (Just tipe)
68 (:) (D.Definition def') <$> go rest
70 _ -> Left (errorMessage "value" name)
73toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
74toExpr moduleName =
75 concatMap (toDefs moduleName)
78toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
79toDefs moduleName decl =
80 let typeVar = Var.Canonical (Var.Module moduleName) in
81 case decl of
82 D.Definition def ->
83 [def]
85 D.Datatype name tvars constructors ->
86 concatMap toDefs' constructors
87 where
88 toDefs' (ctor, tipes) =
89 let vars = take (length tipes) arguments
90 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
91 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
92 in
93 [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
95 D.TypeAlias name tvars tipe@(T.Record fields ext) ->
96 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
97 where
98 result =
99 T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) tipe
101 args =
102 map snd fields ++ maybe [] (:[]) ext
104 var = A.none . E.localVar
105 vars = take (length args) arguments
107 efields = zip (map fst fields) (map var vars)
108 record =
109 case ext of
110 Nothing -> A.none $ E.Record efields
111 Just _ ->
112 foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
114 -- Type aliases must be added to an extended equality dictionary,
115 -- but they do not require any basic constraints.
116 D.TypeAlias _ _ _ ->
117 []
119 D.Port name tipe ->
120 [ definition name (A.none $ E.Port name (T.direction tipe)) (T.tipe tipe) ]
122 D.Perform line expr ->
123 let name = Var.toEffectName line
124 in
125 [ Canonical.Definition (P.Var name) (A.none $ E.Perform expr) Nothing ]
127 -- no constraints are needed for fixity declarations
128 D.Fixity _ _ _ ->
129 []
132arguments :: [String]
133arguments =
134 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
137buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
138buildFunction body@(A.A s _) vars =
139 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
142definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
143definition name expr tipe =
144 Canonical.Definition (P.Var name) expr (Just tipe)