never executed always true always false
1 {-# LANGUAGE ScopedTypeVariables #-}
2
3 module Conjure.UI.TranslateSolution
4 ( translateSolution
5 , prepareTranslateSolution
6 ) where
7
8 -- conjure
9 import Conjure.Prelude
10 import Conjure.Bug
11 import Conjure.Language.Definition
12 import Conjure.Language.Type ( TypeCheckerMode(..) )
13 import Conjure.Language.Constant ( normaliseConstant )
14 import Conjure.Language.Domain ( Domain, HasRepresentation )
15 import Conjure.Language.Pretty
16 import Conjure.Language.Instantiate
17 import Conjure.Process.Enums ( removeEnumsFromParam, addEnumsAndUnnamedsBack )
18 import Conjure.Process.Enumerate ( EnumerateDomain )
19 import Conjure.UI.TranslateParameter ( translateParameter )
20 import Conjure.Representations ( up )
21
22 -- text
23 import qualified Data.Text as T ( pack, stripPrefix )
24
25 -- unordered-containers
26 import qualified Data.HashMap.Strict as M
27
28 -- containers
29 import qualified Data.Set as S
30
31
32 data PreparedLetting = PreparedLetting
33 { plName :: Name
34 , plExpr :: Expression
35 , plConst :: Maybe Constant
36 }
37
38
39 translateSolution ::
40 MonadFailDoc m =>
41 MonadLog m =>
42 NameGen m =>
43 EnumerateDomain m =>
44 MonadIO m =>
45 (?typeCheckerMode :: TypeCheckerMode) =>
46 Model -> -- eprime model
47 Model -> -- essence param
48 Model -> -- eprime solution
49 m Model -- essence solution
50
51 translateSolution eprimeModel essenceParam eprimeSolution = do
52 tr <- prepareTranslateSolution eprimeModel essenceParam
53 tr eprimeSolution
54
55
56 prepareTranslateSolution ::
57 forall m .
58 MonadFailDoc m =>
59 MonadLog m =>
60 NameGen m =>
61 EnumerateDomain m =>
62 MonadIO m =>
63 (?typeCheckerMode :: TypeCheckerMode) =>
64 Model -> -- eprime model
65 Model -> -- essence param
66 m (Model -> m Model)
67
68 -- Precompute solution-invariant data so per-solution translation is cheaper.
69 prepareTranslateSolution (undoUnderscores -> eprimeModel) (undoUnderscores -> essenceParam') = do
70
71 eprimeParam <- translateParameter False eprimeModel essenceParam'
72 (_, essenceParam) <- removeEnumsFromParam eprimeModel essenceParam'
73
74 let eprimeLettingsForEnums =
75 [ (nm, fromInt (genericLength vals))
76 | nm1 <- eprimeModel |> mInfo |> miEnumGivens
77 , Declaration (LettingDomainDefnEnum nm2 vals) <- essenceParam' |> mStatements
78 , nm1 == nm2
79 , let nm = nm1 `mappend` "_EnumSize"
80 ]
81
82 let essenceFindNames = eprimeModel |> mInfo |> miFinds
83 let essenceFinds = eprimeModel |> mInfo |> miRepresentations
84 |> filter (\ (n,_) -> n `elem` essenceFindNames )
85
86 let normalizeLetting (name, val) = (name, maybe val Constant (e2c val))
87
88 let prefixLettings0 =
89 map normalizeLetting (extractLettings essenceParam ++ extractLettings eprimeParam)
90 let suffixLettings0 =
91 map normalizeLetting $
92 extractLettings eprimeModel
93 ++ (eprimeModel |> mInfo |> miLettings)
94 ++ eprimeLettingsForEnums
95
96 let fixedLettings0 = prefixLettings0 ++ suffixLettings0
97
98 let exprNames :: Expression -> S.Set Name
99 exprNames expr = S.fromList (universeBi expr :: [Name])
100
101 let dependentNames =
102 let
103 findNames = S.fromList (eprimeModel |> mInfo |> miFinds)
104 step deps =
105 S.union deps $ S.fromList
106 [ nm
107 | (nm, expr) <- fixedLettings0
108 , not (S.null (exprNames expr `S.intersection` deps))
109 ]
110 go deps =
111 let deps' = step deps
112 in if deps' == deps then deps else go deps'
113 in
114 go findNames
115
116 let fixedContextExpr = fixedLettings0
117
118 let prepareLettings :: [(Name, Expression)] -> m [PreparedLetting]
119 prepareLettings = mapM $ \ (name, expr) -> do
120 if name `S.member` dependentNames
121 then return (PreparedLetting name expr Nothing)
122 else do
123 c <- case expr of
124 Constant c -> return c
125 _ -> instantiateExpression fixedContextExpr expr
126 return (PreparedLetting name (Constant c) (Just c))
127
128 prefixPrepared <- prepareLettings prefixLettings0
129 suffixPrepared <- prepareLettings suffixLettings0
130
131 let domainNames :: Domain HasRepresentation Expression -> S.Set Name
132 domainNames dom = S.fromList (universeBi dom :: [Name])
133
134 essenceFindsPrepared <- forM essenceFinds $ \ (name, dom) -> do
135 if not (S.null (domainNames dom `S.intersection` dependentNames))
136 then return (name, dom, Nothing)
137 else do
138 constant <- instantiateDomain fixedContextExpr dom
139 return (name, dom, Just constant)
140
141 let
142 intToEnumConstant :: M.HashMap (Integer, Name) Constant
143 intToEnumConstant = M.fromList $ concat
144 [ [ ((i,ename), ConstantEnum ename vals v)
145 | (i,v) <- zip allNats vals
146 ]
147 | Declaration (LettingDomainDefnEnum ename vals)
148 <- mStatements essenceParam'
149 ++ eprimeModel |> mInfo |> miEnumLettings |> map Declaration
150 ]
151
152 let
153 unnameds :: [(Name, Expression)]
154 unnameds = eprimeModel |> mInfo |> miUnnameds
155
156 let (unnamedsStatic, unnamedsDynamic) =
157 partition (\ (_, expr) -> S.null (exprNames expr `S.intersection` dependentNames)) unnameds
158
159 unnamedsStaticDecls <- forM unnamedsStatic $ \ (n, s') -> do
160 s <- instantiateExpression fixedContextExpr (maybe s' Constant (e2c s'))
161 case s of
162 ConstantInt _ size -> return $
163 let nms = [ mconcat [n, "_", Name (T.pack (show i))]
164 | i <- [1 .. size]
165 ]
166 in Declaration (LettingDomainDefnEnum n nms)
167 _ -> failDoc $ vcat [ "Expecting an integer value for" <+> pretty n
168 , "But got:" <+> pretty s
169 ]
170
171 let origDomainMap = M.fromList (eprimeModel |> mInfo |> miOriginalDomains)
172
173 let
174 mkUnnamedsDecls ::
175 MonadFailDoc m =>
176 EnumerateDomain m =>
177 NameGen m =>
178 (?typeCheckerMode :: TypeCheckerMode) =>
179 [(Name, Expression)] ->
180 m [Statement]
181 mkUnnamedsDecls ctxtExpr = forM unnamedsDynamic $ \ (n, s') -> do
182 s <- instantiateExpression ctxtExpr (maybe s' Constant (e2c s'))
183 case s of
184 ConstantInt _ size -> return $
185 let nms = [ mconcat [n, "_", Name (T.pack (show i))]
186 | i <- [1 .. size]
187 ]
188 in Declaration (LettingDomainDefnEnum n nms)
189 _ -> failDoc $ vcat [ "Expecting an integer value for" <+> pretty n
190 , "But got:" <+> pretty s
191 ]
192
193 let
194 evalLetting ::
195 MonadFailDoc m =>
196 EnumerateDomain m =>
197 NameGen m =>
198 (?typeCheckerMode :: TypeCheckerMode) =>
199 [(Name, Expression)] -> (Name, Expression) -> m (Name, Constant)
200 evalLetting ctxt (name, expr) =
201 case expr of
202 Constant c -> return (name, c)
203 _ -> do
204 c <- instantiateExpression ctxt expr
205 return (name, c)
206
207 let
208 translateOne ::
209 MonadFailDoc m =>
210 MonadLog m =>
211 NameGen m =>
212 EnumerateDomain m =>
213 MonadIO m =>
214 (?typeCheckerMode :: TypeCheckerMode) =>
215 Model -> m Model
216 translateOne (undoUnderscores -> eprimeSolution) = do
217 let solutionLettings0 = map normalizeLetting (extractLettings eprimeSolution)
218 let prefixExpr = [ (plName p, plExpr p) | p <- prefixPrepared ]
219 let suffixExpr = [ (plName p, plExpr p) | p <- suffixPrepared ]
220 let contextExpr = prefixExpr ++ solutionLettings0 ++ suffixExpr
221
222 prefixConsts <- forM prefixPrepared $ \ p ->
223 case plConst p of
224 Just c -> return (plName p, c)
225 Nothing -> evalLetting contextExpr (plName p, plExpr p)
226 solutionConsts <- forM solutionLettings0 (evalLetting contextExpr)
227 suffixConsts <- forM suffixPrepared $ \ p ->
228 case plConst p of
229 Just c -> return (plName p, c)
230 Nothing -> evalLetting contextExpr (plName p, plExpr p)
231
232 let eprimeLettings' = prefixConsts ++ solutionConsts ++ suffixConsts
233
234 essenceFinds' <- forM essenceFindsPrepared $ \ (name, dom, domConst) -> do
235 constant <- case domConst of
236 Just c -> return c
237 Nothing -> instantiateDomain contextExpr dom
238 return (name, constant)
239
240 essenceLettings <- forM essenceFinds' $ \ (name, domain) -> do
241 (_, constant) <- up eprimeLettings' (name, domain)
242 let origDomain = fromMaybe (bug ("Missing original domain for:" <+> pretty name))
243 (M.lookup name origDomainMap)
244 return (name, origDomain, constant)
245
246 unnamedsDynamicDecls <- mkUnnamedsDecls contextExpr
247
248 let outStmts =
249 unnamedsStaticDecls ++ unnamedsDynamicDecls ++
250 sortNub
251 [ Declaration (Letting n (Constant (normaliseConstant y)))
252 | (n, d, x) <- essenceLettings
253 , let y = addEnumsAndUnnamedsBack
254 (map fst unnameds)
255 intToEnumConstant
256 d x
257 ]
258
259 let undefs = [ u | u@ConstantUndefined{} <- universeBi outStmts ]
260
261 if null undefs
262 then return def { mStatements = outStmts }
263 else bug $ vcat
264 [ "Undefined values in the output:" <++> vcat (map pretty undefs)
265 , ""
266 , "Complete output would have been the following."
267 , ""
268 , pretty $ def { mStatements = outStmts }
269 ]
270
271 return translateOne
272
273 undoUnderscores :: Model -> Model
274 undoUnderscores model =
275 let
276 -- SR doesn't support identifiers that start with _
277 -- we replaced them with UNDERSCORE__ in prologue
278 -- undo that here
279 onName :: Name -> Name
280 onName (Name t) =
281 case T.stripPrefix "UNDERSCORE__" t of
282 Nothing -> Name t
283 Just t' -> Name (mappend "_" t')
284 onName n = n
285
286 in
287 transformBi onName model