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