never executed always true always false
1 {-# OPTIONS_GHC -fno-warn-orphans #-}
2 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
3
4 module Conjure.Language.Definition
5 ( forgetRepr, rangesInts
6 , languageEprime
7 , initInfo
8 , allContextsExceptReferences
9
10 , quantifiedVar, quantifiedVarOverDomain, auxiliaryVar
11 , lambdaToFunction
12
13 , e2c
14 , nbUses
15 , isDomainExpr
16
17 , Model(..), LanguageVersion(..)
18 , ModelInfo(..), Decision(..), TrailRewrites(..)
19 , Statement(..), SearchOrder(..), Objective(..)
20 , Declaration(..), FindOrGiven(..)
21 , Strategy(..)
22 , viewAuto, parseStrategy
23
24 , Name(..)
25 , Expression(..), ReferenceTo(..), Region(..), InBubble(..)
26 , Constant(..)
27 , AbstractLiteral(..)
28 , AbstractPattern(..)
29 , GeneratorOrCondition(..), Generator(..), generatorPat
30
31 , ExpressionLike(..), ReferenceContainer(..)
32
33 , extractLettings
34 , tupleLitIfNeeded
35 , patternToExpr
36 , emptyCollectionX
37
38 , module Conjure.Language.NameGen
39
40 , fromSimpleJSONModel
41
42 ) where
43
44 -- conjure
45 import Conjure.Prelude
46 import Conjure.Bug
47 import Conjure.UserError
48 import Conjure.Language.Pretty
49 import Conjure.Language.AdHoc
50
51 import Conjure.Language.Name
52 import Conjure.Language.NameGen ( NameGen(..), NameGenState, runNameGen )
53 import Conjure.Language.Constant
54 import Conjure.Language.AbstractLiteral
55 import Conjure.Language.Domain
56 import Conjure.Language.Type
57 import Conjure.Language.Expression
58
59
60 -- aeson
61 import Data.Aeson ( (.=), (.:) )
62 import qualified Data.Aeson as JSON
63 import qualified Data.Aeson.KeyMap as KM
64
65 import qualified Data.Vector as V -- vector
66
67 -- uniplate
68 import Data.Generics.Uniplate.Zipper ( Zipper, down, right, hole )
69 import Data.Aeson.Key (toText)
70
71
72 ------------------------------------------------------------------------------------------------------------------------
73 -- Model ---------------------------------------------------------------------------------------------------------------
74 ------------------------------------------------------------------------------------------------------------------------
75
76 data Model = Model
77 { mLanguage :: LanguageVersion
78 , mStatements :: [Statement]
79 , mInfo :: ModelInfo
80 }
81 deriving (Eq, Ord, Show, Data, Typeable, Generic)
82
83 instance Serialize Model
84 instance Hashable Model
85 instance ToJSON Model where toJSON = genericToJSON jsonOptions
86 instance FromJSON Model where parseJSON = genericParseJSON jsonOptions
87
88 instance SimpleJSON Model where
89 toSimpleJSON m = do
90 inners <- mapM toSimpleJSON (mStatements m)
91 let (innersAsMaps, rest) = unzip [ case i of JSON.Object mp -> ([mp], []); _ -> ([], [i]) | i <- inners ]
92 |> (\ (xs, ys) -> (mconcat <$> xs, concat ys))
93 unless (null rest) $ bug $ "Expected json objects only, but got:" <+> vcat (map pretty rest)
94 return (JSON.Object $ mconcat innersAsMaps)
95 fromSimpleJSON = noFromSimpleJSON "Model"
96
97 fromSimpleJSONModel ::
98 (?typeCheckerMode :: TypeCheckerMode) =>
99 MonadLog m =>
100 MonadUserError m =>
101 Model ->
102 JSON.Value ->
103 m Model
104 fromSimpleJSONModel essence json =
105 case json of
106 JSON.Object inners -> do
107 stmts <- forM (KM.toList inners) $ \ (toText->name, valueJSON) -> do
108 let mdomain = [ dom
109 | Declaration (FindOrGiven Given (Name nm) dom) <- mStatements essence
110 , nm == name
111 ]
112 let enums = [ nm
113 | Name nm <- essence |> mInfo |> miEnumGivens
114 , nm == name
115 ]
116 case (mdomain, enums) of
117 ([domain], _) -> do
118 typ <- typeOfDomain domain
119 value <- fromSimpleJSON typ valueJSON
120 return $ Just $ Declaration (Letting (Name name) value)
121 (_, [enum]) -> do
122 case valueJSON of
123 JSON.Array v -> do
124 let vals = [ case str of
125 JSON.String t -> Name t
126 _ -> bug ("fromSimpleJSONModel not name: " <+> pretty (show str))
127 | str <- V.toList v
128 ]
129 return $ Just $ Declaration (LettingDomainDefnEnum (Name enum) vals)
130 _ -> bug "fromSimpleJSONModel"
131 _ -> do
132 logWarn $ "Ignoring" <+> pretty name <+> "from the JSON file."
133 return Nothing
134 return def { mStatements = catMaybes stmts }
135 _ -> noFromSimpleJSON "Model" TypeAny json
136
137 instance ToFromMiniZinc Model where
138 toMiniZinc m = do
139 inners <- mapM toMiniZinc (mStatements m)
140 return $ MZNNamed $ concat [xs | MZNNamed xs <- inners]
141
142 instance Default Model where
143 def = Model def [] def
144
145 instance Pretty Model where
146 pretty (Model lang stmts info) = vcat $ concat
147 [ [pretty lang]
148 , [""]
149 , map pretty stmts
150 , [""]
151 , [pretty info | info /= def]
152 ]
153
154 instance VarSymBreakingDescription Model where
155 varSymBreakingDescription m = JSON.Object $ KM.fromList
156 [ ("type", JSON.String "Model")
157 , ("symmetricChildren", JSON.Bool True)
158 , ("children", JSON.Array $ V.fromList $ map varSymBreakingDescription $ mStatements m)
159 ]
160
161
162 languageEprime :: Model -> Model
163 languageEprime m = m { mLanguage = LanguageVersion "ESSENCE'" [1,0] }
164
165 allContextsExceptReferences :: Zipper a Expression -> [Zipper a Expression]
166 allContextsExceptReferences z0 = concatMap subtreeOf (allSiblings z0)
167 where
168 -- the input has to be the left most
169 allSiblings :: Zipper a Expression -> [Zipper a Expression]
170 allSiblings z = z : maybe [] allSiblings (right z)
171
172 subtreeOf :: Zipper a Expression -> [Zipper a Expression]
173 subtreeOf z = z : case hole z of
174 Reference{} -> [] -- don't go through a Reference
175 _ -> maybe [] allContextsExceptReferences (down z)
176
177 ------------------------------------------------------------------------------------------------------------------------
178 -- LanguageVersion -----------------------------------------------------------------------------------------------------
179 ------------------------------------------------------------------------------------------------------------------------
180
181 data LanguageVersion = LanguageVersion Name [Int]
182 deriving (Eq, Ord, Show, Data, Typeable, Generic)
183
184 instance Serialize LanguageVersion
185 instance Hashable LanguageVersion
186
187 instance ToJSON LanguageVersion where
188 toJSON (LanguageVersion t is) =
189 JSON.object [ "language" .= toJSON t
190 , "version" .= toJSON is
191 ]
192
193 instance FromJSON LanguageVersion where
194 parseJSON (JSON.Object x) =
195 LanguageVersion <$> x .: "language"
196 <*> x .: "version"
197 parseJSON x = bug $ "Error while parsing JSON:" <++> pretty (show x)
198
199 instance Default LanguageVersion where
200 def = LanguageVersion "Essence" [1,3]
201
202 instance Pretty LanguageVersion where
203 pretty (LanguageVersion language version) =
204 "language" <+> pretty language
205 <+> hcat (intersperse "." (map pretty version))
206
207
208 ------------------------------------------------------------------------------------------------------------------------
209 -- ModelInfo -----------------------------------------------------------------------------------------------------------
210 ------------------------------------------------------------------------------------------------------------------------
211
212 data ModelInfo = ModelInfo
213 { miGivens :: [Name]
214 , miFinds :: [Name]
215 , miLettings :: [(Name, Expression)]
216 , miEnumGivens :: [Name]
217 , miEnumLettings :: [Declaration]
218 , miUnnameds :: [(Name, Expression)]
219 , miOriginalDomains :: [(Name, Domain () Expression)]
220 , miRepresentations :: [(Name, Domain HasRepresentation Expression)]
221 , miRepresentationsTree :: [(Name, [Tree (Maybe HasRepresentation)])]
222 , miStrategyQ :: Strategy
223 , miStrategyA :: Strategy
224 , miTrailCompact :: [ ( Int -- picked question #
225 , Int -- picked answer #
226 , Int -- number of answers
227 ) ]
228 , miTrailGeneralised :: [ ( Int -- "question"
229 , Int -- "answer"
230 ) ] -- both are hashes...
231 , miTrailVerbose :: [Decision]
232 , miTrailRewrites :: [TrailRewrites]
233 , miNameGenState :: [(Text, Int)]
234 , miNbExtraGivens :: Int -- number of extra givens Conjure added to make the domains of original givens finite
235 }
236 deriving (Eq, Ord, Show, Data, Typeable, Generic)
237
238 modelInfoJSONOptions :: JSON.Options
239 modelInfoJSONOptions = jsonOptions { JSON.fieldLabelModifier = onHead toLower . drop 2 }
240 where onHead f (x:xs) = f x : xs
241 onHead _ [] = []
242
243 instance Serialize ModelInfo
244 instance Hashable ModelInfo
245 instance ToJSON ModelInfo where toJSON = genericToJSON modelInfoJSONOptions
246 instance FromJSON ModelInfo where parseJSON = genericParseJSON modelInfoJSONOptions
247
248 instance Default ModelInfo where
249 def = ModelInfo def def def def def def def def def def def def def def def def def
250
251 instance Pretty ModelInfo where
252 pretty = commentLines . pretty . toJSON
253 where
254 commentLines :: Doc -> Doc
255 commentLines
256 = vcat -- Doc
257 . (++ [""]) -- add an empty line to the end
258 . map ("$ " `mappend`) -- comment each line
259 . ("Conjure's" :) -- add the heading
260 . map pretty -- [Doc]
261 . lines -- [String]
262 . renderNormal -- to String
263
264 initInfo :: Model -> Model
265 initInfo model = model { mInfo = info }
266 where
267 info = (mInfo model)
268 { miGivens = [ nm | Declaration (FindOrGiven Given nm _) <- mStatements model ]
269 , miFinds = [ nm | Declaration (FindOrGiven Find nm _) <- mStatements model ]
270 , miOriginalDomains =
271 [ (nm, dom)
272 | Declaration (FindOrGiven _ nm dom) <- mStatements model
273 ]
274 , miEnumGivens = [ nm | Declaration (GivenDomainDefnEnum nm) <- mStatements model ]
275 , miEnumLettings = [ d | Declaration d@LettingDomainDefnEnum{} <- mStatements model ]
276 , miLettings = bug "Not initialised yet: miLettings"
277 , miUnnameds = [ (nm,s) | Declaration (LettingDomainDefnUnnamed nm s) <- mStatements model ]
278 }
279
280
281 data Strategy
282 = PickFirst -- ^ pick the first option
283 | PickAll -- ^ keep all options
284 | Interactive -- ^ prompt the user
285 | AtRandom -- ^ pick one option at random
286 | Compact -- ^ pick the compact option
287 | Sparse -- ^ pick the most sparse option, useful for parameters (otherwise identical to PickFirst)
288 | Auto Strategy
289 deriving (Eq, Ord, Read, Show, Data, Typeable, Generic)
290
291 instance Serialize Strategy
292 instance Hashable Strategy
293 instance ToJSON Strategy where toJSON = genericToJSON jsonOptions
294 instance FromJSON Strategy where parseJSON = genericParseJSON jsonOptions
295
296 instance Default Strategy where def = Auto Interactive
297
298 viewAuto :: Strategy -> (Strategy, Bool)
299 viewAuto (Auto s) = second (const True) (viewAuto s)
300 viewAuto s = (s, False)
301
302 parseStrategy :: String -> Maybe Strategy
303 parseStrategy ['a',s] = Auto <$> parseStrategy (return s)
304 parseStrategy "f" = return PickFirst
305 parseStrategy "x" = return PickAll
306 parseStrategy "i" = return Interactive
307 parseStrategy "r" = return AtRandom
308 parseStrategy "c" = return Compact
309 parseStrategy "s" = return Sparse
310 parseStrategy _ = Nothing
311
312
313 ------------------------------------------------------------------------------------------------------------------------
314 -- Decision ------------------------------------------------------------------------------------------------------------
315 ------------------------------------------------------------------------------------------------------------------------
316
317 data Decision = Decision
318 { dDescription :: [Text]
319 , dNumOptions :: Maybe Int
320 , dDecision :: Int
321 }
322 deriving (Eq, Ord, Show, Data, Typeable, Generic)
323
324 decisionJSONOptions :: JSON.Options
325 decisionJSONOptions = jsonOptions { JSON.fieldLabelModifier = map toLower . drop 1 }
326
327 instance Serialize Decision
328 instance Hashable Decision
329 instance ToJSON Decision where toJSON = genericToJSON decisionJSONOptions
330 instance FromJSON Decision where parseJSON = genericParseJSON decisionJSONOptions
331
332
333 ------------------------------------------------------------------------------------------------------------------------
334 -- TrailRewrites -------------------------------------------------------------------------------------------------------
335 ------------------------------------------------------------------------------------------------------------------------
336
337 data TrailRewrites = TrailRewrites
338 { trRule :: Text
339 , trBefore :: [Text]
340 , trAfter :: [Text]
341 }
342 deriving (Eq, Ord, Show, Data, Typeable, Generic)
343
344 trJSONOptions :: JSON.Options
345 trJSONOptions = jsonOptions { JSON.fieldLabelModifier = map toLower . drop 2 }
346
347 instance Serialize TrailRewrites
348 instance Hashable TrailRewrites
349 instance ToJSON TrailRewrites where toJSON = genericToJSON trJSONOptions
350 instance FromJSON TrailRewrites where parseJSON = genericParseJSON trJSONOptions
351
352
353 ------------------------------------------------------------------------------------------------------------------------
354 -- Misc ----------------------------------------------------------------------------------------------------------------
355 ------------------------------------------------------------------------------------------------------------------------
356
357 extractLettings :: Model -> [(Name, Expression)]
358 extractLettings model =
359 [ (n, x) | Declaration (Letting n x) <- mStatements model
360 , not (isDomain x)
361 ]
362 where isDomain Domain{} = True
363 isDomain _ = False