ba5bfd2 · elk · git.iko.soy

src/AST/Type.hs+16−2

compare with master

unifiedsplit

@@ -9,7 +9,9 @@ module AST.Type

9import Control.Arrow (second)

10import Data.Binary

11import qualified Data.Map as Map

12+import qualified Data.Set as Set

12

13

14+import qualified AST.Module.Name as ModuleName

13import qualified AST.Variable as Var

15import qualified AST.Variable as Var

14import qualified Reporting.Annotation as A

16import qualified Reporting.Annotation as A

15import qualified Reporting.Region as R

17import qualified Reporting.Region as R

@@ -29,6 +31,7 @@ data Raw'

29 | RType Var.Raw

31 | RType Var.Raw

30 | RApp Raw [Raw]

32 | RApp Raw [Raw]

31 | RRecord [(String, Raw)] (Maybe Raw)

33 | RRecord [(String, Raw)] (Maybe Raw)

34+ | REffects [A.Located ModuleName.Raw]

32

35

33

36

34data Canonical

37data Canonical

@@ -37,6 +40,7 @@ data Canonical

37 | Type Var.Canonical

40 | Type Var.Canonical

38 | App Canonical [Canonical]

41 | App Canonical [Canonical]

39 | Record [(String, Canonical)] (Maybe Canonical)

42 | Record [(String, Canonical)] (Maybe Canonical)

43+ | Effects (Set.Set ModuleName.Canonical)

40 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)

44 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)

41 deriving (Eq, Ord)

45 deriving (Eq, Ord)

42

46

@@ -81,6 +85,9 @@ deepDealias tipe =

81 App f args ->

85 App f args ->

82 App (deepDealias f) (map deepDealias args)

86 App (deepDealias f) (map deepDealias args)

83

87

88+ Effects _ ->

89+ tipe

90+

84

91

85iteratedDealias :: Canonical -> Canonical

92iteratedDealias :: Canonical -> Canonical

86iteratedDealias tipe =

93iteratedDealias tipe =

@@ -127,6 +134,9 @@ dealiasHelp typeTable tipe =

127 App f args ->

134 App f args ->

128 App (go f) (map go args)

135 App (go f) (map go args)

129

136

137+ Effects _ ->

138+ tipe

139+

130

140

131

141

132-- COLLECT LAMBDAS

142-- COLLECT LAMBDAS

@@ -164,8 +174,11 @@ instance Binary Canonical where

164 Record fs ext ->

174 Record fs ext ->

165 putWord8 4 >> put fs >> put ext

175 putWord8 4 >> put fs >> put ext

166

176

177+ Effects names ->

178+ putWord8 5 >> put names

179+

167 Aliased var args t ->

180 Aliased var args t ->

168− putWord8 5 >> put var >> put args >> put t

181+ putWord8 6 >> put var >> put args >> put t

169

182

170 get =

183 get =

171 do n <- getWord8

184 do n <- getWord8

@@ -175,7 +188,8 @@ instance Binary Canonical where

175 2 -> Type <$> get

188 2 -> Type <$> get

176 3 -> App <$> get <*> get

189 3 -> App <$> get <*> get

177 4 -> Record <$> get <*> get

190 4 -> Record <$> get <*> get

191+ 5 -> Effects <$> get

178− 5 -> Aliased <$> get <*> get <*> get

192+ 6 -> Aliased <$> get <*> get <*> get

179 _ -> error "Error reading a valid type from serialized string"

193 _ -> error "Error reading a valid type from serialized string"

180

194

181

195

src/Canonicalize/Environment.hs+32−9

@@ -1,5 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Environment where

2+module Canonicalize.Environment

3+ ( Environment(..)

4+ , insert

5+ , Patch(..), fromPatches, addPattern

6+ , builtinPatches

7+ , toDealiaser

8+ )

9+ where

3

10

4import qualified Data.List as List

11import qualified Data.List as List

5import qualified Data.Map as Map

12import qualified Data.Map as Map

@@ -14,14 +21,17 @@ import qualified AST.Variable as Var

14import Elm.Utils ((|>))

21import Elm.Utils ((|>))

15

22

16

23

24+

17-- ENVIRONMENT

25-- ENVIRONMENT

18

26

27+

19data Environment = Env

28data Environment = Env

20 { _home :: ModuleName.Canonical

29 { _home :: ModuleName.Canonical

21 , _values :: Dict Var.Canonical

30 , _values :: Dict Var.Canonical

22 , _unions :: Dict Var.Canonical

31 , _unions :: Dict Var.Canonical

23 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

32 , _aliases :: Dict (Var.Canonical, [String], Type.Canonical)

24 , _patterns :: Dict (Var.Canonical, Int)

33 , _patterns :: Dict (Var.Canonical, Int)

34+ , _effects :: Map.Map String ModuleName.Canonical

25 }

35 }

26

36

27

37

@@ -29,23 +39,30 @@ type Dict a =

29 Map.Map String (Set.Set a)

39 Map.Map String (Set.Set a)

30

40

31

41

42+fromPatches

32−fromPatches :: ModuleName.Canonical -> [Patch] -> Environment

43+ :: ModuleName.Canonical

44+ -> Map.Map String ModuleName.Canonical

45+ -> [Patch]

46+ -> Environment

33−fromPatches moduleName patches =

47+fromPatches moduleName moduleNames patches =

34 addPatches

48 addPatches

35− patches

49+ patches

36− (Env moduleName Map.empty Map.empty Map.empty Map.empty)

50+ (Env moduleName Map.empty Map.empty Map.empty Map.empty moduleNames)

37

51

38

52

39addPattern :: P.Pattern ann var -> Environment -> Environment

53addPattern :: P.Pattern ann var -> Environment -> Environment

40addPattern pattern env =

54addPattern pattern env =

55+ let

41− let patches =

56+ patches =

42− map (\x -> Value x (Var.local x)) (P.boundVarList pattern)

57+ map (\x -> Value x (Var.local x)) (P.boundVarList pattern)

43 in

58 in

44− addPatches patches env

59+ addPatches patches env

60+

45

61

46

62

47-- PATCHES

63-- PATCHES

48

64

65+

49data Patch

66data Patch

50 = Value String Var.Canonical

67 = Value String Var.Canonical

51 | Union String Var.Canonical

68 | Union String Var.Canonical

@@ -53,8 +70,10 @@ data Patch

53 | Pattern String (Var.Canonical, Int)

70 | Pattern String (Var.Canonical, Int)

54

71

55

72

73+

56-- ADD PATCH TO ENVIRONMENT

74-- ADD PATCH TO ENVIRONMENT

57

75

76+

58addPatches :: [Patch] -> Environment -> Environment

77addPatches :: [Patch] -> Environment -> Environment

59addPatches patches env =

78addPatches patches env =

60 List.foldl' (flip addPatch) env patches

79 List.foldl' (flip addPatch) env patches

@@ -81,8 +100,10 @@ insert key value =

81 Map.insertWith Set.union key (Set.singleton value)

100 Map.insertWith Set.union key (Set.singleton value)

82

101

83

102

103+

84-- PATCH HELPERS

104-- PATCH HELPERS

85

105

106+

86builtinPatches :: [Patch]

107builtinPatches :: [Patch]

87builtinPatches =

108builtinPatches =

88 concat

109 concat

@@ -108,10 +129,12 @@ builtinPatches =

108 ("_Tuple" ++ show n, n)

129 ("_Tuple" ++ show n, n)

109

130

110

131

132+

111-- TO TYPE DEALIASER

133-- TO TYPE DEALIASER

112

134

135+

113toDealiaser :: Environment -> Map.Map String String

136toDealiaser :: Environment -> Map.Map String String

114−toDealiaser (Env _ _ unions aliases _) =

137+toDealiaser (Env _ _ unions aliases _ _) =

115 let

138 let

116 dealiasUnion (localName, canonicalSet) =

139 dealiasUnion (localName, canonicalSet) =

117 case Set.toList canonicalSet of

140 case Set.toList canonicalSet of

src/Canonicalize/Setup.hs+18−11

@@ -32,23 +32,26 @@ environment

32 -> Result.ResultErr Env.Environment

33environment importDict interfaces (Module.Module name _ info) =

34 let

35− (Module.Valid _ _ (defaults, imports) decls effects) =

35+ (Module.Valid _ _ (defaults, imports) decls _) = -- TODO add foreign effects as patches?

36 info

37

38 allImports =

39 imports ++ map (A.A (error "default import not found")) defaults

40

41− importPatchesResult =

41+ importIngredients =

42− concat <$> Trav.traverse (importPatches importDict interfaces) allImports

42+ unzip <$> Trav.traverse (importPatches importDict interfaces) allImports

43

44 (typeAliasNodes, declPatches) =

45− declarationsToPatches name decls

45+ declarationsToPatches name decls

46

47− patches =

47+ createEnv (moduleNamePairs, patchLists) =

48+ Env.fromPatches

49+ name

50+ (Map.fromList (Maybe.catMaybes moduleNamePairs))

48− (++) (Env.builtinPatches ++ declPatches) <$> importPatchesResult

51+ (concat (Env.builtinPatches : declPatches : patchLists))

49 in

52 in

50− (Env.fromPatches name <$> patches)

53+ (createEnv <$> importIngredients)

51− `Result.andThen` addTypeAliases name typeAliasNodes

54+ `Result.andThen` addTypeAliases name typeAliasNodes

52

55

53

56

54

57

@@ -59,7 +62,7 @@ importPatches

59 :: Map.Map ModuleName.Raw ModuleName.Canonical

62 :: Map.Map ModuleName.Raw ModuleName.Canonical

60 -> Module.Interfaces

63 -> Module.Interfaces

61 -> A.Located (ModuleName.Raw, Module.ImportMethod)

64 -> A.Located (ModuleName.Raw, Module.ImportMethod)

62− -> Result.ResultErr [Env.Patch]

65+ -> Result.ResultErr (Maybe (String, ModuleName.Canonical), [Env.Patch])

63importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

66importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

64 let

67 let

65 maybeInterface =

68 maybeInterface =

@@ -70,7 +73,7 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

70 case maybeInterface of

73 case maybeInterface of

71 Nothing ->

74 Nothing ->

72 if ModuleName.isNative rawImportName then

75 if ModuleName.isNative rawImportName then

73− Result.ok []

76+ Result.ok (Nothing, [])

74

77

75 else

78 else

76 allInterfaces

79 allInterfaces

@@ -102,7 +105,8 @@ importPatches importDict allInterfaces (A.A region (rawImportName, method)) =

102 else

105 else

103 concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

106 concat <$> Trav.traverse (valueToPatches region importName interface) exposedValues

104 in

107 in

108+ (,) (Just (qualifier, importName)) <$>

105− (++) qualifiedPatches <$> unqualifiedPatches

109+ ((++) qualifiedPatches <$> unqualifiedPatches)

106

110

107

111

108interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

112interfacePatches :: ModuleName.Canonical -> String -> Module.Interface -> [Env.Patch]

@@ -255,6 +259,9 @@ node region name tvars alias =

255 Type.RRecord fs ext ->

259 Type.RRecord fs ext ->

256 maybe [] edges ext ++ concatMap (edges . snd) fs

260 maybe [] edges ext ++ concatMap (edges . snd) fs

257

261

262+ Type.REffects _ ->

263+ []

264+

258

265

259addTypeAliases

266addTypeAliases

260 :: ModuleName.Canonical

267 :: ModuleName.Canonical

src/Canonicalize/Type.hs+44−12

@@ -1,8 +1,10 @@

1{-# OPTIONS_GHC -Wall #-}

2module Canonicalize.Type (tipe) where

3

4+import qualified Data.Set as Set

4import qualified Data.Traversable as Trav

5import qualified Data.Traversable as Trav

5

6

7+import qualified AST.Module.Name as ModuleName

6import qualified AST.Type as T

8import qualified AST.Type as T

7import qualified AST.Variable as Var

9import qualified AST.Variable as Var

8

10

@@ -19,10 +21,13 @@ tipe

19 -> T.Raw

21 -> T.Raw

20 -> Result.ResultErr T.Canonical

22 -> Result.ResultErr T.Canonical

21tipe env typ@(A.A region typ') =

23tipe env typ@(A.A region typ') =

24+ let

25+ go =

22− let go = tipe env

26+ tipe env

27+

23− goSnd (name,t) =

28+ goSnd (name,t) =

24− (,) name <$> go t

29+ (,) name <$> go t

25− in

30+ in

26 case typ' of

31 case typ' of

27 T.RVar x ->

32 T.RVar x ->

28 Result.ok (T.Var x)

33 Result.ok (T.Var x)

@@ -39,6 +44,9 @@ tipe env typ@(A.A region typ') =

39 T.RRecord fields ext ->

44 T.RRecord fields ext ->

40 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext

45 T.Record <$> Trav.traverse goSnd fields <*> Trav.traverse go ext

41

46

47+ T.REffects rawNames ->

48+ T.Effects <$> canonicalizeEffects env rawNames

49+

42

50

43canonicalizeApp

51canonicalizeApp

44 :: R.Region

52 :: R.Region

@@ -49,11 +57,13 @@ canonicalizeApp

49canonicalizeApp region env f args =

57canonicalizeApp region env f args =

50 case f of

58 case f of

51 A.A _ (T.RType (Var.Raw rawName)) ->

59 A.A _ (T.RType (Var.Raw rawName)) ->

52− Canonicalize.tvar region env rawName

60+ Canonicalize.tvar region env rawName

53− `Result.andThen` canonicalizeWithTvar

61+ `Result.andThen` canonicalizeWithTvar

54

62

55 _ ->

63 _ ->

64+ T.App

65+ <$> tipe env f

56− T.App <$> tipe env f <*> Trav.traverse (tipe env) args

66+ <*> Trav.traverse (tipe env) args

57

67

58 where

68 where

59 canonicalizeWithTvar tvar =

69 canonicalizeWithTvar tvar =

@@ -76,12 +86,34 @@ canonicalizeAlias

76 -> [T.Raw]

86 -> [T.Raw]

77 -> Result.ResultErr T.Canonical

87 -> Result.ResultErr T.Canonical

78canonicalizeAlias region env (name, tvars, dealiasedTipe) types =

88canonicalizeAlias region env (name, tvars, dealiasedTipe) types =

79− if typesLen /= tvarsLen

89+ let

80− then Result.err (A.A region (Error.alias name tvarsLen typesLen))

81− else toAlias <$> Trav.traverse (tipe env) types

82− where

83 typesLen = length types

90 typesLen = length types

84 tvarsLen = length tvars

91 tvarsLen = length tvars

85

92

86 toAlias canonicalTypes =

93 toAlias canonicalTypes =

87− T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

94+ T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

95+ in

96+ if typesLen /= tvarsLen then

97+ Result.err (A.A region (Error.alias name tvarsLen typesLen))

98+

99+ else

100+ toAlias <$> Trav.traverse (tipe env) types

101+

102+

103+canonicalizeEffects

104+ :: Env.Environment

105+ -> [A.Located ModuleName.Raw]

106+ -> Result.ResultErr (Set.Set ModuleName.Canonical)

107+canonicalizeEffects env rawNames =

108+ let

109+ addToSet (A.A region name) set =

110+ if Set.member name set then

111+ Result.err (A.A region (Error.DuplicateEffect name))

112+

113+ else

114+ Result.ok (Set.insert name set)

115+ in

116+ Trav.traverse (Canonicalize.effect env) rawNames

117+ `Result.andThen`

118+ Result.foldl addToSet Set.empty

119+

src/Canonicalize/Variable.hs+28−1

@@ -1,5 +1,5 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Variable where

2+module Canonicalize.Variable (variable, tvar, pvar, effect) where

3

4import qualified Data.Either as Either

5import qualified Data.Map as Map

@@ -19,6 +19,10 @@ import qualified Elm.Package as Pkg

19import Elm.Utils ((|>))

20

21

22+

23+-- FINDERS

24+

25+

22variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical

26variable :: R.Region -> Env.Environment -> String -> Result.ResultErr Var.Canonical

23variable region env var =

27variable region env var =

24 case toVarName var of

28 case toVarName var of

@@ -92,8 +96,27 @@ pvar region env var actualArgs =

92 else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))

96 else Result.err (A.A region (Error.argMismatch name expectedArgs actualArgs))

93

97

94

98

99+effect

100+ :: Env.Environment

101+ -> A.Located ModuleName.Raw

102+ -> Result.ResultErr (A.Located ModuleName.Canonical)

103+effect env (A.A region rawName) =

104+ let

105+ rawString =

106+ ModuleName.toString rawName

107+ in

108+ case Map.lookup rawString (Env._effects env) of

109+ Just name ->

110+ Result.addModule (ModuleName._module name) (Result.ok (A.A region name))

111+

112+ Nothing ->

113+ notFound region "effect type" (Map.keys (Env._effects env)) rawString

114+

115+

116+

95-- FOUND

117-- FOUND

96

118

119+

97preferLocals

120preferLocals

98 :: R.Region

121 :: R.Region

99 -> Env.Environment

122 -> Env.Environment

@@ -164,8 +187,10 @@ isTopLevel (Var.Canonical home _) =

164 False

187 False

165

188

166

189

190+

167-- NOT FOUND HELPERS

191-- NOT FOUND HELPERS

168

192

193+

169type VarName =

194type VarName =

170 Either String (ModuleName.Raw, String)

195 Either String (ModuleName.Raw, String)

171

196

@@ -194,8 +219,10 @@ isOp name =

194 Help.isOp (noQualifier name)

219 Help.isOp (noQualifier name)

195

220

196

221

222+

197-- NOT FOUND

223-- NOT FOUND

198

224

225+

199notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a

226notFound :: R.Region -> String -> [String] -> String -> Result.ResultErr a

200notFound region kind possibilities var =

227notFound region kind possibilities var =

201 let name =

228 let name =

src/Elm/Compiler/Type.hs+3

@@ -195,3 +195,6 @@ fromRawType (A.A _ astType) =

195 Type.RRecord fields ext ->

196 Record (map (second fromRawType) fields) (fmap fromRawType ext)

197

198+ Type.REffects _ ->

199+ error "TODO - fromRawType REffects"

200+

src/Elm/Compiler/Type/Extract.hs+5−1

@@ -40,5 +40,9 @@ toType useAliases astType =

40 Type.Aliased name args t ->

41 if useAliases then

42 T.App (T.Type (Var.toString name)) (map (go . snd) args)

43+

43 else

44 else

44− go (Type.dealias args t)

45+ go (Type.dealias args t)

46+

47+ Type.Effects _ ->

48+ error "TODO - toType Effects"

src/Parse/Type.hs+9−2

@@ -2,7 +2,7 @@

2module Parse.Type where

3

4import Data.List (intercalate)

5−import Text.Parsec ((<|>), (<?>), char, many, optionMaybe, string, try)

5+import Text.Parsec ((<|>), (<?>), char, choice, many, optionMaybe, string, try)

6

7import qualified AST.Type as Type

8import qualified AST.Variable as Var

@@ -50,6 +50,13 @@ record =

50 (,) lbl <$> expr

51

52

53+effects :: IParser Type.Raw

54+effects =

55+ addLocation $ braces $

56+ do names <- commaSep1 (addLocation (dotSep1 capVar))

57+ return (Type.REffects names)

58+

59+

53capTypeVar :: IParser String

60capTypeVar :: IParser String

54capTypeVar =

61capTypeVar =

55 intercalate "." <$> dotSep1 capVar

62 intercalate "." <$> dotSep1 capVar

@@ -64,7 +71,7 @@ constructor0 =

64

71

65term :: IParser Type.Raw

72term :: IParser Type.Raw

66term =

73term =

67− tuple <|> record <|> tvar <|> constructor0

74+ choice [ tuple, record, effects, tvar, constructor0 ]

68

75

69

76

70app :: IParser Type.Raw

77app :: IParser Type.Raw

src/Reporting/Error/Canonicalize.hs+19

@@ -3,11 +3,13 @@ module Reporting.Error.Canonicalize where

3

4import Control.Arrow (second)

5import qualified Data.Char as Char

6+import qualified Data.Set as Set

6import Text.PrettyPrint.ANSI.Leijen (indent, text)

7import Text.PrettyPrint.ANSI.Leijen (indent, text)

7

8

8import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

9import qualified AST.Type as Type

10import qualified AST.Type as Type

10import qualified AST.Variable as Var

11import qualified AST.Variable as Var

12+import qualified Elm.Package as Package

11import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

12import qualified Reporting.Error.Helpers as Help

14import qualified Reporting.Error.Helpers as Help

13import qualified Reporting.Region as Region

15import qualified Reporting.Region as Region

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

22 | Import ModuleName.Raw ImportError

24 | Import ModuleName.Raw ImportError

23 | Export String [String]

25 | Export String [String]

24 | DuplicateExport String

26 | DuplicateExport String

27+ | DuplicateEffect ModuleName.Canonical

25 | Port PortError

28 | Port PortError

26

29

27

30

@@ -228,6 +231,15 @@ toReport localizer err =

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

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

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

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

230

233

234+ DuplicateEffect rawName ->

235+ let

236+ name =

237+ ModuleName.canonicalToString rawName

238+ in

239+ namingError

240+ ("This type lists the `" ++ name ++ "` effect multiple times.")

241+ "Remove duplicates until each effect is listed only once."

242+

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

243 Port (PortError name isInbound _rootType localType maybeMessage) ->

232 let

244 let

233 boundPort =

245 boundPort =

@@ -292,6 +304,9 @@ extractSuggestions err =

292 DuplicateExport _ ->

304 DuplicateExport _ ->

293 Nothing

305 Nothing

294

306

307+ DuplicateEffect _ ->

308+ Nothing

309+

295 Port _ ->

310 Port _ ->

296 Nothing

311 Nothing

297

312

@@ -311,6 +326,10 @@ unsafePromote (A.A _ rawType) =

311 Type.RApp func args ->

326 Type.RApp func args ->

312 Type.App (unsafePromote func) (map unsafePromote args)

327 Type.App (unsafePromote func) (map unsafePromote args)

313

328

329+ Type.REffects names ->

330+ Type.Effects $ Set.fromList $

331+ map (ModuleName.Canonical Package.dummyName . A.drop) names

332+

314 Type.RRecord fields ext ->

333 Type.RRecord fields ext ->

315 Type.Record (map (second unsafePromote) fields) (fmap unsafePromote ext)

334 Type.Record (map (second unsafePromote) fields) (fmap unsafePromote ext)

316

335

src/Reporting/Error/Syntax.hs+20

@@ -100,6 +100,26 @@ toReport _localizer err =

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

101 ( text "What is it documenting? Maybe it should just be removed?" )

102

103+ SettingsOnNormalModule ->

104+ Report.report

105+ "BAD MODULE DECLARATION"

106+ Nothing

107+ "A normal module can expose values, but not register commands and subscriptions."

108+ ( Help.reflowParagraph $

109+ "If you want a normal module, just remove this stuff. If you want to create\

110+ \ an `effect module` you just forgot to use the `effect` keyword. In that\

111+ \ case, just change `module` to `effect module` and you should be all set!"

112+ )

113+

114+ SettingsOnForeignModule ->

115+ error "TODO - SettingsOnForeignModule"

116+

117+ DuplicateSettingOnEffectModule name ->

118+ error "TODO - DuplicateSettingOnEffectModule" name

119+

120+ BadSettingOnEffectModule name ->

121+ error "TODO - BadSettingOnEffectModule" name

122+

103 InfixDuplicate opName ->

123 InfixDuplicate opName ->

104 Report.report

124 Report.report

105 "INFIX OVERLAP"

125 "INFIX OVERLAP"

src/Reporting/Render/Type.hs+21−5

@@ -12,11 +12,12 @@ import Control.Arrow ((***), first)

12import qualified Data.Map as Map

13import qualified Data.Set as Set

14import Text.PrettyPrint.ANSI.Leijen

15− ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep

15+ ( Doc, (<+>), brackets, cat, colon, comma, dullyellow, equals, hang, hsep

16− , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat

16+ , lbrace, lparen, parens, punctuate, rbrace, rparen, sep, text, vcat

17 )

18

19import qualified AST.Helpers as Help

20+import qualified AST.Module.Name as ModuleName

20import qualified AST.Type as Type

21import qualified AST.Type as Type

21import qualified AST.Variable as Var

22import qualified AST.Variable as Var

22import qualified Reporting.Error.Helpers as Help

23import qualified Reporting.Error.Helpers as Help

@@ -87,13 +88,24 @@ type Localizer =

87varToDoc :: Localizer -> Var.Canonical -> Doc

88varToDoc :: Localizer -> Var.Canonical -> Doc

88varToDoc localizer var =

89varToDoc localizer var =

89 let

90 let

91+ name =

90− name = Var.toString var

92+ Var.toString var

91 in

93 in

92 if name == "_Tuple0" then

94 if name == "_Tuple0" then

93− text "()"

95+ text "()"

94

96

95 else

97 else

98+ text (maybe name id (Map.lookup name localizer))

99+

100+

101+-- TODO make sure that localizer contains qualifiers without variables

102+moduleNameToDoc :: Localizer -> ModuleName.Canonical -> Doc

103+moduleNameToDoc localizer var =

104+ let

105+ name =

106+ ModuleName.canonicalToString var

107+ in

96− text (maybe name id (Map.lookup name localizer))

108+ text (maybe name id (Map.lookup name localizer))

97

109

98

110

99

111

@@ -401,6 +413,10 @@ docType localizer context tipe =

401 (map (text *** docType localizer None) fields)

413 (map (text *** docType localizer None) fields)

402 (fmap text ext)

414 (fmap text ext)

403

415

416+ Type.Effects names ->

417+ brackets $ cat $ punctuate comma $

418+ map (moduleNameToDoc localizer) (Set.toList names)

419+

404 Type.Aliased name args _ ->

420 Type.Aliased name args _ ->

405 docApp localizer context name (map snd args)

421 docApp localizer context name (map snd args)

406

422

src/Type/Environment.hs+7−2

@@ -176,8 +176,10 @@ instantiator env sourceType =

176

177instantiatorHelp :: Environment -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

178instantiatorHelp env aliasVars sourceType =

179+ let

180+ go =

179− let go = instantiatorHelp env aliasVars

181+ instantiatorHelp env aliasVars

180− in

182+ in

181 case sourceType of

183 case sourceType of

182 T.Lambda t1 t2 ->

184 T.Lambda t1 t2 ->

183 (==>) <$> go t1 <*> go t2

185 (==>) <$> go t1 <*> go t2

@@ -235,3 +237,6 @@ instantiatorHelp env aliasVars sourceType =

235 go extType

237 go extType

236

238

237 return $ TermN (Record1 tfields text)

239 return $ TermN (Record1 tfields text)

240+

241+ T.Effects names ->

242+ return $ TermN (Effects1 names)

src/Type/Solve.hs+6

@@ -143,6 +143,9 @@ adjustRankContent youngMark visitedMark groupRank content =

143 Structure (Record1 fields extension) ->

144 maximum <$> mapM go (extension : Map.elems fields)

145

146+ Structure (Effects1 _) ->

147+ return outermostRank

148+

146

149

147

150

148-- SOLVER

151-- SOLVER

@@ -342,3 +345,6 @@ occursHelp seen var =

342

345

343 Record1 fields ext ->

346 Record1 fields ext ->

344 or <$> mapM go (ext : Map.elems fields)

347 or <$> mapM go (ext : Map.elems fields)

348+

349+ Effects1 _ ->

350+ return False

src/Type/State.hs+4

@@ -325,3 +325,7 @@ traverseTerm f term =

325

326 Record1 fields ext ->

327 Record1 <$> traverse f fields <*> f ext

328+

329+ Effects1 names ->

330+ return (Effects1 names)

331+

src/Type/Type.hs+19−11

@@ -9,6 +9,7 @@ import qualified Data.Set as Set

9import qualified Data.Traversable as Traverse (traverse)

10import qualified Data.UnionFind.IO as UF

11

12+import qualified AST.Module.Name as ModuleName

12import qualified AST.Type as T

13import qualified AST.Type as T

13import qualified AST.Variable as Var

14import qualified AST.Variable as Var

14import qualified Reporting.Annotation as A

15import qualified Reporting.Annotation as A

@@ -45,6 +46,7 @@ data Term1 a

45 | Fun1 a a

46 | Fun1 a a

46 | EmptyRecord1

47 | EmptyRecord1

47 | Record1 (Map.Map String a) a

48 | Record1 (Map.Map String a) a

49+ | Effects1 (Set.Set ModuleName.Canonical)

48

50

49

51

50data TermN a

52data TermN a

@@ -309,22 +311,22 @@ termToSrcType :: Term1 Variable -> StateT NameState IO T.Canonical

309termToSrcType term =

311termToSrcType term =

310 case term of

312 case term of

311 App1 func arg ->

313 App1 func arg ->

312− do srcFunc <- variableToSrcType func

314+ do srcFunc <- variableToSrcType func

313− srcArg <- variableToSrcType arg

315+ srcArg <- variableToSrcType arg

314− case srcFunc of

316+ case srcFunc of

315− T.App f args ->

317+ T.App f args ->

316− return (T.App f (args ++ [srcArg]))

318+ return (T.App f (args ++ [srcArg]))

317

319

318− _ ->

320+ _ ->

319− return (T.App srcFunc [srcArg])

321+ return (T.App srcFunc [srcArg])

320

322

321 Fun1 a b ->

323 Fun1 a b ->

322− T.Lambda

324+ T.Lambda

323− <$> variableToSrcType a

325+ <$> variableToSrcType a

324− <*> variableToSrcType b

326+ <*> variableToSrcType b

325

327

326 EmptyRecord1 ->

328 EmptyRecord1 ->

327− return $ T.Record [] Nothing

329+ return $ T.Record [] Nothing

328

330

329 Record1 fields extension ->

331 Record1 fields extension ->

330 do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

332 do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

@@ -340,6 +342,9 @@ termToSrcType term =

340 _ ->

342 _ ->

341 error "Used toSrcType on a type that is not well-formed"

343 error "Used toSrcType on a type that is not well-formed"

342

344

345+ Effects1 names ->

346+ return $ T.Effects names

347+

343

348

344

349

345-- MANAGE FRESH VARIABLE NAMES

350-- MANAGE FRESH VARIABLE NAMES

@@ -456,3 +461,6 @@ getVarNamesTerm term =

456 do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

461 do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

457 Set.union fieldVars <$> go extension

462 Set.union fieldVars <$> go extension

458

463

464+ Effects1 _ ->

465+ return Set.empty

466+

src/Type/Unify.hs+4

@@ -4,6 +4,7 @@ module Type.Unify (unify) where

4import Control.Monad (zipWithM_)

5import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

6import qualified Data.Map as Map

7+import qualified Data.Set as Set

7import qualified Data.UnionFind.IO as UF

8import qualified Data.UnionFind.IO as UF

8

9

9import qualified AST.Variable as Var

10import qualified AST.Variable as Var

@@ -564,6 +565,9 @@ unifyStructure context term otherContent =

564 subUnify context result otherResult

565 subUnify context result otherResult

565 merge context otherContent

566 merge context otherContent

566

567

568+ (Effects1 names, Effects1 otherNames) ->

569+ merge context (Structure (Effects1 (Set.union names otherNames)))

570+

567 (EmptyRecord1, EmptyRecord1) ->

571 (EmptyRecord1, EmptyRecord1) ->

568 merge context otherContent

572 merge context otherContent

569

573

src/Validate.hs+3

@@ -573,3 +573,6 @@ freeVars (A.A region tipe) =

573 maybe [] freeVars ext

574 ++ concatMap (freeVars . snd) fields

575

576+ Type.REffects _ ->

577+ []

578+