@@ -30,6 +30,7 @@ import qualified Transform.Canonicalize.Variable as Canonicalize
3030import qualified Transform.SortDefinitions as Transform
3131import qualified Transform.Declaration as Transform
3232
33+
3334module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule
3435module' interfaces modul =
3536 filterImports <$> modul'
@@ -41,15 +42,17 @@ module' interfaces modul =
4142 let used (name,_) = Set.member name usedModules
4243 in m { Module.imports = filter used (Module.imports m) }
4344
45+
4446moduleHelp :: Module.Interfaces -> Module.ValidModule
4547 -> Canonicalizer [Doc] Module.CanonicalModule
4648moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
47− do env <- Setup.environment interfaces modul
48− canonicalDecls <- mapM (declaration env) decls
49− exports' <- resolveExports locals exports
50− return $ modul { Module.exports = exports'
51− , Module.body = body canonicalDecls
52− }
49+ do env <- Setup.environment interfaces modul
50+ canonicalDecls <- mapM (declaration env) decls
51+ exports' <- resolveExports locals exports
52+ return $ modul
53+ { Module.exports = exports'
54+ , Module.body = body canonicalDecls
55+ }
5356 where
5457 locals :: [Var.Value]
5558 locals = concatMap declToValue decls
@@ -71,6 +74,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =
7174 [ D.portName port | D.Port port <- decls ]
7275 }
7376
77+
7478resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value]
7579resolveExports fullList (Var.Listing partialList open) =
7680 if open
@@ -121,6 +125,7 @@ resolveExports fullList (Var.Listing partialList open) =
121125 commaSep (map pretty xs)
122126 ]
123127
128+
124129{-| Split a list of values into categories so we can work with them
125130independently.
126131-}
@@ -131,8 +136,12 @@ splitValues mixedValues =
131136 x:xs ->
132137 let (values, aliases, adts) = splitValues xs in
133138 case x of
134− Var.Value name -> (name : values, aliases, adts)
135− Var.Alias name -> (values, name : aliases, adts)
139+ Var.Value name ->
140+ (name : values, aliases, adts)
141+
142+ Var.Alias name ->
143+ (values, name : aliases, adts)
144+
136145 Var.ADT name listing ->
137146 (values, aliases, (name, listing) : adts)
138147
@@ -155,6 +164,7 @@ declToValue decl =
155164
156165 _ -> []
157166
167+
158168declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl
159169declaration env decl =
160170 let canonicalize kind context pattern env v =
@@ -165,104 +175,127 @@ declaration env decl =
165175 in
166176 case decl of
167177 D.Definition (Valid.Definition p e t) ->
168− do p' <- canonicalize pattern "definition" p env p
169− e' <- expression env e
170− t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
171− return $ D.Definition (Canonical.Definition p' e' t')
178+ do p' <- canonicalize pattern "definition" p env p
179+ e' <- expression env e
180+ t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t
181+ return $ D.Definition (Canonical.Definition p' e' t')
172182
173183 D.Datatype name tvars ctors ->
174184 D.Datatype name tvars <$> mapM canonicalize' ctors
175− where
176− canonicalize' (ctor,args) =
177− (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
185+ where
186+ canonicalize' (ctor,args) =
187+ (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args
178188
179189 D.TypeAlias name tvars expanded ->
180− do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
181− return (D.TypeAlias name tvars expanded')
182−
183− D.Port port -> do
184− Env.uses ["Native","Ports"]
185− Env.uses ["Native","Json"]
186− D.Port <$>
187− case port of
188− D.In name t ->
189− do t' <- canonicalize Canonicalize.tipe "port" name env t
190− return (D.In name t')
191− D.Out name e t ->
192− do e' <- expression env e
193− t' <- canonicalize Canonicalize.tipe "port" name env t
194− return (D.Out name e' t')
195−
196− D.Fixity assoc prec op -> return $ D.Fixity assoc prec op
190+ do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded
191+ return (D.TypeAlias name tvars expanded')
192+
193+ D.Port port ->
194+ do Env.uses ["Native","Ports"]
195+ Env.uses ["Native","Json"]
196+ D.Port <$>
197+ case port of
198+ D.In name t ->
199+ do t' <- canonicalize Canonicalize.tipe "port" name env t
200+ return (D.In name t')
201+ D.Out name e t ->
202+ do e' <- expression env e
203+ t' <- canonicalize Canonicalize.tipe "port" name env t
204+ return (D.Out name e' t')
205+
206+ D.Fixity assoc prec op ->
207+ return $ D.Fixity assoc prec op
197208
198209
199210expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr
200211expression env (A.A ann expr) =
201212 let go = expression env
202213 tipe' environ = format . Canonicalize.tipe environ
203− throw err = P.vcat [ P.text "Error" <+> pretty ann <> P.colon
204− , P.text err ]
214+ throw err =
215+ P.vcat
216+ [ P.text "Error" <+> pretty ann <> P.colon
217+ , P.text err
218+ ]
205219 format = Env.onError throw
206220 in
207221 A.A ann <$>
208222 case expr of
209− Literal lit -> return (Literal lit)
223+ Literal lit ->
224+ return (Literal lit)
210225
211− Range e1 e2 -> Range <$> go e1 <*> go e2
226+ Range e1 e2 ->
227+ Range <$> go e1 <*> go e2
212228
213− Access e x -> Access <$> go e <*> return x
229+ Access e x ->
230+ Access <$> go e <*> return x
214231
215− Remove e x -> flip Remove x <$> go e
232+ Remove e x ->
233+ flip Remove x <$> go e
216234
217− Insert e x v -> flip Insert x <$> go e <*> go v
235+ Insert e x v ->
236+ flip Insert x <$> go e <*> go v
218237
219238 Modify e fs ->
220239 Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs
221240
222− Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
241+ Record fs ->
242+ Record <$> mapM (\(k,v) -> (,) k <$> go v) fs
223243
224244 Binop (Var.Raw op) e1 e2 ->
225− do op' <- format (Canonicalize.variable env op)
226− Binop op' <$> go e1 <*> go e2
245+ do op' <- format (Canonicalize.variable env op)
246+ Binop op' <$> go e1 <*> go e2
227247
228248 Lambda p e ->
229249 let env' = update p env in
230250 Lambda <$> format (pattern env' p) <*> expression env' e
231251
232− App e1 e2 -> App <$> go e1 <*> go e2
252+ App e1 e2 ->
253+ App <$> go e1 <*> go e2
233254
234− MultiIf ps -> MultiIf <$> mapM go' ps
235− where go' (b,e) = (,) <$> go b <*> go e
255+ MultiIf ps ->
256+ MultiIf <$> mapM go' ps
257+ where
258+ go' (b,e) = (,) <$> go b <*> go e
236259
237− Let defs e -> Let <$> mapM rename' defs <*> expression env' e
238− where
239− env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
240− rename' (Valid.Definition p body mtipe) =
241− Canonical.Definition
242− <$> format (pattern env' p)
243− <*> expression env' body
244− <*> T.traverse (tipe' env') mtipe
260+ Let defs e ->
261+ Let <$> mapM rename' defs <*> expression env' e
262+ where
263+ env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs
264+ rename' (Valid.Definition p body mtipe) =
265+ Canonical.Definition
266+ <$> format (pattern env' p)
267+ <*> expression env' body
268+ <*> T.traverse (tipe' env') mtipe
245269
246− Var (Var.Raw x) -> Var <$> format (Canonicalize.variable env x)
270+ Var (Var.Raw x) ->
271+ Var <$> format (Canonicalize.variable env x)
247272
248− Data name es -> Data name <$> mapM go es
273+ Data name es ->
274+ Data name <$> mapM go es
249275
250− ExplicitList es -> ExplicitList <$> mapM go es
276+ ExplicitList es ->
277+ ExplicitList <$> mapM go es
251278
252− Case e cases -> Case <$> go e <*> mapM branch cases
253− where
254− branch (p,b) = (,) <$> format (pattern env p)
255− <*> expression (update p env) b
279+ Case e cases ->
280+ Case <$> go e <*> mapM branch cases
281+ where
282+ branch (p,b) =
283+ (,) <$> format (pattern env p)
284+ <*> expression (update p env) b
256285
257286 Markdown uid md es ->
258− do Env.uses ["Text"]
259− Markdown uid md <$> mapM go es
287+ do Env.uses ["Text"]
288+ Markdown uid md <$> mapM go es
289+
290+ PortIn name st ->
291+ PortIn name <$> tipe' env st
260292
261− PortIn name st -> PortIn name <$> tipe' env st
293+ PortOut name st signal ->
294+ PortOut name <$> tipe' env st <*> go signal
262295
263− PortOut name st signal -> PortOut name <$> tipe' env st <*> go signal
296+ GLShader uid src tipe ->
297+ return (GLShader uid src tipe)
264298
265− GLShader uid src tipe -> return (GLShader uid src tipe)
266299
267300pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern
268301pattern env ptrn =