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