]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Read/Megaparsec.hs
stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Read / Megaparsec.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic and LCC grammar instances for Megaparsec
4 module Hcompta.LCC.Read.Megaparsec where
5
6 import Control.Applicative (Applicative(..))
7 import Control.Monad (Monad(..))
8 import Control.Monad.IO.Class (MonadIO(..))
9 import Data.Bool
10 import Data.Char (Char)
11 import Data.Either (Either(..))
12 import Data.Eq (Eq(..))
13 import Data.Foldable
14 import Data.Function (($), (.))
15 import Data.Functor (Functor(..), (<$>))
16 import Data.Int (Int)
17 import Data.List.NonEmpty (NonEmpty(..))
18 import Data.Maybe (Maybe(..))
19 import Data.Ord (Ord(..))
20 import Data.String (IsString(..), String)
21 import Data.Text (Text)
22 import Data.Typeable ()
23 import Prelude (pred, succ, (-), error)
24 import Text.Show (Show(..))
25 import qualified Control.Applicative as Alt
26 import qualified Control.Exception.Safe as Exn
27 import qualified Control.Monad.Classes as MC
28 import qualified Data.ByteString as BS
29 import qualified Data.Char as Char
30 import qualified Data.Strict as S
31 import qualified Data.Text as Text
32 import qualified Data.Text.Encoding as Enc
33 import qualified Data.Text.Lazy as TL
34 import qualified System.Directory as IO
35 import qualified Text.Megaparsec as P
36 import qualified Text.Megaparsec.Char as P
37
38 import Language.Symantic.Grammar as G
39 import qualified Language.Symantic as Sym
40 -- import qualified Language.Symantic.Document as D
41
42 import Hcompta.LCC.Amount
43 import Hcompta.LCC.Chart
44 -- import Hcompta.LCC.Compta
45 -- import Hcompta.LCC.Write
46 import Hcompta.LCC.Read.Compta as LCC
47 import Hcompta.LCC.IO
48 import Hcompta.LCC.Journal
49 import Hcompta.LCC.Source
50
51 import Debug.Trace (trace)
52 import Data.Semigroup ((<>))
53
54 dbg :: Show a => [Char] -> a -> a
55 dbg msg x = trace (msg <> " = " <> show x) x
56
57 -- | Convenient converter.
58 sourcePos :: P.SourcePos -> SourcePos
59 sourcePos (P.SourcePos p l c) = SourcePos p (PosFile $ P.unPos l) (PosFile $ P.unPos c)
60
61 -- * Type 'ParsecC'
62 -- | Convenient alias for defining instances involving 'P.ParsecT'.
63 type ParsecC e s = (P.Token s ~ Char, P.Stream s, Ord e, P.ShowErrorComponent e)
64 instance (ParsecC e s, Gram_String (P.ParsecT e s m)) => IsString (P.ParsecT e s m String) where
65 fromString = string
66 {-
67 instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
68 fromString = P.string
69 -}
70
71 --
72 -- Readers
73 --
74
75 -- NonEmpty SourcePos
76 instance ParsecC e s => G.Gram_Reader (NonEmpty SourcePos) (P.ParsecT e s m) where
77 askBefore g = do
78 s <- (sourcePos <$>) . P.statePos <$> P.getParserState
79 ($ s) <$> g
80 askAfter g = do
81 f <- g
82 f . (sourcePos <$>) . P.statePos <$> P.getParserState
83 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (NonEmpty SourcePos)) = 'True
84 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty SourcePos) (P.ParsecT e s m) where
85 askN _n = (sourcePos <$>) . P.statePos <$> P.getParserState
86 -- SourcePos
87 instance ParsecC e s => G.Gram_Reader SourcePos (P.ParsecT e s m) where
88 askBefore g = do
89 s <- sourcePos <$> P.getPosition
90 ($ s) <$> g
91 askAfter g = do
92 f <- g
93 f . sourcePos <$> P.getPosition
94 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader SourcePos) = 'True
95 instance ParsecC e s => MC.MonadReaderN 'MC.Zero SourcePos (P.ParsecT e s m) where
96 askN _n = sourcePos <$> P.getPosition
97 -- ()
98 instance ParsecC e s => G.Gram_Reader () (P.ParsecT e s m) where
99 askBefore = fmap ($ ())
100 askAfter = fmap ($ ())
101 -- S.Either Exn.IOException CanonFile
102 instance (ParsecC e s, MonadIO m) => G.Gram_Reader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m) where
103 askBefore g = do
104 sn <- P.sourceName <$> P.getPosition
105 f <- g
106 liftIO $ Exn.catch
107 (f . S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
108 (return . f . S.Left)
109 askAfter g = do
110 f <- g
111 sn <- P.sourceName <$> P.getPosition
112 liftIO $ Exn.catch
113 (f . S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
114 (return . f . S.Left)
115 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (S.Either Exn.IOException CanonFile)) = 'True
116 instance (ParsecC e s, MonadIO m) => MC.MonadReaderN 'MC.Zero (S.Either Exn.IOException CanonFile) (P.ParsecT e s m) where
117 askN _n = do
118 sn <- P.sourceName <$> P.getPosition
119 liftIO $ Exn.catch
120 (S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
121 (return . S.Left)
122
123 --
124 -- States
125 --
126
127 -- st
128 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState st) = 'False
129 instance (Monad m, MC.MonadState st m) => G.Gram_State st m where
130 stateBefore g = do
131 s <- MC.get
132 f <- g
133 let (s', a) = f s
134 MC.put s'
135 return a
136 stateAfter g = do
137 f <- g
138 s <- MC.get
139 let (s_, a) = f s
140 MC.put s_
141 return a
142 getBefore g = do
143 s <- MC.get
144 f <- g
145 return (f s)
146 getAfter g = do
147 f <- g
148 s <- MC.get
149 return (f s)
150 put g = do
151 (s, a) <- g
152 MC.put s
153 return a
154
155 --
156 -- Sym instances
157 --
158 instance (ParsecC e s, Show err) => G.Gram_Error err (P.ParsecT e s m) where
159 catch me = do
160 e <- me
161 case e of
162 Left err -> fail $ show err
163 Right a -> return a
164 newtype NoShow a = NoShow a
165 instance Show (NoShow a) where show _ = "NoShow"
166 instance ParsecC e s => G.Gram_Rule (P.ParsecT e s m) where
167 rule = P.label . Text.unpack
168 {-
169 rule n g = do
170 NoShow a <- P.dbg (Text.unpack n) $ NoShow <$> g
171 return a
172 -}
173 instance ParsecC e s => G.Gram_Char (P.ParsecT e s m) where
174 any = P.anyChar
175 eoi = P.eof
176 char = P.char
177 unicat cat = P.satisfy $ (`elem` cats) . Char.generalCategory
178 where cats = unicode_categories cat
179 range (l, h) = P.satisfy $ \c -> l <= c && c <= h
180 Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
181 instance ParsecC e String => G.Gram_String (P.ParsecT e String m) where
182 string = P.string
183 instance ParsecC e Text => G.Gram_String (P.ParsecT e Text m) where
184 string t = Text.unpack <$> P.string (Text.pack t)
185 text = P.string
186 textLazy t = TL.fromStrict <$> P.string (TL.toStrict t)
187 instance ParsecC e s => G.Gram_Alt (P.ParsecT e s m) where
188 empty = Alt.empty
189 (<+>) = (Alt.<|>)
190 choice = P.choice
191 instance ParsecC e s => G.Gram_Try (P.ParsecT e s m) where
192 try = P.try
193 instance ParsecC e s => G.Gram_RegR (P.ParsecT e s m) where
194 Terminal f .*> Reg x = Reg $ f <*> x
195 instance ParsecC e s => G.Gram_RegL (P.ParsecT e s m) where
196 Reg f <*. Terminal x = Reg $ f <*> x
197 instance ParsecC e s => G.Gram_App (P.ParsecT e s m) where
198 between = P.between
199 instance ParsecC e s => G.Gram_AltApp (P.ParsecT e s m) where
200 option = P.option
201 optional = P.optional
202 many = P.many
203 some = P.some
204 manySkip = P.skipMany
205 instance ParsecC e s => G.Gram_CF (P.ParsecT e s m) where
206 CF f <& Reg p = CF $ P.lookAhead f <*> p
207 Reg f &> CF p = CF $ P.lookAhead f <*> p
208 minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
209 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => G.Gram_Comment (P.ParsecT e s m)
210 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => G.Gram_Op (P.ParsecT e s m)
211 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => Sym.Gram_Mod (P.ParsecT e s m)
212 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => Sym.Gram_Type_Name (P.ParsecT e s m)
213 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => Sym.Gram_Term_Name (P.ParsecT e s m)
214 instance -- G.Gram_Type
215 ( ParsecC e s
216 , Show src
217 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (P.ParsecT e s m)
218 , Gram_Source src (P.ParsecT e s m)
219 , G.Gram_String (P.ParsecT e s m)
220 ) => Sym.Gram_Type src (P.ParsecT e s m)
221 instance -- G.Gram_Term_Type
222 ( ParsecC e s
223 , Show src
224 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (P.ParsecT e s m)
225 , Gram_Source src (P.ParsecT e s m)
226 , G.Gram_String (P.ParsecT e s m)
227 ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
228 instance -- G.Gram_Term
229 ( ParsecC e s
230 , Show src
231 , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) (P.ParsecT e s m)
232 , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) (P.ParsecT e s m)
233 , Gram_Source src (P.ParsecT e s m)
234 , G.Gram_String (P.ParsecT e s m)
235 , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
236 ) => Sym.Gram_Term src ss (P.ParsecT e s m)
237
238 --
239 -- LCC instances
240 --
241 instance ParsecC e s => LCC.Gram_Count (P.ParsecT e s m)
242 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_Char (P.ParsecT e s m)
243 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_Comment (P.ParsecT e s m)
244 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_Tag (P.ParsecT e s m)
245 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_Account (P.ParsecT e s m)
246 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_Amount (P.ParsecT e s m)
247 instance (ParsecC e s, G.Gram_String (P.ParsecT e s m)) => LCC.Gram_File (P.ParsecT e s m)
248 instance -- LCC.Gram_Date
249 ( ParsecC e s
250 , MC.MonadState Year (P.ParsecT e s m)
251 , G.Gram_String (P.ParsecT e s m)
252 ) => Gram_Date (P.ParsecT e s m)
253 instance -- LCC.Gram_Posting
254 ( ParsecC e s
255 , MC.MonadState Chart (P.ParsecT e s m)
256 , MC.MonadState Style_Amounts (P.ParsecT e s m)
257 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
258 , G.Gram_String (P.ParsecT e s m)
259 ) => Gram_Posting (P.ParsecT e s m)
260 instance -- LCC.Gram_Transaction
261 ( ParsecC e s
262 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
263 , MC.MonadState Chart (P.ParsecT e s m)
264 , MC.MonadState Section (P.ParsecT e s m)
265 , MC.MonadState Style_Amounts (P.ParsecT e s m)
266 , MC.MonadState Year (P.ParsecT e s m)
267 , G.Gram_String (P.ParsecT e s m)
268 ) => Gram_Transaction (P.ParsecT e s m)
269 instance -- LCC.Gram_Chart
270 ( ParsecC e s
271 , MC.MonadState Chart (P.ParsecT e s m)
272 , MC.MonadState Section (P.ParsecT e s m)
273 , G.Gram_String (P.ParsecT e s m)
274 ) => Gram_Chart (P.ParsecT e s m)
275 instance -- LCC.Gram_Path
276 ( ParsecC e s
277 , MonadIO m
278 ) => Gram_Path (P.ParsecT e s m) where
279 g_canonfile g = do
280 pf@(PathFile fp) <- g
281 liftIO $ (pf,) <$> Exn.catch
282 (Right . CanonFile . PathFile <$> IO.canonicalizePath fp)
283 (return . Left)
284 instance -- LCC.Gram_IO
285 ( ParsecC e s
286 , MonadIO m
287 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
288 , MC.MonadState Chart (P.ParsecT e s m)
289 , MC.MonadState Style_Amounts (P.ParsecT e s m)
290 , MC.MonadState Year (P.ParsecT e s m)
291 , Gram_Source src (P.ParsecT e s m)
292 , P.MonadParsec e Text (P.ParsecT e s m)
293 ) => Gram_IO src (P.ParsecT e s m) where
294 g_read g_path g = do
295 lr <- source $ do
296 lr_path <- g_path
297 case lr_path of
298 S.Left (e::Error_Compta src) ->
299 return $ \(src::src) ->
300 S.Left $ At src e
301 S.Right (PathFile fp) ->
302 liftIO $ Exn.catch
303 ((\inp _src -> S.Right $ (fp,) $ Enc.decodeUtf8 inp) <$> BS.readFile fp)
304 (\exn -> return $ \src -> S.Left $ At src $ Error_Compta_Read (PathFile fp) exn)
305 case lr of
306 S.Left e -> return $ S.Left [e]
307 S.Right (fp_new, s_new) -> do
308 P.pushPosition $ P.initialPos fp_new
309 s_old <- P.getInput; P.setInput s_new
310
311 lr_a <- g
312 {-
313 P.observing g >>= \case
314 Left err -> do
315 MC.put jf_old
316 P.setInput s_old
317 P.popPosition
318 P.updateParserState (\st -> st{P.statePos=P.errorPos $ trace ("ERROR: " <> show err) err})
319 P.failure
320 (P.errorUnexpected err)
321 (P.errorExpected err)
322 (P.errorCustom err)
323 Right a -> return a
324 -}
325
326 P.setInput s_old
327 P.popPosition
328
329 return lr_a
330 instance -- LCC.Gram_Compta
331 ( ParsecC e s
332 , MonadIO m
333 -- , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
334 -- , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
335 , MC.MonadState (Terms src) m
336 , Gram_Input (P.ParsecT e s m)
337 -- , Monoid j
338 -- , Show j
339 -- , Show src
340 -- , SourceInj (NonEmpty SourcePos) src
341 -- , SourceInj (Sym.AST_Type src) src
342 -- , SourceInj (Sym.KindK src) src
343 -- , SourceInj (Sym.TypeVT src) src
344 , P.MonadParsec e Text (P.ParsecT e s m)
345 , Gram_Source src (P.ParsecT e s m)
346 -- , G.Gram_Term_Atoms src ss (P.ParsecT e s m)
347 , MC.MonadReader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m)
348 , MC.MonadState (Context_Read src) (P.ParsecT e s m)
349 , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
350 , MC.MonadState Chart (P.ParsecT e s m)
351 , MC.MonadState Section (P.ParsecT e s m)
352 , MC.MonadState Style_Amounts (P.ParsecT e s m)
353 , MC.MonadState Year (P.ParsecT e s m)
354 , G.Gram_String (P.ParsecT e s m)
355 ) => Gram_Compta {-ss-} src (P.ParsecT e s m)
356 instance -- LCC.Gram_Term_Def
357 ( ParsecC e s
358 -- , MC.MonadState (Env src ss) m
359 -- , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
360 -- , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
361 , Monad m
362 -- , Show src
363 -- , SourceInj (Sym.AST_Type src) src
364 -- , SourceInj (Sym.KindK src) src
365 -- , SourceInj (Sym.TypeVT src) src
366 -- , Gram_Source src (P.ParsecT e s m)
367 , P.MonadParsec e Text (P.ParsecT e s m)
368 -- , G.Gram_Term_Atoms src ss (P.ParsecT e s m)
369 , G.Gram_String (P.ParsecT e s m)
370 ) => LCC.Gram_Term_Def src {-ss-} (P.ParsecT e s m)
371
372 instance ParsecC e Text => Gram_Input (P.ParsecT e Text m) where
373 g_input g = do
374 P.State {P.stateInput=ib, P.statePos=P.SourcePos _ lb bc:|_} <- P.getParserState
375 f <- g
376 P.State {P.statePos=P.SourcePos _ le ce:|_} <- P.getParserState
377 return $ f $ (`Text.take` ib) $ sizeInput 0 ib
378 (P.unPos le - P.unPos lb)
379 (if lb == le then P.unPos ce - P.unPos bc else pred (P.unPos ce))
380 where
381 sizeInput :: Int -> Text -> Int -> Int -> Int
382 sizeInput s _i 0 0 = s
383 sizeInput s i 0 c =
384 case Text.uncons i of
385 Nothing -> error "[BUG] sizeInput"
386 Just (_c, i') -> sizeInput (succ s) i' 0 (pred c)
387 sizeInput s i l c =
388 case Text.uncons i of
389 Nothing -> error "[BUG] sizeInput"
390 Just ('\n', i') -> sizeInput (succ s) i' (pred l) c
391 Just (_c, i') -> sizeInput (succ s) i' l c
392
393 -- syntaxError :: P.ParseError Char P.Dec -> Text
394 -- syntaxError
395
396 {-
397 parseErrorPretty ::
398 ( Ord t
399 , P.ShowToken t
400 , P.ShowErrorComponent e
401 ) => P.ParseError t e -> String
402 parseErrorPretty e =
403 sourcePosStackPretty (P.errorPos e) ++ ":\n"
404 ++ parseErrorTextPretty e
405
406 -- | Pretty-print stack of source positions.
407 sourcePosStackPretty :: NonEmpty P.SourcePos -> String
408 sourcePosStackPretty ms = concatMap f rest ++ P.sourcePosPretty pos
409 where
410 (pos :| rest') = ms
411 rest = List.reverse rest'
412 f p = "in file included from " ++ P.sourcePosPretty p ++ ",\n"
413
414 showParseError ::
415 ( Ord t
416 , P.ShowToken t
417 , P.ShowErrorComponent e
418 , D.Doc_Text d
419 , D.Doc_Color d
420 , D.Doc_Decoration d
421 ) => P.ParseError t e -> IO d
422 showParseError err = do
423 let (pos:|_) = P.errorPos err
424 q <- write $ sourcePos pos
425 return $ D.catV
426 [ D.stringH (sourcePosStackPretty $ P.errorPos err) <> ":"
427 , D.stringH $ parseErrorTextPretty err
428 , q
429 ]
430
431 -- | Transforms list of error messages into their textual representation.
432 messageItemsPretty :: P.ShowErrorComponent a => String -> Set a -> String
433 messageItemsPretty prefix ts
434 | Set.null ts = ""
435 | otherwise = prefix ++ f ts ++ "\n"
436 where f = orList . NE.fromList . Set.toAscList . Set.map P.showErrorComponent
437
438 orList :: NonEmpty String -> String
439 orList (x:|[]) = x
440 orList (x:|[y]) = x ++ " or " ++ y
441 orList xs = List.intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs
442
443 -- | Pretty-print textual part of a 'ParseError', that is, everything except
444 -- stack of source positions. The rendered staring always ends with a new line.
445 parseErrorTextPretty ::
446 ( Ord t
447 , P.ShowToken t
448 , P.ShowErrorComponent e )
449 => P.ParseError t e
450 -> String
451 parseErrorTextPretty (P.ParseError _ us ps xs) =
452 if Set.null us && Set.null ps && Set.null xs
453 then "unknown parse error\n"
454 else concat
455 [ messageItemsPretty "unexpected " us
456 , messageItemsPretty "expecting " ps
457 , List.unlines (P.showErrorComponent <$> Set.toAscList xs)
458 ]
459 -}