@@ -1,7 +1,6 @@
11{-# OPTIONS_GHC -Wall #-}
22module Validate (declarations) where
33
4−import qualified Control.Arrow as Arrow
54import Control.Monad (foldM)
65import qualified Data.Map as Map
76import qualified Data.Set as Set
@@ -12,7 +11,6 @@ import AST.Expression.General as Expr
1211import qualified AST.Expression.Source as Source
1312import qualified AST.Expression.Valid as Valid
1413import qualified AST.Declaration as D
15−import qualified AST.Module as Module
1614import qualified AST.Pattern as Pattern
1715import qualified AST.Type as Type
1816import Elm.Utils ((|>))
@@ -60,148 +58,21 @@ collapseComments listWithComments =
6058
6159
6260
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−
18461-- VALIDATE STRUCTURED SOURCE
18562
18663
187−declarations
188− :: Module.Tag
189− -> [D.Source]
190− -> Result.Result wrn Error.Error ([D.Valid], Valid.Effects)
191−declarations tag sourceDecls =
192− do (decls, defines) <-
193− partitionEffects <$> collapseComments sourceDecls
64+declarations :: [D.Source] -> Result.Result wrn Error.Error [D.Valid]
65+declarations sourceDecls =
66+ do decls <-
67+ collapseComments sourceDecls
19468
19569 validDecls <-
19670 validateDecls decls
19771
198− validEffects <-
199− validateDefines tag defines
200−
20172 F.traverse_ id
202− (declDuplicates validDecls validEffects : map findBadTypeVars validDecls)
73+ (declDuplicates validDecls : map findBadTypeVars validDecls)
20374
204− return (validDecls, validEffects)
75+ return validDecls
20576
20677
20778
@@ -274,86 +145,6 @@ validateDeclsHelp maybeComment (A.A region def) decls =
274145
275146
276147
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−
357148-- VALIDATE DEFINITIONS
358149
359150
@@ -556,17 +347,14 @@ defDuplicates patterns =
556347 |> detectDuplicates Error.DuplicateDefinition
557348
558349
559−declDuplicates :: [D.Valid] -> Valid.Effects -> Result.Result wrn Error.Error ()
560−declDuplicates decls effects =
350+declDuplicates :: [D.Valid] -> Result.Result wrn Error.Error ()
351+declDuplicates decls =
561352 let
562353 (valueLists, typeLists) =
563354 unzip (map extractValues decls)
564−
565− effectValues =
566− extractEffectValues effects
567355 in
568356 (\_ _ -> ())
569− <$> detectDuplicates Error.DuplicateValueDeclaration (effectValues ++ concat valueLists)
357+ <$> detectDuplicates Error.DuplicateValueDeclaration (concat valueLists)
570358 <*> detectDuplicates Error.DuplicateTypeDeclaration (concat typeLists)
571359
572360
@@ -599,36 +387,6 @@ extractValues (A.A (region, _) decl) =
599387 )
600388
601389
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−
632390
633391-- UNBOUND TYPE VARIABLES
634392