lcc/Hcompta/LCC/Megaparsec.hs

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