never executed always true always false
1 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
2
3 module Conjure.Language.Constant
4 ( Constant(..)
5 , valuesInIntDomain
6 , normaliseConstant
7 , mkUndef, isUndef
8 , emptyCollection
9 , viewConstantBool
10 , viewConstantInt
11 , viewConstantIntWithTag
12 , viewConstantTuple
13 , viewConstantRecord
14 , viewConstantVariant
15 , viewConstantMatrix
16 , viewConstantSet
17 , viewConstantMSet
18 , viewConstantFunction
19 , viewConstantSequence
20 , viewConstantRelation
21 , viewConstantPartition
22 , viewConstantPermutation
23 , reDomConst
24 ) where
25
26 -- conjure
27 import Conjure.Prelude
28 import Conjure.Bug
29 import Conjure.Language.Name
30 import Conjure.Language.Domain
31 import Conjure.Language.Type
32 import Conjure.Language.AbstractLiteral
33
34 import Conjure.Language.DomainSizeOf
35 import Conjure.Language.TypeOf
36 import Conjure.Language.AdHoc
37 import Conjure.Language.Pretty
38
39 -- base
40 import Data.Data ( toConstr, constrIndex )
41
42 -- QuickCheck
43 import Test.QuickCheck ( Arbitrary(..), oneof )
44
45 -- aeson
46 import qualified Data.Aeson as JSON
47 import Data.Aeson.Key (toText)
48 import qualified Data.Aeson.KeyMap as KM
49
50 import qualified Data.Vector as V -- vector
51
52
53 data Constant
54 = ConstantBool Bool
55 | ConstantInt IntTag Integer
56 | ConstantEnum Name {- name for the enum domain -}
57 [Name] {- values in the enum domain -}
58 Name {- the literal -}
59 | ConstantField Name Type -- the name of a field of Record or Variant and its type
60 | ConstantAbstract (AbstractLiteral Constant)
61 | DomainInConstant (Domain () Constant)
62 | TypedConstant Constant Type
63 | ConstantUndefined Text Type -- never use this for a bool
64 -- use false instead for them
65 deriving (Show, Data, Typeable, Generic)
66
67 instance Eq Constant where
68 a == b = compare a b == EQ
69
70 -- implementing the Eq&Ord instances by hand, because we want to special case the TypedConstant constructor
71 instance Ord Constant where
72
73 -- do not use type info when comparing
74 compare (TypedConstant a _) (TypedConstant b _) = compare a b
75 compare (TypedConstant a _) b = compare a b
76 compare a (TypedConstant b _) = compare a b
77
78 -- the "usual" comparisons
79 compare (ConstantBool a) (ConstantBool b) = compare a b
80 compare (ConstantInt _ a) (ConstantInt _ b) = compare a b
81 compare (ConstantEnum _ aVals aVal) (ConstantEnum _ bVals bVal) =
82 compare (elemIndex aVal aVals, aVal) (elemIndex bVal bVals, bVal)
83 compare (ConstantField a1 a2) (ConstantField b1 b2) = compare (a1,a2) (b1,b2)
84 compare (ConstantAbstract a) (ConstantAbstract b) = compare a b
85 compare (DomainInConstant a) (DomainInConstant b) = compare a b
86 compare (ConstantUndefined a1 a2) (ConstantUndefined b1 b2) = compare (a1,a2) (b1,b2)
87
88 -- if the constructors do not match
89 compare a b = compare (constrIndex (toConstr a)) (constrIndex (toConstr b))
90
91 instance Serialize Constant
92 instance Hashable Constant
93 instance ToJSON Constant where toJSON = genericToJSON jsonOptions
94 instance FromJSON Constant where parseJSON = genericParseJSON jsonOptions
95
96 instance SimpleJSON Constant where
97 toSimpleJSON c =
98 case c of
99 ConstantBool b -> return (toJSON b)
100 ConstantInt _ i -> return (toJSON i)
101 ConstantEnum _ _ nm -> return (toJSON (renderNormal nm))
102 ConstantAbstract lit -> toSimpleJSON lit
103 TypedConstant c' _ -> toSimpleJSON c'
104 _ -> noToSimpleJSON c
105
106 fromSimpleJSON _ (JSON.Bool b) = return (ConstantBool b)
107
108 fromSimpleJSON (TypeInt (TagEnum enum_type_name)) (JSON.String value) =
109 return (ConstantEnum (Name enum_type_name) [] (Name value))
110
111 fromSimpleJSON t@TypeInt{} x@JSON.Number{} = ConstantInt TagInt <$> fromSimpleJSON t x
112 fromSimpleJSON t@TypeInt{} x@JSON.String{} = ConstantInt TagInt <$> fromSimpleJSON t x
113
114 fromSimpleJSON (TypeEnum enum_type_name) (JSON.String value) =
115 return (ConstantEnum enum_type_name [] (Name value))
116
117 fromSimpleJSON (TypeTuple ts) (JSON.Array xs) =
118 ConstantAbstract . AbsLitTuple <$> zipWithM fromSimpleJSON ts (V.toList xs)
119
120 fromSimpleJSON t@(TypeVariant ts) x@(JSON.Object m) = do
121 mys <- forM (KM.toList m) $ \ (toText->name, value) -> do
122 let mty = [ ty | (nm, ty) <- ts, nm == Name name ]
123 case mty of
124 [ty] -> do
125 value' <- fromSimpleJSON ty value
126 return $ Just $ ConstantAbstract $ AbsLitVariant Nothing (Name name) value'
127 _ -> return Nothing
128 let ys = catMaybes mys
129 case ys of
130 [y] -> return y
131 _ -> noFromSimpleJSON "Constant" t x
132
133 fromSimpleJSON t@(TypeRecord ts) x@(JSON.Object m) = do
134 mys <- forM (KM.toList m) $ \ (toText->name, value) -> do
135 let mty = [ ty | (nm, ty) <- ts, nm == Name name ]
136 case mty of
137 [ty] -> do
138 value' <- fromSimpleJSON ty value
139 return $ Just (Name name, value')
140 _ -> return Nothing
141 let ys = catMaybes mys
142 if length ys == length mys
143 then return $ ConstantAbstract $ AbsLitRecord ys
144 else noFromSimpleJSON "Constant" t x
145
146 fromSimpleJSON (TypeMatrix index inner) (JSON.Object m) = do
147 ys <- forM (KM.toList m) $ \ (toText->name, value) -> do
148 -- the name must be an integer
149 a <- fromSimpleJSON index (JSON.String name)
150 b <- fromSimpleJSON inner value
151 return (a, b)
152 -- traceM $ show ys
153 -- traceM $ show $ sort ys
154
155 let ys_sorted = sort ys
156 let domain_ints = map fst ys_sorted
157 let domain = if maximum domain_ints - minimum domain_ints + 1 == genericLength domain_ints
158 then DomainInt TagInt [RangeBounded (ConstantInt TagInt $ minimum domain_ints) (ConstantInt TagInt $ maximum domain_ints)]
159 else DomainInt TagInt (map (RangeSingle . ConstantInt TagInt) domain_ints)
160
161 return $ ConstantAbstract $ AbsLitMatrix domain (map snd ys_sorted)
162
163 fromSimpleJSON (TypeMatrix _index inner) (JSON.Array xs) =
164 let domain = DomainInt TagInt [RangeBounded 1 (fromInt $ genericLength $ V.toList xs)] in
165 ConstantAbstract . AbsLitMatrix domain <$> mapM (fromSimpleJSON inner) (V.toList xs)
166
167 fromSimpleJSON (TypeSet t) (JSON.Array xs) =
168 ConstantAbstract . AbsLitSet <$> mapM (fromSimpleJSON t) (V.toList xs)
169
170 fromSimpleJSON (TypeMSet t) (JSON.Array xs) =
171 ConstantAbstract . AbsLitMSet <$> mapM (fromSimpleJSON t) (V.toList xs)
172
173 fromSimpleJSON (TypeFunction fr to) (JSON.Object m) = do
174 ys <- forM (KM.toList m) $ \ (toText->name, value) -> do
175 -- the name must be an integer
176 -- and this is a function from ints we are reading here
177 a <- fromSimpleJSON fr (JSON.String name)
178 b <- fromSimpleJSON to value
179 return (a, b)
180 return $ ConstantAbstract $ AbsLitFunction ys
181
182 fromSimpleJSON ty@(TypeFunction fr to) value@(JSON.Array xs) = do
183 mys <- forM (V.toList xs) $ \case
184 JSON.Array x' ->
185 case V.toList x' of
186 [a', b'] -> do
187 a <- fromSimpleJSON fr a'
188 b <- fromSimpleJSON to b'
189 return $ Just (a, b)
190 _ -> return Nothing
191 _ -> return Nothing
192 let ys = catMaybes mys
193 if length ys == length mys
194 then return $ ConstantAbstract $ AbsLitFunction ys
195 else noFromSimpleJSON "Constant" ty value
196
197 fromSimpleJSON (TypeSequence inner) (JSON.Object m) = do
198 ys :: [(Integer, Constant)] <- forM (KM.toList m) $ \ (toText->name, value) -> do
199 -- the name must be an integer
200 a <- fromSimpleJSON (TypeInt TagInt) (JSON.String name)
201 b <- fromSimpleJSON inner value
202 return (a, b)
203
204 let ys_sorted = sort ys
205
206 return $ ConstantAbstract $ AbsLitSequence (map snd ys_sorted)
207
208 fromSimpleJSON (TypeSequence t) (JSON.Array xs) =
209 ConstantAbstract . AbsLitSequence <$> mapM (fromSimpleJSON t) (V.toList xs)
210
211 fromSimpleJSON ty@(TypeRelation ts) value@(JSON.Array xs) = do
212 minners <- forM (V.toList xs) $ \ x -> do
213 mtuple <- fromSimpleJSON (TypeTuple ts) x
214 case mtuple of
215 ConstantAbstract (AbsLitTuple tuple) -> return (Just tuple)
216 _ -> return Nothing
217 let inners = catMaybes minners
218 if length inners == length minners
219 then return $ ConstantAbstract $ AbsLitRelation inners
220 else noFromSimpleJSON "Constant" ty value
221
222
223 -- fromSimpleJSON _ (JSON.String s) = return $ ConstantEnum (Name "<unknown>") [] (Name s)
224 -- -- fromSimpleJSON _ (JSON.Array xs) = do
225 -- -- ys <- mapM fromSimpleJSON (V.toList xs)
226 -- -- return $ ConstantFromJSON ys
227 -- fromSimpleJSON t (JSON.Object m) = do
228 -- traceM $ show $ "fromSimpleJSON.Constant type" <+> pretty t
229 -- traceM $ show $ "fromSimpleJSON.Constant type" <+> pretty (show t)
230 -- ys <- forM (M.toList m) $ \ (name, value) ->
231 -- -- the name must be an integer
232 -- -- and this is a function from ints we are reading here
233 -- case readMay (textToString name) of
234 -- Nothing -> userErr1 $ vcat [ "This is not an int. Boo.", pretty name, pretty value]
235 -- Just a -> do
236 -- b <- fromSimpleJSON t value
237 -- return (ConstantInt TagInt a, b)
238 -- return $ ConstantAbstract $ AbsLitFunction ys
239 fromSimpleJSON t x = noFromSimpleJSON "Constant" t x
240
241 instance ToFromMiniZinc Constant where
242 toMiniZinc c =
243 case c of
244 ConstantBool b -> return (MZNBool b)
245 ConstantInt _ i -> return (MZNInt i)
246 ConstantAbstract lit -> toMiniZinc lit
247 TypedConstant c' _ -> toMiniZinc c'
248 _ -> noToMiniZinc c
249
250 instance Arbitrary Constant where
251 arbitrary = oneof
252 [ ConstantBool <$> arbitrary
253 , ConstantInt TagInt <$> arbitrary
254 ]
255
256 instance TypeOf Constant where
257 typeOf ConstantBool{} = return TypeBool
258 typeOf (ConstantInt t _) = return (TypeInt t)
259 typeOf (ConstantEnum defn _ _ ) = return (TypeEnum defn)
260 typeOf (ConstantField _ ty) = return ty
261 typeOf (ConstantAbstract x ) = typeOf x
262 typeOf (DomainInConstant dom) = typeOfDomain dom
263 typeOf (TypedConstant _ ty) = return ty
264 typeOf (ConstantUndefined _ ty) = return ty
265
266 instance DomainSizeOf Constant Integer where
267 domainSizeOf DomainBool{} = return 2
268 domainSizeOf (DomainIntE _ x) = bug ("not implemented, domainSizeOf DomainIntE" <+> pretty (show x))
269 domainSizeOf (DomainInt _ rs) = domainSizeOfRanges rs
270 domainSizeOf DomainEnum{} = failDoc "domainSizeOf: Unknown for given enum."
271 domainSizeOf (DomainTuple ds) = product <$> mapM domainSizeOf ds
272 domainSizeOf (DomainMatrix index inner) = intPow <$> domainSizeOf inner <*> domainSizeOf index
273 domainSizeOf d@(DomainSet _ (SetAttr attrs) inner) =
274 case attrs of
275 SizeAttr_None -> do
276 innerSize <- domainSizeOf inner
277 return (2 `intPow` innerSize)
278 SizeAttr_Size (ConstantInt _ size) -> do
279 innerSize <- domainSizeOf inner
280 return (nchoosek (product . enumFromTo 1) innerSize size)
281 SizeAttr_MinSize{} -> do
282 -- TODO: we can do better here
283 innerSize <- domainSizeOf inner
284 return (2 `intPow` innerSize)
285 SizeAttr_MaxSize (ConstantInt _ maxSize) -> do
286 innerSize <- domainSizeOf inner
287 return $ sum [ nchoosek (product . enumFromTo 1) innerSize k | k <- [0 .. maxSize] ]
288 SizeAttr_MinMaxSize (ConstantInt _ minSize) (ConstantInt _ maxSize) -> do
289 innerSize <- domainSizeOf inner
290 return $ sum [ nchoosek (product . enumFromTo 1) innerSize k | k <- [minSize .. maxSize] ]
291 _ -> failDoc ("domainSizeOf{Constant}" <+> pretty d)
292 domainSizeOf DomainMSet {} = bug "not implemented: domainSizeOf DomainMSet"
293 domainSizeOf DomainFunction {} = bug "not implemented: domainSizeOf DomainFunction"
294 domainSizeOf DomainRelation {} = bug "not implemented: domainSizeOf DomainRelation"
295 domainSizeOf DomainPartition {} = bug "not implemented: domainSizeOf DomainPartition"
296 domainSizeOf _ = bug "not implemented: domainSizeOf"
297
298 emptyCollection :: Constant -> Bool
299 emptyCollection ConstantBool{} = False
300 emptyCollection ConstantInt{} = False
301 emptyCollection ConstantEnum{} = False
302 emptyCollection ConstantField{} = False
303 emptyCollection (ConstantAbstract x) = emptyCollectionAbsLit x
304 emptyCollection DomainInConstant{} = False
305 emptyCollection (TypedConstant x _) = emptyCollection x
306 emptyCollection ConstantUndefined{} = False
307
308 intPow :: Integer -> Integer -> Integer
309 intPow = (^)
310
311 domainSizeOfRanges :: MonadFailDoc m => [Range Constant] -> m Integer
312 domainSizeOfRanges = fmap genericLength . valuesInIntDomain
313
314 instance DomainSizeOf Constant Constant where
315 domainSizeOf = fmap (ConstantInt TagInt) . domainSizeOf
316
317 instance Pretty Constant where
318
319 pretty (TypedConstant (ConstantAbstract (AbsLitMatrix _ [])) ty) | TypeAny `elem` universe ty = "[]"
320
321 -- hack, oh sweet hack!
322 -- print a domain instead of a type when printing an empty matrix literal.
323 -- this means we print "int()" instead of "int" inside the index of a matrix type
324 -- SR expects it this way...
325 pretty (TypedConstant (ConstantAbstract (AbsLitMatrix _ [])) ty) =
326 let
327 pretty' (TypeMatrix index innerNested)
328 = "matrix indexed by" <+> prettyList prBrackets "," (map pretty' indices)
329 <+> "of" <+> pretty inner
330 where
331 (indices,inner) = first (index:) $ collect innerNested
332 collect (TypeMatrix i j) = first (i:) $ collect j
333 collect x = ([],x)
334 pretty' TypeInt{} = "int()"
335 pretty' t = pretty t
336 in
337 prParens $ "[] : `" <> pretty' ty <> "`"
338
339 pretty (ConstantBool False) = "false"
340 pretty (ConstantBool True ) = "true"
341 pretty (ConstantInt t x) = pretty x <> pretty t
342 pretty (ConstantEnum _ _ x) = pretty x
343 pretty (ConstantField n _) = pretty n
344 pretty (ConstantAbstract x) = pretty x
345 pretty (DomainInConstant d) = "`" <> pretty d <> "`"
346 pretty (TypedConstant x ty) = prParens $ pretty x <+> ":" <+> "`" <> pretty ty <> "`"
347 pretty (ConstantUndefined reason ty) = "undefined" <> prParens (pretty reason <+> ":" <+> "`" <> pretty ty <> "`")
348
349 instance ExpressionLike Constant where
350 fromInt = ConstantInt TagInt
351 fromIntWithTag i t = ConstantInt t i
352 intOut _ (ConstantInt _ x) = return x
353 intOut doc c = failDoc $ vcat [ "Expecting an integer, but found:" <+> pretty c
354 , "Called from:" <+> doc
355 ]
356
357 fromBool = ConstantBool
358 boolOut (ConstantBool x) = return x
359 boolOut ConstantUndefined{} = return False
360 boolOut c = failDoc ("Expecting a boolean, but found:" <+> pretty c)
361
362 fromList xs = ConstantAbstract $ AbsLitMatrix (mkDomainIntB 1 (fromInt $ genericLength xs)) xs
363 listOut (ConstantAbstract (AbsLitMatrix _ xs)) = return xs
364 listOut c = failDoc ("Expecting a matrix literal, but found:" <+> pretty c)
365
366 instance ReferenceContainer Constant where
367 fromName name = bug ("ReferenceContainer{Constant} fromName --" <+> pretty name)
368 nameOut (ConstantField nm _) = return nm
369 nameOut p = bug ("ReferenceContainer{Constant} nameOut --" <+> pretty p)
370
371 instance DomainContainer Constant (Domain ()) where
372 fromDomain = DomainInConstant
373 domainOut (DomainInConstant dom) = return dom
374 domainOut _ = failDoc "domainOut{Constant}"
375
376 mkUndef :: Type -> Doc -> Constant
377 mkUndef TypeBool _ = ConstantBool False
378 mkUndef ty reason = ConstantUndefined (stringToText $ show reason) ty
379
380 isUndef :: Constant -> Bool
381 isUndef ConstantUndefined{} = True
382 isUndef _ = False
383
384 normaliseConstant :: Constant -> Constant
385 normaliseConstant x@ConstantBool{} = x
386 normaliseConstant x@ConstantInt{} = x
387 normaliseConstant x@ConstantEnum{} = x
388 normaliseConstant x@ConstantField{} = x
389 normaliseConstant (ConstantAbstract x) = ConstantAbstract (normaliseAbsLit normaliseConstant x)
390 normaliseConstant (DomainInConstant d) = DomainInConstant (normaliseDomain normaliseConstant d)
391 normaliseConstant (TypedConstant c ty) = TypedConstant (normaliseConstant c) ty
392 normaliseConstant x@ConstantUndefined{} = x
393
394 instance Num Constant where
395 ConstantInt _ x + ConstantInt _ y = ConstantInt TagInt (x+y)
396 x + y = bug $ vcat [ "Num Constant (+)", "x:" <+> pretty x, "y:" <+> pretty y ]
397 ConstantInt _ x - ConstantInt _ y = ConstantInt TagInt (x-y)
398 x - y = bug $ vcat [ "Num Constant (-)", "x:" <+> pretty x, "y:" <+> pretty y ]
399 ConstantInt _ x * ConstantInt _ y = ConstantInt TagInt (x*y)
400 x * y = bug $ vcat [ "Num Constant (*)", "x:" <+> pretty x, "y:" <+> pretty y ]
401 abs (ConstantInt t x) = ConstantInt t (abs x)
402 abs x = bug $ vcat [ "Num Constant abs", "x:" <+> pretty x ]
403 signum (ConstantInt t x) = ConstantInt t (signum x)
404 signum x = bug $ vcat [ "Num Constant signum", "x:" <+> pretty x ]
405 fromInteger = ConstantInt TagInt . fromInteger
406
407
408 valuesInIntDomain :: MonadFailDoc m => [Range Constant] -> m [Integer]
409 valuesInIntDomain ranges =
410 if isFinite
411 then return allValues
412 else failDoc $ "Expected finite integer ranges, but got:" <++> prettyList id "," ranges
413
414 where
415
416 allRanges :: [Maybe [Integer]]
417 allRanges =
418 [ vals
419 | r <- ranges
420 , let vals = case r of
421 RangeSingle (ConstantInt _ x) -> return [x]
422 RangeBounded (ConstantInt _ l) (ConstantInt _ u) -> return [l..u]
423 _ -> Nothing
424 ]
425
426 isFinite :: Bool
427 isFinite = Nothing `notElem` allRanges
428
429 allValues :: [Integer]
430 allValues = sortNub $ concat $ catMaybes allRanges
431
432
433 viewConstantBool :: MonadFailDoc m => Constant -> m Bool
434 viewConstantBool (ConstantBool i) = return i
435 viewConstantBool (ConstantInt _ 0) = return False
436 viewConstantBool (ConstantInt _ 1) = return True
437 viewConstantBool constant = failDoc ("Expecting a boolean, but got:" <++> pretty constant)
438
439 viewConstantInt :: MonadFailDoc m => Constant -> m Integer
440 viewConstantInt (ConstantInt _ i) = return i
441 viewConstantInt constant = failDoc ("Expecting an integer, but got:" <++> pretty constant)
442
443 viewConstantIntWithTag :: MonadFailDoc m => Constant -> m (IntTag, Integer)
444 viewConstantIntWithTag (ConstantInt t i) = return (t, i)
445 viewConstantIntWithTag constant = failDoc ("Expecting an integer, but got:" <++> pretty constant)
446
447 viewConstantTuple :: MonadFailDoc m => Constant -> m [Constant]
448 viewConstantTuple (ConstantAbstract (AbsLitTuple xs)) = return xs
449 viewConstantTuple (TypedConstant c _) = viewConstantTuple c
450 viewConstantTuple constant = failDoc ("Expecting a tuple, but got:" <++> pretty constant)
451
452 viewConstantRecord :: MonadFailDoc m => Constant -> m [(Name, Constant)]
453 viewConstantRecord (ConstantAbstract (AbsLitRecord xs)) = return (sortOn fst xs)
454 viewConstantRecord (TypedConstant c _) = viewConstantRecord c
455 viewConstantRecord constant = failDoc ("Expecting a record, but got:" <++> pretty constant)
456
457 viewConstantVariant :: MonadFailDoc m => Constant -> m (Maybe [(Name, Domain () Constant)], Name, Constant)
458 viewConstantVariant (ConstantAbstract (AbsLitVariant lu nm x)) = return (lu, nm, x)
459 viewConstantVariant (TypedConstant c _) = viewConstantVariant c
460 viewConstantVariant constant = failDoc ("Expecting a variant, but got:" <++> pretty constant)
461
462 viewConstantMatrix :: MonadFailDoc m => Constant -> m (Domain () Constant, [Constant])
463 viewConstantMatrix (ConstantAbstract (AbsLitMatrix ind xs)) = return (expandDomainReference ind, xs)
464 viewConstantMatrix (TypedConstant c _) = viewConstantMatrix c
465 viewConstantMatrix constant =
466 case viewConstantFunction constant of
467 Nothing -> failDoc ("Expecting a matrix, but got:" <++> pretty constant)
468 Just func -> do
469 let indices = map fst func
470 values = map snd func
471 indices_as_int = [ i | ConstantInt _ i <- indices ]
472 if length indices == length indices_as_int
473 then
474 if not (null indices)
475 then
476 if maximum indices_as_int - minimum indices_as_int + 1 == genericLength indices
477 then return (DomainInt TagInt [RangeBounded (fromInt (minimum indices_as_int)) (fromInt (maximum indices_as_int))], values)
478 else return (DomainInt TagInt (map (RangeSingle . fromInt) indices_as_int), values)
479 else
480 return (DomainInt TagInt [RangeBounded 1 0], values)
481 else
482 failDoc ("Expecting a matrix, but got:" <++> pretty constant)
483
484 viewConstantSet :: MonadFailDoc m => Constant -> m [Constant]
485 viewConstantSet (ConstantAbstract (AbsLitSet xs)) = return xs
486 viewConstantSet (TypedConstant c _) = viewConstantSet c
487 viewConstantSet constant = failDoc ("Expecting a set, but got:" <++> pretty constant)
488
489 viewConstantMSet :: MonadFailDoc m => Constant -> m [Constant]
490 viewConstantMSet (ConstantAbstract (AbsLitMSet xs)) = return xs
491 viewConstantMSet (TypedConstant c _) = viewConstantMSet c
492 viewConstantMSet constant = failDoc ("Expecting an mset, but got:" <++> pretty constant)
493
494 viewConstantFunction :: MonadFailDoc m => Constant -> m [(Constant, Constant)]
495 viewConstantFunction (ConstantAbstract (AbsLitFunction xs)) = return xs
496 viewConstantFunction (TypedConstant c _) = viewConstantFunction c
497 viewConstantFunction constant = do
498 let
499 suggestion = case constant of
500 ConstantAbstract (AbsLitMatrix (expandDomainReference -> DomainInt _ rs) vals) -> do
501 froms <- valuesInIntDomain rs
502 return $ Just $ pretty $ AbsLitFunction (zip (map (ConstantInt TagInt) froms) vals)
503 _ -> return Nothing
504 suggestion >>= \case
505 Nothing -> failDoc ("Expecting a function, but got:" <++> pretty constant)
506 Just sug -> failDoc (vcat [ "Expecting a function, but got:" <++> pretty constant
507 , "Maybe you meant:" <++> sug
508 ])
509
510 viewConstantSequence :: MonadFailDoc m => Constant -> m [Constant]
511 viewConstantSequence (ConstantAbstract (AbsLitSequence xs)) = return xs
512 viewConstantSequence (ConstantAbstract (AbsLitMatrix _ xs)) = return xs
513 viewConstantSequence (TypedConstant c _) = viewConstantSequence c
514 viewConstantSequence constant = failDoc ("Expecting a sequence, but got:" <++> pretty constant)
515
516 viewConstantRelation :: MonadFailDoc m => Constant -> m [[Constant]]
517 viewConstantRelation (ConstantAbstract (AbsLitRelation xs)) = return xs
518 viewConstantRelation (TypedConstant c _) = viewConstantRelation c
519 viewConstantRelation constant = failDoc ("Expecting a relation, but got:" <++> pretty constant)
520
521 viewConstantPartition :: MonadFailDoc m => Constant -> m [[Constant]]
522 viewConstantPartition (ConstantAbstract (AbsLitPartition xs)) = return xs
523 viewConstantPartition (TypedConstant c _) = viewConstantPartition c
524 viewConstantPartition constant = failDoc ("Expecting a partition, but got:" <++> pretty constant)
525
526 viewConstantPermutation :: MonadFailDoc m => Constant -> m [[Constant]]
527 viewConstantPermutation (ConstantAbstract (AbsLitPermutation xs)) = return xs
528 viewConstantPermutation (TypedConstant c _) = viewConstantPermutation c
529 viewConstantPermutation constant = failDoc ("Expecting a permutation, but got:" <++> pretty constant)
530
531
532 reDomConst :: Domain () Constant -> Domain () Constant
533 reDomConst cns = case cns of
534 DomainInt t _ -> reTag t cns
535 _ -> cns
536