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 -}