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