git.iko.soy/elk
on dfdf96d help sign in
elk/compiler/Transform/Declaration.hs
126 lines 4.9 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.Pattern as P
13import qualified AST.Type as T
14import qualified AST.Variable as Var
16import qualified Transform.Expression as Expr
17import qualified Transform.Definition as Def
20combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]
21combineAnnotations = go
22 where
23 msg x = "Syntax Error: The type annotation for '" ++ x ++
24 "' must be directly above its definition."
26 exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations
28 go decls =
29 case decls of
30 -- simple cases, pass them through with no changes
31 [] -> return []
33 D.Datatype name tvars ctors : rest ->
34 (:) (D.Datatype name tvars ctors) <$> go rest
36 D.TypeAlias name tvars alias : rest ->
37 (:) (D.TypeAlias name tvars alias) <$> go rest
39 D.Fixity assoc prec op : rest ->
40 (:) (D.Fixity assoc prec op) <$> go rest
42 -- combine definitions
43 D.Definition def : defRest ->
44 case def of
45 Source.Definition pat expr ->
46 do expr' <- exprCombineAnnotations expr
47 let def' = Valid.Definition pat expr' Nothing
48 (:) (D.Definition def') <$> go defRest
50 Source.TypeAnnotation name tipe ->
51 case defRest of
52 D.Definition (Source.Definition pat@(P.Var name') expr) : rest
53 | name == name' ->
54 do expr' <- exprCombineAnnotations expr
55 let def' = Valid.Definition pat expr' (Just tipe)
56 (:) (D.Definition def') <$> go rest
58 _ -> Left (msg name)
60 -- combine ports
61 D.Port port : portRest ->
62 case port of
63 D.PPDef name _ -> Left (msg name)
64 D.PPAnnotation name tipe ->
65 case portRest of
66 D.Port (D.PPDef name' expr) : rest | name == name' ->
67 do expr' <- exprCombineAnnotations expr
68 (:) (D.Port (D.Out name expr' tipe)) <$> go rest
70 _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
73toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]
74toExpr moduleName = concatMap (toDefs moduleName)
76toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]
77toDefs moduleName decl =
78 let typeVar = Var.Canonical (Var.Module moduleName) in
79 case decl of
80 D.Definition def -> [def]
82 D.Datatype name tvars constructors -> concatMap toDefs' constructors
83 where
84 toDefs' (ctor, tipes) =
85 let vars = take (length tipes) arguments
86 tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
87 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
88 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
90 D.TypeAlias name _ tipe@(T.Record fields ext) ->
91 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
92 where
93 args = map snd fields ++ maybe [] (:[]) ext
95 var = A.none . E.localVar
96 vars = take (length args) arguments
98 efields = zip (map fst fields) (map var vars)
99 record = case ext of
100 Nothing -> A.none $ E.Record efields
101 Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
103 -- Type aliases must be added to an extended equality dictionary,
104 -- but they do not require any basic constraints.
105 D.TypeAlias _ _ _ -> []
107 D.Port port ->
108 case port of
109 D.Out name expr@(A.A s _) tipe ->
110 [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
111 D.In name tipe ->
112 [ definition name (A.none $ E.PortIn name tipe) tipe ]
114 -- no constraints are needed for fixity declarations
115 D.Fixity _ _ _ -> []
118arguments :: [String]
119arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
121buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
122buildFunction body@(A.A s _) vars =
123 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
125definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
126definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)