git.iko.soy/elk
on 267f708 help sign in
elk/src/Canonicalize/Body.hs
170 lines 4.4 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Body (flatten) where
4import qualified Data.Maybe as Maybe
6import qualified AST.Declaration as Decl
7import qualified AST.Effects as Effects
8import qualified AST.Expression.General as E
9import qualified AST.Expression.Canonical as Canonical
10import qualified AST.Module.Name as ModuleName
11import qualified AST.Pattern as P
12import qualified AST.Type as Type
13import qualified AST.Variable as Var
14import qualified Canonicalize.Sort as Sort
15import qualified Reporting.Annotation as A
16import qualified Reporting.Region as R
20flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr
21flatten moduleName (Decl.Decls defs unions aliases _) effects =
22 let
23 allDefs =
24 concat
25 [ concatMap (unionToDefs moduleName) unions
26 , Maybe.mapMaybe (aliasToDefs moduleName) aliases
27 , effectsToDefs moduleName effects
28 , map A.drop defs
29 ]
31 loc =
32 A.A (error "this annotation should never be needed")
33 in
34 Sort.definitions $ loc $
35 E.Let allDefs (loc $ E.SaveEnv moduleName effects)
39-- TYPES TO DEFS
42unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]
43unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
44 let
45 tagToDef (tag, tipes) =
46 let
47 vars =
48 take (length tipes) infiniteArgs
50 tbody =
51 Type.App
52 (Type.Type (Var.fromModule moduleName name))
53 (map Type.Var tvars)
55 body =
56 A.A region $
57 E.Data tag (map (A.A region . E.localVar) vars)
58 in
59 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
60 in
61 map tagToDef constructors
64aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe Canonical.Def
65aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
66 case tipe of
67 Type.Record fields Nothing ->
68 let
69 resultType =
70 Type.Aliased
71 (Var.fromModule moduleName name)
72 (zip tvars (map Type.Var tvars))
73 (Type.Holey tipe)
75 args =
76 map snd fields
78 vars =
79 take (length args) infiniteArgs
81 record =
82 A.A region $
83 E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))
84 in
85 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
87 _ ->
88 Nothing
91infiniteArgs :: [String]
92infiniteArgs =
93 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
96buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr
97buildFunction vars body@(A.A ann _) =
98 foldr
99 (\pattern expr -> A.A ann (E.Lambda pattern expr))
100 body
101 (map (A.A ann . P.Var) vars)
104definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def
105definition name expr@(A.A ann _) region tipe =
106 Canonical.Def
107 Canonical.dummyFacts
108 (A.A ann (P.Var name))
109 expr
110 (Just (A.A region tipe))
114-- EFFECTS
117effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]
118effectsToDefs moduleName effects =
119 case effects of
120 Effects.None ->
121 []
123 Effects.Port ports ->
124 map portToDef ports
126 Effects.Manager _ info ->
127 let
128 cmdToDef (A.A region name) =
129 definition
130 "command"
131 (A.A region (E.Cmd moduleName))
132 region
133 (Type.cmd moduleName name)
135 subToDef (A.A region name) =
136 definition
137 "subscription"
138 (A.A region (E.Sub moduleName))
139 region
140 (Type.sub moduleName name)
141 in
142 case Effects._managerType info of
143 Effects.CmdManager cmd ->
144 [ cmdToDef cmd
145 ]
147 Effects.SubManager sub ->
148 [ subToDef sub
149 ]
151 Effects.FxManager cmd sub ->
152 [ cmdToDef cmd
153 , subToDef sub
154 ]
157portToDef :: A.Commented Effects.PortCanonical -> Canonical.Def
158portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =
159 definition name (A.A region (toPortExpr name kind)) region tipe
162toPortExpr :: String -> Effects.Kind -> Canonical.Expr'
163toPortExpr name kind =
164 case kind of
165 Effects.Outgoing tipe ->
166 E.OutgoingPort name tipe
168 Effects.Incoming tipe ->
169 E.IncomingPort name tipe