git.iko.soy/elk
on master help sign in
Get foreign effects working
66c833dEvan Czaplicki
elm-compiler.cabal+2
compare with master
unifiedsplit
@@ -63,6 +63,7 @@ Library
63 AST.Variable,
63 AST.Variable,
64 Canonicalize,
64 Canonicalize,
65 Canonicalize.Body,
65 Canonicalize.Body,
66+ Canonicalize.Effects,
66 Canonicalize.Environment,
67 Canonicalize.Environment,
67 Canonicalize.Result,
68 Canonicalize.Result,
68 Canonicalize.Setup,
69 Canonicalize.Setup,
@@ -79,6 +80,7 @@ Library
79 Generate.JavaScript,
80 Generate.JavaScript,
80 Generate.JavaScript.BuiltIn,
81 Generate.JavaScript.BuiltIn,
81 Generate.JavaScript.Expression,
82 Generate.JavaScript.Expression,
83+ Generate.JavaScript.Foreign,
82 Generate.JavaScript.Helpers,
84 Generate.JavaScript.Helpers,
83 Generate.JavaScript.Literal,
85 Generate.JavaScript.Literal,
84 Generate.JavaScript.Variable,
86 Generate.JavaScript.Variable,
src/AST/Declaration.hs+90−34
@@ -11,53 +11,99 @@ import qualified Reporting.Annotation as A
11
11
12
12
13
13
14−-- DECLARATIONS
14+-- SOURCE DECLARATIONS
15
15
16
16
17−data Decl def tipe expr
17+type Source =
18− = Def def
18+ CommentOr (A.Located Raw)
19− | Union String [String] [(String, [tipe])]
20− | Alias String [String] tipe
21− | Fixity Assoc Int String
22
19
23
20
21+data CommentOr a
22+ = Comment (A.Located String)
23+ | Whatever a
24
24
25−-- DECLARATION PHASES
26
25
26+data Raw
27+ = Def Source.Def
28+ | Union (Union Type.Raw)
29+ | Alias (Alias Type.Raw)
30+ | Fixity Infix
31+ | Foreign String Type.Raw
27
32
28−type Source =
29− CommentOr (A.Located Source')
30
33
31
34
32−type Source' =
35+-- STRUCTURED DECLARATIONS
33− Decl Source.Def Type.Raw Source.Expr
34
36
35
37
36−type Valid =
38+data Decls def tipe =
39+ Decls
40+ { _defs :: [A.Commented def]
41+ , _unions :: [A.Commented (Union tipe)]
37− A.Commented Valid'
42+ , _aliases :: [A.Commented (Alias tipe)]
43+ , _infixes :: [Infix]
44+ }
38
45
39
46
40−type Valid' =
47+type Valid =
41− Decl Valid.Def Type.Raw Valid.Expr
48+ Decls Valid.Def Type.Raw
42
49
43
50
44type Canonical =
51type Canonical =
45− A.Commented (Decl Canonical.Def Type.Canonical Canonical.Expr)
52+ Decls Canonical.Def Type.Canonical
46
53
47
54
55+addDef :: A.Commented d -> Decls d t -> Decls d t
56+addDef def decls =
57+ decls { _defs = def : _defs decls }
48
58
49−-- COMMENTS
50
59
60+addUnion :: A.Commented (Union t) -> Decls d t -> Decls d t
61+addUnion union decls =
62+ decls { _unions = union : _unions decls }
63+
64+
65+addAlias :: A.Commented (Alias t) -> Decls d t -> Decls d t
66+addAlias alias decls =
67+ decls { _aliases = alias : _aliases decls }
68+
69+
70+addInfix :: Infix -> Decls d t -> Decls d t
71+addInfix fixity decls =
72+ decls { _infixes = fixity : _infixes decls }
51
73
52−data CommentOr a
74+
53− = Comment (A.Located String)
75+
54− | Whatever a
76+-- TYPE DECLARATIONS
77+
78+
79+data Type body =
80+ Type
81+ { _name :: String
82+ , _args :: [String]
83+ , _body :: body
84+ }
85+
86+
87+type Union tipe =
88+ Type [(String, [tipe])]
89+
90+
91+type Alias tipe =
92+ Type tipe
55
93
56
94
57
95
58-- INFIX STUFF
96-- INFIX STUFF
59
97
60
98
99+data Infix =
100+ Infix
101+ { _op :: String
102+ , _associativity :: Assoc
103+ , _precedence :: Int
104+ }
105+
106+
61data Assoc = L | N | R
107data Assoc = L | N | R
62 deriving (Eq)
108 deriving (Eq)
63
109
@@ -79,18 +125,28 @@ assocToString assoc =
79-- BINARY CONVERSION
125-- BINARY CONVERSION
80
126
81
127
128+instance Binary Infix where
129+ get =
130+ Infix <$> get <*> get <*> get
131+
132+ put (Infix op assoc prec) =
133+ do put op
134+ put assoc
135+ put prec
136+
137+
82instance Binary Assoc where
138instance Binary Assoc where
83− get =
139+ get =
84− do n <- getWord8
140+ do n <- getWord8
85− return $ case n of
141+ return $ case n of
86− 0 -> L
142+ 0 -> L
87− 1 -> N
143+ 1 -> N
88− 2 -> R
144+ 2 -> R
89− _ -> error "Error reading valid associativity from serialized string"
145+ _ -> error "Error reading valid associativity from serialized string"
90−
146+
91− put assoc =
147+ put assoc =
92− putWord8 $
148+ putWord8 $
93− case assoc of
149+ case assoc of
94− L -> 0
150+ L -> 0
95− N -> 1
151+ N -> 1
96− R -> 2
152+ R -> 2
src/AST/Effects.hs+45−5
@@ -1,14 +1,30 @@
1module AST.Effects where
1module AST.Effects where
2
2
3+import qualified AST.Type as Type
3import qualified Reporting.Annotation as A
4import qualified Reporting.Annotation as A
4import qualified Reporting.Region as R
5import qualified Reporting.Region as R
5
6
6
7
7
8
9+-- EFFECTS
10+
11+
8−data Effects
12+data Effects foreigns
9 = None
13 = None
10− | Effect Info
14+ | Manager Info
11− | Foreign
15+ | Foreign foreigns
16+
17+
18+type Raw =
19+ Effects [A.Commented ForeignRaw]
20+
21+
22+type Canonical =
23+ Effects [A.Commented ForeignCanonical]
24+
25+
26+
27+-- EFFECT MANAGERS
12
28
13
29
14data Info =
30data Info =
@@ -17,11 +33,35 @@ data Info =
17 , _init :: R.Region
33 , _init :: R.Region
18 , _onEffects :: R.Region
34 , _onEffects :: R.Region
19 , _onSelfMsg :: R.Region
35 , _onSelfMsg :: R.Region
20− , _type :: ManagerType
36+ , _managerType :: ManagerType
21 }
37 }
22
38
23
39
24data ManagerType
40data ManagerType
25 = CmdManager (A.Located String)
41 = CmdManager (A.Located String)
26 | SubManager (A.Located String)
42 | SubManager (A.Located String)
27− | FxManager (A.Located String) (A.Located String)
43+ | FxManager (A.Located String) (A.Located String)
44+
45+
46+
47+-- FOREIGN EFFECTS
48+
49+
50+data ForeignRaw =
51+ ForeignRaw
52+ { _rawName :: String
53+ , _rawType :: Type.Raw
54+ }
55+
56+
57+data ForeignCanonical =
58+ ForeignCanonical
59+ { _name :: String
60+ , _kind :: Kind
61+ , _type :: Type.Canonical
62+ }
63+
64+
65+data Kind
66+ = Cmd Type.Canonical
67+ | Sub Type.Canonical
src/AST/Expression/Canonical.hs+1−1
@@ -21,7 +21,7 @@ type Expr' =
21
21
22
22
23data Def
23data Def
24− = Definition Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))
24+ = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))
25
25
26
26
27data Facts = Facts
27data Facts = Facts
src/AST/Expression/General.hs+6−4
@@ -8,7 +8,7 @@ enrich the AST with more information.
8-}
8-}
9module AST.Expression.General where
9module AST.Expression.General where
10
10
11−import qualified AST.Effects as Fx
11+import qualified AST.Effects as Effects
12import qualified AST.Literal as Literal
12import qualified AST.Literal as Literal
13import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Pattern as Pattern
14import qualified AST.Pattern as Pattern
@@ -55,9 +55,11 @@ data Expr' ann def var typ
55 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
55 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]
56 | Record [(String, Expr ann def var typ)]
56 | Record [(String, Expr ann def var typ)]
57 -- for type checking and code gen only
57 -- for type checking and code gen only
58− | Cmd ModuleName.Canonical String
58+ | Cmd ModuleName.Canonical
59− | Sub ModuleName.Canonical String
59+ | Sub ModuleName.Canonical
60+ | ForeignCmd String typ
61+ | ForeignSub String typ
60− | SaveEnv ModuleName.Canonical Fx.Effects
62+ | SaveEnv ModuleName.Canonical Effects.Canonical
61 | GLShader String String Literal.GLShaderTipe
63 | GLShader String String Literal.GLShaderTipe
62
64
63
65
src/AST/Expression/Optimized.hs+3
@@ -7,6 +7,7 @@ module AST.Expression.Optimized
7
7
8import qualified AST.Literal as Literal
8import qualified AST.Literal as Literal
9import qualified AST.Module.Name as ModuleName
9import qualified AST.Module.Name as ModuleName
10+import qualified AST.Type as Type
10import qualified AST.Variable as Var
11import qualified AST.Variable as Var
11import qualified Optimize.DecisionTree as DT
12import qualified Optimize.DecisionTree as DT
12import qualified Reporting.Region as R
13import qualified Reporting.Region as R
@@ -52,6 +53,8 @@ data Expr
52 | Record [(String, Expr)]
53 | Record [(String, Expr)]
53 | Cmd ModuleName.Canonical
54 | Cmd ModuleName.Canonical
54 | Sub ModuleName.Canonical
55 | Sub ModuleName.Canonical
56+ | ForeignCmd String Type.Canonical
57+ | ForeignSub String Type.Canonical
55 | GLShader String String Literal.GLShaderTipe
58 | GLShader String String Literal.GLShaderTipe
56 | Crash ModuleName.Canonical R.Region (Maybe Expr)
59 | Crash ModuleName.Canonical R.Region (Maybe Expr)
57
60
src/AST/Expression/Valid.hs+3−3
@@ -20,11 +20,11 @@ type Expr' =
20 General.Expr' R.Region Def Var.Raw Type.Raw
20 General.Expr' R.Region Def Var.Raw Type.Raw
21
21
22
22
23−data Def
23+data Def =
24− = Definition Pattern.Raw Expr (Maybe Type.Raw)
24+ Def Pattern.Raw Expr (Maybe Type.Raw)
25
25
26
26
27getPattern :: Def -> Pattern.Raw
27getPattern :: Def -> Pattern.Raw
28−getPattern (Definition pattern _ _) =
28+getPattern (Def pattern _ _) =
29 pattern
29 pattern
30
30
src/AST/Module.hs+6−6
@@ -19,7 +19,7 @@ import Data.Binary
19import qualified Data.Map as Map
19import qualified Data.Map as Map
20
20
21import qualified AST.Declaration as Decl
21import qualified AST.Declaration as Decl
22−import qualified AST.Effects as Fx
22+import qualified AST.Effects as Effects
23import qualified AST.Expression.Canonical as Canonical
23import qualified AST.Expression.Canonical as Canonical
24import qualified AST.Expression.Optimized as Optimized
24import qualified AST.Expression.Optimized as Optimized
25import qualified AST.Module.Name as Name
25import qualified AST.Module.Name as Name
@@ -99,8 +99,8 @@ data ValidInfo =
99 { validDocs :: A.Located (Maybe String)
99 { validDocs :: A.Located (Maybe String)
100 , validExports :: Var.Listing (A.Located Var.Value)
100 , validExports :: Var.Listing (A.Located Var.Value)
101 , validImports :: ([DefaultImport], [UserImport])
101 , validImports :: ([DefaultImport], [UserImport])
102− , validDecls :: [Decl.Valid]
102+ , validDecls :: Decl.Valid
103− , validEffects :: Fx.Effects
103+ , validEffects :: Effects.Raw
104 }
104 }
105
105
106
106
@@ -140,10 +140,10 @@ data Info program =
140 , imports :: [Name.Raw]
140 , imports :: [Name.Raw]
141 , program :: program
141 , program :: program
142 , types :: Types
142 , types :: Types
143− , fixities :: [(Decl.Assoc, Int, String)]
143+ , fixities :: [Decl.Infix]
144 , aliases :: Aliases
144 , aliases :: Aliases
145 , unions :: Unions
145 , unions :: Unions
146− , effects :: Fx.Effects
146+ , effects :: Effects.Canonical
147 }
147 }
148
148
149
149
@@ -185,7 +185,7 @@ data Interface =
185 , iTypes :: Types
185 , iTypes :: Types
186 , iUnions :: Unions
186 , iUnions :: Unions
187 , iAliases :: Aliases
187 , iAliases :: Aliases
188− , iFixities :: [(Decl.Assoc, Int, String)]
188+ , iFixities :: [Decl.Infix]
189 }
189 }
190
190
191
191
src/Canonicalize.hs+84−78
@@ -27,6 +27,7 @@ import qualified Reporting.Region as Region
27import qualified Reporting.Result as R
27import qualified Reporting.Result as R
28import qualified Reporting.Warning as Warning
28import qualified Reporting.Warning as Warning
29import qualified Canonicalize.Body as Body
29import qualified Canonicalize.Body as Body
30+import qualified Canonicalize.Effects as Effects
30import qualified Canonicalize.Environment as Env
31import qualified Canonicalize.Environment as Env
31import qualified Canonicalize.Result as Result
32import qualified Canonicalize.Result as Result
32import qualified Canonicalize.Setup as Setup
33import qualified Canonicalize.Setup as Setup
@@ -53,38 +54,32 @@ module' canonicalImports interfaces modul =
53 |> map (\cName -> (ModuleName._module cName, cName))
54 |> map (\cName -> (ModuleName._module cName, cName))
54 |> Map.fromList
55 |> Map.fromList
55
56
56− canonicalDeclsResult =
57+ (Result.Result uses rawResults) =
57 Setup.environment importDict interfaces modul
58 Setup.environment importDict interfaces modul
58− `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls
59+ `Result.andThen` \env ->
59
60
60− (Result.Result uses rawResults) =
61− (,)
61+ (,,,) env
62− <$> canonicalDeclsResult
63− <*> resolveExports (concatMap declToValues decls) exports
62+ <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports
63+ <*> canonicalizeDecls env decls
64+ <*> Effects.canonicalize env effects
64 in
65 in
65 case rawResults of
66 case rawResults of
66 Result.Err msgs ->
67 Result.Err msgs ->
67 R.throwMany (map (A.map Error.Canonicalize) msgs)
68 R.throwMany (map (A.map Error.Canonicalize) msgs)
68
69
69− Result.Ok ((env, canonicalDecls), canonicalExports) ->
70+ Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->
70 let
71 let
71− nakedDecls =
72+ (D.Decls _ unions aliases infixes) =
72− map A.drop canonicalDecls
73+ canonicalDecls
73
74
74 centralizedDocs =
75 centralizedDocs =
75 A.map (fmap (Docs.centralize canonicalDecls)) docs
76 A.map (fmap (Docs.centralize canonicalDecls)) docs
76
77
77− program =
78+ typeToPair (A.A _ (D.Type name args body)) =
78− Body.flatten (Module.name modul) canonicalDecls effects
79+ ( name, (args, body) )
79−
80− fixities =
81− [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]
82
80
83− aliases =
81+ program =
84− Map.fromList [ (name,(tvs,alias)) | D.Alias name tvs alias <- nakedDecls ]
82+ Body.flatten (Module.name modul) canonicalDecls canonicalEffects
85−
86− unions =
87− Map.fromList [ (name,(vars,ctors)) | D.Union name vars ctors <- nakedDecls ]
88 in
83 in
89 R.addDealiaser (Env.toDealiaser env) $
84 R.addDealiaser (Env.toDealiaser env) $
90 do canonicalImports <- filterImports uses imports
85 do canonicalImports <- filterImports uses imports
@@ -96,10 +91,10 @@ module' canonicalImports interfaces modul =
96 , Module.imports = canonicalImports
91 , Module.imports = canonicalImports
97 , Module.program = program
92 , Module.program = program
98 , Module.types = Map.empty
93 , Module.types = Map.empty
99− , Module.fixities = fixities
94+ , Module.fixities = infixes
100− , Module.aliases = aliases
95+ , Module.aliases = Map.fromList (map typeToPair aliases)
101− , Module.unions = unions
96+ , Module.unions = Map.fromList (map typeToPair unions)
102− , Module.effects = effects
97+ , Module.effects = canonicalEffects
103 }
98 }
104 }
99 }
105
100
@@ -251,25 +246,28 @@ allUnique statedExports =
251-- CONVERSIONS
246-- CONVERSIONS
252
247
253
248
254−declToValues :: D.Valid -> [Var.Value]
249+declsToValues :: D.Valid -> [Var.Value]
255−declToValues (A.A _ decl) =
250+declsToValues (D.Decls defs unions aliases _) =
256− case decl of
251+ let
257− D.Def def ->
252+ fromDef (A.A _ def) =
258 map Var.Value (P.boundVarList (Valid.getPattern def))
253 map Var.Value (P.boundVarList (Valid.getPattern def))
259
254
260− D.Union name _tvs ctors ->
255+ fromUnion (A.A _ (D.Type name _ ctors)) =
261− [ Var.Union name (Var.Listing (map fst ctors) False) ]
256+ Var.Union name (Var.Listing (map fst ctors) False)
262
257
263− D.Alias name _ tipe ->
258+ fromAlias (A.A _ (D.Type name _ tipe)) =
264 case tipe of
259 case tipe of
265 A.A _ (Type.RRecord _ Nothing) ->
260 A.A _ (Type.RRecord _ Nothing) ->
266 [ Var.Alias name, Var.Value name ]
261 [ Var.Alias name, Var.Value name ]
267
262
268 _ ->
263 _ ->
269 [ Var.Alias name ]
264 [ Var.Alias name ]
270−
265+ in
271− _ ->
266+ concat
267+ [ map fromUnion unions
268+ , concatMap fromAlias aliases
269+ , concatMap fromDef defs
272− []
270+ ]
273
271
274
272
275
273
@@ -321,46 +319,48 @@ splitLocatedValue (A.A region value) =
321-- DECLARATIONS
319-- DECLARATIONS
322
320
323
321
324−declaration :: Env.Environment -> D.Valid -> Result.ResultErr D.Canonical
322+canonicalizeDecls :: Env.Environment -> D.Valid -> Result.ResultErr D.Canonical
325−declaration env (A.A ann decl) =
323+canonicalizeDecls env (D.Decls defs unions aliases infixes) =
326− A.A ann <$>
324+ let
327− case decl of
325+ traverse canEntry entries =
326+ T.traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries
327+
328− D.Def (Valid.Definition pat expr typ) ->
328+ canonicalizeDef (Valid.Def pat expr typ) =
329− D.Def <$> (
330− Canonical.Definition Canonical.dummyFacts
329+ Canonical.Def Canonical.dummyFacts
331− <$> pattern env pat
330+ <$> canonicalizePattern env pat
332− <*> expression env expr
331+ <*> canonicalizeExpr env expr
333− <*> T.traverse (regionType env) typ
332+ <*> T.traverse (canonicalizeRegionType env) typ
334− )
335−
336− D.Union name tvars ctors ->
337− D.Union name tvars <$> T.traverse canonicalizeArgs ctors
338− where
339− canonicalizeArgs (ctor, args) =
340− (,) ctor <$> T.traverse (Canonicalize.tipe env) args
341
333
342− D.Alias name tvars expanded ->
334+ canonicalizeArgs (ctor, args) =
343− D.Alias name tvars
344− <$> Canonicalize.tipe env expanded
335+ (,) ctor <$> T.traverse (Canonicalize.tipe env) args
345
336
346− D.Fixity assoc prec op ->
337+ canonicalizeUnion (D.Type name tvars ctors) =
347− Result.ok (D.Fixity assoc prec op)
338+ D.Type name tvars <$> T.traverse canonicalizeArgs ctors
339+
340+ canonicalizeAlias (D.Type name tvars alias) =
341+ D.Type name tvars <$> Canonicalize.tipe env alias
342+ in
343+ D.Decls
344+ <$> traverse canonicalizeDef defs
345+ <*> traverse canonicalizeUnion unions
346+ <*> traverse canonicalizeAlias aliases
347+ <*> pure infixes
348
348
349
349
350−regionType
350+canonicalizeRegionType
351 :: Env.Environment
351 :: Env.Environment
352 -> Type.Raw
352 -> Type.Raw
353 -> Result.ResultErr (A.Located Type.Canonical)
353 -> Result.ResultErr (A.Located Type.Canonical)
354−regionType env typ@(A.A region _) =
354+canonicalizeRegionType env typ@(A.A region _) =
355 A.A region <$> Canonicalize.tipe env typ
355 A.A region <$> Canonicalize.tipe env typ
356
356
357
357
358−expression
358+canonicalizeExpr
359 :: Env.Environment
359 :: Env.Environment
360 -> Valid.Expr
360 -> Valid.Expr
361 -> Result.ResultErr Canonical.Expr
361 -> Result.ResultErr Canonical.Expr
362−expression env (A.A region validExpr) =
362+canonicalizeExpr env (A.A region validExpr) =
363− let go = expression env
363+ let go = canonicalizeExpr env
364 in
364 in
365 A.A region <$>
365 A.A region <$>
366 case validExpr of
366 case validExpr of
@@ -393,7 +393,7 @@ expression env (A.A region validExpr) =
393 env' =
393 env' =
394 Env.addPattern arg env
394 Env.addPattern arg env
395 in
395 in
396− Lambda <$> pattern env' arg <*> expression env' body
396+ Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body
397
397
398 App func arg ->
398 App func arg ->
399 App <$> go func <*> go arg
399 App <$> go func <*> go arg
@@ -407,16 +407,16 @@ expression env (A.A region validExpr) =
407 (,) <$> go condition <*> go branch
407 (,) <$> go condition <*> go branch
408
408
409 Let defs body ->
409 Let defs body ->
410− Let <$> T.traverse rename' defs <*> expression env' body
410+ Let <$> T.traverse rename' defs <*> canonicalizeExpr env' body
411 where
411 where
412 env' =
412 env' =
413− foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs
413+ foldr Env.addPattern env (map Valid.getPattern defs)
414
414
415− rename' (Valid.Definition p body mtipe) =
415+ rename' (Valid.Def p body mtipe) =
416− Canonical.Definition Canonical.dummyFacts
416+ Canonical.Def Canonical.dummyFacts
417− <$> pattern env' p
417+ <$> canonicalizePattern env' p
418− <*> expression env' body
418+ <*> canonicalizeExpr env' body
419− <*> T.traverse (regionType env') mtipe
419+ <*> T.traverse (canonicalizeRegionType env') mtipe
420
420
421 Var (Var.Raw x) ->
421 Var (Var.Raw x) ->
422 Var <$> Canonicalize.variable region env x
422 Var <$> Canonicalize.variable region env x
@@ -432,14 +432,20 @@ expression env (A.A region validExpr) =
432 where
432 where
433 branch (ptrn, brnch) =
433 branch (ptrn, brnch) =
434 (,)
434 (,)
435− <$> pattern env ptrn
435+ <$> canonicalizePattern env ptrn
436− <*> expression (Env.addPattern ptrn env) brnch
436+ <*> canonicalizeExpr (Env.addPattern ptrn env) brnch
437+
438+ Cmd moduleName ->
439+ Result.ok (Cmd moduleName)
440+
441+ Sub moduleName ->
442+ Result.ok (Sub moduleName)
437
443
438− Cmd moduleName string ->
444+ ForeignCmd name tipe ->
439− Result.ok (Cmd moduleName string)
445+ ForeignCmd name <$> Canonicalize.tipe env tipe
440
446
441− Sub moduleName string ->
447+ ForeignSub name tipe ->
442− Result.ok (Sub moduleName string)
448+ ForeignSub name <$> Canonicalize.tipe env tipe
443
449
444 SaveEnv moduleName effects ->
450 SaveEnv moduleName effects ->
445 Result.ok (SaveEnv moduleName effects)
451 Result.ok (SaveEnv moduleName effects)
@@ -448,8 +454,8 @@ expression env (A.A region validExpr) =
448 Result.ok (GLShader uid src tipe)
454 Result.ok (GLShader uid src tipe)
449
455
450
456
451−pattern :: Env.Environment -> P.Raw -> Result.ResultErr P.Canonical
457+canonicalizePattern :: Env.Environment -> P.Raw -> Result.ResultErr P.Canonical
452−pattern env (A.A region ptrn) =
458+canonicalizePattern env (A.A region ptrn) =
453 A.A region <$>
459 A.A region <$>
454 case ptrn of
460 case ptrn of
455 P.Var x ->
461 P.Var x ->
@@ -465,9 +471,9 @@ pattern env (A.A region ptrn) =
465 Result.ok P.Anything
471 Result.ok P.Anything
466
472
467 P.Alias x p ->
473 P.Alias x p ->
468− P.Alias x <$> pattern env p
474+ P.Alias x <$> canonicalizePattern env p
469
475
470 P.Data (Var.Raw name) patterns ->
476 P.Data (Var.Raw name) patterns ->
471 P.Data
477 P.Data
472 <$> Canonicalize.pvar region env name (length patterns)
478 <$> Canonicalize.pvar region env name (length patterns)
473− <*> T.traverse (pattern env) patterns
479+ <*> T.traverse (canonicalizePattern env) patterns
src/Canonicalize/Body.hs+101−85
@@ -1,13 +1,15 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Body (flatten) where
2module Canonicalize.Body (flatten) where
3
3
4−import qualified AST.Declaration as D
4+import qualified Data.Maybe as Maybe
5+
6+import qualified AST.Declaration as Decl
5−import qualified AST.Effects as Fx
7+import qualified AST.Effects as Effects
6import qualified AST.Expression.General as E
8import qualified AST.Expression.General as E
7import qualified AST.Expression.Canonical as Canonical
9import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Module.Name as ModuleName
10import qualified AST.Module.Name as ModuleName
9import qualified AST.Pattern as P
11import qualified AST.Pattern as P
10−import qualified AST.Type as T
12+import qualified AST.Type as Type
11import qualified AST.Variable as Var
13import qualified AST.Variable as Var
12import qualified Canonicalize.Sort as Sort
14import qualified Canonicalize.Sort as Sort
13import qualified Reporting.Annotation as A
15import qualified Reporting.Annotation as A
@@ -15,63 +17,60 @@ import qualified Reporting.Region as R
15
17
16
18
17
19
18−flatten :: ModuleName.Canonical -> [D.Canonical] -> Fx.Effects -> Canonical.Expr
20+flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr
19−flatten moduleName decls effects =
21+flatten moduleName (Decl.Decls defs unions aliases _) effects =
20 let
22 let
21− declDefs =
23+ allDefs =
24+ concat
22− concatMap (declToDefs moduleName) decls
25+ [ concatMap (unionToDefs moduleName) unions
23−
26+ , Maybe.mapMaybe (aliasToDefs moduleName) aliases
24− effectDefs =
25− effectsToDefs moduleName effects
27+ , effectsToDefs moduleName effects
28+ , map A.drop defs
29+ ]
26
30
27 loc =
31 loc =
28 A.A (error "this annotation should never be needed")
32 A.A (error "this annotation should never be needed")
29 in
33 in
30 Sort.definitions $ loc $
34 Sort.definitions $ loc $
31− E.Let
32− (declDefs ++ effectDefs)
33− (loc $ E.SaveEnv moduleName effects)
35+ E.Let allDefs (loc $ E.SaveEnv moduleName effects)
34
36
35
37
36
38
37−-- DECLARATIONS
39+-- TYPES TO DEFS
38
40
39
41
40−declToDefs :: ModuleName.Canonical -> D.Canonical -> [Canonical.Def]
42+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]
41−declToDefs moduleName (A.A (region,_) decl) =
43+unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =
42 let
44 let
43− typeVar =
45+ tagToDef (tag, tipes) =
44− Var.fromModule moduleName
46+ let
47+ vars =
48+ take (length tipes) infiniteArgs
45
49
46− loc expr =
50+ tbody =
47− A.A region expr
51+ Type.App
48− in
52+ (Type.Type (Var.fromModule moduleName name))
49− case decl of
53+ (map Type.Var tvars)
50− D.Def def ->
51− [def]
52
54
53− D.Union name tvars constructors ->
55+ body =
54− let
56+ A.A region $
55− tagToDef (ctor, tipes) =
56− let
57− vars =
58− take (length tipes) infiniteArgs
59−
60− tbody =
61− T.App (T.Type (typeVar name)) (map T.Var tvars)
62−
63− body =
64− loc . E.Data ctor $ map (loc . E.localVar) vars
57+ E.Data tag (map (A.A region . E.localVar) vars)
65− in
66− definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes)
67 in
58 in
59+ definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)
60+ in
68− map tagToDef constructors
61+ map tagToDef constructors
62+
69
63
64+aliasToDefs :: ModuleName.Canonical -> A.Commented (Decl.Alias Type.Canonical) -> Maybe Canonical.Def
65+aliasToDefs moduleName (A.A (region,_) (Decl.Type name tvars tipe)) =
66+ case tipe of
70− D.Alias name tvars tipe@(T.Record fields Nothing) ->
67+ Type.Record fields Nothing ->
71− [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]
68+ let
72− where
69+ resultType =
73− result =
70+ Type.Aliased
71+ (Var.fromModule moduleName name)
74− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)
72+ (zip tvars (map Type.Var tvars))
73+ (Type.Holey tipe)
75
74
76 args =
75 args =
77 map snd fields
76 map snd fields
@@ -80,16 +79,13 @@ declToDefs moduleName (A.A (region,_) decl) =
80 take (length args) infiniteArgs
79 take (length args) infiniteArgs
81
80
82 record =
81 record =
82+ A.A region $
83− loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))
83+ E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))
84−
84+ in
85− -- Type aliases must be added to an extended equality dictionary,
85+ Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)
86− -- but they do not require any basic constraints.
87− D.Alias _ _ _ ->
88− []
89
86
90− -- no constraints are needed for fixity declarations
87+ _ ->
91− D.Fixity _ _ _ ->
88+ Nothing
92− []
93
89
94
90
95infiniteArgs :: [String]
91infiniteArgs :: [String]
@@ -97,17 +93,17 @@ infiniteArgs =
97 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
93 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
98
94
99
95
100−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr
96+buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr
101−buildFunction body@(A.A ann _) vars =
97+buildFunction vars body@(A.A ann _) =
102 foldr
98 foldr
103− (\pattern expr -> A.A ann (E.Lambda pattern expr))
99+ (\pattern expr -> A.A ann (E.Lambda pattern expr))
104− body
100+ body
105− (map (A.A ann . P.Var) vars)
101+ (map (A.A ann . P.Var) vars)
106
102
107
103
108−definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def
104+definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def
109definition name expr@(A.A ann _) region tipe =
105definition name expr@(A.A ann _) region tipe =
110− Canonical.Definition
106+ Canonical.Def
111 Canonical.dummyFacts
107 Canonical.dummyFacts
112 (A.A ann (P.Var name))
108 (A.A ann (P.Var name))
113 expr
109 expr
@@ -118,37 +114,57 @@ definition name expr@(A.A ann _) region tipe =
118-- EFFECTS
114-- EFFECTS
119
115
120
116
121−effectsToDefs :: ModuleName.Canonical -> Fx.Effects -> [Canonical.Def]
117+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]
122effectsToDefs moduleName effects =
118effectsToDefs moduleName effects =
123 case effects of
119 case effects of
124− Fx.None ->
120+ Effects.None ->
125 []
121 []
126
122
127− Fx.Foreign ->
123+ Effects.Foreign foreigns ->
124+ map foreignToDef foreigns
125+
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)
134+
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
128− []
145+ ]
129
146
130− Fx.Effect info ->
147+ Effects.SubManager sub ->
131− case Fx._type info of
148+ [ subToDef sub
132− Fx.CmdManager cmd ->
149+ ]
133− [ effectsToDefsHelp "command" (E.Cmd moduleName) cmd ]
134
150
135− Fx.SubManager sub ->
151+ Effects.FxManager cmd sub ->
136− [ effectsToDefsHelp "subscription" (E.Sub moduleName) sub ]
152+ [ cmdToDef cmd
153+ , subToDef sub
154+ ]
137
155
138− Fx.FxManager cmd sub ->
139− [ effectsToDefsHelp "command" (E.Cmd moduleName) cmd
140− , effectsToDefsHelp "subscription" (E.Sub moduleName) sub
141− ]
142
156
157+foreignToDef :: A.Commented Effects.ForeignCanonical -> Canonical.Def
158+foreignToDef (A.A (region, _) (Effects.ForeignCanonical name kind tipe)) =
159+ definition name (A.A region (toForeignExpr name kind)) region tipe
160+
161+
162+toForeignExpr :: String -> Effects.Kind -> Canonical.Expr'
163+toForeignExpr name kind =
164+ case kind of
165+ Effects.Cmd tipe ->
166+ E.ForeignCmd name tipe
167+
168+ Effects.Sub tipe ->
169+ E.ForeignSub name tipe
143
170
144−effectsToDefsHelp
145− :: String
146− -> (String -> Canonical.Expr')
147− -> A.Located String
148− -> Canonical.Def
149−effectsToDefsHelp name toExpr' (A.A region typeName) =
150− Canonical.Definition
151− Canonical.dummyFacts
152− (A.A region (P.Var name))
153− (A.A region (toExpr' typeName))
154− Nothing
src/Canonicalize/Effects.hsnew file+135
@@ -0,0 +1,135 @@
1+module Canonicalize.Effects (canonicalize, toValues) where
2+
3+import qualified Data.Foldable as F
4+import qualified Data.Traversable as T
5+
6+import qualified AST.Effects as Effects
7+import qualified AST.Type as T
8+import qualified AST.Variable as Var
9+import qualified Reporting.Annotation as A
10+import qualified Reporting.Error.Canonicalize as Error
11+import qualified Reporting.Region as R
12+import qualified Canonicalize.Environment as Env
13+import qualified Canonicalize.Result as Result
14+import qualified Canonicalize.Type as Canonicalize
15+
16+
17+
18+-- TO EXPORT VALUES
19+
20+
21+toValues :: Effects.Raw -> [Var.Value]
22+toValues effects =
23+ case effects of
24+ Effects.None ->
25+ []
26+
27+ Effects.Manager _ ->
28+ []
29+
30+ Effects.Foreign foreigns ->
31+ map (Var.Value . Effects._rawName . A.drop) foreigns
32+
33+
34+
35+-- CANONICALIZE
36+
37+
38+canonicalize :: Env.Environment -> Effects.Raw -> Result.ResultErr Effects.Canonical
39+canonicalize env effects =
40+ case effects of
41+ Effects.None ->
42+ Result.ok Effects.None
43+
44+ Effects.Manager info ->
45+ Result.ok (Effects.Manager info)
46+
47+ Effects.Foreign rawForeigns ->
48+ Effects.Foreign <$> T.traverse (canonicalizeRawForeign env) rawForeigns
49+
50+
51+canonicalizeRawForeign
52+ :: Env.Environment
53+ -> A.Commented Effects.ForeignRaw
54+ -> Result.ResultErr (A.Commented Effects.ForeignCanonical)
55+canonicalizeRawForeign env (A.A ann (Effects.ForeignRaw name rawType)) =
56+ Canonicalize.tipe env rawType
57+ `Result.andThen` \tipe ->
58+
59+ figureOutKind (fst ann) name tipe
60+ `Result.andThen` \kind ->
61+
62+ Result.ok (A.A ann (Effects.ForeignCanonical name kind tipe))
63+
64+
65+figureOutKind :: R.Region -> String -> T.Canonical -> Result.ResultErr Effects.Kind
66+figureOutKind region name rootType =
67+ case T.deepDealias rootType of
68+ T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
69+ | effect == Var.cmd ->
70+ const (Effects.Cmd outgoingType)
71+ <$> checkForeignType region name "command" outgoingType
72+
73+ T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
74+ | effect == Var.sub && msg1 == msg2 ->
75+ const (Effects.Sub incomingType)
76+ <$> checkForeignType region name "subscription" incomingType
77+
78+ _ ->
79+ Result.err (A.A region (error "TODO - bad overall type"))
80+
81+
82+
83+-- CHECK INCOMING AND OUTGOING TYPES
84+
85+
86+--
87+-- Note: assumes that deepDealias has been called on the incoming type.
88+--
89+checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result.ResultErr ()
90+checkForeignType region name kind tipe =
91+ let
92+ throwError maybeMessage =
93+ Result.err $ A.A region $
94+ Error.foreign name kind tipe maybeMessage
95+
96+ check subType =
97+ checkForeignType region name kind subType
98+ in
99+ case tipe of
100+ T.Aliased _ _ _ ->
101+ error "there should be no aliases, they are stripped by `figureOutKind`"
102+
103+ T.Type name ->
104+ if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
105+ Result.ok ()
106+
107+ else
108+ throwError Nothing
109+
110+ T.App name [] ->
111+ check name
112+
113+ T.App (T.Type name) [arg]
114+ | Var.isMaybe name -> check arg
115+ | Var.isArray name -> check arg
116+ | Var.isList name -> check arg
117+
118+ T.App (T.Type name) args
119+ | Var.isTuple name ->
120+ F.traverse_ check args
121+
122+ T.App _ _ ->
123+ throwError Nothing
124+
125+ T.Var _ ->
126+ throwError (Just "free type variable")
127+
128+ T.Lambda _ _ ->
129+ throwError (Just "function")
130+
131+ T.Record _ (Just _) ->
132+ throwError (Just "extended record")
133+
134+ T.Record fields Nothing ->
135+ F.traverse_ (\(k,v) -> (,) k <$> check v) fields
src/Canonicalize/Port.hsdeleted−123
@@ -1,123 +0,0 @@
1−module Canonicalize.Port (check) where
2−
3−import qualified Data.Foldable as Foldable
4−
5−import qualified AST.Declaration as D
6−import qualified AST.Expression.General as E
7−import qualified AST.Expression.Canonical as Canonical
8−import qualified AST.Type as T
9−import qualified AST.Variable as Var
10−import qualified Reporting.Annotation as A
11−import qualified Reporting.Error.Canonicalize as Error
12−import qualified Reporting.Region as R
13−import qualified Canonicalize.Result as Result
14−
15−
16−-- CHECK FOR PORT
17−
18−check
19− :: R.Region
20− -> String
21− -> Maybe Canonical.Expr
22− -> T.Canonical
23− -> Result.ResultErr D.CanonicalPort
24−check region name maybeExpr rootType =
25− D.CanonicalPort <$> checkHelp region name maybeExpr rootType rootType
26−
27−
28−checkHelp
29− :: R.Region
30− -> String
31− -> Maybe Canonical.Expr
32− -> T.Canonical
33− -> T.Canonical
34− -> Result.ResultErr (E.PortImpl Canonical.Expr T.Canonical)
35−checkHelp region name maybeExpr rootType tipe =
36− case (maybeExpr, tipe) of
37− (_, T.Aliased _ args t) ->
38− checkHelp region name maybeExpr rootType (T.dealias args t)
39−
40− (Just expr, T.App (T.Type task) [ _x, _a ])
41− | Var.isTask task ->
42− Result.ok (E.Task name expr (T.Normal tipe))
43−
44−
45− (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])
46− | Var.isSignal signal && Var.isTask task ->
47− Result.ok (E.Task name expr (T.Signal tipe arg))
48−
49−
50− (_, T.App (T.Type signal) [arg])
51− | Var.isSignal signal ->
52− case maybeExpr of
53− Nothing ->
54− const (E.In name (T.Signal rootType arg))
55− <$> validForeignType region name True arg arg
56−
57− Just expr ->
58− const (E.Out name expr (T.Signal rootType arg))
59− <$> validForeignType region name False arg arg
60−
61− _ ->
62− case maybeExpr of
63− Nothing ->
64− const (E.In name (T.Normal rootType))
65− <$> validForeignType region name True rootType tipe
66−
67− Just expr ->
68− const (E.Out name expr (T.Normal rootType))
69− <$> validForeignType region name False rootType tipe
70−
71−
72−-- CHECK INBOUND AND OUTBOUND TYPES
73−
74−validForeignType
75− :: R.Region
76− -> String
77− -> Bool
78− -> T.Canonical
79− -> T.Canonical
80− -> Result.ResultErr ()
81−validForeignType region name isInbound rootType tipe =
82− let valid localType =
83− validForeignType region name isInbound rootType localType
84−
85− err problem =
86− Result.err $ A.A region $
87− Error.port name isInbound rootType tipe problem
88− in
89− case tipe of
90− T.Aliased _ args t ->
91− valid (T.dealias args t)
92−
93− T.Type v ->
94− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
95− True -> Result.ok ()
96− False -> err Nothing
97−
98− T.App t [] ->
99− valid t
100−
101− T.App (T.Type v) [t]
102− | Var.isMaybe v -> valid t
103− | Var.isArray v -> valid t
104− | Var.isList v -> valid t
105−
106− T.App (T.Type v) ts
107− | Var.isTuple v ->
108− Foldable.traverse_ valid ts
109−
110− T.App _ _ ->
111− err Nothing
112−
113− T.Var _ ->
114− err (Just "a free type variable")
115−
116− T.Lambda _ _ ->
117− err (Just "a function")
118−
119− T.Record _ (Just _) ->
120− err (Just "an extended record")
121−
122− T.Record fields Nothing ->
123− Foldable.traverse_ (\(k,v) -> (,) k <$> valid v) fields
src/Canonicalize/Setup.hs+59−58
@@ -8,7 +8,7 @@ import qualified Data.Maybe as Maybe
8import qualified Data.Traversable as Trav
8import qualified Data.Traversable as Trav
9
9
10import qualified AST.Declaration as D
10import qualified AST.Declaration as D
11−import qualified AST.Effects as Fx
11+import qualified AST.Effects as Effects
12import qualified AST.Expression.Valid as Valid
12import qualified AST.Expression.Valid as Valid
13import qualified AST.Module as Module
13import qualified AST.Module as Module
14import qualified AST.Module.Name as ModuleName
14import qualified AST.Module.Name as ModuleName
@@ -43,7 +43,7 @@ environment importDict interfaces (Module.Module name _ info) =
43 Trav.traverse (importToPatches importDict interfaces) allImports
43 Trav.traverse (importToPatches importDict interfaces) allImports
44
44
45 (typeAliasNodes, declPatches) =
45 (typeAliasNodes, declPatches) =
46− declarationsToPatches name decls
46+ declsToPatches name decls
47
47
48 effectPatches =
48 effectPatches =
49 effectsToPatches name effects
49 effectsToPatches name effects
@@ -306,85 +306,86 @@ addTypeAlias moduleName scc env =
306-- DECLARATIONS TO PATCHES
306-- DECLARATIONS TO PATCHES
307
307
308
308
309−declarationsToPatches :: ModuleName.Canonical -> [D.Valid] -> ([Node], [Env.Patch])
309+{- When canonicalizing, it is important that:
310−declarationsToPatches moduleName decls =
311− let
312− (maybeNodes, patchLists) =
313− unzip (map (declToPatches moduleName) decls)
314− in
315− (Maybe.catMaybes maybeNodes, concat patchLists)
316
310
311+ _adts are fully namespaced (Var.Module ...)
312+ _patterns are fully namespaced (Var.Module ...)
313+ _values that are defined as top-level declarations are (Var.TopLevel ...)
314+ all other _values are local (Var.Local)
317
315
318−-- When canonicalizing, it is important that:
316+-}
319−-- _adts are fully namespaced (Var.Module ...)
320−-- _patterns are fully namespaced (Var.Module ...)
321−-- _values that are defined as top-level declarations are (Var.TopLevel ...)
322−-- all other _values are local (Var.Local)
323−declToPatches :: ModuleName.Canonical -> D.Valid -> (Maybe Node, [Env.Patch])
317+declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])
324−declToPatches moduleName (A.A (region,_) decl) =
318+declsToPatches moduleName (D.Decls defs unions aliases _) =
325 let
319 let
326− topLevel mkPatch x =
327− mkPatch x (Var.topLevel moduleName x)
328
320
329− namespaced mkPatch x =
321+ -- HELPERS
322+
323+ topLevelValue x =
330− mkPatch x (Var.fromModule moduleName x)
324+ Env.Value x (Var.topLevel moduleName x)
331
325
332 patternPatch (name, args) =
326 patternPatch (name, args) =
333 Env.Pattern name (Var.fromModule moduleName name, length args)
327 Env.Pattern name (Var.fromModule moduleName name, length args)
334− in
335− case decl of
336− D.Def def ->
337− ( Nothing
338− , map (topLevel Env.Value) (P.boundVarList (Valid.getPattern def))
339− )
340−
341− D.Union name _ ctors ->
342− let ctorNames = map fst ctors
343− in
344− ( Nothing
345− , namespaced Env.Union name
346− : map (topLevel Env.Value) ctorNames
347− ++ map patternPatch ctors
348− )
349−
350− D.Alias name tvars alias ->
351− ( Just (node region name tvars alias)
352− , case alias of
353− A.A _ (Type.RRecord _ Nothing) ->
354− [topLevel Env.Value name]
355− _ ->
356− []
357− )
358−
359− D.Fixity _ _ _ ->
360− ( Nothing
361− , []
362− )
363
328
329+ -- TO PATCHES
330+
331+ defToPatches (A.A _ (Valid.Def pattern _ _)) =
332+ map topLevelValue (P.boundVarList pattern)
333+
334+ unionToPatches (A.A _ (D.Type name _ ctors)) =
335+ Env.Union name (Var.fromModule moduleName name)
336+ : map topLevelValue (map fst ctors)
337+ ++ map patternPatch ctors
338+
339+ aliasToPatches (A.A _ (D.Type name _ alias)) =
340+ case A.drop alias of
341+ Type.RRecord _ Nothing ->
342+ Just (topLevelValue name)
343+
344+ _ ->
345+ Nothing
346+
347+ -- TO NODES
348+
349+ aliasToNode (A.A (region, _) (D.Type name tvars alias)) =
350+ node region name tvars alias
351+ in
352+ (
353+ map aliasToNode aliases
354+ ,
355+ concat
356+ [ Maybe.mapMaybe aliasToPatches aliases
357+ , concatMap unionToPatches unions
358+ , concatMap defToPatches defs
359+ ]
360+ )
364
361
365
362
366-- EFFECTS TO PATCHES
363-- EFFECTS TO PATCHES
367
364
368
365
369−effectsToPatches :: ModuleName.Canonical -> Fx.Effects -> [Env.Patch]
366+effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]
370effectsToPatches moduleName effects =
367effectsToPatches moduleName effects =
371 case effects of
368 case effects of
372− Fx.None ->
369+ Effects.None ->
373 []
370 []
374
371
375− Fx.Foreign ->
372+ Effects.Foreign foreigns ->
376− []
373+ let
374+ toPatch (A.A _ (Effects.ForeignRaw name _)) =
375+ Env.Value name (Var.topLevel moduleName name)
376+ in
377+ map toPatch foreigns
377
378
378− Fx.Effect info ->
379+ Effects.Manager info ->
379 map (\name -> Env.Value name (Var.topLevel moduleName name)) $
380 map (\name -> Env.Value name (Var.topLevel moduleName name)) $
380− case Fx._type info of
381+ case Effects._managerType info of
381− Fx.CmdManager _ ->
382+ Effects.CmdManager _ ->
382 [ "command" ]
383 [ "command" ]
383
384
384− Fx.SubManager _ ->
385+ Effects.SubManager _ ->
385 [ "subscription" ]
386 [ "subscription" ]
386
387
387− Fx.FxManager _ _ ->
388+ Effects.FxManager _ _ ->
388 [ "command", "subscription" ]
389 [ "command", "subscription" ]
389
390
390
391
src/Canonicalize/Sort.hs+12−6
@@ -96,10 +96,16 @@ reorder (A.A ann expression) =
96 Record
96 Record
97 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
97 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields
98
98
99− Cmd _ _ ->
99+ Cmd _ ->
100 return expression
100 return expression
101
101
102− Sub _ _ ->
102+ Sub _ ->
103+ return expression
104+
105+ ForeignCmd _ _ ->
106+ return expression
107+
108+ ForeignSub _ _ ->
103 return expression
109 return expression
104
110
105 SaveEnv _ _ ->
111 SaveEnv _ _ ->
@@ -120,7 +126,7 @@ reorder (A.A ann expression) =
120 let defss = map Graph.flattenSCC sccs
126 let defss = map Graph.flattenSCC sccs
121
127
122 -- remove let-bound variables from the context
128 -- remove let-bound variables from the context
123− forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do
129+ forM_ defs $ \(Canonical.Def _ pattern _ _) -> do
124 bound pattern
130 bound pattern
125 mapM free (ctors pattern)
131 mapM free (ctors pattern)
126
132
@@ -194,7 +200,7 @@ buildDefGraph defs =
194 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
200 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]
195
201
196 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
202 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]
197− variableToKey (Canonical.Definition _ pattern _ _, key, _) =
203+ variableToKey (Canonical.Def _ pattern _ _, key, _) =
198 [ (var, key) | var <- P.boundVarList pattern ]
204 [ (var, key) | var <- P.boundVarList pattern ]
199
205
200 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
206 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int
@@ -215,7 +221,7 @@ buildDefGraph defs =
215reorderAndGetDependencies
221reorderAndGetDependencies
216 :: Canonical.Def
222 :: Canonical.Def
217 -> State (Set.Set String) (Canonical.Def, [String])
223 -> State (Set.Set String) (Canonical.Def, [String])
218−reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
224+reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =
219 do globalFrees <- get
225 do globalFrees <- get
220 -- work in a fresh environment
226 -- work in a fresh environment
221 put Set.empty
227 put Set.empty
@@ -223,4 +229,4 @@ reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =
223 localFrees <- get
229 localFrees <- get
224 -- merge with global frees
230 -- merge with global frees
225 modify (Set.union globalFrees)
231 modify (Set.union globalFrees)
226− return (Canonical.Definition facts pattern expr' mType, Set.toList localFrees)
232+ return (Canonical.Def facts pattern expr' mType, Set.toList localFrees)
src/Compile.hs+2−1
@@ -2,6 +2,7 @@ module Compile (compile) where
2
2
3import qualified Data.Map as Map
3import qualified Data.Map as Map
4
4
5+import qualified AST.Declaration as D
5import qualified AST.Module as Module
6import qualified AST.Module as Module
6import qualified AST.Module.Name as ModuleName
7import qualified AST.Module.Name as ModuleName
7import qualified Canonicalize
8import qualified Canonicalize
@@ -64,5 +65,5 @@ getOpTable :: Module.Interfaces -> Parse.OpTable
64getOpTable interfaces =
65getOpTable interfaces =
65 Map.elems interfaces
66 Map.elems interfaces
66 |> concatMap Module.iFixities
67 |> concatMap Module.iFixities
67− |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
68+ |> map (\(D.Infix op assoc lvl) -> ( op, (lvl,assoc) ))
68 |> Map.fromList
69 |> Map.fromList
src/Docs/Centralize.hs+56−73
@@ -2,96 +2,79 @@ module Docs.Centralize (centralize) where
2
2
3import Control.Arrow (second)
3import Control.Arrow (second)
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5+import qualified Data.Maybe as Maybe
5
6
6import qualified AST.Declaration as D
7import qualified AST.Declaration as D
7import qualified AST.Expression.Canonical as Canonical
8import qualified AST.Expression.Canonical as Canonical
8−import qualified AST.Pattern as P
9+import qualified AST.Pattern as Pattern
10+import qualified AST.Type as Type
9import qualified Docs.AST as Docs
11import qualified Docs.AST as Docs
10import qualified Elm.Compiler.Type as Type
12import qualified Elm.Compiler.Type as Type
11import qualified Elm.Compiler.Type.Extract as Extract
13import qualified Elm.Compiler.Type.Extract as Extract
12import qualified Reporting.Annotation as A
14import qualified Reporting.Annotation as A
13
15
14
16
17+
15-- CENTRALIZE DOCUMENTATION
18-- CENTRALIZE DOCUMENTATION
16
19
20+
17−centralize :: [D.Canonical] -> String -> Docs.Centralized
21+centralize :: D.Canonical -> String -> Docs.Centralized
18−centralize decls comment =
22+centralize (D.Decls defs unions aliases infixes) comment =
19 let
23 let
20− (Raw aliases types valueInfo fixities) =
24+ infixDict =
21− toRawDocs decls
25+ Map.fromList (map infixToEntry infixes)
26+ in
27+ Docs.Docs
28+ comment
29+ (Map.fromList (map aliasToEntry aliases))
30+ (Map.fromList (map unionToEntry unions))
31+ (Map.fromList (Maybe.mapMaybe (defToEntry infixDict) defs))
32+
33+
34+
35+-- CONVERSION TO DOC ENTRIES
36+
22
37
23− values =
38+defToEntry
24− Map.fromList (map (toValue fixities) (Map.toList valueInfo))
39+ :: Map.Map String (String, Int)
40+ -> A.Commented Canonical.Def
41+ -> Maybe (String, A.Located (Docs.Value (Maybe Type.Type)))
42+defToEntry infixDict (A.A (_, maybeComment) (Canonical.Def _ pattern _ maybeType)) =
43+ case pattern of
44+ A.A subregion (Pattern.Var name) ->
45+ let
46+ value =
47+ Docs.Value
48+ maybeComment
49+ (fmap (Extract.toAliasedType . A.drop) maybeType)
50+ (Map.lookup name infixDict)
51+ in
52+ Just (name, A.A subregion value)
53+
54+ _ ->
55+ Nothing
56+
57+
58+unionToEntry :: A.Commented (D.Union Type.Canonical) -> (String, A.Located Docs.Union)
59+unionToEntry (A.A (region, maybeComment) (D.Type name args ctors)) =
60+ let
61+ ctors' =
62+ map (second (map Extract.toAliasedType)) ctors
25 in
63 in
26− Docs.Docs comment aliases types values
64+ (name, A.A region (Docs.Union maybeComment args ctors'))
27
65
28
66
29−toValue
67+aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)
30− :: Map.Map String (String, Int)
31− -> ( String, A.Located (Maybe String, Maybe Type.Type) )
32− -> ( String, A.Located (Docs.Value (Maybe Type.Type)) )
33−toValue fixities (name, A.A region (maybeComment, maybeType)) =
68+aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =
34 ( name
69 ( name
35− , A.A region (Docs.Value maybeComment maybeType (Map.lookup name fixities))
70+ , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))
36 )
71 )
37
72
38
73
39−-- GATHER INFORMATION
74+infixToEntry :: D.Infix -> (String, (String, Int))
40−
75+infixToEntry (D.Infix name assoc precedence) =
41−data Raw = Raw
42− { rawAliases :: Map.Map String (A.Located Docs.Alias)
43− , rawTypes :: Map.Map String (A.Located Docs.Union)
44− , rawValues :: Map.Map String (A.Located (Maybe String, Maybe Type.Type))
45− , rawFixities :: Map.Map String (String, Int)
46− }
47−
48−
49−toRawDocs :: [D.Canonical] -> Raw
50−toRawDocs decls =
51− foldr addDeclToDocs (Raw Map.empty Map.empty Map.empty Map.empty) decls
52−
53−
54−addDeclToDocs :: D.Canonical -> Raw -> Raw
55−addDeclToDocs (A.A (region,maybeComment) decl) docs =
56− case decl of
57− D.Def (Canonical.Definition _ (A.A subregion (P.Var name)) _ maybeType) ->
58− let
59− info =
60− ( maybeComment
61− , fmap (Extract.toAliasedType . A.drop) maybeType
62− )
63−
64− newValues =
65− Map.insert name (A.A subregion info) (rawValues docs)
66− in
67− docs { rawValues = newValues }
68−
69− D.Def _ ->
70− docs
71−
72− D.Union name args ctors ->
73− let
74− ctors' =
75− map (second (map Extract.toAliasedType)) ctors
76−
77− union =
78− A.A region (Docs.Union maybeComment args ctors')
79− in
80− docs { rawTypes = Map.insert name union (rawTypes docs) }
81−
82− D.Alias name args tipe ->
83− let
76+ let
84− alias =
85− A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))
86− in
87− docs { rawAliases = Map.insert name alias (rawAliases docs) }
88−
89− D.Fixity assoc precedence name ->
90− let
91− fixity =
77+ fixity =
92− (D.assocToString assoc, precedence)
78+ (D.assocToString assoc, precedence)
93− in
79+ in
94− docs
95− { rawFixities =
96− Map.insert name fixity (rawFixities docs)
80+ ( name, fixity )
97− }
src/Generate/JavaScript.hs+8−8
@@ -5,7 +5,7 @@ import qualified Language.ECMAScript3.PrettyPrint as ES
5import qualified Language.ECMAScript3.Syntax as JS
5import qualified Language.ECMAScript3.Syntax as JS
6import qualified Text.PrettyPrint.Leijen as PP
6import qualified Text.PrettyPrint.Leijen as PP
7
7
8−import qualified AST.Effects as Fx
8+import qualified AST.Effects as Effects
9import qualified AST.Module as Module
9import qualified AST.Module as Module
10import qualified AST.Module.Name as ModuleName
10import qualified AST.Module.Name as ModuleName
11import qualified Generate.JavaScript.Expression as JS
11import qualified Generate.JavaScript.Expression as JS
@@ -35,16 +35,16 @@ generate (Module.Module moduleName _ info) =
35-- GENERATE EFFECT MANAGER
35-- GENERATE EFFECT MANAGER
36
36
37
37
38−generateEffectManager :: ModuleName.Canonical -> Fx.Effects -> [JS.Statement ()]
38+generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Statement ()]
39generateEffectManager moduleName effects =
39generateEffectManager moduleName effects =
40 case effects of
40 case effects of
41− Fx.None ->
41+ Effects.None ->
42 []
42 []
43
43
44− Fx.Foreign ->
44+ Effects.Foreign _ ->
45 []
45 []
46
46
47− Fx.Effect (Fx.Info _ _ _ _ managerType) ->
47+ Effects.Manager (Effects.Info _ _ _ _ managerType) ->
48 let
48 let
49 managers =
49 managers =
50 Var.native (ModuleName.inCore ["Native","Platform"]) "globalManagerInfo"
50 Var.native (ModuleName.inCore ["Native","Platform"]) "globalManagerInfo"
@@ -65,13 +65,13 @@ generateEffectManager moduleName effects =
65
65
66 otherEntries =
66 otherEntries =
67 case managerType of
67 case managerType of
68− Fx.CmdManager _ ->
68+ Effects.CmdManager _ ->
69 [ tagEntry "cmd", entry "cmdMap" ]
69 [ tagEntry "cmd", entry "cmdMap" ]
70
70
71− Fx.SubManager _ ->
71+ Effects.SubManager _ ->
72 [ tagEntry "sub", entry "subMap" ]
72 [ tagEntry "sub", entry "subMap" ]
73
73
74− Fx.FxManager _ _ ->
74+ Effects.FxManager _ _ ->
75 [ tagEntry "fx", entry "cmdMap", entry "subMap" ]
75 [ tagEntry "fx", entry "cmdMap", entry "subMap" ]
76
76
77 addManager =
77 addManager =
src/Generate/JavaScript/BuiltIn.hs+20−11
@@ -3,16 +3,15 @@ module Generate.JavaScript.BuiltIn
3 , list, range
3 , list, range
4 , recordUpdate
4 , recordUpdate
5 , eq, cmp
5 , eq, cmp
6− , effect
6+ , effect, foreignCmd, foreignSub
7 , crash
7 , crash
8 )
8 )
9 where
9 where
10
10
11−import Control.Arrow (first)
12import qualified Language.ECMAScript3.Syntax as JS
11import qualified Language.ECMAScript3.Syntax as JS
13
12
14import qualified AST.Module.Name as ModuleName
13import qualified AST.Module.Name as ModuleName
15−import Generate.JavaScript.Helpers
14+import Generate.JavaScript.Helpers ((<|), (==>), call)
16import qualified Generate.JavaScript.Variable as Var
15import qualified Generate.JavaScript.Variable as Var
17import qualified Reporting.Region as R
16import qualified Reporting.Region as R
18
17
@@ -20,12 +19,12 @@ import qualified Reporting.Region as R
20
19
21utils :: String -> [JS.Expression ()] -> JS.Expression ()
20utils :: String -> [JS.Expression ()] -> JS.Expression ()
22utils func args =
21utils func args =
23− Var.native (ModuleName.inCore ["Native","Utils"]) func `call` args
22+ Var.coreNative "Utils" func `call` args
24
23
25
24
26nativeList :: String -> [JS.Expression ()] -> JS.Expression ()
25nativeList :: String -> [JS.Expression ()] -> JS.Expression ()
27nativeList func args =
26nativeList func args =
28− Var.native (ModuleName.inCore ["Native","List"]) func `call` args
27+ Var.coreNative "List" func `call` args
29
28
30
29
31
30
@@ -64,7 +63,7 @@ recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expressio
64recordUpdate record fields =
63recordUpdate record fields =
65 utils "update"
64 utils "update"
66 [ record
65 [ record
67− , JS.ObjectLit () (map (first prop) fields)
66+ , JS.ObjectLit () (map (uncurry (==>)) fields)
68 ]
67 ]
69
68
70
69
@@ -92,6 +91,16 @@ effect effectName =
92 JS.StringLit () (ModuleName.canonicalToString effectName)
91 JS.StringLit () (ModuleName.canonicalToString effectName)
93
92
94
93
94+foreignCmd :: String -> JS.Expression () -> JS.Expression ()
95+foreignCmd name converter =
96+ Var.coreNative "Platform" "foreignCmd" `call` [ JS.StringLit () name, converter ]
97+
98+
99+foreignSub :: String -> JS.Expression () -> JS.Expression ()
100+foreignSub name converter =
101+ Var.coreNative "Platform" "foreignSub" `call` [ JS.StringLit () name, converter ]
102+
103+
95
104
96-- CRASH
105-- CRASH
97
106
@@ -113,14 +122,14 @@ crash home region maybeCaseCrashValue =
113regionToJs :: R.Region -> JS.Expression ()
122regionToJs :: R.Region -> JS.Expression ()
114regionToJs (R.Region start end) =
123regionToJs (R.Region start end) =
115 JS.ObjectLit ()
124 JS.ObjectLit ()
116− [ ( prop "start", positionToJs start )
125+ [ "start" ==> positionToJs start
117− , ( prop "end", positionToJs end )
126+ , "end" ==> positionToJs end
118 ]
127 ]
119
128
120
129
121positionToJs :: R.Position -> JS.Expression ()
130positionToJs :: R.Position -> JS.Expression ()
122positionToJs (R.Position line column) =
131positionToJs (R.Position line column) =
123 JS.ObjectLit ()
132 JS.ObjectLit ()
124− [ ( prop "line", JS.IntLit () line )
133+ [ "line" ==> JS.IntLit () line
125− , ( prop "column", JS.IntLit () column )
134+ , "column" ==> JS.IntLit () column
126− ]
135+ ]
src/Generate/JavaScript/Expression.hs+17−6
@@ -12,6 +12,7 @@ import qualified AST.Module.Name as ModuleName
12import qualified AST.Variable as Var
12import qualified AST.Variable as Var
13import Generate.JavaScript.Helpers as Help
13import Generate.JavaScript.Helpers as Help
14import qualified Generate.JavaScript.BuiltIn as BuiltIn
14import qualified Generate.JavaScript.BuiltIn as BuiltIn
15+import qualified Generate.JavaScript.Foreign as Foreign
15import qualified Generate.JavaScript.Literal as Literal
16import qualified Generate.JavaScript.Literal as Literal
16import qualified Generate.JavaScript.Variable as Var
17import qualified Generate.JavaScript.Variable as Var
17import qualified Optimize.DecisionTree as DT
18import qualified Optimize.DecisionTree as DT
@@ -134,7 +135,7 @@ generateCode expr =
134 let
135 let
135 toField (field, value) =
136 toField (field, value) =
136 do jsValue <- generateJsExpr value
137 do jsValue <- generateJsExpr value
137− return (prop (Var.safe field), jsValue)
138+ return (Var.safe field ==> jsValue)
138 in
139 in
139 do jsFields <- mapM toField fields
140 do jsFields <- mapM toField fields
140 jsExpr $ ObjectLit () jsFields
141 jsExpr $ ObjectLit () jsFields
@@ -186,12 +187,15 @@ generateCode expr =
186 jsExpr $ BuiltIn.list jsElements
187 jsExpr $ BuiltIn.list jsElements
187
188
188 Data tag members ->
189 Data tag members ->
190+ let
191+ ctor =
192+ "ctor" ==> StringLit () tag
193+
194+ toEntry entry n =
195+ ("_" ++ show n) ==> entry
196+ in
189 do jsMembers <- mapM generateJsExpr members
197 do jsMembers <- mapM generateJsExpr members
190− jsExpr $ ObjectLit () (ctor : fields jsMembers)
198+ jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])
191− where
192− ctor = (prop "ctor", StringLit () tag)
193− fields =
194− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]
195
199
196 DataAccess dataExpr index ->
200 DataAccess dataExpr index ->
197 do jsDataExpr <- generateJsExpr dataExpr
201 do jsDataExpr <- generateJsExpr dataExpr
@@ -203,6 +207,13 @@ generateCode expr =
203 Sub moduleName ->
207 Sub moduleName ->
204 jsExpr $ BuiltIn.effect moduleName
208 jsExpr $ BuiltIn.effect moduleName
205
209
210+ ForeignCmd name tipe ->
211+ jsExpr $ BuiltIn.foreignCmd name (Foreign.encode tipe)
212+
213+ ForeignSub name tipe ->
214+ do jsDecoder <- generateJsExpr (Foreign.decode tipe)
215+ jsExpr $ BuiltIn.foreignSub name jsDecoder
216+
206 GLShader _uid src _tipe ->
217 GLShader _uid src _tipe ->
207 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
218 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]
208
219
src/Generate/JavaScript/Foreign.hsnew file+214
@@ -0,0 +1,214 @@
1+module Generate.JavaScript.Foreign (encode, decode) where
2+
3+import qualified Data.List as List
4+import Language.ECMAScript3.Syntax
5+
6+import qualified AST.Expression.Optimized as Opt
7+import qualified AST.Literal as Literal
8+import qualified AST.Type as T
9+import qualified AST.Variable as Var
10+import Generate.JavaScript.Helpers ((<|), (==>), function, ref, var)
11+import qualified Generate.JavaScript.Variable as Var
12+
13+
14+
15+-- ENCODE
16+
17+
18+encode :: T.Canonical -> Expression ()
19+encode tipe =
20+ function ["v"] [ ReturnStmt () (Just (encodeHelp tipe (ref "v"))) ]
21+
22+
23+encodeHelp :: T.Canonical -> Expression () -> Expression ()
24+encodeHelp tipe expr =
25+ case tipe of
26+ T.Aliased _ args t ->
27+ encodeHelp (T.dealias args t) expr
28+
29+ T.Lambda _ _ ->
30+ error "encodeHelp: function"
31+
32+ T.Var _ ->
33+ error "encodeHelp: type variable"
34+
35+ T.Type name
36+ | Var.isPrim "Float" name -> expr
37+ | Var.isPrim "Int" name -> expr
38+ | Var.isPrim "Bool" name -> expr
39+ | Var.isPrim "String" name -> expr
40+ | Var.isJson name -> expr
41+ | Var.isTuple name -> NullLit ()
42+ | otherwise -> error "encodeHelp: bad type"
43+
44+ T.App (T.Type name) [arg]
45+ | Var.isMaybe name -> fromMaybe arg expr
46+ | Var.isList name -> fromList arg expr
47+ | Var.isArray name -> fromArray arg expr
48+ | otherwise -> error "encodeHelp: bad union type"
49+
50+ T.App (T.Type name) args
51+ | Var.isTuple name -> fromTuple args expr
52+
53+ T.App _ _ ->
54+ error "encodeHelp: bad union type"
55+
56+ T.Record _ (Just _) ->
57+ error "encodeHelp: bad record"
58+
59+ T.Record fields Nothing ->
60+ let
61+ convert (name, tipe) =
62+ name ==> encodeHelp tipe (DotRef () expr (var name))
63+ in
64+ ObjectLit () (map convert fields)
65+
66+
67+fromMaybe :: T.Canonical -> Expression () -> Expression ()
68+fromMaybe tipe expr =
69+ CondExpr ()
70+ (InfixExpr () OpStrictEq (DotRef () expr (var "ctor")) (StringLit () "Nothing"))
71+ (NullLit ())
72+ (encodeHelp tipe (DotRef () expr (var "_0")))
73+
74+
75+fromList :: T.Canonical -> Expression () -> Expression ()
76+fromList tipe expr =
77+ let
78+ array =
79+ Var.coreNative "List" "toArray" <| expr
80+ in
81+ DotRef () array (var "map") <| encode tipe
82+
83+
84+fromArray :: T.Canonical -> Expression () -> Expression ()
85+fromArray tipe expr =
86+ let
87+ array =
88+ Var.coreNative "Array" "toJSArray" <| expr
89+ in
90+ DotRef () array (var "map") <| encode tipe
91+
92+
93+fromTuple :: [T.Canonical] -> Expression () -> Expression ()
94+fromTuple types expr =
95+ let
96+ convert subType n =
97+ encodeHelp subType $ DotRef () expr (var ('_':show n))
98+ in
99+ ArrayLit () (zipWith convert types [0..])
100+
101+
102+
103+-- SUBSCRIPTIONS
104+
105+
106+decode :: T.Canonical -> Opt.Expr
107+decode tipe =
108+ case tipe of
109+ T.Lambda _ _ ->
110+ error "functions should not be allowed through input ports"
111+
112+ T.Var _ ->
113+ error "type variables should not be allowed through input ports"
114+
115+ T.Aliased _ args t ->
116+ decode (T.dealias args t)
117+
118+ T.Type name
119+ | Var.isPrim "Float" name -> to "float"
120+ | Var.isPrim "Int" name -> to "int"
121+ | Var.isPrim "Bool" name -> to "bool"
122+ | Var.isPrim "String" name -> to "string"
123+ | Var.isJson name -> to "value"
124+ | Var.isTuple name -> toTuple0
125+ | otherwise -> error "decode: bad type"
126+
127+ T.App (T.Type name) [arg]
128+ | Var.isMaybe name -> toMaybe arg
129+ | Var.isList name -> to "list" <== [decode arg]
130+ | Var.isArray name -> to "array" <== [decode arg]
131+ | otherwise -> error "decode: bad union type"
132+
133+ T.App (T.Type name) args
134+ | Var.isTuple name -> toTuple args
135+
136+ T.App _ _ ->
137+ error "decode: bad union type"
138+
139+ T.Record _ (Just _) ->
140+ error "decode: bad record"
141+
142+ T.Record fields Nothing ->
143+ toRecord fields
144+
145+
146+-- DECODE HELPERS
147+
148+
149+inJsonDecode :: String -> Var.Canonical
150+inJsonDecode name =
151+ Var.inCore ["Json","Decode"] name
152+
153+
154+to :: String -> Opt.Expr
155+to name =
156+ Opt.Var (inJsonDecode name)
157+
158+
159+(=:) :: String -> Opt.Expr -> Opt.Expr
160+(=:) name decoder =
161+ Opt.Binop (inJsonDecode ":=") (Opt.Literal (Literal.Str name)) decoder
162+
163+
164+(<==) :: Opt.Expr -> [Opt.Expr] -> Opt.Expr
165+(<==) func args =
166+ Opt.Call func args
167+
168+
169+
170+-- COMPLEX DECODE HELPERS
171+
172+
173+toMaybe :: T.Canonical -> Opt.Expr
174+toMaybe tipe =
175+ let
176+ maybe tag =
177+ Opt.Var (Var.inCore ["Maybe"] tag)
178+ in
179+ to "oneOf" <==
180+ [ to "null" <== [ maybe "Nothing" ]
181+ , to "map" <== [ maybe "Just", decode tipe ]
182+ ]
183+
184+
185+toTuple0 :: Opt.Expr
186+toTuple0 =
187+ to "null" <== [Opt.Var (Var.builtin "_Tuple0")]
188+
189+
190+toTuple :: [T.Canonical] -> Opt.Expr
191+toTuple types =
192+ let
193+ size =
194+ length types
195+ in
196+ to ("tuple" ++ show size) <== map decode types
197+
198+
199+toRecord :: [(String, T.Canonical)] -> Opt.Expr
200+toRecord fields =
201+ let
202+ keys =
203+ map fst fields
204+
205+ toField key =
206+ (key, Opt.Var (Var.local key))
207+
208+ rootExpr =
209+ to "succeed" <== [ Opt.Function keys (Opt.Record (map toField keys)) ]
210+
211+ andMap root (key, tipe) =
212+ to "andMap" <== [ root, key =: decode tipe ]
213+ in
214+ List.foldl' andMap rootExpr fields
src/Generate/JavaScript/Helpers.hs+3−26
@@ -33,9 +33,9 @@ ref name =
33 VarRef () (var name)
33 VarRef () (var name)
34
34
35
35
36−prop :: String -> Prop ()
36+(==>) :: String -> Expression () -> (Prop (), Expression ())
37−prop name =
37+(==>) name expr =
38− PropId () (var name)
38+ ( PropId () (var name), expr )
39
39
40
40
41obj :: [String] -> Expression ()
41obj :: [String] -> Expression ()
@@ -66,26 +66,3 @@ call :: Expression () -> [Expression ()] -> Expression ()
66call =
66call =
67 CallExpr ()
67 CallExpr ()
68
68
69−
70−
71−-- Checks
72−
73−
74−equal :: Expression () -> Expression () -> Expression ()
75−equal a b =
76− InfixExpr () OpStrictEq a b
77−
78−
79−instanceof :: String -> Expression () -> Expression ()
80−instanceof tipe x =
81− InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))
82−
83−
84−typeof :: String -> Expression () -> Expression ()
85−typeof tipe x =
86− equal (PrefixExpr () PrefixTypeof x) (StringLit () tipe)
87−
88−
89−member :: String -> Expression () -> Expression ()
90−member field x =
91− InfixExpr () OpIn (StringLit () field) x
src/Generate/JavaScript/Port.hsdeleted−299
@@ -1,299 +0,0 @@
1−module Generate.JavaScript.Port (inbound, outbound, task) where
2−
3−import qualified Data.List as List
4−import qualified Data.Map as Map
5−import Language.ECMAScript3.Syntax
6−
7−import qualified AST.Type as T
8−import qualified AST.Variable as Var
9−import Generate.JavaScript.Helpers
10−import qualified Reporting.Render.Type as RenderType
11−
12−
13−-- TASK
14−
15−task :: String -> Expression () -> T.Port t -> Expression ()
16−task name expr portType =
17− case portType of
18− T.Normal _ ->
19− _Task "perform" `call` [ expr ]
20−
21− T.Signal _ _ ->
22− _Task "performSignal" `call` [ StringLit () name, expr ]
23−
24−
25−
26−-- HELPERS
27−
28−data JSType
29− = JSNumber
30− | JSInt
31− | JSBoolean
32− | JSString
33− | JSArray
34− | JSObject [String]
35−
36−
37−typeToString :: JSType -> String
38−typeToString tipe =
39− case tipe of
40− JSNumber -> "a number"
41− JSInt -> "an integer"
42− JSBoolean -> "a boolean (true or false)"
43− JSString -> "a string"
44− JSArray -> "an array"
45− JSObject fields ->
46− "an object with fields `" ++ List.intercalate "`, `" fields ++ "`"
47−
48−
49−_Array :: String -> Expression ()
50−_Array functionName =
51− useLazy ["Elm","Native","Array"] functionName
52−
53−
54−_List :: String -> Expression ()
55−_List functionName =
56− useLazy ["Elm","Native","List"] functionName
57−
58−
59−_Maybe :: String -> Expression ()
60−_Maybe functionName =
61− useLazy ["Elm","Maybe"] functionName
62−
63−
64−_Port :: String -> Expression ()
65−_Port functionName =
66− useLazy ["Elm","Native","Port"] functionName
67−
68−
69−_Task :: String -> Expression ()
70−_Task functionName =
71− useLazy ["Elm","Native","Task"] functionName
72−
73−
74−check :: Expression () -> JSType -> Expression () -> Expression ()
75−check x jsType continue =
76− CondExpr () (jsFold OpLOr checks x) continue throw
77− where
78− jsFold op checks value =
79− foldl1 (InfixExpr () op) (map ($ value) checks)
80−
81− throw =
82− obj ["_U","badPort"] `call` [ StringLit () (typeToString jsType), x ]
83−
84− checks =
85− case jsType of
86− JSNumber ->
87− [typeof "number"]
88−
89− JSInt ->
90− [jsFold OpLAnd intChecks]
91−
92− JSBoolean ->
93− [typeof "boolean"]
94−
95− JSString ->
96− [typeof "string", instanceof "String"]
97−
98− JSArray ->
99− [instanceof "Array"]
100−
101− JSObject fields ->
102− [jsFold OpLAnd (typeof "object" : map member fields)]
103−
104−
105−intChecks :: [Expression () -> Expression ()]
106−intChecks =
107− [ typeof "number"
108− , \x -> ref "isFinite" <| x
109− , \x -> equal (obj ["Math","floor"] <| x) x
110− ]
111−
112−
113−-- INBOUND
114−
115−inbound :: String -> T.Port T.Canonical -> Expression ()
116−inbound name portType =
117− case portType of
118− T.Normal tipe ->
119− _Port "inbound" `call`
120− [ StringLit () name
121− , StringLit () (show (RenderType.toDoc Map.empty tipe))
122− , toTypeFunction tipe
123− ]
124−
125− T.Signal _root arg ->
126− _Port "inboundSignal" `call`
127− [ StringLit () name
128− , StringLit () (show (RenderType.toDoc Map.empty arg))
129− , toTypeFunction arg
130− ]
131−
132−
133−toTypeFunction :: T.Canonical -> Expression ()
134−toTypeFunction tipe =
135− function ["v"] [ ReturnStmt () (Just (toType tipe (ref "v"))) ]
136−
137−
138−toType :: T.Canonical -> Expression () -> Expression ()
139−toType tipe x =
140− case tipe of
141− T.Lambda _ _ ->
142− error "functions should not be allowed through input ports"
143−
144− T.Var _ ->
145− error "type variables should not be allowed through input ports"
146−
147− T.Aliased _ args t ->
148− toType (T.dealias args t) x
149−
150− T.Type (Var.Canonical Var.BuiltIn name)
151− | name == "Float" -> from JSNumber
152− | name == "Int" -> from JSInt
153− | name == "Bool" -> from JSBoolean
154− | name == "String" -> from JSString
155− where
156− from checks = check x checks x
157−
158− T.Type name
159− | Var.isJson name ->
160− x
161−
162− | Var.isTuple name ->
163− toTuple [] x
164−
165− | otherwise ->
166− error "bad type got to foreign input conversion"
167−
168− T.App f args ->
169− case f : args of
170− T.Type name : [t]
171− | Var.isMaybe name ->
172− CondExpr ()
173− (equal x (NullLit ()))
174− (_Maybe "Nothing")
175− (_Maybe "Just" <| toType t x)
176−
177− | Var.isList name ->
178− check x JSArray (_List "fromArray" <| array)
179−
180− | Var.isArray name ->
181− check x JSArray (_Array "fromJSArray" <| array)
182− where
183− array = DotRef () x (var "map") <| toTypeFunction t
184−
185− T.Type name : ts
186− | Var.isTuple name ->
187− toTuple ts x
188−
189− _ -> error "bad ADT got to foreign input conversion"
190−
191− T.Record _ (Just _) ->
192− error "bad record got to foreign input conversion"
193−
194− T.Record fields Nothing ->
195− check x (JSObject (map fst fields)) object
196− where
197− object = ObjectLit () $ (prop "_", ObjectLit () []) : keys
198− keys = map convert fields
199− convert (f,t) = (prop f, toType t (DotRef () x (var f)))
200−
201−
202−toTuple :: [T.Canonical] -> Expression () -> Expression ()
203−toTuple types x =
204− check x JSArray (ObjectLit () fields)
205− where
206− fields =
207− (prop "ctor", ctor) : zipWith convert [0..] types
208−
209− ctor =
210− StringLit () ("_Tuple" ++ show (length types))
211−
212− convert n t =
213− ( prop ('_':show n)
214− , toType t (BracketRef () x (IntLit () n))
215− )
216−
217−
218−-- OUTBOUND
219−
220−outbound :: String -> Expression () -> T.Port T.Canonical -> Expression ()
221−outbound name expr portType =
222− case portType of
223− T.Normal tipe ->
224− _Port "outbound" `call` [ StringLit () name, fromTypeFunction tipe, expr ]
225−
226− T.Signal _ arg ->
227− _Port "outboundSignal" `call` [ StringLit () name, fromTypeFunction arg, expr ]
228−
229−
230−fromTypeFunction :: T.Canonical -> Expression ()
231−fromTypeFunction tipe =
232− function ["v"] [ ReturnStmt () (Just (fromType tipe (ref "v"))) ]
233−
234−
235−fromType :: T.Canonical -> Expression () -> Expression ()
236−fromType tipe x =
237− case tipe of
238− T.Aliased _ args t ->
239− fromType (T.dealias args t) x
240−
241− T.Lambda _ _
242− | numArgs > 1 && numArgs < 10 ->
243− func (ref ('A':show numArgs) `call` (x:values))
244− | otherwise ->
245− func (foldl (<|) x values)
246− where
247− ts = T.collectLambdas tipe
248− numArgs = length ts - 1
249− args = map (\n -> '_' : show n) [0..]
250− values = zipWith toType (init ts) (map ref args)
251− func body =
252− function (take numArgs args)
253− [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]
254− , ReturnStmt () (Just (fromType (last ts) (ref "_r")))
255− ]
256−
257− T.Var _ ->
258− error "type variables should not be allowed through outputs"
259−
260− T.Type (Var.Canonical Var.BuiltIn name)
261− | name `elem` ["Int","Float","Bool","String"] ->
262− x
263−
264− T.Type name
265− | Var.isJson name -> x
266− | Var.isTuple name -> ArrayLit () []
267− | otherwise -> error "bad type got to an output"
268−
269− T.App f args ->
270− case f : args of
271− T.Type name : [t]
272− | Var.isMaybe name ->
273− CondExpr ()
274− (equal (DotRef () x (var "ctor")) (StringLit () "Nothing"))
275− (NullLit ())
276− (fromType t (DotRef () x (var "_0")))
277−
278− | Var.isArray name ->
279− DotRef () (_Array "toJSArray" <| x) (var "map") <| fromTypeFunction t
280−
281− | Var.isList name ->
282− DotRef () (_List "toArray" <| x) (var "map") <| fromTypeFunction t
283−
284− T.Type name : ts
285− | Var.isTuple name ->
286− let convert n t = fromType t $ DotRef () x $ var ('_':show n)
287− in ArrayLit () $ zipWith convert [0..] ts
288−
289− _ -> error "bad ADT got to an output"
290−
291− T.Record _ (Just _) ->
292− error "bad record got to an output"
293−
294− T.Record fields Nothing ->
295− ObjectLit () keys
296− where
297− keys = map convert fields
298− convert (f,t) =
299− (PropId () (var f), fromType t (DotRef () x (var f)))
src/Generate/JavaScript/Variable.hs+6
@@ -4,6 +4,7 @@ module Generate.JavaScript.Variable
4 , canonical
4 , canonical
5 , qualified
5 , qualified
6 , native
6 , native
7+ , coreNative
7 , define
8 , define
8 , safe
9 , safe
9 )
10 )
@@ -106,6 +107,11 @@ native moduleName name =
106 JS.obj [ moduleToString moduleName, name ]
107 JS.obj [ moduleToString moduleName, name ]
107
108
108
109
110+coreNative :: String -> String -> JS.Expression ()
111+coreNative moduleName name =
112+ native (ModuleName.inCore ["Native",moduleName]) name
113+
114+
109getOpsDictName :: Var.Home -> String
115getOpsDictName :: Var.Home -> String
110getOpsDictName home =
116getOpsDictName home =
111 let
117 let
src/Nitpick/PatternMatches.hs+9−3
@@ -161,7 +161,7 @@ checkExpression tagDict (A.A region expression) =
161 go body
161 go body
162 <* F.traverse_ goDef defs
162 <* F.traverse_ goDef defs
163 where
163 where
164− goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =
164+ goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =
165 checkPatterns tagDict patRegion Error.LetBound [pattern]
165 checkPatterns tagDict patRegion Error.LetBound [pattern]
166 <* go expr
166 <* go expr
167
167
@@ -183,10 +183,16 @@ checkExpression tagDict (A.A region expression) =
183 E.Record fields ->
183 E.Record fields ->
184 F.traverse_ (go . snd) fields
184 F.traverse_ (go . snd) fields
185
185
186− E.Cmd _ _ ->
186+ E.Cmd _ ->
187 Result.ok ()
187 Result.ok ()
188
188
189− E.Sub _ _ ->
189+ E.Sub _ ->
190+ Result.ok ()
191+
192+ E.ForeignCmd _ _ ->
193+ Result.ok ()
194+
195+ E.ForeignSub _ _ ->
190 Result.ok ()
196 Result.ok ()
191
197
192 E.SaveEnv _ _ ->
198 E.SaveEnv _ _ ->
src/Nitpick/TopLevelTypes.hs+7−7
@@ -26,10 +26,10 @@ import qualified Reporting.Warning as Warning
26
26
27topLevelTypes
27topLevelTypes
28 :: Map.Map String Type.Canonical
28 :: Map.Map String Type.Canonical
29− -> [Decl.Valid]
29+ -> Decl.Valid
30 -> Result.Result Warning.Warning Error.Error ()
30 -> Result.Result Warning.Warning Error.Error ()
31−topLevelTypes typeEnv validDecls =
31+topLevelTypes typeEnv (Decl.Decls defs _ _ _) =
32− do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing validDecls
32+ do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing defs
33 maybe (return ()) (checkMainType typeEnv) maybeMainRegion
33 maybe (return ()) (checkMainType typeEnv) maybeMainRegion
34
34
35
35
@@ -40,11 +40,11 @@ topLevelTypes typeEnv validDecls =
40warnMissingAnnotation
40warnMissingAnnotation
41 :: Map.Map String Type.Canonical
41 :: Map.Map String Type.Canonical
42 -> Maybe R.Region
42 -> Maybe R.Region
43− -> Decl.Valid
43+ -> A.Commented Valid.Def
44 -> Result.Result Warning.Warning Error.Error (Maybe R.Region)
44 -> Result.Result Warning.Warning Error.Error (Maybe R.Region)
45−warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) decl) =
45+warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =
46− case decl of
46+ case def of
47− Decl.Def (Valid.Definition (A.A _ (P.Var name)) _ maybeType) ->
47+ Valid.Def (A.A _ (P.Var name)) _ maybeType ->
48 do when (Maybe.isNothing maybeType) $
48 do when (Maybe.isNothing maybeType) $
49 Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name))
49 Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name))
50
50
src/Optimize.hs+9−3
@@ -53,7 +53,7 @@ flattenLets defs annExpr@(A.A _ expr) =
53
53
54
54
55optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
55optimizeDef :: Bool -> Can.Def -> Env.Optimizer [Opt.Def]
56−optimizeDef isRoot (Can.Definition (Can.Facts deps) pattern expression _) =
56+optimizeDef isRoot (Can.Def (Can.Facts deps) pattern expression _) =
57 let
57 let
58 (args, canBody) =
58 (args, canBody) =
59 Expr.collectLambdas expression
59 Expr.collectLambdas expression
@@ -301,12 +301,18 @@ optimizeExpr context annExpr@(A.A region expression) =
301 Opt.Record
301 Opt.Record
302 <$> T.traverse (mapSnd justConvert) fields
302 <$> T.traverse (mapSnd justConvert) fields
303
303
304− Expr.Cmd moduleName _ ->
304+ Expr.Cmd moduleName ->
305 pure (Opt.Cmd moduleName)
305 pure (Opt.Cmd moduleName)
306
306
307− Expr.Sub moduleName _ ->
307+ Expr.Sub moduleName ->
308 pure (Opt.Sub moduleName)
308 pure (Opt.Sub moduleName)
309
309
310+ Expr.ForeignCmd name tipe ->
311+ pure (Opt.ForeignCmd name tipe)
312+
313+ Expr.ForeignSub name tipe ->
314+ pure (Opt.ForeignSub name tipe)
315+
310 Expr.SaveEnv _ _ ->
316 Expr.SaveEnv _ _ ->
311 error "save_the_environment should never make it to optimization phase"
317 error "save_the_environment should never make it to optimization phase"
312
318
src/Optimize/Inline.hs+12
@@ -175,6 +175,12 @@ count expression =
175 Sub _ ->
175 Sub _ ->
176 Map.empty
176 Map.empty
177
177
178+ ForeignCmd _ _ ->
179+ Map.empty
180+
181+ ForeignSub _ _ ->
182+ Map.empty
183+
178 GLShader _ _ _ ->
184 GLShader _ _ _ ->
179 Map.empty
185 Map.empty
180
186
@@ -280,6 +286,12 @@ replace substitutions expression =
280 Sub _ ->
286 Sub _ ->
281 expression
287 expression
282
288
289+ ForeignCmd _ _ ->
290+ expression
291+
292+ ForeignSub _ _ ->
293+ expression
294+
283 GLShader _ _ _ ->
295 GLShader _ _ _ ->
284 expression
296 expression
285
297
src/Parse/Declaration.hs+22−6
@@ -16,6 +16,7 @@ declaration =
16 choice
16 choice
17 [ typeDecl
17 [ typeDecl
18 , infixDecl
18 , infixDecl
19+ , foreignDecl
19 , definition
20 , definition
20 ]
21 ]
21
22
@@ -32,7 +33,7 @@ commentOr parser =
32-- TYPE ANNOTATIONS and DEFINITIONS
33-- TYPE ANNOTATIONS and DEFINITIONS
33
34
34
35
35−definition :: IParser Decl.Source'
36+definition :: IParser Decl.Raw
36definition =
37definition =
37 do def <- Expr.def <?> "a value definition"
38 do def <- Expr.def <?> "a value definition"
38 return $ Decl.Def def
39 return $ Decl.Def def
@@ -42,7 +43,7 @@ definition =
42-- TYPE ALIAS and UNION TYPES
43-- TYPE ALIAS and UNION TYPES
43
44
44
45
45−typeDecl :: IParser Decl.Source'
46+typeDecl :: IParser Decl.Raw
46typeDecl =
47typeDecl =
47 do try (reserved "type") <?> "a type declaration"
48 do try (reserved "type") <?> "a type declaration"
48 forcedWS
49 forcedWS
@@ -55,18 +56,18 @@ typeDecl =
55 case isAlias of
56 case isAlias of
56 Just _ ->
57 Just _ ->
57 do tipe <- Type.expr <?> "a type"
58 do tipe <- Type.expr <?> "a type"
58− return $ Decl.Alias name args tipe
59+ return $ Decl.Alias (Decl.Type name args tipe)
59
60
60 Nothing ->
61 Nothing ->
61 do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
62 do tcs <- pipeSep1 Type.constructor <?> "a constructor for a union type"
62− return $ Decl.Union name args tcs
63+ return $ Decl.Union (Decl.Type name args tcs)
63
64
64
65
65
66
66-- INFIX
67-- INFIX
67
68
68
69
69−infixDecl :: IParser Decl.Source'
70+infixDecl :: IParser Decl.Raw
70infixDecl =
71infixDecl =
71 expecting "an infix declaration" $
72 expecting "an infix declaration" $
72 do assoc <-
73 do assoc <-
@@ -79,5 +80,20 @@ infixDecl =
79 n <- digit
80 n <- digit
80 forcedWS
81 forcedWS
81 op <- anyOp
82 op <- anyOp
82− return $ Decl.Fixity assoc (read [n]) op
83+ return $ Decl.Fixity (Decl.Infix op assoc (read [n]))
84+
85+
86+
87+-- FOREIGN
88+
89+
90+foreignDecl :: IParser Decl.Raw
91+foreignDecl =
92+ expecting "a foreign declaration" $
93+ do try (reserved "foreign")
94+ forcedWS
95+ name <- Help.lowVar
96+ padded hasType
97+ tipe <- Type.expr
98+ return $ Decl.Foreign name tipe
83
99
src/Parse/Parse.hs+1−1
@@ -137,7 +137,7 @@ parseFixities =
137 where
137 where
138 infics =
138 infics =
139 do start <- getMyPosition
139 do start <- getMyPosition
140− (Decl.Fixity assoc level op) <- Parse.infixDecl
140+ (Decl.Fixity (Decl.Infix op assoc level)) <- Parse.infixDecl
141 end <- getMyPosition
141 end <- getMyPosition
142 return (op, InfixInfo (R.Region start end) (level, assoc))
142 return (op, InfixInfo (R.Region start end) (level, assoc))
143
143
src/Reporting/Error/Canonicalize.hs+32−37
@@ -22,7 +22,7 @@ data Error
22 | Import ModuleName.Raw ImportError
22 | Import ModuleName.Raw ImportError
23 | Export String [String]
23 | Export String [String]
24 | DuplicateExport String
24 | DuplicateExport String
25− | Port PortError
25+ | Foreign ForeignError
26
26
27
27
28
28
@@ -100,24 +100,18 @@ alias name expected actual =
100-- PORTS
100-- PORTS
101
101
102
102
103−data PortError = PortError
103+data ForeignError =
104− { portName :: String
104+ ForeignError
105− , portIsInbound :: Bool
105+ { foreignName :: String
106− , portRootType :: Type.Canonical
106+ , foreignKind :: String
107− , portLocalType :: Type.Canonical
107+ , foreignType :: Type.Canonical
108− , portMessage :: Maybe String
108+ , foreignMessage :: Maybe String
109 }
109 }
110
110
111
111
112−port
113− :: String
114− -> Bool
115− -> Type.Canonical
112+foreign :: String -> String -> Type.Canonical -> Maybe String -> Error
116− -> Type.Canonical
117− -> Maybe String
118− -> Error
119−port name isInbound rootType localType maybeMessage =
113+foreign name kind tipe maybeMessage =
120− Port (PortError name isInbound rootType localType maybeMessage)
114+ Foreign (ForeignError name kind tipe maybeMessage)
121
115
122
116
123
117
@@ -228,26 +222,27 @@ toReport localizer err =
228 ("You are trying to export `" ++ name ++ "` multiple times!")
222 ("You are trying to export `" ++ name ++ "` multiple times!")
229 "Remove duplicates until there is only one listed."
223 "Remove duplicates until there is only one listed."
230
224
231− Port (PortError name isInbound _rootType localType maybeMessage) ->
225+ Foreign (ForeignError name kind tipe maybeMessage) ->
232− let
226+ let
233− boundPort =
227+ context =
234− if isInbound then "inbound port" else "outbound port"
228+ maybe "" (" the following " ++ ) maybeMessage
235− in
229+ in
236− Report.report
230+ Report.report
237− "PORT ERROR"
231+ "FOREIGN ERROR"
238− Nothing
232+ Nothing
233+ ("Only certain types can flow in and out of Elm. The `"
239− ("Trying to send " ++ maybe "an unsupported type" id maybeMessage
234+ ++ name ++ "` " ++ kind ++ " is trying to communicate an unsupported type."
240− ++ " through " ++ boundPort ++ " `" ++ name ++ "`"
241− )
235+ )
242− ( Help.stack
236+ ( Help.stack
243− [ text "The specific unsupported type is:"
237+ [ text ("The specific unsupported type is" ++ context ++ ":")
244− , indent 4 (RenderType.toDoc localizer localType)
238+ , indent 4 (RenderType.toDoc localizer tipe)
245− , text ("The types of values that can flow through " ++ boundPort ++ "s include:")
239+ , text "The types of values that can flow through in and out of Elm include:"
246− , indent 4 $ Help.reflowParagraph $
240+ , indent 4 $ Help.reflowParagraph $
247− "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
241+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\
248− \ Tuples, Json.Values, and concrete records."
242+ \ Tuples, Json.Values, and concrete records."
243+ -- TODO add a note about custom decoders and encoders when they exist!
249− ]
244+ ]
250− )
245+ )
251
246
252
247
253argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report
248argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report
@@ -292,7 +287,7 @@ extractSuggestions err =
292 DuplicateExport _ ->
287 DuplicateExport _ ->
293 Nothing
288 Nothing
294
289
295− Port _ ->
290+ Foreign _ ->
296 Nothing
291 Nothing
297
292
298
293
src/Reporting/Error/Syntax.hs+16−23
@@ -16,8 +16,6 @@ data Error
16 | BadFunctionName Int
16 | BadFunctionName Int
17 | BadPattern String
17 | BadPattern String
18
18
19− | CommentAfterAnnotation String
20− | CommentOnComment
21 | CommentOnNothing
19 | CommentOnNothing
22
20
23 | SettingsOnNormalModule
21 | SettingsOnNormalModule
@@ -26,6 +24,7 @@ data Error
26 | BadSettingOnEffectModule String
24 | BadSettingOnEffectModule String
27 | NoSettingsOnEffectModule
25 | NoSettingsOnEffectModule
28 | MissingManagerOnEffectModule String
26 | MissingManagerOnEffectModule String
27+ | UnexpectedForeign String
29
28
30 | InfixDuplicate String
29 | InfixDuplicate String
31 | TypeWithoutDefinition String
30 | TypeWithoutDefinition String
@@ -74,34 +73,17 @@ toReport _localizer err =
74 ]
73 ]
75 )
74 )
76
75
77− CommentAfterAnnotation name ->
76+ CommentOnNothing ->
78− Report.report
79− "STRAY COMMENT"
80− Nothing
81− ("The type annotation for `" ++ name ++ "` is followed by a documentation comment.")
82− ( Help.reflowParagraph $
83− "Documentation comments need to be *before* type annotations. Furthermore,\
84− \ type annotations need to be right above the corresponding definition, no\
85− \ comments in between."
86− )
87−
88− CommentOnComment ->
89 Report.report
77 Report.report
90 "STRAY COMMENT"
78 "STRAY COMMENT"
91 Nothing
79 Nothing
92− ("This comment is followed by another documentation comment.")
80+ ("This documentation comment is not followed by anything.")
93 ( Help.reflowParagraph $
81 ( Help.reflowParagraph $
94 "All documentation comments need to be right above the declaration they\
82 "All documentation comments need to be right above the declaration they\
95− \ describe. Maybe some code got deleted or commented out by accident?"
83+ \ describe. Maybe some code got deleted or commented out by accident? Or\
84+ \ maybe this comment is here by accident?"
96 )
85 )
97
86
98− CommentOnNothing ->
99− Report.report
100− "STRAY COMMENT"
101− Nothing
102− ("This documentation comment is not followed by anything.")
103− ( text "What is it documenting? Maybe it should just be removed?" )
104−
105 SettingsOnNormalModule ->
87 SettingsOnNormalModule ->
106 Report.report
88 Report.report
107 "BAD MODULE DECLARATION"
89 "BAD MODULE DECLARATION"
@@ -168,6 +150,17 @@ toReport _localizer err =
168 \ <TODO> (please forgive me if I forgot to fill this in!)"
150 \ <TODO> (please forgive me if I forgot to fill this in!)"
169 )
151 )
170
152
153+ UnexpectedForeign name ->
154+ Report.report
155+ "BAD FOREIGN"
156+ Nothing
157+ ("You are declaring foreign effect " ++ Help.functionName name ++ " in a normal module.")
158+ ( Help.reflowParagraph $
159+ "All foreign effects must be defined in a `foreign effect module`. You should\
160+ \ probably have just one of these for your project. This way all of your foreign\
161+ \ interactions stay relatively organized."
162+ )
163+
171 InfixDuplicate opName ->
164 InfixDuplicate opName ->
172 Report.report
165 Report.report
173 "INFIX OVERLAP"
166 "INFIX OVERLAP"
src/Type/Constrain/Effects.hs+11−11
@@ -3,7 +3,7 @@ module Type.Constrain.Effects (constrain) where
3
3
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5
5
6−import qualified AST.Effects as Fx
6+import qualified AST.Effects as Effects
7import qualified AST.Module.Name as ModuleName
7import qualified AST.Module.Name as ModuleName
8import qualified Reporting.Annotation as A
8import qualified Reporting.Annotation as A
9import qualified Reporting.Error.Type as Error
9import qualified Reporting.Error.Type as Error
@@ -17,26 +17,26 @@ import Type.Type
17constrain
17constrain
18 :: Env.Environment
18 :: Env.Environment
19 -> ModuleName.Canonical
19 -> ModuleName.Canonical
20− -> Fx.Effects
20+ -> Effects.Canonical
21 -> IO TypeConstraint
21 -> IO TypeConstraint
22constrain env moduleName effects =
22constrain env moduleName effects =
23 case effects of
23 case effects of
24− Fx.None ->
24+ Effects.None ->
25 return CSaveEnv
25 return CSaveEnv
26
26
27− Fx.Foreign ->
27+ Effects.Foreign _ ->
28 return CSaveEnv
28 return CSaveEnv
29
29
30− Fx.Effect info ->
30+ Effects.Manager info ->
31 constrainHelp env moduleName info
31 constrainHelp env moduleName info
32
32
33
33
34constrainHelp
34constrainHelp
35 :: Env.Environment
35 :: Env.Environment
36 -> ModuleName.Canonical
36 -> ModuleName.Canonical
37− -> Fx.Info
37+ -> Effects.Info
38 -> IO TypeConstraint
38 -> IO TypeConstraint
39−constrainHelp env moduleName (Fx.Info tagRegion r0 r1 r2 managerType) =
39+constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =
40 let
40 let
41 task t =
41 task t =
42 Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t
42 Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t
@@ -89,7 +89,7 @@ constrainHelp env moduleName (Fx.Info tagRegion r0 r1 r2 managerType) =
89addEffectArgs
89addEffectArgs
90 :: Env.Environment
90 :: Env.Environment
91 -> ModuleName.Canonical
91 -> ModuleName.Canonical
92− -> Fx.ManagerType
92+ -> Effects.ManagerType
93 -> Variable
93 -> Variable
94 -> Type
94 -> Type
95 -> Type
95 -> Type
@@ -103,12 +103,12 @@ addEffectArgs env moduleName managerType msg result =
103 (Env.getType env (toTypeName fxName) <| VarN msg)
103 (Env.getType env (toTypeName fxName) <| VarN msg)
104 in
104 in
105 case managerType of
105 case managerType of
106− Fx.CmdManager cmd ->
106+ Effects.CmdManager cmd ->
107 effectList cmd ==> result
107 effectList cmd ==> result
108
108
109− Fx.SubManager sub ->
109+ Effects.SubManager sub ->
110 effectList sub ==> result
110 effectList sub ==> result
111
111
112− Fx.FxManager cmd sub ->
112+ Effects.FxManager cmd sub ->
113 effectList cmd ==> effectList sub ==> result
113 effectList cmd ==> effectList sub ==> result
114
114
src/Type/Constrain/Expression.hs+25−19
@@ -37,15 +37,17 @@ constrain env annotatedExpr@(A.A region expression) tipe =
37 E.Literal lit ->
37 E.Literal lit ->
38 Literal.constrain env region lit tipe
38 Literal.constrain env region lit tipe
39
39
40− E.Cmd moduleName typeName ->
40+ E.Cmd _ ->
41− do (vars, cmd) <-
41+ return CTrue
42− Env.instantiateType env (ST.cmd moduleName typeName) Map.empty
43− return $ ex vars (CEqual (Error.Instance "command") region cmd tipe)
44
42
45− E.Sub moduleName typeName ->
43+ E.Sub _ ->
46− do (vars, sub) <-
44+ return CTrue
47− Env.instantiateType env (ST.sub moduleName typeName) Map.empty
45+
48− return $ ex vars (CEqual (Error.Instance "subscription") region sub tipe)
46+ E.ForeignCmd _ _ ->
47+ return CTrue
48+
49+ E.ForeignSub _ _ ->
50+ return CTrue
49
51
50 E.SaveEnv moduleName effects ->
52 E.SaveEnv moduleName effects ->
51 Effects.constrain env moduleName effects
53 Effects.constrain env moduleName effects
@@ -462,7 +464,7 @@ collectPairs index items =
462
464
463
465
464expandPattern :: Canonical.Def -> [Canonical.Def]
466expandPattern :: Canonical.Def -> [Canonical.Def]
465−expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
467+expandPattern def@(Canonical.Def facts lpattern expr maybeType) =
466 let
468 let
467 (A.A patternRegion pattern) =
469 (A.A patternRegion pattern) =
468 lpattern
470 lpattern
@@ -474,23 +476,27 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =
474 _ ->
476 _ ->
475 mainDef : map toDef vars
477 mainDef : map toDef vars
476 where
478 where
479+ vars =
477− vars = P.boundVarList lpattern
480+ P.boundVarList lpattern
478
481
479− combinedName = "$" ++ concat vars
482+ combinedName =
483+ "$" ++ concat vars
480
484
481 pvar name =
485 pvar name =
482− A.A patternRegion (P.Var name)
486+ A.A patternRegion (P.Var name)
483
487
484 localVar name =
488 localVar name =
485− A.A patternRegion (E.localVar name)
489+ A.A patternRegion (E.localVar name)
486
490
491+ mainDef =
487− mainDef = Canonical.Definition facts (pvar combinedName) expr maybeType
492+ Canonical.Def facts (pvar combinedName) expr maybeType
488
493
489 toDef name =
494 toDef name =
495+ let
490− let extract =
496+ extract =
491− E.Case (localVar combinedName) [(lpattern, localVar name)]
497+ E.Case (localVar combinedName) [(lpattern, localVar name)]
492− in
498+ in
493− Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing
499+ Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing
494
500
495
501
496
502
@@ -508,7 +514,7 @@ data Info = Info
508
514
509
515
510constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
516constrainDef :: Env.Environment -> Info -> Canonical.Def -> IO Info
511−constrainDef env info (Canonical.Definition _ (A.A patternRegion pattern) expr maybeTipe) =
517+constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =
512 let qs = [] -- should come from the def, but I'm not sure what would live there...
518 let qs = [] -- should come from the def, but I'm not sure what would live there...
513 in
519 in
514 case (pattern, maybeTipe) of
520 case (pattern, maybeTipe) of
src/Validate.hs+240−251
@@ -1,14 +1,16 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Validate (module') where
2module Validate (module') where
3
3
4+import Prelude hiding (init)
4import Control.Monad (foldM, when)
5import Control.Monad (foldM, when)
5import qualified Data.Map as Map
6import qualified Data.Map as Map
7+import qualified Data.Maybe as Maybe
6import qualified Data.Set as Set
8import qualified Data.Set as Set
7import qualified Data.Foldable as F
9import qualified Data.Foldable as F
8import qualified Data.Traversable as T
10import qualified Data.Traversable as T
9
11
10import AST.Expression.General as Expr
12import AST.Expression.General as Expr
11−import qualified AST.Effects as Fx
13+import qualified AST.Effects as Effects
12import qualified AST.Expression.Source as Source
14import qualified AST.Expression.Source as Source
13import qualified AST.Expression.Valid as Valid
15import qualified AST.Expression.Valid as Valid
14import qualified AST.Declaration as D
16import qualified AST.Declaration as D
@@ -38,11 +40,12 @@ module' (Module.Module name path info) =
38 (Module.Source tag settings docs exports imports decls) =
40 (Module.Source tag settings docs exports imports decls) =
39 info
41 info
40 in
42 in
41− do validDecls <- declarations decls
43+ do (ValidStuff foreigns structure) <- validateDecls decls
44+
42− validEffects <- validateEffects tag settings validDecls
45+ validEffects <- validateEffects tag settings foreigns (D._defs structure)
43
46
44 return $ Module.Module name path $
47 return $ Module.Module name path $
45− Module.Valid docs exports (addDefaults pkgName imports) validDecls validEffects
48+ Module.Valid docs exports (addDefaults pkgName imports) structure validEffects
46
49
47
50
48
51
@@ -69,17 +72,19 @@ addDefaults pkgName imports =
69validateEffects
72validateEffects
70 :: Module.SourceTag
73 :: Module.SourceTag
71 -> Module.SourceSettings
74 -> Module.SourceSettings
75+ -> [A.Commented Effects.ForeignRaw]
72− -> [D.Valid]
76+ -> [A.Commented Valid.Def]
73− -> Result.Result wrn Error.Error Fx.Effects
77+ -> Result.Result wrn Error.Error Effects.Raw
74−validateEffects tag settings@(A.A _ pairs) decls =
78+validateEffects tag settings@(A.A _ pairs) foreigns validDefs =
75 case tag of
79 case tag of
76 Module.Normal ->
80 Module.Normal ->
77 do noSettings Error.SettingsOnNormalModule settings
81 do noSettings Error.SettingsOnNormalModule settings
82+ noForeigns foreigns
78− return Fx.None
83+ return Effects.None
79
84
80 Module.Foreign _ ->
85 Module.Foreign _ ->
81 do noSettings Error.SettingsOnForeignModule settings
86 do noSettings Error.SettingsOnForeignModule settings
82− return Fx.Foreign
87+ return (Effects.Foreign foreigns)
83
88
84 Module.Effect tagRegion ->
89 Module.Effect tagRegion ->
85 let
90 let
@@ -89,9 +94,10 @@ validateEffects tag settings@(A.A _ pairs) decls =
89 settingsDict =
94 settingsDict =
90 foldr collectSettings Map.empty pairs
95 foldr collectSettings Map.empty pairs
91 in
96 in
97+ do noForeigns foreigns
92− do managerType <- toManagerType tagRegion settingsDict
98+ managerType <- toManagerType tagRegion settingsDict
93− (r0, r1, r2) <- checkManagerImpl tagRegion managerType noInfo decls
99+ (r0, r1, r2) <- checkManager tagRegion managerType validDefs
94− return (Fx.Effect (Fx.Info tagRegion r0 r1 r2 managerType))
100+ return (Effects.Manager (Effects.Info tagRegion r0 r1 r2 managerType))
95
101
96
102
97noSettings
103noSettings
@@ -107,10 +113,24 @@ noSettings errorMsg (A.A region settings) =
107 Result.throw region errorMsg
113 Result.throw region errorMsg
108
114
109
115
116+noForeigns :: [A.Commented Effects.ForeignRaw] -> Result.Result wrn Error.Error ()
117+noForeigns foreigns =
118+ case foreigns of
119+ [] ->
120+ Result.ok ()
121+
122+ _ : _ ->
123+ let
124+ toError (A.A (region, _) (Effects.ForeignRaw name _)) =
125+ A.A region (Error.UnexpectedForeign name)
126+ in
127+ Result.throwMany (map toError foreigns)
128+
129+
110toManagerType
130toManagerType
111 :: R.Region
131 :: R.Region
112 -> Map.Map String [(R.Region, A.Located String)]
132 -> Map.Map String [(R.Region, A.Located String)]
113− -> Result.Result wrn Error.Error Fx.ManagerType
133+ -> Result.Result wrn Error.Error Effects.ManagerType
114toManagerType tagRegion settingsDict =
134toManagerType tagRegion settingsDict =
115 let
135 let
116 toErrors name entries =
136 toErrors name entries =
@@ -129,18 +149,19 @@ toManagerType tagRegion settingsDict =
129 (,) <$> extractOne "command" settingsDict
149 (,) <$> extractOne "command" settingsDict
130 <*> extractOne "subscription" settingsDict
150 <*> extractOne "subscription" settingsDict
131
151
152+ -- TODO check that cmd and sub types exist?
132 case maybeEffects of
153 case maybeEffects of
133 (Nothing, Nothing) ->
154 (Nothing, Nothing) ->
134 Result.throw tagRegion Error.NoSettingsOnEffectModule
155 Result.throw tagRegion Error.NoSettingsOnEffectModule
135
156
136 (Just cmd, Nothing) ->
157 (Just cmd, Nothing) ->
137− return (Fx.CmdManager cmd)
158+ return (Effects.CmdManager cmd)
138
159
139 (Nothing, Just sub) ->
160 (Nothing, Just sub) ->
140− return (Fx.SubManager sub)
161+ return (Effects.SubManager sub)
141
162
142 (Just cmd, Just sub) ->
163 (Just cmd, Just sub) ->
143− return (Fx.FxManager cmd sub)
164+ return (Effects.FxManager cmd sub)
144
165
145
166
146extractOne
167extractOne
@@ -163,95 +184,65 @@ extractOne name settingsDict =
163
184
164
185
165
186
166−-- EFFECT REGIONS
187+-- CHECK EFFECT MANAGER
167−
168
188
169−data ManagerInfo =
170− ManagerInfo
171− { _cmdMap :: Bool
172− , _subMap :: Bool
173− , _init :: Maybe R.Region
174− , _onEffects :: Maybe R.Region
175− , _onSelfMsg :: Maybe R.Region
176− }
177−
178−
179−noInfo :: ManagerInfo
180−noInfo =
181− ManagerInfo False False Nothing Nothing Nothing
182
189
183−
190+checkManager
184−checkManagerImpl
185 :: R.Region
191 :: R.Region
186− -> Fx.ManagerType
192+ -> Effects.ManagerType
187− -> ManagerInfo
188− -> [D.Valid]
193+ -> [A.Commented Valid.Def]
189 -> Result.Result w Error.Error (R.Region, R.Region, R.Region)
194 -> Result.Result w Error.Error (R.Region, R.Region, R.Region)
190−checkManagerImpl tagRegion managerType info decls =
195+checkManager tagRegion managerType validDefs =
191− case decls of
192− [] ->
193− let
196+ let
194− (ManagerInfo cmdMap subMap init onEffects onSelfMsg) = info
197+ regionDict =
198+ Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)
195− in
199+ in
196− const (,,)
200+ const (,,)
197− <$> requireMaps tagRegion managerType cmdMap subMap
201+ <$> requireMaps tagRegion regionDict managerType
198− <*> requireRegion tagRegion "init" init
202+ <*> requireRegion tagRegion regionDict "init"
199− <*> requireRegion tagRegion "onEffects" onEffects
203+ <*> requireRegion tagRegion regionDict "onEffects"
200− <*> requireRegion tagRegion "onSelfMsg" onSelfMsg
204+ <*> requireRegion tagRegion regionDict "onSelfMsg"
201−
202− decl : rest ->
203− case getDefInfo decl of
204− Just ("init", region) ->
205− checkManagerImpl tagRegion managerType (info { _init = Just region }) rest
206−
207− Just ("onEffects", region) ->
208− checkManagerImpl tagRegion managerType (info { _onEffects = Just region }) rest
209−
210− Just ("onSelfMsg", region) ->
211− checkManagerImpl tagRegion managerType (info { _onSelfMsg = Just region }) rest
212−
213− Just ("cmdMap", _) ->
214− checkManagerImpl tagRegion managerType (info { _cmdMap = True }) rest
215−
216− Just ("subMap", _) ->
217− checkManagerImpl tagRegion managerType (info { _subMap = True }) rest
218−
219− _ ->
220− checkManagerImpl tagRegion managerType info rest
221
205
222
206
223−getDefInfo :: D.Valid -> Maybe (String, R.Region)
207+getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)
224−getDefInfo decl =
208+getSimpleDefRegion decl =
225 case decl of
209 case decl of
226− A.A region (D.Def (Valid.Definition (A.A _ (Pattern.Var name)) _ _)) ->
210+ A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->
227− Just (name, fst region)
211+ Just (name, region)
228
212
229 _ ->
213 _ ->
230 Nothing
214 Nothing
231
215
232
216
217+requireMaps
218+ :: R.Region
219+ -> Map.Map String R.Region
220+ -> Effects.ManagerType
233−requireMaps :: R.Region -> Fx.ManagerType -> Bool -> Bool -> Result.Result w Error.Error ()
221+ -> Result.Result w Error.Error ()
234−requireMaps tagRegion managerType hasCmdMap hasSubMap =
222+requireMaps tagRegion regionDict managerType =
235 let
223 let
236− check hasIt name =
224+ check name =
225+ when (Map.notMember name regionDict) $
237− when (not hasIt) (Result.throw tagRegion (Error.MissingManagerOnEffectModule name))
226+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)
238 in
227 in
239 case managerType of
228 case managerType of
240− Fx.CmdManager _ ->
229+ Effects.CmdManager _ ->
241− check hasCmdMap "cmdMap"
230+ check "cmdMap"
242
231
243− Fx.SubManager _ ->
232+ Effects.SubManager _ ->
244− check hasSubMap "subMap"
233+ check "subMap"
245
234
246− Fx.FxManager _ _ ->
235+ Effects.FxManager _ _ ->
247− (\_ _ -> ())
248− <$> check hasCmdMap "cmdMap"
236+ check "cmdMap" <* check "subMap"
249− <*> check hasSubMap "subMap"
250
237
251
238
239+requireRegion
240+ :: R.Region
241+ -> Map.Map String R.Region
242+ -> String
252−requireRegion :: R.Region -> String -> Maybe R.Region -> Result.Result w Error.Error R.Region
243+ -> Result.Result w Error.Error R.Region
253−requireRegion tagRegion name maybeRegion =
244+requireRegion tagRegion regionDict name =
254− case maybeRegion of
245+ case Map.lookup name regionDict of
255 Just region ->
246 Just region ->
256 return region
247 return region
257
248
@@ -263,30 +254,23 @@ requireRegion tagRegion name maybeRegion =
263-- COLLAPSE COMMENTS
254-- COLLAPSE COMMENTS
264
255
265
256
266−type Commented a =
267− A.Annotated (R.Region, Maybe (A.Located String)) a
268−
269−
270−collapseComments
271− :: [D.CommentOr (A.Located a)]
272− -> Result.Result wrn Error.Error [Commented a]
257+collapseComments :: [D.CommentOr (A.Located a)] -> Result.Result wrn Error.Error [A.Commented a]
273collapseComments listWithComments =
258collapseComments listWithComments =
274 case listWithComments of
259 case listWithComments of
275 [] ->
260 [] ->
276 Result.ok []
261 Result.ok []
277
262
278− D.Comment msg : D.Whatever (A.A region a) : rest ->
263+ D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->
279 let
264 let
280 entry =
265 entry =
281 A.A (region, Just msg) a
266 A.A (region, Just msg) a
282 in
267 in
283 fmap (entry:) (collapseComments rest)
268 fmap (entry:) (collapseComments rest)
284
269
285− D.Comment (A.A region _) : D.Comment _ : _ ->
270+ D.Comment (A.A region _) : rest ->
271+ collapseComments rest
286− Result.throw region Error.CommentOnComment
272+ <* Result.throw region Error.CommentOnNothing
287
273
288− [D.Comment (A.A region _)] ->
289− Result.throw region Error.CommentOnNothing
290
274
291 D.Whatever (A.A region a) : rest ->
275 D.Whatever (A.A region a) : rest ->
292 let
276 let
@@ -300,87 +284,92 @@ collapseComments listWithComments =
300-- VALIDATE STRUCTURED SOURCE
284-- VALIDATE STRUCTURED SOURCE
301
285
302
286
303−declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
287+validateDecls :: [D.Source] -> Result.Result wrn Error.Error ValidStuff
304−declarations sourceDecls =
288+validateDecls sourceDecls =
305− do decls <-
306− collapseComments sourceDecls
289+ do rawDecls <- collapseComments sourceDecls
307
290
308− validDecls <-
291+ validStuff <- validateRawDecls rawDecls
309− validateDecls decls
310
292
311− F.traverse_ id
293+ let (D.Decls _ unions aliases _) = _structure validStuff
312− (declDuplicates validDecls : map findBadTypeVars validDecls)
313
294
314− return validDecls
295+ return validStuff
296+ <* F.traverse_ checkTypeVarsInUnion unions
297+ <* F.traverse_ checkTypeVarsInAlias aliases
298+ <* checkDuplicates validStuff
315
299
316
300
317
301
318-- VALIDATE DECLARATIONS
302-- VALIDATE DECLARATIONS
319
303
320
304
321−validateDecls
305+data ValidStuff =
322− :: [Commented D.Source']
306+ ValidStuff
307+ { _foreigns :: [A.Commented Effects.ForeignRaw]
308+ , _structure :: D.Valid
309+ }
310+
311+
323− -> Result.Result wrn Error.Error [D.Valid]
312+validateRawDecls :: [A.Commented D.Raw] -> Result.Result wrn Error.Error ValidStuff
313+validateRawDecls commentedDecls =
314+ vrdHelp commentedDecls [] (D.Decls [] [] [] [])
315+
316+
317+vrdHelp
318+ :: [A.Commented D.Raw]
319+ -> [A.Commented Effects.ForeignRaw]
320+ -> D.Valid
321+ -> Result.Result wrn Error.Error ValidStuff
324−validateDecls commentedDecls =
322+vrdHelp commentedDecls foreigns structure =
325 case commentedDecls of
323 case commentedDecls of
326 [] ->
324 [] ->
327− Result.ok []
325+ Result.ok (ValidStuff foreigns structure)
328
326
329− A.A (region, maybeComment) decl : rest ->
327+ A.A ann decl : rest ->
330− let
331− addRest validDecl =
332− let
333− entry =
334− A.A (region, fmap A.drop maybeComment) validDecl
335− in
336− fmap (entry:) (validateDecls rest)
337− in
338− case decl of
328+ case decl of
339− D.Union name tvars ctors ->
329+ D.Union (D.Type name tvars ctors) ->
340− addRest (D.Union name tvars ctors)
330+ vrdHelp rest foreigns (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)
341
331
342− D.Alias name tvars alias ->
332+ D.Alias (D.Type name tvars alias) ->
343− addRest (D.Alias name tvars alias)
333+ vrdHelp rest foreigns (D.addAlias (A.A ann (D.Type name tvars alias)) structure)
344
334
345− D.Fixity assoc prec op ->
335+ D.Fixity fixity ->
346− addRest (D.Fixity assoc prec op)
336+ vrdHelp rest foreigns (D.addInfix fixity structure)
347
337
348− D.Def def ->
338+ D.Def (A.A region def) ->
349− validateDeclsHelp maybeComment def rest
339+ vrdDefHelp rest (A.A (region, snd ann) def) foreigns structure
350
340
341+ D.Foreign name tipe ->
342+ vrdHelp rest (A.A ann (Effects.ForeignRaw name tipe) : foreigns) structure
351
343
352−validateDeclsHelp
353− :: Maybe (A.Located String)
354− -> Source.Def
355− -> [Commented D.Source']
356− -> Result.Result wrn Error.Error [D.Valid]
357−validateDeclsHelp maybeComment (A.A region def) decls =
358− let
359− ann =
360− (region, fmap A.drop maybeComment)
361
344
362− makeDef pat expr maybeType =
345+vrdDefHelp
363− D.Def (Valid.Definition pat expr maybeType)
346+ :: [A.Commented D.Raw]
347+ -> A.Commented Source.Def'
348+ -> [A.Commented Effects.ForeignRaw]
349+ -> D.Valid
350+ -> Result.Result wrn Error.Error ValidStuff
351+vrdDefHelp remainingDecls (A.A ann def) foreigns structure =
352+ let
353+ addDef validDef (ValidStuff finalForeigns struct) =
354+ ValidStuff finalForeigns (D.addDef (A.A ann validDef) struct)
364 in
355 in
365 case def of
356 case def of
366 Source.Definition pat expr ->
357 Source.Definition pat expr ->
367− (:)
358+ addDef
368− <$> validateDef makeDef ann pat expr Nothing
359+ <$> validateDef pat expr Nothing
369− <*> validateDecls decls
360+ <*> vrdHelp remainingDecls foreigns structure
370
361
371 Source.Annotation name tipe ->
362 Source.Annotation name tipe ->
372− case decls of
363+ case remainingDecls of
373− A.A (_, Just (A.A commentRegion _)) _ : _ ->
374− Result.throw commentRegion (Error.CommentAfterAnnotation name)
375−
376 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
364 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
377 | Pattern.isVar name pat ->
365 | Pattern.isVar name pat ->
378− (:)
366+ addDef
379− <$> validateDef makeDef ann pat expr (Just tipe)
367+ <$> validateDef pat expr (Just tipe)
380− <*> validateDecls rest
368+ <*> vrdHelp rest foreigns structure
381
369
382 _ ->
370 _ ->
371+ vrdHelp remainingDecls foreigns structure
383− Result.throw region (Error.TypeWithoutDefinition name)
372+ <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)
384
373
385
374
386
375
@@ -390,8 +379,12 @@ validateDeclsHelp maybeComment (A.A region def) decls =
390definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
379definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
391definitions sourceDefs =
380definitions sourceDefs =
392 do validDefs <- definitionsHelp sourceDefs
381 do validDefs <- definitionsHelp sourceDefs
393− let patterns = map (\(Valid.Definition p _ _) -> p) validDefs
382+
394− defDuplicates patterns
383+ validDefs
384+ |> map Valid.getPattern
385+ |> concatMap Pattern.boundVars
386+ |> detectDuplicates Error.DuplicateDefinition
387+
395 return validDefs
388 return validDefs
396
389
397
390
@@ -401,34 +394,32 @@ definitionsHelp sourceDefs =
401 [] ->
394 [] ->
402 return []
395 return []
403
396
404− A.A region (Source.Definition pat expr) : rest ->
397+ A.A _ (Source.Definition pat expr) : rest ->
405 (:)
398 (:)
406− <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
399+ <$> validateDef pat expr Nothing
407 <*> definitionsHelp rest
400 <*> definitionsHelp rest
408
401
409− A.A r1 (Source.Annotation name tipe) : rest ->
402+ A.A region (Source.Annotation name tipe) : rest ->
410 case rest of
403 case rest of
411− A.A r2 (Source.Definition pat expr) : rest'
404+ A.A _ (Source.Definition pat expr) : rest'
412 | Pattern.isVar name pat ->
405 | Pattern.isVar name pat ->
413 (:)
406 (:)
414− <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
407+ <$> validateDef pat expr (Just tipe)
415 <*> definitionsHelp rest'
408 <*> definitionsHelp rest'
416
409
417 _ ->
410 _ ->
418− Result.throw r1 (Error.TypeWithoutDefinition name)
411+ Result.throw region (Error.TypeWithoutDefinition name)
419
412
420
413
421validateDef
414validateDef
422− :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
423− -> annotation
424− -> Pattern.Raw
415+ :: Pattern.Raw
425 -> Source.Expr
416 -> Source.Expr
426 -> Maybe Type.Raw
417 -> Maybe Type.Raw
427− -> Result.Result wrn Error.Error (A.Annotated annotation def)
418+ -> Result.Result wrn Error.Error Valid.Def
428−validateDef makeDef annotation pat expr maybeType =
419+validateDef pat expr maybeType =
429 do validExpr <- expression expr
420 do validExpr <- expression expr
430 validateDefPattern pat validExpr
421 validateDefPattern pat validExpr
431− return $ A.A annotation (makeDef pat validExpr maybeType)
422+ return $ Valid.Def pat validExpr maybeType
432
423
433
424
434validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
425validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
@@ -528,11 +519,17 @@ expression (A.A ann sourceExpression) =
528 <$> definitions defs
519 <$> definitions defs
529 <*> expression body
520 <*> expression body
530
521
531− Cmd moduleName typeName ->
522+ Cmd moduleName ->
532− return (Cmd moduleName typeName)
523+ return (Cmd moduleName)
533
524
534− Sub moduleName typeName ->
525+ Sub moduleName ->
535− return (Sub moduleName typeName)
526+ return (Sub moduleName)
527+
528+ ForeignCmd name tipe ->
529+ return (ForeignCmd name tipe)
530+
531+ ForeignSub name tipe ->
532+ return (ForeignSub name tipe)
536
533
537 SaveEnv moduleName effects ->
534 SaveEnv moduleName effects ->
538 return (SaveEnv moduleName effects)
535 return (SaveEnv moduleName effects)
@@ -567,112 +564,105 @@ validatePattern pattern =
567-- DETECT DUPLICATES
564-- DETECT DUPLICATES
568
565
569
566
570−detectDuplicates
571− :: (String -> Error.Error)
572− -> [A.Located String]
573− -> Result.Result wrn Error.Error ()
567+checkDuplicates :: ValidStuff -> Result.Result wrn Error.Error ()
574−detectDuplicates tag names =
568+checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =
575− let add (A.A region name) dict =
569+ let
576− Map.insertWith (++) name [region] dict
570+ -- SIMPLE NAMES
577
571
578− makeGroups pairs =
572+ defValues =
579− Map.toList (foldr add Map.empty pairs)
573+ concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs
580
574
581− check (name, regions) =
575+ foreignValues =
582− case regions of
576+ map fromForeign foreigns
583− _ : region : _ ->
584− Result.throw region (tag name)
585
577
586− _ ->
578+ fromForeign (A.A (region, _) (Effects.ForeignRaw name _)) =
587− return ()
579+ A.A region name
588− in
589− F.traverse_ check (makeGroups names)
590
580
581+ -- TYPE NAMES
591
582
592−defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
583+ (types, typeValues) =
593−defDuplicates patterns =
584+ unzip (map fromUnion unions ++ map fromAlias aliases)
594− concatMap Pattern.boundVars patterns
595− |> detectDuplicates Error.DuplicateDefinition
596
585
586+ fromUnion (A.A (region, _) (D.Type name _ ctors)) =
587+ ( A.A region name
588+ , map (A.A region . fst) ctors
589+ )
597
590
598−declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
591+ fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =
599−declDuplicates decls =
592+ (,) (A.A region name) $
600− let
593+ case tipe of
601− (valueLists, typeLists) =
594+ Type.RRecord _ _ ->
602− unzip (map extractValues decls)
595+ [A.A region name]
603− in
604− (\_ _ -> ())
605− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
606− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
607
596
597+ _ ->
598+ []
599+ in
600+ F.sequenceA_
601+ [ detectDuplicates Error.DuplicateValueDeclaration (foreignValues ++ defValues)
602+ , detectDuplicates Error.DuplicateValueDeclaration (concat typeValues)
603+ , detectDuplicates Error.DuplicateTypeDeclaration types
604+ ]
608
605
609−extractValues :: D.Valid -> ([A.Located String], [A.Located String])
610−extractValues (A.A (region, _) decl) =
611− case decl of
612− D.Def (Valid.Definition pattern _ _) ->
613− ( Pattern.boundVars pattern
614− , []
615− )
616
606
617− D.Union name _ ctors ->
607+detectDuplicates
618− ( map (A.A region . fst) ctors
608+ :: (String -> Error.Error)
609+ -> [A.Located String]
610+ -> Result.Result wrn Error.Error ()
611+detectDuplicates tag names =
612+ let
619− , [A.A region name]
613+ add (A.A region name) dict =
620− )
614+ Map.insertWith (++) name [region] dict
621
615
622− D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
616+ makeGroups pairs =
623− ( [A.A region name]
617+ Map.toList (foldr add Map.empty pairs)
624− , [A.A region name]
625− )
626
618
627− D.Alias name _ _ ->
619+ check (name, regions) =
628− ( []
620+ case regions of
621+ _ : region : _ ->
629− , [A.A region name]
622+ Result.throw region (tag name)
630− )
631
623
632− D.Fixity _ _ _ ->
624+ _ ->
633− ( []
625+ return ()
634− , []
626+ in
635− )
627+ F.traverse_ check (makeGroups names)
636
628
637
629
638
630
639-- UNBOUND TYPE VARIABLES
631-- UNBOUND TYPE VARIABLES
640
632
641
633
634+checkTypeVarsInUnion
635+ :: A.Commented (D.Union Type.Raw)
642−findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
636+ -> Result.Result wrn Error.Error ()
643−findBadTypeVars (A.A (region,_) decl) =
637+checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =
644− case decl of
638+ case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
645− D.Def _ ->
639+ (_, []) ->
646 return ()
640 return ()
647
641
648− D.Union name boundVars ctors ->
642+ (_, unbound) ->
649− case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
643+ Result.throw region
650− (_, []) ->
644+ (Error.UnboundTypeVarsInUnion name boundVars unbound)
651− return ()
652
645
653− (_, unbound) ->
654− Result.throw region
655− (Error.UnboundTypeVarsInUnion name boundVars unbound)
656−
657− D.Alias name boundVars tipe ->
658− case diff boundVars (freeVars tipe) of
659− ([], []) ->
660− return ()
661
646
662− ([], unbound) ->
647+checkTypeVarsInAlias
663− Result.throw region
648+ :: A.Commented (D.Alias Type.Raw)
664− (Error.UnboundTypeVarsInAlias name boundVars unbound)
649+ -> Result.Result wrn Error.Error ()
650+checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =
651+ case diff boundVars (freeVars tipe) of
652+ ([], []) ->
653+ return ()
665
654
666− (unused, []) ->
655+ ([], unbound) ->
667− Result.throw region
656+ Result.throw region
668− (Error.UnusedTypeVarsInAlias name boundVars unused)
657+ (Error.UnboundTypeVarsInAlias name boundVars unbound)
669
658
670− (unused, unbound) ->
659+ (unused, []) ->
671− Result.throw region
660+ Result.throw region
672− (Error.MessyTypeVarsInAlias name boundVars unused unbound)
661+ (Error.UnusedTypeVarsInAlias name boundVars unused)
673
662
674− D.Fixity _ _ _ ->
663+ (unused, unbound) ->
675− return ()
664+ Result.throw region
665+ (Error.MessyTypeVarsInAlias name boundVars unused unbound)
676
666
677
667
678diff :: [String] -> [A.Located String] -> ([String], [String])
668diff :: [String] -> [A.Located String] -> ([String], [String])
@@ -689,7 +679,6 @@ diff left right =
689 )
679 )
690
680
691
681
692−
693freeVars :: Type.Raw -> [A.Located String]
682freeVars :: Type.Raw -> [A.Located String]
694freeVars (A.A region tipe) =
683freeVars (A.A region tipe) =
695 case tipe of
684 case tipe of