94ebc2d · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Use the same Result type everywhere

94ebc2dEvan Czaplicki11 years ago

elm-compiler.cabal+1−1

compare with master

unifiedsplit

@@ -65,7 +65,6 @@ Library

65 Canonicalize.Body,

66 Canonicalize.Effects,

67 Canonicalize.Environment,

68− Canonicalize.Result,

69 Canonicalize.Setup,

68 Canonicalize.Setup,

70 Canonicalize.Sort,

69 Canonicalize.Sort,

71 Canonicalize.Type,

70 Canonicalize.Type,

@@ -102,6 +101,7 @@ Library

102 Parse.Pattern,

101 Parse.Pattern,

103 Parse.Type,

102 Parse.Type,

104 Reporting.Annotation,

103 Reporting.Annotation,

104+ Reporting.Bag,

105 Reporting.Error,

106 Reporting.Error.Canonicalize,

107 Reporting.Error.Docs,

src/Canonicalize.hs+81−82

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

1+{-# OPTIONS_GHC -Wall #-}

1module Canonicalize (module') where

2module Canonicalize (module') where

3import qualified Data.List as List

4import qualified Data.List as List

4import qualified Data.Map as Map

5import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

6import qualified Data.Maybe as Maybe

6import qualified Data.Set as Set

7import qualified Data.Set as Set

7−import qualified Data.Traversable as T

8import qualified Data.Foldable as T

10import AST.Expression.General (Expr'(..))

@@ -18,24 +18,28 @@ import qualified AST.Module.Name as ModuleName

18import qualified AST.Pattern as P

19import qualified AST.Type as Type

20import qualified AST.Variable as Var

21+import qualified Canonicalize.Body as Body

22+import qualified Canonicalize.Effects as Effects

23+import qualified Canonicalize.Environment as Env

24+import qualified Canonicalize.Setup as Setup

25+import qualified Canonicalize.Type as Canon

26+import qualified Canonicalize.Variable as Canon

21import qualified Docs.Centralize as Docs

27import qualified Docs.Centralize as Docs

22import qualified Reporting.Annotation as A

28import qualified Reporting.Annotation as A

23import qualified Reporting.Error as Error

29import qualified Reporting.Error as Error

24import qualified Reporting.Error.Canonicalize as CError

30import qualified Reporting.Error.Canonicalize as CError

25import qualified Reporting.Error.Helpers as ErrorHelp

31import qualified Reporting.Error.Helpers as ErrorHelp

26import qualified Reporting.Region as Region

32import qualified Reporting.Region as Region

27−import qualified Reporting.Result as R

33+import qualified Reporting.Render.Type as RenderType

34+import qualified Reporting.Result as Result

28import qualified Reporting.Warning as Warning

35import qualified Reporting.Warning as Warning

29−import qualified Canonicalize.Body as Body

30−import qualified Canonicalize.Effects as Effects

31−import qualified Canonicalize.Environment as Env

32−import qualified Canonicalize.Result as Result

33−import qualified Canonicalize.Setup as Setup

34−import qualified Canonicalize.Type as Canonicalize

35−import qualified Canonicalize.Variable as Canonicalize

39+type Result a =

40+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error a

41+

42+

39-- MODULES

43-- MODULES

@@ -43,29 +47,29 @@ module'

43 :: [ModuleName.Canonical]

47 :: [ModuleName.Canonical]

44 -> Module.Interfaces

48 -> Module.Interfaces

45 -> Module.Valid

49 -> Module.Valid

46− -> R.Result Warning.Warning Error.Error Module.Canonical

50+ -> Result Module.Canonical

47−module' canonicalImports interfaces modul =

51+module' allCanonicalImports interfaces modul =

48 let

52 let

49 (Module.Valid docs exports imports decls effects) =

53 (Module.Valid docs exports imports decls effects) =

50 Module.info modul

54 Module.info modul

52 importDict =

56 importDict =

53− canonicalImports

57+ allCanonicalImports

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

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

55 |> Map.fromList

59 |> Map.fromList

57− (Result.Result uses rawResults) =

61+ (Result.Result uses warnings rawResults) =

58− Setup.environment importDict interfaces modul

62+ do env <- Setup.environment importDict interfaces modul

59− `Result.andThen` \env ->

61− (,,,) env

64+ (,,,) env

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

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

63− <*> canonicalizeDecls env decls

66+ <*> canonicalizeDecls env decls

64− <*> Effects.canonicalize env effects

67+ <*> Effects.canonicalize env effects

65 in

68 in

66 case rawResults of

69 case rawResults of

67− Result.Err msgs ->

70+ Result.Err errors ->

68− R.throwMany (map (A.map Error.Canonicalize) msgs)

71+ Result.mapError Error.Canonicalize $

72+ Result.Result Result.None warnings (Result.Err errors)

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

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

71 let

75 let

@@ -81,9 +85,9 @@ module' canonicalImports interfaces modul =

81 program =

85 program =

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

86 Body.flatten (Module.name modul) canonicalDecls canonicalEffects

83 in

87 in

84− R.addDealiaser (Env.toDealiaser env) $

85− do canonicalImports <- filterImports uses imports

88+ do canonicalImports <- filterImports uses imports

89+ Result.accumulate (Result.One (Env.toDealiaser env)) $

86− return $ modul {

90+ modul {

87 Module.info =

91 Module.info =

88 Module.Info

92 Module.Info

89 { Module.docs = centralizedDocs

93 { Module.docs = centralizedDocs

@@ -96,7 +100,7 @@ module' canonicalImports interfaces modul =

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

100 , Module.unions = Map.fromList (map typeToPair unions)

97 , Module.effects = canonicalEffects

101 , Module.effects = canonicalEffects

98 }

102 }

99− }

103+ }

100

104

101

105

102

106

@@ -106,7 +110,7 @@ module' canonicalImports interfaces modul =

106filterImports

110filterImports

107 :: Set.Set ModuleName.Raw

111 :: Set.Set ModuleName.Raw

108 -> ([Module.DefaultImport], [Module.UserImport])

112 -> ([Module.DefaultImport], [Module.UserImport])

109− -> R.Result Warning.Warning e [ModuleName.Raw]

113+ -> Result [ModuleName.Raw]

110filterImports uses (defaults, imports) =

114filterImports uses (defaults, imports) =

111 let

115 let

112 checkImport (A.A region (name, _method)) =

116 checkImport (A.A region (name, _method)) =

@@ -114,24 +118,28 @@ filterImports uses (defaults, imports) =

114 return (Just name)

118 return (Just name)

115

119

116 else

120 else

117− do R.warn region (Warning.UnusedImport name)

121+ Result.warn region (Warning.UnusedImport name) Nothing

118− return Nothing

119 in

122 in

120 do reducedImports <-

123 do reducedImports <-

121− Maybe.catMaybes <$> T.traverse checkImport imports

124+ Maybe.catMaybes <$> traverse checkImport imports

122

125

123 return $

126 return $

124 Set.toList (Set.fromList (map fst defaults ++ reducedImports))

127 Set.toList (Set.fromList (map fst defaults ++ reducedImports))

125

128

126

129

127

130

131+-------- CANONICALIZATION --------

132+

133+

134+type CResult a =

135+ Canon.Result a

136+

137+

138+

128-- EXPORTS

139-- EXPORTS

129

140

130

141

131−resolveExports

132− :: [Var.Value]

133− -> Var.Listing (A.Located Var.Value)

142+resolveExports :: [Var.Value] -> Var.Listing (A.Located Var.Value) -> CResult [Var.Value]

134− -> Result.ResultErr [Var.Value]

135resolveExports fullList (Var.Listing partialList open) =

143resolveExports fullList (Var.Listing partialList open) =

136 if open then

144 if open then

137 Result.ok fullList

145 Result.ok fullList

@@ -148,17 +156,13 @@ resolveExports fullList (Var.Listing partialList open) =

148 map fst allAdts

156 map fst allAdts

149 in

157 in

150 (\xs ys zs _ -> xs ++ ys ++ zs)

158 (\xs ys zs _ -> xs ++ ys ++ zs)

151− <$> T.traverse (getValueExport allValues (Set.fromList allValues)) values

159+ <$> traverse (getValueExport allValues (Set.fromList allValues)) values

152− <*> (concat <$> T.traverse (getAliasExport allValues allAliases adtTypes) aliases)

160+ <*> (concat <$> traverse (getAliasExport allValues allAliases adtTypes) aliases)

153− <*> T.traverse (getAdtExport allAdts adtTypes) adts

161+ <*> traverse (getAdtExport allAdts adtTypes) adts

154 <*> allUnique partialList

162 <*> allUnique partialList

155

163

156

164

157−getValueExport

165+getValueExport :: [String] -> Set.Set String -> A.Located String -> CResult Var.Value

158− :: [String]

159− -> Set.Set String

160− -> A.Located String

161− -> Result.ResultErr Var.Value

162getValueExport allValues allValuesSet (A.A region name) =

166getValueExport allValues allValuesSet (A.A region name) =

163 if Set.member name allValuesSet then

167 if Set.member name allValuesSet then

164 Result.ok (Var.Value name)

168 Result.ok (Var.Value name)

@@ -166,12 +170,7 @@ getValueExport allValues allValuesSet (A.A region name) =

166 manyNotFound region [name] allValues

170 manyNotFound region [name] allValues

167

171

168

172

169−getAliasExport

173+getAliasExport :: [String] -> [String] -> [String] -> A.Located String -> CResult [Var.Value]

170− :: [String]

171− -> [String]

172− -> [String]

173− -> A.Located String

174− -> Result.ResultErr [Var.Value]

175getAliasExport allValues allAliases adtTypes (A.A region alias) =

174getAliasExport allValues allAliases adtTypes (A.A region alias) =

176 if alias `elem` allAliases then

175 if alias `elem` allAliases then

177

176

@@ -191,7 +190,7 @@ getAdtExport

191 :: [(String, Var.Listing String)]

190 :: [(String, Var.Listing String)]

192 -> [String]

191 -> [String]

193 -> A.Located (String, Var.Listing String)

192 -> A.Located (String, Var.Listing String)

194− -> Result.ResultErr Var.Value

193+ -> CResult Var.Value

195getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =

194getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =

196 case List.lookup name allAdts of

195 case List.lookup name allAdts of

197 Nothing ->

196 Nothing ->

@@ -208,9 +207,9 @@ getAdtExport allAdts adtTypes (A.A region (name, Var.Listing ctors open)) =

208 manyNotFound region unfoundCtors allCtors

207 manyNotFound region unfoundCtors allCtors

209

208

210

209

211−manyNotFound :: Region.Region -> [String] -> [String] -> Result.ResultErr a

210+manyNotFound :: Region.Region -> [String] -> [String] -> CResult a

212manyNotFound region nameList possibilities =

211manyNotFound region nameList possibilities =

213− Result.errors (map (notFound region possibilities) nameList)

212+ Result.throwMany (map (notFound region possibilities) nameList)

214

213

215

214

216notFound :: Region.Region -> [String] -> String -> A.Located CError.Error

215notFound :: Region.Region -> [String] -> String -> A.Located CError.Error

@@ -219,7 +218,7 @@ notFound region possibilities name =

219 ErrorHelp.nearbyNames id name possibilities

218 ErrorHelp.nearbyNames id name possibilities

220

219

221

220

222−allUnique :: [A.Located Var.Value] -> Result.ResultErr ()

221+allUnique :: [A.Located Var.Value] -> CResult ()

223allUnique statedExports =

222allUnique statedExports =

224 let

223 let

225 valueToString value =

224 valueToString value =

@@ -234,12 +233,12 @@ allUnique statedExports =

234 isUnique value allRegions =

233 isUnique value allRegions =

235 case allRegions of

234 case allRegions of

236 region : _ : _ ->

235 region : _ : _ ->

237− Result.err (A.A region (CError.DuplicateExport (valueToString value)))

236+ Result.throw region (CError.DuplicateExport (valueToString value))

238

237

239 _ ->

238 _ ->

240 Result.ok ()

239 Result.ok ()

241 in

240 in

242− T.traverse_ id (Map.mapWithKey isUnique locations)

241+ T.sequenceA_ (Map.mapWithKey isUnique locations)

243

242

244

243

245

244

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

319-- DECLARATIONS

318-- DECLARATIONS

320

319

321

320

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

321+canonicalizeDecls :: Env.Environment -> D.Valid -> CResult D.Canonical

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

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

324 let

323 let

325− traverse canEntry entries =

324+ annTraverse canEntry entries =

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

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

327

326

328 canonicalizeDef (Valid.Def pat expr typ) =

327 canonicalizeDef (Valid.Def pat expr typ) =

329 Canonical.Def Canonical.dummyFacts

328 Canonical.Def Canonical.dummyFacts

330 <$> canonicalizePattern env pat

329 <$> canonicalizePattern env pat

331 <*> canonicalizeExpr env expr

330 <*> canonicalizeExpr env expr

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

331+ <*> traverse (canonicalizeRegionType env) typ

333

332

334 canonicalizeArgs (ctor, args) =

333 canonicalizeArgs (ctor, args) =

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

334+ (,) ctor <$> traverse (Canon.tipe env) args

336

335

337 canonicalizeUnion (D.Type name tvars ctors) =

336 canonicalizeUnion (D.Type name tvars ctors) =

338− D.Type name tvars <$> T.traverse canonicalizeArgs ctors

337+ D.Type name tvars <$> traverse canonicalizeArgs ctors

339

338

340 canonicalizeAlias (D.Type name tvars alias) =

339 canonicalizeAlias (D.Type name tvars alias) =

341− D.Type name tvars <$> Canonicalize.tipe env alias

340+ D.Type name tvars <$> Canon.tipe env alias

342 in

341 in

343 D.Decls

342 D.Decls

344− <$> traverse canonicalizeDef defs

343+ <$> annTraverse canonicalizeDef defs

345− <*> traverse canonicalizeUnion unions

344+ <*> annTraverse canonicalizeUnion unions

346− <*> traverse canonicalizeAlias aliases

345+ <*> annTraverse canonicalizeAlias aliases

347 <*> pure infixes

346 <*> pure infixes

348

347

349

348

350canonicalizeRegionType

349canonicalizeRegionType

351 :: Env.Environment

350 :: Env.Environment

352 -> Type.Raw

351 -> Type.Raw

353− -> Result.ResultErr (A.Located Type.Canonical)

352+ -> CResult (A.Located Type.Canonical)

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

353canonicalizeRegionType env typ@(A.A region _) =

355− A.A region <$> Canonicalize.tipe env typ

354+ A.A region <$> Canon.tipe env typ

356

355

357

356

358canonicalizeExpr

357canonicalizeExpr

359 :: Env.Environment

358 :: Env.Environment

360 -> Valid.Expr

359 -> Valid.Expr

361− -> Result.ResultErr Canonical.Expr

360+ -> CResult Canonical.Expr

362canonicalizeExpr env (A.A region validExpr) =

361canonicalizeExpr env (A.A region validExpr) =

363 let go = canonicalizeExpr env

362 let go = canonicalizeExpr env

364 in

363 in

@@ -376,15 +375,15 @@ canonicalizeExpr env (A.A region validExpr) =

376 Update record fields ->

375 Update record fields ->

377 Update

376 Update

378 <$> go record

377 <$> go record

379− <*> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

378+ <*> traverse (\(field,expr) -> (,) field <$> go expr) fields

380

379

381 Record fields ->

380 Record fields ->

382 Record

381 Record

383− <$> T.traverse (\(field,expr) -> (,) field <$> go expr) fields

382+ <$> traverse (\(field,expr) -> (,) field <$> go expr) fields

384

383

385 Binop (Var.Raw op) leftExpr rightExpr ->

384 Binop (Var.Raw op) leftExpr rightExpr ->

386 Binop

385 Binop

387− <$> Canonicalize.variable region env op

386+ <$> Canon.variable region env op

388 <*> go leftExpr

387 <*> go leftExpr

389 <*> go rightExpr

388 <*> go rightExpr

390

389

@@ -400,14 +399,14 @@ canonicalizeExpr env (A.A region validExpr) =

400

399

401 If branches finally ->

400 If branches finally ->

402 If

401 If

403− <$> T.traverse go' branches

402+ <$> traverse go' branches

404 <*> go finally

403 <*> go finally

405 where

404 where

406 go' (condition, branch) =

405 go' (condition, branch) =

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

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

408

407

409− Let defs body ->

408+ Let defs expr ->

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

409+ Let <$> traverse rename' defs <*> canonicalizeExpr env' expr

411 where

410 where

412 env' =

411 env' =

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

412 foldr Env.addPattern env (map Valid.getPattern defs)

@@ -416,19 +415,19 @@ canonicalizeExpr env (A.A region validExpr) =

416 Canonical.Def Canonical.dummyFacts

415 Canonical.Def Canonical.dummyFacts

417 <$> canonicalizePattern env' p

416 <$> canonicalizePattern env' p

418 <*> canonicalizeExpr env' body

417 <*> canonicalizeExpr env' body

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

418+ <*> traverse (canonicalizeRegionType env') mtipe

420

419

421 Var (Var.Raw x) ->

420 Var (Var.Raw x) ->

422− Var <$> Canonicalize.variable region env x

421+ Var <$> Canon.variable region env x

423

422

424 Data name exprs ->

423 Data name exprs ->

425− Data name <$> T.traverse go exprs

424+ Data name <$> traverse go exprs

426

425

427 ExplicitList exprs ->

426 ExplicitList exprs ->

428− ExplicitList <$> T.traverse go exprs

427+ ExplicitList <$> traverse go exprs

429

428

430 Case expr cases ->

429 Case expr cases ->

431− Case <$> go expr <*> T.traverse branch cases

430+ Case <$> go expr <*> traverse branch cases

432 where

431 where

433 branch (ptrn, brnch) =

432 branch (ptrn, brnch) =

434 (,)

433 (,)

@@ -442,10 +441,10 @@ canonicalizeExpr env (A.A region validExpr) =

442 Result.ok (Sub moduleName)

441 Result.ok (Sub moduleName)

443

442

444 ForeignCmd name tipe ->

443 ForeignCmd name tipe ->

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

444+ ForeignCmd name <$> Canon.tipe env tipe

446

445

447 ForeignSub name tipe ->

446 ForeignSub name tipe ->

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

447+ ForeignSub name <$> Canon.tipe env tipe

449

448

450 SaveEnv moduleName effects ->

449 SaveEnv moduleName effects ->

451 Result.ok (SaveEnv moduleName effects)

450 Result.ok (SaveEnv moduleName effects)

@@ -454,7 +453,7 @@ canonicalizeExpr env (A.A region validExpr) =

454 Result.ok (GLShader uid src tipe)

453 Result.ok (GLShader uid src tipe)

455

454

456

455

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

456+canonicalizePattern :: Env.Environment -> P.Raw -> CResult P.Canonical

458canonicalizePattern env (A.A region ptrn) =

457canonicalizePattern env (A.A region ptrn) =

459 A.A region <$>

458 A.A region <$>

460 case ptrn of

459 case ptrn of

@@ -475,5 +474,5 @@ canonicalizePattern env (A.A region ptrn) =

475

474

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

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

477 P.Data

476 P.Data

478− <$> Canonicalize.pvar region env name (length patterns)

477+ <$> Canon.pvar region env name (length patterns)

479− <*> T.traverse (canonicalizePattern env) patterns

478+ <*> traverse (canonicalizePattern env) patterns

src/Canonicalize/Effects.hs+11−14

@@ -9,9 +9,10 @@ import qualified AST.Variable as Var

9import qualified Reporting.Annotation as A

10import qualified Reporting.Error.Canonicalize as Error

11import qualified Reporting.Region as R

12+import qualified Reporting.Result as Result

12import qualified Canonicalize.Environment as Env

13import qualified Canonicalize.Environment as Env

13−import qualified Canonicalize.Result as Result

14import qualified Canonicalize.Type as Canonicalize

15+import Canonicalize.Variable (Result)

@@ -35,7 +36,7 @@ toValues effects =

35-- CANONICALIZE

36-- CANONICALIZE

38−canonicalize :: Env.Environment -> Effects.Raw -> Result.ResultErr Effects.Canonical

39+canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical

39canonicalize env effects =

40canonicalize env effects =

40 case effects of

41 case effects of

41 Effects.None ->

42 Effects.None ->

@@ -51,18 +52,14 @@ canonicalize env effects =

51canonicalizeRawForeign

52canonicalizeRawForeign

52 :: Env.Environment

53 :: Env.Environment

53 -> A.Commented Effects.ForeignRaw

54 -> A.Commented Effects.ForeignRaw

54− -> Result.ResultErr (A.Commented Effects.ForeignCanonical)

55+ -> Result (A.Commented Effects.ForeignCanonical)

55canonicalizeRawForeign env (A.A ann (Effects.ForeignRaw name rawType)) =

56canonicalizeRawForeign env (A.A ann (Effects.ForeignRaw name rawType)) =

56− Canonicalize.tipe env rawType

57+ do tipe <- Canonicalize.tipe env rawType

57− `Result.andThen` \tipe ->

58+ kind <- figureOutKind (fst ann) name tipe

59+ Result.ok (A.A ann (Effects.ForeignCanonical name kind tipe))

59− figureOutKind (fst ann) name tipe

60− `Result.andThen` \kind ->

62− Result.ok (A.A ann (Effects.ForeignCanonical name kind tipe))

63−

64−

65−figureOutKind :: R.Region -> String -> T.Canonical -> Result.ResultErr Effects.Kind

62+figureOutKind :: R.Region -> String -> T.Canonical -> Result Effects.Kind

66figureOutKind region name rootType =

63figureOutKind region name rootType =

67 case T.deepDealias rootType of

64 case T.deepDealias rootType of

68 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])

65 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])

@@ -76,7 +73,7 @@ figureOutKind region name rootType =

76 <$> checkForeignType region name "subscription" incomingType

73 <$> checkForeignType region name "subscription" incomingType

78 _ ->

75 _ ->

79− Result.err (A.A region (error "TODO - bad overall type"))

76+ Result.throw region (error "TODO - bad overall type")

@@ -86,11 +83,11 @@ figureOutKind region name rootType =

86--

83--

87-- Note: assumes that deepDealias has been called on the incoming type.

84-- Note: assumes that deepDealias has been called on the incoming type.

88--

85--

89−checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result.ResultErr ()

86+checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result ()

90checkForeignType region name kind tipe =

87checkForeignType region name kind tipe =

91 let

88 let

92 throwError maybeMessage =

89 throwError maybeMessage =

93− Result.err $ A.A region $

90+ Result.throw region $

94 Error.foreign name kind tipe maybeMessage

91 Error.foreign name kind tipe maybeMessage

96 check subType =

93 check subType =

src/Canonicalize/Result.hsdeleted−117

@@ -1,117 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Canonicalize.Result where

3−

4−import Prelude hiding (foldl)

5−import qualified Control.Applicative as A

6−import qualified Data.Functor as F

7−import qualified Data.Set as Set

8−

9−import qualified AST.Module.Name as ModuleName

10−import qualified AST.Variable as Var

11−import qualified Reporting.Annotation as A

12−import qualified Reporting.Error.Canonicalize as Error

13−

14−

15−type ResultErr a = Result (A.Located Error.Error) a

16−

17−

18−data Result err a =

19− Result (Set.Set ModuleName.Raw) (RawResult err a)

20−

21−

22−data RawResult err a

23− = Ok a

24− | Err [err]

25−

26−

27−-- RESULT HELPERS

28−

29−ok :: a -> Result e a

30−ok value =

31− Result Set.empty (Ok value)

32−

33−

34−err :: e -> Result e a

35−err msg =

36− errors [msg]

37−

38−

39−errors :: [e] -> Result e a

40−errors msgs =

41− Result Set.empty (Err msgs)

42−

43−

44−foldl :: (a -> b -> Result e b) -> b -> [a] -> Result e b

45−foldl f acc list =

46− case list of

47− [] ->

48− ok acc

49−

50− x:xs ->

51− f x acc `andThen` (\acc' -> foldl f acc' xs)

52−

53−

54−andThen :: Result e a -> (a -> Result e b) -> Result e b

55−andThen (Result uses rawResult) callback =

56− case rawResult of

57− Err msg ->

58− Result uses (Err msg)

59−

60− Ok value ->

61− let (Result uses' rawResult') = callback value

62− in

63− Result (Set.union uses uses') rawResult'

64−

65−

66−instance F.Functor (Result e) where

67− fmap func (Result uses result) =

68− case result of

69− Ok a ->

70− Result uses (Ok (func a))

71−

72− Err msgs ->

73− Result uses (Err msgs)

74−

75−

76−instance A.Applicative (Result e) where

77− pure value =

78− ok value

79−

80− (<*>) (Result uses resultFunc) (Result uses' resultVal) =

81− Result (Set.union uses uses') $

82− case (resultFunc, resultVal) of

83− (Ok func, Ok val) ->

84− Ok (func val)

85−

86− (Err msgs, Err msgs') ->

87− Err (msgs ++ msgs')

88−

89− (Err msgs, _) ->

90− Err msgs

91−

92− (_, Err msgs) ->

93− Err msgs

94−

95−

96−-- TRACK USES OF IMPORTS

97−

98−addModule :: ModuleName.Raw -> Result e a -> Result e a

99−addModule home (Result uses result) =

100− Result (Set.insert home uses) result

101−

102−

103−var' :: (a -> Var.Canonical) -> a -> Result e a

104−var' toVar value =

105− case toVar value of

106− Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->

107− Result (Set.singleton moduleName) (Ok value)

108−

109− Var.Canonical _ _ ->

110− ok value

111−

112−

113−var :: Var.Canonical -> Result e Var.Canonical

114−var variable =

115− var' id variable

116−

117−

src/Canonicalize/Setup.hs+32−33

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

2module Canonicalize.Setup (environment) where

4import Control.Arrow (second)

5+import Control.Monad (foldM)

5import qualified Data.Graph as Graph

6import qualified Data.Graph as Graph

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Maybe as Maybe

8import qualified Data.Maybe as Maybe

@@ -20,9 +21,10 @@ import qualified Reporting.Annotation as A

20import qualified Reporting.Error.Canonicalize as Error

21import qualified Reporting.Error.Canonicalize as Error

21import qualified Reporting.Error.Helpers as Error

22import qualified Reporting.Error.Helpers as Error

22import qualified Reporting.Region as R

23import qualified Reporting.Region as R

24+import qualified Reporting.Result as Result

23import qualified Canonicalize.Environment as Env

25import qualified Canonicalize.Environment as Env

24−import qualified Canonicalize.Result as Result

25import qualified Canonicalize.Type as Canonicalize

26import qualified Canonicalize.Type as Canonicalize

27+import Canonicalize.Variable (Result)

@@ -30,7 +32,7 @@ environment

30 :: Map.Map ModuleName.Raw ModuleName.Canonical

32 :: Map.Map ModuleName.Raw ModuleName.Canonical

31 -> Module.Interfaces

33 -> Module.Interfaces

32 -> Module.Valid

34 -> Module.Valid

33− -> Result.ResultErr Env.Environment

35+ -> Result Env.Environment

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

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

35 let

37 let

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

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

@@ -53,8 +55,8 @@ environment importDict interfaces (Module.Module name _ info) =

53 name

55 name

54 (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))

56 (concat (Env.builtinPatches : declPatches : effectPatches : importPatches))

55 in

57 in

56− (createEnv <$> getImportPatches)

58+ do env <- createEnv <$> getImportPatches

57− `Result.andThen` addTypeAliases name typeAliasNodes

59+ addTypeAliases name typeAliasNodes env

@@ -65,7 +67,7 @@ importToPatches

65 :: Map.Map ModuleName.Raw ModuleName.Canonical

67 :: Map.Map ModuleName.Raw ModuleName.Canonical

66 -> Module.Interfaces

68 -> Module.Interfaces

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

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

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

70+ -> Result [Env.Patch]

69importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

71importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

70 let

72 let

71 maybeInterface =

73 maybeInterface =

@@ -84,8 +86,7 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

84 |> map ModuleName._module

86 |> map ModuleName._module

85 |> Error.nearbyNames ModuleName.toString rawImportName

87 |> Error.nearbyNames ModuleName.toString rawImportName

86 |> Error.moduleNotFound rawImportName

88 |> Error.moduleNotFound rawImportName

87− |> A.A region

89+ |> Result.throw region

88− |> Result.err

90 Just (importName, interface) ->

91 Just (importName, interface) ->

91 let

92 let

@@ -156,7 +157,7 @@ valueToPatches

156 -> ModuleName.Canonical

157 -> ModuleName.Canonical

157 -> Module.Interface

158 -> Module.Interface

158 -> Var.Value

159 -> Var.Value

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

160+ -> Result [Env.Patch]

160valueToPatches region moduleName interface value =

161valueToPatches region moduleName interface value =

161 let

162 let

162 patch mkPatch x =

163 patch mkPatch x =

@@ -170,8 +171,7 @@ valueToPatches region moduleName interface value =

170 |> getNames

171 |> getNames

171 |> Error.nearbyNames id x

172 |> Error.nearbyNames id x

172 |> Error.valueNotFound (ModuleName._module moduleName) x

173 |> Error.valueNotFound (ModuleName._module moduleName) x

173− |> A.A region

174+ |> Result.throw region

174− |> Result.err

175 in

176 case value of

177 Var.Value x ->

@@ -184,13 +184,16 @@ valueToPatches region moduleName interface value =

184 Var.Alias x ->

185 case Map.lookup x (Module.iAliases interface) of

186 Just (tvars, t) ->

187+ let

187− let alias =

188+ alias =

188− Env.Alias x (Var.fromModule moduleName x, tvars, t)

189+ Env.Alias x (Var.fromModule moduleName x, tvars, t)

189 in

190 in

190− Result.ok $

191+ Result.ok $

191− if Map.member x (Module.iTypes interface)

192+ if Map.member x (Module.iTypes interface) then

192− then [alias, patch Env.Value x]

193+ [alias, patch Env.Value x]

194+

195+ else

193− else [alias]

196+ [alias]

194

197

195 Nothing ->

198 Nothing ->

196 case Map.lookup x (Module.iUnions interface) of

199 case Map.lookup x (Module.iUnions interface) of

@@ -211,9 +214,11 @@ valueToPatches region moduleName interface value =

211

214

212 Just (_tvars, realCtors) ->

215 Just (_tvars, realCtors) ->

213 patches <$>

216 patches <$>

214− if open

217+ if open then

215− then Result.ok realCtorList

218+ Result.ok realCtorList

219+

220+ else

216− else Trav.traverse ctorExists givenCtorNames

221+ Trav.traverse ctorExists givenCtorNames

217 where

222 where

218 realCtorList =

223 realCtorList =

219 map (second length) realCtors

224 map (second length) realCtors

@@ -225,6 +230,7 @@ valueToPatches region moduleName interface value =

225 case Map.lookup givenCtorName realCtorDict of

230 case Map.lookup givenCtorName realCtorDict of

226 Just numArgs ->

231 Just numArgs ->

227 Result.ok (givenCtorName, numArgs)

232 Result.ok (givenCtorName, numArgs)

233+

228 Nothing ->

234 Nothing ->

229 notFound (const (map fst realCtors)) givenCtorName

235 notFound (const (map fst realCtors)) givenCtorName

230

236

@@ -264,24 +270,17 @@ node region name tvars alias =

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

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

265

271

266

272

267−addTypeAliases

268− :: ModuleName.Canonical

273+addTypeAliases :: ModuleName.Canonical -> [Node] -> Env.Environment -> Result Env.Environment

269− -> [Node]

270− -> Env.Environment

271− -> Result.ResultErr Env.Environment

272addTypeAliases moduleName typeAliasNodes initialEnv =

274addTypeAliases moduleName typeAliasNodes initialEnv =

273− Result.foldl

274− (addTypeAlias moduleName)

275− initialEnv

276− (Graph.stronglyConnComp typeAliasNodes)

275+ foldM (addTypeAlias moduleName) initialEnv (Graph.stronglyConnComp typeAliasNodes)

277

276

278

277

279addTypeAlias

278addTypeAlias

280 :: ModuleName.Canonical

279 :: ModuleName.Canonical

281− -> Graph.SCC (R.Region, String, [String], Type.Raw)

282 -> Env.Environment

280 -> Env.Environment

281+ -> Graph.SCC (R.Region, String, [String], Type.Raw)

283− -> Result.ResultErr Env.Environment

282+ -> Result Env.Environment

284−addTypeAlias moduleName scc env =

283+addTypeAlias moduleName env scc =

285 case scc of

284 case scc of

286 Graph.AcyclicSCC (_, name, tvars, alias) ->

285 Graph.AcyclicSCC (_, name, tvars, alias) ->

287 addToEnv <$> Canonicalize.tipe env alias

286 addToEnv <$> Canonicalize.tipe env alias

@@ -296,10 +295,10 @@ addTypeAlias moduleName scc env =

296 Result.ok env

295 Result.ok env

297

296

298 Graph.CyclicSCC [(region, name, tvars, alias)] ->

297 Graph.CyclicSCC [(region, name, tvars, alias)] ->

299− Result.err (A.A region (Error.Alias (Error.SelfRecursive name tvars alias)))

298+ Result.throw region (Error.Alias (Error.SelfRecursive name tvars alias))

300

299

301 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->

300 Graph.CyclicSCC aliases@((region, _, _, _) : _) ->

302− Result.err (A.A region (Error.Alias (Error.MutuallyRecursive aliases)))

301+ Result.throw region (Error.Alias (Error.MutuallyRecursive aliases))

303

302

304

303

305

304

src/Canonicalize/Type.hs+13−16

@@ -9,15 +9,13 @@ import qualified AST.Variable as Var

9import qualified Reporting.Annotation as A

10import qualified Reporting.Error.Canonicalize as Error

11import qualified Reporting.Region as R

12+import qualified Reporting.Result as Result

12import qualified Canonicalize.Environment as Env

13import qualified Canonicalize.Environment as Env

13−import qualified Canonicalize.Result as Result

14import qualified Canonicalize.Variable as Canonicalize

15+import Canonicalize.Variable (Result)

17−tipe

18− :: Env.Environment

18+tipe :: Env.Environment -> T.Raw -> Result T.Canonical

19− -> T.Raw

20− -> Result.ResultErr T.Canonical

21tipe env annType@(A.A _ typ) =

19tipe env annType@(A.A _ typ) =

22 let

20 let

23 go =

21 go =

@@ -43,16 +41,11 @@ tipe env annType@(A.A _ typ) =

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

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

46−canonicalizeApp

44+canonicalizeApp :: Env.Environment -> T.Raw -> [T.Raw] -> Result T.Canonical

47− :: Env.Environment

48− -> T.Raw

49− -> [T.Raw]

50− -> Result.ResultErr T.Canonical

51canonicalizeApp env annFunc@(A.A region func) args =

45canonicalizeApp env annFunc@(A.A region func) args =

52 case func of

46 case func of

53 T.RType (Var.Raw rawName) ->

47 T.RType (Var.Raw rawName) ->

54− Canonicalize.tvar region env rawName

48+ canonicalizeWithTvar =<< Canonicalize.tvar region env rawName

55− `Result.andThen` canonicalizeWithTvar

57 _ ->

50 _ ->

58 T.App

51 T.App

@@ -69,6 +62,7 @@ canonicalizeApp env annFunc@(A.A region func) args =

69 case args of

62 case args of

70 [] ->

63 [] ->

71 Result.ok (T.Type name)

64 Result.ok (T.Type name)

65+

72 _ ->

66 _ ->

73 T.App (T.Type name) <$> Trav.traverse (tipe env) args

67 T.App (T.Type name) <$> Trav.traverse (tipe env) args

@@ -78,17 +72,20 @@ canonicalizeAlias

78 -> Env.Environment

72 -> Env.Environment

79 -> (Var.Canonical, [String], T.Canonical)

73 -> (Var.Canonical, [String], T.Canonical)

80 -> [T.Raw]

74 -> [T.Raw]

81− -> Result.ResultErr T.Canonical

75+ -> Result T.Canonical

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

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

83 let

77 let

78+ typesLen =

84− typesLen = length types

79+ length types

80+

81+ tvarsLen =

85− tvarsLen = length tvars

82+ length tvars

87 toAlias canonicalTypes =

84 toAlias canonicalTypes =

88 T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

85 T.Aliased name (zip tvars canonicalTypes) (T.Holey dealiasedTipe)

89 in

86 in

90 if typesLen /= tvarsLen then

87 if typesLen /= tvarsLen then

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

88+ Result.throw region (Error.alias name tvarsLen typesLen)

93 else

90 else

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

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

src/Canonicalize/Variable.hs+47−23

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

1{-# OPTIONS_GHC -Wall #-}

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

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

4import qualified Data.Either as Either

5import qualified Data.Map as Map

@@ -9,20 +9,43 @@ import qualified AST.Helpers as Help

9import qualified AST.Module.Name as ModuleName

10import qualified AST.Type as Type

11import qualified AST.Variable as Var

12−import qualified Reporting.Annotation as A

12+import qualified Canonicalize.Environment as Env

13import qualified Reporting.Error.Canonicalize as Error

14import qualified Reporting.Error.Helpers as Error

15import qualified Reporting.Region as R

16−import qualified Canonicalize.Environment as Env

16+import qualified Reporting.Result as Result

17−import qualified Canonicalize.Result as Result

17+import qualified Reporting.Warning as Warning

18import Elm.Utils ((|>))

22+-- RESULT HELPERS

23+

24+

25+type Result a =

26+ Result.Result (Set.Set ModuleName.Raw) Warning.Warning Error.Error a

27+

28+

29+logVarWith :: (a -> Var.Canonical) -> a -> Result a

30+logVarWith toVar value =

31+ case toVar value of

32+ Var.Canonical (Var.Module (ModuleName.Canonical _ moduleName)) _name ->

33+ Result.accumulate (Set.singleton moduleName) value

34+

35+ Var.Canonical _ _ ->

36+ Result.ok value

37+

38+

39+logVar :: Var.Canonical -> Result Var.Canonical

40+logVar var =

41+ logVarWith id var

42+

43+

44+

22-- FINDERS

45-- FINDERS

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

48+variable :: R.Region -> Env.Environment -> String -> Result Var.Canonical

26variable region env var =

49variable region env var =

27 case toVarName var of

50 case toVarName var of

28 Right (name, varName) | ModuleName.isNative name ->

51 Right (name, varName) | ModuleName.isNative name ->

@@ -33,12 +56,12 @@ variable region env var =

33 moduleName =

56 moduleName =

34 ModuleName.Canonical localPkg name

57 ModuleName.Canonical localPkg name

35 in

58 in

36− Result.var (Var.Canonical (Var.Module moduleName) varName)

59+ logVar (Var.Canonical (Var.Module moduleName) varName)

38 _ ->

61 _ ->

39 case Set.toList `fmap` Map.lookup var (Env._values env) of

62 case Set.toList `fmap` Map.lookup var (Env._values env) of

40 Just [v] ->

63 Just [v] ->

41− Result.var v

64+ logVar v

43 Just vs ->

66 Just vs ->

44 preferLocals region env "variable" vs var

67 preferLocals region env "variable" vs var

@@ -51,7 +74,7 @@ tvar

51 :: R.Region

74 :: R.Region

52 -> Env.Environment

75 -> Env.Environment

53 -> String

76 -> String

54− -> Result.ResultErr

77+ -> Result

55 (Either

78 (Either

56 Var.Canonical

79 Var.Canonical

57 (Var.Canonical, [String], Type.Canonical)

80 (Var.Canonical, [String], Type.Canonical)

@@ -59,7 +82,7 @@ tvar

59tvar region env var =

82tvar region env var =

60 case unions ++ aliases of

83 case unions ++ aliases of

61 [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var

84 [] -> notFound region "type" (Map.keys (Env._unions env) ++ Map.keys (Env._aliases env)) var

62− [v] -> Result.var' extract v

85+ [v] -> logVarWith extract v

63 vs -> preferLocals' region env extract "type" vs var

86 vs -> preferLocals' region env extract "type" vs var

64 where

87 where

65 unions =

88 unions =

@@ -79,23 +102,24 @@ pvar

79 -> Env.Environment

102 -> Env.Environment

80 -> String

103 -> String

81 -> Int

104 -> Int

82− -> Result.ResultErr Var.Canonical

105+ -> Result Var.Canonical

83pvar region env var actualArgs =

106pvar region env var actualArgs =

84 case Set.toList `fmap` Map.lookup var (Env._patterns env) of

107 case Set.toList `fmap` Map.lookup var (Env._patterns env) of

85 Just [value] ->

108 Just [value] ->

86 foundArgCheck value

109 foundArgCheck value

110

88 Just values ->

111 Just values ->

89− preferLocals' region env fst "pattern" values var

112+ foundArgCheck =<< preferLocals' region env fst "pattern" values var

90− `Result.andThen` foundArgCheck

113

92 Nothing ->

114 Nothing ->

93 notFound region "pattern" (Map.keys (Env._patterns env)) var

115 notFound region "pattern" (Map.keys (Env._patterns env)) var

94 where

116 where

95 foundArgCheck (name, expectedArgs) =

117 foundArgCheck (name, expectedArgs) =

96− if actualArgs == expectedArgs

118+ if actualArgs == expectedArgs then

97− then Result.var name

119+ logVar name

120+

121+ else

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

122+ Result.throw region (Error.argMismatch name expectedArgs actualArgs)

123

100

124

101

125

@@ -108,7 +132,7 @@ preferLocals

108 -> String

132 -> String

109 -> [Var.Canonical]

133 -> [Var.Canonical]

110 -> String

134 -> String

111− -> Result.ResultErr Var.Canonical

135+ -> Result Var.Canonical

112preferLocals region env =

136preferLocals region env =

113 preferLocals' region env id

137 preferLocals' region env id

114

138

@@ -120,28 +144,28 @@ preferLocals'

120 -> String

144 -> String

121 -> [a]

145 -> [a]

122 -> String

146 -> String

123− -> Result.ResultErr a

147+ -> Result a

124preferLocals' region env extract kind possibilities var =

148preferLocals' region env extract kind possibilities var =

125 case filter (isLocal (Env._home env) . extract) possibilities of

149 case filter (isLocal (Env._home env) . extract) possibilities of

126 [] ->

150 [] ->

127 ambiguous possibilities

151 ambiguous possibilities

128

152

129 [v] ->

153 [v] ->

130− Result.var' extract v

154+ logVarWith extract v

131

155

132 --Local vars shadow top-level vars

156 --Local vars shadow top-level vars

133 [v1, v2]

157 [v1, v2]

134 | isTopLevel (extract v1) ->

158 | isTopLevel (extract v1) ->

135− Result.var' extract v2

159+ logVarWith extract v2

136

160

137 | isTopLevel (extract v2) ->

161 | isTopLevel (extract v2) ->

138− Result.var' extract v1

162+ logVarWith extract v1

139

163

140 locals ->

164 locals ->

141 ambiguous locals

165 ambiguous locals

142 where

166 where

143 ambiguous possibleVars =

167 ambiguous possibleVars =

144− Result.err (A.A region (Error.variable kind var Error.Ambiguous vars))

168+ Result.throw region (Error.variable kind var Error.Ambiguous vars)

145 where

169 where

146 vars = map (Var.toString . extract) possibleVars

170 vars = map (Var.toString . extract) possibleVars

147

171

@@ -208,7 +232,7 @@ isOp name =

208-- NOT FOUND

232-- NOT FOUND

209

233

210

234

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

235+notFound :: R.Region -> String -> [String] -> String -> Result a

212notFound region kind possibilities var =

236notFound region kind possibilities var =

213 let name =

237 let name =

214 toVarName var

238 toVarName var

@@ -224,7 +248,7 @@ notFound region kind possibilities var =

224 Right (modul, varName) ->

248 Right (modul, varName) ->

225 qualifiedProblem modul varName (Either.rights possibleNames)

249 qualifiedProblem modul varName (Either.rights possibleNames)

226 in

250 in

227− Result.err (A.A region (Error.variable kind var problem suggestions))

251+ Result.throw region (Error.variable kind var problem suggestions)

228

252

229

253

230exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])

254exposedProblem :: VarName -> [VarName] -> (Error.VarProblem, [String])

src/Compile.hs+10−5

@@ -14,23 +14,28 @@ import qualified Optimize

14import qualified Parse.Helpers as Parse

15import qualified Parse.Parse as Parse

16import qualified Reporting.Error as Error

17+import qualified Reporting.Render.Type as RenderType

17import qualified Reporting.Result as Result

18import qualified Reporting.Result as Result

18import qualified Reporting.Warning as Warning

19import qualified Reporting.Warning as Warning

19import qualified Type.Inference as TI

20import qualified Type.Inference as TI

23+

24+type Result =

25+ Result.Result (Result.One RenderType.Localizer) Warning.Warning Error.Error

26+

27+

22compile

28compile

23 :: Package.Name

29 :: Package.Name

24 -> [ModuleName.Canonical]

30 -> [ModuleName.Canonical]

25 -> Module.Interfaces

31 -> Module.Interfaces

26 -> String

32 -> String

27− -> Result.Result Warning.Warning Error.Error Module.Optimized

33+ -> Result Module.Optimized

28−

29compile packageName canonicalImports interfaces source =

34compile packageName canonicalImports interfaces source =

30 do

35 do

31 -- Parse the source code

36 -- Parse the source code

32 validModule <-

37 validModule <-

33− Result.mapError Error.Syntax $

38+ Result.format Error.Syntax $

34 Parse.program packageName (getOpTable interfaces) source

39 Parse.program packageName (getOpTable interfaces) source

36 -- Canonicalize all variables, pinning down where they came from.

41 -- Canonicalize all variables, pinning down where they came from.

@@ -43,11 +48,11 @@ compile packageName canonicalImports interfaces source =

43 TI.infer interfaces canonicalModule

48 TI.infer interfaces canonicalModule

45 -- One last round of checks

50 -- One last round of checks

46− Result.mapError Error.Type $

51+ Result.format Error.Type $

47 Nitpick.topLevelTypes types (Module.validDecls (Module.info validModule))

52 Nitpick.topLevelTypes types (Module.validDecls (Module.info validModule))

49 tagDict <-

54 tagDict <-

50− Result.mapError Error.Pattern $

55+ Result.format Error.Pattern $

51 Nitpick.patternMatches interfaces canonicalModule

56 Nitpick.patternMatches interfaces canonicalModule

53 -- Add the real list of types

58 -- Add the real list of types

src/Docs/Check.hs+4−2

@@ -1,4 +1,4 @@

1−module Docs.Check (check) where

1+module Docs.Check (Result, check) where

3import qualified Data.List as List

4import qualified Data.Map as Map

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

22import qualified Reporting.Result as R

25+

26+type Result w a =

25−type Result w a = R.Result w Error.Error a

27+ R.Result () w Error.Error a

28-- CHECK DOCUMENTATION

30-- CHECK DOCUMENTATION

src/Elm/Compiler.hs+14−24

@@ -25,6 +25,7 @@ import qualified Generate.JavaScript as JS

25import qualified Parse.Module as Parse

26import qualified Parse.Parse as Parse

27import qualified Reporting.Annotation as A

28+import qualified Reporting.Bag as Bag

28import qualified Reporting.Error as Error

29import qualified Reporting.Error as Error

29import qualified Reporting.Render.Type as RenderType

30import qualified Reporting.Render.Type as RenderType

30import qualified Reporting.Report as Report

31import qualified Reporting.Report as Report

@@ -48,18 +49,13 @@ version =

48parseDependencies :: String -> Either [Error] (PublicModule.Raw, [PublicModule.Raw])

49parseDependencies :: String -> Either [Error] (PublicModule.Raw, [PublicModule.Raw])

49parseDependencies sourceCode =

50parseDependencies sourceCode =

50 let

51 let

51− (Result.Result _warnings rawResult) =

52+ (Result.Result _ _ answer) =

52 Parse.parse sourceCode Parse.header

53 Parse.parse sourceCode Parse.header

53− in

54− case rawResult of

55− Result.Err msgs ->

56− Left $ map (Error . A.map Error.Syntax) msgs

58− Result.Ok (Module.Header _ name _ _ _ imports) ->

55+ getDeps (Module.Header _ name _ _ _ imports) =

59− Right

60− ( name

61− , map (fst . A.drop) imports

56+ ( name, map (fst . A.drop) imports )

62− )

57+ in

58+ Result.answerToEither (Error . A.map Error.Syntax) getDeps answer

@@ -78,18 +74,18 @@ compile context source interfaces =

78 (Context packageName isExposed dependencies) =

74 (Context packageName isExposed dependencies) =

79 context

75 context

81− (Result.Result (localizer, warnings) rawResult) =

77+ (Result.Result oneLocalizer warnings answer) =

82 do modul <- Compile.compile packageName dependencies interfaces source

78 do modul <- Compile.compile packageName dependencies interfaces source

83− docs <- docsGen isExposed modul

79+ docs <- Result.format Error.Docs (docsGen isExposed modul)

85 let interface = Module.toInterface packageName modul

81 let interface = Module.toInterface packageName modul

86 let javascript = JS.generate modul

82 let javascript = JS.generate modul

88 return (Result docs interface javascript)

84 return (Result docs interface javascript)

89 in

85 in

90− ( maybe dummyLocalizer Localizer localizer

86+ ( Result.oneToValue dummyLocalizer Localizer oneLocalizer

91− , map Warning warnings

87+ , Bag.toList Warning warnings

92− , Result.destruct (Left . map Error) Right rawResult

88+ , Result.answerToEither Error id answer

93 )

89 )

@@ -107,23 +103,17 @@ data Result = Result

107 }

103 }

108

104

109

105

110−docsGen

111− :: Bool

112− -> Module.Optimized

113− -> Result.Result w Error.Error (Maybe Docs.Documentation)

106+docsGen :: Bool -> Module.Optimized -> Docs.Result w (Maybe Docs.Documentation)

114docsGen isExposed (Module.Module name _ info) =

107docsGen isExposed (Module.Module name _ info) =

115 if not isExposed then

108 if not isExposed then

116 Result.ok Nothing

109 Result.ok Nothing

117

110

118 else

111 else

119 let

112 let

120− getChecked =

121− Docs.check (Module.exports info) (Module.docs info)

122−

123 toDocs checked =

113 toDocs checked =

124− Docs.fromCheckedDocs (ModuleName._module name) checked

114+ Just (Docs.fromCheckedDocs (ModuleName._module name) checked)

125 in

115 in

126− (Just . toDocs) `fmap` Result.mapError Error.Docs getChecked

116+ toDocs <$> Docs.check (Module.exports info) (Module.docs info)

127

117

128

118

129

119

src/Nitpick/PatternMatches.hs+9−16

@@ -23,10 +23,11 @@ import qualified Reporting.Result as Result

26−patternMatches

26+type Result warning a =

27− :: Module.Interfaces

27+ Result.Result () warning Error.Error a

28− -> Module.Canonical

28+

29− -> Result.Result w Error.Error DT.VariantDict

29+

30+patternMatches :: Module.Interfaces -> Module.Canonical -> Result wrn DT.VariantDict

30patternMatches interfaces (Module.Module name _ info) =

31patternMatches interfaces (Module.Module name _ info) =

31 let

32 let

32 tagDict =

33 tagDict =

@@ -118,10 +119,7 @@ lookupOtherTags (Var.Canonical home name) tagDict =

118-- CHECK EXPRESSIONS

119-- CHECK EXPRESSIONS

119

120

121

121−checkExpression

122+checkExpression :: TagDict -> Canonical.Expr -> Result wrn ()

122− :: TagDict

123− -> Canonical.Expr

124− -> Result.Result w Error.Error ()

125checkExpression tagDict (A.A region expression) =

123checkExpression tagDict (A.A region expression) =

126 let

124 let

127 go =

125 go =

@@ -206,12 +204,7 @@ checkExpression tagDict (A.A region expression) =

206-- CHECK PATTERNS

204-- CHECK PATTERNS

207

205

208

206

209−checkPatterns

207+checkPatterns :: TagDict -> Region.Region -> Error.Origin -> [Pattern.Canonical] -> Result wrn ()

210− :: TagDict

211− -> Region.Region

212− -> Error.Origin

213− -> [Pattern.Canonical]

214− -> Result.Result w Error.Error ()

215checkPatterns tagDict region origin patterns =

208checkPatterns tagDict region origin patterns =

216 checkPatternsHelp tagDict region origin [Anything] patterns

209 checkPatternsHelp tagDict region origin [Anything] patterns

217

210

@@ -222,7 +215,7 @@ checkPatternsHelp

222 -> Error.Origin

215 -> Error.Origin

223 -> [Pattern]

216 -> [Pattern]

224 -> [Pattern.Canonical]

217 -> [Pattern.Canonical]

225− -> Result.Result w Error.Error ()

218+ -> Result wrn ()

226checkPatternsHelp tagDict region origin unhandled patterns =

219checkPatternsHelp tagDict region origin unhandled patterns =

227 case (unhandled, patterns) of

220 case (unhandled, patterns) of

228 ([], []) ->

221 ([], []) ->

@@ -241,7 +234,7 @@ filterPatterns

241 -> Region.Region

234 -> Region.Region

242 -> Pattern.Canonical

235 -> Pattern.Canonical

243 -> [Pattern]

236 -> [Pattern]

244− -> Result.Result w Error.Error [Pattern]

237+ -> Result wrn [Pattern]

245filterPatterns tagDict region pattern unhandled =

238filterPatterns tagDict region pattern unhandled =

246 let

239 let

247 nitPattern =

240 nitPattern =

src/Nitpick/TopLevelTypes.hs+8−7

@@ -21,13 +21,14 @@ import qualified Reporting.Warning as Warning

24+type Result =

25+ Result.Result () Warning.Warning Error.Error

26+

27+

24-- CHECK TOP LEVEL TYPES

28-- CHECK TOP LEVEL TYPES

27−topLevelTypes

28− :: Map.Map String Type.Canonical

31+topLevelTypes :: Map.Map String Type.Canonical -> Decl.Valid -> Result ()

29− -> Decl.Valid

30− -> Result.Result Warning.Warning Error.Error ()

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

32topLevelTypes typeEnv (Decl.Decls defs _ _ _) =

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

33 do maybeMainRegion <- foldM (warnMissingAnnotation typeEnv) Nothing defs

33 maybe (return ()) (checkMainType typeEnv) maybeMainRegion

34 maybe (return ()) (checkMainType typeEnv) maybeMainRegion

@@ -41,12 +42,12 @@ warnMissingAnnotation

41 :: Map.Map String Type.Canonical

42 :: Map.Map String Type.Canonical

42 -> Maybe R.Region

43 -> Maybe R.Region

43 -> A.Commented Valid.Def

44 -> A.Commented Valid.Def

44− -> Result.Result Warning.Warning Error.Error (Maybe R.Region)

45+ -> Result (Maybe R.Region)

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

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

46 case def of

47 case def of

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

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

48 do when (Maybe.isNothing maybeType) $

49 do when (Maybe.isNothing maybeType) $

49− Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name))

50+ Result.warn region (Warning.MissingTypeAnnotation name (typeEnv ! name)) ()

51 return (if name == "main" then Just region else maybeMainRegion)

52 return (if name == "main" then Just region else maybeMainRegion)

@@ -58,7 +59,7 @@ warnMissingAnnotation typeEnv maybeMainRegion (A.A (region,_) def) =

58-- CHECK MAIN TYPE

59-- CHECK MAIN TYPE

61−checkMainType :: Map.Map String Type.Canonical -> R.Region -> Result.Result w Error.Error ()

62+checkMainType :: Map.Map String Type.Canonical -> R.Region -> Result ()

62checkMainType typeEnv region =

63checkMainType typeEnv region =

63 let

64 let

64 tipe =

65 tipe =

src/Parse/Parse.hs+4−12

@@ -20,11 +20,7 @@ import qualified Validate

23−program

24− :: Package.Name

25− -> OpTable

26− -> String

27− -> Result.Result wrn Error.Error Module.Valid

23+program :: Package.Name -> OpTable -> String -> Validate.Result wrn Module.Valid

28program pkgName table src =

24program pkgName table src =

29 do modul <-

25 do modul <-

30 parseWithTable table src (programParser pkgName)

26 parseWithTable table src (programParser pkgName)

@@ -72,7 +68,7 @@ freshDef =

72-- RUN PARSERS

68-- RUN PARSERS

75−parse :: String -> IParser a -> Result.Result wrn Error.Error a

71+parse :: String -> IParser a -> Validate.Result wrn a

76parse source parser =

72parse source parser =

77 case iParse parser source of

73 case iParse parser source of

78 Right result ->

74 Right result ->

@@ -85,11 +81,7 @@ parse source parser =

85 Result.throw (R.Region pos pos) (Error.Parse msgs)

81 Result.throw (R.Region pos pos) (Error.Parse msgs)

88−parseWithTable

84+parseWithTable :: OpTable -> String -> IParser a -> Validate.Result wrn a

89− :: OpTable

90− -> String

91− -> IParser a

92− -> Result.Result wrn Error.Error a

93parseWithTable table source parser =

85parseWithTable table source parser =

94 do infixInfoList <- parse source parseFixities

86 do infixInfoList <- parse source parseFixities

@@ -107,7 +99,7 @@ parseWithTable table source parser =

107makeInfixTable

99makeInfixTable

108 :: Map.Map String (Int, Decl.Assoc)

100 :: Map.Map String (Int, Decl.Assoc)

109 -> [(String, InfixInfo)]

101 -> [(String, InfixInfo)]

110− -> Result.Result wrn Error.Error (Map.Map String (Int, Decl.Assoc))

102+ -> Validate.Result wrn (Map.Map String (Int, Decl.Assoc))

111makeInfixTable table newInfo =

103makeInfixTable table newInfo =

112 let add (op, info) dict =

104 let add (op, info) dict =

113 Map.insertWith (++) op [info] dict

105 Map.insertWith (++) op [info] dict

src/Reporting/Bag.hsnew file+101

@@ -0,0 +1,101 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Reporting.Bag

3+ ( Bag

4+ , empty, singleton, cons, append, map

5+ , toList, fromList

6+ )

7+ where

10+import Prelude hiding (map)

11+

12+

13+

14+-- BAGS

15+

16+

17+data Bag a

18+ = Empty

19+ | One a

20+ | Two (Bag a) (Bag a)

21+ | Many [a]

22+

23+

24+empty :: Bag a

25+empty =

26+ Empty

27+

28+

29+singleton :: a -> Bag a

30+singleton =

31+ One

32+

33+

34+cons :: a -> Bag a -> Bag a

35+cons x bag =

36+ case bag of

37+ Empty ->

38+ One x

39+

40+ _ ->

41+ Two (One x) bag

42+

43+

44+append :: Bag a -> Bag a -> Bag a

45+append left right =

46+ case (left, right) of

47+ (other, Empty) ->

48+ other

49+

50+ (Empty, other) ->

51+ other

52+

53+ (_, _) ->

54+ Two left right

55+

56+

57+map :: (a -> b) -> Bag a -> Bag b

58+map func bag =

59+ case bag of

60+ Empty ->

61+ Empty

62+

63+ One x ->

64+ One (func x)

65+

66+ Two left right ->

67+ Two (map func left) (map func right)

68+

69+ Many xs ->

70+ Many (fmap func xs)

71+

72+

73+

74+-- LIST CONVERSIONS

75+

76+

77+fromList :: [a] -> Bag a

78+fromList =

79+ Many

80+

81+

82+toList :: (a -> b) -> Bag a -> [b]

83+toList func bag =

84+ toListHelp func bag []

85+

86+

87+toListHelp :: (a -> b) -> Bag a -> [b] -> [b]

88+toListHelp func bag list =

89+ case bag of

90+ Empty ->

91+ list

92+

93+ One x ->

94+ func x : list

95+

96+ Two left right ->

97+ toListHelp func left (toListHelp func right list)

98+

99+ Many xs ->

100+ foldr (\x newList -> func x : newList) list xs

101+

src/Reporting/Result.hs+97−57

@@ -1,45 +1,69 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Reporting.Result where

2module Reporting.Result where

3−import Control.Applicative ((<|>))

4−import qualified Control.Monad as M

5import Control.Monad.Except (Except, runExcept)

4import Control.Monad.Except (Except, runExcept)

7import qualified Reporting.Annotation as A

6import qualified Reporting.Annotation as A

7+import qualified Reporting.Bag as Bag

8import qualified Reporting.Region as R

9−import qualified Reporting.Render.Type as RenderType

12−-- TASK

14−data Result warning error result =

12+-- RESULTS

15− Result

16− (Maybe RenderType.Localizer, [A.Located warning])

17− (RawResult [A.Located error] result)

20−data RawResult e a

15+data Result info warning error result =

21− = Ok a

16+ Result

22− | Err e

17+ { _info :: info

18+ , _warnings :: LBag warning

19+ , _answer :: Answer (LBag error) result

20+ }

25−-- HELPERS

23+data Answer e a = Ok a | Err e

25+

26+type LBag a =

27+ Bag.Bag (A.Located a)

28+

29+

30+data One a = None | One a

31+

32+

33+

34+-- RESULT HELPERS

35+

36+

27−ok :: a -> Result w e a

37+ok :: (Monoid i) => a -> Result i w e a

28ok value =

38ok value =

29− Result (Nothing, []) (Ok value)

39+ Result mempty Bag.empty (Ok value)

32−throw :: R.Region -> e -> Result w e a

42+throw :: (Monoid i) => R.Region -> e -> Result i w e a

33throw region err =

43throw region err =

34− Result (Nothing, []) (Err [A.A region err])

44+ Result mempty Bag.empty (Err (Bag.singleton (A.A region err)))

37−throwMany :: [A.Located e] -> Result w e a

47+throwMany :: (Monoid i) => [A.Located e] -> Result i w e a

38throwMany errors =

48throwMany errors =

39− Result (Nothing, []) (Err errors)

49+ Result mempty Bag.empty (Err (Bag.fromList errors))

50+

51+

52+accumulate :: (Monoid i) => i -> a -> Result i w e a

53+accumulate info value =

54+ Result info Bag.empty (Ok value)

55+

57+warn :: (Monoid i) => R.Region -> w -> a -> Result i w e a

58+warn region warning a =

59+ Result mempty (Bag.singleton (A.A region warning)) (Ok a)

61+

62+

63+-- EXTRACTION HELPERS

64+

65+

42−from :: (e -> e') -> Except [A.Located e] a -> Result w e' a

66+from :: (Monoid i) => (e -> e') -> Except [A.Located e] a -> Result i w e' a

43from f except =

67from f except =

44 case runExcept except of

68 case runExcept except of

45 Right answer ->

69 Right answer ->

@@ -49,66 +73,68 @@ from f except =

49 throwMany (map (A.map f) errors)

73 throwMany (map (A.map f) errors)

52−mapError :: (e -> e') -> Result w e a -> Result w e' a

76+mapError :: (e -> e') -> Result i w e a -> Result i w e' a

53−mapError f (Result warnings rawResult) =

77+mapError f (Result info warnings rawResult) =

54− Result warnings $

78+ Result info warnings $

55 case rawResult of

79 case rawResult of

56 Ok v ->

80 Ok v ->

57 Ok v

81 Ok v

59 Err msgs ->

83 Err msgs ->

60− Err (map (A.map f) msgs)

84+ Err (Bag.map (A.map f) msgs)

63−warn :: R.Region -> w -> Result w e ()

87+format :: (Monoid i) => (e -> e') -> Result () w e a -> Result i w e' a

64−warn region warning =

88+format func (Result _ warnings answer) =

65− Result (Nothing, [A.A region warning]) (Ok ())

89+ mapError func (Result mempty warnings answer)

68−addWarnings :: [A.Located w] -> Result w e a -> Result w e a

92+answerToEither :: (A.Located e -> e') -> (a -> a') -> Answer (LBag e) a -> Either [e'] a'

69−addWarnings newWarnings (Result (dealiaser, warnings) rawResult) =

93+answerToEither onErr onOk answer =

70− Result (dealiaser, newWarnings ++ warnings) rawResult

94+ case answer of

95+ Ok value ->

96+ Right (onOk value)

98+ Err errors ->

99+ Left (Bag.toList onErr errors)

100

73−addDealiaser :: RenderType.Localizer -> Result w e a -> Result w e a

74−addDealiaser dealiaser (Result (_, warnings) rawResult) =

75− Result (Just dealiaser, warnings) rawResult

101

102+oneToValue :: b -> (a -> b) -> One a -> b

103+oneToValue fallback onOne one =

104+ case one of

105+ None ->

106+ fallback

107

78−destruct :: (e -> b) -> (a -> b) -> RawResult e a -> b

108+ One value ->

79−destruct errFunc okFunc rawResult =

109+ onOne value

80− case rawResult of

81− Ok answer ->

82− okFunc answer

110

84− Err errors ->

85− errFunc errors

111

112

88-- EXTRA FANCY HELPERS

113-- EXTRA FANCY HELPERS

114

115+

90−instance M.Functor (Result w e) where

116+instance Functor (Result i w e) where

91− fmap func (Result warnings rawResult) =

117+ fmap func (Result info warnings rawResult) =

92 case rawResult of

118 case rawResult of

93 Ok a ->

119 Ok a ->

94− Result warnings (Ok (func a))

120+ Result info warnings (Ok (func a))

121

96 Err msgs ->

122 Err msgs ->

97− Result warnings (Err msgs)

123+ Result info warnings (Err msgs)

124

125

100−instance Applicative (Result w e) where

126+instance (Monoid i) => Applicative (Result i w e) where

101 pure value =

127 pure value =

102 ok value

128 ok value

103

129

104− (<*>) (Result context resultFunc) (Result context' resultVal) =

130+ (<*>) (Result info warnings resultFunc) (Result info' warnings' resultVal) =

105− Result (merge context context') $

131+ Result (mappend info info') (Bag.append warnings warnings') $

106 case (resultFunc, resultVal) of

132 case (resultFunc, resultVal) of

107 (Ok func, Ok val) ->

133 (Ok func, Ok val) ->

108 Ok (func val)

134 Ok (func val)

109

135

110 (Err msgs, Err msgs') ->

136 (Err msgs, Err msgs') ->

111− Err (msgs ++ msgs')

137+ Err (Bag.append msgs msgs')

112

138

113 (Err msgs, _) ->

139 (Err msgs, _) ->

114 Err msgs

140 Err msgs

@@ -117,23 +143,37 @@ instance Applicative (Result w e) where

117 Err msgs

143 Err msgs

118

144

119

145

120−instance M.Monad (Result w e) where

146+instance (Monoid i) => Monad (Result i w e) where

121 return value =

147 return value =

122 ok value

148 ok value

123

149

124− (>>=) (Result context rawResult) callback =

150+ (>>=) (Result info warnings rawResult) callback =

125 case rawResult of

151 case rawResult of

126 Err msg ->

152 Err msg ->

127− Result context (Err msg)

153+ Result info warnings (Err msg)

128

154

129 Ok value ->

155 Ok value ->

156+ let

157+ (Result info' warnings' rawResult') =

130− let (Result context' rawResult') = callback value

158+ callback value

131 in

159 in

160+ Result

161+ (mappend info info')

162+ (Bag.append warnings warnings')

132− Result (merge context context') rawResult'

163+ rawResult'

164+

165+

166+instance Monoid (One a) where

167+ mempty =

168+ None

169+

170+ mappend left right =

171+ case (left, right) of

172+ (other, None) ->

173+ other

133

174

175+ (None, other) ->

176+ other

134

177

135−merge :: (Maybe a, [b]) -> (Maybe a, [b]) -> (Maybe a, [b])

178+ (One _, One _) ->

136−merge (dealiaser, warnings) (dealiaser', warnings') =

179+ error "There should only be one!"

137− ( dealiaser <|> dealiaser'

138− , warnings ++ warnings'

139− )

src/Validate.hs+32−43

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

1{-# OPTIONS_GHC -Wall #-}

2−module Validate (module') where

2+module Validate (Result, module') where

4import Prelude hiding (init)

5import Control.Monad (foldM, when)

@@ -28,10 +28,15 @@ import qualified Reporting.Result as Result

31+type Result warning a =

32+ Result.Result () warning Error.Error a

33+

34+

35+

31-- MODULES

36-- MODULES

34−module' :: Module.Source -> Result.Result wrn Error.Error Module.Valid

39+module' :: Module.Source -> Result wrn Module.Valid

35module' (Module.Module name path info) =

40module' (Module.Module name path info) =

36 let

41 let

37 (ModuleName.Canonical pkgName _) =

42 (ModuleName.Canonical pkgName _) =

@@ -74,7 +79,7 @@ validateEffects

74 -> Module.SourceSettings

79 -> Module.SourceSettings

75 -> [A.Commented Effects.ForeignRaw]

80 -> [A.Commented Effects.ForeignRaw]

76 -> [A.Commented Valid.Def]

81 -> [A.Commented Valid.Def]

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

82+ -> Result wrn Effects.Raw

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

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

79 case tag of

84 case tag of

80 Module.Normal ->

85 Module.Normal ->

@@ -100,10 +105,7 @@ validateEffects tag settings@(A.A _ pairs) foreigns validDefs =

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

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

101

106

102

107

103−noSettings

104− :: Error.Error

105− -> Module.SourceSettings

108+noSettings :: Error.Error -> Module.SourceSettings -> Result wrn ()

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

107noSettings errorMsg (A.A region settings) =

109noSettings errorMsg (A.A region settings) =

108 case settings of

110 case settings of

109 [] ->

111 [] ->

@@ -113,7 +115,7 @@ noSettings errorMsg (A.A region settings) =

113 Result.throw region errorMsg

115 Result.throw region errorMsg

114

116

115

117

116−noForeigns :: [A.Commented Effects.ForeignRaw] -> Result.Result wrn Error.Error ()

118+noForeigns :: [A.Commented Effects.ForeignRaw] -> Result wrn ()

117noForeigns foreigns =

119noForeigns foreigns =

118 case foreigns of

120 case foreigns of

119 [] ->

121 [] ->

@@ -130,7 +132,7 @@ noForeigns foreigns =

130toManagerType

132toManagerType

131 :: R.Region

133 :: R.Region

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

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

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

135+ -> Result wrn Effects.ManagerType

134toManagerType tagRegion settingsDict =

136toManagerType tagRegion settingsDict =

135 let

137 let

136 toErrors name entries =

138 toErrors name entries =

@@ -167,7 +169,7 @@ toManagerType tagRegion settingsDict =

167extractOne

169extractOne

168 :: String

170 :: String

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

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

170− -> Result.Result w Error.Error (Maybe (A.Located String))

172+ -> Result wrn (Maybe (A.Located String))

171extractOne name settingsDict =

173extractOne name settingsDict =

172 case Map.lookup name settingsDict of

174 case Map.lookup name settingsDict of

173 Nothing ->

175 Nothing ->

@@ -191,7 +193,7 @@ checkManager

191 :: R.Region

193 :: R.Region

192 -> Effects.ManagerType

194 -> Effects.ManagerType

193 -> [A.Commented Valid.Def]

195 -> [A.Commented Valid.Def]

194− -> Result.Result w Error.Error (R.Region, R.Region, R.Region)

196+ -> Result wrn (R.Region, R.Region, R.Region)

195checkManager tagRegion managerType validDefs =

197checkManager tagRegion managerType validDefs =

196 let

198 let

197 regionDict =

199 regionDict =

@@ -218,7 +220,7 @@ requireMaps

218 :: R.Region

220 :: R.Region

219 -> Map.Map String R.Region

221 -> Map.Map String R.Region

220 -> Effects.ManagerType

222 -> Effects.ManagerType

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

223+ -> Result wrn ()

222requireMaps tagRegion regionDict managerType =

224requireMaps tagRegion regionDict managerType =

223 let

225 let

224 check name =

226 check name =

@@ -236,11 +238,7 @@ requireMaps tagRegion regionDict managerType =

236 check "cmdMap" <* check "subMap"

238 check "cmdMap" <* check "subMap"

237

239

238

240

239−requireRegion

240− :: R.Region

241− -> Map.Map String R.Region

241+requireRegion :: R.Region -> Map.Map String R.Region -> String -> Result wrn R.Region

242− -> String

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

244requireRegion tagRegion regionDict name =

242requireRegion tagRegion regionDict name =

245 case Map.lookup name regionDict of

243 case Map.lookup name regionDict of

246 Just region ->

244 Just region ->

@@ -254,7 +252,7 @@ requireRegion tagRegion regionDict name =

254-- COLLAPSE COMMENTS

252-- COLLAPSE COMMENTS

255

253

256

254

257−collapseComments :: [D.CommentOr (A.Located a)] -> Result.Result wrn Error.Error [A.Commented a]

255+collapseComments :: [D.CommentOr (A.Located a)] -> Result wrn [A.Commented a]

258collapseComments listWithComments =

256collapseComments listWithComments =

259 case listWithComments of

257 case listWithComments of

260 [] ->

258 [] ->

@@ -284,7 +282,7 @@ collapseComments listWithComments =

284-- VALIDATE STRUCTURED SOURCE

282-- VALIDATE STRUCTURED SOURCE

285

283

286

284

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

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

288validateDecls sourceDecls =

286validateDecls sourceDecls =

289 do rawDecls <- collapseComments sourceDecls

287 do rawDecls <- collapseComments sourceDecls

290

288

@@ -309,7 +307,7 @@ data ValidStuff =

309 }

307 }

310

308

311

309

312−validateRawDecls :: [A.Commented D.Raw] -> Result.Result wrn Error.Error ValidStuff

310+validateRawDecls :: [A.Commented D.Raw] -> Result wrn ValidStuff

313validateRawDecls commentedDecls =

311validateRawDecls commentedDecls =

314 vrdHelp commentedDecls [] (D.Decls [] [] [] [])

312 vrdHelp commentedDecls [] (D.Decls [] [] [] [])

315

313

@@ -318,7 +316,7 @@ vrdHelp

318 :: [A.Commented D.Raw]

316 :: [A.Commented D.Raw]

319 -> [A.Commented Effects.ForeignRaw]

317 -> [A.Commented Effects.ForeignRaw]

320 -> D.Valid

318 -> D.Valid

321− -> Result.Result wrn Error.Error ValidStuff

319+ -> Result wrn ValidStuff

322vrdHelp commentedDecls foreigns structure =

320vrdHelp commentedDecls foreigns structure =

323 case commentedDecls of

321 case commentedDecls of

324 [] ->

322 [] ->

@@ -347,7 +345,7 @@ vrdDefHelp

347 -> A.Commented Source.Def'

345 -> A.Commented Source.Def'

348 -> [A.Commented Effects.ForeignRaw]

346 -> [A.Commented Effects.ForeignRaw]

349 -> D.Valid

347 -> D.Valid

350− -> Result.Result wrn Error.Error ValidStuff

348+ -> Result wrn ValidStuff

351vrdDefHelp remainingDecls (A.A ann def) foreigns structure =

349vrdDefHelp remainingDecls (A.A ann def) foreigns structure =

352 let

350 let

353 addDef validDef (ValidStuff finalForeigns struct) =

351 addDef validDef (ValidStuff finalForeigns struct) =

@@ -376,7 +374,7 @@ vrdDefHelp remainingDecls (A.A ann def) foreigns structure =

376-- VALIDATE DEFINITIONS

374-- VALIDATE DEFINITIONS

377

375

378

376

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

377+definitions :: [Source.Def] -> Result wrn [Valid.Def]

380definitions sourceDefs =

378definitions sourceDefs =

381 do validDefs <- definitionsHelp sourceDefs

379 do validDefs <- definitionsHelp sourceDefs

382

380

@@ -388,7 +386,7 @@ definitions sourceDefs =

388 return validDefs

386 return validDefs

389

387

390

388

391−definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]

389+definitionsHelp :: [Source.Def] -> Result wrn [Valid.Def]

392definitionsHelp sourceDefs =

390definitionsHelp sourceDefs =

393 case sourceDefs of

391 case sourceDefs of

394 [] ->

392 [] ->

@@ -415,14 +413,14 @@ validateDef

415 :: Pattern.Raw

413 :: Pattern.Raw

416 -> Source.Expr

414 -> Source.Expr

417 -> Maybe Type.Raw

415 -> Maybe Type.Raw

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

416+ -> Result wrn Valid.Def

419validateDef pat expr maybeType =

417validateDef pat expr maybeType =

420 do validExpr <- expression expr

418 do validExpr <- expression expr

421 validateDefPattern pat validExpr

419 validateDefPattern pat validExpr

422 return $ Valid.Def pat validExpr maybeType

420 return $ Valid.Def pat validExpr maybeType

423

421

424

422

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

423+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result wrn ()

426validateDefPattern pattern body =

424validateDefPattern pattern body =

427 case fst (Expr.collectLambdas body) of

425 case fst (Expr.collectLambdas body) of

428 [] ->

426 [] ->

@@ -445,7 +443,7 @@ validateDefPattern pattern body =

445-- VALIDATE EXPRESSIONS

443-- VALIDATE EXPRESSIONS

446

444

447

445

448−expression :: Source.Expr -> Result.Result wrn Error.Error Valid.Expr

446+expression :: Source.Expr -> Result wrn Valid.Expr

449expression (A.A ann sourceExpression) =

447expression (A.A ann sourceExpression) =

450 A.A ann <$>

448 A.A ann <$>

451 case sourceExpression of

449 case sourceExpression of

@@ -538,14 +536,12 @@ expression (A.A ann sourceExpression) =

538 return (GLShader uid src gltipe)

536 return (GLShader uid src gltipe)

539

537

540

538

541−second :: (a, Source.Expr) -> Result.Result wrn Error.Error (a, Valid.Expr)

539+second :: (a, Source.Expr) -> Result wrn (a, Valid.Expr)

542second (value, expr) =

540second (value, expr) =

543 (,) value <$> expression expr

541 (,) value <$> expression expr

544

542

545

543

546−both

547− :: (Source.Expr, Source.Expr)

548− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)

544+both :: (Source.Expr, Source.Expr) -> Result wrn (Valid.Expr, Valid.Expr)

549both (expr1, expr2) =

545both (expr1, expr2) =

550 (,) <$> expression expr1 <*> expression expr2

546 (,) <$> expression expr1 <*> expression expr2

551

547

@@ -554,7 +550,7 @@ both (expr1, expr2) =

554-- VALIDATE PATTERNS

550-- VALIDATE PATTERNS

555

551

556

552

557−validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw

553+validatePattern :: Pattern.Raw -> Result wrn Pattern.Raw

558validatePattern pattern =

554validatePattern pattern =

559 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)

555 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)

560 return pattern

556 return pattern

@@ -564,7 +560,7 @@ validatePattern pattern =

564-- DETECT DUPLICATES

560-- DETECT DUPLICATES

565

561

566

562

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

563+checkDuplicates :: ValidStuff -> Result wrn ()

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

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

569 let

565 let

570 -- SIMPLE NAMES

566 -- SIMPLE NAMES

@@ -604,10 +600,7 @@ checkDuplicates (ValidStuff foreigns (D.Decls defs unions aliases _)) =

604 ]

600 ]

605

601

606

602

607−detectDuplicates

603+detectDuplicates :: (String -> Error.Error) -> [A.Located String] -> Result wrn ()

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

609− -> [A.Located String]

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

611detectDuplicates tag names =

604detectDuplicates tag names =

612 let

605 let

613 add (A.A region name) dict =

606 add (A.A region name) dict =

@@ -631,9 +624,7 @@ detectDuplicates tag names =

631-- UNBOUND TYPE VARIABLES

624-- UNBOUND TYPE VARIABLES

632

625

633

626

634−checkTypeVarsInUnion

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

627+checkTypeVarsInUnion :: A.Commented (D.Union Type.Raw) -> Result wrn ()

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

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

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

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

629 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of

639 (_, []) ->

630 (_, []) ->

@@ -644,9 +635,7 @@ checkTypeVarsInUnion (A.A (region,_) (D.Type name boundVars ctors)) =

644 (Error.UnboundTypeVarsInUnion name boundVars unbound)

635 (Error.UnboundTypeVarsInUnion name boundVars unbound)

645

636

646

637

647−checkTypeVarsInAlias

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

638+checkTypeVarsInAlias :: A.Commented (D.Alias Type.Raw) -> Result wrn ()

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

650checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =

639checkTypeVarsInAlias (A.A (region,_) (D.Type name boundVars tipe)) =

651 case diff boundVars (freeVars tipe) of

640 case diff boundVars (freeVars tipe) of

652 ([], []) ->

641 ([], []) ->