@@ -1,13 +1,14 @@
11{-# OPTIONS_GHC -Wall #-}
22module Validate (module') where
33
4−import Control.Monad (foldM)
4+import Control.Monad (foldM, when)
55import qualified Data.Map as Map
66import qualified Data.Set as Set
77import qualified Data.Foldable as F
88import qualified Data.Traversable as T
99
1010import AST.Expression.General as Expr
11+import qualified AST.Effects as Fx
1112import qualified AST.Expression.Source as Source
1213import qualified AST.Expression.Valid as Valid
1314import qualified AST.Declaration as D
@@ -61,19 +62,28 @@ addDefaults pkgName imports =
6162validateModuleDecl
6263 :: Module.SourceTag
6364 -> Module.SourceSettings
64− -> Result.Result wrn Error.Error Module.ValidEffects
65−validateModuleDecl tag settings =
65+ -> Result.Result wrn Error.Error Fx.Effects
66+validateModuleDecl tag settings@(A.A _ pairs) =
6667 case tag of
67− Module.SrcNormal ->
68+ Module.Normal ->
6869 do noSettings Error.SettingsOnNormalModule settings
69− return Module.ValidNormal
70+ return Fx.None
7071
71− Module.SrcForeign ->
72+ Module.Foreign _ ->
7273 do noSettings Error.SettingsOnForeignModule settings
73− return Module.ValidForeign
74+ return Fx.Foreign
7475
75− Module.SrcEffect ->
76− gatherEffectSettings settings
76+ Module.Effect tagRegion ->
77+ let
78+ collectSettings (A.A region setting, userValue) dict =
79+ Map.insertWith (++) setting [(region, userValue)] dict
80+
81+ settingsDict =
82+ foldr collectSettings Map.empty pairs
83+ in
84+ do managerType <- toManagerType tagRegion settingsDict
85+ return $ Fx.Effect $
86+ Fx.Info tagRegion (error "TODO") (error "TODO") (error "TODO") managerType
7787
7888
7989noSettings
@@ -89,47 +99,59 @@ noSettings errorMsg (A.A region settings) =
8999 Result.throw region errorMsg
90100
91101
92−gatherEffectSettings
93− :: Module.SourceSettings
94− -> Result.Result wrn Error.Error Module.ValidEffects
95−gatherEffectSettings (A.A _ pairs) =
96− uncurry Module.ValidEffect <$>
97− gatherEffectSettingsHelp (Nothing, Nothing) pairs
102+toManagerType
103+ :: R.Region
104+ -> Map.Map String [(R.Region, A.Located String)]
105+ -> Result.Result wrn Error.Error Fx.ManagerType
106+toManagerType tagRegion settingsDict =
107+ let
108+ toErrors name entries =
109+ map (\entry -> A.A (fst entry) (Error.BadSettingOnEffectModule name)) entries
110+
111+ errors =
112+ settingsDict
113+ |> Map.delete "command"
114+ |> Map.delete "subscription"
115+ |> Map.mapWithKey toErrors
116+ |> Map.elems
117+ |> concat
118+ in
119+ do when (not (null errors)) (Result.throwMany errors)
120+ maybeEffects <-
121+ (,) <$> extractOne "command" settingsDict
122+ <*> extractOne "subscription" settingsDict
98123
124+ case maybeEffects of
125+ (Nothing, Nothing) ->
126+ Result.throw tagRegion Error.NoSettingsOnEffectModule
99127
100−type Effects =
101− (Maybe (A.Located String), Maybe (A.Located String))
128+ (Just cmd, Nothing) ->
129+ return (Fx.CmdManager cmd)
102130
131+ (Nothing, Just sub) ->
132+ return (Fx.SubManager sub)
103133
104−gatherEffectSettingsHelp
105− :: Effects
106− -> [(A.Located String, A.Located String)]
107− -> Result.Result wrn Error.Error Effects
108−gatherEffectSettingsHelp effects@(maybeCmd, maybeSub) pairs =
109− case pairs of
110− [] ->
111− Result.ok effects
134+ (Just cmd, Just sub) ->
135+ return (Fx.FxManager cmd sub)
112136
113− (A.A region name, effect) : rest ->
114− case name of
115− "command" ->
116− case maybeCmd of
117− Nothing ->
118− gatherEffectSettingsHelp (Just effect, maybeSub) rest
119137
120− Just _ ->
121− Result.throw region (Error.DuplicateSettingOnEffectModule name)
138+extractOne
139+ :: String
140+ -> Map.Map String [(R.Region, A.Located String)]
141+ -> Result.Result w Error.Error (Maybe (A.Located String))
142+extractOne name settingsDict =
143+ case Map.lookup name settingsDict of
144+ Nothing ->
145+ return Nothing
122146
123− "subscription" ->
124− case maybeSub of
125− Nothing ->
126− gatherEffectSettingsHelp (maybeCmd, Just effect) rest
147+ Just [] ->
148+ error "Empty lists should never be added to the dictionary of effect module settings."
127149
128− Just _ ->
129− Result.throw region (Error.DuplicateSettingOnEffectModule name)
150+ Just [(_, userType)] ->
151+ return (Just userType)
130152
131− _ ->
132− Result.throw region (Error.BadSettingOnEffectModule name)
153+ Just ((region, _) : _) ->
154+ Result.throw region (Error.DuplicateSettingOnEffectModule name)
133155
134156
135157
@@ -407,6 +429,9 @@ expression (A.A ann sourceExpression) =
407429 Sub moduleName typeName ->
408430 return (Sub moduleName typeName)
409431
432+ SaveEnv moduleName effects ->
433+ return (SaveEnv moduleName effects)
434+
410435 GLShader uid src gltipe ->
411436 return (GLShader uid src gltipe)
412437