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.Compta
  52 import Hcompta.LCC.Document
  53 import Hcompta.LCC.Grammar as LCC
  54 import Hcompta.LCC.IO
  55 import Hcompta.LCC.Journal
  56 import Hcompta.LCC.Posting
  57
  58 import Debug.Trace (trace)
  59 import Data.Semigroup ((<>))
  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)
  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 instance ParsecC e s => Sym.Gram_Rule (P.ParsecT e s m) where
 167         rule = P.label . Text.unpack
 168 instance ParsecC e s => Sym.Gram_Terminal (P.ParsecT e s m) where
 169         any          = P.anyChar
 170         eoi          = P.eof
 171         char         = P.char
 172         string       = P.string
 173         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
 174                 where cats = unicode_categories cat
 175         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
 176         Terminal f `but` Terminal p = Terminal $ P.notFollowedBy (P.try p) *> f
 177 instance ParsecC e s => Sym.Gram_Alt (P.ParsecT e s m) where
 178         empty  = Alt.empty
 179         (<+>)  = (Alt.<|>)
 180         choice = P.choice
 181 instance ParsecC e s => Sym.Gram_Try (P.ParsecT e s m) where
 182         try = P.try
 183 instance ParsecC e s => Sym.Gram_RegR (P.ParsecT e s m) where
 184         Terminal f .*> Reg x = Reg $ f <*> x
 185 instance ParsecC e s => Sym.Gram_RegL (P.ParsecT e s m) where
 186         Reg f <*. Terminal x = Reg $ f <*> x
 187 instance ParsecC e s => Sym.Gram_App (P.ParsecT e s m) where
 188         between = P.between
 189 instance ParsecC e s => Sym.Gram_AltApp (P.ParsecT e s m) where
 190         option   = P.option
 191         optional = P.optional
 192         many     = P.many
 193         some     = P.some
 194         manySkip = P.skipMany
 195 instance ParsecC e s => Sym.Gram_CF (P.ParsecT e s m) where
 196         CF f <& Reg p        = CF $ P.lookAhead f <*> p
 197         Reg f &> CF p        = CF $ P.lookAhead f <*> p
 198         minus (CF f) (Reg p) = CF $ P.notFollowedBy (P.try p) *> f
 199 instance ParsecC e s => Sym.Gram_Comment (P.ParsecT e s m)
 200 instance ParsecC e s => Sym.Gram_Op (P.ParsecT e s m)
 201 instance ParsecC e s => Sym.Gram_Mod (P.ParsecT e s m)
 202 instance ParsecC e s => Sym.Gram_Type_Name (P.ParsecT e s m)
 203 instance ParsecC e s => Sym.Gram_Term_Name (P.ParsecT e s m)
 204 instance -- Sym.Gram_Type
 205  ( ParsecC e s
 206  , Show src
 207  , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 208  , Gram_Source src      (P.ParsecT e s m)
 209  ) => Sym.Gram_Type src (P.ParsecT e s m)
 210 instance -- Sym.Gram_Term_Type
 211  ( ParsecC e s
 212  , Show src
 213  , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 214  , Gram_Source src           (P.ParsecT e s m)
 215  ) => Sym.Gram_Term_Type src (P.ParsecT e s m)
 216 instance -- Sym.Gram_Term
 217  ( ParsecC e s
 218  , Show src
 219  , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) (P.ParsecT e s m)
 220  , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src)  (P.ParsecT e s m)
 221  , Sym.Gram_Source src        (P.ParsecT e s m)
 222  , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 223  ) => Sym.Gram_Term src ss    (P.ParsecT e s m)
 224
 225 --
 226 -- LCC instances
 227 --
 228 instance ParsecC e s => LCC.Gram_Count   (P.ParsecT e s m)
 229 instance ParsecC e s => LCC.Gram_Char    (P.ParsecT e s m)
 230 instance ParsecC e s => LCC.Gram_Comment (P.ParsecT e s m)
 231 instance ParsecC e s => LCC.Gram_Tag     (P.ParsecT e s m)
 232 instance ParsecC e s => LCC.Gram_Account (P.ParsecT e s m)
 233 instance ParsecC e s => LCC.Gram_Amount  (P.ParsecT e s m)
 234 instance ParsecC e s => LCC.Gram_File    (P.ParsecT e s m)
 235 instance -- LCC.Gram_Date
 236  ( ParsecC e s
 237  , MC.MonadState Year (P.ParsecT e s m)
 238  ) => Gram_Date       (P.ParsecT e s m)
 239 instance -- LCC.Gram_Posting
 240  ( ParsecC e s
 241  , MC.MonadState Chart          (P.ParsecT e s m)
 242  , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 243  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 244  ) => Gram_Posting              (P.ParsecT e s m)
 245 instance -- LCC.Gram_Transaction
 246  ( ParsecC e s
 247  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 248  , MC.MonadState Chart          (P.ParsecT e s m)
 249  , MC.MonadState Section        (P.ParsecT e s m)
 250  , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 251  , MC.MonadState Year           (P.ParsecT e s m)
 252  ) => Gram_Transaction          (P.ParsecT e s m)
 253 instance -- LCC.Gram_Chart
 254  ( ParsecC e s
 255  , MC.MonadState Chart          (P.ParsecT e s m)
 256  , MC.MonadState Section        (P.ParsecT e s m)
 257  ) => Gram_Chart                (P.ParsecT e s m)
 258 instance -- LCC.Gram_Path
 259  ( ParsecC e s
 260  , MonadIO m
 261  ) => Gram_Path                 (P.ParsecT e s m) where
 262         g_canonfile g = do
 263                 pf@(PathFile fp) <- g
 264                 liftIO $ (pf,) <$> Exn.catch
 265                  (Right . CanonFile . PathFile <$> IO.canonicalizePath fp)
 266                  (return . Left)
 267 instance -- LCC.Gram_IO
 268  ( ParsecC e s
 269  , MonadIO m
 270  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 271  , MC.MonadState Chart          (P.ParsecT e s m)
 272  , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 273  , MC.MonadState Year           (P.ParsecT e s m)
 274  , Sym.Gram_Source src          (P.ParsecT e s m)
 275  , P.MonadParsec e Text         (P.ParsecT e s m)
 276  ) => Gram_IO src               (P.ParsecT e s m) where
 277         g_read g_path g = do
 278                 lr <- source $ do
 279                         lr_path <- g_path
 280                         case lr_path of
 281                          S.Left (e::Error_Compta src) ->
 282                                 return $ \(src::src) ->
 283                                         S.Left $ At src e
 284                          S.Right (PathFile fp) ->
 285                                 liftIO $ Exn.catch
 286                                  ((\inp _src -> S.Right $ (fp,) $ Enc.decodeUtf8 inp) <$> BS.readFile fp)
 287                                  (\exn -> return $ \src -> S.Left $ At src $ Error_Compta_Read (PathFile fp) exn)
 288                 case lr of
 289                  S.Left e -> return $ S.Left [e]
 290                  S.Right (fp_new, s_new) -> do
 291                         P.pushPosition $ P.initialPos fp_new
 292                         s_old <- P.getInput; P.setInput s_new
 293
 294                         lr_a <- g
 295                                 {-
 296                                 P.observing g >>= \case
 297                                  Left err -> do
 298                                         MC.put jf_old
 299                                         P.setInput s_old
 300                                         P.popPosition
 301                                         P.updateParserState (\st -> st{P.statePos=P.errorPos $ trace ("ERROR: " <> show err) err})
 302                                         P.failure
 303                                          (P.errorUnexpected err)
 304                                          (P.errorExpected err)
 305                                          (P.errorCustom err)
 306                                  Right a -> return a
 307                                 -}
 308
 309                         P.setInput s_old
 310                         P.popPosition
 311
 312                         return lr_a
 313 instance -- LCC.Gram_Compta
 314  ( ParsecC e s
 315  , MonadIO m
 316  , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
 317  , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
 318  , MC.MonadState Terms m
 319  , Gram_Input (P.ParsecT e s m)
 320  -- , Monoid j
 321  -- , Show j
 322  , Show src
 323  , SourceInj (Sym.AST_Type src) src
 324  , SourceInj (Sym.KindK    src) src
 325  , SourceInj (Sym.TypeVT   src) src
 326  , P.MonadParsec e Text                                (P.ParsecT e s m)
 327  , Sym.Gram_Source src                                 (P.ParsecT e s m)
 328  , Sym.Gram_Term_Atoms src ss                          (P.ParsecT e s m)
 329  , MC.MonadReader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m)
 330  , MC.MonadState (Context_Read src)                    (P.ParsecT e s m)
 331  , MC.MonadState (S.Maybe Unit)                        (P.ParsecT e s m)
 332  , MC.MonadState Chart                                 (P.ParsecT e s m)
 333  , MC.MonadState Section                               (P.ParsecT e s m)
 334  , MC.MonadState Style_Amounts                         (P.ParsecT e s m)
 335  , MC.MonadState Year                                  (P.ParsecT e s m)
 336  ) => Gram_Compta ss src (P.ParsecT e s m)
 337 instance -- LCC.Gram_Term_Def
 338  ( ParsecC e s
 339  -- , MC.MonadState (Env src ss) m
 340  , MC.MonadState (Sym.Imports Sym.NameTe, Sym.Modules src ss) m
 341  , MC.MonadState (Sym.Imports Sym.NameTy, Sym.ModulesTy src) m
 342  , Monad m
 343  , Show src
 344  , SourceInj (Sym.AST_Type src) src
 345  , SourceInj (Sym.KindK    src) src
 346  , SourceInj (Sym.TypeVT   src) src
 347  , Gram_Source src            (P.ParsecT e s m)
 348  , P.MonadParsec e Text       (P.ParsecT e s m)
 349  , Sym.Gram_Term_Atoms src ss (P.ParsecT e s m)
 350  ) => LCC.Gram_Term_Def src ss    (P.ParsecT e s m)
 351
 352 instance ParsecC e Text => Gram_Input (P.ParsecT e Text m) where
 353         g_input g = do
 354                 P.State {P.stateInput=ib, P.statePos=P.SourcePos _ lb bc:|_} <- P.getParserState
 355                 f <- g
 356                 P.State {P.statePos=P.SourcePos _ le ce:|_} <- P.getParserState
 357                 return $ f $ (`Text.take` ib) $ sizeInput 0 ib
 358                  (P.unPos le - P.unPos lb)
 359                  (if lb == le then P.unPos ce - P.unPos bc else pred (P.unPos ce))
 360                 where
 361                 sizeInput :: Int -> Text -> Word -> Word -> Int
 362                 sizeInput s _i 0 0 = s
 363                 sizeInput s i 0 c =
 364                         case Text.uncons i of
 365                          Nothing -> error "[BUG] sizeInput"
 366                          Just (_c, i') -> sizeInput (succ s) i' 0 (pred c)
 367                 sizeInput s i l c =
 368                         case Text.uncons i of
 369                          Nothing -> error "[BUG] sizeInput"
 370                          Just ('\n', i') -> sizeInput (succ s) i' (pred l) c
 371                          Just (_c, i')   -> sizeInput (succ s) i' l c
 372
 373 -- syntaxError :: P.ParseError Char P.Dec -> Text
 374 -- syntaxError
 375
 376 parseErrorPretty ::
 377  ( Ord t
 378  , P.ShowToken t
 379  , P.ShowErrorComponent e
 380  ) => P.ParseError t e -> String
 381 parseErrorPretty e =
 382         sourcePosStackPretty (P.errorPos e) ++ ":\n"
 383          ++ parseErrorTextPretty e
 384
 385 -- | Pretty-print stack of source positions.
 386 sourcePosStackPretty :: NonEmpty P.SourcePos -> String
 387 sourcePosStackPretty ms = concatMap f rest ++ P.sourcePosPretty pos
 388         where
 389         (pos :| rest') = ms
 390         rest           = List.reverse rest'
 391         f p = "in file included from " ++ P.sourcePosPretty p ++ ",\n"
 392
 393 showParseError ::
 394  ( Ord t
 395  , P.ShowToken t
 396  , P.ShowErrorComponent e
 397  , D.Doc_Text d
 398  , D.Doc_Color d
 399  , D.Doc_Decoration d
 400  ) => P.ParseError t e -> IO d
 401 showParseError err = do
 402         let (pos:|_) = P.errorPos err
 403         q <- d_sourcepos $ sourcePos pos
 404         return $ D.catV
 405          [ D.stringH (sourcePosStackPretty $ P.errorPos err) <> ":"
 406          , D.stringH $ parseErrorTextPretty err
 407          , q
 408          ]
 409
 410 -- | Transforms list of error messages into their textual representation.
 411 messageItemsPretty :: P.ShowErrorComponent a => String -> Set a -> String
 412 messageItemsPretty prefix ts
 413  | Set.null ts = ""
 414  | otherwise = prefix ++ f ts ++ "\n"
 415         where f = orList . NE.fromList . Set.toAscList . Set.map P.showErrorComponent
 416
 417 orList :: NonEmpty String -> String
 418 orList (x:|[])  = x
 419 orList (x:|[y]) = x ++ " or " ++ y
 420 orList xs       = List.intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs
 421
 422 -- | Pretty-print textual part of a 'ParseError', that is, everything except
 423 -- stack of source positions. The rendered staring always ends with a new line.
 424 parseErrorTextPretty ::
 425  ( Ord t
 426  , P.ShowToken t
 427  , P.ShowErrorComponent e )
 428  => P.ParseError t e
 429  -> String
 430 parseErrorTextPretty (P.ParseError _ us ps xs) =
 431         if Set.null us && Set.null ps && Set.null xs
 432         then "unknown parse error\n"
 433         else concat
 434          [ messageItemsPretty "unexpected " us
 435          , messageItemsPretty "expecting "  ps
 436          , List.unlines (P.showErrorComponent <$> Set.toAscList xs)
 437          ]