never executed always true always false
1
2 module Conjure.Representations.Combined
3 ( downD, downC, up
4 , downD1, downC1, up1
5 , downToX1
6 , symmetryOrderingDispatch
7 , reprOptions, getStructurals
8 , reprsStandardOrderNoLevels, reprsStandardOrder, reprsSparseOrder
9 ) where
10
11 -- conjure
12 import Conjure.Prelude
13 import Conjure.Bug
14 import Conjure.Language
15 import Conjure.Language.Instantiate
16 import Conjure.Process.Enumerate ( EnumerateDomain )
17
18 import Conjure.Representations.Internal
19 import Conjure.Representations.Primitive
20 import Conjure.Representations.Tuple
21 import Conjure.Representations.Matrix
22 import Conjure.Representations.Record
23 import Conjure.Representations.Variant
24 import Conjure.Representations.Set.Occurrence
25 import Conjure.Representations.Set.Explicit
26 import Conjure.Representations.Set.ExplicitVarSizeWithDummy
27 import Conjure.Representations.Set.ExplicitVarSizeWithMarker
28 import Conjure.Representations.Set.ExplicitVarSizeWithFlags
29 import Conjure.Representations.MSet.Occurrence
30 import Conjure.Representations.MSet.ExplicitWithFlags
31 import Conjure.Representations.MSet.ExplicitWithRepetition
32 import Conjure.Representations.Function.Function1D
33 import Conjure.Representations.Function.Function1DPartial
34 import Conjure.Representations.Function.FunctionND
35 import Conjure.Representations.Function.FunctionNDPartial
36 import Conjure.Representations.Function.FunctionNDPartialDummy
37 import Conjure.Representations.Function.FunctionAsRelation
38 import Conjure.Representations.Sequence.ExplicitBounded
39 import Conjure.Representations.Relation.RelationAsMatrix
40 import Conjure.Representations.Relation.RelationAsSet
41 import Conjure.Representations.Partition.Occurrence
42 import Conjure.Representations.Partition.PartitionAsSet
43
44
45 -- | Refine (down) a domain, outputting refinement expressions (X) one level (1).
46 -- The domain is allowed to be at the class level.
47 downToX1 ::
48 MonadFailDoc m =>
49 NameGen m =>
50 EnumerateDomain m =>
51 (?typeCheckerMode :: TypeCheckerMode) =>
52 FindOrGiven -> Name -> DomainX Expression -> m [Expression]
53 downToX1 forg name domain = rDownToX (dispatch domain) forg name domain
54
55 -- | Refine (down) a domain (D), one level (1).
56 -- The domain is allowed to be at the class level.
57 downD1 ::
58 MonadFailDoc m =>
59 NameGen m =>
60 EnumerateDomain m =>
61 (?typeCheckerMode :: TypeCheckerMode) =>
62 (Name, DomainX Expression) -> m (Maybe [(Name, DomainX Expression)])
63 downD1 (name, domain) = rDownD (dispatch domain) (name, domain)
64
65 -- | Refine (down) a domain, together with a constant (C), one level (1).
66 -- The domain has to be fully instantiated.
67 downC1 ::
68 MonadFailDoc m =>
69 NameGen m =>
70 EnumerateDomain m =>
71 (?typeCheckerMode :: TypeCheckerMode) =>
72 (Name, DomainC, Constant) -> m (Maybe [(Name, DomainC, Constant)])
73 downC1 (name, domain, constant) = rDownC (dispatch domain) (name, domain, constant)
74
75
76 -- | Translate a bunch of low level constants up, one level.
77 -- The high level domain (i.e. the target domain) has to be given.
78 -- The domain has to be fully instantiated.
79 up1 ::
80 MonadFailDoc m =>
81 NameGen m =>
82 EnumerateDomain m =>
83 (?typeCheckerMode :: TypeCheckerMode) =>
84 (Name, DomainC) -> [(Name, Constant)] -> m (Name, Constant)
85 up1 (name, domain) ctxt = rUp (dispatch domain) ctxt (name, domain)
86
87
88 -- | Refine (down) a domain (D), all the way.
89 -- The domain is allowed to be at the class level.
90 downD ::
91 MonadFailDoc m =>
92 NameGen m =>
93 EnumerateDomain m =>
94 (?typeCheckerMode :: TypeCheckerMode) =>
95 (Name, DomainX Expression) -> m [(Name, DomainX Expression)]
96 downD inp@(_, domain) = do
97 mout <- rDownD (dispatch domain) inp
98 case mout of
99 Nothing -> return [inp]
100 Just outs -> concatMapM downD outs
101
102 -- | Refine (down) a domain, together with a constant (C), all the way.
103 -- The domain has to be fully instantiated.
104 downC ::
105 MonadFailDoc m =>
106 NameGen m =>
107 EnumerateDomain m =>
108 (?typeCheckerMode :: TypeCheckerMode) =>
109 (Name, DomainC, Constant) -> m [(Name, DomainC, Constant)]
110 downC inp0 = do
111 let inp1 = case inp0 of (nm, dom, TypedConstant con _) -> (nm, dom, con)
112 _ -> inp0
113 mout <- downC1 inp1
114 case mout of
115 Nothing -> return [inp0]
116 Just outs -> concatMapM downC outs
117
118 -- | Translate a bunch of low level constants up, all the way.
119 -- The high level domain (i.e. the target domain) has to be given.
120 -- The domain has to be fully instantiated.
121 up ::
122 MonadFailDoc m =>
123 NameGen m =>
124 EnumerateDomain m =>
125 (?typeCheckerMode :: TypeCheckerMode) =>
126 [(Name, Constant)] -> (Name, DomainC) -> m (Name, Constant)
127 up ctxt (name, highDomain) = do
128 toDescend'
129 -- :: Maybe [(Name, DomainX x)]
130 <- downD1 (name, fmap Constant highDomain)
131 case toDescend' of
132 Nothing ->
133 case lookup name ctxt of
134 Nothing -> failDoc $ vcat
135 $ ("No value for:" <+> pretty name)
136 : "Bindings in context:"
137 : prettyContext ctxt
138 Just val -> return (name, val)
139 Just toDescend -> do
140 midConstants
141 :: [(Name, Constant)]
142 <- sequence [ do d' <- instantiateDomain [] d
143 up ctxt (n, d')
144 | (n, d) <- toDescend
145 ]
146 up1 (name, highDomain) midConstants
147
148
149 -- | ...
150 symmetryOrderingDispatch ::
151 MonadFailDoc m =>
152 NameGen m =>
153 EnumerateDomain m =>
154 (?typeCheckerMode :: TypeCheckerMode) =>
155 (Expression -> m [Expression]) ->
156 Expression ->
157 DomainX Expression ->
158 m Expression
159 symmetryOrderingDispatch downX1 inp domain =
160 rSymmetryOrdering
161 (dispatch domain)
162 symmetryOrderingDispatch downX1
163 inp domain
164
165
166 -- | Combine all known representations into one.
167 -- Dispatch into the actual implementation of the representation depending on the provided domain.
168 dispatch ::
169 MonadFailDoc m =>
170 NameGen m =>
171 EnumerateDomain m =>
172 Pretty x =>
173 (?typeCheckerMode :: TypeCheckerMode) =>
174 Domain HasRepresentation x -> Representation m
175 dispatch domain = do
176 let nope = bug $ "No representation for the domain:" <+> pretty domain
177 case domain of
178 DomainBool{} -> primitive
179 DomainIntE{} -> primitive
180 DomainInt{} -> primitive
181 DomainTuple{} -> tuple
182 DomainRecord{} -> record
183 DomainVariant{} -> variant
184 DomainMatrix{} -> matrix downD1 downC1 up1
185 DomainSet r _ _ -> case r of
186 Set_Occurrence -> setOccurrence
187 Set_Explicit -> setExplicit
188 Set_ExplicitVarSizeWithDummy -> setExplicitVarSizeWithDummy
189 Set_ExplicitVarSizeWithMarker -> setExplicitVarSizeWithMarker
190 Set_ExplicitVarSizeWithFlags -> setExplicitVarSizeWithFlags
191 _ -> nope
192 DomainMSet r _ _ -> case r of
193 MSet_Occurrence -> msetOccurrence
194 MSet_ExplicitWithFlags -> msetExplicitWithFlags
195 MSet_ExplicitWithRepetition -> msetExplicitWithRepetition
196 _ -> nope
197 DomainFunction r _ _ _ -> case r of
198 Function_1D -> function1D
199 Function_1DPartial -> function1DPartial
200 Function_ND -> functionND
201 Function_NDPartial -> functionNDPartial
202 Function_NDPartialDummy -> functionNDPartialDummy
203 Function_AsRelation{} -> functionAsRelation dispatch
204 (bug "reprOptions inside dispatch")
205 _ -> nope
206 DomainSequence r _ _ -> case r of
207 Sequence_ExplicitBounded -> sequenceExplicitBounded
208 _ -> nope
209 DomainRelation r _ _ -> case r of
210 Relation_AsMatrix -> relationAsMatrix
211 Relation_AsSet{} -> relationAsSet dispatch
212 (bug "reprOptions inside dispatch")
213 (bug "useLevels inside dispatch")
214 _ -> nope
215 DomainPartition r _ _ -> case r of
216 Partition_Occurrence -> partitionOccurrence
217 Partition_AsSet{} -> partitionAsSet dispatch
218 (bug "reprOptions inside dispatch")
219 (bug "useLevels inside dispatch")
220 _ -> nope
221 _ -> nope
222
223
224 type AllRepresentations m = [[Representation m]]
225
226
227 -- | No levels!
228 reprsStandardOrderNoLevels ::
229 MonadFailDoc m =>
230 NameGen m =>
231 EnumerateDomain m =>
232 (?typeCheckerMode :: TypeCheckerMode) =>
233 AllRepresentations m
234 reprsStandardOrderNoLevels = [concat reprsStandardOrder]
235
236
237 -- | A list of all representations.
238 -- As a crude measure, implementing levels here.
239 -- We shouldn't have levels between representations in the long run.
240 reprsStandardOrder ::
241 MonadFailDoc m =>
242 NameGen m =>
243 EnumerateDomain m =>
244 (?typeCheckerMode :: TypeCheckerMode) =>
245 AllRepresentations m
246 reprsStandardOrder =
247 [ [ primitive, tuple, record, variant, matrix downD1 downC1 up1
248 , setExplicit, setOccurrence, setExplicitVarSizeWithDummy
249 , setExplicitVarSizeWithMarker, setExplicitVarSizeWithFlags
250 , msetExplicitWithFlags, msetExplicitWithRepetition, msetOccurrence
251 , function1D, function1DPartial, functionND, functionNDPartial, functionNDPartialDummy
252 , sequenceExplicitBounded
253 , relationAsMatrix
254 , partitionAsSet dispatch (reprOptions reprsStandardOrder) True
255 , partitionOccurrence
256 ]
257 , [ functionAsRelation dispatch (reprOptions reprsStandardOrder)
258 , relationAsSet dispatch (reprOptions reprsStandardOrder) True
259 ]
260 ]
261
262
263 -- | Sparser representations are to be preferred for parameters.
264 reprsSparseOrder ::
265 MonadFailDoc m =>
266 NameGen m =>
267 EnumerateDomain m =>
268 (?typeCheckerMode :: TypeCheckerMode) =>
269 AllRepresentations m
270 reprsSparseOrder = map return
271 [ primitive, tuple, record, variant, matrix downD1 downC1 up1
272
273 , setExplicit, setExplicitVarSizeWithDummy, setExplicitVarSizeWithMarker
274 , setOccurrence, setExplicitVarSizeWithFlags -- redundant
275
276 , msetExplicitWithFlags
277 , msetExplicitWithRepetition, msetOccurrence -- redundant
278
279 , function1D, functionND
280 , functionAsRelation dispatch (reprOptions reprsSparseOrder)
281 , function1DPartial, functionNDPartial -- redundant
282 , functionNDPartialDummy -- redundant
283
284 , sequenceExplicitBounded
285
286 , relationAsSet dispatch (reprOptions reprsSparseOrder) False
287 , relationAsMatrix
288 , partitionAsSet dispatch (reprOptions reprsSparseOrder) False
289
290 , partitionOccurrence -- redundant
291 ]
292
293
294 -- | For a domain, produce a list of domains with different representation options.
295 -- This function should never return an empty list.
296 reprOptions ::
297 Monad m =>
298 Functor m =>
299 Data x =>
300 Pretty x =>
301 ExpressionLike x =>
302 AllRepresentations m -> Domain () x -> m [Domain HasRepresentation x]
303 reprOptions reprs (expandDomainReference -> domain) = go reprs
304 where
305 go [] = return []
306 go (reprsThisLevel:reprsNextLevels) = do
307 matchesOnThisLevel <- concat <$> sequence [ rCheck r (reprOptions reprs) domain
308 | r <- reprsThisLevel
309 ]
310 if null matchesOnThisLevel
311 then go reprsNextLevels
312 else return matchesOnThisLevel
313
314
315 -- | For a domain, returns the structural constraints.
316 -- Makes recursive calls to generate the complete structural constraints.
317 -- Takes in a function to refine inner guys.
318 getStructurals ::
319 MonadFailDoc m =>
320 NameGen m =>
321 EnumerateDomain m =>
322 (?typeCheckerMode :: TypeCheckerMode) =>
323 (Expression -> m [Expression]) ->
324 DomainX Expression ->
325 m (Expression -> m [Expression])
326 getStructurals downX1 domain = rStructural (dispatch domain) (getStructurals downX1) downX1 domain
327