never executed always true always false
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 {-# LANGUAGE QuasiQuotes #-}
3
4 module Conjure.Language.Expression.DomainSizeOf
5 ( DomainSizeOf(..)
6 , getMaxNumberOfElementsInContainer
7 ) where
8
9 -- conjure
10 import Conjure.Prelude
11 import Conjure.Bug
12 import Conjure.Language.Definition
13 import Conjure.Language.AdHoc
14 import Conjure.Language.Domain
15 import Conjure.Language.Expression.Op
16 import Conjure.Language.Lenses
17 import Conjure.Language.TH
18 import Conjure.Language.Type
19
20 import Conjure.Language.DomainSizeOf
21 import Conjure.Language.Pretty
22
23
24 instance DomainSizeOf Expression Expression where
25 domainSizeOf (DomainReference _ (Just d)) = domainSizeOf d
26 domainSizeOf DomainBool = return 2
27 domainSizeOf (DomainInt _ [] ) = failDoc "domainSizeOf infinite integer domain"
28 domainSizeOf (DomainInt _ [r]) = domainSizeOfRange r
29 domainSizeOf (DomainInt _ rs ) = make opSum . fromList <$> mapM domainSizeOfRange rs
30 domainSizeOf (DomainIntE x) = do
31 let
32 go (Reference _ (Just (Alias y))) = go y
33 go (Comprehension _body gocs) = return $ make opSum $ Comprehension 1 gocs
34 go y = bug ("not implemented: domainSizeOf.go:" <+> vcat [pretty y, pretty (show y)])
35 go x
36 domainSizeOf (DomainEnum n Nothing _) = return $
37 let n' = n `mappend` "_EnumSize"
38 in Reference n' (Just (DeclHasRepr Given n' (DomainInt TagInt [])))
39 domainSizeOf (DomainUnnamed _ x) = return x
40 domainSizeOf (DomainTuple []) = return 1
41 domainSizeOf (DomainTuple xs) = make opProduct . fromList <$> mapM domainSizeOf xs
42 domainSizeOf (DomainRecord xs) = make opProduct . fromList <$> mapM (domainSizeOf . snd) xs
43 domainSizeOf (DomainVariant xs) = make opSum . fromList <$> mapM (domainSizeOf . snd) xs
44 domainSizeOf (DomainMatrix index inner) = make opPow <$> domainSizeOf inner <*> domainSizeOf index
45 domainSizeOf (DomainSet _ (SetAttr sizeAttr) inner) = do
46 innerSize <- domainSizeOf inner
47 case sizeAttr of
48 SizeAttr_None -> return (make opPow 2 innerSize)
49 SizeAttr_Size size -> return (nchoosek (make opFactorial) innerSize size)
50 SizeAttr_MinSize _ -> return (make opPow 2 innerSize) -- TODO: can be better
51 SizeAttr_MaxSize _ -> return (make opPow 2 innerSize) -- TODO: can be better
52 SizeAttr_MinMaxSize _ _ -> return (make opPow 2 innerSize) -- TODO: can be better
53 domainSizeOf (DomainMSet _ attrs inner) = do
54 innerSize <- domainSizeOf inner
55 let
56 getMaxSize = case attrs of
57 MSetAttr (SizeAttr_Size x) _ -> return x
58 MSetAttr (SizeAttr_MaxSize x) _ -> return x
59 MSetAttr (SizeAttr_MinMaxSize _ x) _ -> return x
60 MSetAttr _ (OccurAttr_MaxOccur x) -> return (x * innerSize)
61 MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> return (x * innerSize)
62 _ -> failDoc ("domainSizeOf.getMaxSize, mset not supported. attributes:" <+> pretty attrs)
63 getMaxOccur = case attrs of
64 MSetAttr _ (OccurAttr_MaxOccur x) -> return x
65 MSetAttr _ (OccurAttr_MinMaxOccur _ x) -> return x
66 MSetAttr (SizeAttr_Size x) _ -> return (make opMin $ fromList [x, innerSize])
67 MSetAttr (SizeAttr_MaxSize x) _ -> return (make opMin $ fromList [x, innerSize])
68 MSetAttr (SizeAttr_MinMaxSize _ x) _ -> return (make opMin $ fromList [x, innerSize])
69 _ -> failDoc ("domainSizeOf.getMaxSize, mset not supported. attributes:" <+> pretty attrs)
70 maxSize <- getMaxSize
71 maxOccur <- getMaxOccur
72 return (make opPow maxOccur maxSize)
73 domainSizeOf d@(DomainSequence _ (SequenceAttr sizeAttr jectivityAttr) innerTo) = do
74 size <- case sizeAttr of
75 SizeAttr_None -> failDoc ("Infinite domain:" <+> pretty d)
76 SizeAttr_Size s -> return s
77 SizeAttr_MinSize _ -> failDoc ("Infinite domain:" <+> pretty d)
78 SizeAttr_MaxSize s -> return s
79 SizeAttr_MinMaxSize _ s -> return s
80 domainSizeOf $ DomainFunction def (FunctionAttr sizeAttr PartialityAttr_Partial jectivityAttr)
81 (DomainInt TagInt [RangeBounded 1 size]) innerTo
82 domainSizeOf (DomainFunction _ (FunctionAttr sizeAttr _ _) innerFr innerTo) =
83 domainSizeOf $ DomainRelation def (RelationAttr sizeAttr def) [innerFr, innerTo]
84 domainSizeOf (DomainRelation _ (RelationAttr sizeAttr _binRelAttr) inners) =
85 domainSizeOf (DomainSet def (SetAttr sizeAttr) (DomainTuple inners))
86 domainSizeOf (DomainPartition _ a inner) =
87 domainSizeOf $ DomainSet def (SetAttr (partsNum a))
88 $ DomainSet def (SetAttr (partsSize a)) inner
89 domainSizeOf d = bug ("not implemented: domainSizeOf:" <+> vcat [pretty d, pretty (show d)])
90
91
92 domainSizeOfRange :: (Op a :< a, ExpressionLike a, Pretty a, MonadFailDoc m, Num a, Eq a) => Range a -> m a
93 domainSizeOfRange RangeSingle{} = return 1
94 domainSizeOfRange (RangeBounded 1 u) = return u
95 domainSizeOfRange (RangeBounded l u) = return $ make opSum $ fromList [1, make opMinus u l]
96 domainSizeOfRange r = failDoc ("domainSizeOf infinite range:" <+> pretty r)
97
98
99 getMaxNumberOfElementsInContainer :: Domain () Expression -> Expression
100 getMaxNumberOfElementsInContainer domain@(DomainSet _ (SetAttr sizeAttr) inner) =
101 case (getMaxFrom_SizeAttr sizeAttr, domainSizeOf inner) of
102 (Just n, _) -> n
103 (_, Just n) -> n
104 _ -> bug $ "getMaxNumberOfElementsInContainer, DomainSet:" <+> pretty domain
105 getMaxNumberOfElementsInContainer domain@(DomainMSet _ (MSetAttr sizeAttr occurAttr) inner) =
106 case (getMaxFrom_SizeAttr sizeAttr, getMaxFrom_OccurAttr occurAttr, domainSizeOf inner) of
107 (Just n, _ , _ ) -> n
108 (_ , Just o, Just n) -> [essence| &o * &n |]
109 _ -> bug $ "getMaxNumberOfElementsInContainer, DomainMSet:" <+> pretty domain
110 getMaxNumberOfElementsInContainer domain@(DomainSequence _ (SequenceAttr sizeAttr _) _) =
111 case getMaxFrom_SizeAttr sizeAttr of
112 Just n -> n
113 _ -> bug $ "getMaxNumberOfElementsInContainer, DomainSequence:" <+> pretty domain
114 getMaxNumberOfElementsInContainer domain = bug $ "getMaxNumberOfElementsInContainer:" <+> pretty domain
115