never executed always true always false
1 {-# LANGUAGE QuasiQuotes #-}
2
3 module Conjure.Representations.Matrix
4 ( matrix
5 ) where
6
7 -- conjure
8 import Conjure.Prelude
9 import Conjure.Bug
10 import Conjure.Language
11 import Conjure.Language.Instantiate
12 import Conjure.Process.Enumerate
13 import Conjure.Representations.Internal
14
15
16 -- | The matrix "representation rule".
17 -- This rule handles the plumbing for matrices.
18 matrix
19 :: forall m . (MonadFailDoc m, NameGen m, MonadUserError m, EnumerateDomain m, ?typeCheckerMode :: TypeCheckerMode)
20 => ((Name, DomainX Expression) -> m (Maybe [(Name, DomainX Expression)]))
21 -> ((Name, DomainC, Constant) -> m (Maybe [(Name, DomainC, Constant)]))
22 -> ((Name, DomainC) -> [(Name, Constant)] -> m (Name, Constant))
23 -> Representation m
24 matrix downD1 downC1 up1 = Representation chck matrixDownD structuralCons matrixDownC matrixUp symmetryOrdering
25
26 where
27
28 chck :: TypeOf_ReprCheck m
29 chck f (DomainMatrix indexDomain innerDomain) = map (DomainMatrix indexDomain) <$> f innerDomain
30 chck _ _ = return []
31
32 matrixDownD :: TypeOf_DownD m
33 matrixDownD (name, DomainMatrix indexDomain innerDomain) = do
34 mres <- downD1 (name, innerDomain)
35 case mres of
36 Nothing -> return Nothing
37 Just mids -> return $ Just
38 [ (n, DomainMatrix indexDomain d) | (n, d) <- mids ]
39 matrixDownD _ = na "{matrixDownD}"
40
41 structuralCons :: TypeOf_Structural m
42 structuralCons f _ (DomainMatrix indexDomain innerDomain) = do
43 let
44 innerStructuralCons inpMatrix = do
45 (iPat, i) <- quantifiedVarOverDomain indexDomain
46 let activeZone b = [essence| forAll &iPat : &indexDomain . &b |]
47
48 -- preparing structural constraints for the inner guys
49 innerStructuralConsGen <- f innerDomain
50
51 let inLoop r = [essence| &r[&i] |]
52 outs <- innerStructuralConsGen (inLoop inpMatrix)
53 return (map activeZone outs)
54
55 return $ \ inpMatrix -> innerStructuralCons inpMatrix
56
57 structuralCons _ _ _ = na "{structuralCons} matrix 2"
58
59 matrixDownC :: TypeOf_DownC m
60 matrixDownC ( name -- special-case for empty matrix literals
61 , domain@(DomainMatrix indexDomain _)
62 , viewConstantMatrix -> Just (_indexDomain2, [])
63 ) = do
64 mids1
65 :: Maybe [(Name, DomainX Expression)]
66 <- downD1 (name, fmap Constant domain)
67 let
68 addEmptyLiteral :: (Name, DomainX Expression) -> m (Name, DomainC, Constant)
69 addEmptyLiteral (nm, dom) = do
70 dom' <- mapM (instantiateExpression []) dom
71 return (nm, dom', ConstantAbstract (AbsLitMatrix indexDomain []))
72 mapM (mapM addEmptyLiteral) mids1
73 matrixDownC ( name
74 , domain@(DomainMatrix indexDomain innerDomain)
75 , constant@(viewConstantMatrix -> Just (indexDomain2, constants))
76 ) = do
77 -- TODO: this may be too strict
78 unless (indexDomain == indexDomain2) $
79 userErr1 $ vcat
80 [ "Index mismatch."
81 , "When working on:" <+> pretty name
82 , "With domain:" <+> pretty domain
83 , "With value :" <+> pretty constant
84 ]
85 mids1
86 :: [Maybe [(Name, DomainC, Constant)]]
87 <- sequence [ downC1 (name, innerDomain, c) | c <- constants ]
88 let mids2 = catMaybes mids1
89 if null mids2 -- if all were `Nothing`s
90 then return Nothing
91 else do
92 if length mids2 == length mids1 -- if all were `Just`s
93 then do
94 let
95 mids3 :: [(Name, DomainC, [Constant])]
96 mids3 = [ ( head [ n | (n,_,_) <- line ]
97 , head [ d | (_,d,_) <- line ]
98 , [ c | (_,_,c) <- line ]
99 )
100 | line <- transpose mids2
101 ]
102 return $ Just
103 [ ( n
104 , DomainMatrix indexDomain d
105 , ConstantAbstract $ AbsLitMatrix indexDomain cs
106 )
107 | (n, d, cs) <- mids3
108 ]
109 else
110 failDoc $ vcat
111 [ "This is weird. Heterogeneous matrix literal?"
112 , "When working on:" <+> pretty name
113 , "With domain:" <+> pretty (DomainMatrix indexDomain innerDomain)
114 ]
115 matrixDownC (name, domain, constant) = na $ "{matrixDownC}" <+> vcat [ pretty name
116 , ""
117 , pretty domain
118 , pretty (show domain)
119 , ""
120 , pretty constant
121 , pretty (show constant)
122 ]
123
124 matrixUp :: TypeOf_Up m
125 matrixUp ctxt (name, DomainMatrix indexDomain innerDomain)= do
126
127 mid1
128 :: Maybe [(Name, DomainX Expression)]
129 <- downD1 (name, fmap Constant innerDomain)
130
131 case mid1 of
132 Nothing ->
133 -- the inner domain doesn't require refinement
134 -- there needs to be a binding with "name"
135 -- and we just pass it through
136 case lookup name ctxt of
137 Nothing -> failDoc $ vcat $
138 [ "(in Matrix up 1)"
139 , "No value for:" <+> pretty name
140 , "With domain:" <+> pretty (DomainMatrix indexDomain innerDomain)
141 ] ++
142 ("Bindings in context:" : prettyContext ctxt)
143 Just constant -> return (name, constant)
144 Just mid2 -> do
145 -- the inner domain needs refinement
146 -- there needs to be bindings for each name in (map fst mid2)
147 -- we find those bindings, call (up1 name inner) on them, then lift
148 mid3
149 :: [(Name, [Constant])]
150 <- forM mid2 $ \ (n, _) ->
151 case lookup n ctxt of
152 Nothing -> failDoc $ vcat $
153 [ "(in Matrix up 2)"
154 , "No value for:" <+> pretty n
155 , "When working on:" <+> pretty name
156 , "With domain:" <+> pretty (DomainMatrix indexDomain innerDomain)
157 ] ++
158 ("Bindings in context:" : prettyContext ctxt)
159 Just constant ->
160 -- this constant is a ConstantMatrix, containing one component of the things to go into up1
161 case viewConstantMatrix constant of
162 Just (_, vals) -> return (n, vals)
163 _ -> failDoc $ vcat
164 [ "Expecting a matrix literal for:" <+> pretty n
165 , "But got:" <+> pretty constant
166 , "When working on:" <+> pretty name
167 , "With domain:" <+> pretty (DomainMatrix indexDomain innerDomain)
168 ]
169
170 let
171 midNames :: [Name]
172 midNames = map fst mid3
173
174 midConstants :: [[Constant]]
175 midConstants = map snd mid3
176
177 midConstantsMaxLength = maximum (0 : map length midConstants)
178
179 midConstantsPadded :: [[Constant]]
180 midConstantsPadded =
181 [ cs ++ replicate (midConstantsMaxLength - length cs) z
182 | let z = ConstantUndefined "midConstantsPadded" TypeAny
183 , cs <- midConstants
184 ]
185
186 -- -- assertion, midConstants should not be rugged
187 -- case midConstants of
188 -- (x:xs) | any (length x /=) (map length xs) -> failDoc $ vcat
189 -- [ "midConstants is rugged"
190 -- , "midConstants :" <+> vcat (map (prettyList prBrackets ",") midConstants)
191 -- , "midConstantsPadded:" <+> vcat (map (prettyList prBrackets ",") midConstantsPadded)
192 -- ]
193 -- _ -> return ()
194
195 mid4
196 :: [(Name, Constant)]
197 <- sequence
198 [ up1 (name, innerDomain) (zip midNames cs)
199 | cs <- transpose midConstantsPadded
200 ]
201 let values = map snd mid4
202 return (name, ConstantAbstract $ AbsLitMatrix indexDomain values)
203 matrixUp _ _ = na "{matrixUp}"
204
205 symmetryOrdering :: TypeOf_SymmetryOrdering m
206 symmetryOrdering innerSO downX1 inp domain =
207 case domain of
208 DomainMatrix indexDom innerDom -> do
209 (iPat, i) <- quantifiedVarOverDomain indexDom
210 let mi = [essence| &inp[&i] |]
211 res <- innerSO downX1 mi innerDom
212 return [essence| [ &res | &iPat : &indexDom ] |]
213 _ -> bug $ "symmetryOrdering matrix" <+> pretty inp <+> pretty domain