fa09513 · elk · git.iko.soy

elm-compiler.cabal+2

compare with master

unifiedsplit

@@ -48,6 +48,7 @@ Library

48

49 other-modules:

50 AST.Declaration,

51+ AST.Effects,

51 AST.Expression.Canonical,

52 AST.Expression.Canonical,

52 AST.Expression.General,

53 AST.Expression.General,

53 AST.Expression.Optimized,

54 AST.Expression.Optimized,

@@ -112,6 +113,7 @@ Library

112 Reporting.Report,

113 Reporting.Report,

113 Reporting.Result,

114 Reporting.Result,

114 Reporting.Warning,

115 Reporting.Warning,

116+ Type.Constrain.Effects,

115 Type.Constrain.Expression,

117 Type.Constrain.Expression,

116 Type.Constrain.Literal,

118 Type.Constrain.Literal,

117 Type.Constrain.Pattern,

119 Type.Constrain.Pattern,

src/AST/Effects.hsnew file+27

@@ -0,0 +1,27 @@

1+module AST.Effects where

2+

3+import qualified Reporting.Annotation as A

4+import qualified Reporting.Region as R

5+

6+

7+

8+data Effects

9+ = None

10+ | Effect Info

11+ | Foreign

12+

13+

14+data Info =

15+ Info

16+ { _tag :: R.Region

17+ , _init :: R.Region

18+ , _onEffects :: R.Region

19+ , _onSelfMsg :: R.Region

20+ , _type :: ManagerType

21+ }

22+

23+

24+data ManagerType

25+ = CmdManager (A.Located String)

26+ | SubManager (A.Located String)

27+ | FxManager (A.Located String) (A.Located String)

src/AST/Expression/General.hs+2−14

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

8-}

9module AST.Expression.General where

10

11+import qualified AST.Effects as Fx

11import qualified AST.Literal as Literal

12import qualified AST.Literal as Literal

12import qualified AST.Module.Name as ModuleName

13import qualified AST.Module.Name as ModuleName

13import qualified AST.Pattern as Pattern

14import qualified AST.Pattern as Pattern

@@ -56,6 +57,7 @@ data Expr' ann def var typ

56 -- for type checking and code gen only

57 -- for type checking and code gen only

57 | Cmd ModuleName.Canonical String

58 | Cmd ModuleName.Canonical String

58 | Sub ModuleName.Canonical String

59 | Sub ModuleName.Canonical String

60+ | SaveEnv ModuleName.Canonical Fx.Effects

59 | GLShader String String Literal.GLShaderTipe

61 | GLShader String String Literal.GLShaderTipe

60

62

61

63

@@ -78,20 +80,6 @@ tuple expressions =

78 Data ("_Tuple" ++ show (length expressions)) expressions

80 Data ("_Tuple" ++ show (length expressions)) expressions

79

81

80

82

81−saveEnvName :: String

82−saveEnvName =

83− "_save_the_environment!!!"

84−

85−

86−dummyLet :: [def] -> Expr ann def Var.Canonical typ

87−dummyLet defs =

88− let

89− body =

90− A.A undefined (Var (Var.builtin saveEnvName))

91− in

92− A.A undefined (Let defs body)

93−

94−

95collectApps :: Expr ann def var typ -> [Expr ann def var typ]

83collectApps :: Expr ann def var typ -> [Expr ann def var typ]

96collectApps annExpr@(A.A _ expr) =

84collectApps annExpr@(A.A _ expr) =

97 case expr of

85 case expr of

src/AST/Module.hs+10−13

@@ -2,7 +2,7 @@ module AST.Module

2 ( Header(..), Module(..)

3

4 , Source, SourceInfo(..), SourceTag(..), SourceSettings, emptySettings

5− , Valid, ValidInfo(..), ValidEffects(..)

5+ , Valid, ValidInfo(..)

6 , Canonical, Optimized, Info(..)

7

8 , UserImport, DefaultImport, ImportMethod(..)

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

19import qualified Data.Map as Map

20

21import qualified AST.Declaration as Decl

22+import qualified AST.Effects as Fx

22import qualified AST.Expression.Canonical as Canonical

23import qualified AST.Expression.Canonical as Canonical

23import qualified AST.Expression.Optimized as Optimized

24import qualified AST.Expression.Optimized as Optimized

24import qualified AST.Module.Name as Name

25import qualified AST.Module.Name as Name

@@ -28,6 +29,7 @@ import qualified Docs.AST as Docs

28import qualified Elm.Package as Package

29import qualified Elm.Package as Package

29import qualified Elm.Compiler.Version as Compiler

30import qualified Elm.Compiler.Version as Compiler

30import qualified Reporting.Annotation as A

31import qualified Reporting.Annotation as A

32+import qualified Reporting.Region as R

31

33

32

34

33

35

@@ -74,9 +76,9 @@ data SourceInfo =

74

76

75

77

76data SourceTag

78data SourceTag

77− = SrcNormal

79+ = Normal

78− | SrcEffect

80+ | Effect R.Region

79− | SrcForeign

81+ | Foreign R.Region

80

82

81

83

82type SourceSettings =

84type SourceSettings =

@@ -98,16 +100,10 @@ data ValidInfo =

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

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

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

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

100 , validDecls :: [Decl.Valid]

102 , validDecls :: [Decl.Valid]

101− , validEffects :: ValidEffects

103+ , validEffects :: Fx.Effects

102 }

104 }

103

105

104

106

105−data ValidEffects

106− = ValidNormal

107− | ValidEffect (Maybe (A.Located String)) (Maybe (A.Located String))

108− | ValidForeign

109−

110−

111type Canonical =

107type Canonical =

112 Module (Info Canonical.Expr)

108 Module (Info Canonical.Expr)

113

109

@@ -137,16 +133,17 @@ data ImportMethod =

137-- LATE PHASE MODULE INFORMATION

133-- LATE PHASE MODULE INFORMATION

138

134

139

135

140−data Info expr =

136+data Info program =

141 Info

137 Info

142 { docs :: A.Located (Maybe Docs.Centralized)

138 { docs :: A.Located (Maybe Docs.Centralized)

143 , exports :: [Var.Value]

139 , exports :: [Var.Value]

144 , imports :: [Name.Raw]

140 , imports :: [Name.Raw]

145− , program :: expr

141+ , program :: program

146 , types :: Types

142 , types :: Types

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

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

148 , aliases :: Aliases

144 , aliases :: Aliases

149 , unions :: Unions

145 , unions :: Unions

146+ , effects :: Fx.Effects

150 }

147 }

151

148

152

149

src/Canonicalize.hs+4

@@ -99,6 +99,7 @@ module' canonicalImports interfaces modul =

99 , Module.fixities = fixities

100 , Module.aliases = aliases

101 , Module.unions = unions

102+ , Module.effects = effects

102 }

103 }

104 }

104

105

@@ -440,6 +441,9 @@ expression env (A.A region validExpr) =

440 Sub moduleName string ->

441 Sub moduleName string ->

441 Result.ok (Sub moduleName string)

442 Result.ok (Sub moduleName string)

442

443

444+ SaveEnv moduleName effects ->

445+ Result.ok (SaveEnv moduleName effects)

446+

443 GLShader uid src tipe ->

447 GLShader uid src tipe ->

444 Result.ok (GLShader uid src tipe)

448 Result.ok (GLShader uid src tipe)

445

449

src/Canonicalize/Body.hs+33−25

@@ -2,9 +2,9 @@

2module Canonicalize.Body (flatten) where

3

4import qualified AST.Declaration as D

5+import qualified AST.Effects as Fx

5import qualified AST.Expression.General as E

6import qualified AST.Expression.General as E

6import qualified AST.Expression.Canonical as Canonical

7import qualified AST.Expression.Canonical as Canonical

7−import qualified AST.Module as Module

8import qualified AST.Module.Name as ModuleName

9import qualified AST.Pattern as P

10import qualified AST.Type as T

@@ -15,7 +15,7 @@ import qualified Reporting.Region as R

15

16

17

18−flatten :: ModuleName.Canonical -> [D.Canonical] -> Module.ValidEffects -> Canonical.Expr

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

19flatten moduleName decls effects =

20 let

21 declDefs =

@@ -23,8 +23,14 @@ flatten moduleName decls effects =

23

24 effectDefs =

25 effectsToDefs moduleName effects

26+

27+ loc =

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

26 in

29 in

30+ Sort.definitions $ loc $

31+ E.Let

27− Sort.definitions (E.dummyLet (declDefs ++ effectDefs))

32+ (declDefs ++ effectDefs)

33+ (loc $ E.SaveEnv moduleName effects)

28

34

29

35

30

36

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

112-- EFFECTS

118-- EFFECTS

113

119

114

120

115−effectsToDefs :: ModuleName.Canonical -> Module.ValidEffects -> [Canonical.Def]

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

116effectsToDefs moduleName effects =

122effectsToDefs moduleName effects =

117 case effects of

123 case effects of

118− Module.ValidNormal ->

124+ Fx.None ->

119 []

125 []

120

126

121− Module.ValidEffect maybeCmd maybeSub ->

127+ Fx.Foreign ->

122− effectsToDefsHelp "command" (E.Cmd moduleName) maybeCmd

123− ++ effectsToDefsHelp "subscription" (E.Sub moduleName) maybeSub

124−

125− Module.ValidForeign ->

126 []

128 []

127

129

130+ Fx.Effect info ->

131+ case Fx._type info of

132+ Fx.CmdManager cmd ->

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

134+

135+ Fx.SubManager sub ->

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

137+

138+ Fx.FxManager cmd sub ->

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

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

141+ ]

142+

128

143

129effectsToDefsHelp

144effectsToDefsHelp

130 :: String

145 :: String

131 -> (String -> Canonical.Expr')

146 -> (String -> Canonical.Expr')

132− -> Maybe (A.Located String)

147+ -> A.Located String

133− -> [Canonical.Def]

148+ -> Canonical.Def

134−effectsToDefsHelp name toExpr' maybeEffect =

149+effectsToDefsHelp name toExpr' (A.A region typeName) =

135− case maybeEffect of

136− Nothing ->

137− []

138−

139− Just (A.A region typeName) ->

140− [ Canonical.Definition

150+ Canonical.Definition

141− Canonical.dummyFacts

151+ Canonical.dummyFacts

142− (A.A region (P.Var name))

152+ (A.A region (P.Var name))

143− (A.A region (toExpr' typeName))

153+ (A.A region (toExpr' typeName))

144− Nothing

154+ Nothing

145− ]

146−

src/Canonicalize/Environment.hs+1−2

@@ -13,7 +13,6 @@ import qualified Data.Map as Map

13import qualified Data.Maybe as Maybe

14import qualified Data.Set as Set

15

16−import AST.Expression.General (saveEnvName)

17import qualified AST.Module.Name as ModuleName

16import qualified AST.Module.Name as ModuleName

18import qualified AST.Pattern as P

17import qualified AST.Pattern as P

19import qualified AST.Type as Type

18import qualified AST.Type as Type

@@ -112,7 +111,7 @@ insert key value =

112builtinPatches :: [Patch]

111builtinPatches :: [Patch]

113builtinPatches =

112builtinPatches =

114 concat

113 concat

115− [ map (patch Value) (tupleNames ++ [saveEnvName])

114+ [ map (patch Value) tupleNames

116 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])

115 , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])

117 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])

116 , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])

118 ]

117 ]

src/Canonicalize/Setup.hs+15−9

@@ -8,6 +8,7 @@ import qualified Data.Maybe as Maybe

8import qualified Data.Traversable as Trav

9

10import qualified AST.Declaration as D

11+import qualified AST.Effects as Fx

11import qualified AST.Expression.Valid as Valid

12import qualified AST.Expression.Valid as Valid

12import qualified AST.Module as Module

13import qualified AST.Module as Module

13import qualified AST.Module.Name as ModuleName

14import qualified AST.Module.Name as ModuleName

@@ -367,21 +368,26 @@ declToPatches moduleName (A.A (region,_) decl) =

367-- EFFECTS TO PATCHES

368-- EFFECTS TO PATCHES

368

369

370

370−effectsToPatches :: ModuleName.Canonical -> Module.ValidEffects -> [Env.Patch]

371+effectsToPatches :: ModuleName.Canonical -> Fx.Effects -> [Env.Patch]

371effectsToPatches moduleName effects =

372effectsToPatches moduleName effects =

372 case effects of

373 case effects of

373− Module.ValidNormal ->

374+ Fx.None ->

374 []

375 []

375

376

376− Module.ValidEffect maybeCmd maybeSub ->

377+ Fx.Foreign ->

378+ []

379+

380+ Fx.Effect info ->

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

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

378− Maybe.catMaybes

382+ case Fx._type info of

383+ Fx.CmdManager _ ->

379− [ fmap (const "command") maybeCmd

384+ [ "command" ]

380− , fmap (const "subscription") maybeSub

381− ]

382

385

383− Module.ValidForeign ->

386+ Fx.SubManager _ ->

384− []

387+ [ "subscription" ]

388+

389+ Fx.FxManager _ _ ->

390+ [ "command", "subscription" ]

385

391

386

392

387

393

src/Canonicalize/Sort.hs+3

@@ -102,6 +102,9 @@ reorder (A.A ann expression) =

102 Sub _ _ ->

103 return expression

104

105+ SaveEnv _ _ ->

106+ return expression

107+

105 GLShader _ _ _ ->

108 GLShader _ _ _ ->

106 return expression

109 return expression

107

110

src/Nitpick/PatternMatches.hs+3

@@ -189,6 +189,9 @@ checkExpression tagDict (A.A region expression) =

189 E.Sub _ _ ->

190 Result.ok ()

191

192+ E.SaveEnv _ _ ->

193+ Result.ok ()

194+

192 E.GLShader _ _ _ ->

195 E.GLShader _ _ _ ->

193 Result.ok ()

196 Result.ok ()

194

197

src/Optimize.hs+3

@@ -307,6 +307,9 @@ optimizeExpr context annExpr@(A.A region expression) =

307 Expr.Sub moduleName _ ->

308 pure (Opt.Sub moduleName)

309

310+ Expr.SaveEnv _ _ ->

311+ error "save_the_environment should never make it to optimization phase"

312+

310 Expr.GLShader uid src gltipe ->

313 Expr.GLShader uid src gltipe ->

311 pure (Opt.GLShader uid src gltipe)

314 pure (Opt.GLShader uid src gltipe)

312

315

src/Parse/Module.hs+11−6

@@ -8,6 +8,7 @@ import qualified AST.Module as Module

8import qualified AST.Module.Name as ModuleName

9import qualified AST.Variable as Var

10import qualified Reporting.Annotation as A

11+import qualified Reporting.Region as R

11

12

13

13getModuleName :: String -> Maybe String

14getModuleName :: String -> Maybe String

@@ -31,7 +32,7 @@ header =

31 do optional freshLine

32 do optional freshLine

32 (ModuleDecl tag names exports settings) <-

33 (ModuleDecl tag names exports settings) <-

33 option

34 option

34− (ModuleDecl Module.SrcNormal ["Main"] Var.openListing Module.emptySettings)

35+ (ModuleDecl Module.Normal ["Main"] Var.openListing Module.emptySettings)

35 (moduleDecl `followedBy` freshLine)

36 (moduleDecl `followedBy` freshLine)

36

37

37 docs <-

38 docs <-

@@ -76,19 +77,23 @@ parseTag =

76 choice

77 choice

77 [

78 [

78 do try (reserved "module")

79 do try (reserved "module")

79− return Module.SrcNormal

80+ return Module.Normal

80 ,

81 ,

82+ do start <- getMyPosition

81− do try (reserved "effect")

83+ try (reserved "effect")

82 whitespace

84 whitespace

83 reserved "module"

85 reserved "module"

86+ end <- getMyPosition

84− return Module.SrcEffect

87+ return (Module.Effect (R.Region start end))

85 ,

88 ,

89+ do start <- getMyPosition

86− do reserved "foreign"

90+ reserved "foreign"

87 whitespace

91 whitespace

88 reserved "effect"

92 reserved "effect"

89 whitespace

93 whitespace

90 reserved "module"

94 reserved "module"

95+ end <- getMyPosition

91− return Module.SrcForeign

96+ return (Module.Foreign (R.Region start end))

92 ]

97 ]

93

98

94

99

src/Reporting/Error/Syntax.hs+4

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

24 | SettingsOnForeignModule

25 | DuplicateSettingOnEffectModule String

26 | BadSettingOnEffectModule String

27+ | NoSettingsOnEffectModule

27

28

28 | InfixDuplicate String

29 | InfixDuplicate String

29 | TypeWithoutDefinition String

30 | TypeWithoutDefinition String

@@ -120,6 +121,9 @@ toReport _localizer err =

120 BadSettingOnEffectModule name ->

121 BadSettingOnEffectModule name ->

121 error "TODO - BadSettingOnEffectModule" name

122 error "TODO - BadSettingOnEffectModule" name

122

123

124+ NoSettingsOnEffectModule ->

125+ error "TODO - NoSettingsOnEffectModule"

126+

123 InfixDuplicate opName ->

127 InfixDuplicate opName ->

124 Report.report

128 Report.report

125 "INFIX OVERLAP"

129 "INFIX OVERLAP"

src/Type/Constrain/Effects.hsnew file+113

@@ -0,0 +1,113 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Type.Constrain.Effects (constrain) where

3+

4+import qualified Data.Map as Map

5+

6+import qualified AST.Effects as Fx

7+import qualified AST.Module.Name as ModuleName

8+import qualified Reporting.Annotation as A

9+import qualified Type.Environment as Env

10+import Type.Type

11+ ( Variable, Type, TypeConstraint, Constraint(..), Scheme(Scheme)

12+ , TermN(VarN), (==>), (<|), mkVar

13+ )

14+

15+

16+constrain

17+ :: Env.Environment

18+ -> ModuleName.Canonical

19+ -> Fx.Effects

20+ -> IO TypeConstraint

21+constrain env moduleName effects =

22+ case effects of

23+ Fx.None ->

24+ return CSaveEnv

25+

26+ Fx.Foreign ->

27+ return CSaveEnv

28+

29+ Fx.Effect info ->

30+ constrainHelp env moduleName info

31+

32+

33+constrainHelp

34+ :: Env.Environment

35+ -> ModuleName.Canonical

36+ -> Fx.Info

37+ -> IO TypeConstraint

38+constrainHelp env moduleName (Fx.Info tagRegion r0 r1 r2 managerType) =

39+ let

40+ task t =

41+ Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t

42+

43+ router msg selfMsg =

44+ Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg

45+ in

46+ do v0 <- mkVar Nothing

47+ v1 <- mkVar Nothing

48+ v2 <- mkVar Nothing

49+

50+ state0 <- mkVar Nothing

51+ state1 <- mkVar Nothing

52+ state2 <- mkVar Nothing

53+

54+ msg1 <- mkVar Nothing

55+ msg2 <- mkVar Nothing

56+

57+ selfMsg1 <- mkVar Nothing

58+ selfMsg2 <- mkVar Nothing

59+

60+ let

61+ vars =

62+ [v0, v1, v2, state0, state1, state2, msg1, msg2, selfMsg1, selfMsg2]

63+

64+ onEffectsType =

65+ router msg1 selfMsg1

66+ ==> addEffectArgs env moduleName managerType msg1

67+ (VarN state1 ==> task state1)

68+

69+ onSelfMsgType =

70+ router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN state2 ==> task state2

71+

72+ constrains =

73+ [ CInstance tagRegion "init" (VarN v0)

74+ , CInstance tagRegion "onEffects" (VarN v1)

75+ , CInstance tagRegion "onSelfMsg" (VarN v2)

76+ , CEqual (error "TODO 1") r0 (VarN v0) (task state0)

77+ , CEqual (error "TODO 2") r1 (VarN v1) onEffectsType

78+ , CEqual (error "TODO 3") r2 (VarN v2) onSelfMsgType

79+ , CEqual (error "TODO 4") r1 (VarN state0) (VarN state1)

80+ , CEqual (error "TODO 5") r2 (VarN state0) (VarN state2)

81+ , CEqual (error "TODO 6") r2 (VarN selfMsg1) (VarN selfMsg2)

82+ ]

83+

84+ return $

85+ CLet [Scheme [] vars (CAnd constrains) Map.empty] CSaveEnv

86+

87+

88+addEffectArgs

89+ :: Env.Environment

90+ -> ModuleName.Canonical

91+ -> Fx.ManagerType

92+ -> Variable

93+ -> Type

94+ -> Type

95+addEffectArgs env moduleName managerType msg result =

96+ let

97+ toTypeName (A.A _ name) =

98+ ModuleName.canonicalToString moduleName ++ "." ++ name

99+

100+ effectList fxName =

101+ Env.getType env "List" <|

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

103+ in

104+ case managerType of

105+ Fx.CmdManager cmd ->

106+ effectList cmd ==> result

107+

108+ Fx.SubManager sub ->

109+ effectList sub ==> result

110+

111+ Fx.FxManager cmd sub ->

112+ effectList cmd ==> effectList sub ==> result

113+

src/Type/Constrain/Expression.hs+5−5

@@ -14,6 +14,7 @@ import qualified AST.Variable as V

14import qualified Reporting.Annotation as A

15import qualified Reporting.Error.Type as Error

16import qualified Reporting.Region as R

17+import qualified Type.Constrain.Effects as Effects

17import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Pattern as Pattern

19import qualified Type.Constrain.Pattern as Pattern

19import qualified Type.Environment as Env

20import qualified Type.Environment as Env

@@ -46,6 +47,9 @@ constrain env annotatedExpr@(A.A region expression) tipe =

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

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

47 return $ ex vars (CEqual (error "TODO - Sub") region sub tipe)

48 return $ ex vars (CEqual (error "TODO - Sub") region sub tipe)

48

49

50+ E.SaveEnv moduleName effects ->

51+ Effects.constrain env moduleName effects

52+

49 E.GLShader _uid _src gltipe ->

53 E.GLShader _uid _src gltipe ->

50 exists $ \attr ->

54 exists $ \attr ->

51 exists $ \unif ->

55 exists $ \unif ->

@@ -71,11 +75,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

71 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

75 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

72

76

73 E.Var var ->

77 E.Var var ->

74− let

75− name =

76− V.toString var

77− in

78− return (if name == E.saveEnvName then CSaveEnv else CInstance region name tipe)

78+ return (CInstance region (V.toString var) tipe)

79

80 E.Range lowExpr highExpr ->

81 existsNumber $ \n ->

src/Validate.hs+66−41

@@ -1,13 +1,14 @@

1{-# OPTIONS_GHC -Wall #-}

2module Validate (module') where

3

4−import Control.Monad (foldM)

4+import Control.Monad (foldM, when)

5import qualified Data.Map as Map

6import qualified Data.Set as Set

7import qualified Data.Foldable as F

8import qualified Data.Traversable as T

9

10import AST.Expression.General as Expr

11+import qualified AST.Effects as Fx

11import qualified AST.Expression.Source as Source

12import qualified AST.Expression.Source as Source

12import qualified AST.Expression.Valid as Valid

13import qualified AST.Expression.Valid as Valid

13import qualified AST.Declaration as D

14import qualified AST.Declaration as D

@@ -61,19 +62,28 @@ addDefaults pkgName imports =

61validateModuleDecl

62validateModuleDecl

62 :: Module.SourceTag

63 :: Module.SourceTag

63 -> Module.SourceSettings

64 -> Module.SourceSettings

64− -> Result.Result wrn Error.Error Module.ValidEffects

65+ -> Result.Result wrn Error.Error Fx.Effects

65−validateModuleDecl tag settings =

66+validateModuleDecl tag settings@(A.A _ pairs) =

66 case tag of

67 case tag of

67− Module.SrcNormal ->

68+ Module.Normal ->

68 do noSettings Error.SettingsOnNormalModule settings

69 do noSettings Error.SettingsOnNormalModule settings

69− return Module.ValidNormal

70+ return Fx.None

70

71

71− Module.SrcForeign ->

72+ Module.Foreign _ ->

72 do noSettings Error.SettingsOnForeignModule settings

73 do noSettings Error.SettingsOnForeignModule settings

73− return Module.ValidForeign

74+ return Fx.Foreign

74

75

75− Module.SrcEffect ->

76+ Module.Effect tagRegion ->

76− gatherEffectSettings settings

77+ let

78+ collectSettings (A.A region setting, userValue) dict =

79+ Map.insertWith (++) setting [(region, userValue)] dict

80+

81+ settingsDict =

82+ foldr collectSettings Map.empty pairs

83+ in

84+ do managerType <- toManagerType tagRegion settingsDict

85+ return $ Fx.Effect $

86+ Fx.Info tagRegion (error "TODO") (error "TODO") (error "TODO") managerType

77

87

78

88

79noSettings

89noSettings

@@ -89,47 +99,59 @@ noSettings errorMsg (A.A region settings) =

89 Result.throw region errorMsg

99 Result.throw region errorMsg

90

100

91

101

92−gatherEffectSettings

102+toManagerType

93− :: Module.SourceSettings

103+ :: R.Region

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

94− -> Result.Result wrn Error.Error Module.ValidEffects

105+ -> Result.Result wrn Error.Error Fx.ManagerType

95−gatherEffectSettings (A.A _ pairs) =

106+toManagerType tagRegion settingsDict =

96− uncurry Module.ValidEffect <$>

107+ let

97− gatherEffectSettingsHelp (Nothing, Nothing) pairs

108+ toErrors name entries =

109+ map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries

110+

111+ errors =

112+ settingsDict

113+ |> Map.delete "command"

114+ |> Map.delete "subscription"

115+ |> Map.mapWithKey toErrors

116+ |> Map.elems

117+ |> concat

118+ in

119+ do when (not (null errors)) (Result.throwMany errors)

120+ maybeEffects <-

121+ (,) <$> extractOne "command" settingsDict

122+ <*> extractOne "subscription" settingsDict

98

123

124+ case maybeEffects of

125+ (Nothing, Nothing) ->

126+ Result.throw tagRegion Error.NoSettingsOnEffectModule

99

127

100−type Effects =

128+ (Just cmd, Nothing) ->

101− (Maybe (A.Located String), Maybe (A.Located String))

129+ return (Fx.CmdManager cmd)

102

130

131+ (Nothing, Just sub) ->

132+ return (Fx.SubManager sub)

103

133

104−gatherEffectSettingsHelp

134+ (Just cmd, Just sub) ->

105− :: Effects

135+ return (Fx.FxManager cmd sub)

106− -> [(A.Located String, A.Located String)]

107− -> Result.Result wrn Error.Error Effects

108−gatherEffectSettingsHelp effects@(maybeCmd, maybeSub) pairs =

109− case pairs of

110− [] ->

111− Result.ok effects

112

136

113− (A.A region name, effect) : rest ->

114− case name of

115− "command" ->

116− case maybeCmd of

117− Nothing ->

118− gatherEffectSettingsHelp (Just effect, maybeSub) rest

119

137

120− Just _ ->

138+extractOne

121− Result.throw region (Error.DuplicateSettingOnEffectModule name)

139+ :: String

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

141+ -> Result.Result w Error.Error (Maybe (A.Located String))

142+extractOne name settingsDict =

143+ case Map.lookup name settingsDict of

144+ Nothing ->

145+ return Nothing

122

146

123− "subscription" ->

147+ Just [] ->

124− case maybeSub of

148+ error "Empty lists should never be added to the dictionary of effect module settings."

125− Nothing ->

126− gatherEffectSettingsHelp (maybeCmd, Just effect) rest

127

149

128− Just _ ->

150+ Just [(_, userType)] ->

129− Result.throw region (Error.DuplicateSettingOnEffectModule name)

151+ return (Just userType)

130

152

131− _ ->

153+ Just ((region, _) : _) ->

132− Result.throw region (Error.BadSettingOnEffectModule name)

154+ Result.throw region (Error.DuplicateSettingOnEffectModule name)

133

155

134

156

135

157

@@ -407,6 +429,9 @@ expression (A.A ann sourceExpression) =

407 Sub moduleName typeName ->

429 Sub moduleName typeName ->

408 return (Sub moduleName typeName)

430 return (Sub moduleName typeName)

409

431

432+ SaveEnv moduleName effects ->

433+ return (SaveEnv moduleName effects)

434+

410 GLShader uid src gltipe ->

435 GLShader uid src gltipe ->

411 return (GLShader uid src gltipe)

436 return (GLShader uid src gltipe)

412

437