never executed always true always false
1 {-# LANGUAGE TupleSections #-}
2
3 module Conjure.Process.Enums
4 ( removeEnumsFromModel
5 , removeEnumsFromParam
6 , addEnumsAndUnnamedsBack
7 ) where
8
9 import Conjure.Prelude
10 import Conjure.Bug
11 import Conjure.UserError
12 import Conjure.Language.Definition
13 import Conjure.Language.Domain
14 import Conjure.Language.Constant
15 import Conjure.Language.Pretty
16 import Conjure.Language.Type
17
18 -- text
19 import Data.Text as T ( pack )
20
21 -- unordered-containers
22 import qualified Data.HashMap.Strict as M
23
24
25 -- | The argument is a model before nameResolution.
26 -- Only intended to work on problem specifications.
27 removeEnumsFromModel ::
28 MonadFailDoc m =>
29 MonadLog m =>
30 MonadUserError m =>
31 Model -> m Model
32 removeEnumsFromModel =
33 preCheckForNameReuse >=>
34 removeEnumsFromModel_LettingEnums >=>
35 removeEnumsFromModel_GivenEnums >=>
36 checkEnums
37
38 where
39
40 -- check if names defined as part of enumerated types are later used as names of top-level or quantified declarations
41 preCheckForNameReuse model = do
42 let enumNames = concat [ names | Declaration (LettingDomainDefnEnum _ names) <- mStatements model ]
43 let redefinedTopLevel = [ name | Declaration (FindOrGiven _ name _) <- mStatements model, name `elem` enumNames ]
44 let redefinedQuantified = [ name | Generator gen <- universeBi (mStatements model)
45 , name@Name{} <- case gen of
46 GenDomainNoRepr defn _ -> universeBi defn
47 GenDomainHasRepr defn _ -> universeBi defn
48 GenInExpr defn _ -> universeBi defn
49 , name `elem` enumNames ]
50 let redefined = redefinedTopLevel ++ redefinedQuantified
51 let duplicates = [ name | (name, count) <- histogram enumNames, count > 1 ]
52 unless (null duplicates) $ userErr1 $ "Enumerated value defined multiple times:" <+> prettyList id "," duplicates
53 unless (null redefined) $ userErr1 $ vcat
54 [ "Members of an enum domain are later redefined as top-level or quantified variables."
55 , "Check:" <+> prettyList id "," redefined
56 ]
57 return model
58
59 removeEnumsFromModel_LettingEnums model = do
60 (statements', ( enumDomainNames :: [(Name, Domain () Expression)]
61 , nameToIntMapping_ :: [(Name, (Name, Integer))]
62 )) <-
63 flip runStateT ([], []) $ forM (mStatements model) $ \ st ->
64 case st of
65 Declaration (LettingDomainDefnEnum ename@(Name enameText) names) -> do
66 namesBefore <- gets (map fst . snd)
67 let outDomain = mkDomainIntBTagged (TagEnum enameText)
68 (fromIntWithTag 1 (TagEnum enameText))
69 (fromIntWithTag (genericLength names) (TagEnum enameText))
70 case names `intersect` namesBefore of
71 [] -> modify ( ( [(ename, outDomain)]
72 , zip names (map (ename,) allNats)
73 ) `mappend` )
74 repeated -> userErr1 $ vcat
75 [ "Some members of this enum domain (" <> pretty ename <> ") seem to be defined"
76 , "as part of other enum domains."
77 , "Repeated:" <+> prettyList id "," repeated
78 , "While working on domain:" <+> pretty st
79 ]
80 return [ Declaration (Letting (ename `mappend` "_EnumSize") (fromInt $ genericLength names))
81 , Declaration (Letting ename (Domain outDomain))
82 ]
83 _ -> return [st]
84
85 let nameToIntMapping = M.fromList nameToIntMapping_
86
87 let
88 onX :: Monad m => Expression -> m Expression
89 onX (Reference nm Nothing)
90 | Just (Name ename, i) <- M.lookup nm nameToIntMapping
91 = return (fromIntWithTag i (TagEnum ename))
92 onX p = return p
93
94 onD :: MonadFailDoc m => Domain () Expression -> m (Domain () Expression)
95 onD (DomainEnum nm@(Name nmText) (Just ranges) _)
96 | Just _ <- lookup nm enumDomainNames
97 = DomainInt (TagEnum nmText) <$> mapM (mapM (nameToX nameToIntMapping)) ranges
98 onD (DomainEnum nm Nothing _)
99 | Just d <- lookup nm enumDomainNames
100 = return (DomainReference nm (Just d))
101 onD (DomainReference nm Nothing)
102 | Just d <- lookup nm enumDomainNames
103 = return (DomainReference nm (Just d))
104 onD p = return p
105
106 statements'' <- (transformBiM onD >=> transformBiM onX) statements'
107 return model { mStatements = concat statements'' }
108
109 removeEnumsFromModel_GivenEnums model = do
110 (statements', enumDomainNames) <-
111 flip runStateT [] $ forM (mStatements model) $ \ st ->
112 case st of
113 Declaration (GivenDomainDefnEnum name@(Name nameText)) -> do
114 let nameS = name `mappend` "_EnumSize"
115 let outDomainS = DomainInt (TagEnum nameText) []
116 let outDomain = mkDomainIntBTagged (TagEnum nameText)
117 (fromIntWithTag 1 (TagEnum nameText))
118 (Reference nameS (Just (Alias (Domain outDomainS))))
119 modify ([(name, outDomain)] `mappend`)
120 return [ Declaration (FindOrGiven Given nameS outDomainS)
121 , Declaration (Letting name (Domain outDomain))
122 ]
123 _ -> return [st]
124
125 let
126
127 onD :: Domain () Expression -> Domain () Expression
128 onD (DomainEnum nm@(Name nmText) (Just ranges) _)
129 | Just _ <- lookup nm enumDomainNames
130 = DomainInt (TagEnum nmText) ranges
131 onD (DomainEnum nm Nothing _)
132 | Just d <- lookup nm enumDomainNames
133 = DomainReference nm (Just d)
134 onD (DomainReference nm Nothing)
135 | Just d <- lookup nm enumDomainNames
136 = DomainReference nm (Just d)
137 onD p = p
138
139
140 let model' = model { mStatements = concat statements'
141 |> transformBi onD
142 }
143
144 logDebug $ "Recording enumGivens:" <+> prettyList id "," (map fst enumDomainNames)
145
146 return model'
147
148 checkEnums model = do
149 let
150 leftovers :: [Domain () Expression]
151 leftovers = [ d | d@DomainEnum{} <- universeBi (mStatements model) ]
152 unless (null leftovers) $ bug $ vcat
153 $ "Could not remove some enum domains:"
154 : map (nest 4 . pretty) leftovers
155 return model
156
157
158 removeEnumsFromParam
159 :: (MonadFailDoc m, MonadUserError m)
160 => Model -> Model -> m (Model, Model)
161 removeEnumsFromParam model param = do
162 let allStatements = map (False,) (map Declaration (miEnumLettings (mInfo model)))
163 ++ map (True,) (mStatements param)
164
165 (statements', (enumDomainNames_, nameToIntMapping_)) <-
166 flip runStateT ([], []) $ forM allStatements $ \ (keep,st) ->
167 case st of
168 Declaration (LettingDomainDefnEnum ename@(Name enameText) names) -> do
169 namesBefore <- gets (map fst . snd)
170 let outDomain = mkDomainIntBTagged (TagEnum enameText)
171 (fromIntWithTag 1 (TagEnum enameText))
172 (fromIntWithTag (genericLength names) (TagEnum enameText))
173 case names `intersect` namesBefore of
174 [] -> modify ( ( [(ename, outDomain)]
175 , zip names (zip (cycle [ename]) allNats)
176 ) `mappend` )
177 repeated -> userErr1 $ vcat
178 [ "Some members of this enum domain (" <> pretty ename <> ") seem to be defined"
179 , "as part of other enum domains."
180 , "Repeated:" <+> prettyList id "," repeated
181 , "While working on domain:" <+> pretty st
182 ]
183 return (Just (Declaration (Letting ename (Domain outDomain))))
184 _ -> return (if keep then Just st else Nothing)
185
186 let enumDomainNames = M.fromList enumDomainNames_
187 let nameToIntMapping = M.fromList nameToIntMapping_
188
189 let
190 onX :: Monad m => Expression -> m Expression
191 onX (Reference nm Nothing)
192 | Just (Name ename, i) <- M.lookup nm nameToIntMapping
193 = return (fromIntWithTag i (TagEnum ename))
194 onX p = return p
195
196 onC :: Monad m => Constant -> m Constant
197 onC (ConstantEnum _ _ nm)
198 | Just (Name ename, i) <- M.lookup nm nameToIntMapping
199 = return (fromIntWithTag i (TagEnum ename))
200 onC p = return p
201
202 onD :: MonadFailDoc m => Domain () Expression -> m (Domain () Expression)
203 onD (DomainEnum nm@(Name nmText) (Just ranges) _)
204 | Just _ <- M.lookup nm enumDomainNames
205 = DomainInt (TagEnum nmText) <$> mapM (mapM (nameToX nameToIntMapping)) ranges
206 onD (DomainEnum nm Nothing _)
207 | Just d <- M.lookup nm enumDomainNames
208 = return (DomainReference nm (Just d))
209 onD (DomainReference nm Nothing)
210 | Just d <- M.lookup nm enumDomainNames
211 = return (DomainReference nm (Just d))
212 onD p = return p
213
214 let param' = param { mStatements = catMaybes statements' }
215 let f = transformBiM onD >=> transformBiM onX >=> transformBiM onC
216 (,) <$> f model <*> f param'
217
218
219 -- | Using the original domains from the Essence file.
220 -- Converting integers back to enum constants.
221 -- TODO: complete addEnumsAndUnnamedsBack
222
223 addEnumsAndUnnamedsBack
224 :: ( Pretty r, Pretty x )
225 => [Name] -- unnamed types
226 -> M.HashMap (Integer, Name) Constant -- a lookup table for enums
227 -> Domain r x -- the domain we are working on
228 -> Constant -- the constant with ints in place of enums & unnameds
229 -> Constant -- the constant with enums & unnameds again
230 addEnumsAndUnnamedsBack unnameds ctxt = helper
231
232 where
233
234 helper domain constant = case (domain, constant) of
235
236 (_, TypedConstant c _) -> helper domain c
237
238 (_, c@ConstantUndefined{}) -> c
239
240 (DomainBool , c) -> c
241 (DomainIntE{}, c) -> c
242 (DomainInt{} , c) -> c
243
244 (DomainEnum ename _ _, ConstantInt _ i) ->
245 fromMaybe (bug $ "addEnumsAndUnnamedsBack 1:" <+> pretty (i, ename))
246 (M.lookup (i, ename) ctxt)
247
248 (DomainReference ename _ , ConstantInt _ i) ->
249 if ename `elem` unnameds
250 then ConstantEnum ename [] (mconcat [ename, "_", Name (T.pack (show i))])
251 else bug $ "addEnumsAndUnnamedsBack Unnamed:" <++> vcat [ "domain :" <+> pretty domain
252 , "constant:" <+> pretty constant
253 ]
254
255 (DomainTuple ds, viewConstantTuple -> Just cs) ->
256 ConstantAbstract $ AbsLitTuple
257 [ helper d c
258 | (d,c) <- zip ds cs ]
259
260 (DomainRecord (sortOn fst -> ds), viewConstantRecord -> Just cs) ->
261 ConstantAbstract $ AbsLitRecord
262 [ (n, helper d c)
263 | ((n,d),(_,c)) <- zip ds cs ]
264
265 (DomainVariant ds, viewConstantVariant -> Just (t, n, c)) ->
266 case lookup n ds of
267 Nothing -> bug $ "addEnumsAndUnnamedsBack Variant:" <++> vcat [ "domain :" <+> pretty domain
268 , "constant:" <+> pretty constant
269 ]
270 Just d -> ConstantAbstract $ AbsLitVariant t n (helper d c)
271
272 (DomainMatrix _ inner, viewConstantMatrix -> Just (index, vals)) ->
273 ConstantAbstract $ AbsLitMatrix index $ map (helper inner) vals
274
275 (DomainSet _ _ inner, viewConstantSet -> Just vals) ->
276 ConstantAbstract $ AbsLitSet $ map (helper inner) vals
277
278 (DomainMSet _ _ inner, viewConstantMSet -> Just vals) ->
279 ConstantAbstract $ AbsLitMSet $ map (helper inner) vals
280
281 (DomainFunction _ _ fr to, viewConstantFunction -> Just vals) ->
282 ConstantAbstract $ AbsLitFunction
283 [ (helper fr a, helper to b)
284 | (a,b) <- vals ]
285
286 (DomainSequence _ _ inner, viewConstantSequence -> Just vals) ->
287 ConstantAbstract $ AbsLitSequence $ map (helper inner) vals
288
289 (DomainRelation _ _ inners, viewConstantRelation -> Just vals) ->
290 ConstantAbstract $ AbsLitRelation
291 [ [ helper d c | (d,c) <- zip inners line ]
292 | line <- vals ]
293
294 (DomainPartition _ _ inner, viewConstantPartition -> Just vals) ->
295 ConstantAbstract $ AbsLitPartition
296 [ [ helper inner c | c <- line ]
297 | line <- vals ]
298
299 (DomainPermutation _ _ inner, ConstantAbstract (AbsLitPermutation vals)) ->
300 ConstantAbstract $ AbsLitPermutation
301 [ [helper inner c | c <- line ]
302 | line <- vals]
303 _ -> bug ("addEnumsAndUnnamedsBack 3:" <++> vcat [ "domain :" <+> pretty domain
304 , "constant:" <+> pretty constant
305 , "domain :" <+> pretty (show domain)
306 , "constant:" <+> pretty (show constant)
307 ])
308
309 -- first Name is the value, the second Name is the name of the enum domain
310 nameToX :: MonadFailDoc m => M.HashMap Name (Name, Integer) -> Expression -> m Expression
311 nameToX nameToIntMapping (Reference nm _) = case M.lookup nm nameToIntMapping of
312 Nothing -> failDoc (pretty nm <+> "is used in a domain, but it isn't a member of the enum domain.")
313 Just (Name ename, i) -> return (fromIntWithTag i (TagEnum ename))
314 Just (ename, i) -> bug $ "nameToX, nm:" <+> vcat [pretty (show ename), pretty i]
315 nameToX _ x = return x