<commit_before>{-|
Module      : Idris.Parser.Stack
Description : Idris parser stack and its primitives.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts, MultiParamTypeClasses #-}
module Idris.Parser.Stack
  ( -- * Parsing
    Parser(..)
  , Parsing(..)
  , runparser
    -- * Parse errors
  , ParseError
  , prettyError
    -- * Mark and restore
  , Mark
  , mark
  , restore

    -- * Tracking the extent of productions
    --
    -- The parser stack automatically builds up the extent of any parse from
    -- the extents of sub-parsers wrapped with @trackExtent@.
  , getFC
  , addExtent
  , trackExtent
  , extent
  , withExtent
  , appExtent
  )
where

import Idris.Core.TT (FC(..))
import Idris.Output (Message(..))

import Control.Arrow (app)
import qualified Control.Monad.Fail as Fail
import Control.Monad.State.Strict (StateT(..), evalStateT)
import Control.Monad.Writer.Strict (MonadWriter(..), WriterT(..), listen,
                                    runWriterT, tell)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Void (Void(..))
import System.FilePath (addTrailingPathSeparator, splitFileName)
import qualified Text.Megaparsec as P
import qualified Util.Pretty as PP

{- * Parsing -}

-- | Our parser stack with state of type @s@
type Parser s = StateT s (WriterT FC (P.Parsec Void String))

-- | A constraint for parsing without state
type Parsing m = (Fail.MonadFail m, P.MonadParsec Void String m, MonadWriter FC m)

-- | Run the Idris parser stack
runparser :: Parser st res -> st -> String -> String -> Either ParseError res
runparser p i inputname s =
  case P.parse (runWriterT (evalStateT p i)) inputname s of
    Left err -> Left $ ParseError err
    Right v  -> Right $ fst v

{- * Parse errors -}

newtype ParseError = ParseError { unParseError :: P.ParseErrorBundle String Void }

parseError :: ParseError -> P.ParseError String Void
parseError = NonEmpty.head . P.bundleErrors . unParseError

parseErrorPosState :: ParseError -> P.PosState String
parseErrorPosState = P.bundlePosState . unParseError

parseErrorOffset :: ParseError -> Int
parseErrorOffset = P.errorOffset . parseError

instance Message ParseError where
  messageExtent err = sourcePositionFC pos
    where
#if MIN_VERSION_megaparsec(8,0,0)
      P.PosState {P.pstateSourcePos = pos} =
        P.reachOffsetNoLine (parseErrorOffset err) (parseErrorPosState err)
#else
      (pos, _) = P.reachOffsetNoLine (parseErrorOffset err) (parseErrorPosState err)
#endif
  messageText = PP.text . init . P.parseErrorTextPretty . parseError
  messageSource err = Just sline
    where
#if MIN_VERSION_megaparsec(8,0,0)
      (sline, _) = P.reachOffset (parseErrorOffset err) (parseErrorPosState err)
#else
      (_, sline, _) = P.reachOffset (parseErrorOffset err) (parseErrorPosState err)
#endif

-- | A fully formatted parse error, with caret and bar, etc.
prettyError :: ParseError -> String
prettyError =  P.errorBundlePretty . unParseError<commit_msg>Fix compatibility with megaparsec 9<commit_after>{-|
Module      : Idris.Parser.Stack
Description : Idris parser stack and its primitives.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts, MultiParamTypeClasses #-}
module Idris.Parser.Stack
  ( -- * Parsing
    Parser(..)
  , Parsing(..)
  , runparser
    -- * Parse errors
  , ParseError
  , prettyError
    -- * Mark and restore
  , Mark
  , mark
  , restore

    -- * Tracking the extent of productions
    --
    -- The parser stack automatically builds up the extent of any parse from
    -- the extents of sub-parsers wrapped with @trackExtent@.
  , getFC
  , addExtent
  , trackExtent
  , extent
  , withExtent
  , appExtent
  )
where

import Idris.Core.TT (FC(..))
import Idris.Output (Message(..))

import Control.Arrow (app)
import qualified Control.Monad.Fail as Fail
import Control.Monad.State.Strict (StateT(..), evalStateT)
import Control.Monad.Writer.Strict (MonadWriter(..), WriterT(..), listen,
                                    runWriterT, tell)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Void (Void(..))
import System.FilePath (addTrailingPathSeparator, splitFileName)
import qualified Text.Megaparsec as P
import qualified Util.Pretty as PP

{- * Parsing -}

-- | Our parser stack with state of type @s@
type Parser s = StateT s (WriterT FC (P.Parsec Void String))

-- | A constraint for parsing without state
type Parsing m = (Fail.MonadFail m, P.MonadParsec Void String m, MonadWriter FC m)

-- | Run the Idris parser stack
runparser :: Parser st res -> st -> String -> String -> Either ParseError res
runparser p i inputname s =
  case P.parse (runWriterT (evalStateT p i)) inputname s of
    Left err -> Left $ ParseError err
    Right v  -> Right $ fst v

{- * Parse errors -}

newtype ParseError = ParseError { unParseError :: P.ParseErrorBundle String Void }

parseError :: ParseError -> P.ParseError String Void
parseError = NonEmpty.head . P.bundleErrors . unParseError

parseErrorPosState :: ParseError -> P.PosState String
parseErrorPosState = P.bundlePosState . unParseError

parseErrorOffset :: ParseError -> Int
parseErrorOffset = P.errorOffset . parseError

instance Message ParseError where
  messageExtent err = sourcePositionFC pos
    where
#if MIN_VERSION_megaparsec(8,0,0)
      P.PosState {P.pstateSourcePos = pos} =
        P.reachOffsetNoLine (parseErrorOffset err) (parseErrorPosState err)
#else
      (pos, _) = P.reachOffsetNoLine (parseErrorOffset err) (parseErrorPosState err)
#endif
  messageText = PP.text . init . P.parseErrorTextPretty . parseError
#if MIN_VERSION_megaparsec(9,0,0)
  messageSource err = sline
#else
  messageSource err = Just sline
#endif
    where
#if MIN_VERSION_megaparsec(8,0,0)
      (sline, _) = P.reachOffset (parseErrorOffset err) (parseErrorPosState err)
#else
      (_, sline, _) = P.reachOffset (parseErrorOffset err) (parseErrorPosState err)
#endif

-- | A fully formatted parse error, with caret and bar, etc.
prettyError :: ParseError -> String
prettyError =  P.errorBundlePretty . unParseError
{'fraction_non_alphanumeric': 0.09766454352441614, 'fraction_numerical': 0.002939735423811857, 'mean_word_length': 3.499632623071271, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5417256', 'n_tokens_mistral': 1946, 'n_tokens_neox': 1899, 'n_words': 592}