never executed always true always false
1 module Conjure.UI.IO
2 ( readModelFromFile
3 , readModelFromStdin
4 , readModelPreambleFromFile
5 , readModelInfoFromFile
6 , readParamJSON
7 , readParamOrSolutionFromFile
8 , writeModel, writeModels
9 , readModel
10 ) where
11
12 -- conjure
13 import Conjure.Prelude
14 import Conjure.Bug
15 import Conjure.UserError
16 import Conjure.UI
17 import Conjure.Language
18 import qualified Conjure.Language.Parser as Parser
19 import qualified Conjure.Language.ParserC as ParserC
20 import Conjure.Language.AST.Syntax (ProgramTree)
21
22 -- aeson
23 import qualified Data.Aeson ( eitherDecodeStrict )
24
25 -- cereal
26 import qualified Data.Serialize ( decode, encode )
27
28 -- text
29 import qualified Data.Text as T
30 import qualified Data.Text.IO as T ( getContents )
31 import qualified Data.Text.Encoding as T ( encodeUtf8 )
32
33 -- bytestring
34 import qualified Data.ByteString as BS ( readFile, writeFile )
35 import qualified Data.ByteString.Char8 as BS ( putStrLn )
36
37
38 readASTJSONFromFile ::
39 MonadIO m =>
40 -- MonadFailDoc m =>
41 -- MonadUserError m =>
42 FilePath -> m (Either String Model)
43 readASTJSONFromFile fp = do
44 (_, contents) <- liftIO $ pairWithContents fp
45 contents
46 |> T.encodeUtf8 -- convert Text to ByteString
47 |> Data.Aeson.eitherDecodeStrict
48 |> return
49 -- case rawJSON of
50 -- Left err -> userErr1 (pretty err)
51 -- Right m -> return m
52
53
54 readModelFromFile ::
55 MonadIO m =>
56 MonadFailDoc m =>
57 MonadUserError m =>
58 FilePath -> m Model
59 readModelFromFile fp = do
60 con <- liftIO $ BS.readFile fp
61 case Data.Serialize.decode con of
62 Right res -> return res
63 Left _ -> do
64 ast_ <- readASTJSONFromFile fp
65 case ast_ of
66 Right res -> return res
67 Left _ -> do
68 pair <- liftIO $ pairWithContents fp
69 readModel Parser.parseModel (Just id) pair
70
71
72 readModelFromStdin ::
73 MonadIO m =>
74 MonadFailDoc m =>
75 MonadUserError m =>
76 m Model
77 readModelFromStdin = do
78 con2 <- liftIO $ T.getContents
79 let pair = ("stdin", con2)
80 readModel Parser.parseModel (Just id) pair
81
82
83 readParamJSON ::
84 (?typeCheckerMode :: TypeCheckerMode) =>
85 MonadIO m =>
86 MonadFail m =>
87 MonadLog m =>
88 MonadUserError m =>
89 Model -> FilePath -> m Model
90 readParamJSON model fp = do
91 (_, contents) <- liftIO $ pairWithContents fp
92 let paramJSON = contents
93 |> T.encodeUtf8 -- convert Text to ByteString
94 |> Data.Aeson.eitherDecodeStrict
95 case paramJSON of
96 Left err -> userErr1 (pretty err)
97 Right j -> fromSimpleJSONModel model j
98
99
100 readParamOrSolutionFromFile ::
101 (?typeCheckerMode :: TypeCheckerMode) =>
102 MonadIO m =>
103 MonadLog m =>
104 MonadFailDoc m =>
105 MonadUserError m =>
106 Model -> FilePath -> m Model
107 readParamOrSolutionFromFile model fp = do
108 if ".json" `isSuffixOf` fp
109 then readParamJSON model fp
110 else do
111 con <- liftIO $ BS.readFile fp
112 case Data.Serialize.decode con of
113 Right res -> return res
114 Left _ -> do
115 pair <- liftIO $ pairWithContents fp
116 readModel ParserC.parseModel (Just id) pair
117
118
119 readModelPreambleFromFile ::
120 MonadIO m =>
121 MonadFailDoc m =>
122 MonadUserError m =>
123 FilePath -> m Model
124 readModelPreambleFromFile fp = do
125 con <- liftIO $ BS.readFile fp
126 case Data.Serialize.decode con of
127 Right res -> return res
128 Left _ -> do
129 pair <- liftIO $ pairWithContents fp
130 readModel Parser.parseModel (Just onlyPreamble) pair
131
132
133 readModelInfoFromFile ::
134 MonadIO m =>
135 MonadFailDoc m =>
136 MonadUserError m =>
137 FilePath -> m Model
138 readModelInfoFromFile fp = do
139 con <- liftIO $ BS.readFile fp
140 case Data.Serialize.decode con of
141 Right res -> return res
142 Left _ -> do
143 pair <- liftIO $ pairWithContents fp
144 model0 <- readModel Parser.parseModel Nothing pair
145 return model0 { mStatements = [ Declaration (FindOrGiven Given nm (forgetRepr dom))
146 | nm <- model0 |> mInfo |> miGivens
147 , (nm', dom) <- model0 |> mInfo |> miRepresentations
148 , nm == nm'
149 ] }
150
151
152 readModel ::
153 MonadFailDoc m =>
154 MonadUserError m =>
155 Parser.Pipeline ProgramTree Model ->
156 Maybe (Text -> Text) ->
157 (FilePath, Text) ->
158 m Model
159 readModel modelParser preprocess (fp, con) = do
160 model <- case preprocess of
161 Nothing -> return def
162 Just prep ->
163 do
164 let res = Parser.runLexerAndParser modelParser fp (prep con)
165 case res of
166 Left e -> userErr1 e
167 Right x -> return x
168
169 let
170 infoBlock = con
171 |> T.lines
172 |> dropWhile ("$ Conjure's" /=) -- info block heading line
173 |> drop 1 -- drop the heading
174 |> map (T.drop 2) -- uncomment
175 |> T.unlines
176 infoJson = infoBlock
177 |> T.encodeUtf8 -- convert Text to ByteString
178 |> Data.Aeson.eitherDecodeStrict
179
180 if T.null (T.filter isSpace infoBlock)
181 then return model
182 else
183 case infoJson of
184 Left err -> userErr1 $ vcat
185 [ "Malformed JSON in a cached Essence Prime model."
186 , "It could be created by a different version of Conjure or modified by hand."
187 , ""
188 , pretty err
189 ]
190 Right i -> return model { mInfo = i }
191
192
193 onlyPreamble :: Text -> Text
194 onlyPreamble
195 = discardAfter "maximising"
196 . discardAfter "maximizing"
197 . discardAfter "minimising"
198 . discardAfter "minimizing"
199 . discardAfter "such that"
200 . stripComments
201 where
202 stripComments = T.unlines . map (T.takeWhile (/= '$')) . T.lines
203 discardAfter t = fst . T.breakOn t
204
205
206 writeModel ::
207 MonadFail m =>
208 MonadIO m =>
209 MonadUserError m =>
210 Int ->
211 OutputFormat ->
212 Maybe FilePath ->
213 Model ->
214 m ()
215 writeModel lnWidth Plain Nothing spec
216 | lnWidth == 0 = liftIO $ putStrLn (show spec)
217 | otherwise = liftIO $ putStrLn (render lnWidth spec)
218 writeModel lnWidth Plain (Just fp) spec
219 | lnWidth == 0 = liftIO $ writeFile fp (show spec)
220 | otherwise = liftIO $ writeFile fp (render lnWidth spec)
221 writeModel _lnWidth Binary Nothing spec = liftIO $ BS.putStrLn (Data.Serialize.encode spec)
222 writeModel _lnWidth Binary (Just fp) spec = liftIO $ BS.writeFile fp (Data.Serialize.encode spec)
223 writeModel lnWidth ASTJSON Nothing spec
224 | lnWidth == 0 = liftIO $ putStrLn (show (toJSON spec))
225 | otherwise = liftIO $ putStrLn (render lnWidth (toJSON spec))
226 writeModel lnWidth ASTJSON (Just fp) spec
227 | lnWidth == 0 = liftIO $ writeFile fp (show (toJSON spec))
228 | otherwise = liftIO $ writeFile fp (render lnWidth (toJSON spec))
229 writeModel lnWidth fmt Nothing spec | fmt `elem` [JSON, JSONStream] = do
230 spec' <- toSimpleJSON spec
231 -- a line width of 0 means "do not wrap". It must still be rendered as JSON:
232 -- show would give the Haskell representation of the value instead.
233 if lnWidth == 0
234 then liftIO $ putStrLn (render maxBound spec')
235 else liftIO $ putStrLn (render lnWidth spec')
236 writeModel lnWidth fmt (Just fp) spec | fmt `elem` [JSON, JSONStream] = do
237 spec' <- toSimpleJSON spec
238 if lnWidth == 0
239 then liftIO $ writeFile fp (render maxBound spec')
240 else liftIO $ writeFile fp (render lnWidth spec')
241 writeModel lnWidth MiniZinc Nothing spec = do
242 spec' <- toMiniZinc spec
243 if lnWidth == 0
244 then liftIO $ putStrLn (show spec')
245 else liftIO $ putStrLn (render lnWidth spec')
246 writeModel lnWidth MiniZinc (Just fp) spec = do
247 spec' <- toMiniZinc spec
248 if lnWidth == 0
249 then liftIO $ writeFile fp (show spec')
250 else liftIO $ writeFile fp (render lnWidth spec')
251 writeModel _ _ _ _ = bug "writeModels"
252
253
254 writeModels ::
255 MonadFail m =>
256 MonadIO m =>
257 MonadUserError m =>
258 Int ->
259 OutputFormat ->
260 FilePath ->
261 String ->
262 [Model] ->
263 m ()
264 writeModels lnWidth mode base tag specs = do
265 let numbers = map (padShowInt 4) [ (1 :: Int) .. ]
266 let outDirname = base ++ "-" ++ tag
267 liftIO $ createDirectoryIfMissing True outDirname
268 forM_ (zip numbers specs) $ \ (i, spec) -> do
269 let outFilename = base ++ "-" ++ tag ++ "/" ++ i ++ ".essence"
270 writeModel lnWidth mode (Just outFilename) spec
271 liftIO $ putStrLn $ "[created file] " ++ outFilename
272