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 if lnWidth == 0
232 then liftIO $ putStrLn (show spec')
233 else liftIO $ putStrLn (render lnWidth spec')
234 writeModel lnWidth fmt (Just fp) spec | fmt `elem` [JSON, JSONStream] = do
235 spec' <- toSimpleJSON spec
236 if lnWidth == 0
237 then liftIO $ writeFile fp (show spec')
238 else liftIO $ writeFile fp (render lnWidth spec')
239 writeModel lnWidth MiniZinc Nothing spec = do
240 spec' <- toMiniZinc spec
241 if lnWidth == 0
242 then liftIO $ putStrLn (show spec')
243 else liftIO $ putStrLn (render lnWidth spec')
244 writeModel lnWidth MiniZinc (Just fp) spec = do
245 spec' <- toMiniZinc spec
246 if lnWidth == 0
247 then liftIO $ writeFile fp (show spec')
248 else liftIO $ writeFile fp (render lnWidth spec')
249 writeModel _ _ _ _ = bug "writeModels"
250
251
252 writeModels ::
253 MonadFail m =>
254 MonadIO m =>
255 MonadUserError m =>
256 Int ->
257 OutputFormat ->
258 FilePath ->
259 String ->
260 [Model] ->
261 m ()
262 writeModels lnWidth mode base tag specs = do
263 let numbers = map (padShowInt 4) [ (1 :: Int) .. ]
264 let outDirname = base ++ "-" ++ tag
265 liftIO $ createDirectoryIfMissing True outDirname
266 forM_ (zip numbers specs) $ \ (i, spec) -> do
267 let outFilename = base ++ "-" ++ tag ++ "/" ++ i ++ ".essence"
268 writeModel lnWidth mode (Just outFilename) spec
269 liftIO $ putStrLn $ "[created file] " ++ outFilename
270