@@ -3,6 +3,7 @@ module Validate (declarations) where
33
44import Control.Monad (foldM)
55import qualified Data.Map as Map
6+import qualified Data.Maybe as Maybe
67import qualified Data.Set as Set
78import qualified Data.Foldable as F
89import qualified Data.Traversable as T
@@ -21,94 +22,225 @@ import qualified Reporting.Result as Result
2122
2223
2324
24−-- VALIDATE DECLARATIONS
25+-- COLLAPSE COMMENTS
26+
27+
28+type Commented a =
29+ A.Annotated (R.Region, Maybe (A.Located String)) a
30+
31+
32+collapseComments
33+ :: [D.CommentOr (A.Located a)]
34+ -> Result.Result wrn Error.Error [Commented a]
35+collapseComments listWithComments =
36+ case listWithComments of
37+ [] ->
38+ Result.ok []
39+
40+ D.Comment msg : D.Whatever (A.A region a) : rest ->
41+ let
42+ entry =
43+ A.A (region, Just msg) a
44+ in
45+ fmap (entry:) (collapseComments rest)
46+
47+ D.Comment (A.A region _) : D.Comment _ : _ ->
48+ Result.throw region Error.CommentOnComment
49+
50+ [D.Comment (A.A region _)] ->
51+ Result.throw region Error.CommentOnNothing
52+
53+ D.Whatever (A.A region a) : rest ->
54+ let
55+ entry =
56+ A.A (region, Nothing) a
57+ in
58+ fmap (entry:) (collapseComments rest)
59+
60+
61+
62+-- EXTRACT DEFINES
63+
2564
65+data StructuredSource =
66+ Src
67+ { _decls :: [Commented D.Source']
68+ , _cmds :: Maybe [Commented Source.Effect]
69+ , _subs :: Maybe [Commented Source.Effect]
70+ }
2671
27−declarations
28− :: [D.SourceDecl]
29− -> Result.Result wrn Error.Error [D.ValidDecl]
72+
73+extractEffects :: [Commented D.SourceOrDefine] -> Result.Result wrn Error.Error StructuredSource
74+extractEffects commentedDecls =
75+ case commentedDecls of
76+ [] ->
77+ Result.ok (Src [] Nothing Nothing)
78+
79+ A.A ann (D.Source decl) : rest ->
80+ do restSrc <- extractEffects rest
81+ return $ restSrc { _decls = A.A ann decl : _decls restSrc }
82+
83+ A.A (region, _) (D.Define name commentOrEffects) : rest ->
84+ do restSrc <- extractEffects rest
85+ case name of
86+ "commands" ->
87+ case _cmds restSrc of
88+ Nothing ->
89+ do effects <- collapseComments commentOrEffects
90+ Result.ok $ restSrc { _cmds = Just effects }
91+
92+ Just _ ->
93+ Result.throw region (Error.DefineDuplicate name)
94+
95+ "subscriptions" ->
96+ case _subs restSrc of
97+ Nothing ->
98+ do effects <- collapseComments commentOrEffects
99+ Result.ok $ restSrc { _subs = Just effects }
100+
101+ Just _ ->
102+ Result.throw region (Error.DefineDuplicate name)
103+
104+ _ ->
105+ Result.throw region (Error.DefineUnknown name)
106+
107+
108+
109+-- VALIDATE STRUCTURED SOURCE
110+
111+
112+declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
30113declarations sourceDecls =
31− do validDecls <- validateDecls Nothing sourceDecls
114+ do (Src decls cmds subs) <-
115+ extractEffects =<< collapseComments sourceDecls
116+
117+ validDecls <-
118+ validateDecls decls
119+
120+ validCmds <-
121+ validateEffects (Maybe.fromMaybe [] cmds)
122+
123+ validSubs <-
124+ validateEffects (Maybe.fromMaybe [] subs)
125+
32126 (\_ _ -> validDecls)
33127 <$> declDuplicates validDecls
34128 <*> T.traverse checkDecl validDecls
35129
36130
131+
132+-- VALIDATE DECLARATIONS
133+
134+
37135validateDecls
38− :: Maybe String
39− -> [D.SourceDecl]
40− -> Result.Result wrn Error.Error [D.ValidDecl]
41−validateDecls maybeComment sourceDecls =
42− case sourceDecls of
136+ :: [Commented D.Source']
137+ -> Result.Result wrn Error.Error [D.Valid]
138+validateDecls commentedDecls =
139+ case commentedDecls of
43140 [] ->
44− return []
141+ Result.ok []
45142
46− sourceDecl : decls ->
47− case sourceDecl of
48− D.Comment comment ->
49− validateDecls (Just comment) decls
143+ A.A (region, maybeComment) decl : rest ->
144+ let
145+ addRest validDecl =
146+ let
147+ entry =
148+ A.A (region, fmap A.drop maybeComment) validDecl
149+ in
150+ fmap (entry:) (validateDecls rest)
151+ in
152+ case decl of
153+ D.Union name tvars ctors ->
154+ addRest (D.Union name tvars ctors)
50155
51− D.Decl decl ->
52− validateDeclsHelp maybeComment decl decls
156+ D.Alias name tvars alias ->
157+ addRest (D.Alias name tvars alias)
158+
159+ D.Fixity assoc prec op ->
160+ addRest (D.Fixity assoc prec op)
161+
162+ D.Def def ->
163+ validateDeclsHelp maybeComment def rest
53164
54165
55166validateDeclsHelp
56− :: Maybe String
57− -> A.Located D.SourceDecl'
58− -> [D.SourceDecl]
59− -> Result.Result wrn Error.Error [D.ValidDecl]
60−validateDeclsHelp comment (A.A region decl) decls =
61− let addRest validDecl =
62− (:) (A.A (region, comment) validDecl)
63− <$> validateDecls Nothing decls
167+ :: Maybe (A.Located String)
168+ -> Source.Def
169+ -> [Commented D.Source']
170+ -> Result.Result wrn Error.Error [D.Valid]
171+validateDeclsHelp maybeComment (A.A region def) decls =
172+ let
173+ makeDef pat expr maybeType =
174+ D.Def (Valid.Definition pat expr maybeType)
175+
176+ ann =
177+ (region, fmap A.drop maybeComment)
64178 in
65− case decl of
66− D.Datatype name tvars ctors ->
67− addRest (D.Datatype name tvars ctors)
179+ case def of
180+ Source.Definition pat expr ->
181+ (:)
182+ <$> validateDef makeDef ann pat expr Nothing
183+ <*> validateDecls decls
184+
185+ Source.Annotation name tipe ->
186+ case decls of
187+ A.A (_, Just (A.A commentRegion _)) _ : _ ->
188+ Result.throw commentRegion (Error.CommentAfterAnnotation name)
68189
69− D.TypeAlias name tvars alias ->
70− addRest (D.TypeAlias name tvars alias)
190+ A.A _ (D.Def (A.A _ (Source.Definition pat expr))) : rest
191+ | Pattern.isVar name pat ->
192+ (:)
193+ <$> validateDef makeDef ann pat expr (Just tipe)
194+ <*> validateDecls rest
71195
72− D.Fixity assoc prec op ->
73− addRest (D.Fixity assoc prec op)
196+ _ ->
197+ Result.throw region (Error.TypeWithoutDefinition name)
74198
75− D.Definition def ->
76− defHelp comment def decls
77199
78200
201+-- VALIDATE EFFECTS
79202
80−-- VALIDATE DEFINITIONS IN DECLARATIONS
81203
204+validateEffects
205+ :: [Commented Source.Effect]
206+ -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
207+validateEffects effects =
208+ case effects of
209+ [] ->
210+ Result.ok []
82211
83−defHelp
84− :: Maybe String
85− -> Source.Def
86− -> [D.SourceDecl]
87− -> Result.Result wrn Error.Error [D.ValidDecl]
88−defHelp comment (A.A region def) decls =
89− let addRest def' rest =
90− (:) (A.A (region, comment) (D.Definition def'))
91− <$> validateDecls Nothing rest
92− in
93− case def of
94− Source.Definition pat expr ->
95− do expr' <- expression expr
96− let def' = Valid.Definition pat expr' Nothing
97− checkDefinition def'
98− addRest def' decls
99−
100− Source.TypeAnnotation name tipe ->
101− case decls of
102− D.Decl (A.A _ (D.Definition (A.A _
103− (Source.Definition pat@(A.A _ (Pattern.Var name')) expr)))) : rest
104− | name == name' ->
105− do expr' <- expression expr
106− let def' = Valid.Definition pat expr' (Just tipe)
107− checkDefinition def'
108− addRest def' rest
212+ A.A (region, maybeComment) effect : rest ->
213+ validateEffectsHelp (region, fmap A.drop maybeComment) effect rest
109214
110− _ ->
111− Result.throw region (Error.TypeWithoutDefinition name)
215+
216+validateEffectsHelp
217+ :: (R.Region, Maybe String)
218+ -> Source.Effect
219+ -> [Commented Source.Effect]
220+ -> Result.Result wrn Error.Error [A.Commented Valid.Effect]
221+validateEffectsHelp ann effect remainingEffects =
222+ case effect of
223+ Source.With _ _ ->
224+ Result.throw (fst ann) (error "TODO")
225+
226+ Source.Def pat expr ->
227+ (:)
228+ <$> validateDef Valid.Def ann pat expr Nothing
229+ <*> validateEffects remainingEffects
230+
231+ Source.Type name tipe ->
232+ case remainingEffects of
233+ A.A (_, Just (A.A commentRegion _)) _ : _ ->
234+ Result.throw commentRegion (Error.CommentAfterAnnotation name)
235+
236+ A.A _ (Source.Def pat expr) : rest
237+ | Pattern.isVar name pat ->
238+ (:)
239+ <$> validateDef Valid.Def ann pat expr (Just tipe)
240+ <*> validateEffects rest
241+
242+ _ ->
243+ Result.throw (fst ann) (Error.TypeWithoutDefinition name)
112244
113245
114246
@@ -127,29 +259,40 @@ definitionsHelp :: [Source.Def] -> Result.Result wrn Error.Error [Valid.Def]
127259definitionsHelp sourceDefs =
128260 case sourceDefs of
129261 [] ->
130− return []
131−
132− A.A _ (Source.Definition pat expr) : rest ->
133− do expr' <- expression expr
134− let def = Valid.Definition pat expr' Nothing
135− checkDefinition def
136− (:) def <$> definitionsHelp rest
137−
138− A.A region (Source.TypeAnnotation name tipe) : rest ->
139− case rest of
140− A.A _ (Source.Definition pat@(A.A _ (Pattern.Var name')) expr) : rest'
141− | name == name' ->
142− do expr' <- expression expr
143− let def = Valid.Definition pat expr' (Just tipe)
144− checkDefinition def
145− (:) def <$> definitionsHelp rest'
146−
147− _ ->
148− Result.throw region (Error.TypeWithoutDefinition name)
149−
150−
151−checkDefinition :: Valid.Def -> Result.Result wrn Error.Error ()
152−checkDefinition (Valid.Definition pattern body _) =
262+ return []
263+
264+ A.A region (Source.Definition pat expr) : rest ->
265+ (:)
266+ <$> fmap A.drop (validateDef Valid.Definition region pat expr Nothing)
267+ <*> definitionsHelp rest
268+
269+ A.A r1 (Source.Annotation name tipe) : rest ->
270+ case rest of
271+ A.A r2 (Source.Definition pat expr) : rest'
272+ | Pattern.isVar name pat ->
273+ (:)
274+ <$> fmap A.drop (validateDef Valid.Definition (R.merge r1 r2) pat expr (Just tipe))
275+ <*> definitionsHelp rest'
276+
277+ _ ->
278+ Result.throw r1 (Error.TypeWithoutDefinition name)
279+
280+
281+validateDef
282+ :: (Pattern.Raw -> Valid.Expr -> Maybe Type.Raw -> def)
283+ -> annotation
284+ -> Pattern.Raw
285+ -> Source.Expr
286+ -> Maybe Type.Raw
287+ -> Result.Result wrn Error.Error (A.Annotated annotation def)
288+validateDef makeDef annotation pat expr maybeType =
289+ do validExpr <- expression expr
290+ validateDefPattern pat validExpr
291+ return $ A.A annotation (makeDef pat validExpr maybeType)
292+
293+
294+validateDefPattern :: Pattern.Raw -> Valid.Expr -> Result.Result wrn Error.Error ()
295+validateDefPattern pattern body =
153296 case fst (Expr.collectLambdas body) of
154297 [] ->
155298 return ()
@@ -265,7 +408,7 @@ both (expr1, expr2) =
265408-- VALIDATE PATTERNS
266409
267410
268−validatePattern :: Pattern.RawPattern -> Result.Result wrn Error.Error Pattern.RawPattern
411+validatePattern :: Pattern.Raw -> Result.Result wrn Error.Error Pattern.Raw
269412validatePattern pattern =
270413 do detectDuplicates Error.BadPattern (Pattern.boundVars pattern)
271414 return pattern
@@ -297,15 +440,13 @@ detectDuplicates tag names =
297440 F.traverse_ check (makeGroups names)
298441
299442
300−defDuplicates
301− :: [Pattern.RawPattern]
302− -> Result.Result wrn Error.Error ()
443+defDuplicates :: [Pattern.Raw] -> Result.Result wrn Error.Error ()
303444defDuplicates patterns =
304445 concatMap Pattern.boundVars patterns
305446 |> detectDuplicates Error.DuplicateDefinition
306447
307448
308−declDuplicates :: [D.ValidDecl] -> Result.Result wrn Error.Error ()
449+declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
309450declDuplicates decls =
310451 let (valueLists, typeLists) = unzip (map extractValues decls)
311452 in
@@ -314,25 +455,25 @@ declDuplicates decls =
314455 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
315456
316457
317−extractValues :: D.ValidDecl -> ([A.Located String], [A.Located String])
458+extractValues :: D.Valid -> ([A.Located String], [A.Located String])
318459extractValues (A.A (region, _) decl) =
319460 case decl of
320− D.Definition (Valid.Definition pattern _ _) ->
461+ D.Def (Valid.Definition pattern _ _) ->
321462 ( Pattern.boundVars pattern
322463 , []
323464 )
324465
325− D.Datatype name _ ctors ->
466+ D.Union name _ ctors ->
326467 ( map (A.A region . fst) ctors
327468 , [A.A region name]
328469 )
329470
330− D.TypeAlias name _ (A.A _ (Type.RRecord _ _)) ->
471+ D.Alias name _ (A.A _ (Type.RRecord _ _)) ->
331472 ( [A.A region name]
332473 , [A.A region name]
333474 )
334475
335− D.TypeAlias name _ _ ->
476+ D.Alias name _ _ ->
336477 ( []
337478 , [A.A region name]
338479 )
@@ -347,13 +488,13 @@ extractValues (A.A (region, _) decl) =
347488-- UNBOUND TYPE VARIABLES
348489
349490
350−checkDecl :: D.ValidDecl -> Result.Result wrn Error.Error ()
491+checkDecl :: D.Valid -> Result.Result wrn Error.Error ()
351492checkDecl (A.A (region,_) decl) =
352493 case decl of
353− D.Definition _ ->
494+ D.Def _ ->
354495 return ()
355496
356− D.Datatype name boundVars ctors ->
497+ D.Union name boundVars ctors ->
357498 case diff boundVars (concatMap freeVars (concatMap snd ctors)) of
358499 (_, []) ->
359500 return ()
@@ -362,7 +503,7 @@ checkDecl (A.A (region,_) decl) =
362503 Result.throw region
363504 (Error.UnboundTypeVarsInUnion name boundVars unbound)
364505
365− D.TypeAlias name boundVars tipe ->
506+ D.Alias name boundVars tipe ->
366507 case diff boundVars (freeVars tipe) of
367508 ([], []) ->
368509 return ()
@@ -400,20 +541,20 @@ diff left right =
400541
401542freeVars :: Type.Raw -> [A.Located String]
402543freeVars (A.A region tipe) =
403− case tipe of
404− Type.RLambda t1 t2 ->
405− freeVars t1 ++ freeVars t2
544+ case tipe of
545+ Type.RLambda t1 t2 ->
546+ freeVars t1 ++ freeVars t2
406547
407− Type.RVar x ->
408− [A.A region x]
548+ Type.RVar x ->
549+ [A.A region x]
409550
410− Type.RType _ ->
411− []
551+ Type.RType _ ->
552+ []
412553
413− Type.RApp t ts ->
414− concatMap freeVars (t:ts)
554+ Type.RApp t ts ->
555+ concatMap freeVars (t:ts)
415556
416− Type.RRecord fields ext ->
417− maybe [] freeVars ext
418− ++ concatMap (freeVars . snd) fields
557+ Type.RRecord fields ext ->
558+ maybe [] freeVars ext
559+ ++ concatMap (freeVars . snd) fields
419560