66c833d · elk · git.iko.soy

git.iko.soy/elk

Get foreign effects working

- Switch to structured representation of Decls for Valid and Canonical phases - Revamp Canonicalize.Port for foreign effects - Revamp Generate.JavaScript.Port for foreign effects - Switch border patrol to use Json.Decode on incoming JS values - Instead of generating type constraints for effects, just rely on their type annotations to be correct and do the right thing.

commit66c833db4663e7820c1168623939dc5947c3a19b authorEvan Czaplicki <info@elm-lang.org> dateMon 21 Mar 2016, 12:32 (11 years ago) parent8aa55e0

34 files changed+1257−1188

compare with master

unifiedsplit

elm-compiler.cabal+2 src/AST/Declaration.hs+90−34 src/AST/Effects.hs+45−5 src/AST/Expression/Canonical.hs+1−1 src/AST/Expression/General.hs+6−4 src/AST/Expression/Optimized.hs+3 src/AST/Expression/Valid.hs+3−3 src/AST/Module.hs+6−6 src/Canonicalize.hs+84−78 src/Canonicalize/Body.hs+101−85 src/Canonicalize/Effects.hs+135 src/Canonicalize/Port.hs−123 src/Canonicalize/Setup.hs+59−58 src/Canonicalize/Sort.hs+12−6 src/Compile.hs+2−1 src/Docs/Centralize.hs+56−73 src/Generate/JavaScript.hs+8−8 src/Generate/JavaScript/BuiltIn.hs+20−11 src/Generate/JavaScript/Expression.hs+17−6 src/Generate/JavaScript/Foreign.hs+214 src/Generate/JavaScript/Helpers.hs+3−26 src/Generate/JavaScript/Port.hs−299 src/Generate/JavaScript/Variable.hs+6 src/Nitpick/PatternMatches.hs+9−3 src/Nitpick/TopLevelTypes.hs+7−7 src/Optimize.hs+9−3 src/Optimize/Inline.hs+12 src/Parse/Declaration.hs+22−6 src/Parse/Parse.hs+1−1 src/Reporting/Error/Canonicalize.hs+32−37 src/Reporting/Error/Syntax.hs+16−23 src/Type/Constrain/Effects.hs+11−11 src/Type/Constrain/Expression.hs+25−19 src/Validate.hs+240−251

elm-compiler.cabal+2

@@ -63,6 +63,7 @@ Library

6363 AST.Variable,

6464 Canonicalize,

6565 Canonicalize.Body,

66+ Canonicalize.Effects,

6667 Canonicalize.Environment,

6768 Canonicalize.Result,

6869 Canonicalize.Setup,

@@ -79,6 +80,7 @@ Library

7980 Generate.JavaScript,

8081 Generate.JavaScript.BuiltIn,

8182 Generate.JavaScript.Expression,

83+ Generate.JavaScript.Foreign,

8284 Generate.JavaScript.Helpers,

8385 Generate.JavaScript.Literal,

8486 Generate.JavaScript.Variable,

src/AST/Declaration.hs+90−34

@@ -11,53 +11,99 @@ import qualified Reporting.Annotation as A

1111

1212

1313

14−-- DECLARATIONS

14+-- SOURCE DECLARATIONS

1515

1616

17−data Decl def tipe expr

18− = Def def

19− | Union String [String] [(String, [tipe])]

20− | Alias String [String] tipe

21− | Fixity Assoc Int String

17+type Source =

18+ CommentOr (A.Located Raw)

2219

2320

21+data CommentOr a

22+ = Comment (A.Located String)

23+ | Whatever a

2424

25−-- DECLARATION PHASES

2625

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

2732

28−type Source =

29− CommentOr (A.Located Source')

3033

3134

32−type Source' =

33− Decl Source.Def Type.Raw Source.Expr

35+-- STRUCTURED DECLARATIONS

3436

3537

36−type Valid =

37− A.Commented Valid'

38+data Decls def tipe =

39+ Decls

40+ { _defs :: [A.Commented def]

41+ , _unions :: [A.Commented (Union tipe)]

42+ , _aliases :: [A.Commented (Alias tipe)]

43+ , _infixes :: [Infix]

44+ }

3845

3946

40−type Valid' =

41− Decl Valid.Def Type.Raw Valid.Expr

47+type Valid =

48+ Decls Valid.Def Type.Raw

4249

4350

4451type Canonical =

45− A.Commented (Decl Canonical.Def Type.Canonical Canonical.Expr)

52+ Decls Canonical.Def Type.Canonical

4653

4754

55+addDef :: A.Commented d -> Decls d t -> Decls d t

56+addDef def decls =

57+ decls { _defs = def : _defs decls }

4858

49−-- COMMENTS

5059

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 }

5173

52−data CommentOr a

53− = Comment (A.Located String)

54− | Whatever a

74+

75+

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

5593

5694

5795

5896-- INFIX STUFF

5997

6098

99+data Infix =

100+ Infix

101+ { _op :: String

102+ , _associativity :: Assoc

103+ , _precedence :: Int

104+ }

105+

106+

61107data Assoc = L | N | R

62108 deriving (Eq)

63109

@@ -79,18 +125,28 @@ assocToString assoc =

79125-- BINARY CONVERSION

80126

81127

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+

82138instance Binary Assoc where

83− get =

84− do n <- getWord8

85− return $ case n of

86− 0 -> L

87− 1 -> N

88− 2 -> R

89− _ -> error "Error reading valid associativity from serialized string"

90−

91− put assoc =

92− putWord8 $

93− case assoc of

94− L -> 0

95− N -> 1

96− R -> 2

139+ get =

140+ do n <- getWord8

141+ return $ case n of

142+ 0 -> L

143+ 1 -> N

144+ 2 -> R

145+ _ -> error "Error reading valid associativity from serialized string"

146+

147+ put assoc =

148+ putWord8 $

149+ case assoc of

150+ L -> 0

151+ N -> 1

152+ R -> 2

src/AST/Effects.hs+45−5

@@ -1,14 +1,30 @@

11module AST.Effects where

3+import qualified AST.Type as Type

34import qualified Reporting.Annotation as A

45import qualified Reporting.Region as R

8−data Effects

9+-- EFFECTS

10+

11+

12+data Effects foreigns

913 = None

10− | Effect Info

11− | Foreign

14+ | Manager Info

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

1228

1329

1430data Info =

@@ -17,11 +33,35 @@ data Info =

1733 , _init :: R.Region

1834 , _onEffects :: R.Region

1935 , _onSelfMsg :: R.Region

20− , _type :: ManagerType

36+ , _managerType :: ManagerType

2137 }

2238

2339

2440data ManagerType

2541 = CmdManager (A.Located String)

2642 | 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' =

2121

2222

2323data Def

24− = Definition Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

24+ = Def Facts Pattern.Canonical Expr (Maybe (A.Located Type.Canonical))

2525

2626

2727data Facts = Facts

src/AST/Expression/General.hs+6−4

@@ -8,7 +8,7 @@ enrich the AST with more information.

88-}

99module AST.Expression.General where

1010

11−import qualified AST.Effects as Fx

11+import qualified AST.Effects as Effects

1212import qualified AST.Literal as Literal

1313import qualified AST.Module.Name as ModuleName

1414import qualified AST.Pattern as Pattern

@@ -55,9 +55,11 @@ data Expr' ann def var typ

5555 | Update (Expr ann def var typ) [(String, Expr ann def var typ)]

5656 | Record [(String, Expr ann def var typ)]

5757 -- for type checking and code gen only

58− | Cmd ModuleName.Canonical String

59− | Sub ModuleName.Canonical String

60− | SaveEnv ModuleName.Canonical Fx.Effects

58+ | Cmd ModuleName.Canonical

59+ | Sub ModuleName.Canonical

60+ | ForeignCmd String typ

61+ | ForeignSub String typ

62+ | SaveEnv ModuleName.Canonical Effects.Canonical

6163 | GLShader String String Literal.GLShaderTipe

6264

6365

src/AST/Expression/Optimized.hs+3

@@ -7,6 +7,7 @@ module AST.Expression.Optimized

88import qualified AST.Literal as Literal

99import qualified AST.Module.Name as ModuleName

10+import qualified AST.Type as Type

1011import qualified AST.Variable as Var

1112import qualified Optimize.DecisionTree as DT

1213import qualified Reporting.Region as R

@@ -52,6 +53,8 @@ data Expr

5253 | Record [(String, Expr)]

5354 | Cmd ModuleName.Canonical

5455 | Sub ModuleName.Canonical

56+ | ForeignCmd String Type.Canonical

57+ | ForeignSub String Type.Canonical

5558 | GLShader String String Literal.GLShaderTipe

5659 | Crash ModuleName.Canonical R.Region (Maybe Expr)

5760

src/AST/Expression/Valid.hs+3−3

@@ -20,11 +20,11 @@ type Expr' =

2020 General.Expr' R.Region Def Var.Raw Type.Raw

2121

2222

23−data Def

24− = Definition Pattern.Raw Expr (Maybe Type.Raw)

23+data Def =

24+ Def Pattern.Raw Expr (Maybe Type.Raw)

2525

2626

2727getPattern :: Def -> Pattern.Raw

28−getPattern (Definition pattern _ _) =

28+getPattern (Def pattern _ _) =

2929 pattern

3030

src/AST/Module.hs+6−6

@@ -19,7 +19,7 @@ import Data.Binary

1919import qualified Data.Map as Map

2020

2121import qualified AST.Declaration as Decl

22−import qualified AST.Effects as Fx

22+import qualified AST.Effects as Effects

2323import qualified AST.Expression.Canonical as Canonical

2424import qualified AST.Expression.Optimized as Optimized

2525import qualified AST.Module.Name as Name

@@ -99,8 +99,8 @@ data ValidInfo =

9999 { validDocs :: A.Located (Maybe String)

100100 , validExports :: Var.Listing (A.Located Var.Value)

101101 , validImports :: ([DefaultImport], [UserImport])

102− , validDecls :: [Decl.Valid]

103− , validEffects :: Fx.Effects

102+ , validDecls :: Decl.Valid

103+ , validEffects :: Effects.Raw

104104 }

105105

106106

@@ -140,10 +140,10 @@ data Info program =

140140 , imports :: [Name.Raw]

141141 , program :: program

142142 , types :: Types

143− , fixities :: [(Decl.Assoc, Int, String)]

143+ , fixities :: [Decl.Infix]

144144 , aliases :: Aliases

145145 , unions :: Unions

146− , effects :: Fx.Effects

146+ , effects :: Effects.Canonical

147147 }

148148

149149

@@ -185,7 +185,7 @@ data Interface =

185185 , iTypes :: Types

186186 , iUnions :: Unions

187187 , iAliases :: Aliases

188− , iFixities :: [(Decl.Assoc, Int, String)]

188+ , iFixities :: [Decl.Infix]

189189 }

190190

191191

src/Canonicalize.hs+84−78

@@ -27,6 +27,7 @@ import qualified Reporting.Region as Region

2727import qualified Reporting.Result as R

2828import qualified Reporting.Warning as Warning

2929import qualified Canonicalize.Body as Body

30+import qualified Canonicalize.Effects as Effects

3031import qualified Canonicalize.Environment as Env

3132import qualified Canonicalize.Result as Result

3233import qualified Canonicalize.Setup as Setup

@@ -53,38 +54,32 @@ module' canonicalImports interfaces modul =

5354 |> map (\cName -> (ModuleName._module cName, cName))

5455 |> Map.fromList

5556

56− canonicalDeclsResult =

57+ (Result.Result uses rawResults) =

5758 Setup.environment importDict interfaces modul

58− `Result.andThen` \env -> (,) env <$> T.traverse (declaration env) decls

59+ `Result.andThen` \env ->

5960

60− (Result.Result uses rawResults) =

61− (,)

62− <$> canonicalDeclsResult

63− <*> resolveExports (concatMap declToValues decls) exports

61+ (,,,) env

62+ <$> resolveExports (Effects.toValues effects ++ declsToValues decls) exports

63+ <*> canonicalizeDecls env decls

64+ <*> Effects.canonicalize env effects

6465 in

6566 case rawResults of

6667 Result.Err msgs ->

6768 R.throwMany (map (A.map Error.Canonicalize) msgs)

6869

69− Result.Ok ((env, canonicalDecls), canonicalExports) ->

70+ Result.Ok (env, canonicalExports, canonicalDecls, canonicalEffects) ->

7071 let

71− nakedDecls =

72− map A.drop canonicalDecls

72+ (D.Decls _ unions aliases infixes) =

73+ canonicalDecls

7374

7475 centralizedDocs =

7576 A.map (fmap (Docs.centralize canonicalDecls)) docs

7677

77− program =

78− Body.flatten (Module.name modul) canonicalDecls effects

79−

80− fixities =

81− [ (assoc,level,op) | D.Fixity assoc level op <- nakedDecls ]

78+ typeToPair (A.A _ (D.Type name args body)) =

79+ ( name, (args, body) )

8280

83− aliases =

84− Map.fromList [ (name,(tvs,alias)) | D.Alias name tvs alias <- nakedDecls ]

85−

86− unions =

87− Map.fromList [ (name,(vars,ctors)) | D.Union name vars ctors <- nakedDecls ]

81+ program =

82+ Body.flatten (Module.name modul) canonicalDecls canonicalEffects

8883 in

8984 R.addDealiaser (Env.toDealiaser env) $

9085 do canonicalImports <- filterImports uses imports

@@ -96,10 +91,10 @@ module' canonicalImports interfaces modul =

9691 , Module.imports = canonicalImports

9792 , Module.program = program

9893 , Module.types = Map.empty

99− , Module.fixities = fixities

100− , Module.aliases = aliases

101− , Module.unions = unions

102− , Module.effects = effects

94+ , Module.fixities = infixes

95+ , Module.aliases = Map.fromList (map typeToPair aliases)

96+ , Module.unions = Map.fromList (map typeToPair unions)

97+ , Module.effects = canonicalEffects

10398 }

10499 }

105100

@@ -251,25 +246,28 @@ allUnique statedExports =

251246-- CONVERSIONS

252247

253248

254−declToValues :: D.Valid -> [Var.Value]

255−declToValues (A.A _ decl) =

256− case decl of

257− D.Def def ->

249+declsToValues :: D.Valid -> [Var.Value]

250+declsToValues (D.Decls defs unions aliases _) =

251+ let

252+ fromDef (A.A _ def) =

258253 map Var.Value (P.boundVarList (Valid.getPattern def))

259254

260− D.Union name _tvs ctors ->

261− [ Var.Union name (Var.Listing (map fst ctors) False) ]

255+ fromUnion (A.A _ (D.Type name _ ctors)) =

256+ Var.Union name (Var.Listing (map fst ctors) False)

262257

263− D.Alias name _ tipe ->

258+ fromAlias (A.A _ (D.Type name _ tipe)) =

264259 case tipe of

265260 A.A _ (Type.RRecord _ Nothing) ->

266261 [ Var.Alias name, Var.Value name ]

267262

268263 _ ->

269264 [ Var.Alias name ]

270−

271− _ ->

272− []

265+ in

266+ concat

267+ [ map fromUnion unions

268+ , concatMap fromAlias aliases

269+ , concatMap fromDef defs

270+ ]

273271

274272

275273

@@ -321,46 +319,48 @@ splitLocatedValue (A.A region value) =

321319-- DECLARATIONS

322320

323321

324−declaration :: Env.Environment -> D.Valid -> Result.ResultErr D.Canonical

325−declaration env (A.A ann decl) =

326− A.A ann <$>

327− case decl of

328− D.Def (Valid.Definition pat expr typ) ->

329− D.Def <$> (

330− Canonical.Definition Canonical.dummyFacts

331− <$> pattern env pat

332− <*> expression env expr

333− <*> T.traverse (regionType 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

322+canonicalizeDecls :: Env.Environment -> D.Valid -> Result.ResultErr D.Canonical

323+canonicalizeDecls env (D.Decls defs unions aliases infixes) =

324+ let

325+ traverse canEntry entries =

326+ T.traverse (\(A.A ann entry) -> A.A ann <$> canEntry entry) entries

327+

328+ canonicalizeDef (Valid.Def pat expr typ) =

329+ Canonical.Def Canonical.dummyFacts

330+ <$> canonicalizePattern env pat

331+ <*> canonicalizeExpr env expr

332+ <*> T.traverse (canonicalizeRegionType env) typ

341333

342− D.Alias name tvars expanded ->

343− D.Alias name tvars

344− <$> Canonicalize.tipe env expanded

334+ canonicalizeArgs (ctor, args) =

335+ (,) ctor <$> T.traverse (Canonicalize.tipe env) args

345336

346− D.Fixity assoc prec op ->

347− Result.ok (D.Fixity assoc prec op)

337+ canonicalizeUnion (D.Type name tvars ctors) =

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

348348

349349

350−regionType

350+canonicalizeRegionType

351351 :: Env.Environment

352352 -> Type.Raw

353353 -> Result.ResultErr (A.Located Type.Canonical)

354−regionType env typ@(A.A region _) =

354+canonicalizeRegionType env typ@(A.A region _) =

355355 A.A region <$> Canonicalize.tipe env typ

356356

357357

358−expression

358+canonicalizeExpr

359359 :: Env.Environment

360360 -> Valid.Expr

361361 -> Result.ResultErr Canonical.Expr

362−expression env (A.A region validExpr) =

363− let go = expression env

362+canonicalizeExpr env (A.A region validExpr) =

363+ let go = canonicalizeExpr env

364364 in

365365 A.A region <$>

366366 case validExpr of

@@ -393,7 +393,7 @@ expression env (A.A region validExpr) =

393393 env' =

394394 Env.addPattern arg env

395395 in

396− Lambda <$> pattern env' arg <*> expression env' body

396+ Lambda <$> canonicalizePattern env' arg <*> canonicalizeExpr env' body

397397

398398 App func arg ->

399399 App <$> go func <*> go arg

@@ -407,16 +407,16 @@ expression env (A.A region validExpr) =

407407 (,) <$> go condition <*> go branch

408408

409409 Let defs body ->

410− Let <$> T.traverse rename' defs <*> expression env' body

410+ Let <$> T.traverse rename' defs <*> canonicalizeExpr env' body

411411 where

412412 env' =

413− foldr Env.addPattern env $ map (\(Valid.Definition p _ _) -> p) defs

413+ foldr Env.addPattern env (map Valid.getPattern defs)

414414

415− rename' (Valid.Definition p body mtipe) =

416− Canonical.Definition Canonical.dummyFacts

417− <$> pattern env' p

418− <*> expression env' body

419− <*> T.traverse (regionType env') mtipe

415+ rename' (Valid.Def p body mtipe) =

416+ Canonical.Def Canonical.dummyFacts

417+ <$> canonicalizePattern env' p

418+ <*> canonicalizeExpr env' body

419+ <*> T.traverse (canonicalizeRegionType env') mtipe

420420

421421 Var (Var.Raw x) ->

422422 Var <$> Canonicalize.variable region env x

@@ -432,14 +432,20 @@ expression env (A.A region validExpr) =

432432 where

433433 branch (ptrn, brnch) =

434434 (,)

435− <$> pattern env ptrn

436− <*> expression (Env.addPattern ptrn env) brnch

435+ <$> canonicalizePattern env ptrn

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)

437443

438− Cmd moduleName string ->

439− Result.ok (Cmd moduleName string)

444+ ForeignCmd name tipe ->

445+ ForeignCmd name <$> Canonicalize.tipe env tipe

440446

441− Sub moduleName string ->

442− Result.ok (Sub moduleName string)

447+ ForeignSub name tipe ->

448+ ForeignSub name <$> Canonicalize.tipe env tipe

443449

444450 SaveEnv moduleName effects ->

445451 Result.ok (SaveEnv moduleName effects)

@@ -448,8 +454,8 @@ expression env (A.A region validExpr) =

448454 Result.ok (GLShader uid src tipe)

449455

450456

451−pattern :: Env.Environment -> P.Raw -> Result.ResultErr P.Canonical

452−pattern env (A.A region ptrn) =

457+canonicalizePattern :: Env.Environment -> P.Raw -> Result.ResultErr P.Canonical

458+canonicalizePattern env (A.A region ptrn) =

453459 A.A region <$>

454460 case ptrn of

455461 P.Var x ->

@@ -465,9 +471,9 @@ pattern env (A.A region ptrn) =

465471 Result.ok P.Anything

466472

467473 P.Alias x p ->

468− P.Alias x <$> pattern env p

474+ P.Alias x <$> canonicalizePattern env p

469475

470476 P.Data (Var.Raw name) patterns ->

471477 P.Data

472478 <$> 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 @@

11{-# OPTIONS_GHC -Wall #-}

22module Canonicalize.Body (flatten) where

4−import qualified AST.Declaration as D

5−import qualified AST.Effects as Fx

4+import qualified Data.Maybe as Maybe

6+import qualified AST.Declaration as Decl

7+import qualified AST.Effects as Effects

68import qualified AST.Expression.General as E

79import qualified AST.Expression.Canonical as Canonical

810import qualified AST.Module.Name as ModuleName

911import qualified AST.Pattern as P

10−import qualified AST.Type as T

12+import qualified AST.Type as Type

1113import qualified AST.Variable as Var

1214import qualified Canonicalize.Sort as Sort

1315import qualified Reporting.Annotation as A

@@ -15,63 +17,60 @@ import qualified Reporting.Region as R

1517

1618

1719

18−flatten :: ModuleName.Canonical -> [D.Canonical] -> Fx.Effects -> Canonical.Expr

19−flatten moduleName decls effects =

20+flatten :: ModuleName.Canonical -> Decl.Canonical -> Effects.Canonical -> Canonical.Expr

21+flatten moduleName (Decl.Decls defs unions aliases _) effects =

2022 let

21− declDefs =

22− concatMap (declToDefs moduleName) decls

23−

24− effectDefs =

25− effectsToDefs moduleName effects

23+ allDefs =

24+ concat

25+ [ concatMap (unionToDefs moduleName) unions

26+ , Maybe.mapMaybe (aliasToDefs moduleName) aliases

27+ , effectsToDefs moduleName effects

28+ , map A.drop defs

29+ ]

2630

2731 loc =

2832 A.A (error "this annotation should never be needed")

2933 in

3034 Sort.definitions $ loc $

31− E.Let

32− (declDefs ++ effectDefs)

33− (loc $ E.SaveEnv moduleName effects)

35+ E.Let allDefs (loc $ E.SaveEnv moduleName effects)

3436

3537

3638

37−-- DECLARATIONS

39+-- TYPES TO DEFS

3840

3941

40−declToDefs :: ModuleName.Canonical -> D.Canonical -> [Canonical.Def]

41−declToDefs moduleName (A.A (region,_) decl) =

42+unionToDefs :: ModuleName.Canonical -> A.Commented (Decl.Union Type.Canonical) -> [Canonical.Def]

43+unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

4244 let

43− typeVar =

44− Var.fromModule moduleName

45+ tagToDef (tag, tipes) =

46+ let

47+ vars =

48+ take (length tipes) infiniteArgs

4549

46− loc expr =

47− A.A region expr

48− in

49− case decl of

50− D.Def def ->

51− [def]

50+ tbody =

51+ Type.App

52+ (Type.Type (Var.fromModule moduleName name))

53+ (map Type.Var tvars)

5254

53− D.Union name tvars constructors ->

54− let

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

65− in

66− definition ctor (buildFunction body vars) region (foldr T.Lambda tbody tipes)

55+ body =

56+ A.A region $

57+ E.Data tag (map (A.A region . E.localVar) vars)

6758 in

68− map tagToDef constructors

59+ definition tag (buildFunction vars body) region (foldr Type.Lambda tbody tipes)

60+ in

61+ map tagToDef constructors

62+

6963

70− D.Alias name tvars tipe@(T.Record fields Nothing) ->

71− [ definition name (buildFunction record vars) region (foldr T.Lambda result args) ]

72− where

73− result =

74− T.Aliased (typeVar name) (zip tvars (map T.Var tvars)) (T.Holey tipe)

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

67+ Type.Record fields Nothing ->

68+ let

69+ resultType =

70+ Type.Aliased

71+ (Var.fromModule moduleName name)

72+ (zip tvars (map Type.Var tvars))

73+ (Type.Holey tipe)

7574

7675 args =

7776 map snd fields

@@ -80,16 +79,13 @@ declToDefs moduleName (A.A (region,_) decl) =

8079 take (length args) infiniteArgs

8180

8281 record =

83− loc (E.Record (zip (map fst fields) (map (loc . E.localVar) vars)))

84−

85− -- Type aliases must be added to an extended equality dictionary,

86− -- but they do not require any basic constraints.

87− D.Alias _ _ _ ->

88− []

82+ A.A region $

83+ E.Record (zip (map fst fields) (map (A.A region . E.localVar) vars))

84+ in

85+ Just $ definition name (buildFunction vars record) region (foldr Type.Lambda resultType args)

8986

90− -- no constraints are needed for fixity declarations

91− D.Fixity _ _ _ ->

92− []

87+ _ ->

88+ Nothing

9389

9490

9591infiniteArgs :: [String]

@@ -97,17 +93,17 @@ infiniteArgs =

9793 map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

9894

9995

100−buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr

101−buildFunction body@(A.A ann _) vars =

96+buildFunction :: [String] -> Canonical.Expr -> Canonical.Expr

97+buildFunction vars body@(A.A ann _) =

10298 foldr

103− (\pattern expr -> A.A ann (E.Lambda pattern expr))

104− body

105− (map (A.A ann . P.Var) vars)

99+ (\pattern expr -> A.A ann (E.Lambda pattern expr))

100+ body

101+ (map (A.A ann . P.Var) vars)

106102

107103

108−definition :: String -> Canonical.Expr -> R.Region -> T.Canonical -> Canonical.Def

104+definition :: String -> Canonical.Expr -> R.Region -> Type.Canonical -> Canonical.Def

109105definition name expr@(A.A ann _) region tipe =

110− Canonical.Definition

106+ Canonical.Def

111107 Canonical.dummyFacts

112108 (A.A ann (P.Var name))

113109 expr

@@ -118,37 +114,57 @@ definition name expr@(A.A ann _) region tipe =

118114-- EFFECTS

119115

120116

121−effectsToDefs :: ModuleName.Canonical -> Fx.Effects -> [Canonical.Def]

117+effectsToDefs :: ModuleName.Canonical -> Effects.Canonical -> [Canonical.Def]

122118effectsToDefs moduleName effects =

123119 case effects of

124− Fx.None ->

120+ Effects.None ->

125121 []

126122

127− Fx.Foreign ->

128− []

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

145+ ]

129146

130− Fx.Effect info ->

131− case Fx._type info of

132− Fx.CmdManager cmd ->

133− [ effectsToDefsHelp "command" (E.Cmd moduleName) cmd ]

147+ Effects.SubManager sub ->

148+ [ subToDef sub

149+ ]

134150

135− Fx.SubManager sub ->

136− [ effectsToDefsHelp "subscription" (E.Sub moduleName) sub ]

151+ Effects.FxManager cmd sub ->

152+ [ cmdToDef cmd

153+ , subToDef sub

154+ ]

137155

138− Fx.FxManager cmd sub ->

139− [ effectsToDefsHelp "command" (E.Cmd moduleName) cmd

140− , effectsToDefsHelp "subscription" (E.Sub moduleName) sub

141− ]

142156

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

143170

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

3+import qualified Data.Foldable as F

4+import qualified Data.Traversable as T

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

88import qualified Data.Traversable as Trav

1010import qualified AST.Declaration as D

11−import qualified AST.Effects as Fx

11+import qualified AST.Effects as Effects

1212import qualified AST.Expression.Valid as Valid

1313import qualified AST.Module as Module

1414import qualified AST.Module.Name as ModuleName

@@ -43,7 +43,7 @@ environment importDict interfaces (Module.Module name _ info) =

4343 Trav.traverse (importToPatches importDict interfaces) allImports

4444

4545 (typeAliasNodes, declPatches) =

46− declarationsToPatches name decls

46+ declsToPatches name decls

4747

4848 effectPatches =

4949 effectsToPatches name effects

@@ -306,85 +306,86 @@ addTypeAlias moduleName scc env =

306306-- DECLARATIONS TO PATCHES

307307

308308

309−declarationsToPatches :: ModuleName.Canonical -> [D.Valid] -> ([Node], [Env.Patch])

310−declarationsToPatches moduleName decls =

311− let

312− (maybeNodes, patchLists) =

313− unzip (map (declToPatches moduleName) decls)

314− in

315− (Maybe.catMaybes maybeNodes, concat patchLists)

309+{- When canonicalizing, it is important that:

316310

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)

317315

318−-- When canonicalizing, it is important that:

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])

324−declToPatches moduleName (A.A (region,_) decl) =

316+-}

317+declsToPatches :: ModuleName.Canonical -> D.Valid -> ([Node], [Env.Patch])

318+declsToPatches moduleName (D.Decls defs unions aliases _) =

325319 let

326− topLevel mkPatch x =

327− mkPatch x (Var.topLevel moduleName x)

328320

329− namespaced mkPatch x =

330− mkPatch x (Var.fromModule moduleName x)

321+ -- HELPERS

322+

323+ topLevelValue x =

324+ Env.Value x (Var.topLevel moduleName x)

331325

332326 patternPatch (name, args) =

333327 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− )

363328

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+ )

364361

365362

366363-- EFFECTS TO PATCHES

367364

368365

369−effectsToPatches :: ModuleName.Canonical -> Fx.Effects -> [Env.Patch]

366+effectsToPatches :: ModuleName.Canonical -> Effects.Raw -> [Env.Patch]

370367effectsToPatches moduleName effects =

371368 case effects of

372− Fx.None ->

369+ Effects.None ->

373370 []

374371

375− Fx.Foreign ->

376− []

372+ Effects.Foreign foreigns ->

373+ let

374+ toPatch (A.A _ (Effects.ForeignRaw name _)) =

375+ Env.Value name (Var.topLevel moduleName name)

376+ in

377+ map toPatch foreigns

377378

378− Fx.Effect info ->

379+ Effects.Manager info ->

379380 map (\name -> Env.Value name (Var.topLevel moduleName name)) $

380− case Fx._type info of

381− Fx.CmdManager _ ->

381+ case Effects._managerType info of

382+ Effects.CmdManager _ ->

382383 [ "command" ]

383384

384− Fx.SubManager _ ->

385+ Effects.SubManager _ ->

385386 [ "subscription" ]

386387

387− Fx.FxManager _ _ ->

388+ Effects.FxManager _ _ ->

388389 [ "command", "subscription" ]

389390

390391

src/Canonicalize/Sort.hs+12−6

@@ -96,10 +96,16 @@ reorder (A.A ann expression) =

9696 Record

9797 <$> mapM (\(field,expr) -> (,) field <$> reorder expr) fields

9898

99− Cmd _ _ ->

99+ Cmd _ ->

100100 return expression

101101

102− Sub _ _ ->

102+ Sub _ ->

103+ return expression

104+

105+ ForeignCmd _ _ ->

106+ return expression

107+

108+ ForeignSub _ _ ->

103109 return expression

104110

105111 SaveEnv _ _ ->

@@ -120,7 +126,7 @@ reorder (A.A ann expression) =

120126 let defss = map Graph.flattenSCC sccs

121127

122128 -- remove let-bound variables from the context

123− forM_ defs $ \(Canonical.Definition _ pattern _ _) -> do

129+ forM_ defs $ \(Canonical.Def _ pattern _ _) -> do

124130 bound pattern

125131 mapM free (ctors pattern)

126132

@@ -194,7 +200,7 @@ buildDefGraph defs =

194200 zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

195201

196202 variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)]

197− variableToKey (Canonical.Definition _ pattern _ _, key, _) =

203+ variableToKey (Canonical.Def _ pattern _ _, key, _) =

198204 [ (var, key) | var <- P.boundVarList pattern ]

199205

200206 variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int

@@ -215,7 +221,7 @@ buildDefGraph defs =

215221reorderAndGetDependencies

216222 :: Canonical.Def

217223 -> State (Set.Set String) (Canonical.Def, [String])

218−reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =

224+reorderAndGetDependencies (Canonical.Def facts pattern expr mType) =

219225 do globalFrees <- get

220226 -- work in a fresh environment

221227 put Set.empty

@@ -223,4 +229,4 @@ reorderAndGetDependencies (Canonical.Definition facts pattern expr mType) =

223229 localFrees <- get

224230 -- merge with global frees

225231 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

33import qualified Data.Map as Map

5+import qualified AST.Declaration as D

56import qualified AST.Module as Module

67import qualified AST.Module.Name as ModuleName

78import qualified Canonicalize

@@ -64,5 +65,5 @@ getOpTable :: Module.Interfaces -> Parse.OpTable

6465getOpTable interfaces =

6566 Map.elems interfaces

6667 |> concatMap Module.iFixities

67− |> map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

68+ |> map (\(D.Infix op assoc lvl) -> ( op, (lvl,assoc) ))

6869 |> Map.fromList

src/Docs/Centralize.hs+56−73

@@ -2,96 +2,79 @@ module Docs.Centralize (centralize) where

33import Control.Arrow (second)

44import qualified Data.Map as Map

5+import qualified Data.Maybe as Maybe

67import qualified AST.Declaration as D

78import 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

911import qualified Docs.AST as Docs

1012import qualified Elm.Compiler.Type as Type

1113import qualified Elm.Compiler.Type.Extract as Extract

1214import qualified Reporting.Annotation as A

1315

1416

17+

1518-- CENTRALIZE DOCUMENTATION

1619

17−centralize :: [D.Canonical] -> String -> Docs.Centralized

18−centralize decls comment =

20+

21+centralize :: D.Canonical -> String -> Docs.Centralized

22+centralize (D.Decls defs unions aliases infixes) comment =

1923 let

20− (Raw aliases types valueInfo fixities) =

21− toRawDocs decls

24+ infixDict =

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+

2237

23− values =

24− Map.fromList (map (toValue fixities) (Map.toList valueInfo))

38+defToEntry

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

2563 in

26− Docs.Docs comment aliases types values

64+ (name, A.A region (Docs.Union maybeComment args ctors'))

2765

2866

29−toValue

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)) =

67+aliasToEntry :: A.Commented (D.Alias Type.Canonical) -> (String, A.Located Docs.Alias)

68+aliasToEntry (A.A (region, maybeComment) (D.Type name args tipe)) =

3469 ( name

35− , A.A region (Docs.Value maybeComment maybeType (Map.lookup name fixities))

70+ , A.A region (Docs.Alias maybeComment args (Extract.toAliasedType tipe))

3671 )

3772

3873

39−-- GATHER INFORMATION

40−

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

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 =

92− (D.assocToString assoc, precedence)

93− in

94− docs

95− { rawFixities =

96− Map.insert name fixity (rawFixities docs)

97− }

74+infixToEntry :: D.Infix -> (String, (String, Int))

75+infixToEntry (D.Infix name assoc precedence) =

76+ let

77+ fixity =

78+ (D.assocToString assoc, precedence)

79+ in

80+ ( name, fixity )

src/Generate/JavaScript.hs+8−8

@@ -5,7 +5,7 @@ import qualified Language.ECMAScript3.PrettyPrint as ES

55import qualified Language.ECMAScript3.Syntax as JS

66import qualified Text.PrettyPrint.Leijen as PP

8−import qualified AST.Effects as Fx

8+import qualified AST.Effects as Effects

99import qualified AST.Module as Module

1010import qualified AST.Module.Name as ModuleName

1111import qualified Generate.JavaScript.Expression as JS

@@ -35,16 +35,16 @@ generate (Module.Module moduleName _ info) =

3535-- GENERATE EFFECT MANAGER

3636

3737

38−generateEffectManager :: ModuleName.Canonical -> Fx.Effects -> [JS.Statement ()]

38+generateEffectManager :: ModuleName.Canonical -> Effects.Canonical -> [JS.Statement ()]

3939generateEffectManager moduleName effects =

4040 case effects of

41− Fx.None ->

41+ Effects.None ->

4242 []

4343

44− Fx.Foreign ->

44+ Effects.Foreign _ ->

4545 []

4646

47− Fx.Effect (Fx.Info _ _ _ _ managerType) ->

47+ Effects.Manager (Effects.Info _ _ _ _ managerType) ->

4848 let

4949 managers =

5050 Var.native (ModuleName.inCore ["Native","Platform"]) "globalManagerInfo"

@@ -65,13 +65,13 @@ generateEffectManager moduleName effects =

6565

6666 otherEntries =

6767 case managerType of

68− Fx.CmdManager _ ->

68+ Effects.CmdManager _ ->

6969 [ tagEntry "cmd", entry "cmdMap" ]

7070

71− Fx.SubManager _ ->

71+ Effects.SubManager _ ->

7272 [ tagEntry "sub", entry "subMap" ]

7373

74− Fx.FxManager _ _ ->

74+ Effects.FxManager _ _ ->

7575 [ tagEntry "fx", entry "cmdMap", entry "subMap" ]

7676

7777 addManager =

src/Generate/JavaScript/BuiltIn.hs+20−11

@@ -3,16 +3,15 @@ module Generate.JavaScript.BuiltIn

33 , list, range

44 , recordUpdate

55 , eq, cmp

6− , effect

6+ , effect, foreignCmd, foreignSub

77 , crash

88 )

99 where

1010

11−import Control.Arrow (first)

1211import qualified Language.ECMAScript3.Syntax as JS

1312

1413import qualified AST.Module.Name as ModuleName

15−import Generate.JavaScript.Helpers

14+import Generate.JavaScript.Helpers ((<|), (==>), call)

1615import qualified Generate.JavaScript.Variable as Var

1716import qualified Reporting.Region as R

1817

@@ -20,12 +19,12 @@ import qualified Reporting.Region as R

2019

2120utils :: String -> [JS.Expression ()] -> JS.Expression ()

2221utils func args =

23− Var.native (ModuleName.inCore ["Native","Utils"]) func `call` args

22+ Var.coreNative "Utils" func `call` args

2423

2524

2625nativeList :: String -> [JS.Expression ()] -> JS.Expression ()

2726nativeList func args =

28− Var.native (ModuleName.inCore ["Native","List"]) func `call` args

27+ Var.coreNative "List" func `call` args

2928

3029

3130

@@ -64,7 +63,7 @@ recordUpdate :: JS.Expression () -> [(String, JS.Expression ())] -> JS.Expressio

6463recordUpdate record fields =

6564 utils "update"

6665 [ record

67− , JS.ObjectLit () (map (first prop) fields)

66+ , JS.ObjectLit () (map (uncurry (==>)) fields)

6867 ]

6968

7069

@@ -92,6 +91,16 @@ effect effectName =

9291 JS.StringLit () (ModuleName.canonicalToString effectName)

9392

9493

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+

95104

96105-- CRASH

97106

@@ -113,14 +122,14 @@ crash home region maybeCaseCrashValue =

113122regionToJs :: R.Region -> JS.Expression ()

114123regionToJs (R.Region start end) =

115124 JS.ObjectLit ()

116− [ ( prop "start", positionToJs start )

117− , ( prop "end", positionToJs end )

125+ [ "start" ==> positionToJs start

126+ , "end" ==> positionToJs end

118127 ]

119128

120129

121130positionToJs :: R.Position -> JS.Expression ()

122131positionToJs (R.Position line column) =

123132 JS.ObjectLit ()

124− [ ( prop "line", JS.IntLit () line )

125− , ( prop "column", JS.IntLit () column )

126− ]

133+ [ "line" ==> JS.IntLit () line

134+ , "column" ==> JS.IntLit () column

135+ ]

src/Generate/JavaScript/Expression.hs+17−6

@@ -12,6 +12,7 @@ import qualified AST.Module.Name as ModuleName

1212import qualified AST.Variable as Var

1313import Generate.JavaScript.Helpers as Help

1414import qualified Generate.JavaScript.BuiltIn as BuiltIn

15+import qualified Generate.JavaScript.Foreign as Foreign

1516import qualified Generate.JavaScript.Literal as Literal

1617import qualified Generate.JavaScript.Variable as Var

1718import qualified Optimize.DecisionTree as DT

@@ -134,7 +135,7 @@ generateCode expr =

134135 let

135136 toField (field, value) =

136137 do jsValue <- generateJsExpr value

137− return (prop (Var.safe field), jsValue)

138+ return (Var.safe field ==> jsValue)

138139 in

139140 do jsFields <- mapM toField fields

140141 jsExpr $ ObjectLit () jsFields

@@ -186,12 +187,15 @@ generateCode expr =

186187 jsExpr $ BuiltIn.list jsElements

187188

188189 Data tag members ->

190+ let

191+ ctor =

192+ "ctor" ==> StringLit () tag

193+

194+ toEntry entry n =

195+ ("_" ++ show n) ==> entry

196+ in

189197 do jsMembers <- mapM generateJsExpr members

190− jsExpr $ ObjectLit () (ctor : fields jsMembers)

191− where

192− ctor = (prop "ctor", StringLit () tag)

193− fields =

194− zipWith (\n e -> (prop ("_" ++ show n), e)) [ 0 :: Int .. ]

198+ jsExpr $ ObjectLit () (ctor : zipWith toEntry jsMembers [ 0 :: Int .. ])

195199

196200 DataAccess dataExpr index ->

197201 do jsDataExpr <- generateJsExpr dataExpr

@@ -203,6 +207,13 @@ generateCode expr =

203207 Sub moduleName ->

204208 jsExpr $ BuiltIn.effect moduleName

205209

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+

206217 GLShader _uid src _tipe ->

207218 jsExpr $ ObjectLit () [(PropString () "src", Literal.literal (L.Str src))]

208219

src/Generate/JavaScript/Foreign.hsnew file+214

@@ -0,0 +1,214 @@

1+module Generate.JavaScript.Foreign (encode, decode) where

3+import qualified Data.List as List

4+import Language.ECMAScript3.Syntax

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 =

3333 VarRef () (var name)

3434

3535

36−prop :: String -> Prop ()

37−prop name =

38− PropId () (var name)

36+(==>) :: String -> Expression () -> (Prop (), Expression ())

37+(==>) name expr =

38+ ( PropId () (var name), expr )

3939

4040

4141obj :: [String] -> Expression ()

@@ -66,26 +66,3 @@ call :: Expression () -> [Expression ()] -> Expression ()

6666call =

6767 CallExpr ()

6868

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

44 , canonical

55 , qualified

66 , native

7+ , coreNative

78 , define

89 , safe

910 )

@@ -106,6 +107,11 @@ native moduleName name =

106107 JS.obj [ moduleToString moduleName, name ]

107108

108109

110+coreNative :: String -> String -> JS.Expression ()

111+coreNative moduleName name =

112+ native (ModuleName.inCore ["Native",moduleName]) name

113+

114+

109115getOpsDictName :: Var.Home -> String

110116getOpsDictName home =

111117 let

src/Nitpick/PatternMatches.hs+9−3

@@ -161,7 +161,7 @@ checkExpression tagDict (A.A region expression) =

161161 go body

162162 <* F.traverse_ goDef defs

163163 where

164− goDef (Canonical.Definition _ pattern@(A.A patRegion _) expr _) =

164+ goDef (Canonical.Def _ pattern@(A.A patRegion _) expr _) =

165165 checkPatterns tagDict patRegion Error.LetBound [pattern]

166166 <* go expr

167167

@@ -183,10 +183,16 @@ checkExpression tagDict (A.A region expression) =

183183 E.Record fields ->

184184 F.traverse_ (go . snd) fields

185185

186− E.Cmd _ _ ->

186+ E.Cmd _ ->

187187 Result.ok ()

188188

189− E.Sub _ _ ->

189+ E.Sub _ ->

190+ Result.ok ()

191+

192+ E.ForeignCmd _ _ ->

193+ Result.ok ()

194+

195+ E.ForeignSub _ _ ->

190196 Result.ok ()

191197

192198 E.SaveEnv _ _ ->

src/Nitpick/TopLevelTypes.hs+7−7

@@ -26,10 +26,10 @@ import qualified Reporting.Warning as Warning

2626

2727topLevelTypes

2828 :: Map.Map String Type.Canonical

29− -> [Decl.Valid]

29+ -> Decl.Valid

3030 -> Result.Result Warning.Warning Error.Error ()

31−topLevelTypes typeEnv validDecls =

32− do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing validDecls

31+topLevelTypes typeEnv (Decl.Decls defs _ _ _) =

32+ do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing defs

3333 maybe (return ()) (checkMainType typeEnv) maybeMainRegion

3434

3535

@@ -40,11 +40,11 @@ topLevelTypes typeEnv validDecls =

4040warnMissingAnnotation

4141 :: Map.Map String Type.Canonical

4242 -> Maybe R.Region

43− -> Decl.Valid

43+ -> A.Commented Valid.Def

4444 -> Result.Result Warning.Warning Error.Error (Maybe R.Region)

45−warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) decl) =

46− case decl of

47− Decl.Def (Valid.Definition (A.A _ (P.Var name)) _ maybeType) ->

45+warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =

46+ case def of

47+ Valid.Def (A.A _ (P.Var name)) _ maybeType ->

4848 do when (Maybe.isNothing maybeType) $

4949 Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name))

5050

src/Optimize.hs+9−3

@@ -53,7 +53,7 @@ flattenLets defs annExpr@(A.A _ expr) =

5353

5454

5555optimizeDef :: 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 _) =

5757 let

5858 (args, canBody) =

5959 Expr.collectLambdas expression

@@ -301,12 +301,18 @@ optimizeExpr context annExpr@(A.A region expression) =

301301 Opt.Record

302302 <$> T.traverse (mapSnd justConvert) fields

303303

304− Expr.Cmd moduleName _ ->

304+ Expr.Cmd moduleName ->

305305 pure (Opt.Cmd moduleName)

306306

307− Expr.Sub moduleName _ ->

307+ Expr.Sub moduleName ->

308308 pure (Opt.Sub moduleName)

309309

310+ Expr.ForeignCmd name tipe ->

311+ pure (Opt.ForeignCmd name tipe)

312+

313+ Expr.ForeignSub name tipe ->

314+ pure (Opt.ForeignSub name tipe)

315+

310316 Expr.SaveEnv _ _ ->

311317 error "save_the_environment should never make it to optimization phase"

312318

src/Optimize/Inline.hs+12

@@ -175,6 +175,12 @@ count expression =

175175 Sub _ ->

176176 Map.empty

177177

178+ ForeignCmd _ _ ->

179+ Map.empty

180+

181+ ForeignSub _ _ ->

182+ Map.empty

183+

178184 GLShader _ _ _ ->

179185 Map.empty

180186

@@ -280,6 +286,12 @@ replace substitutions expression =

280286 Sub _ ->

281287 expression

282288

289+ ForeignCmd _ _ ->

290+ expression

291+

292+ ForeignSub _ _ ->

293+ expression

294+

283295 GLShader _ _ _ ->

284296 expression

285297

src/Parse/Declaration.hs+22−6

@@ -16,6 +16,7 @@ declaration =

1616 choice

1717 [ typeDecl

1818 , infixDecl

19+ , foreignDecl

1920 , definition

2021 ]

2122

@@ -32,7 +33,7 @@ commentOr parser =

3233-- TYPE ANNOTATIONS and DEFINITIONS

3334

3435

35−definition :: IParser Decl.Source'

36+definition :: IParser Decl.Raw

3637definition =

3738 do def <- Expr.def <?> "a value definition"

3839 return $ Decl.Def def

@@ -42,7 +43,7 @@ definition =

4243-- TYPE ALIAS and UNION TYPES

4344

4445

45−typeDecl :: IParser Decl.Source'

46+typeDecl :: IParser Decl.Raw

4647typeDecl =

4748 do try (reserved "type") <?> "a type declaration"

4849 forcedWS

@@ -55,18 +56,18 @@ typeDecl =

5556 case isAlias of

5657 Just _ ->

5758 do tipe <- Type.expr <?> "a type"

58− return $ Decl.Alias name args tipe

59+ return $ Decl.Alias (Decl.Type name args tipe)

5960

6061 Nothing ->

6162 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)

6364

6465

6566

6667-- INFIX

6768

6869

69−infixDecl :: IParser Decl.Source'

70+infixDecl :: IParser Decl.Raw

7071infixDecl =

7172 expecting "an infix declaration" $

7273 do assoc <-

@@ -79,5 +80,20 @@ infixDecl =

7980 n <- digit

8081 forcedWS

8182 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

8399

src/Parse/Parse.hs+1−1

@@ -137,7 +137,7 @@ parseFixities =

137137 where

138138 infics =

139139 do start <- getMyPosition

140− (Decl.Fixity assoc level op) <- Parse.infixDecl

140+ (Decl.Fixity (Decl.Infix op assoc level)) <- Parse.infixDecl

141141 end <- getMyPosition

142142 return (op, InfixInfo (R.Region start end) (level, assoc))

143143

src/Reporting/Error/Canonicalize.hs+32−37

@@ -22,7 +22,7 @@ data Error

2222 | Import ModuleName.Raw ImportError

2323 | Export String [String]

2424 | DuplicateExport String

25− | Port PortError

25+ | Foreign ForeignError

2626

2727

2828

@@ -100,24 +100,18 @@ alias name expected actual =

100100-- PORTS

101101

102102

103−data PortError = PortError

104− { portName :: String

105− , portIsInbound :: Bool

106− , portRootType :: Type.Canonical

107− , portLocalType :: Type.Canonical

108− , portMessage :: Maybe String

103+data ForeignError =

104+ ForeignError

105+ { foreignName :: String

106+ , foreignKind :: String

107+ , foreignType :: Type.Canonical

108+ , foreignMessage :: Maybe String

109109 }

110110

111111

112−port

113− :: String

114− -> Bool

115− -> Type.Canonical

116− -> Type.Canonical

117− -> Maybe String

118− -> Error

119−port name isInbound rootType localType maybeMessage =

120− Port (PortError name isInbound rootType localType maybeMessage)

112+foreign :: String -> String -> Type.Canonical -> Maybe String -> Error

113+foreign name kind tipe maybeMessage =

114+ Foreign (ForeignError name kind tipe maybeMessage)

121115

122116

123117

@@ -228,26 +222,27 @@ toReport localizer err =

228222 ("You are trying to export `" ++ name ++ "` multiple times!")

229223 "Remove duplicates until there is only one listed."

230224

231− Port (PortError name isInbound _rootType localType maybeMessage) ->

232− let

233− boundPort =

234− if isInbound then "inbound port" else "outbound port"

235− in

236− Report.report

237− "PORT ERROR"

238− Nothing

239− ("Trying to send " ++ maybe "an unsupported type" id maybeMessage

240− ++ " through " ++ boundPort ++ " `" ++ name ++ "`"

241− )

242− ( Help.stack

243− [ text "The specific unsupported type is:"

244− , indent 4 (RenderType.toDoc localizer localType)

245− , text ("The types of values that can flow through " ++ boundPort ++ "s include:")

246− , indent 4 $ Help.reflowParagraph $

247− "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\

248− \ Tuples, Json.Values, and concrete records."

249− ]

250− )

225+ Foreign (ForeignError name kind tipe maybeMessage) ->

226+ let

227+ context =

228+ maybe "" (" the following " ++ ) maybeMessage

229+ in

230+ Report.report

231+ "FOREIGN ERROR"

232+ Nothing

233+ ("Only certain types can flow in and out of Elm. The `"

234+ ++ name ++ "` " ++ kind ++ " is trying to communicate an unsupported type."

235+ )

236+ ( Help.stack

237+ [ text ("The specific unsupported type is" ++ context ++ ":")

238+ , indent 4 (RenderType.toDoc localizer tipe)

239+ , text "The types of values that can flow through in and out of Elm include:"

240+ , indent 4 $ Help.reflowParagraph $

241+ "Ints, Floats, Bools, Strings, Maybes, Lists, Arrays,\

242+ \ Tuples, Json.Values, and concrete records."

243+ -- TODO add a note about custom decoders and encoders when they exist!

244+ ]

245+ )

251246

252247

253248argMismatchReport :: String -> Var.Canonical -> Int -> Int -> Report.Report

@@ -292,7 +287,7 @@ extractSuggestions err =

292287 DuplicateExport _ ->

293288 Nothing

294289

295− Port _ ->

290+ Foreign _ ->

296291 Nothing

297292

298293

src/Reporting/Error/Syntax.hs+16−23

@@ -16,8 +16,6 @@ data Error

1616 | BadFunctionName Int

1717 | BadPattern String

1818

19− | CommentAfterAnnotation String

20− | CommentOnComment

2119 | CommentOnNothing

2220

2321 | SettingsOnNormalModule

@@ -26,6 +24,7 @@ data Error

2624 | BadSettingOnEffectModule String

2725 | NoSettingsOnEffectModule

2826 | MissingManagerOnEffectModule String

27+ | UnexpectedForeign String

2928

3029 | InfixDuplicate String

3130 | TypeWithoutDefinition String

@@ -74,34 +73,17 @@ toReport _localizer err =

7473 ]

7574 )

7675

77− CommentAfterAnnotation name ->

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 ->

76+ CommentOnNothing ->

8977 Report.report

9078 "STRAY COMMENT"

9179 Nothing

92− ("This comment is followed by another documentation comment.")

80+ ("This documentation comment is not followed by anything.")

9381 ( Help.reflowParagraph $

9482 "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?"

9685 )

9786

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−

10587 SettingsOnNormalModule ->

10688 Report.report

10789 "BAD MODULE DECLARATION"

@@ -168,6 +150,17 @@ toReport _localizer err =

168150 \ <TODO> (please forgive me if I forgot to fill this in!)"

169151 )

170152

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+

171164 InfixDuplicate opName ->

172165 Report.report

173166 "INFIX OVERLAP"

src/Type/Constrain/Effects.hs+11−11

@@ -3,7 +3,7 @@ module Type.Constrain.Effects (constrain) where

44import qualified Data.Map as Map

6−import qualified AST.Effects as Fx

6+import qualified AST.Effects as Effects

77import qualified AST.Module.Name as ModuleName

88import qualified Reporting.Annotation as A

99import qualified Reporting.Error.Type as Error

@@ -17,26 +17,26 @@ import Type.Type

1717constrain

1818 :: Env.Environment

1919 -> ModuleName.Canonical

20− -> Fx.Effects

20+ -> Effects.Canonical

2121 -> IO TypeConstraint

2222constrain env moduleName effects =

2323 case effects of

24− Fx.None ->

24+ Effects.None ->

2525 return CSaveEnv

2626

27− Fx.Foreign ->

27+ Effects.Foreign _ ->

2828 return CSaveEnv

2929

30− Fx.Effect info ->

30+ Effects.Manager info ->

3131 constrainHelp env moduleName info

3232

3333

3434constrainHelp

3535 :: Env.Environment

3636 -> ModuleName.Canonical

37− -> Fx.Info

37+ -> Effects.Info

3838 -> IO TypeConstraint

39−constrainHelp env moduleName (Fx.Info tagRegion r0 r1 r2 managerType) =

39+constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

4040 let

4141 task t =

4242 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) =

8989addEffectArgs

9090 :: Env.Environment

9191 -> ModuleName.Canonical

92− -> Fx.ManagerType

92+ -> Effects.ManagerType

9393 -> Variable

9494 -> Type

9595 -> Type

@@ -103,12 +103,12 @@ addEffectArgs env moduleName managerType msg result =

103103 (Env.getType env (toTypeName fxName) <| VarN msg)

104104 in

105105 case managerType of

106− Fx.CmdManager cmd ->

106+ Effects.CmdManager cmd ->

107107 effectList cmd ==> result

108108

109− Fx.SubManager sub ->

109+ Effects.SubManager sub ->

110110 effectList sub ==> result

111111

112− Fx.FxManager cmd sub ->

112+ Effects.FxManager cmd sub ->

113113 effectList cmd ==> effectList sub ==> result

114114

src/Type/Constrain/Expression.hs+25−19

@@ -37,15 +37,17 @@ constrain env annotatedExpr@(A.A region expression) tipe =

3737 E.Literal lit ->

3838 Literal.constrain env region lit tipe

3939

40− E.Cmd moduleName typeName ->

41− do (vars, cmd) <-

42− Env.instantiateType env (ST.cmd moduleName typeName) Map.empty

43− return $ ex vars (CEqual (Error.Instance "command") region cmd tipe)

40+ E.Cmd _ ->

41+ return CTrue

4442

45− E.Sub moduleName typeName ->

46− do (vars, sub) <-

47− Env.instantiateType env (ST.sub moduleName typeName) Map.empty

48− return $ ex vars (CEqual (Error.Instance "subscription") region sub tipe)

43+ E.Sub _ ->

44+ return CTrue

45+

46+ E.ForeignCmd _ _ ->

47+ return CTrue

48+

49+ E.ForeignSub _ _ ->

50+ return CTrue

4951

5052 E.SaveEnv moduleName effects ->

5153 Effects.constrain env moduleName effects

@@ -462,7 +464,7 @@ collectPairs index items =

462464

463465

464466expandPattern :: Canonical.Def -> [Canonical.Def]

465−expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =

467+expandPattern def@(Canonical.Def facts lpattern expr maybeType) =

466468 let

467469 (A.A patternRegion pattern) =

468470 lpattern

@@ -474,23 +476,27 @@ expandPattern def@(Canonical.Definition facts lpattern expr maybeType) =

474476 _ ->

475477 mainDef : map toDef vars

476478 where

477− vars = P.boundVarList lpattern

479+ vars =

480+ P.boundVarList lpattern

478481

479− combinedName = "$" ++ concat vars

482+ combinedName =

483+ "$" ++ concat vars

480484

481485 pvar name =

482− A.A patternRegion (P.Var name)

486+ A.A patternRegion (P.Var name)

483487

484488 localVar name =

485− A.A patternRegion (E.localVar name)

489+ A.A patternRegion (E.localVar name)

486490

487− mainDef = Canonical.Definition facts (pvar combinedName) expr maybeType

491+ mainDef =

492+ Canonical.Def facts (pvar combinedName) expr maybeType

488493

489494 toDef name =

490− let extract =

491− E.Case (localVar combinedName) [(lpattern, localVar name)]

492− in

493− Canonical.Definition facts (pvar name) (A.A patternRegion extract) Nothing

495+ let

496+ extract =

497+ E.Case (localVar combinedName) [(lpattern, localVar name)]

498+ in

499+ Canonical.Def facts (pvar name) (A.A patternRegion extract) Nothing

494500

495501

496502

@@ -508,7 +514,7 @@ data Info = Info

508514

509515

510516constrainDef :: 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) =

512518 let qs = [] -- should come from the def, but I'm not sure what would live there...

513519 in

514520 case (pattern, maybeTipe) of

src/Validate.hs+240−251

@@ -1,14 +1,16 @@

11{-# OPTIONS_GHC -Wall #-}

22module Validate (module') where

4+import Prelude hiding (init)

45import Control.Monad (foldM, when)

56import qualified Data.Map as Map

7+import qualified Data.Maybe as Maybe

68import qualified Data.Set as Set

79import qualified Data.Foldable as F

810import qualified Data.Traversable as T

911

1012import AST.Expression.General as Expr

11−import qualified AST.Effects as Fx

13+import qualified AST.Effects as Effects

1214import qualified AST.Expression.Source as Source

1315import qualified AST.Expression.Valid as Valid

1416import qualified AST.Declaration as D

@@ -38,11 +40,12 @@ module' (Module.Module name path info) =

3840 (Module.Source tag settings docs exports imports decls) =

3941 info

4042 in

41− do validDecls <- declarations decls

42− validEffects <- validateEffects tag settings validDecls

43+ do (ValidStuff foreigns structure) <- validateDecls decls

44+

45+ validEffects <- validateEffects tag settings foreigns (D._defs structure)

4346

4447 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

4649

4750

4851

@@ -69,17 +72,19 @@ addDefaults pkgName imports =

6972validateEffects

7073 :: Module.SourceTag

7174 -> Module.SourceSettings

72− -> [D.Valid]

73− -> Result.Result wrn Error.Error Fx.Effects

74−validateEffects tag settings@(A.A _ pairs) decls =

75+ -> [A.Commented Effects.ForeignRaw]

76+ -> [A.Commented Valid.Def]

77+ -> Result.Result wrn Error.Error Effects.Raw

78+validateEffects tag settings@(A.A _ pairs) foreigns validDefs =

7579 case tag of

7680 Module.Normal ->

7781 do noSettings Error.SettingsOnNormalModule settings

78− return Fx.None

82+ noForeigns foreigns

83+ return Effects.None

7984

8085 Module.Foreign _ ->

8186 do noSettings Error.SettingsOnForeignModule settings

82− return Fx.Foreign

87+ return (Effects.Foreign foreigns)

8388

8489 Module.Effect tagRegion ->

8590 let

@@ -89,9 +94,10 @@ validateEffects tag settings@(A.A _ pairs) decls =

8994 settingsDict =

9095 foldr collectSettings Map.empty pairs

9196 in

92− do managerType <- toManagerType tagRegion settingsDict

93− (r0, r1, r2) <- checkManagerImpl tagRegion managerType noInfo decls

94− return (Fx.Effect (Fx.Info tagRegion r0 r1 r2 managerType))

97+ do noForeigns foreigns

98+ managerType <- toManagerType tagRegion settingsDict

99+ (r0, r1, r2) <- checkManager tagRegion managerType validDefs

100+ return (Effects.Manager (Effects.Info tagRegion r0 r1 r2 managerType))

95101

96102

97103noSettings

@@ -107,10 +113,24 @@ noSettings errorMsg (A.A region settings) =

107113 Result.throw region errorMsg

108114

109115

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+

110130toManagerType

111131 :: R.Region

112132 -> Map.Map String [(R.Region, A.Located String)]

113− -> Result.Result wrn Error.Error Fx.ManagerType

133+ -> Result.Result wrn Error.Error Effects.ManagerType

114134toManagerType tagRegion settingsDict =

115135 let

116136 toErrors name entries =

@@ -129,18 +149,19 @@ toManagerType tagRegion settingsDict =

129149 (,) <$> extractOne "command" settingsDict

130150 <*> extractOne "subscription" settingsDict

131151

152+ -- TODO check that cmd and sub types exist?

132153 case maybeEffects of

133154 (Nothing, Nothing) ->

134155 Result.throw tagRegion Error.NoSettingsOnEffectModule

135156

136157 (Just cmd, Nothing) ->

137− return (Fx.CmdManager cmd)

158+ return (Effects.CmdManager cmd)

138159

139160 (Nothing, Just sub) ->

140− return (Fx.SubManager sub)

161+ return (Effects.SubManager sub)

141162

142163 (Just cmd, Just sub) ->

143− return (Fx.FxManager cmd sub)

164+ return (Effects.FxManager cmd sub)

144165

145166

146167extractOne

@@ -163,95 +184,65 @@ extractOne name settingsDict =

163184

164185

165186

166−-- EFFECT REGIONS

167−

187+-- CHECK EFFECT MANAGER

168188

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

182189

183−

184−checkManagerImpl

190+checkManager

185191 :: R.Region

186− -> Fx.ManagerType

187− -> ManagerInfo

188− -> [D.Valid]

192+ -> Effects.ManagerType

193+ -> [A.Commented Valid.Def]

189194 -> Result.Result w Error.Error (R.Region, R.Region, R.Region)

190−checkManagerImpl tagRegion managerType info decls =

191− case decls of

192− [] ->

193− let

194− (ManagerInfo cmdMap subMap init onEffects onSelfMsg) = info

195− in

196− const (,,)

197− <$> requireMaps tagRegion managerType cmdMap subMap

198− <*> requireRegion tagRegion "init" init

199− <*> requireRegion tagRegion "onEffects" onEffects

200− <*> requireRegion tagRegion "onSelfMsg" 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

195+checkManager tagRegion managerType validDefs =

196+ let

197+ regionDict =

198+ Map.fromList (Maybe.mapMaybe getSimpleDefRegion validDefs)

199+ in

200+ const (,,)

201+ <$> requireMaps tagRegion regionDict managerType

202+ <*> requireRegion tagRegion regionDict "init"

203+ <*> requireRegion tagRegion regionDict "onEffects"

204+ <*> requireRegion tagRegion regionDict "onSelfMsg"

221205

222206

223−getDefInfo :: D.Valid -> Maybe (String, R.Region)

224−getDefInfo decl =

207+getSimpleDefRegion :: A.Commented Valid.Def -> Maybe (String, R.Region)

208+getSimpleDefRegion decl =

225209 case decl of

226− A.A region (D.Def (Valid.Definition (A.A _ (Pattern.Var name)) _ _)) ->

227− Just (name, fst region)

210+ A.A (region, _) (Valid.Def (A.A _ (Pattern.Var name)) _ _) ->

211+ Just (name, region)

228212

229213 _ ->

230214 Nothing

231215

232216

233−requireMaps :: R.Region -> Fx.ManagerType -> Bool -> Bool -> Result.Result w Error.Error ()

234−requireMaps tagRegion managerType hasCmdMap hasSubMap =

217+requireMaps

218+ :: R.Region

219+ -> Map.Map String R.Region

220+ -> Effects.ManagerType

221+ -> Result.Result w Error.Error ()

222+requireMaps tagRegion regionDict managerType =

235223 let

236− check hasIt name =

237− when (not hasIt) (Result.throw tagRegion (Error.MissingManagerOnEffectModule name))

224+ check name =

225+ when (Map.notMember name regionDict) $

226+ Result.throw tagRegion (Error.MissingManagerOnEffectModule name)

238227 in

239228 case managerType of

240− Fx.CmdManager _ ->

241− check hasCmdMap "cmdMap"

229+ Effects.CmdManager _ ->

230+ check "cmdMap"

242231

243− Fx.SubManager _ ->

244− check hasSubMap "subMap"

232+ Effects.SubManager _ ->

233+ check "subMap"

245234

246− Fx.FxManager _ _ ->

247− (\_ _ -> ())

248− <$> check hasCmdMap "cmdMap"

249− <*> check hasSubMap "subMap"

235+ Effects.FxManager _ _ ->

236+ check "cmdMap" <* check "subMap"

250237

251238

252−requireRegion :: R.Region -> String -> Maybe R.Region -> Result.Result w Error.Error R.Region

253−requireRegion tagRegion name maybeRegion =

254− case maybeRegion of

239+requireRegion

240+ :: R.Region

241+ -> Map.Map String R.Region

242+ -> String

243+ -> Result.Result w Error.Error R.Region

244+requireRegion tagRegion regionDict name =

245+ case Map.lookup name regionDict of

255246 Just region ->

256247 return region

257248

@@ -263,30 +254,23 @@ requireRegion tagRegion name maybeRegion =

263254-- COLLAPSE COMMENTS

264255

265256

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]

273258collapseComments listWithComments =

274259 case listWithComments of

275260 [] ->

276261 Result.ok []

277262

278− D.Comment msg : D.Whatever (A.A region a) : rest ->

263+ D.Comment (A.A _ msg) : D.Whatever (A.A region a) : rest ->

279264 let

280265 entry =

281266 A.A (region, Just msg) a

282267 in

283268 fmap (entry:) (collapseComments rest)

284269

285− D.Comment (A.A region _) : D.Comment _ : _ ->

286− Result.throw region Error.CommentOnComment

270+ D.Comment (A.A region _) : rest ->

271+ collapseComments rest

272+ <* Result.throw region Error.CommentOnNothing

287273

288− [D.Comment (A.A region _)] ->

289− Result.throw region Error.CommentOnNothing

290274

291275 D.Whatever (A.A region a) : rest ->

292276 let

@@ -300,87 +284,92 @@ collapseComments listWithComments =

300284-- VALIDATE STRUCTURED SOURCE

301285

302286

303−declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]

304−declarations sourceDecls =

305− do decls <-

306− collapseComments sourceDecls

287+validateDecls :: [D.Source] -> Result.Result wrn Error.Error ValidStuff

288+validateDecls sourceDecls =

289+ do rawDecls <- collapseComments sourceDecls

307290

308− validDecls <-

309− validateDecls decls

291+ validStuff <- validateRawDecls rawDecls

310292

311− F.traverse_ id

312− (declDuplicates validDecls : map findBadTypeVars validDecls)

293+ let (D.Decls _ unions aliases _) = _structure validStuff

313294

314− return validDecls

295+ return validStuff

296+ <* F.traverse_ checkTypeVarsInUnion unions

297+ <* F.traverse_ checkTypeVarsInAlias aliases

298+ <* checkDuplicates validStuff

315299

316300

317301

318302-- VALIDATE DECLARATIONS

319303

320304

321−validateDecls

322− :: [Commented D.Source']

323− -> Result.Result wrn Error.Error [D.Valid]

324−validateDecls commentedDecls =

305+data ValidStuff =

306+ ValidStuff

307+ { _foreigns :: [A.Commented Effects.ForeignRaw]

308+ , _structure :: D.Valid

309+ }

310+

311+

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

322+vrdHelp commentedDecls foreigns structure =

325323 case commentedDecls of

326324 [] ->

327− Result.ok []

325+ Result.ok (ValidStuff foreigns structure)

328326

329− A.A (region, maybeComment) 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

339− D.Union name tvars ctors ->

340− addRest (D.Union name tvars ctors)

327+ A.A ann decl : rest ->

328+ case decl of

329+ D.Union (D.Type name tvars ctors) ->

330+ vrdHelp rest foreigns (D.addUnion (A.A ann (D.Type name tvars ctors)) structure)

341331

342− D.Alias name tvars alias ->

343− addRest (D.Alias name tvars alias)

332+ D.Alias (D.Type name tvars alias) ->

333+ vrdHelp rest foreigns (D.addAlias (A.A ann (D.Type name tvars alias)) structure)

344334

345− D.Fixity assoc prec op ->

346− addRest (D.Fixity assoc prec op)

335+ D.Fixity fixity ->

336+ vrdHelp rest foreigns (D.addInfix fixity structure)

347337

348− D.Def def ->

349− validateDeclsHelp maybeComment def rest

338+ D.Def (A.A region def) ->

339+ vrdDefHelp rest (A.A (region, snd ann) def) foreigns structure

350340

341+ D.Foreign name tipe ->

342+ vrdHelp rest (A.A ann (Effects.ForeignRaw name tipe) : foreigns) structure

351343

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)

361344

362− makeDef pat expr maybeType =

363− D.Def (Valid.Definition pat expr maybeType)

345+vrdDefHelp

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)

364355 in

365356 case def of

366357 Source.Definition pat expr ->

367− (:)

368− <$> validateDef makeDef ann pat expr Nothing

369− <*> validateDecls decls

358+ addDef

359+ <$> validateDef pat expr Nothing

360+ <*> vrdHelp remainingDecls foreigns structure

370361

371362 Source.Annotation name tipe ->

372− case decls of

373− A.A (_, Just (A.A commentRegion _)) _ : _ ->

374− Result.throw commentRegion (Error.CommentAfterAnnotation name)

375−

363+ case remainingDecls of

376364 A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest

377365 | Pattern.isVar name pat ->

378− (:)

379− <$> validateDef makeDef ann pat expr (Just tipe)

380− <*> validateDecls rest

366+ addDef

367+ <$> validateDef pat expr (Just tipe)

368+ <*> vrdHelp rest foreigns structure

381369

382370 _ ->

383− Result.throw region (Error.TypeWithoutDefinition name)

371+ vrdHelp remainingDecls foreigns structure

372+ <* Result.throw (fst ann) (Error.TypeWithoutDefinition name)

384373

385374

386375

@@ -390,8 +379,12 @@ validateDeclsHelp maybeComment (A.A region def) decls =

390379definitions :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

391380definitions sourceDefs =

392381 do validDefs <- definitionsHelp sourceDefs

393− let patterns = map (\(Valid.Definition p _ _) -> p) validDefs

394− defDuplicates patterns

382+

383+ validDefs

384+ |> map Valid.getPattern

385+ |> concatMap Pattern.boundVars

386+ |> detectDuplicates Error.DuplicateDefinition

387+

395388 return validDefs

396389

397390

@@ -401,34 +394,32 @@ definitionsHelp sourceDefs =

401394 [] ->

402395 return []

403396

404− A.A region (Source.Definition pat expr) : rest ->

397+ A.A _ (Source.Definition pat expr) : rest ->

405398 (:)

406− <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)

399+ <$> validateDef pat expr Nothing

407400 <*> definitionsHelp rest

408401

409− A.A r1 (Source.Annotation name tipe) : rest ->

402+ A.A region (Source.Annotation name tipe) : rest ->

410403 case rest of

411− A.A r2 (Source.Definition pat expr) : rest'

404+ A.A _ (Source.Definition pat expr) : rest'

412405 | Pattern.isVar name pat ->

413406 (:)

414− <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))

407+ <$> validateDef pat expr (Just tipe)

415408 <*> definitionsHelp rest'

416409

417410 _ ->

418− Result.throw r1 (Error.TypeWithoutDefinition name)

411+ Result.throw region (Error.TypeWithoutDefinition name)

419412

420413

421414validateDef

422− :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)

423− -> annotation

424− -> Pattern.Raw

415+ :: Pattern.Raw

425416 -> Source.Expr

426417 -> Maybe Type.Raw

427− -> Result.Result wrn Error.Error (A.Annotated annotation def)

428−validateDef makeDef annotation pat expr maybeType =

418+ -> Result.Result wrn Error.Error Valid.Def

419+validateDef pat expr maybeType =

429420 do validExpr <- expression expr

430421 validateDefPattern pat validExpr

431− return $ A.A annotation (makeDef pat validExpr maybeType)

422+ return $ Valid.Def pat validExpr maybeType

432423

433424

434425validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()

@@ -528,11 +519,17 @@ expression (A.A ann sourceExpression) =

528519 <$> definitions defs

529520 <*> expression body

530521

531− Cmd moduleName typeName ->

532− return (Cmd moduleName typeName)

522+ Cmd moduleName ->

523+ return (Cmd moduleName)

533524

534− Sub moduleName typeName ->

535− return (Sub moduleName typeName)

525+ Sub moduleName ->

526+ return (Sub moduleName)

527+

528+ ForeignCmd name tipe ->

529+ return (ForeignCmd name tipe)

530+

531+ ForeignSub name tipe ->

532+ return (ForeignSub name tipe)

536533

537534 SaveEnv moduleName effects ->

538535 return (SaveEnv moduleName effects)

@@ -567,112 +564,105 @@ validatePattern pattern =

567564-- DETECT DUPLICATES

568565

569566

570−detectDuplicates

571− :: (String -> Error.Error)

572− -> [A.Located String]

573− -> Result.Result wrn Error.Error ()

574−detectDuplicates tag names =

575− let add (A.A region name) dict =

576− Map.insertWith (++) name [region] dict

567+checkDuplicates :: ValidStuff -> Result.Result wrn Error.Error ()

568+checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =

569+ let

570+ -- SIMPLE NAMES

577571

578− makeGroups pairs =

579− Map.toList (foldr add Map.empty pairs)

572+ defValues =

573+ concatMap (Pattern.boundVars . Valid.getPattern . A.drop) defs

580574

581− check (name, regions) =

582− case regions of

583− _ : region : _ ->

584− Result.throw region (tag name)

575+ foreignValues =

576+ map fromForeign foreigns

585577

586− _ ->

587− return ()

588− in

589− F.traverse_ check (makeGroups names)

578+ fromForeign (A.A (region, _) (Effects.ForeignRaw name _)) =

579+ A.A region name

590580

581+ -- TYPE NAMES

591582

592−defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()

593−defDuplicates patterns =

594− concatMap Pattern.boundVars patterns

595− |> detectDuplicates Error.DuplicateDefinition

583+ (types, typeValues) =

584+ unzip (map fromUnion unions ++ map fromAlias aliases)

596585

586+ fromUnion (A.A (region, _) (D.Type name _ ctors)) =

587+ ( A.A region name

588+ , map (A.A region . fst) ctors

589+ )

597590

598−declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()

599−declDuplicates decls =

600− let

601− (valueLists, typeLists) =

602− unzip (map extractValues decls)

603− in

604− (\_ _ -> ())

605− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)

606− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)

591+ fromAlias (A.A (region, _) (D.Type name _ (A.A _ tipe))) =

592+ (,) (A.A region name) $

593+ case tipe of

594+ Type.RRecord _ _ ->

595+ [A.A region name]

607596

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+ ]

608605

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− )

616606

617− D.Union name _ ctors ->

618− ( map (A.A region . fst) ctors

619− , [A.A region name]

620− )

607+detectDuplicates

608+ :: (String -> Error.Error)

609+ -> [A.Located String]

610+ -> Result.Result wrn Error.Error ()

611+detectDuplicates tag names =

612+ let

613+ add (A.A region name) dict =

614+ Map.insertWith (++) name [region] dict

621615

622− D.Alias name _ (A.A _ (Type.RRecord _ _)) ->

623− ( [A.A region name]

624− , [A.A region name]

625− )

616+ makeGroups pairs =

617+ Map.toList (foldr add Map.empty pairs)

626618

627− D.Alias name _ _ ->

628− ( []

629− , [A.A region name]

630− )

619+ check (name, regions) =

620+ case regions of

621+ _ : region : _ ->

622+ Result.throw region (tag name)

631623

632− D.Fixity _ _ _ ->

633− ( []

634− , []

635− )

624+ _ ->

625+ return ()

626+ in

627+ F.traverse_ check (makeGroups names)

636628

637629

638630

639631-- UNBOUND TYPE VARIABLES

640632

641633

642−findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()

643−findBadTypeVars (A.A (region,_) decl) =

644− case decl of

645− D.Def _ ->

634+checkTypeVarsInUnion

635+ :: A.Commented (D.Union Type.Raw)

636+ -> Result.Result wrn Error.Error ()

637+checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =

638+ case diff boundVars (concatMap freeVars (concatMap snd ctors)) of

639+ (_, []) ->

646640 return ()

647641

648− D.Union name boundVars ctors ->

649− case diff boundVars (concatMap freeVars (concatMap snd ctors)) of

650− (_, []) ->

651− return ()

642+ (_, unbound) ->

643+ Result.throw region

644+ (Error.UnboundTypeVarsInUnion name boundVars unbound)

652645

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 ()

661646

662− ([], unbound) ->

663− Result.throw region

664− (Error.UnboundTypeVarsInAlias name boundVars unbound)

647+checkTypeVarsInAlias

648+ :: A.Commented (D.Alias Type.Raw)

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 ()

665654

666− (unused, []) ->

667− Result.throw region

668− (Error.UnusedTypeVarsInAlias name boundVars unused)

655+ ([], unbound) ->

656+ Result.throw region

657+ (Error.UnboundTypeVarsInAlias name boundVars unbound)

669658

670− (unused, unbound) ->

671− Result.throw region

672− (Error.MessyTypeVarsInAlias name boundVars unused unbound)

659+ (unused, []) ->

660+ Result.throw region

661+ (Error.UnusedTypeVarsInAlias name boundVars unused)

673662

674− D.Fixity _ _ _ ->

675− return ()

663+ (unused, unbound) ->

664+ Result.throw region

665+ (Error.MessyTypeVarsInAlias name boundVars unused unbound)

676666

677667

678668diff :: [String] -> [A.Located String] -> ([String], [String])

@@ -689,7 +679,6 @@ diff left right =

689679 )

690680

691681

692−

693682freeVars :: Type.Raw -> [A.Located String]

694683freeVars (A.A region tipe) =

695684 case tipe of