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 =
146 case inp of
147 -- Constant x -> so_onConstant x
148 -- AbstractLiteral x
149 Reference _ (Just refTo) -> do
150 case refTo of
151 Alias x -> symmetryOrdering x
152 InComprehension{} -> bug ("symmetryOrdering.InComprehension:" <++> pretty (show inp))
153 DeclNoRepr{} -> bug ("symmetryOrdering.DeclNoRepr:" <++> pretty (show inp))
154 DeclHasRepr _forg _name domain -> symmetryOrderingDispatch downX1 inp domain
155 RecordField{} -> bug ("symmetryOrdering.RecordField:" <++> pretty (show inp))
156 VariantField{} -> bug ("symmetryOrdering.VariantField:" <++> pretty (show inp))
157 Op op -> case op of
158 MkOpIndexing (OpIndexing m _) -> do
159 ty <- typeOf m
160 case ty of
161 TypeMatrix{} -> return ()
162 TypeList{} -> return ()
163 _ -> bug $ "[symmetryOrdering.onOp, not a TypeMatrix or TypeList]" <+> vcat [pretty ty, pretty op]
164 mDom <- domainOfR m
165 case mDom of
166 DomainMatrix _ domainInner -> symmetryOrderingDispatch downX1 inp domainInner
167 _ -> bug ("symmetryOrdering, not DomainMatrix:" <++> pretty (show op))
168 _ -> bug ("symmetryOrdering, unhandled Op:" <++> pretty (show op))
169 -- Comprehension body stmts -> do
170 -- xs <- downX1 body
171 -- return [Comprehension x stmts | x <- xs]
172 -- x@WithLocals{} -> bug ("downX1:" <++> pretty (show x))
173 _ -> bug ("symmetryOrdering:" <++> pretty (show inp))
174