never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Representations
4 ( downD, downC, up
5 , downD1, downC1, up1
6 , downToX1
7 , reprOptions, getStructurals
8 , symmetryOrdering
9 , reprsStandardOrderNoLevels, reprsStandardOrder, reprsSparseOrder
10 , downX1
11 , downX
12 ) where
13
14 -- conjure
15 import Conjure.Prelude
16 import Conjure.Bug
17 import Conjure.Language
18 import Conjure.Process.Enumerate
19 import Conjure.Compute.DomainOf
20 import Conjure.Representations.Combined
21
22
23 -- | Refine (down) an expression (X), one level (1).
24 downX1 ::
25 MonadFailDoc m =>
26 NameGen m =>
27 EnumerateDomain m =>
28 (?typeCheckerMode :: TypeCheckerMode) =>
29 Expression -> m [Expression]
30 downX1 (Constant x) = onConstant x
31 downX1 (AbstractLiteral x) = onAbstractLiteral x
32 downX1 (Reference x (Just refTo)) = onReference x refTo
33 downX1 (Op x) = onOp x
34 downX1 (Comprehension body stmts) = do
35 xs <- downX1 body
36 return [Comprehension x stmts | x <- xs]
37 downX1 x@WithLocals{} = failDoc ("downX1:" <++> pretty (show x))
38 downX1 x = bug ("downX1:" <++> pretty (show x))
39
40
41 -- | Refine (down) an expression (X), all the way.
42 downX ::
43 NameGen m =>
44 EnumerateDomain m =>
45 (?typeCheckerMode :: TypeCheckerMode) =>
46 Expression -> m [Expression]
47 downX x = do
48 res <- runMaybeT $ downX1 x
49 case res of
50 Nothing -> return [x]
51 Just [] -> return [x]
52 Just xs -> concatMapM downX xs
53
54
55 onConstant ::
56 MonadFailDoc m =>
57 NameGen m =>
58 EnumerateDomain m =>
59 (?typeCheckerMode :: TypeCheckerMode) =>
60 Constant -> m [Expression]
61 onConstant (ConstantAbstract (AbsLitTuple xs)) = return (map Constant xs)
62 onConstant (ConstantAbstract (AbsLitRecord xs)) = return (map (Constant . snd) xs)
63 onConstant (ConstantAbstract (AbsLitVariant (Just t) n x))
64 | Just i <- elemIndex n (map fst t)
65 , let iExpr = fromInt (fromIntegral (i+1))
66 = return $ iExpr : [ if n == n'
67 then Constant x
68 else ExpressionMetaVar "zeroVal for variant"
69 | (n',_) <- t ]
70 onConstant (ConstantAbstract (AbsLitMatrix index xs)) = do
71 yss <- mapM (downX1 . Constant) xs
72 let indexX = fmap Constant index
73 return [ AbstractLiteral (AbsLitMatrix indexX ys) | ys <- transpose yss ]
74 onConstant (TypedConstant c _) = onConstant c
75 onConstant x = bug ("downX1.onConstant:" <++> pretty (show x))
76
77 onAbstractLiteral ::
78 MonadFailDoc m =>
79 NameGen m =>
80 EnumerateDomain m =>
81 (?typeCheckerMode :: TypeCheckerMode) =>
82 AbstractLiteral Expression -> m [Expression]
83 onAbstractLiteral (AbsLitTuple xs) = return xs
84 onAbstractLiteral (AbsLitRecord xs) = return (map snd xs)
85 onAbstractLiteral (AbsLitVariant (Just t) n x)
86 | Just i <- elemIndex n (map fst t)
87 , let iExpr = fromInt (fromIntegral (i+1))
88 = return $ iExpr : [ if n == n'
89 then x
90 else ExpressionMetaVar "zeroVal for variant"
91 | (n',_) <- t ]
92 onAbstractLiteral (AbsLitMatrix index xs) = do
93 yss <- mapM downX1 xs
94 return [ AbstractLiteral (AbsLitMatrix index ys) | ys <- transpose yss ]
95 onAbstractLiteral x = bug ("downX1.onAbstractLiteral:" <++> pretty (show x))
96
97 onReference ::
98 MonadFailDoc m =>
99 NameGen m =>
100 EnumerateDomain m =>
101 (?typeCheckerMode :: TypeCheckerMode) =>
102 Name -> ReferenceTo -> m [Expression]
103 onReference nm refTo =
104 case refTo of
105 Alias x -> downX1 x
106 InComprehension{} -> failDoc ("downX1.onReference.InComprehension:" <++> pretty (show nm))
107 DeclNoRepr{} -> failDoc ("downX1.onReference.DeclNoRepr:" <++> pretty (show nm))
108 DeclHasRepr forg _ domain -> downToX1 forg nm domain
109 RecordField{} -> failDoc ("downX1.onReference.RecordField:" <++> pretty (show nm))
110 VariantField{} -> failDoc ("downX1.onReference.VariantField:" <++> pretty (show nm))
111
112 onOp ::
113 MonadFailDoc m =>
114 NameGen m =>
115 EnumerateDomain m =>
116 (?typeCheckerMode :: TypeCheckerMode) =>
117 Op Expression -> m [Expression]
118 onOp p@(MkOpIndexing (OpIndexing m i)) = do
119 ty <- typeOf m
120 case ty of
121 TypeMatrix{} -> return ()
122 TypeList{} -> return ()
123 _ -> failDoc $ "[onOp, not a TypeMatrix or TypeList]" <+> vcat [pretty ty, pretty p]
124 xs <- downX1 m
125 let iIndexed x = Op (MkOpIndexing (OpIndexing x i))
126 return (map iIndexed xs)
127 onOp (MkOpImage (OpImage (match functionLiteral -> Just (_, xs)) a)) | length xs > 0 = do
128 vals <- forM xs $ \ (_, value) -> do
129 ys <- downX1 value
130 return ys
131 let keys = map fst xs
132 let outs = map (zip keys) (transpose vals)
133 return [ Op $ MkOpImage $ OpImage (AbstractLiteral (AbsLitFunction out)) a
134 | out <- outs ]
135 onOp op = failDoc ("downX1.onOp:" <++> pretty op)
136
137
138
139 symmetryOrdering ::
140 MonadFailDoc m =>
141 NameGen m =>
142 EnumerateDomain m =>
143 (?typeCheckerMode :: TypeCheckerMode) =>
144 Expression -> m Expression
145 symmetryOrdering inp' = do
146 let constBool (ConstantBool True) = ConstantInt TagInt 1
147 constBool (ConstantBool False) = ConstantInt TagInt 0
148 constBool x = x
149 inp = transformBi constBool inp'
150 ta <- typeOf inp
151 case ta of
152 TypeBool -> return [essence| [-toInt(&inp)] |]
153 TypeInt{} -> return [essence| [&inp] |]
154 TypeList TypeInt{} -> return inp
155 TypeMatrix TypeInt{} TypeInt{} -> return inp
156 _ ->
157 case inp of
158 -- Constant x -> so_onConstant x
159 -- AbstractLiteral _ -> return inp
160
161 Constant ConstantBool{} -> return [essence| -toInt(&inp) |]
162
163 Constant (ConstantAbstract x) -> do
164 case x of
165 AbsLitTuple xs -> do
166 soVals <- mapM symmetryOrdering (Constant <$> xs)
167 return $ fromList soVals
168 AbsLitMatrix _ xs -> do
169 soVals <- mapM symmetryOrdering (Constant <$> xs)
170 return $ fromList soVals
171 _ -> na ("symmetryOrdering: AbstractLiteral:" <++> pretty (show inp) <++> pretty inp)
172
173 AbstractLiteral x -> do
174 case x of
175 AbsLitTuple xs -> do
176 soVals <- mapM symmetryOrdering xs
177 return $ AbstractLiteral $ AbsLitTuple soVals
178 AbsLitMatrix d xs -> do
179 soVals <- mapM symmetryOrdering xs
180 return $ AbstractLiteral $ AbsLitMatrix d soVals
181 _ -> na ("symmetryOrdering: AbstractLiteral:" <++> pretty (show inp) <++> pretty inp)
182
183 Reference _ (Just refTo) -> do
184 case refTo of
185 Alias x -> symmetryOrdering x
186 InComprehension{} -> na ("symmetryOrdering.InComprehension:" <++> pretty (show inp))
187 DeclNoRepr{} -> na ("symmetryOrdering.DeclNoRepr:" <++> pretty (show inp))
188 DeclHasRepr _forg _name domain -> symmetryOrderingDispatch downX1 inp domain
189 RecordField{} -> na ("symmetryOrdering.RecordField:" <++> pretty (show inp))
190 VariantField{} -> na ("symmetryOrdering.VariantField:" <++> pretty (show inp))
191
192 Op op -> case op of
193 MkOpIndexing (OpIndexing m _) -> do
194 ty <- typeOf m
195 case ty of
196 TypeMatrix{} -> return ()
197 TypeList{} -> return ()
198 _ -> na $ "[symmetryOrdering.onOp, not a TypeMatrix or TypeList]" <+> vcat [pretty ty, pretty op]
199 mDom <- domainOfR m
200 case mDom of
201 DomainMatrix _ domainInner -> symmetryOrderingDispatch downX1 inp domainInner
202 _ -> na ("symmetryOrdering, not DomainMatrix:" <++> pretty (show op))
203 MkOpImage (OpImage p x) -> do
204 so <- symmetryOrdering x
205 return [essence| image(&p, &so) |]
206 _ -> na ("symmetryOrdering, no OpIndexing:" <++> pretty (show op))
207
208 Comprehension body stmts -> do
209 xs <- symmetryOrdering body
210 return $ make opFlatten $ Comprehension xs stmts
211
212 _ -> na ("symmetryOrdering:" <++> pretty (show inp) <++> pretty inp)