3e8eb7b · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Just focus on effect modules, ignore foreign effects for now

3e8eb7bEvan Czaplicki11 years ago

src/AST/Declaration.hs+1−34

compare with master

unifiedsplit

@@ -26,12 +26,7 @@ data Decl def tipe expr

28type Source =

29− CommentOr (A.Located SourceOrDefine)

29+ CommentOr (A.Located Source')

30−

31−

32−data SourceOrDefine

33− = Source Source'

34− | Define EffectType [CommentOr (A.Located Source.Effect)]

37type Source' =

32type Source' =

@@ -60,34 +55,6 @@ data CommentOr a

63−-- EFFECTS

64−

65−

66−data EffectType

67− = Cmd

68− | Sub

69− | ForeignCmd

70− | ForeignSub

71− deriving (Eq, Ord)

72−

73−

74−effectTypeToString :: EffectType -> String

75−effectTypeToString tipe =

76− case tipe of

77− Cmd ->

78− "commands"

79−

80− Sub ->

81− "subscriptions"

82−

83− ForeignCmd ->

84− "foreign commands"

85−

86− ForeignSub ->

87− "foreign subscriptions"

88−

89−

90−

91-- INFIX STUFF

58-- INFIX STUFF

src/AST/Expression/Source.hs−6

@@ -29,9 +29,3 @@ data Def'

29 = Definition Pattern.Raw Expr

30 | Annotation String Type.Raw

32−

33−data Effect

34− = Def Pattern.Raw Expr

35− | Type String Type.Raw

36− | With String Expr

37−

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

@@ -5,7 +5,6 @@ import qualified AST.Expression.General as General

5import qualified AST.Pattern as Pattern

6import qualified AST.Type as Type

7import qualified AST.Variable as Var

8−import qualified Reporting.Annotation as A

9import qualified Reporting.Region as R

8import qualified Reporting.Region as R

@@ -25,17 +24,7 @@ data Def

25 = Definition Pattern.Raw Expr (Maybe Type.Raw)

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

28−data Effects

27+getPattern :: Def -> Pattern.Raw

29− = None

28+getPattern (Definition pattern _ _) =

30− | Effects [A.Commented Def] [A.Commented Def]

29+ pattern

31− | ForeignEffects [A.Commented ForeignCmd] [A.Commented ForeignSub]

32−

33−

34−data ForeignCmd

35− = Cmd String Type.Raw

36−

37−

38−data ForeignSub

39− = Sub String Type.Raw

40− | SubWith String Expr

src/AST/Module.hs+2−13

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

8 , UserImport, DefaultImport, ImportMethod(..)

10− , Effects(..)

11 , Types

10 , Types

12 , Aliases

11 , Aliases

13 , Unions, UnionInfo, CanonicalUnion

12 , Unions, UnionInfo, CanonicalUnion

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

22import qualified AST.Declaration as Decl

21import qualified AST.Declaration as Decl

23import qualified AST.Expression.Canonical as Canonical

22import qualified AST.Expression.Canonical as Canonical

24import qualified AST.Expression.Optimized as Optimized

23import qualified AST.Expression.Optimized as Optimized

25−import qualified AST.Expression.Valid as Valid

26import qualified AST.Module.Name as Name

24import qualified AST.Module.Name as Name

27import qualified AST.Type as Type

25import qualified AST.Type as Type

28import qualified AST.Variable as Var

26import qualified AST.Variable as Var

@@ -62,8 +60,8 @@ data Module phase =

64data Tag

62data Tag

65− = None

63+ = Normal

66− | Effect R.Region

64+ | Effect (Maybe (A.Located String)) (Maybe (A.Located String))

67 | Foreign R.Region

65 | Foreign R.Region

@@ -90,7 +88,6 @@ data ValidInfo =

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

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

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

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

92 , validDecls :: [Decl.Valid]

90 , validDecls :: [Decl.Valid]

93− , validEffects :: Valid.Effects

94 }

91 }

@@ -133,7 +130,6 @@ data Info expr =

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

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

134 , aliases :: Aliases

131 , aliases :: Aliases

135 , unions :: Unions

132 , unions :: Unions

136− , effects :: Effects

137 }

133 }

138

134

139

135

@@ -157,13 +153,6 @@ type CanonicalUnion =

157 ( Var.Canonical, UnionInfo Var.Canonical )

153 ( Var.Canonical, UnionInfo Var.Canonical )

158

154

159

155

160−data Effects =

161− Effects

162− { cmds :: [String]

163− , subs :: [String]

164− }

165−

166−

167

156

168-- INTERFACES

157-- INTERFACES

169

158

src/Canonicalize.hs+28−22

@@ -46,7 +46,7 @@ module'

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

47module' canonicalImports interfaces modul =

48 let

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

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

50 Module.info modul

52 importDict =

@@ -61,7 +61,7 @@ module' canonicalImports interfaces modul =

61 (Result.Result uses rawResults) =

62 (,)

63 <$> canonicalDeclsResult

64− <*> resolveExports (concatMap declToValue decls) exports

64+ <*> resolveExports (concatMap declToValues decls) exports

65 in

66 case rawResults of

67 Result.Err msgs ->

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

100 , Module.fixities = fixities

101 , Module.aliases = aliases

102 , Module.unions = unions

103− , Module.effects = error "TODO"

104 }

103 }

105 }

104 }

106

105

@@ -249,6 +248,31 @@ allUnique statedExports =

249

248

250

249

251

250

251+-- CONVERSIONS

252+

253+

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

255+declToValues (A.A _ decl) =

256+ case decl of

257+ D.Def def ->

258+ map Var.Value (P.boundVarList (Valid.getPattern def))

259+

260+ D.Union name _tvs ctors ->

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

262+

263+ D.Alias name _ tipe ->

264+ case tipe of

265+ A.A _ (Type.RRecord _ Nothing) ->

266+ [ Var.Alias name, Var.Value name ]

267+

268+ _ ->

269+ [ Var.Alias name ]

270+

271+ _ ->

272+ []

273+

274+

275+

252-- GROUPING VALUES

276-- GROUPING VALUES

253

277

254

278

@@ -293,26 +317,8 @@ splitLocatedValue (A.A region value) =

293 (Nothing, Nothing, Just (A.A region (name, listing)))

317 (Nothing, Nothing, Just (A.A region (name, listing)))

294

318

295

319

296−-- DECLARATIONS

297−

298−declToValue :: D.Valid -> [Var.Value]

299−declToValue (A.A _ decl) =

300− case decl of

301− D.Def (Valid.Definition pattern _ _) ->

302− map Var.Value (P.boundVarList pattern)

303−

304− D.Union name _tvs ctors ->

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

306−

307− D.Alias name _ tipe ->

308− case tipe of

309− A.A _ (Type.RRecord _ Nothing) ->

310− [ Var.Alias name, Var.Value name ]

311

320

312− _ ->

321+-- DECLARATIONS

313− [ Var.Alias name ]

314−

315− _ -> []

316

322

317

323

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

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

src/Canonicalize/Setup.hs+3−3

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

32 -> Result.ResultErr Env.Environment

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

34 let

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

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

36 info

38 allImports =

@@ -331,9 +331,9 @@ declToPatches moduleName (A.A (region,_) decl) =

331 Env.Pattern name (Var.fromModule moduleName name, length args)

332 in

333 case decl of

334− D.Def (Valid.Definition pattern _ _) ->

334+ D.Def def ->

335 ( Nothing

336− , map (topLevel Env.Value) (P.boundVarList pattern)

336+ , map (topLevel Env.Value) (P.boundVarList (Valid.getPattern def))

337 )

338

339 D.Union name _ ctors ->

src/Compile.hs+4−4

@@ -43,19 +43,19 @@ compile packageName canonicalImports interfaces source =

44 -- One last round of checks

45 Result.mapError Error.Type $

46− Nitpick.topLevelTypes types (Module.body validModule)

46+ Nitpick.topLevelTypes types (Module.validDecls (Module.info validModule))

48 tagDict <-

49 Result.mapError Error.Pattern $

50 Nitpick.patternMatches interfaces canonicalModule

52 -- Add the real list of types

53− let body =

53+ let canonicalInfo =

54− (Module.body canonicalModule) { Module.types = types }

54+ (Module.info canonicalModule) { Module.types = types }

56 -- Do some basic optimizations

57 let optModule =

58− Optimize.optimize tagDict (canonicalModule { Module.body = body })

58+ Optimize.optimize tagDict (canonicalModule { Module.info = canonicalInfo })

60 return optModule

src/Elm/Compiler.hs+6−5

@@ -107,19 +107,20 @@ docsGen

107 :: Bool

108 -> Module.Optimized

109 -> Result.Result w Error.Error (Maybe Docs.Documentation)

110−docsGen isExposed modul =

110+docsGen isExposed (Module.Module _ name _ info) =

111 if not isExposed then

112 Result.ok Nothing

113+

113 else

114 else

114 let

115 let

115 getChecked =

116 getChecked =

116− Docs.check (Module.exports modul) (Module.docs modul)

117+ Docs.check (Module.exports info) (Module.docs info)

117

118

118− name =

119+ publicName =

119− PublicModule.Name (ModuleName._module (Module.name modul))

120+ PublicModule.Name (ModuleName._module name)

120

121

121 toDocs checked =

122 toDocs checked =

122− Docs.fromCheckedDocs name checked

123+ Docs.fromCheckedDocs publicName checked

123 in

124 in

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

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

125

126

src/Generate/JavaScript.hs+4−7

@@ -17,18 +17,15 @@ import qualified Generate.JavaScript.Variable as Var

19generate :: Module.Optimized -> String

20−generate module_ =

20+generate (Module.Module _ (ModuleName.Canonical _ name) _ info) =

21 let

22− (ModuleName.Canonical _ name) =

23− Module.name module_

24−

25 body =

22 body =

26 concat

23 concat

27 [ useStrict

24 [ useStrict

28 , checkForCachedVersion name

25 , checkForCachedVersion name

29− , imports (Module.imports module_)

26+ , imports (Module.imports info)

30− , definitions (Module.program (Module.body module_))

27+ , definitions (Module.program info)

31− , exports name (Module.exports module_)

28+ , exports name (Module.exports info)

32 ]

29 ]

34 make =

31 make =

src/Nitpick/PatternMatches.hs+5−6

@@ -22,19 +22,18 @@ import qualified Reporting.Region as Region

22import qualified Reporting.Result as Result

25+

25patternMatches

26patternMatches

26 :: Module.Interfaces

27 :: Module.Interfaces

27− -> Module.CanonicalModule

28+ -> Module.Canonical

28 -> Result.Result w Error.Error DT.VariantDict

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

29−patternMatches interfaces modul =

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

30 let

31 let

31− name = Module.name modul

32− body = Module.body modul

33 tagDict =

32 tagDict =

34− toTagDict interfaces name (Module.unions body)

33+ toTagDict interfaces name (Module.unions info)

35 in

34 in

36 const (Map.map (Map.map length) tagDict)

35 const (Map.map (Map.map length) tagDict)

37− <$> checkExpression tagDict (Module.program body)

36+ <$> checkExpression tagDict (Module.program info)

src/Optimize.hs+4−10

@@ -26,22 +26,16 @@ import qualified Reporting.Region as R

26optimize :: DT.VariantDict -> Module.Canonical -> Module.Optimized

27optimize variantDict module_@(Module.Module _ home _ info) =

28 let

29− (Module.Canonical docs exports imports body) =

30− info

31−

32 (defs, _) =

29 (defs, _) =

33− flattenLets [] (Module.program body)

30+ flattenLets [] (Module.program info)

35 optDefs =

32 optDefs =

36 Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

33 Env.run variantDict home (concat <$> mapM (optimizeDef True) defs)

38− optBody =

35+ optInfo =

39− body { Module.program = optDefs }

36+ info { Module.program = optDefs }

40 in

37 in

41− module_

42− { Module.info =

38+ module_ { Module.info = optInfo }

43− Module.Optimized docs exports imports optBody

44− }

47flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

41flattenLets :: [Can.Def] -> Can.Expr -> ([Can.Def], Can.Expr)

src/Parse/Declaration.hs+3−48

@@ -2,14 +2,11 @@

2module Parse.Declaration where

4import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )

5−import qualified Text.Parsec.Indent as Indent

7import qualified AST.Declaration as Decl

6import qualified AST.Declaration as Decl

8−import qualified AST.Expression.Source as Source

9import qualified Parse.Expression as Expr

7import qualified Parse.Expression as Expr

10import Parse.Helpers as Help

8import Parse.Helpers as Help

11import qualified Parse.Type as Type

9import qualified Parse.Type as Type

12−import qualified Reporting.Annotation as A

@@ -17,10 +14,9 @@ declaration :: IParser Decl.Source

17declaration =

14declaration =

18 commentOr $ addLocation $

15 commentOr $ addLocation $

19 choice

16 choice

20− [ Decl.Source <$> typeDecl

17+ [ typeDecl

21− , Decl.Source <$> infixDecl

18+ , infixDecl

22− , defineDecl

23− , Decl.Source <$> definition

19+ , definition

24 ]

20 ]

@@ -85,44 +81,3 @@ infixDecl =

85 op <- anyOp

81 op <- anyOp

86 return $ Decl.Fixity assoc (read [n]) op

82 return $ Decl.Fixity assoc (read [n]) op

88−

89−

90−-- DEFINE

91−

92−

93−defineDecl :: IParser Decl.SourceOrDefine

94−defineDecl =

95− do try (reserved "define")

96− forcedWS

97−

98− effectType <-

99− choice

100− [ string "commands" >> return Decl.Cmd

101− , string "subscriptions" >> return Decl.Sub

102− , do string "foreign"

103− whitespace

104− choice

105− [ string "commands" >> return Decl.ForeignCmd

106− , string "subscriptions" >> return Decl.ForeignSub

107− ]

108− ]

109−

110− padded (reserved "as")

111−

112− effects <-

113− Indent.block (commentOr effectDef <* whitespace)

114−

115− return (Decl.Define effectType effects)

116−

117−

118−effectDef :: IParser (A.Located Source.Effect)

119−effectDef =

120− choice

121− [ Expr.annotation Source.Type

122− , Expr.definition Source.Def

123− , addLocation $

124− do name <- lowVar

125− padded (reserved "with")

126− expr <- Expr.expr

127− return (Source.With name expr)

128− ]

src/Parse/Module.hs+42−15

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

32 do optional freshLine

33 (tag, names, exports) <-

34 option

35− (Module.None, ["Main"], Var.openListing)

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

36 (moduleDecl `followedBy` freshLine)

38 docs <-

@@ -50,36 +50,63 @@ moduleDecl :: IParser (Module.Tag, [String], Var.Listing (A.Located Var.Value))

50moduleDecl =

51 expecting "a module declaration" $

52 do

53− kind <-

53+ endParser <-

54 choice

55+ [

55− [ do try (reserved "module")

56+ do try (reserved "module")

56− return Module.None

57+ return (return Module.Normal)

57− , do start <- getMyPosition

58+ ,

58− try (reserved "effect")

59+ do try (reserved "effect")

59 whitespace

60 whitespace

60 reserved "module"

61 reserved "module"

61− end <- getMyPosition

62+ return parseEffects

62− return $ Module.Effect (R.Region start end)

63+ ,

63− , do start <- getMyPosition

64+ do start <- getMyPosition

64 reserved "foreign"

65 reserved "foreign"

65 whitespace

66 whitespace

66 reserved "effect"

67 reserved "effect"

67 whitespace

68 whitespace

68 reserved "module"

69 reserved "module"

69 end <- getMyPosition

70 end <- getMyPosition

70− return $ Module.Foreign (R.Region start end)

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

71 ]

72 ]

73 whitespace

74 whitespace

74 names <- dotSep1 capVar <?> "the name of this module"

75 names <- dotSep1 capVar <?> "the name of this module"

76− whitespace

77+ padded (reserved "exposing")

77− exports <- option Var.openListing (listing (addLocation value))

79− whitespace

79+ exports <- listing (addLocation value)

80− reserved "where"

80+

81+ tag <- endParser

82− return (kind, names, exports)

83+ return (tag, names, exports)

84+

85+

86+parseEffects :: IParser Module.Tag

87+parseEffects =

88+ do padded (reserved "where")

89+ brackets $ choice $

90+ [ do cmd <- entry "command"

91+ whitespace

92+ sub <- option Nothing (secondEntry "subscription")

93+ return (Module.Effect cmd sub)

94+ , do sub <- entry "subscription"

95+ whitespace

96+ cmd <- option Nothing (secondEntry "command")

97+ return (Module.Effect cmd sub)

98+ ]

99+ where

100+ entry name =

101+ do try (string name)

102+ padded equals

103+ typeName <- addLocation capVar

104+ return (Just typeName)

105+

106+ secondEntry name =

107+ do try comma

108+ whitespace

109+ entry name

110

111

85imports :: IParser [Module.UserImport]

112imports :: IParser [Module.UserImport]

src/Parse/Parse.hs+2−3

@@ -34,8 +34,8 @@ program pkgName table src =

34 (Module.Source docs exports imports sourceDecls) =

35 Module.info modul

37− (validDecls, validEffects) <-

37+ validDecls <-

38− Validate.declarations (Module.tag modul) sourceDecls

38+ Validate.declarations sourceDecls

40 return $

41 modul

@@ -45,7 +45,6 @@ program pkgName table src =

45 exports

46 (addDefaults pkgName imports)

47 validDecls

48− validEffects

49 }

48 }

src/Reporting/Error/Syntax.hs−25

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

6import qualified Text.Parsec.Error as Parsec

7import Text.PrettyPrint.ANSI.Leijen (dullyellow, hsep, text)

9−import qualified AST.Declaration as Decl

10import qualified Reporting.Error.Helpers as Help

9import qualified Reporting.Error.Helpers as Help

11import qualified Reporting.Render.Type as RenderType

10import qualified Reporting.Render.Type as RenderType

12import qualified Reporting.Report as Report

11import qualified Reporting.Report as Report

@@ -21,14 +20,6 @@ data Error

21 | CommentOnComment

20 | CommentOnComment

22 | CommentOnNothing

21 | CommentOnNothing

24− | BadDefineInNormalModule Decl.EffectType

25− | BadDefineInEffectModule Decl.EffectType

26− | BadDefineInForeignModule Decl.EffectType

27− | WithInEffectDefine Decl.EffectType String

28− | NoDefineInEffectModule

29− | NoDefineInForeignModule

30− | DuplicateDefines Decl.EffectType Int

31−

32 | InfixDuplicate String

23 | InfixDuplicate String

33 | TypeWithoutDefinition String

24 | TypeWithoutDefinition String

34 | DuplicateFieldName String

25 | DuplicateFieldName String

@@ -104,22 +95,6 @@ toReport _localizer err =

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

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

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

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

106

107− DuplicateDefines effectType n ->

108− let

109− name =

110− Decl.effectTypeToString effectType

111− in

112− Report.report

113− "DUPLICATE DEFINE"

114− Nothing

115− ("There can only be one `define " ++ name ++ "` per module.")

116− ( Help.reflowParagraph $

117− "The `define` shown above is the last of " ++ show n ++ " in this module.\

118− \ They all say `define "++ name ++ "`, but maybe some are supposed to define\

119− \ something else? Could be a copy paste error. If they really are supposed\

120− \ to define the same kind of thing, just combine them and you should be all set!"

121− )

122−

123 InfixDuplicate opName ->

98 InfixDuplicate opName ->

124 Report.report

99 Report.report

125 "INFIX OVERLAP"

100 "INFIX OVERLAP"

src/Type/Inference.hs+14−14

@@ -5,7 +5,7 @@ import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

5import qualified Data.Map as Map

6import qualified Data.Traversable as Traverse

8−import AST.Module as Module

8+import qualified AST.Module as Module

9import qualified AST.Module.Name as ModuleName

10import qualified AST.Type as Type

11import qualified AST.Variable as Var

@@ -24,7 +24,7 @@ import System.IO.Unsafe

25infer

26 :: Module.Interfaces

27− -> Module.CanonicalModule

27+ -> Module.Canonical

28 -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

29infer interfaces modul =

30 either throwError return $ unsafePerformIO $ runExceptT $

@@ -41,7 +41,7 @@ infer interfaces modul =

42genConstraints

43 :: Module.Interfaces

44− -> Module.CanonicalModule

44+ -> Module.Canonical

45 -> IO (Map.Map String T.Type, T.TypeConstraint)

46genConstraints interfaces modul =

47 do env <- Env.initialize (canonicalizeUnions interfaces modul)

@@ -62,17 +62,17 @@ genConstraints interfaces modul =

62 fvar <- T.mkVar Nothing

64 constraint <-

65− TcExpr.constrain env (program (body modul)) (T.VarN fvar)

65+ TcExpr.constrain env (Module.program (Module.info modul)) (T.VarN fvar)

67 return (header, environ constraint)

70canonicalizeValues

71 :: Env.Environment

72− -> (ModuleName.Canonical, Interface)

72+ -> (ModuleName.Canonical, Module.Interface)

73 -> IO [(String, ([T.Variable], T.Type))]

74canonicalizeValues env (moduleName, iface) =

75− forM (Map.toList (iTypes iface)) $ \(name,tipe) ->

75+ forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->

76 do tipe' <- Env.instantiateType env tipe Map.empty

77 return

78 ( ModuleName.canonicalToString moduleName ++ "." ++ name

@@ -80,24 +80,24 @@ canonicalizeValues env (moduleName, iface) =

80 )

83−canonicalizeUnions :: Module.Interfaces -> Module.CanonicalModule -> [CanonicalUnion]

83+canonicalizeUnions :: Module.Interfaces -> Module.Canonical -> [Module.CanonicalUnion]

84−canonicalizeUnions interfaces modul =

84+canonicalizeUnions interfaces (Module.Module _ name _ info) =

85 localUnions ++ importedUnions

86 where

87− localUnions :: [CanonicalUnion]

87+ localUnions :: [Module.CanonicalUnion]

88 localUnions =

89− format (Module.name modul, unions (body modul))

89+ format (name, Module.unions info)

91− importedUnions :: [CanonicalUnion]

91+ importedUnions :: [Module.CanonicalUnion]

92 importedUnions =

93− concatMap (format . second iUnions) (Map.toList interfaces)

93+ concatMap (format . second Module.iUnions) (Map.toList interfaces)

96−format :: (ModuleName.Canonical, Module.Unions) -> [CanonicalUnion]

96+format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]

97format (home, adts) =

98 map canonical (Map.toList adts)

99 where

100− canonical :: (String, UnionInfo String) -> CanonicalUnion

100+ canonical :: (String, Module.UnionInfo String) -> Module.CanonicalUnion

101 canonical (name, (tvars, ctors)) =

102 ( toVar name

103 , (tvars, map (first toVar) ctors)

src/Validate.hs+9−251

@@ -1,7 +1,6 @@

1{-# OPTIONS_GHC -Wall #-}

2module Validate (declarations) where

4−import qualified Control.Arrow as Arrow

5import Control.Monad (foldM)

4import Control.Monad (foldM)

6import qualified Data.Map as Map

5import qualified Data.Map as Map

7import qualified Data.Set as Set

6import qualified Data.Set as Set

@@ -12,7 +11,6 @@ import AST.Expression.General as Expr

12import qualified AST.Expression.Source as Source

11import qualified AST.Expression.Source as Source

13import qualified AST.Expression.Valid as Valid

12import qualified AST.Expression.Valid as Valid

14import qualified AST.Declaration as D

13import qualified AST.Declaration as D

15−import qualified AST.Module as Module

16import qualified AST.Pattern as Pattern

14import qualified AST.Pattern as Pattern

17import qualified AST.Type as Type

15import qualified AST.Type as Type

18import Elm.Utils ((|>))

16import Elm.Utils ((|>))

@@ -60,148 +58,21 @@ collapseComments listWithComments =

63−-- PARTITION AND VALIDATE DEFINES

64−

65−

66−type Defines =

67− Map.Map D.EffectType [A.Located [D.CommentOr (A.Located Source.Effect)]]

68−

69−

70−partitionEffects :: [Commented D.SourceOrDefine] -> ([Commented D.Source'], Defines)

71−partitionEffects commentedDecls =

72− case commentedDecls of

73− [] ->

74− ([], Map.empty)

75−

76− A.A ann (D.Source decl) : rest ->

77− Arrow.first

78− ((:) (A.A ann decl))

79− (partitionEffects rest)

80−

81− A.A (region, _) (D.Define effectType commentOrEffects) : rest ->

82− Arrow.second

83− (Map.insertWith (++) effectType [A.A region commentOrEffects])

84− (partitionEffects rest)

85−

86−

87−validateDefines

88− :: Module.Tag

89− -> Defines

90− -> Result.Result wrn Error.Error Valid.Effects

91−validateDefines tag defines =

92− case tag of

93− Module.None ->

94− do disallowLeftoverDefines Error.BadDefineInNormalModule defines

95− return Valid.None

96−

97− Module.Effect region ->

98− let

99− (maybeCmds, smallerDefines) =

100− extractKey D.Cmd defines

101−

102− (maybeSubs, leftovers) =

103− extractKey D.Sub smallerDefines

104− in

105− do disallowLeftoverDefines Error.BadDefineInEffectModule leftovers

106− case (maybeCmds, maybeSubs) of

107− (Nothing, Nothing) ->

108− Result.throw region Error.NoDefineInEffectModule

109−

110− _ ->

111−

112− Valid.Effects

113− <$> validateDefineDefs D.Cmd maybeCmds validateEffects

114− <*> validateDefineDefs D.Sub maybeSubs validateEffects

115−

116− Module.Foreign region ->

117− let

118− (maybeCmds, smallerDefines) =

119− extractKey D.ForeignCmd defines

120−

121− (maybeSubs, leftovers) =

122− extractKey D.ForeignSub smallerDefines

123− in

124− do disallowLeftoverDefines Error.BadDefineInForeignModule leftovers

125− case (maybeCmds, maybeSubs) of

126− (Nothing, Nothing) ->

127− Result.throw region Error.NoDefineInForeignModule

128−

129− (_, _) ->

130− Valid.ForeignEffects

131− <$> validateDefineDefs D.ForeignCmd maybeCmds (T.traverse validateForeignCmd)

132− <*> validateDefineDefs D.ForeignSub maybeSubs (T.traverse validateForeignSub)

133−

134−

135−extractKey :: (Ord k) => k -> Map.Map k v -> (Maybe v, Map.Map k v)

136−extractKey key dict =

137− ( Map.lookup key dict

138− , Map.delete key dict

139− )

140−

141−

142−validateDefineDefs

143− :: D.EffectType

144− -> Maybe [A.Located [D.CommentOr (A.Located Source.Effect)]]

145− -> ([Commented Source.Effect] -> Result.Result wrn Error.Error a)

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

147−validateDefineDefs effectType maybeAllRawDefines validate =

148− case maybeAllRawDefines of

149− Nothing ->

150− validate []

151−

152− Just [A.A _ sourceDefs] ->

153− validate =<< collapseComments sourceDefs

154−

155− Just allRawDefines ->

156− let

157− (A.A region _) =

158− last allRawDefines

159−

160− errorMsg =

161− Error.DuplicateDefines effectType (length allRawDefines)

162− in

163− Result.throw region errorMsg

164−

165−

166−disallowLeftoverDefines

167− :: (D.EffectType -> Error.Error)

168− -> Defines

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

170−disallowLeftoverDefines errorTagger leftoverDefines =

171− case Map.toList leftoverDefines of

172− [] ->

173− Result.ok ()

174−

175− pairs ->

176− let

177− toErrors (key, allDefines) =

178− map (A.map (\_ -> errorTagger key)) allDefines

179− in

180− Result.throwMany (concatMap toErrors pairs)

181−

182−

183−

184-- VALIDATE STRUCTURED SOURCE

61-- VALIDATE STRUCTURED SOURCE

185

186

187−declarations

188− :: Module.Tag

189− -> [D.Source]

190− -> Result.Result wrn Error.Error ([D.Valid], Valid.Effects)

64+declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]

191−declarations tag sourceDecls =

65+declarations sourceDecls =

192− do (decls, defines) <-

66+ do decls <-

193− partitionEffects <$> collapseComments sourceDecls

67+ collapseComments sourceDecls

194

195 validDecls <-

69 validDecls <-

196 validateDecls decls

70 validateDecls decls

197

198− validEffects <-

199− validateDefines tag defines

200−

201 F.traverse_ id

72 F.traverse_ id

202− (declDuplicates validDecls validEffects : map findBadTypeVars validDecls)

73+ (declDuplicates validDecls : map findBadTypeVars validDecls)

203

204− return (validDecls, validEffects)

75+ return validDecls

205

206

207

@@ -274,86 +145,6 @@ validateDeclsHelp maybeComment (A.A region def) decls =

274

145

275

146

276

147

277−-- VALIDATE EFFECTS

278−

279−

280−validateEffects

281− :: [Commented Source.Effect]

282− -> Result.Result wrn Error.Error [A.Commented Valid.Def]

283−validateEffects effects =

284− case effects of

285− [] ->

286− Result.ok []

287−

288− A.A (region, maybeComment) effect : rest ->

289− validateEffectsHelp (region, fmap A.drop maybeComment) effect rest

290−

291−

292−validateEffectsHelp

293− :: (R.Region, Maybe String)

294− -> Source.Effect

295− -> [Commented Source.Effect]

296− -> Result.Result wrn Error.Error [A.Commented Valid.Def]

297−validateEffectsHelp ann effect remainingEffects =

298− case effect of

299− Source.With _ _ ->

300− Result.throw (fst ann) (error "TODO")

301−

302− Source.Def pat expr ->

303− (:)

304− <$> validateDef Valid.Definition ann pat expr Nothing

305− <*> validateEffects remainingEffects

306−

307− Source.Type name tipe ->

308− case remainingEffects of

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

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

311−

312− A.A _ (Source.Def pat expr) : rest

313− | Pattern.isVar name pat ->

314− (:)

315− <$> validateDef Valid.Definition ann pat expr (Just tipe)

316− <*> validateEffects rest

317−

318− _ ->

319− Result.throw (fst ann) (Error.TypeWithoutDefinition name)

320−

321−

322−validateForeignCmd

323− :: Commented Source.Effect

324− -> Result.Result wrn Error.Error (A.Commented Valid.ForeignCmd)

325−validateForeignCmd (A.A (region, maybeComment) effect) =

326− case effect of

327− Source.With _ _ ->

328− Result.throw region (error "TODO")

329−

330− Source.Def _ _ ->

331− Result.throw region (error "TODO")

332−

333− Source.Type name tipe ->

334− Result.ok $

335− A.A (region, fmap A.drop maybeComment) (Valid.Cmd name tipe)

336−

337−

338−validateForeignSub

339− :: Commented Source.Effect

340− -> Result.Result wrn Error.Error (A.Commented Valid.ForeignSub)

341−validateForeignSub (A.A (region, maybeComment) effect) =

342− case effect of

343− Source.With name expr ->

344− do validExpr <- expression expr

345− Result.ok $

346− A.A (region, fmap A.drop maybeComment) (Valid.SubWith name validExpr)

347−

348− Source.Def _ _ ->

349− Result.throw region (error "TODO")

350−

351− Source.Type name tipe ->

352− Result.ok $

353− A.A (region, fmap A.drop maybeComment) (Valid.Sub name tipe)

354−

355−

356−

357-- VALIDATE DEFINITIONS

148-- VALIDATE DEFINITIONS

358

149

359

150

@@ -556,17 +347,14 @@ defDuplicates patterns =

556 |> detectDuplicates Error.DuplicateDefinition

347 |> detectDuplicates Error.DuplicateDefinition

557

348

558

349

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

350+declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()

560−declDuplicates decls effects =

351+declDuplicates decls =

561 let

352 let

562 (valueLists, typeLists) =

353 (valueLists, typeLists) =

563 unzip (map extractValues decls)

354 unzip (map extractValues decls)

564−

565− effectValues =

566− extractEffectValues effects

567 in

355 in

568 (\_ _ -> ())

356 (\_ _ -> ())

569− <$> detectDuplicates Error.DuplicateValueDeclaration (effectValues ++ concat valueLists)

357+ <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)

570 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)

358 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)

571

359

572

360

@@ -599,36 +387,6 @@ extractValues (A.A (region, _) decl) =

599 )

387 )

600

388

601

389

602−extractEffectValues :: Valid.Effects -> [A.Located String]

603−extractEffectValues effects =

604− case effects of

605− Valid.None ->

606− []

607−

608− Valid.Effects cmds subs ->

609− let

610− extractNames (Valid.Definition pat _ _) =

611− Pattern.boundVars pat

612− in

613− concatMap (extractNames . A.drop) (cmds ++ subs)

614−

615− Valid.ForeignEffects cmds subs ->

616− let

617− extractCmdNames (A.A (region, _) (Valid.Cmd name _)) =

618− A.A region name

619−

620− extractSubNames (A.A (region, _) sub) =

621− A.A region $

622− case sub of

623− Valid.Sub name _ ->

624− name

625−

626− Valid.SubWith name _ ->

627− name

628− in

629− map extractCmdNames cmds ++ map extractSubNames subs

630−

631−

632

390

633-- UNBOUND TYPE VARIABLES

391-- UNBOUND TYPE VARIABLES

634

392