git.iko.soy/elk
on master help sign in
Properly parse and validate define construct
4da491bEvan Czaplicki
src/AST/Declaration.hs+54−26
compare with master
unifiedsplit
@@ -22,24 +22,32 @@ data Decl def tipe expr
22
22
23
23
24
24
25−-- INFIX STUFF
25+-- DECLARATION PHASES
26
26
27
27
28−data Assoc = L | N | R
28+type Source =
29− deriving (Eq)
29+ CommentOr (A.Located SourceOrDefine)
30
30
31
31
32−assocToString :: Assoc -> String
32+data SourceOrDefine
33−assocToString assoc =
33+ = Source Source'
34− case assoc of
34+ | Define EffectType [CommentOr (A.Located Source.Effect)]
35− L ->
36− "left"
37
35
38− N ->
39− "non"
40
36
41− R ->
37+type Source' =
42− "right"
38+ Decl Source.Def Type.Raw Source.Expr
39+
40+
41+type Valid =
42+ A.Commented Valid'
43+
44+
45+type Valid' =
46+ Decl Valid.Def Type.Raw Valid.Expr
47+
48+
49+type Canonical =
50+ A.Commented (Decl Canonical.Def Type.Canonical Canonical.Expr)
43
51
44
52
45
53
@@ -52,32 +60,52 @@ data CommentOr a
52
60
53
61
54
62
55−-- DECLARATION PHASES
63+-- EFFECTS
56
64
57
65
58−type Source =
66+data EffectType
59− CommentOr (A.Located SourceOrDefine)
67+ = Cmd
68+ | Sub
69+ | ForeignCmd
70+ | ForeignSub
71+ deriving (Eq, Ord)
60
72
61
73
62−data SourceOrDefine
74+effectTypeToString :: EffectType -> String
63− = Source Source'
75+effectTypeToString tipe =
64− | Define String [CommentOr (A.Located Source.Effect)]
76+ case tipe of
77+ Cmd ->
78+ "commands"
65
79
80+ Sub ->
81+ "subscriptions"
66
82
67−type Source' =
83+ ForeignCmd ->
68− Decl Source.Def Type.Raw Source.Expr
84+ "foreign commands"
69
85
86+ ForeignSub ->
87+ "foreign subscriptions"
70
88
71−type Valid =
72− A.Commented Valid'
73
89
74
90
75−type Valid' =
91+-- INFIX STUFF
76− Decl Valid.Def Type.Raw Valid.Expr
77
92
78
93
79−type Canonical =
94+data Assoc = L | N | R
80− A.Commented (Decl Canonical.Def Type.Canonical Canonical.Expr)
95+ deriving (Eq)
96+
97+
98+assocToString :: Assoc -> String
99+assocToString assoc =
100+ case assoc of
101+ L ->
102+ "left"
103+
104+ N ->
105+ "non"
106+
107+ R ->
108+ "right"
81
109
82
110
83
111
src/AST/Expression/Valid.hs+13−6
@@ -5,6 +5,7 @@ import qualified AST.Expression.General as General
5import qualified AST.Pattern as Pattern
5import qualified AST.Pattern as Pattern
6import qualified AST.Type as Type
6import qualified AST.Type as Type
7import qualified AST.Variable as Var
7import qualified AST.Variable as Var
8+import qualified Reporting.Annotation as A
8import qualified Reporting.Region as R
9import qualified Reporting.Region as R
9
10
10
11
@@ -21,14 +22,20 @@ type Expr' =
21
22
22
23
23data Def
24data Def
24− = Definition Pattern.Raw Expr (Maybe Type.Raw)
25+ = Definition Pattern.Raw Expr (Maybe Type.Raw)
25
26
26
27
27−data Effect
28+data Effects
28− = Def Pattern.Raw Expr (Maybe Type.Raw)
29+ = None
30+ | Effects [A.Commented Def] [A.Commented Def]
31+ | ForeignEffects [A.Commented ForeignCmd] [A.Commented ForeignSub]
29
32
30
33
31−data Foreign
34+data ForeignCmd
35+ = Cmd String Type.Raw
36+
37+
38+data ForeignSub
32− = Type String Type.Raw
39+ = Sub String Type.Raw
33− | With String Expr
40+ | SubWith String Expr
34
41
src/AST/Module.hs+4−4
@@ -30,6 +30,7 @@ import qualified Docs.AST as Docs
30import qualified Elm.Package as Package
30import qualified Elm.Package as Package
31import qualified Elm.Compiler.Version as Compiler
31import qualified Elm.Compiler.Version as Compiler
32import qualified Reporting.Annotation as A
32import qualified Reporting.Annotation as A
33+import qualified Reporting.Region as R
33
34
34
35
35
36
@@ -62,8 +63,8 @@ data Module phase =
62
63
63data Tag
64data Tag
64 = None
65 = None
65− | Effect
66+ | Effect R.Region
66− | Foreign
67+ | Foreign R.Region
67
68
68
69
69type Source =
70type Source =
@@ -89,8 +90,7 @@ data ValidInfo =
89 , validExports :: Var.Listing (A.Located Var.Value)
90 , validExports :: Var.Listing (A.Located Var.Value)
90 , validImports :: ([DefaultImport], [UserImport])
91 , validImports :: ([DefaultImport], [UserImport])
91 , validDecls :: [Decl.Valid]
92 , validDecls :: [Decl.Valid]
92− , validCmds :: [A.Commented Valid.Effect]
93+ , validEffects :: Valid.Effects
93− , validSubs :: [A.Commented Valid.Effect]
94 }
94 }
95
95
96
96
src/Parse/Declaration.hs+13−4
@@ -1,7 +1,7 @@
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2module Parse.Declaration where
2module Parse.Declaration where
3
3
4−import Text.Parsec ( (<|>), (<?>), choice, digit, optionMaybe, string, try )
4+import Text.Parsec ( (<?>), choice, digit, optionMaybe, string, try )
5import qualified Text.Parsec.Indent as Indent
5import qualified Text.Parsec.Indent as Indent
6
6
7import qualified AST.Declaration as Decl
7import qualified AST.Declaration as Decl
@@ -95,15 +95,24 @@ defineDecl =
95 do try (reserved "define")
95 do try (reserved "define")
96 forcedWS
96 forcedWS
97
97
98− name <-
98+ effectType <-
99+ choice
100+ [ string "commands" >> return Decl.Cmd
99− string "commands" <|> string "subscriptions"
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+ ]
100
109
101 padded (reserved "as")
110 padded (reserved "as")
102
111
103 effects <-
112 effects <-
104 Indent.block (commentOr effectDef <* whitespace)
113 Indent.block (commentOr effectDef <* whitespace)
105
114
106− return (Decl.Define name effects)
115+ return (Decl.Define effectType effects)
107
116
108
117
109effectDef :: IParser (A.Located Source.Effect)
118effectDef :: IParser (A.Located Source.Effect)
src/Parse/Module.hs+10−5
@@ -7,7 +7,8 @@ import Parse.Helpers
7import qualified AST.Module as Module
7import qualified AST.Module as Module
8import qualified AST.Module.Name as ModuleName
8import qualified AST.Module.Name as ModuleName
9import qualified AST.Variable as Var
9import qualified AST.Variable as Var
10−import Reporting.Annotation as A
10+import qualified Reporting.Annotation as A
11+import qualified Reporting.Region as R
11
12
12
13
13getModuleName :: String -> Maybe String
14getModuleName :: String -> Maybe String
@@ -53,16 +54,20 @@ moduleDecl =
53 choice
54 choice
54 [ do try (reserved "module")
55 [ do try (reserved "module")
55 return Module.None
56 return Module.None
57+ , do start <- getMyPosition
56− , do try (reserved "effect")
58+ try (reserved "effect")
57 whitespace
59 whitespace
58 reserved "module"
60 reserved "module"
61+ end <- getMyPosition
59− return Module.Effect
62+ return $ Module.Effect (R.Region start end)
63+ , do start <- getMyPosition
60− , do reserved "foreign"
64+ reserved "foreign"
61 whitespace
65 whitespace
62 reserved "effect"
66 reserved "effect"
63 whitespace
67 whitespace
64 reserved "module"
68 reserved "module"
69+ end <- getMyPosition
65− return Module.Foreign
70+ return $ Module.Foreign (R.Region start end)
66 ]
71 ]
67
72
68 whitespace
73 whitespace
src/Parse/Parse.hs+3−4
@@ -34,8 +34,8 @@ program pkgName table src =
34 (Module.Source docs exports imports sourceDecls) =
34 (Module.Source docs exports imports sourceDecls) =
35 Module.info modul
35 Module.info modul
36
36
37− validDecls <-
37+ (validDecls, validEffects) <-
38− Validate.declarations sourceDecls
38+ Validate.declarations (Module.tag modul) sourceDecls
39
39
40 return $
40 return $
41 modul
41 modul
@@ -45,8 +45,7 @@ program pkgName table src =
45 exports
45 exports
46 (addDefaults pkgName imports)
46 (addDefaults pkgName imports)
47 validDecls
47 validDecls
48− (error "TODO")
48+ validEffects
49− (error "TODO")
50 }
49 }
51
50
52
51
src/Reporting/Error/Syntax.hs+21−14
@@ -6,6 +6,7 @@ import qualified Data.Set as Set
6import qualified Text.Parsec.Error as Parsec
6import qualified Text.Parsec.Error as Parsec
7import Text.PrettyPrint.ANSI.Leijen (dullyellow, hsep, text)
7import Text.PrettyPrint.ANSI.Leijen (dullyellow, hsep, text)
8
8
9+import qualified AST.Declaration as Decl
9import qualified Reporting.Error.Helpers as Help
10import qualified Reporting.Error.Helpers as Help
10import qualified Reporting.Render.Type as RenderType
11import qualified Reporting.Render.Type as RenderType
11import qualified Reporting.Report as Report
12import qualified Reporting.Report as Report
@@ -15,11 +16,19 @@ data Error
15 = Parse [Parsec.Message]
16 = Parse [Parsec.Message]
16 | BadFunctionName Int
17 | BadFunctionName Int
17 | BadPattern String
18 | BadPattern String
19+
18 | CommentAfterAnnotation String
20 | CommentAfterAnnotation String
19 | CommentOnComment
21 | CommentOnComment
20 | CommentOnNothing
22 | CommentOnNothing
21− | DefineDuplicate String
23+
22− | DefineUnknown String
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+
23 | InfixDuplicate String
32 | InfixDuplicate String
24 | TypeWithoutDefinition String
33 | TypeWithoutDefinition String
25 | DuplicateFieldName String
34 | DuplicateFieldName String
@@ -95,22 +104,20 @@ toReport _localizer err =
95 ("This documentation comment is not followed by anything.")
104 ("This documentation comment is not followed by anything.")
96 ( text "What is it documenting? Maybe it should just be removed?" )
105 ( text "What is it documenting? Maybe it should just be removed?" )
97
106
98− DefineDuplicate name ->
107+ DuplicateDefines effectType n ->
108+ let
109+ name =
110+ Decl.effectTypeToString effectType
111+ in
99 Report.report
112 Report.report
100 "DUPLICATE DEFINE"
113 "DUPLICATE DEFINE"
101 Nothing
114 Nothing
102− ("A module can have only one `define " ++ name ++ "` declaration.")
115+ ("There can only be one `define " ++ name ++ "` per module.")
103− ( text "This module has two though. You should combine them or remove one." )
104−
105− DefineUnknown name ->
106− Report.report
107− "UNKNOWN DEFINE"
108− Nothing
109− ("You are trying to `define " ++ name ++ "`, but that is not recognized.")
110 ( Help.reflowParagraph $
116 ( Help.reflowParagraph $
111− "You can only define `commands` and `subscriptions` with this syntax.\
117+ "The `define` shown above is the last of " ++ show n ++ " in this module.\
112− \ Furthermore, you must be in an `effect module` or `foreign effect module` to\
118+ \ They all say `define "++ name ++ "`, but maybe some are supposed to define\
113− \ even have access to this syntax."
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!"
114 )
121 )
115
122
116 InfixDuplicate opName ->
123 InfixDuplicate opName ->
src/Validate.hs+210−65
@@ -1,9 +1,9 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Validate (declarations) where
2module Validate (declarations) where
3
3
4+import qualified Control.Arrow as Arrow
4import Control.Monad (foldM)
5import Control.Monad (foldM)
5import qualified Data.Map as Map
6import qualified Data.Map as Map
6−import qualified Data.Maybe as Maybe
7import qualified Data.Set as Set
7import qualified Data.Set as Set
8import qualified Data.Foldable as F
8import qualified Data.Foldable as F
9import qualified Data.Traversable as T
9import qualified Data.Traversable as T
@@ -12,6 +12,7 @@ import AST.Expression.General as Expr
12import qualified AST.Expression.Source as Source
12import qualified AST.Expression.Source as Source
13import qualified AST.Expression.Valid as Valid
13import qualified AST.Expression.Valid as Valid
14import qualified AST.Declaration as D
14import qualified AST.Declaration as D
15+import qualified AST.Module as Module
15import qualified AST.Pattern as Pattern
16import qualified AST.Pattern as Pattern
16import qualified AST.Type as Type
17import qualified AST.Type as Type
17import Elm.Utils ((|>))
18import Elm.Utils ((|>))
@@ -59,73 +60,148 @@ collapseComments listWithComments =
59
60
60
61
61
62
62−-- EXTRACT DEFINES
63+-- PARTITION AND VALIDATE DEFINES
63
64
64
65
65−data StructuredSource =
66+type Defines =
66− Src
67+ Map.Map D.EffectType [A.Located [D.CommentOr (A.Located Source.Effect)]]
67− { _decls :: [Commented D.Source']
68− , _cmds :: Maybe [Commented Source.Effect]
69− , _subs :: Maybe [Commented Source.Effect]
70− }
71
68
72
69
73−extractEffects :: [Commented D.SourceOrDefine] -> Result.Result wrn Error.Error StructuredSource
70+partitionEffects :: [Commented D.SourceOrDefine] -> ([Commented D.Source'], Defines)
74−extractEffects commentedDecls =
71+partitionEffects commentedDecls =
75 case commentedDecls of
72 case commentedDecls of
76 [] ->
73 [] ->
77− Result.ok (Src [] Nothing Nothing)
74+ ([], Map.empty)
78
75
79 A.A ann (D.Source decl) : rest ->
76 A.A ann (D.Source decl) : rest ->
80− do restSrc <- extractEffects rest
77+ Arrow.first
81− return $ restSrc { _decls = A.A ann decl : _decls restSrc }
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
82
120
83− A.A (region, _) (D.Define name commentOrEffects) : rest ->
121+ (maybeSubs, leftovers) =
84− do restSrc <- extractEffects rest
122+ extractKey D.ForeignSub smallerDefines
85− case name of
123+ in
86− "commands" ->
124+ do disallowLeftoverDefines Error.BadDefineInForeignModule leftovers
87− case _cmds restSrc of
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
88− Nothing ->
149+ Nothing ->
150+ validate []
151+
152+ Just [A.A _ sourceDefs] ->
89− do effects <- collapseComments commentOrEffects
153+ validate =<< collapseComments sourceDefs
90− Result.ok $ restSrc { _cmds = Just effects }
154+
155+ Just allRawDefines ->
156+ let
157+ (A.A region _) =
158+ last allRawDefines
91
159
92− Just _ ->
160+ errorMsg =
161+ Error.DuplicateDefines effectType (length allRawDefines)
162+ in
93− Result.throw region (Error.DefineDuplicate name)
163+ Result.throw region errorMsg
94
164
95− "subscriptions" ->
96− case _subs restSrc of
97− Nothing ->
98− do effects <- collapseComments commentOrEffects
99− Result.ok $ restSrc { _subs = Just effects }
100
165
101− Just _ ->
166+disallowLeftoverDefines
102− Result.throw region (Error.DefineDuplicate name)
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 ()
103
174
104− _ ->
175+ pairs ->
105− Result.throw region (Error.DefineUnknown name)
176+ let
177+ toErrors (key, allDefines) =
178+ map (A.map (\_ -> errorTagger key)) allDefines
179+ in
180+ Result.throwMany (concatMap toErrors pairs)
106
181
107
182
108
183
109-- VALIDATE STRUCTURED SOURCE
184-- VALIDATE STRUCTURED SOURCE
110
185
111
186
187+declarations
188+ :: Module.Tag
189+ -> [D.Source]
112−declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
190+ -> Result.Result wrn Error.Error ([D.Valid], Valid.Effects)
113−declarations sourceDecls =
191+declarations tag sourceDecls =
114− do (Src decls cmds subs) <-
192+ do (decls, defines) <-
115− extractEffects =<< collapseComments sourceDecls
193+ partitionEffects <$> collapseComments sourceDecls
116
194
117 validDecls <-
195 validDecls <-
118 validateDecls decls
196 validateDecls decls
119
197
120− validCmds <-
198+ validEffects <-
121− validateEffects (Maybe.fromMaybe [] cmds)
199+ validateDefines tag defines
122
200
123− validSubs <-
201+ F.traverse_ id
124− validateEffects (Maybe.fromMaybe [] subs)
202+ (declDuplicates validDecls validEffects : map findBadTypeVars validDecls)
125
203
126− (\_ _ -> validDecls)
204+ return (validDecls, validEffects)
127− <$> declDuplicates validDecls
128− <*> T.traverse checkDecl validDecls
129
205
130
206
131
207
@@ -170,11 +246,11 @@ validateDeclsHelp
170 -> Result.Result wrn Error.Error [D.Valid]
246 -> Result.Result wrn Error.Error [D.Valid]
171validateDeclsHelp maybeComment (A.A region def) decls =
247validateDeclsHelp maybeComment (A.A region def) decls =
172 let
248 let
173− makeDef pat expr maybeType =
174− D.Def (Valid.Definition pat expr maybeType)
175−
176 ann =
249 ann =
177 (region, fmap A.drop maybeComment)
250 (region, fmap A.drop maybeComment)
251+
252+ makeDef pat expr maybeType =
253+ D.Def (Valid.Definition pat expr maybeType)
178 in
254 in
179 case def of
255 case def of
180 Source.Definition pat expr ->
256 Source.Definition pat expr ->
@@ -203,21 +279,21 @@ validateDeclsHelp maybeComment (A.A region def) decls =
203
279
204validateEffects
280validateEffects
205 :: [Commented Source.Effect]
281 :: [Commented Source.Effect]
206− -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
282+ -> Result.Result wrn Error.Error [A.Commented Valid.Def]
207validateEffects effects =
283validateEffects effects =
208− case effects of
284+ case effects of
209− [] ->
285+ [] ->
210− Result.ok []
286+ Result.ok []
211
287
212− A.A (region, maybeComment) effect : rest ->
288+ A.A (region, maybeComment) effect : rest ->
213− validateEffectsHelp (region, fmap A.drop maybeComment) effect rest
289+ validateEffectsHelp (region, fmap A.drop maybeComment) effect rest
214
290
215
291
216validateEffectsHelp
292validateEffectsHelp
217 :: (R.Region, Maybe String)
293 :: (R.Region, Maybe String)
218 -> Source.Effect
294 -> Source.Effect
219 -> [Commented Source.Effect]
295 -> [Commented Source.Effect]
220− -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
296+ -> Result.Result wrn Error.Error [A.Commented Valid.Def]
221validateEffectsHelp ann effect remainingEffects =
297validateEffectsHelp ann effect remainingEffects =
222 case effect of
298 case effect of
223 Source.With _ _ ->
299 Source.With _ _ ->
@@ -225,7 +301,7 @@ validateEffectsHelp ann effect remainingEffects =
225
301
226 Source.Def pat expr ->
302 Source.Def pat expr ->
227 (:)
303 (:)
228− <$> validateDef Valid.Def ann pat expr Nothing
304+ <$> validateDef Valid.Definition ann pat expr Nothing
229 <*> validateEffects remainingEffects
305 <*> validateEffects remainingEffects
230
306
231 Source.Type name tipe ->
307 Source.Type name tipe ->
@@ -236,13 +312,47 @@ validateEffectsHelp ann effect remainingEffects =
236 A.A _ (Source.Def pat expr) : rest
312 A.A _ (Source.Def pat expr) : rest
237 | Pattern.isVar name pat ->
313 | Pattern.isVar name pat ->
238 (:)
314 (:)
239− <$> validateDef Valid.Def ann pat expr (Just tipe)
315+ <$> validateDef Valid.Definition ann pat expr (Just tipe)
240 <*> validateEffects rest
316 <*> validateEffects rest
241
317
242 _ ->
318 _ ->
243 Result.throw (fst ann) (Error.TypeWithoutDefinition name)
319 Result.throw (fst ann) (Error.TypeWithoutDefinition name)
244
320
245
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+
246
356
247-- VALIDATE DEFINITIONS
357-- VALIDATE DEFINITIONS
248
358
@@ -398,8 +508,8 @@ second (value, expr) =
398
508
399
509
400both
510both
401− :: (Source.Expr, Source.Expr)
511+ :: (Source.Expr, Source.Expr)
402− -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
512+ -> Result.Result wrn Error.Error (Valid.Expr, Valid.Expr)
403both (expr1, expr2) =
513both (expr1, expr2) =
404 (,) <$> expression expr1 <*> expression expr2
514 (,) <$> expression expr1 <*> expression expr2
405
515
@@ -446,13 +556,18 @@ defDuplicates patterns =
446 |> detectDuplicates Error.DuplicateDefinition
556 |> detectDuplicates Error.DuplicateDefinition
447
557
448
558
449−declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
559+declDuplicates :: [D.Valid] -> Valid.Effects -> Result.Result wrn Error.Error ()
450−declDuplicates decls =
560+declDuplicates decls effects =
561+ let
562+ (valueLists, typeLists) =
451− let (valueLists, typeLists) = unzip (map extractValues decls)
563+ unzip (map extractValues decls)
564+
565+ effectValues =
566+ extractEffectValues effects
452 in
567 in
453− (\_ _ -> ())
568+ (\_ _ -> ())
454− <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
569+ <$> detectDuplicates Error.DuplicateValueDeclaration (effectValues ++ concat valueLists)
455− <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
570+ <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
456
571
457
572
458extractValues :: D.Valid -> ([A.Located String], [A.Located String])
573extractValues :: D.Valid -> ([A.Located String], [A.Located String])
@@ -484,12 +599,42 @@ extractValues (A.A (region, _) decl) =
484 )
599 )
485
600
486
601
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+
487
632
488-- UNBOUND TYPE VARIABLES
633-- UNBOUND TYPE VARIABLES
489
634
490
635
491−checkDecl :: D.Valid -> Result.Result wrn Error.Error ()
636+findBadTypeVars :: D.Valid -> Result.Result wrn Error.Error ()
492−checkDecl (A.A (region,_) decl) =
637+findBadTypeVars (A.A (region,_) decl) =
493 case decl of
638 case decl of
494 D.Def _ ->
639 D.Def _ ->
495 return ()
640 return ()