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