git.iko.soy/elk
on ab17521 help sign in
elk/compiler/Transform/Declaration.hs
125 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.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 :: [D.CanonicalDecl] -> [Canonical.Def]
74toExpr = concatMap toDefs
76toDefs :: D.CanonicalDecl -> [Canonical.Def]
77toDefs decl =
78 case decl of
79 D.Definition def -> [def]
81 D.Datatype name tvars constructors -> concatMap toDefs' constructors
82 where
83 toDefs' (ctor, tipes) =
84 let vars = take (length tipes) arguments
85 tbody = T.Data (Var.local name) $ map T.Var tvars
86 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
87 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
89 D.TypeAlias name _ tipe@(T.Record fields ext) ->
90 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
91 where
92 args = map snd fields ++ maybe [] (:[]) ext
94 var = A.none . E.localVar
95 vars = take (length args) arguments
97 efields = zip (map fst fields) (map var vars)
98 record = case ext of
99 Nothing -> A.none $ E.Record efields
100 Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
102 -- Type aliases must be added to an extended equality dictionary,
103 -- but they do not require any basic constraints.
104 D.TypeAlias _ _ _ -> []
106 D.Port port ->
107 case port of
108 D.Out name expr@(A.A s _) tipe ->
109 [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
110 D.In name tipe ->
111 [ definition name (A.none $ E.PortIn name tipe) tipe ]
113 -- no constraints are needed for fixity declarations
114 D.Fixity _ _ _ -> []
117arguments :: [String]
118arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
120buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
121buildFunction body@(A.A s _) vars =
122 foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
124definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def
125definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe)