git.iko.soy/elk
on c19392f help sign in
elk/src/Canonicalize/Body.hs
180 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Body (flatten) where
5import qualified Data.Maybe as Maybe
6import qualified Data.Text as Text
7import Data.Text (Text)
9import qualified AST.Declaration as Decl
10import qualified AST.Effects as Effects
11import qualified AST.Expression.Canonical as C
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Pattern as P
14import qualified AST.Type as Type
15import qualified AST.Variable as Var
16import qualified Canonicalize.Sort as Sort
17import qualified Reporting.Annotation as A
18import Reporting.Error.Canonicalize (Error)
19import Reporting.Region (Region)
20import Reporting.Result (Result)
24flatten
25 :: (Monoid i)
26 => ModuleName.Canonical
27 -> Decl.Canonical
28 -> Effects.Canonical
29 -> Result i w Error C.Expr
30flatten moduleName (Decl.Decls defs unions aliases _) effects =
31 let
32 allDefs =
33 concat
34 [ concatMap (unionToDefs moduleName) unions
35 , Maybe.mapMaybe (aliasToDefs moduleName) aliases
36 , effectsToDefs moduleName effects
37 , map A.drop defs
38 ]
40 loc =
41 A.A (error "this annotation should never be needed")
42 in
43 Sort.definitions $ loc $
44 C.Let allDefs (loc $ C.SaveEnv moduleName effects)
48-- TYPES TO DEFS
51unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [C.Def]
52unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
53 let
54 tagToDef (tag, tipes) =
55 let
56 vars =
57 generateArgs (length tipes) []
59 tbody =
60 Type.Type (Var.fromModule moduleName name) (map Type.Var tvars)
62 body =
63 A.A region $
64 C.Ctor (Var.fromModule moduleName tag) (map (A.A region . C.localVar) vars)
65 in
66 definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
67 in
68 map tagToDef constructors
71aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe C.Def
72aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
73 case tipe of
74 Type.Record fields Nothing ->
75 let
76 resultType =
77 Type.Aliased
78 (Var.fromModule moduleName name)
79 (zip tvars (map Type.Var tvars))
80 (Type.Holey tipe)
82 args =
83 map snd fields
85 vars =
86 generateArgs (length args) []
88 record =
89 A.A region $
90 C.Record (zip (map fst fields) (map (A.A region . C.localVar) vars))
91 in
92 Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
94 _ ->
95 Nothing
98generateArgs :: Int -> [Text] -> [Text]
99generateArgs n args =
100 if n == 0 then
101 args
102 else
103 generateArgs (n - 1) (Text.pack ('v' : show n) : args)
106buildFunction :: [Text] -> C.Expr -> C.Expr
107buildFunction vars body@(A.A ann _) =
108 foldr
109 (\pattern expr -> A.A ann (C.Lambda pattern expr))
110 body
111 (map (A.A ann . P.Var) vars)
114definition :: Text -> C.Expr -> Region -> Type.Canonical -> C.Def
115definition name expr@(A.A ann _) region tipe =
116 C.Def
117 region
118 (A.A ann (P.Var name))
119 expr
120 (Just (A.A region tipe))
124-- EFFECTS
127effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [C.Def]
128effectsToDefs moduleName effects =
129 case effects of
130 Effects.None ->
131 []
133 Effects.Port ports ->
134 map portToDef ports
136 Effects.Manager _ info ->
137 let
138 cmdToDef (A.A region name) managerType =
139 definition
140 "command"
141 (A.A region (C.Cmd moduleName managerType))
142 region
143 (Type.cmd moduleName name)
145 subToDef (A.A region name) managerType =
146 definition
147 "subscription"
148 (A.A region (C.Sub moduleName managerType))
149 region
150 (Type.sub moduleName name)
151 in
152 case Effects._managerType info of
153 Effects.CmdManager cmd ->
154 [ cmdToDef cmd Effects.Cmds
155 ]
157 Effects.SubManager sub ->
158 [ subToDef sub Effects.Subs
159 ]
161 Effects.FxManager cmd sub ->
162 [ cmdToDef cmd Effects.Both
163 , subToDef sub Effects.Both
164 ]
167portToDef :: A.Commented Effects.PortCanonical -> C.Def
168portToDef (A.A (region, _) (Effects.PortCanonical name kind tipe)) =
169 definition name (A.A region (toPortExpr name kind)) region tipe
172toPortExpr :: Text -> Effects.Kind -> C.Expr'
173toPortExpr name kind =
174 case kind of
175 Effects.Outgoing tipe ->
176 C.OutgoingPort name tipe
178 Effects.Incoming tipe ->
179 C.IncomingPort name tipe