never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2 {-# LANGUAGE Rank2Types #-}
3
4 module Conjure.Representations.Relation.RelationAsSet ( relationAsSet ) where
5
6 -- conjure
7 import Conjure.Prelude
8 import Conjure.Bug
9 import Conjure.Language
10 import Conjure.Representations.Internal
11 import Conjure.Representations.Common
12
13
14 relationAsSet
15 :: forall m . (MonadFailDoc m, NameGen m)
16 => (forall x . DispatchFunction m x)
17 -> (forall r x . ReprOptionsFunction m r x)
18 -> Bool
19 -> Representation m
20 relationAsSet dispatch reprOptions useLevels = Representation chck downD structuralCons downC up symmetryOrdering
21
22 where
23
24 chck :: TypeOf_ReprCheck m
25 chck _ dom1@(DomainRelation _ attrs _) = do
26 dom2 <- outDomain_ dom1
27 dom3 <- reprOptions dom2
28 return [ DomainRelation (Relation_AsSet r) attrs innerDomains
29 | DomainSet r _ (DomainTuple innerDomains) <- dom3
30 -- special hack: do not use Set_ExplicitVarSizeWithFlags when --representation-levels=yes
31 , if useLevels
32 then r /= Set_ExplicitVarSizeWithFlags
33 else True
34 ]
35 chck _ _ = return []
36
37 outName :: Domain HasRepresentation x -> Name -> Name
38 outName = mkOutName Nothing
39
40 outDomain_ :: Pretty x => Domain () x -> m (Domain () x)
41 outDomain_ (DomainRelation () (RelationAttr sizeAttr _binRelAttrs) innerDomains) =
42 return (DomainSet () (SetAttr sizeAttr) (DomainTuple innerDomains))
43 outDomain_ domain = na $ vcat [ "{outDomain_} RelationAsSet"
44 , "domain:" <+> pretty domain
45 ]
46
47 outDomain :: Pretty x => Domain HasRepresentation x -> m (Domain HasRepresentation x)
48 outDomain (DomainRelation (Relation_AsSet repr) (RelationAttr sizeAttr _binRelAttrs) innerDomains) =
49 return (DomainSet repr (SetAttr sizeAttr) (DomainTuple innerDomains))
50 outDomain domain = na $ vcat [ "{outDomain} RelationAsSet"
51 , "domain:" <+> pretty domain
52 ]
53
54 downD :: TypeOf_DownD m
55 downD (name, inDom) = do
56 outDom <- outDomain inDom
57 return $ Just [ ( outName inDom name , outDom ) ]
58
59 structuralCons :: TypeOf_Structural m
60 structuralCons f downX1 inDom = do
61 let
62 innerStructuralCons rel = do
63 outDom <- outDomain inDom
64 innerStructuralConsGen <- f outDom
65 innerStructuralConsGen rel
66
67 return $ \ rel -> do
68 refs <- downX1 rel
69 case refs of
70 [set] -> do
71 binRelCons <- case inDom of
72 DomainRelation Relation_AsSet{} (RelationAttr _ binRelAttrs) [innerDomain1, innerDomain2]
73 | binRelAttrs == def
74 -> return []
75 | forgetRepr innerDomain1 == forgetRepr innerDomain2
76 -> mkBinRelCons binRelAttrs innerDomain1 rel
77 | otherwise
78 -> bug $ vcat [ "Binary relation between different domains. (RelationAsSet)"
79 , "innerDomain1:" <+> pretty innerDomain1
80 , "innerDomain2:" <+> pretty innerDomain2
81 ]
82 DomainRelation Relation_AsSet{} (RelationAttr _ binRelAttrs) innerDomains
83 | length innerDomains /= 2 && binRelAttrs /= def
84 -> bug "Non-binary relation has binary relation attributes."
85 _ -> return []
86 concat <$> sequence
87 [ innerStructuralCons set
88 , return binRelCons
89 ]
90 _ -> na $ vcat [ "{structuralCons} RelationAsSet"
91 , pretty inDom
92 ]
93
94 downC :: TypeOf_DownC m
95 downC ( name
96 , inDom
97 , viewConstantRelation -> Just vals
98 ) = do
99 outDom <- outDomain inDom
100 rDownC
101 (dispatch outDom)
102 ( outName inDom name
103 , outDom
104 , ConstantAbstract $ AbsLitSet $ map (ConstantAbstract . AbsLitTuple) vals
105 )
106 downC (name, domain, constant) = na $ vcat [ "{downC} RelationAsSet"
107 , "name:" <+> pretty name
108 , "domain:" <+> pretty domain
109 , "constant:" <+> pretty constant
110 ]
111
112 up :: TypeOf_Up m
113 up ctxt (name, domain@(DomainRelation Relation_AsSet{} _ _)) =
114 case lookup (outName domain name) ctxt of
115 Just (viewConstantSet -> Just tuples) -> do
116 vals <- mapM viewConstantTuple tuples
117 return (name, ConstantAbstract (AbsLitRelation vals))
118 Nothing -> failDoc $ vcat $
119 [ "(in RelationAsSet up)"
120 , "No value for:" <+> pretty (outName domain name)
121 , "When working on:" <+> pretty name
122 , "With domain:" <+> pretty domain
123 ] ++
124 ("Bindings in context:" : prettyContext ctxt)
125 Just constant -> failDoc $ vcat $
126 [ "Incompatible value for:" <+> pretty (outName domain name)
127 , "When working on:" <+> pretty name
128 , "With domain:" <+> pretty domain
129 , "Expected a set value, but got:" <++> pretty constant
130 ] ++
131 ("Bindings in context:" : prettyContext ctxt)
132 up _ (name, domain) = na $ vcat [ "{up} RelationAsSet"
133 , "name:" <+> pretty name
134 , "domain:" <+> pretty domain
135 ]
136
137 symmetryOrdering :: TypeOf_SymmetryOrdering m
138 symmetryOrdering innerSO downX1 inp domain = do
139 [inner] <- downX1 inp
140 Just [(_, innerDomain)] <- downD ("SO", domain)
141 innerSO downX1 inner innerDomain