git.iko.soy/elk
on 914e047 help sign in
elk/src/Transform/Declaration.hs
129 lines 5.0 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 = go
23 where
24 msg x = "Syntax Error: The type annotation for '" ++ x ++
25 "' must be directly above its definition."
27 exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
29 go decls =
30 case decls of
31 -- simple cases, pass them through with no changes
32 [] -> return []
34 D.Datatype name tvars ctors : rest ->
35 (:) (D.Datatype name tvars ctors) <$> go rest
37 D.TypeAlias name tvars alias : rest ->
38 (:) (D.TypeAlias name tvars alias) <$> go rest
40 D.Fixity assoc prec op : rest ->
41 (:) (D.Fixity assoc prec op) <$> go rest
43 -- combine definitions
44 D.Definition def : defRest ->
45 case def of
46 Source.Definition pat expr ->
47 do expr' <- exprCombineAnnotations expr
48 let def' = Valid.Definition pat expr' Nothing
49 (:) (D.Definition def') <$> go defRest
51 Source.TypeAnnotation name tipe ->
52 case defRest of
53 D.Definition (Source.Definition pat@(P.Var name') expr) : rest
54 | name == name' ->
55 do expr' <- exprCombineAnnotations expr
56 let def' = Valid.Definition pat expr' (Just tipe)
57 (:) (D.Definition def') <$> go rest
59 _ -> Left (msg name)
61 -- combine ports
62 D.Port port : portRest ->
63 case port of
64 D.PPDef name _ -> Left (msg name)
65 D.PPAnnotation name tipe ->
66 case portRest of
67 D.Port (D.PPDef name' expr) : rest | name == name' ->
68 do expr' <- exprCombineAnnotations expr
69 (:) (D.Port (D.Out name expr' tipe)) <$> go rest
71 _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
74toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]
75toExpr moduleName = concatMap (toDefs moduleName)
77toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def]
78toDefs moduleName decl =
79 let typeVar = Var.Canonical (Var.Module moduleName) in
80 case decl of
81 D.Definition def -> [def]
83 D.Datatype name tvars constructors -> concatMap toDefs' constructors
84 where
85 toDefs' (ctor, tipes) =
86 let vars = take (length tipes) arguments
87 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
88 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
89 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
91 D.TypeAlias name _ tipe@(T.Record fields ext) ->
92 [ definition name (buildFunction record vars) (foldr T.Lambda result args) ]
93 where
94 result = T.Aliased (typeVar name) tipe
96 args = map snd fields ++ maybe [] (:[]) ext
98 var = A.none . E.localVar
99 vars = take (length args) arguments
101 efields = zip (map fst fields) (map var vars)
102 record = case ext of
103 Nothing -> A.none $ E.Record efields
104 Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
106 -- Type aliases must be added to an extended equality dictionary,
107 -- but they do not require any basic constraints.
108 D.TypeAlias _ _ _ -> []
110 D.Port port ->
111 case port of
112 D.Out name expr@(A.A s _) tipe ->
113 [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
114 D.In name tipe ->
115 [ definition name (A.none $ E.PortIn name tipe) tipe ]
117 -- no constraints are needed for fixity declarations
118 D.Fixity _ _ _ -> []
121arguments :: [String]
122arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
124buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
125buildFunction body@(A.A s _) vars =
126 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
128definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
129definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)