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