diff --git a/example.hs b/example.hs --- a/example.hs +++ b/example.hs @@ -1,12 +1,26 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + import System.Environment (getArgs) import Text.PariPari import qualified Data.ByteString as B +type StringType = B.ByteString +type ParserMonad p = CharParser StringType p +type Parser a = (forall p. ParserMonad p => p a) + +-- {-# SPECIALISE_ALL ParserMonad p = p ~ Acceptor StringType #-} +-- {-# SPECIALISE_ALL ParserMonad p = p ~ Reporter StringType #-} +-- {-# SPECIALISE_ALL Parser = Acceptor StringType #-} +-- {-# SPECIALISE_ALL Parser = Reporter StringType #-} + data Value - = Object ![(Text, Value)] + = Object ![(StringType, Value)] | Array ![Value] - | String !Text + | String !StringType | Number !Integer !Integer | Bool !Bool | Null @@ -18,7 +32,7 @@ object :: Parser Value object = Object <$> (char '{' *> space *> sepBy pair (space *> char ',' *> space) <* space <* char '}') "object" -pair :: Parser (Text, Value) +pair :: Parser (StringType, Value) pair = (,) <$> (text <* space) <*> (char ':' *> space *> value) array :: Parser Value @@ -34,7 +48,7 @@ <|> (Null <$ string "null") <|> number -text :: Parser Text +text :: Parser StringType text = char '"' *> takeCharsWhile (/= '"') <* char '"' "text" number :: Parser Value @@ -52,9 +66,9 @@ case args of [file] -> do b <- B.readFile file - case runParser json file b of - Left x -> do - putStrLn $ showReport x + case runCharParser json file b of + Left report -> do + putStrLn $ showReport report print $ runTracer json file b - Right x -> print x - _ -> error "Usage: example test.json" + Right val -> print val + _ -> error "Usage: paripari-example test.json" diff --git a/paripari.cabal b/paripari.cabal --- a/paripari.cabal +++ b/paripari.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 35567a9d1dd99ccd046b88ea5fd4cf74ce38d5bb58560bb7f1b3450ff1a1fbbe +-- hash: 2b6dd0a88b444dee67e31d36c8744b234a1ef0a86434d9caacc7196eba7ac3f9 name: paripari -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Fast-path parser combinators with fallback for error reporting description: PariPari offers two parsing strategies. There is a fast Acceptor and a slower Reporter which are evaluated in parallel. If the Acceptor fails, the Reporter returns a report about the parsing errors. Unlike Parsec and like Attoparsec, the parser combinators backtrack by default. category: Text @@ -28,17 +28,18 @@ library exposed-modules: Text.PariPari - Text.PariPari.Acceptor - Text.PariPari.Ascii - Text.PariPari.Class - Text.PariPari.Combinators - Text.PariPari.Decode - Text.PariPari.Reporter + Text.PariPari.Internal.Acceptor + Text.PariPari.Internal.CharCombinators + Text.PariPari.Internal.Chunk + Text.PariPari.Internal.Class + Text.PariPari.Internal.ElementCombinators + Text.PariPari.Internal.Reporter + Text.PariPari.Internal.Run + Text.PariPari.Internal.Tracer other-modules: Paths_paripari hs-source-dirs: src - default-extensions: BangPatterns DeriveGeneric GeneralizedNewtypeDeriving MultiWayIf NamedFieldPuns OverloadedStrings Rank2Types ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances build-depends: base >=4.8 && <5 @@ -47,16 +48,46 @@ , text >=0.11 && <1.3 default-language: Haskell2010 -executable example +executable paripari-example main-is: example.hs other-modules: Paths_paripari - default-extensions: BangPatterns DeriveGeneric GeneralizedNewtypeDeriving MultiWayIf NamedFieldPuns OverloadedStrings Rank2Types ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances build-depends: base >=4.8 && <5 , bytestring >=0.10 && <0.11 , paripari , parser-combinators >=1.0 && <1.1 + , text >=0.11 && <1.3 + default-language: Haskell2010 + +executable paripari-specialise-all + main-is: specialise-all.hs + other-modules: + Paths_paripari + ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances + build-depends: + base >=4.8 && <5 + , bytestring >=0.10 && <0.11 + , paripari + , parser-combinators >=1.0 && <1.1 + , text >=0.11 && <1.3 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: test.hs + other-modules: + Paths_paripari + hs-source-dirs: + test + ghc-options: -Wall -Widentities -Wmonomorphism-restriction -Wincomplete-uni-patterns -Wincomplete-record-updates -Wtabs -fprint-potential-instances + build-depends: + base >=4.8 && <5 + , bytestring >=0.10 && <0.11 + , paripari + , parser-combinators >=1.0 && <1.1 + , tasty + , tasty-hunit , text >=0.11 && <1.3 default-language: Haskell2010 diff --git a/specialise-all.hs b/specialise-all.hs new file mode 100644 --- /dev/null +++ b/specialise-all.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +import System.Environment (getArgs) +import Text.PariPari +import qualified Data.Char as C +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Text.IO as T + +type StringType = T.Text +type ParserMonad p = CharParser StringType p +type Parser a = (forall p. ParserMonad p => p a) + +data Type + = TypeName !StringType + | TypeVar !StringType + | TypeApp !Type !(NE.NonEmpty Type) + | TypeEq !Type !Type + | TypeConstr !Type !Type + | TypeLam !Type !Type + | TypeTuple ![Type] + | TypeList !Type + deriving (Show, Eq) + +data SourceLine + = SpecialiseAll !Type !Type + | TypeDecl !(NE.NonEmpty StringType) !Type + | OtherLine !StringType + deriving (Show) + +source :: Parser [SourceLine] +source = sepBy sourceLine (char '\n') <* eof + +sourceLine :: Parser SourceLine +sourceLine = specialiseAll <|> typeDecl <|> otherLine + +otherLine :: Parser SourceLine +otherLine = OtherLine <$> takeCharsWhile (/= '\n') + +specialiseAll :: Parser SourceLine +specialiseAll = SpecialiseAll + <$> (symbol "{-#" *> symbol "SPECIALISE_ALL" *> type_) + <*> (symbol "=" *> type_ <* symbol "#-}") + +identifierAtom :: ParserMonad p => (Char -> Bool) -> p () +identifierAtom f = satisfy f *> skipCharsWhile (\c -> C.isAlphaNum c || c == '_' || c == '\'') + +name :: Parser StringType +name = asChunk (sepEndBy (identifierAtom C.isUpper) (char '.') *> + identifierAtom C.isLower) <* space + +typeName :: Parser StringType +typeName = asChunk (void $ sepBy1 (identifierAtom C.isUpper) (char '.')) <* space + +symbol :: ParserMonad p => StringType -> p StringType +symbol s = string s <* space + +typeTuple :: Parser Type +typeTuple = do + ts <- between (symbol "(") (symbol ")") (sepBy type_ (symbol ",")) + pure $ case ts of + [] -> TypeName "()" + [t] -> t + _ -> TypeTuple ts + +typeAtom :: Parser Type +typeAtom = + TypeName <$> typeName + <|> TypeVar <$> name + <|> TypeList <$> between (symbol "[") (symbol "]") type_ + <|> typeTuple + +typeApp :: Parser Type +typeApp = do + t <- typeAtom + option t $ TypeApp t <$> some typeAtom + +type_ :: Parser Type +type_ = do + t <- typeApp + TypeEq t <$> (symbol "~" *> type_) + <|> TypeLam t <$> (symbol "->" *> type_) + <|> TypeConstr t <$> (symbol "=>" *> type_) + <|> pure t + +typeDecl :: Parser SourceLine +typeDecl = TypeDecl <$> sepBy1 name (symbol ",") <*> (symbol "::" *> type_) + +space :: Parser () +space = skipCharsWhile (== ' ') + +showType :: Type -> StringType +showType (TypeName t) = t +showType (TypeVar t) = t +showType (TypeApp t a) = "(" <> showType t <> " " <> T.intercalate " " (NE.toList $ fmap showType a) <> ")" +showType (TypeEq a b) = "(" <> showType a <> " ~ " <> showType b <> ")" +showType (TypeLam a b) = "(" <> showType a <> " -> " <> showType b <> ")" +showType (TypeConstr a b) = "(" <> showType a <> " => " <> showType b <> ")" +showType (TypeList t) = "[" <> showType t <> "]" +showType (TypeTuple t) = "(" <> T.intercalate ", " (fmap showType t) <> ")" + +showSource :: SourceLine -> StringType +showSource (SpecialiseAll from to) = "-- SPECIALISE_ALL " <> showType from <> " = " <> showType to +showSource (TypeDecl names t) = T.intercalate "," (NE.toList names) <> " :: " <> showType t +showSource (OtherLine str) = str + +substitute :: [(StringType, Type)] -> Type -> Type +substitute vars t@(TypeVar v) + | Just t' <- lookup v vars = t' + | otherwise = t +substitute _ t@TypeName{} = t +substitute vars (TypeApp t a) = TypeApp (substitute vars t) (fmap (substitute vars) a) +substitute vars (TypeEq a b) = TypeEq (substitute vars a) (substitute vars b) +substitute vars (TypeConstr a b) = TypeConstr (substitute vars a) (substitute vars b) +substitute vars (TypeLam a b) = TypeLam (substitute vars a) (substitute vars b) +substitute vars (TypeTuple t) = TypeTuple (fmap (substitute vars) t) +substitute vars (TypeList t) = TypeList (substitute vars t) + +unify :: Type -> Type -> Maybe [(StringType, Type)] +unify (TypeVar v) t = + Just [(v, t)] +unify (TypeName t1) (TypeName t2) + | t1 == t2 = Just [] +unify (TypeApp t1 a1) (TypeApp t2 a2) | length a1 == length a2 = do + t <- unify t1 t2 + a <- foldMap (uncurry unify) $ NE.zip a1 a2 + pure $ t <> a +unify (TypeEq a1 b1) (TypeEq a2 b2) = do + a <- unify a1 a2 + b <- unify b1 b2 + pure $ a <> b +unify (TypeConstr a1 b1) (TypeConstr a2 b2) = do + a <- unify a1 a2 + b <- unify b1 b2 + pure $ a <> b +unify (TypeLam a1 b1) (TypeLam a2 b2) = do + a <- unify a1 a2 + b <- unify b1 b2 + pure $ a <> b +unify (TypeTuple t1) (TypeTuple t2) | length t1 == length t2 = + foldMap (uncurry unify) $ zip t1 t2 +unify (TypeList t1) (TypeList t2) = + unify t1 t2 +unify _ _ = Nothing + +simplify :: Type -> Type +simplify t@TypeVar{} = t +simplify t@TypeName{} = t +simplify (TypeApp t a) = TypeApp (simplify t) (fmap simplify a) +simplify (TypeEq a b) = TypeEq (simplify a) (simplify b) +simplify (TypeLam a b) = TypeLam (simplify a) (simplify b) +simplify (TypeTuple t) = TypeTuple (fmap simplify t) +simplify (TypeList t) = TypeList (simplify t) +simplify (TypeConstr (TypeEq (TypeVar v) t) t') = substitute [(v, t)] t' +simplify (TypeConstr c t) = TypeConstr (TypeTuple otherConstraints) (substitute constraintVars t) + where eqConstraints = [e | e@(TypeEq TypeVar{} _) <- constraints] + constraintVars = [(v,x) | TypeEq (TypeVar v) x <- eqConstraints] + otherConstraints = filter (\x -> all (/= x) eqConstraints) constraints + constraints = case c of + TypeTuple xs -> xs + x -> [x] + +specialiseType :: Type -> Type -> Type -> Type +specialiseType from to typ + | Just vars <- unify from typ = substitute vars to + | otherwise = + case typ of + TypeName{} -> typ + TypeVar{} -> typ + TypeApp t a -> TypeApp (specialiseType from to t) (fmap (specialiseType from to) a) + TypeEq a b -> TypeEq (specialiseType from to a) (specialiseType from to b) + TypeConstr a b -> TypeConstr (specialiseType from to a) (specialiseType from to b) + TypeLam a b -> TypeLam (specialiseType from to a) (specialiseType from to b) + TypeTuple t -> TypeTuple (fmap (specialiseType from to) t) + TypeList t -> TypeList (specialiseType from to t) + +specialise :: [(Type, Type)] -> (NE.NonEmpty StringType, Type) -> [StringType] +specialise specs (names, typ) = concatMap go specs + where go (from, to) + | typ' <- specialiseType from to typ, typ /= typ' = + ["{-# SPECIALISE " <> n <> " :: " <> showType (simplify typ') <> " #-}" | n <- NE.toList names] + | otherwise = [] + +main :: IO () +main = do + args <- getArgs + case args of + [src, _, dst] -> do + code <- T.readFile src + case runCharParser source src code of + Left report -> putStrLn $ showReport report + Right ls -> do + let specialisers = [(from, to) | SpecialiseAll from to <- ls] + specialisedTypeDecls = concatMap (specialise specialisers) [(n, t) | TypeDecl n t <- ls] + T.writeFile dst $ T.intercalate "\n" $ map showSource ls <> specialisedTypeDecls + _ -> error "Usage: paripari-specialise-all src _ dst" diff --git a/src/Text/PariPari.hs b/src/Text/PariPari.hs --- a/src/Text/PariPari.hs +++ b/src/Text/PariPari.hs @@ -1,53 +1,43 @@ module Text.PariPari ( - module Text.PariPari.Class - , module Text.PariPari.Combinators - , module Text.PariPari.Acceptor - , module Text.PariPari.Reporter - , runParser - , runSeqParser - , runParserWithOptions - , runSeqParserWithOptions -) where + C.ChunkParser(..) + , C.CharParser(..) + , C.Error(..) + , C.showError -import Text.PariPari.Acceptor -import Text.PariPari.Class -import Text.PariPari.Combinators -import Text.PariPari.Reporter -import GHC.Conc (par) + , K.Chunk(Element, showElement, showChunk) + , K.CharChunk + , K.Pos(..) --- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **in parallel**. --- The 'FilePath' is used for error reporting. --- When the acceptor does not return successfully, the result from the reporter --- is awaited. -runParser :: Parser a -> FilePath -> ByteString -> Either Report a -runParser = runParserWithOptions defaultReportOptions -{-# INLINE runParser #-} --- Inline to force the specializer to kick in + , U.runCharParser + , U.runSeqCharParser + , U.runCharParserWithOptions + , U.runSeqCharParserWithOptions + , U.runChunkParser + , U.runSeqChunkParser + , U.runChunkParserWithOptions + , U.runSeqChunkParserWithOptions --- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **sequentially**. --- The 'FilePath' is used for error reporting. --- When the acceptor does not return successfully, the result from the reporter --- is awaited. -runSeqParser :: Parser a -> FilePath -> ByteString -> Either Report a -runSeqParser = runSeqParserWithOptions defaultReportOptions -{-# INLINE runSeqParser #-} + , A.Acceptor + , A.runAcceptor --- | Run parsers **in parallel** with additional 'ReportOptions'. -runParserWithOptions :: ReportOptions -> Parser a -> FilePath -> ByteString -> Either Report a -runParserWithOptions o p f b = - let a = runAcceptor p f b - r = runReporterWithOptions o p f b - in case r `par` a of - Left _ -> r - Right x -> Right x -{-# INLINE runParserWithOptions #-} + , R.Reporter + , R.runReporter + , R.showReport + , R.showErrors + , R.runReporterWithOptions --- | Run parsers **sequentially** with additional 'ReportOptions'. -runSeqParserWithOptions :: ReportOptions -> Parser a -> FilePath -> ByteString -> Either Report a -runSeqParserWithOptions o p f b = - let a = runAcceptor p f b - r = runReporterWithOptions o p f b - in case a of - Left _ -> r - Right x -> Right x -{-# INLINE runSeqParserWithOptions #-} + , T.Tracer + , T.runTracer + + , module Text.PariPari.Internal.ElementCombinators + , module Text.PariPari.Internal.CharCombinators +) where + +import Text.PariPari.Internal.CharCombinators +import Text.PariPari.Internal.ElementCombinators +import qualified Text.PariPari.Internal.Acceptor as A +import qualified Text.PariPari.Internal.Chunk as K +import qualified Text.PariPari.Internal.Class as C +import qualified Text.PariPari.Internal.Reporter as R +import qualified Text.PariPari.Internal.Run as U +import qualified Text.PariPari.Internal.Tracer as T diff --git a/src/Text/PariPari/Acceptor.hs b/src/Text/PariPari/Acceptor.hs deleted file mode 100644 --- a/src/Text/PariPari/Acceptor.hs +++ /dev/null @@ -1,242 +0,0 @@ -module Text.PariPari.Acceptor ( - Acceptor - , runAcceptor -) where - -import Control.Monad (void) -import Text.PariPari.Ascii -import Text.PariPari.Class -import Text.PariPari.Decode -import Foreign.ForeignPtr (ForeignPtr) -import qualified Control.Monad.Fail as Fail -import qualified Data.ByteString.Internal as B - -data Env = Env - { _envSrc :: !(ForeignPtr Word8) - , _envEnd :: !Int - , _envFile :: !FilePath - , _envRefLine :: !Int - , _envRefCol :: !Int - } - -data State = State - { _stOff :: !Int - , _stLine :: !Int - , _stCol :: !Int - } - --- | Parser which is optimized for fast parsing. Error reporting --- is minimal. -newtype Acceptor a = Acceptor - { unAcceptor :: forall b. Env -> State - -> (a -> State -> b) - -> (Error -> b) - -> b - } - -instance Semigroup a => Semigroup (Acceptor a) where - p1 <> p2 = (<>) <$> p1 <*> p2 - {-# INLINE (<>) #-} - -instance Monoid a => Monoid (Acceptor a) where - mempty = pure mempty - {-# INLINE mempty #-} - -instance Functor Acceptor where - fmap f p = Acceptor $ \env st ok err -> - unAcceptor p env st (ok . f) err - {-# INLINE fmap #-} - -instance Applicative Acceptor where - pure x = Acceptor $ \_ st ok _ -> ok x st - {-# INLINE pure #-} - - f <*> a = Acceptor $ \env st ok err -> - let ok1 f' s = - let ok2 a' s' = ok (f' a') s' - in unAcceptor a env s ok2 err - in unAcceptor f env st ok1 err - {-# INLINE (<*>) #-} - - p1 *> p2 = do - void p1 - p2 - {-# INLINE (*>) #-} - - p1 <* p2 = do - x <- p1 - void p2 - pure x - {-# INLINE (<*) #-} - -instance Alternative Acceptor where - empty = Acceptor $ \_ _ _ err -> err EEmpty - {-# INLINE empty #-} - - p1 <|> p2 = Acceptor $ \env st ok err -> - let err' _ = unAcceptor p2 env st ok err - in unAcceptor p1 env st ok err' - {-# INLINE (<|>) #-} - -instance MonadPlus Acceptor - -instance Monad Acceptor where - p >>= f = Acceptor $ \env st ok err -> - let ok' x s = unAcceptor (f x) env s ok err - in unAcceptor p env st ok' err - {-# INLINE (>>=) #-} - - fail msg = Fail.fail msg - {-# INLINE fail #-} - -instance Fail.MonadFail Acceptor where - fail msg = failWith $ EFail msg - {-# INLINE fail #-} - -instance MonadParser Acceptor where - getPos = get $ \_ st -> Pos (_stLine st) (_stCol st) - {-# INLINE getPos #-} - - getFile = get $ \env _ -> _envFile env - {-# INLINE getFile #-} - - getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env) - {-# INLINE getRefPos #-} - - withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p - {-# INLINE withRefPos #-} - - notFollowedBy p = Acceptor $ \env st ok err -> - let ok' _ _ = err $ ECombinator "notFollowedBy" - err' _ = ok () st - in unAcceptor p env st ok' err' - {-# INLINE notFollowedBy #-} - - lookAhead p = Acceptor $ \env st ok err -> - let ok' x _ = ok x st - in unAcceptor p env st ok' err - {-# INLINE lookAhead #-} - - failWith e = Acceptor $ \_ _ _ err -> err e - {-# INLINE failWith #-} - - eof = Acceptor $ \env st ok err -> - if _stOff st >= _envEnd env then - ok () st - else - err EExpectedEnd - {-# INLINE eof #-} - - label _ p = p - {-# INLINE label #-} - - hidden p = p - {-# INLINE hidden #-} - - commit p = p - {-# INLINE commit #-} - - byte b = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> - if | _stOff >= _envEnd env -> err EEmpty - | b == byteAt (_envSrc env) _stOff -> - ok b st - { _stOff =_stOff + 1 - , _stLine = if b == asc_newline then _stLine + 1 else _stLine - , _stCol = if b == asc_newline then 1 else _stCol + 1 - } - | otherwise -> - err $ ECombinator "byte" - {-# INLINE byte #-} - - byteSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> - let b = byteAt (_envSrc env) _stOff - in if | _stOff >= _envEnd env -> err EEmpty - | f b -> - ok b st - { _stOff =_stOff + 1 - , _stLine = if b == asc_newline then _stLine + 1 else _stLine - , _stCol = if b == asc_newline then 1 else _stCol + 1 - } - | otherwise -> - err $ ECombinator "byteSatisfy" - {-# INLINE byteSatisfy #-} - - bytes b@(B.PS p i n) = Acceptor $ \env st@State{_stOff,_stCol} ok err -> - if n + _stOff <= _envEnd env && - bytesEqual (_envSrc env) _stOff p i n then - ok b st { _stOff = _stOff + n, _stCol = _stCol + n } - else - err $ ECombinator "bytes" - {-# INLINE bytes #-} - - asBytes p = do - begin <- get (const _stOff) - p - end <- get (const _stOff) - src <- get (\env _ -> _envSrc env) - pure $ B.PS src begin (end - begin) - {-# INLINE asBytes #-} - - satisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> - let (c, w) = utf8Decode (_envSrc env) _stOff - in if | c /= '\0' -> - if f c then - ok c st - { _stOff =_stOff + w - , _stLine = if c == '\n' then _stLine + 1 else _stLine - , _stCol = if c == '\n' then 1 else _stCol + 1 - } - else - err $ ECombinator "satisfy" - | c == '\0' && _stOff >= _envEnd env -> err EEmpty - | otherwise -> err $ ECombinator "satisfy" - {-# INLINE satisfy #-} - - -- By inling this combinator, GHC should figure out the `utf8Width` - -- of the character resulting in an optimized decoder. - char c = - let w = utf8Width c - in Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> - if utf8DecodeFixed w (_envSrc env) _stOff == c then - ok c st - { _stOff =_stOff + w - , _stLine = if c == '\n' then _stLine + 1 else _stLine - , _stCol = if c == '\n' then 1 else _stCol + 1 - } - else - err $ ECombinator "char" - {-# INLINE char #-} - --- | Reader monad, get something from the environment -get :: (Env -> State -> a) -> Acceptor a -get f = Acceptor $ \env st ok _ -> ok (f env st) st -{-# INLINE get #-} - --- | Reader monad, modify environment locally -local :: (State -> Env -> Env) -> Acceptor a -> Acceptor a -local f p = Acceptor $ \env st ok err -> - unAcceptor p (f st env) st ok err -{-# INLINE local #-} - --- | Run 'Acceptor' on the given 'ByteString', returning either --- a simple 'Error' or, if successful, the result. -runAcceptor :: Acceptor a -> FilePath -> ByteString -> Either Error a -runAcceptor p f t = - let b = t <> "\0\0\0" - in unAcceptor p (initialEnv f b) (initialState b) (\x _ -> Right x) Left - -initialEnv :: FilePath -> ByteString -> Env -initialEnv _envFile (B.PS _envSrc off len) = Env - { _envSrc - , _envFile - , _envEnd = off + len - 3 - , _envRefLine = 0 - , _envRefCol = 0 - } - -initialState :: ByteString -> State -initialState (B.PS _ _stOff _) = State - { _stOff - , _stLine = 1 - , _stCol = 1 - } diff --git a/src/Text/PariPari/Ascii.hs b/src/Text/PariPari/Ascii.hs deleted file mode 100644 --- a/src/Text/PariPari/Ascii.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Text.PariPari.Ascii ( - module Text.PariPari.Ascii -) where - -import Data.ByteString (ByteString) -import Data.Foldable (foldl') -import Data.Word (Word8) -import GHC.Base (unsafeChr) -import GHC.Show (showLitChar) -import Numeric (showHex) -import qualified Data.ByteString as B - -asc_0, asc_9, asc_A, asc_E, asc_P, asc_a, asc_e, asc_p, - asc_minus, asc_plus, asc_point, asc_newline :: Word8 -asc_0 = 48 -asc_9 = 57 -asc_A = 65 -asc_E = 69 -asc_P = 80 -asc_a = 97 -asc_e = 101 -asc_p = 112 -asc_minus = 45 -asc_plus = 43 -asc_point = 46 -asc_newline = 10 - -unsafeAsciiToChar :: Word8 -> Char -unsafeAsciiToChar = unsafeChr . fromIntegral -{-# INLINE unsafeAsciiToChar #-} - -byteS :: Word8 -> ShowS -byteS b - | b < 128 = showLitChar $ unsafeAsciiToChar b - | otherwise = ("\\x" <>) . showHex b - -bytesS :: ByteString -> ShowS -bytesS b | B.length b == 1 = byteS $ B.head b - | otherwise = foldl' ((. byteS) . (.)) id $ B.unpack b - -showByte :: Word8 -> String -showByte b = ('\'':) . byteS b . ('\'':) $ "" - -showBytes :: ByteString -> String -showBytes b = ('"':) . bytesS b . ('"':) $ "" diff --git a/src/Text/PariPari/Class.hs b/src/Text/PariPari/Class.hs deleted file mode 100644 --- a/src/Text/PariPari/Class.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Text.PariPari.Class ( - MonadParser(..) - , Parser - , Alternative(..) - , MonadPlus - , Pos(..) - , Error(..) - , ByteString - , Word8 - , showError -) where - -import Control.Applicative (Alternative(empty, (<|>))) -import Control.Monad (MonadPlus(..)) -import Control.Monad.Fail (MonadFail(..)) -import Data.ByteString (ByteString) -import Data.List (intercalate) -import Data.Word (Word8) -import GHC.Generics (Generic) - --- | Line and column position starting at (1,1) -data Pos = Pos - { _posLine :: !Int - , _posColumn :: !Int - } deriving (Eq, Show, Generic) - --- | Parsing errors -data Error - = EEmpty - | EInvalidUtf8 - | EExpectedEnd - | EExpected [String] - | EUnexpected String - | EFail String - | ECombinator String - | EIndentNotAligned !Int !Int - | EIndentOverLine !Int !Int - | ENotEnoughIndent !Int !Int - deriving (Eq, Ord, Show, Generic) - --- | Parser shortcut -type Parser a = (forall p. MonadParser p => p a) - --- | Parser class, which specifies the necessary --- primitives for parsing. All other parser combinators --- rely on these primitives. -class (MonadFail p, MonadPlus p) => MonadParser p where - -- | Get file name associated with current parser - getFile :: p FilePath - - -- | Get current position of the parser - getPos :: p Pos - - -- | Get reference position used for indentation-sensitive parsing - getRefPos :: p Pos - - -- | Update reference position with current position - withRefPos :: p a -> p a - - -- | Parser which succeeds when the given parser fails - notFollowedBy :: Show a => p a -> p () - - -- | Look ahead and return result of the given parser - -- The current position stays the same. - lookAhead :: p a -> p a - - -- | Parser failure with detailled 'Error' - failWith :: Error -> p a - - -- | Parser which succeeds at the end of file - eof :: p () - - -- | Annotate the given parser with a label - -- used for error reporting - label :: String -> p a -> p a - - -- | Hide errors occurring within the given parser - -- from the error report. Based on the given - -- labels an 'Error' is constructed instead. - hidden :: p a -> p a - - -- | Commit to the given branch, increasing - -- the priority of the errors within this branch - -- in contrast to other branches. - -- - -- This is basically the opposite of the `try` - -- combinator provided by other parser combinator - -- libraries, which decreases the error priority - -- within the given branch (and usually also influences backtracking). - -- - -- __Note__: `commit` only applies to the reported - -- errors, it has no effect on the backtracking behavior - -- of the parser. - commit :: p a -> p a - - -- | Parse a single byte - byte :: Word8 -> p Word8 - - -- | Parse a single UTF-8 character - char :: Char -> p Char - - -- | Parse a single character with the given predicate - satisfy :: (Char -> Bool) -> p Char - - -- | Parse a single byte with the given predicate - byteSatisfy :: (Word8 -> Bool) -> p Word8 - - -- | Parse a string of bytes - bytes :: ByteString -> p ByteString - - -- | Run the given parser and return the - -- result as bytes - asBytes :: p () -> p ByteString - --- | Pretty string representation of 'Error' -showError :: Error -> String -showError EEmpty = "No error" -showError EInvalidUtf8 = "Invalid UTF-8 character found" -showError EExpectedEnd = "Expected end of file" -showError (EExpected tokens) = "Expected " <> intercalate ", " tokens -showError (EUnexpected token) = "Unexpected " <> token -showError (EFail msg) = msg -showError (ECombinator name) = "Combinator " <> name <> " failed" -showError (EIndentNotAligned rc c) = "Invalid alignment, expected column " <> show rc <> " expected, got " <> show c -showError (EIndentOverLine rl l) = "Indentation over line, expected line " <> show rl <> ", got " <> show l -showError (ENotEnoughIndent rc c) = "Not enough indentation, expected column " <> show rc <> ", got " <> show c diff --git a/src/Text/PariPari/Combinators.hs b/src/Text/PariPari/Combinators.hs deleted file mode 100644 --- a/src/Text/PariPari/Combinators.hs +++ /dev/null @@ -1,457 +0,0 @@ -module Text.PariPari.Combinators ( - -- * Basics - Text - , void - , (<|>) - , empty - , optional - - -- * Control.Monad.Combinators.NonEmpty - , NonEmpty(..) - , ON.some - , ON.endBy1 - , ON.someTill - , ON.sepBy1 - , ON.sepEndBy1 - - -- * Control.Monad.Combinators - , O.many -- dont use Applicative version for efficiency - , O.between - , O.choice - , O.count - , O.count' - , O.eitherP - , O.endBy - , O.manyTill - , O.option - , O.sepBy - , O.sepEndBy - , O.skipMany - , O.skipSome - , O.skipCount - , O.skipManyTill - , O.skipSomeTill - - -- * PariPari - , () - , getLine - , getColumn - , withPos - , withSpan - , getRefColumn - , getRefLine - , withRefPos - , align - , indented - , line - , linefold - , notByte - , anyByte - , digitByte - , asciiByte - , integer - , integer' - , decimal - , octal - , hexadecimal - , digit - , signed - , fractionHex - , fractionDec - , char' - , notChar - , anyChar - , alphaNumChar - , digitChar - , letterChar - , lowerChar - , upperChar - , symbolChar - , categoryChar - , punctuationChar - , spaceChar - , asciiChar - , string - , string' - , asString - , takeBytes - , skipChars - , skipBytes - , takeChars - , skipCharsWhile - , takeCharsWhile - , skipBytesWhile - , takeBytesWhile - , skipBytesWhile1 - , takeBytesWhile1 - , skipCharsWhile1 - , takeCharsWhile1 -) where - -import Control.Applicative ((<|>), empty, optional) -import Control.Monad (when) -import Control.Monad.Combinators (option, skipCount, skipMany) -import Data.List.NonEmpty (NonEmpty(..)) -import Text.PariPari.Ascii -import Text.PariPari.Class -import Data.Text (Text) -import Data.Functor (void) -import Prelude hiding (getLine) -import qualified Control.Monad.Combinators as O -import qualified Control.Monad.Combinators.NonEmpty as ON -import qualified Data.Char as C -import qualified Data.Text.Encoding as T -import qualified Data.Text as T - -infix 0 - --- | Infix alias for 'label' -() :: MonadParser p => p a -> String -> p a -() = flip label -{-# INLINE () #-} - --- | Get line number of the reference position -getRefLine :: Parser Int -getRefLine = _posLine <$> getRefPos -{-# INLINE getRefLine #-} - --- | Get column number of the reference position -getRefColumn :: Parser Int -getRefColumn = _posColumn <$> getRefPos -{-# INLINE getRefColumn #-} - --- | Get current line number -getLine :: Parser Int -getLine = _posLine <$> getPos -{-# INLINE getLine #-} - --- | Get current column -getColumn :: Parser Int -getColumn = _posColumn <$> getPos -{-# INLINE getColumn #-} - --- | Decorate the parser result with the current position -withPos :: MonadParser p => p a -> p (Pos, a) -withPos p = do - pos <- getPos - ret <- p - pure (pos, ret) -{-# INLINE withPos #-} - -type Span = (Pos, Pos) - --- | Decoreate the parser result with the position span -withSpan :: MonadParser p => p a -> p (Span, a) -withSpan p = do - begin <- getPos - ret <- p - end <- getPos - pure ((begin, end), ret) -{-# INLINE withSpan #-} - --- | Parser succeeds on the same line as the reference line -line :: Parser () -line = do - l <- getLine - rl <- getRefLine - when (l /= rl) $ failWith $ EIndentOverLine rl l -{-# INLINE line #-} - --- | Parser succeeds on the same column as the reference column -align :: Parser () -align = do - c <- getColumn - rc <- getRefColumn - when (c /= rc) $ failWith $ EIndentNotAligned rc c -{-# INLINE align #-} - --- | Parser succeeds for columns greater than the current reference column -indented :: Parser () -indented = do - c <- getColumn - rc <- getRefColumn - when (c <= rc) $ failWith $ ENotEnoughIndent rc c -{-# INLINE indented #-} - --- | Parser succeeds either on the reference line or --- for columns greater than the current reference column -linefold :: Parser () -linefold = line <|> indented -{-# INLINE linefold #-} - --- | Parser a single byte different from the given one -notByte :: Word8 -> Parser Word8 -notByte b = byteSatisfy (/= b) "not " <> showByte b -{-# INLINE notByte #-} - --- | Parse an arbitrary byte -anyByte :: Parser Word8 -anyByte = byteSatisfy (const True) -{-# INLINE anyByte #-} - --- | Parse a byte of the ASCII charset (< 128) -asciiByte :: Parser Word8 -asciiByte = byteSatisfy (< 128) -{-# INLINE asciiByte #-} - --- | Parse a digit byte for the given base. --- Bases 2 to 36 are supported. -digitByte :: Int -> Parser Word8 -digitByte base = byteSatisfy (isDigit base) -{-# INLINE digitByte #-} - --- | Parse an integer of the given base. --- Returns the integer and the number of digits. --- Bases 2 to 36 are supported. --- Digits can be separated by separator, e.g. `optional (char '_')`. -integer' :: (Num a, MonadParser p) => p sep -> Int -> p (a, Int) -integer' sep base = label (integerLabel base) $ do - d <- digit base - accum 1 $ fromIntegral d - where accum !i !n = next i n <|> pure (n, i) - next !i !n = do - void $ sep - d <- digit base - accum (i + 1) $ n * fromIntegral base + fromIntegral d -{-# INLINE integer' #-} - --- | Parse an integer of the given base. --- Bases 2 to 36 are supported. --- Digits can be separated by separator, e.g. `optional (char '_')`. -integer :: (Num a, MonadParser p) => p sep -> Int -> p a -integer sep base = label (integerLabel base) $ do - d <- digit base - accum $ fromIntegral d - where accum !n = next n <|> pure n - next !n = do - void $ sep - d <- digit base - accum $ n * fromIntegral base + fromIntegral d -{-# INLINE integer #-} - -integerLabel :: Int -> String -integerLabel 2 = "binary integer" -integerLabel 8 = "octal integer" -integerLabel 10 = "decimal integer" -integerLabel 16 = "hexadecimal integer" -integerLabel b = "integer of base " <> show b - -decimal :: Num a => Parser a -decimal = integer (pure ()) 10 -{-# INLINE decimal #-} - -octal :: Num a => Parser a -octal = integer (pure ()) 8 -{-# INLINE octal #-} - -hexadecimal :: Num a => Parser a -hexadecimal = integer (pure ()) 16 -{-# INLINE hexadecimal #-} - -digitToInt :: Int -> Word8 -> Word -digitToInt base b - | n <- (fromIntegral b :: Word) - fromIntegral asc_0, base <= 10 || n <= 9 = n - | n <- (fromIntegral b :: Word) - fromIntegral asc_A, n <= 26 = n + 10 - | n <- (fromIntegral b :: Word) - fromIntegral asc_a = n + 10 -{-# INLINE digitToInt #-} - --- | Parse a single digit of the given base and return its value. --- Bases 2 to 36 are supported. -digit :: Int -> Parser Word -digit base = digitToInt base <$> byteSatisfy (isDigit base) -{-# INLINE digit #-} - -isDigit :: Int -> Word8 -> Bool -isDigit base b - | base >= 2 && base <= 10 = b >= asc_0 && b <= asc_0 + fromIntegral base - 1 - | base <= 36 = (b >= asc_0 && b <= asc_9) - || ((fromIntegral b :: Word) - fromIntegral asc_A) < fromIntegral (base - 10) - || ((fromIntegral b :: Word) - fromIntegral asc_a) < fromIntegral (base - 10) - |otherwise = error "Text.PariPari.Combinators.isDigit: Bases 2 to 36 are supported" -{-# INLINE isDigit #-} - --- | Parse a number with a plus or minus sign. -signed :: (Num a, MonadParser p) => p a -> p a -signed p = ($) <$> ((id <$ byte asc_plus) <|> (negate <$ byte asc_minus) <|> pure id) <*> p -{-# INLINE signed #-} - --- | Parse a fraction of arbitrary exponent base and coefficient base. --- 'fractionDec' and 'fractionHex' should be used instead probably. -fraction :: (Num a, MonadParser p) => p expSep -> Int -> Int -> p digitSep -> p (a, Int, a) -fraction expSep expBase coeffBasePow digitSep = do - let coeffBase = expBase ^ coeffBasePow - coeff <- integer digitSep coeffBase - void $ optional $ byte asc_point - (frac, fracLen) <- option (0, 0) $ integer' digitSep coeffBase - expVal <- option 0 $ expSep *> signed (integer digitSep 10) - pure (coeff * fromIntegral coeffBase ^ fracLen + frac, - expBase, - expVal - fromIntegral (fracLen * coeffBasePow)) -{-# INLINE fraction #-} - --- | Parse a decimal fraction, returning (coefficient, 10, exponent), --- corresponding to coefficient * 10^exponent. --- Digits can be separated by separator, e.g. `optional (char '_')`. -fractionDec :: (Num a, MonadParser p) => p digitSep -> p (a, Int, a) -fractionDec sep = fraction (byteSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep "fraction" -{-# INLINE fractionDec #-} - --- | Parse a hexadecimal fraction, returning (coefficient, 2, exponent), --- corresponding to coefficient * 2^exponent. --- Digits can be separated by separator, e.g. `optional (char '_')`. -fractionHex :: (Num a, MonadParser p) => p digitSep -> p (a, Int, a) -fractionHex sep = fraction (byteSatisfy (\b -> b == asc_P || b == asc_p)) 2 4 sep "hexadecimal fraction" -{-# INLINE fractionHex #-} - --- | Parse a case-insensitive character -char' :: Char -> Parser Char -char' x = - let l = C.toLower x - u = C.toUpper x - in satisfy (\c -> c == l || c == u) -{-# INLINE char' #-} - --- | Parse a character different from the given one. -notChar :: Char -> Parser Char -notChar c = satisfy (/= c) -{-# INLINE notChar #-} - --- | Parse an arbitrary character. -anyChar :: Parser Char -anyChar = satisfy (const True) -{-# INLINE anyChar #-} - --- | Parse an alphanumeric character, including Unicode. -alphaNumChar :: Parser Char -alphaNumChar = satisfy C.isAlphaNum "alphanumeric character" -{-# INLINE alphaNumChar #-} - --- | Parse a letter character, including Unicode. -letterChar :: Parser Char -letterChar = satisfy C.isLetter "letter" -{-# INLINE letterChar #-} - --- | Parse a lowercase letter, including Unicode. -lowerChar :: Parser Char -lowerChar = satisfy C.isLower "lowercase letter" -{-# INLINE lowerChar #-} - --- | Parse a uppercase letter, including Unicode. -upperChar :: Parser Char -upperChar = satisfy C.isUpper "uppercase letter" -{-# INLINE upperChar #-} - --- | Parse a space character, including Unicode. -spaceChar :: Parser Char -spaceChar = satisfy C.isSpace "space" -{-# INLINE spaceChar #-} - --- | Parse a symbol character, including Unicode. -symbolChar :: Parser Char -symbolChar = satisfy C.isSymbol "symbol" -{-# INLINE symbolChar #-} - --- | Parse a punctuation character, including Unicode. -punctuationChar :: Parser Char -punctuationChar = satisfy C.isPunctuation "punctuation" -{-# INLINE punctuationChar #-} - --- | Parse a digit character of the given base. --- Bases 2 to 36 are supported. -digitChar :: Int -> Parser Char -digitChar base = unsafeAsciiToChar <$> digitByte base -{-# INLINE digitChar #-} - --- | Parse a character beloning to the ASCII charset (< 128) -asciiChar :: Int -> Parser Char -asciiChar base = unsafeAsciiToChar <$> digitByte base -{-# INLINE asciiChar #-} - --- | Parse a character belonging to the given Unicode category -categoryChar :: C.GeneralCategory -> Parser Char -categoryChar cat = satisfy ((== cat) . C.generalCategory) untitle (show cat) -{-# INLINE categoryChar #-} - --- | Parse a text string -string :: Text -> Parser Text -string t = t <$ bytes (T.encodeUtf8 t) -{-# INLINE string #-} - -string' :: Text -> Parser Text -string' s = asString (go s) "case-insensitive \"" <> T.unpack (T.toLower s) <> "\"" - where go t - | T.null t = pure () - | otherwise = char' (T.head t) *> go (T.tail t) -{-# INLINE string' #-} - --- | Run the given parser but return the result as a 'Text' string -asString :: MonadParser p => p () -> p Text -asString p = T.decodeUtf8 <$> asBytes p -{-# INLINE asString #-} - --- | Take the next n bytes and advance the position by n bytes -takeBytes :: Int -> Parser ByteString -takeBytes n = asBytes (skipBytes n) show n <> " bytes" -{-# INLINE takeBytes #-} - --- | Skip the next n bytes -skipBytes :: Int -> Parser () -skipBytes n = skipCount n anyByte -{-# INLINE skipBytes #-} - --- | Skip the next n characters -skipChars :: Int -> Parser () -skipChars n = skipCount n anyChar -{-# INLINE skipChars #-} - --- | Take the next n characters and advance the position by n characters -takeChars :: Int -> Parser Text -takeChars n = asString (skipChars n) "string of length " <> show n -{-# INLINE takeChars #-} - --- | Skip char while predicate is true -skipCharsWhile :: (Char -> Bool) -> Parser () -skipCharsWhile f = skipMany (satisfy f) -{-# INLINE skipCharsWhile #-} - --- | Take chars while predicate is true -takeCharsWhile :: (Char -> Bool) -> Parser Text -takeCharsWhile f = asString (skipCharsWhile f) -{-# INLINE takeCharsWhile #-} - --- | Skip bytes while predicate is true -skipBytesWhile :: (Word8 -> Bool) -> Parser () -skipBytesWhile f = skipMany (byteSatisfy f) -{-# INLINE skipBytesWhile #-} - --- | Takes bytes while predicate is true -takeBytesWhile :: (Word8 -> Bool) -> Parser ByteString -takeBytesWhile f = asBytes (skipBytesWhile f) -{-# INLINE takeBytesWhile #-} - --- | Skip at least one byte while predicate is true -skipBytesWhile1 :: (Word8 -> Bool) -> Parser () -skipBytesWhile1 f = byteSatisfy f *> skipBytesWhile f -{-# INLINE skipBytesWhile1 #-} - --- | Take at least one byte while predicate is true -takeBytesWhile1 :: (Word8 -> Bool) -> Parser ByteString -takeBytesWhile1 f = asBytes (skipBytesWhile1 f) -{-# INLINE takeBytesWhile1 #-} - --- | Skip at least one byte while predicate is true -skipCharsWhile1 :: (Char -> Bool) -> Parser () -skipCharsWhile1 f = satisfy f *> skipCharsWhile f -{-# INLINE skipCharsWhile1 #-} - --- | Take at least one byte while predicate is true -takeCharsWhile1 :: (Char -> Bool) -> Parser Text -takeCharsWhile1 f = asString (skipCharsWhile1 f) -{-# INLINE takeCharsWhile1 #-} - -untitle :: String -> String -untitle [] = [] -untitle (x:xs) = C.toLower x : go xs - where go [] = "" - go (y:ys) | C.isUpper y = ' ' : C.toLower y : untitle ys - | otherwise = y : ys diff --git a/src/Text/PariPari/Decode.hs b/src/Text/PariPari/Decode.hs deleted file mode 100644 --- a/src/Text/PariPari/Decode.hs +++ /dev/null @@ -1,90 +0,0 @@ -module Text.PariPari.Decode ( - bytesEqual - , byteAt - , utf8Decode - , utf8DecodeFixed - , utf8Width -) where - -import Data.Word (Word8) -import Data.Bits (unsafeShiftL, (.|.), (.&.)) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (plusPtr) -import Foreign.Storable (peekByteOff) -import GHC.Base (unsafeChr) -import qualified Data.ByteString.Internal as B - -bytesEqual :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool -bytesEqual p1 i1 p2 i2 n = - B.accursedUnutterablePerformIO $ - withForeignPtr p1 $ \q1 -> - withForeignPtr p2 $ \q2 -> - (== 0) <$> B.memcmp (q1 `plusPtr` i1) (q2 `plusPtr` i2) n -{-# INLINE bytesEqual #-} - -byteAt :: ForeignPtr Word8 -> Int -> Word8 -byteAt p i = B.accursedUnutterablePerformIO $ - withForeignPtr p $ \q -> peekByteOff q i -{-# INLINE byteAt #-} - -at :: ForeignPtr Word8 -> Int -> Int -at p i = fromIntegral $ byteAt p i -{-# INLINE at #-} - --- | Decode UTF-8 character at the given offset relative to the pointer -utf8Decode :: ForeignPtr Word8 -> Int -> (Char, Int) -utf8Decode p i - | a1 <- at p i, - a1 <= 0x7F = - (unsafeChr a1, 1) - | a1 <- at p i, a2 <- at p (i + 1), - (a1 .&. 0xE0) == 0xC0, - (a2 .&. 0xC0) == 0x80 = - (unsafeChr (((a1 .&. 31) `unsafeShiftL` 6) - .|. (a2 .&. 0x3F)), 2) - | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), - (a1 .&. 0xF0) == 0xE0, - (a2 .&. 0xC0) == 0x80, - (a3 .&. 0xC0) == 0x80 = - (unsafeChr (((a1 .&. 15) `unsafeShiftL` 12) - .|. ((a2 .&. 0x3F) `unsafeShiftL` 6) - .|. (a3 .&. 0x3F)), 3) - | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3), - (a1 .&. 0xF8) == 0xF0, - (a2 .&. 0xC0) == 0x80, - (a3 .&. 0xC0) == 0x80, - (a4 .&. 0xC0) == 0x80 = - (unsafeChr (((a1 .&. 7) `unsafeShiftL` 18) - .|. ((a2 .&. 0x3F) `unsafeShiftL` 12) - .|. ((a3 .&. 0x3F) `unsafeShiftL` 6) - .|. (a4 .&. 0x3F)), 4) - | otherwise = ('\0', 0) -{-# INLINE utf8Decode #-} - --- | Decode UTF-8 character with known width at the given offset relative to the pointer -utf8DecodeFixed :: Int -> ForeignPtr Word8 -> Int -> Char -utf8DecodeFixed w p i = unsafeChr $ - case w of - 1 -> at p i - 2 | a1 <- at p i, a2 <- at p (i + 1) -> - ((a1 .&. 31) `unsafeShiftL` 6) - .|. (a2 .&. 0x3F) - 3 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2) -> - ((a1 .&. 15) `unsafeShiftL` 12) - .|. ((a2 .&. 0x3F) `unsafeShiftL` 6) - .|. (a3 .&. 0x3F) - 4 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3) -> - ((a1 .&. 7) `unsafeShiftL` 18) - .|. ((a2 .&. 0x3F) `unsafeShiftL` 12) - .|. ((a3 .&. 0x3F) `unsafeShiftL` 6) - .|. (a4 .&. 0x3F) - _ -> 0 -{-# INLINE utf8DecodeFixed #-} - --- | Bytes width of an UTF-8 character -utf8Width :: Char -> Int -utf8Width c | c <= unsafeChr 0x7F = 1 - | c <= unsafeChr 0x7FF = 2 - | c <= unsafeChr 0xFFFF = 3 - | otherwise = 4 -{-# INLINE utf8Width #-} diff --git a/src/Text/PariPari/Internal/Acceptor.hs b/src/Text/PariPari/Internal/Acceptor.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Acceptor.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Text.PariPari.Internal.Acceptor ( + Acceptor(..) + , Env(..) + , State(..) + , get + , local + , runAcceptor +) where + +import Control.Monad (void) +import Text.PariPari.Internal.Class +import Text.PariPari.Internal.Chunk +import qualified Control.Monad.Fail as Fail + +data Env k = Env + { _envBuf :: !(Buffer k) + , _envEnd :: !Int + , _envFile :: !FilePath + , _envRefLine :: !Int + , _envRefCol :: !Int + } + +data State = State + { _stOff :: !Int + , _stLine :: !Int + , _stCol :: !Int + } + +-- | Parser which is optimised for fast parsing. Error reporting +-- is minimal. +newtype Acceptor k a = Acceptor + { unAcceptor :: forall b. Env k -> State + -> (a -> State -> b) + -> (Error -> b) + -> b + } + +instance (Chunk k, Semigroup a) => Semigroup (Acceptor k a) where + p1 <> p2 = (<>) <$> p1 <*> p2 + {-# INLINE (<>) #-} + +instance (Chunk k, Monoid a) => Monoid (Acceptor k a) where + mempty = pure mempty + {-# INLINE mempty #-} + +instance Functor (Acceptor k) where + fmap f p = Acceptor $ \env st ok err -> + unAcceptor p env st (ok . f) err + {-# INLINE fmap #-} + +instance Chunk k => Applicative (Acceptor k) where + pure x = Acceptor $ \_ st ok _ -> ok x st + {-# INLINE pure #-} + + f <*> a = Acceptor $ \env st ok err -> + let ok1 f' s = + let ok2 a' s' = ok (f' a') s' + in unAcceptor a env s ok2 err + in unAcceptor f env st ok1 err + {-# INLINE (<*>) #-} + + p1 *> p2 = do + void p1 + p2 + {-# INLINE (*>) #-} + + p1 <* p2 = do + x <- p1 + void p2 + pure x + {-# INLINE (<*) #-} + +instance Chunk k => Alternative (Acceptor k) where + empty = Acceptor $ \_ _ _ err -> err $ ECombinator "empty" + {-# INLINE empty #-} + + p1 <|> p2 = Acceptor $ \env st ok err -> + let err' _ = unAcceptor p2 env st ok err + in unAcceptor p1 env st ok err' + {-# INLINE (<|>) #-} + +instance Chunk k => MonadPlus (Acceptor k) + +instance Chunk k => Monad (Acceptor k) where + p >>= f = Acceptor $ \env st ok err -> + let ok' x s = unAcceptor (f x) env s ok err + in unAcceptor p env st ok' err + {-# INLINE (>>=) #-} + + fail msg = Fail.fail msg + {-# INLINE fail #-} + +instance Chunk k => Fail.MonadFail (Acceptor k) where + fail msg = failWith $ EFail msg + {-# INLINE fail #-} + +instance Chunk k => ChunkParser k (Acceptor k) where + getPos = get $ \_ st -> Pos (_stLine st) (_stCol st) + {-# INLINE getPos #-} + + getFile = get $ \env _ -> _envFile env + {-# INLINE getFile #-} + + getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env) + {-# INLINE getRefPos #-} + + withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p + {-# INLINE withRefPos #-} + + notFollowedBy p = Acceptor $ \env st ok err -> + let ok' _ _ = err $ ECombinator "notFollowedBy" + err' _ = ok () st + in unAcceptor p env st ok' err' + {-# INLINE notFollowedBy #-} + + lookAhead p = Acceptor $ \env st ok err -> + let ok' x _ = ok x st + in unAcceptor p env st ok' err + {-# INLINE lookAhead #-} + + failWith e = Acceptor $ \_ _ _ err -> err e + {-# INLINE failWith #-} + + eof = Acceptor $ \env st ok err -> + if _stOff st >= _envEnd env then + ok () st + else + err expectedEnd + {-# INLINE eof #-} + + label _ p = p + {-# INLINE label #-} + + hidden p = p + {-# INLINE hidden #-} + + commit p = p + {-# INLINE commit #-} + + element e = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | _stOff < _envEnd env, + (e', w) <- elementAt @k (_envBuf env) _stOff, + e == e', + pos <- elementPos @k e (Pos _stLine _stCol) -> + ok e st { _stOff = _stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos } + | otherwise -> + err $ ECombinator "element" + {-# INLINE element #-} + + elementSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | _stOff < _envEnd env, + (e, w) <- elementAt @k (_envBuf env) _stOff, + f e, + pos <- elementPos @k e (Pos _stLine _stCol) -> + ok e st { _stOff = _stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos } + | otherwise -> + err $ ECombinator "elementSatisfy" + {-# INLINE elementSatisfy #-} + + chunk k = Acceptor $ \env st@State{_stOff,_stCol} ok err -> + let n = chunkWidth @k k + in if n + _stOff <= _envEnd env && + chunkEqual @k (_envBuf env) _stOff k then + ok k st { _stOff = _stOff + n, _stCol = _stCol + n } + else + err $ ECombinator "chunk" + {-# INLINE chunk #-} + + asChunk p = do + begin <- get (const _stOff) + p + end <- get (const _stOff) + src <- get (\env _ -> _envBuf env) + pure $ packChunk src begin (end - begin) + {-# INLINE asChunk #-} + +instance CharChunk k => CharParser k (Acceptor k) where + satisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | (c, w) <- charAt @k (_envBuf env) _stOff, + c /= '\0', + f c -> + ok c st + { _stOff = _stOff + w + , _stLine = if c == '\n' then _stLine + 1 else _stLine + , _stCol = if c == '\n' then 1 else _stCol + 1 + } + | otherwise -> + err $ ECombinator "satisfy" + {-# INLINE satisfy #-} + + -- By inling this combinator, GHC should figure out the `charWidth` + -- of the character resulting in an optimised decoder. + char '\0' = error "Character '\\0' cannot be parsed because it is used as sentinel" + char c + | w <- charWidth @k c = + Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if charAtFixed @k w (_envBuf env) _stOff == c then + ok c st + { _stOff = _stOff + w + , _stLine = if c == '\n' then _stLine + 1 else _stLine + , _stCol = if c == '\n' then 1 else _stCol + 1 + } + else + err $ ECombinator "char" + {-# INLINE char #-} + + asciiSatisfy f = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | b <- byteAt @k (_envBuf env) _stOff, + b /= 0, + b < 128, + f b -> + ok b st + { _stOff = _stOff + 1 + , _stLine = if b == asc_newline then _stLine + 1 else _stLine + , _stCol = if b == asc_newline then 1 else _stCol + 1 + } + | otherwise -> + err $ ECombinator "asciiSatisfy" + {-# INLINE asciiSatisfy #-} + + asciiByte 0 = error "Character '\\0' cannot be parsed because it is used as sentinel" + asciiByte b + | b >= 128 = error "Not an ASCII character" + | otherwise = Acceptor $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if byteAt @k (_envBuf env) _stOff == b then + ok b st + { _stOff = _stOff + 1 + , _stLine = if b == asc_newline then _stLine + 1 else _stLine + , _stCol = if b == asc_newline then 1 else _stCol + 1 + } + else + err $ ECombinator "asciiByte" + {-# INLINE asciiByte #-} + +-- | Reader monad, get something from the environment +get :: (Env k -> State -> a) -> Acceptor k a +get f = Acceptor $ \env st ok _ -> ok (f env st) st +{-# INLINE get #-} + +-- | Reader monad, modify environment locally +local :: (State -> Env k -> Env k) -> Acceptor k a -> Acceptor k a +local f p = Acceptor $ \env st ok err -> + unAcceptor p (f st env) st ok err +{-# INLINE local #-} + +-- | Run 'Acceptor' on the given chunk, returning either +-- a simple 'Error' or, if successful, the result. +runAcceptor :: Chunk k => Acceptor k a -> FilePath -> k -> Either Error a +runAcceptor p f k = + let (b, off, len) = unpackChunk k + in unAcceptor p (initialEnv f b (off + len)) (initialState off) (\x _ -> Right x) Left + +initialEnv :: FilePath -> Buffer k -> Int -> Env k +initialEnv _envFile _envBuf _envEnd = Env + { _envBuf + , _envFile + , _envEnd + , _envRefLine = 1 + , _envRefCol = 1 + } + +initialState :: Int -> State +initialState _stOff = State + { _stOff + , _stLine = 1 + , _stCol = 1 + } diff --git a/src/Text/PariPari/Internal/CharCombinators.hs b/src/Text/PariPari/Internal/CharCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/CharCombinators.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +module Text.PariPari.Internal.CharCombinators ( + digitByte + , integer + , integer' + , decimal + , octal + , hexadecimal + , digit + , signed + , fractionHex + , fractionDec + , char' + , notChar + , anyChar + , alphaNumChar + , digitChar + , letterChar + , lowerChar + , upperChar + , symbolChar + , categoryChar + , punctuationChar + , spaceChar + , asciiChar + , skipChars + , takeChars + , skipCharsWhile + , takeCharsWhile + , skipCharsWhile1 + , takeCharsWhile1 + , string +) where + +import Control.Applicative ((<|>), optional) +import Control.Monad.Combinators (option, skipCount, skipMany) +import Text.PariPari.Internal.Chunk +import Text.PariPari.Internal.Class +import Text.PariPari.Internal.ElementCombinators (()) +import Data.Text (Text) +import Data.Functor (void) +import Data.Word (Word8) +import qualified Data.Char as C + +type CharP k a = (forall p. CharParser k p => p a) + +-- | Parse a digit byte for the given base. +-- Bases 2 to 36 are supported. +digitByte :: CharParser k p => Int -> p Word8 +digitByte base = asciiSatisfy (isDigit base) +{-# INLINE digitByte #-} + +isDigit :: Int -> Word8 -> Bool +isDigit base b + | base >= 2 && base <= 10 = b >= asc_0 && b <= asc_0 + fromIntegral base - 1 + | base <= 36 = (b >= asc_0 && b <= asc_9) + || ((fromIntegral b :: Word) - fromIntegral asc_A) < fromIntegral (base - 10) + || ((fromIntegral b :: Word) - fromIntegral asc_a) < fromIntegral (base - 10) + |otherwise = error "Text.PariPari.Internal.Combinators.isDigit: Bases 2 to 36 are supported" +{-# INLINE isDigit #-} + +digitToInt :: Int -> Word8 -> Word +digitToInt base b + | n <- (fromIntegral b :: Word) - fromIntegral asc_0, base <= 10 || n <= 9 = n + | n <- (fromIntegral b :: Word) - fromIntegral asc_A, n <= 26 = n + 10 + | n <- (fromIntegral b :: Word) - fromIntegral asc_a = n + 10 +{-# INLINE digitToInt #-} + +-- | Parse a single digit of the given base and return its value. +-- Bases 2 to 36 are supported. +digit :: CharParser k p => Int -> p Word +digit base = digitToInt base <$> asciiSatisfy (isDigit base) +{-# INLINE digit #-} + +-- | Parse an integer of the given base. +-- Returns the integer and the number of digits. +-- Bases 2 to 36 are supported. +-- Digits can be separated by separator, e.g. `optional (char '_')`. +integer' :: (Num a, CharParser k p) => p sep -> Int -> p (a, Int) +integer' sep base = label (integerLabel base) $ do + d <- digit base + accum 1 $ fromIntegral d + where accum !i !n = next i n <|> pure (n, i) + next !i !n = do + void $ sep + d <- digit base + accum (i + 1) $ n * fromIntegral base + fromIntegral d +{-# INLINE integer' #-} + +-- | Parse an integer of the given base. +-- Bases 2 to 36 are supported. +-- Digits can be separated by separator, e.g. `optional (char '_')`. +integer :: (Num a, CharParser k p) => p sep -> Int -> p a +integer sep base = label (integerLabel base) $ do + d <- digit base + accum $ fromIntegral d + where accum !n = next n <|> pure n + next !n = do + void $ sep + d <- digit base + accum $ n * fromIntegral base + fromIntegral d +{-# INLINE integer #-} + +integerLabel :: Int -> String +integerLabel 2 = "binary integer" +integerLabel 8 = "octal integer" +integerLabel 10 = "decimal integer" +integerLabel 16 = "hexadecimal integer" +integerLabel b = "integer of base " <> show b + +decimal :: Num a => CharP k a +decimal = integer (pure ()) 10 +{-# INLINE decimal #-} + +octal :: Num a => CharP k a +octal = integer (pure ()) 8 +{-# INLINE octal #-} + +hexadecimal :: Num a => CharP k a +hexadecimal = integer (pure ()) 16 +{-# INLINE hexadecimal #-} + +-- | Parse a number with a plus or minus sign. +signed :: (Num a, CharParser k p) => p a -> p a +signed p = ($) <$> ((id <$ asciiByte asc_plus) <|> (negate <$ asciiByte asc_minus) <|> pure id) <*> p +{-# INLINE signed #-} + +-- | Parse a fraction of arbitrary exponent base and coefficient base. +-- 'fractionDec' and 'fractionHex' should be used instead probably. +fraction :: (Num a, CharParser k p) => p expSep -> Int -> Int -> p digitSep -> p (a, Int, a) +fraction expSep expBase coeffBasePow digitSep = do + let coeffBase = expBase ^ coeffBasePow + coeff <- integer digitSep coeffBase + void $ optional $ asciiByte asc_point + (frac, fracLen) <- option (0, 0) $ integer' digitSep coeffBase + expVal <- option 0 $ expSep *> signed (integer digitSep 10) + pure (coeff * fromIntegral coeffBase ^ fracLen + frac, + expBase, + expVal - fromIntegral (fracLen * coeffBasePow)) +{-# INLINE fraction #-} + +-- | Parse a decimal fraction, returning (coefficient, 10, exponent), +-- corresponding to coefficient * 10^exponent. +-- Digits can be separated by separator, e.g. `optional (char '_')`. +fractionDec :: (Num a, CharParser k p) => p digitSep -> p (a, Int, a) +fractionDec sep = fraction (asciiSatisfy (\b -> b == asc_E || b == asc_e)) 10 1 sep "fraction" +{-# INLINE fractionDec #-} + +-- | Parse a hexadecimal fraction, returning (coefficient, 2, exponent), +-- corresponding to coefficient * 2^exponent. +-- Digits can be separated by separator, e.g. `optional (char '_')`. +fractionHex :: (Num a, CharParser k p) => p digitSep -> p (a, Int, a) +fractionHex sep = fraction (asciiSatisfy (\b -> b == asc_P || b == asc_p)) 2 4 sep "hexadecimal fraction" +{-# INLINE fractionHex #-} + +-- | Parse a case-insensitive character +char' :: CharParser k p => Char -> p Char +char' x = + let l = C.toLower x + u = C.toUpper x + in satisfy (\c -> c == l || c == u) +{-# INLINE char' #-} + +-- | Parse a character different from the given one. +notChar :: CharParser k p => Char -> p Char +notChar c = satisfy (/= c) +{-# INLINE notChar #-} + +-- | Parse an arbitrary character. +anyChar :: CharP k Char +anyChar = satisfy (const True) +{-# INLINE anyChar #-} + +-- | Parse an alphanumeric character, including Unicode. +alphaNumChar :: CharP k Char +alphaNumChar = satisfy C.isAlphaNum "alphanumeric character" +{-# INLINE alphaNumChar #-} + +-- | Parse a letter character, including Unicode. +letterChar :: CharP k Char +letterChar = satisfy C.isLetter "letter" +{-# INLINE letterChar #-} + +-- | Parse a lowercase letter, including Unicode. +lowerChar :: CharP k Char +lowerChar = satisfy C.isLower "lowercase letter" +{-# INLINE lowerChar #-} + +-- | Parse a uppercase letter, including Unicode. +upperChar :: CharP k Char +upperChar = satisfy C.isUpper "uppercase letter" +{-# INLINE upperChar #-} + +-- | Parse a space character, including Unicode. +spaceChar :: CharP k Char +spaceChar = satisfy C.isSpace "space" +{-# INLINE spaceChar #-} + +-- | Parse a symbol character, including Unicode. +symbolChar :: CharP k Char +symbolChar = satisfy C.isSymbol "symbol" +{-# INLINE symbolChar #-} + +-- | Parse a punctuation character, including Unicode. +punctuationChar :: CharP k Char +punctuationChar = satisfy C.isPunctuation "punctuation" +{-# INLINE punctuationChar #-} + +-- | Parse a digit character of the given base. +-- Bases 2 to 36 are supported. +digitChar :: CharParser k p => Int -> p Char +digitChar base = unsafeAsciiToChar <$> digitByte base +{-# INLINE digitChar #-} + +-- | Parse a character beloning to the ASCII charset (< 128) +asciiChar :: CharP k Char +asciiChar = unsafeAsciiToChar <$> asciiSatisfy (const True) +{-# INLINE asciiChar #-} + +-- | Parse a character belonging to the given Unicode category +categoryChar :: CharParser k p => C.GeneralCategory -> p Char +categoryChar cat = satisfy ((== cat) . C.generalCategory) untitle (show cat) +{-# INLINE categoryChar #-} + +untitle :: String -> String +untitle [] = [] +untitle (x:xs) = C.toLower x : go xs + where go [] = "" + go (y:ys) | C.isUpper y = ' ' : C.toLower y : untitle ys + | otherwise = y : ys + +-- | Skip the next n characters +skipChars :: CharParser k p => Int -> p () +skipChars n = skipCount n anyChar +{-# INLINE skipChars #-} + +-- | Skip char while predicate is true +skipCharsWhile :: CharParser k p => (Char -> Bool) -> p () +skipCharsWhile f = skipMany (satisfy f) +{-# INLINE skipCharsWhile #-} + +-- | Skip at least one char while predicate is true +skipCharsWhile1 :: CharParser k p => (Char -> Bool) -> p () +skipCharsWhile1 f = satisfy f *> skipCharsWhile f +{-# INLINE skipCharsWhile1 #-} + +-- | Take the next n characters and advance the position by n characters +takeChars :: CharParser k p => Int -> p k +takeChars n = asChunk (skipChars n) "string of length " <> show n +{-# INLINE takeChars #-} + +-- | Take chars while predicate is true +takeCharsWhile :: CharParser k p => (Char -> Bool) -> p k +takeCharsWhile f = asChunk (skipCharsWhile f) +{-# INLINE takeCharsWhile #-} + +-- | Take at least one byte while predicate is true +takeCharsWhile1 :: CharParser k p => (Char -> Bool) -> p k +takeCharsWhile1 f = asChunk (skipCharsWhile1 f) +{-# INLINE takeCharsWhile1 #-} + +-- | Parse a string +string :: CharParser k p => Text -> p Text +string t = t <$ chunk (textToChunk t) +{-# INLINE string #-} diff --git a/src/Text/PariPari/Internal/Chunk.hs b/src/Text/PariPari/Internal/Chunk.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Chunk.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +module Text.PariPari.Internal.Chunk ( + Chunk(..) + , CharChunk(..) + , Pos(..) + , showByte + , showByteString + , unsafeAsciiToChar + , asc_0, asc_9, asc_A, asc_E, asc_P, asc_a, asc_e, asc_p, + asc_minus, asc_plus, asc_point, asc_newline +) where + +import Data.Bits (unsafeShiftL, (.|.), (.&.)) +import Data.ByteString (ByteString) +import Data.Foldable (foldl') +import Data.String (fromString) +import Data.Text (Text) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (peekByteOff) +import GHC.Base (unsafeChr) +import GHC.Generics (Generic) +import GHC.Show (showLitChar) +import Numeric (showHex) +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.Text.Array as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Internal as T + +-- | Line and column position starting at (1,1) +data Pos = Pos + { _posLine :: !Int + , _posColumn :: !Int + } deriving (Eq, Show, Generic) + +class (Ord (Element k), Ord k) => Chunk k where + type Element k + type Buffer k + elementAt :: Buffer k -> Int -> (Element k, Int) + elementPos :: Element k -> Pos -> Pos + chunkWidth :: k -> Int + chunkEqual :: Buffer k -> Int -> k -> Bool + packChunk :: Buffer k -> Int -> Int -> k + unpackChunk :: k -> (Buffer k, Int, Int) + showElement :: Element k -> String + showChunk :: k -> String + +class Chunk k => CharChunk k where + byteAt :: Buffer k -> Int -> Word8 + charAt :: Buffer k -> Int -> (Char, Int) + charAtFixed :: Int -> Buffer k -> Int -> Char + charWidth :: Char -> Int + textToChunk :: Text -> k + +instance Chunk ByteString where + type Element ByteString = Word8 + type Buffer ByteString = ForeignPtr Word8 + + elementAt b i = (ptrByteAt b i, 1) + {-# INLINE elementAt #-} + + elementPos e (Pos l c) = + Pos (if e == asc_newline then l + 1 else l) + (if e == asc_newline then 1 else c + 1) + {-# INLINE elementPos #-} + + chunkWidth (B.PS _ _ n) = n + {-# INLINE chunkWidth #-} + + chunkEqual b i (B.PS p j n) = ptrBytesEqual b i p j n + {-# INLINE chunkEqual #-} + + packChunk b i n = B.PS b i n + {-# INLINE packChunk #-} + + unpackChunk k = + let (B.PS b i n) = k <> fromString "\0\0\0" -- sentinel + in (b, i, n - 3) + {-# INLINE unpackChunk #-} + + showElement = showByte + showChunk = showByteString + +instance CharChunk ByteString where + byteAt = ptrByteAt + {-# INLINE byteAt #-} + + charAt = ptrDecodeUtf8 + {-# INLINE charAt #-} + + charWidth = charWidthUtf8 + {-# INLINE charWidth #-} + + charAtFixed = ptrDecodeFixedUtf8 + {-# INLINE charAtFixed #-} + + textToChunk t = T.encodeUtf8 t + {-# INLINE textToChunk #-} + +instance Chunk Text where + type Element Text = Char + type Buffer Text = T.Array + + elementAt b i = arrayCharAt 2 b i + {-# INLINE elementAt #-} + + elementPos e (Pos l c) = + Pos (if e == '\n' then l + 1 else l) + (if e == '\n' then 1 else c + 1) + {-# INLINE elementPos #-} + + chunkWidth (T.Text _ _ n) = n + {-# INLINE chunkWidth #-} + + chunkEqual b i (T.Text a j n) = T.equal b i a j n + {-# INLINE chunkEqual #-} + + packChunk b i n = T.Text b i n + {-# INLINE packChunk #-} + + unpackChunk k = + let (T.Text b i n) = k <> fromString "\0" -- sentinel + in (b, i, n - 1) + {-# INLINE unpackChunk #-} + + showElement = show + showChunk = show + +instance CharChunk Text where + byteAt = arrayByteAt + {-# INLINE byteAt #-} + + charAt = arrayCharAt 2 + {-# INLINE charAt #-} + + charWidth = charWidthUtf16 + {-# INLINE charWidth #-} + + charAtFixed n b i = fst $ arrayCharAt n b i + {-# INLINE charAtFixed #-} + + textToChunk t = t + {-# INLINE textToChunk #-} + +arrayByteAt :: T.Array -> Int -> Word8 +arrayByteAt a i + | c <- T.unsafeIndex a i, c <= 0xFF = fromIntegral c + | otherwise = 0 +{-# INLINE arrayByteAt #-} + +arrayCharAt :: Int -> T.Array -> Int -> (Char, Int) +arrayCharAt 1 a i + | c <- T.unsafeIndex a i, c < 0xD800 || c > 0xDFFF = (unsafeChr $ fromIntegral c, 1) + | otherwise = ('\0', 0) +arrayCharAt _ a i + | hi <- T.unsafeIndex a i, lo <- T.unsafeIndex a (i + 1) = + if hi < 0xD800 || hi > 0xDFFF then + (unsafeChr $ fromIntegral hi, 1) + else + (unsafeChr $ 0x10000 + ((fromIntegral $ hi - 0xD800) `unsafeShiftL` 10) + (fromIntegral lo - 0xDC00), 2) +{-# INLINE arrayCharAt #-} + +ptrBytesEqual :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool +ptrBytesEqual p1 i1 p2 i2 n = + B.accursedUnutterablePerformIO $ + withForeignPtr p1 $ \q1 -> + withForeignPtr p2 $ \q2 -> + (== 0) <$> B.memcmp (q1 `plusPtr` i1) (q2 `plusPtr` i2) n +{-# INLINE ptrBytesEqual #-} + +ptrByteAt :: ForeignPtr Word8 -> Int -> Word8 +ptrByteAt p i = B.accursedUnutterablePerformIO $ + withForeignPtr p $ \q -> peekByteOff q i +{-# INLINE ptrByteAt #-} + +at :: ForeignPtr Word8 -> Int -> Int +at p i = fromIntegral $ ptrByteAt p i +{-# INLINE at #-} + +-- | Decode UTF-8 character at the given offset relative to the pointer +ptrDecodeUtf8 :: ForeignPtr Word8 -> Int -> (Char, Int) +ptrDecodeUtf8 p i + | a1 <- at p i, + a1 <= 0x7F = + (unsafeChr a1, 1) + | a1 <- at p i, a2 <- at p (i + 1), + (a1 .&. 0xE0) == 0xC0, + (a2 .&. 0xC0) == 0x80 = + (unsafeChr (((a1 .&. 31) `unsafeShiftL` 6) + .|. (a2 .&. 0x3F)), 2) + | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), + (a1 .&. 0xF0) == 0xE0, + (a2 .&. 0xC0) == 0x80, + (a3 .&. 0xC0) == 0x80 = + (unsafeChr (((a1 .&. 15) `unsafeShiftL` 12) + .|. ((a2 .&. 0x3F) `unsafeShiftL` 6) + .|. (a3 .&. 0x3F)), 3) + | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3), + (a1 .&. 0xF8) == 0xF0, + (a2 .&. 0xC0) == 0x80, + (a3 .&. 0xC0) == 0x80, + (a4 .&. 0xC0) == 0x80 = + (unsafeChr (((a1 .&. 7) `unsafeShiftL` 18) + .|. ((a2 .&. 0x3F) `unsafeShiftL` 12) + .|. ((a3 .&. 0x3F) `unsafeShiftL` 6) + .|. (a4 .&. 0x3F)), 4) + | otherwise = ('\0', 0) +{-# INLINE ptrDecodeUtf8 #-} + +-- | Decode UTF-8 character with fixed width at the given offset relative to the pointer +ptrDecodeFixedUtf8 :: Int -> ForeignPtr Word8 -> Int -> Char +ptrDecodeFixedUtf8 w p i = unsafeChr $ + case w of + 1 -> at p i + 2 | a1 <- at p i, a2 <- at p (i + 1) -> + ((a1 .&. 31) `unsafeShiftL` 6) + .|. (a2 .&. 0x3F) + 3 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2) -> + ((a1 .&. 15) `unsafeShiftL` 12) + .|. ((a2 .&. 0x3F) `unsafeShiftL` 6) + .|. (a3 .&. 0x3F) + 4 | a1 <- at p i, a2 <- at p (i + 1), a3 <- at p (i + 2), a4 <- at p (i + 3) -> + ((a1 .&. 7) `unsafeShiftL` 18) + .|. ((a2 .&. 0x3F) `unsafeShiftL` 12) + .|. ((a3 .&. 0x3F) `unsafeShiftL` 6) + .|. (a4 .&. 0x3F) + _ -> 0 +{-# INLINE ptrDecodeFixedUtf8 #-} + +charWidthUtf16 :: Char -> Int +charWidthUtf16 c | c <= unsafeChr 0xFFFF = 1 + | otherwise = 2 +{-# INLINE charWidthUtf16 #-} + +-- | Bytes width of an UTF-8 character +charWidthUtf8 :: Char -> Int +charWidthUtf8 c | c <= unsafeChr 0x7F = 1 + | c <= unsafeChr 0x7FF = 2 + | c <= unsafeChr 0xFFFF = 3 + | otherwise = 4 +{-# INLINE charWidthUtf8 #-} + +asc_0, asc_9, asc_A, asc_E, asc_P, asc_a, asc_e, asc_p, + asc_minus, asc_plus, asc_point, asc_newline :: Word8 +asc_0 = 48 +asc_9 = 57 +asc_A = 65 +asc_E = 69 +asc_P = 80 +asc_a = 97 +asc_e = 101 +asc_p = 112 +asc_minus = 45 +asc_plus = 43 +asc_point = 46 +asc_newline = 10 + +unsafeAsciiToChar :: Word8 -> Char +unsafeAsciiToChar = unsafeChr . fromIntegral +{-# INLINE unsafeAsciiToChar #-} + +byteS :: Word8 -> ShowS +byteS b + | b < 128 = showLitChar $ unsafeAsciiToChar b + | otherwise = ("\\x" <>) . showHex b + +bytesS :: ByteString -> ShowS +bytesS b | B.length b == 1 = byteS $ B.head b + | otherwise = foldl' ((. byteS) . (.)) id $ B.unpack b + +showByte :: Word8 -> String +showByte b = ('\'':) . byteS b . ('\'':) $ "" + +showByteString :: ByteString -> String +showByteString b = ('"':) . bytesS b . ('"':) $ "" diff --git a/src/Text/PariPari/Internal/Class.hs b/src/Text/PariPari/Internal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Class.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FunctionalDependencies #-} +module Text.PariPari.Internal.Class ( + ChunkParser(..) + , CharParser(..) + , Alternative(..) + , MonadPlus + , Pos(..) + , Error(..) + , showError + , expectedEnd + , unexpectedEnd +) where + +import Control.Applicative (Alternative(empty, (<|>))) +import Control.Monad (MonadPlus(..)) +import Control.Monad.Fail (MonadFail(..)) +import Data.List (intercalate) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Text.PariPari.Internal.Chunk + +-- | Parsing errors +data Error + = EInvalidUtf8 + | EExpected [String] + | EUnexpected String + | EFail String + | ECombinator String + | EIndentNotAligned !Int !Int + | EIndentOverLine !Int !Int + | ENotEnoughIndent !Int !Int + deriving (Eq, Ord, Show, Generic) + +-- | Parser class, which specifies the necessary +-- primitives for parsing. All other parser combinators +-- rely on these primitives. +class (MonadFail p, MonadPlus p, Chunk k) => ChunkParser k p | p -> k where + -- | Get file name associated with current parser + getFile :: p FilePath + + -- | Get current position of the parser + getPos :: p Pos + + -- | Get reference position used for indentation-sensitive parsing + getRefPos :: p Pos + + -- | Update reference position with current position + withRefPos :: p a -> p a + + -- | Parser which succeeds when the given parser fails + notFollowedBy :: Show a => p a -> p () + + -- | Look ahead and return result of the given parser + -- The current position stays the same. + lookAhead :: p a -> p a + + -- | Parser failure with detailled 'Error' + failWith :: Error -> p a + + -- | Parser which succeeds at the end of file + eof :: p () + + -- | Annotate the given parser with a label + -- used for error reporting + label :: String -> p a -> p a + + -- | Hide errors occurring within the given parser + -- from the error report. Based on the given + -- labels an 'Error' is constructed instead. + hidden :: p a -> p a + + -- | Commit to the given branch, increasing + -- the priority of the errors within this branch + -- in contrast to other branches. + -- + -- This is basically the opposite of the `try` + -- combinator provided by other parser combinator + -- libraries, which decreases the error priority + -- within the given branch (and usually also influences backtracking). + -- + -- __Note__: `commit` only applies to the reported + -- errors, it has no effect on the backtracking behavior + -- of the parser. + commit :: p a -> p a + + -- | Parse a single element + element :: Element k -> p (Element k) + + -- | Parse a single byte with the given predicate + elementSatisfy :: (Element k -> Bool) -> p (Element k) + + -- | Parse a chunk of elements. The chunk must not + -- contain multiple lines, otherwise the position information + -- will be invalid. + chunk :: k -> p k + + -- | Run the given parser and return the + -- result as buffer + asChunk :: p () -> p k + +class (ChunkParser k p, CharChunk k) => CharParser k p | p -> k where + -- | Parse a single character + -- + -- __Note__: The character '\0' cannot be parsed using this combinator + -- since it is used as decoding sentinel. Use 'element' instead. + char :: Char -> p Char + + -- | Parse a single character with the given predicate + -- + -- __Note__: The character '\0' cannot be parsed using this combinator + -- since it is used as decoding sentinel. Use 'elementSatisfy' instead. + satisfy :: (Char -> Bool) -> p Char + + -- | Parse a single character within the ASCII charset + -- + -- __Note__: The character '\0' cannot be parsed using this combinator + -- since it is used as decoding sentinel. Use 'element' instead. + asciiByte :: Word8 -> p Word8 + + -- | Parse a single character within the ASCII charset with the given predicate + -- + -- __Note__: The character '\0' cannot be parsed using this combinator + -- since it is used as decoding sentinel. Use 'elementSatisfy' instead. + asciiSatisfy :: (Word8 -> Bool) -> p Word8 + +-- | Pretty string representation of 'Error' +showError :: Error -> String +showError EInvalidUtf8 = "Invalid UTF-8 character found" +showError (EExpected tokens) = "Expected " <> intercalate ", " tokens +showError (EUnexpected token) = "Unexpected " <> token +showError (EFail msg) = msg +showError (ECombinator name) = "Combinator " <> name <> " failed" +showError (EIndentNotAligned rc c) = "Invalid alignment, expected column " <> show rc <> " expected, got " <> show c +showError (EIndentOverLine rl l) = "Indentation over line, expected line " <> show rl <> ", got " <> show l +showError (ENotEnoughIndent rc c) = "Not enough indentation, expected column " <> show rc <> ", got " <> show c + +expectedEnd :: Error +expectedEnd = EExpected ["end of file"] + +unexpectedEnd :: Error +unexpectedEnd = EUnexpected "end of file" diff --git a/src/Text/PariPari/Internal/ElementCombinators.hs b/src/Text/PariPari/Internal/ElementCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/ElementCombinators.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Text.PariPari.Internal.ElementCombinators ( + -- * Basic combinators + void + , (<|>) + , empty + + -- * Control.Monad.Combinators.NonEmpty + , ON.some + , ON.endBy1 + , ON.someTill + , ON.sepBy1 + , ON.sepEndBy1 + + -- * Control.Monad.Combinators + , O.optional -- dont use Applicative version for efficiency + , O.many -- dont use Applicative version for efficiency + , O.between + , O.choice + , O.count + , O.count' + , O.eitherP + , O.endBy + , O.manyTill + , O.option + , O.sepBy + , O.sepEndBy + , O.skipMany + , O.skipSome + , O.skipCount + , O.skipManyTill + , O.skipSomeTill + + -- * PariPari + , () + , getLine + , getColumn + , withPos + , withSpan + , getRefColumn + , getRefLine + , withRefPos + , align + , indented + , line + , linefold + , notElement + , anyElement + , takeElements + , skipElements + , skipElementsWhile + , takeElementsWhile + , skipElementsWhile1 + , takeElementsWhile1 +) where + +import Control.Applicative ((<|>), empty) +import Control.Monad (when) +import Control.Monad.Combinators (skipCount, skipMany) +import Data.Functor (void) +import Prelude hiding (getLine) +import Text.PariPari.Internal.Class +import Text.PariPari.Internal.Chunk +import qualified Control.Monad.Combinators as O +import qualified Control.Monad.Combinators.NonEmpty as ON + +type ChunkP k a = (forall p. ChunkParser k p => p a) + +-- | Infix alias for 'label' +() :: ChunkParser k p => p a -> String -> p a +() = flip label +{-# INLINE () #-} +infix 0 + +-- | Get line number of the reference position +getRefLine :: ChunkP k Int +getRefLine = _posLine <$> getRefPos +{-# INLINE getRefLine #-} + +-- | Get column number of the reference position +getRefColumn :: ChunkP k Int +getRefColumn = _posColumn <$> getRefPos +{-# INLINE getRefColumn #-} + +-- | Get current line number +getLine :: ChunkP k Int +getLine = _posLine <$> getPos +{-# INLINE getLine #-} + +-- | Get current column +getColumn :: ChunkP k Int +getColumn = _posColumn <$> getPos +{-# INLINE getColumn #-} + +-- | Decorate the parser result with the current position +withPos :: ChunkParser k p => p a -> p (Pos, a) +withPos p = do + pos <- getPos + ret <- p + pure (pos, ret) +{-# INLINE withPos #-} + +type Span = (Pos, Pos) + +-- | Decoreate the parser result with the position span +withSpan :: ChunkParser k p => p a -> p (Span, a) +withSpan p = do + begin <- getPos + ret <- p + end <- getPos + pure ((begin, end), ret) +{-# INLINE withSpan #-} + +-- | Parser succeeds on the same line as the reference line +line :: ChunkP k () +line = do + l <- getLine + rl <- getRefLine + when (l /= rl) $ failWith $ EIndentOverLine rl l +{-# INLINE line #-} + +-- | Parser succeeds on the same column as the reference column +align :: ChunkP k () +align = do + c <- getColumn + rc <- getRefColumn + when (c /= rc) $ failWith $ EIndentNotAligned rc c +{-# INLINE align #-} + +-- | Parser succeeds for columns greater than the current reference column +indented :: ChunkP k () +indented = do + c <- getColumn + rc <- getRefColumn + when (c <= rc) $ failWith $ ENotEnoughIndent rc c +{-# INLINE indented #-} + +-- | Parser succeeds either on the reference line or +-- for columns greater than the current reference column +linefold :: ChunkP k () +linefold = line <|> indented +{-# INLINE linefold #-} + +-- | Parser a single byte different from the given one +notElement :: forall k p. ChunkParser k p => Element k -> p (Element k) +notElement e = elementSatisfy @k (/= e) "not " <> showElement @k e +{-# INLINE notElement #-} + +-- | Parse an arbitrary byte +anyElement :: ChunkP k (Element k) +anyElement = elementSatisfy (const True) +{-# INLINE anyElement #-} + +-- | Skip the next n elements +skipElements :: ChunkParser k p => Int -> p () +skipElements n = skipCount n anyElement +{-# INLINE skipElements #-} + +-- | Take the next n elements and advance the position by n +takeElements :: ChunkParser k p => Int -> p k +takeElements n = asChunk (skipElements n) show n <> " elements" +{-# INLINE takeElements #-} + +-- | Skip elements while predicate is true +skipElementsWhile :: ChunkParser k p => (Element k -> Bool) -> p () +skipElementsWhile f = skipMany (elementSatisfy f) +{-# INLINE skipElementsWhile #-} + +-- | Takes elements while predicate is true +takeElementsWhile :: ChunkParser k p => (Element k -> Bool) -> p k +takeElementsWhile f = asChunk (skipElementsWhile f) +{-# INLINE takeElementsWhile #-} + +-- | Skip at least one element while predicate is true +skipElementsWhile1 :: ChunkParser k p => (Element k -> Bool) -> p () +skipElementsWhile1 f = elementSatisfy f *> skipElementsWhile f +{-# INLINE skipElementsWhile1 #-} + +-- | Take at least one element while predicate is true +takeElementsWhile1 :: ChunkParser k p => (Element k -> Bool) -> p k +takeElementsWhile1 f = asChunk (skipElementsWhile1 f) +{-# INLINE takeElementsWhile1 #-} diff --git a/src/Text/PariPari/Internal/Reporter.hs b/src/Text/PariPari/Internal/Reporter.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Reporter.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Text.PariPari.Internal.Reporter ( + Reporter(..) + , Env(..) + , State(..) + , local + , get + , raiseError + , mergeErrorState + , Report(..) + , runReporter + , runReporterWithOptions + , ErrorContext(..) + , showReport + , showErrors + , ReportOptions(..) + , defaultReportOptions +) where + +import Control.Monad (void) +import Data.Function (on) +import Data.List (intercalate, sort, group, sortOn) +import Data.List.NonEmpty (NonEmpty(..)) +import GHC.Generics (Generic) +import Text.PariPari.Internal.Chunk +import Text.PariPari.Internal.Class +import qualified Control.Monad.Fail as Fail +import qualified Data.List.NonEmpty as NE + +data ErrorContext = ErrorContext + { _ecErrors :: [Error] + , _ecContext :: [String] + } deriving (Eq, Show, Generic) + +data ReportOptions = ReportOptions + { _optMaxContexts :: !Int + , _optMaxErrorsPerContext :: !Int + , _optMaxLabelsPerContext :: !Int + } deriving (Eq, Show, Generic) + +data Report = Report + { _reportFile :: !FilePath + , _reportLine :: !Int + , _reportCol :: !Int + , _reportErrors :: [ErrorContext] + } deriving (Eq, Show, Generic) + +data Env k = Env + { _envBuf :: !(Buffer k) + , _envEnd :: !Int + , _envFile :: !FilePath + , _envOptions :: !ReportOptions + , _envHidden :: !Bool + , _envCommit :: !Int + , _envContext :: [String] + , _envRefLine :: !Int + , _envRefCol :: !Int + } + +data State = State + { _stOff :: !Int + , _stLine :: !Int + , _stCol :: !Int + , _stErrOff :: !Int + , _stErrLine :: !Int + , _stErrCol :: !Int + , _stErrCommit :: !Int + , _stErrors :: [ErrorContext] + } + +-- | Parser which is optimised for good error reports. +-- Performance is secondary, since the 'Reporter' is used +-- as a fallback to the 'Acceptor'. +newtype Reporter k a = Reporter + { unReporter :: forall b. Env k -> State + -> (a -> State -> b) + -> (State -> b) + -> b + } + +instance (Chunk k, Semigroup a) => Semigroup (Reporter k a) where + p1 <> p2 = (<>) <$> p1 <*> p2 + {-# INLINE (<>) #-} + +instance (Chunk k, Monoid a) => Monoid (Reporter k a) where + mempty = pure mempty + {-# INLINE mempty #-} + +instance Chunk k => Functor (Reporter k) where + fmap f p = Reporter $ \env st ok err -> + unReporter p env st (ok . f) err + {-# INLINE fmap #-} + +instance Chunk k => Applicative (Reporter k) where + pure x = Reporter $ \_ st ok _ -> ok x st + {-# INLINE pure #-} + + f <*> a = Reporter $ \env st ok err -> + let ok1 f' s = + let ok2 a' s' = ok (f' a') s' + in unReporter a env s ok2 err + in unReporter f env st ok1 err + {-# INLINE (<*>) #-} + + p1 *> p2 = do + void p1 + p2 + {-# INLINE (*>) #-} + + p1 <* p2 = do + x <- p1 + void p2 + pure x + {-# INLINE (<*) #-} + +instance Chunk k => Alternative (Reporter k) where + empty = Reporter $ \_ st _ err -> err st + {-# INLINE empty #-} + + p1 <|> p2 = Reporter $ \env st ok err -> + let err' s = unReporter p2 env (mergeErrorState env st s) ok err + in unReporter p1 env st ok err' + {-# INLINE (<|>) #-} + +instance Chunk k => MonadPlus (Reporter k) + +instance Chunk k => Monad (Reporter k) where + p >>= f = Reporter $ \env st ok err -> + let ok' x s = unReporter (f x) env s ok err + in unReporter p env st ok' err + {-# INLINE (>>=) #-} + + fail msg = Fail.fail msg + {-# INLINE fail #-} + +instance Chunk k => Fail.MonadFail (Reporter k) where + fail msg = failWith $ EFail msg + {-# INLINE fail #-} + +instance Chunk k => ChunkParser k (Reporter k) where + getPos = get $ \_ st -> Pos (_stLine st) (_stCol st) + {-# INLINE getPos #-} + + getFile = get $ \env _ -> _envFile env + {-# INLINE getFile #-} + + getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env) + {-# INLINE getRefPos #-} + + withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p + {-# INLINE withRefPos #-} + + label l p = local (const $ addLabel l) p + {-# INLINE label #-} + + hidden p = local (const $ \env -> env { _envHidden = True }) p + {-# INLINE hidden #-} + + commit p = local (const $ \env -> env { _envCommit = _envCommit env + 1 }) p + {-# INLINE commit #-} + + notFollowedBy p = Reporter $ \env st ok err -> + let ok' x _ = raiseError env st err $ EUnexpected $ show x + err' _ = ok () st + in unReporter p env st ok' err' + {-# INLINE notFollowedBy #-} + + lookAhead p = Reporter $ \env st ok err -> + let ok' x _ = ok x st + in unReporter p env st ok' err + {-# INLINE lookAhead #-} + + failWith e = Reporter $ \env st _ err -> raiseError env st err e + {-# INLINE failWith #-} + + eof = Reporter $ \env st ok err -> + if _stOff st >= _envEnd env then + ok () st + else + raiseError env st err expectedEnd + {-# INLINE eof #-} + + element e = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | _stOff < _envEnd env, + (e', w) <- elementAt @k (_envBuf env) _stOff, + e == e', + pos <- elementPos @k e (Pos _stLine _stCol) -> + ok e st { _stOff =_stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos } + | otherwise -> + raiseError env st err $ EExpected [showElement @k e] + {-# INLINE element #-} + + elementSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + let (e, w) = elementAt @k (_envBuf env) _stOff + in if | _stOff >= _envEnd env -> + raiseError env st err unexpectedEnd + | _stOff < _envEnd env, + f e, + pos <- elementPos @k e (Pos _stLine _stCol) -> + ok e st { _stOff =_stOff + w, _stLine = _posLine pos, _stCol = _posColumn pos } + | otherwise -> + raiseError env st err $ EUnexpected $ showElement @k e + {-# INLINE elementSatisfy #-} + + chunk k = Reporter $ \env st@State{_stOff,_stCol} ok err -> + let n = chunkWidth @k k + in if n + _stOff <= _envEnd env && + chunkEqual @k (_envBuf env) _stOff k then + ok k st { _stOff = _stOff + n, _stCol = _stCol + n } + else + raiseError env st err $ EExpected [showChunk @k k] + {-# INLINE chunk #-} + + asChunk p = do + begin <- get (const _stOff) + p + end <- get (const _stOff) + src <- get (\env _ -> _envBuf env) + pure $ packChunk src begin (end - begin) + {-# INLINE asChunk #-} + +instance CharChunk k => CharParser k (Reporter k) where + satisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if | (c, w) <- charAt @k (_envBuf env) _stOff, + c /= '\0' -> + if f c then + ok c st + { _stOff = _stOff + w + , _stLine = if c == '\n' then _stLine + 1 else _stLine + , _stCol = if c == '\n' then 1 else _stCol + 1 + } + else + raiseError env st err $ EUnexpected $ show c + | _stOff >= _envEnd env -> + raiseError env st err unexpectedEnd + | otherwise -> + raiseError env st err EInvalidUtf8 + {-# INLINE satisfy #-} + + -- By inling this combinator, GHC should figure out the `charWidth` + -- of the character resulting in an optimised decoder. + char '\0' = error "Character '\\0' cannot be parsed because it is used as sentinel" + char c + | w <- charWidth @k c = + Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if charAtFixed @k w (_envBuf env) _stOff == c then + ok c st + { _stOff = _stOff + w + , _stLine = if c == '\n' then _stLine + 1 else _stLine + , _stCol = if c == '\n' then 1 else _stCol + 1 + } + else + raiseError env st err $ EExpected [show c] + {-# INLINE char #-} + + asciiSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + let b = byteAt @k (_envBuf env) _stOff + in if | b /= 0, + b < 128, + f b -> + ok b st + { _stOff = _stOff + 1 + , _stLine = if b == asc_newline then _stLine + 1 else _stLine + , _stCol = if b == asc_newline then 1 else _stCol + 1 + } + | _stOff >= _envEnd env -> + raiseError env st err unexpectedEnd + | otherwise -> + raiseError env st err $ EUnexpected $ showByte b + {-# INLINE asciiSatisfy #-} + + asciiByte 0 = error "Character '\\0' cannot be parsed because it is used as sentinel" + asciiByte b + | b >= 128 = error "Not an ASCII character" + | otherwise = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> + if byteAt @k (_envBuf env) _stOff == b then + ok b st + { _stOff = _stOff + 1 + , _stLine = if b == asc_newline then _stLine + 1 else _stLine + , _stCol = if b == asc_newline then 1 else _stCol + 1 + } + else + raiseError env st err $ EExpected [showByte b] + {-# INLINE asciiByte #-} + +raiseError :: Env k -> State -> (State -> b) -> Error -> b +raiseError env st err e = err $ addError env st e +{-# INLINE raiseError #-} + +-- | Reader monad, modify environment locally +local :: (State -> Env k -> Env k) -> Reporter k a -> Reporter k a +local f p = Reporter $ \env st ok err -> + unReporter p (f st env) st ok err +{-# INLINE local #-} + +-- | Reader monad, get something from the environment +get :: (Env k -> State -> a) -> Reporter k a +get f = Reporter $ \env st ok _ -> ok (f env st) st +{-# INLINE get #-} + +addLabel :: String -> Env k -> Env k +addLabel l env = case _envContext env of + (l':_) | l == l' -> env + ls -> env { _envContext = take (_optMaxLabelsPerContext._envOptions $ env) $ l : ls } +{-# INLINE addLabel #-} + +-- | Add parser error to the list of errors +-- which are kept in the parser state. +-- Errors of lower priority and at an earlier position. +-- Furthermore the error is merged with existing errors if possible. +addError :: Env k -> State -> Error -> State +addError env st e + | _stOff st > _stErrOff st || _envCommit env > _stErrCommit st, + Just e' <- mkError env e = + st { _stErrors = [e'] + , _stErrOff = _stOff st + , _stErrLine = _stLine st + , _stErrCol = _stCol st + , _stErrCommit = _envCommit env + } + | _stOff st == _stErrOff st && _envCommit env == _stErrCommit st, + Just e' <- mkError env e = + st { _stErrors = shrinkErrors env $ e' : _stErrors st } + | otherwise = st +{-# INLINE addError #-} + +mkError :: Env k -> Error -> Maybe ErrorContext +mkError env e + | _envHidden env, (l:ls) <- _envContext env = Just $ ErrorContext [EExpected [l]] ls + | _envHidden env = Nothing + | otherwise = Just $ ErrorContext [e] $ _envContext env +{-# INLINE mkError #-} + +-- | Merge errors of two states, used when backtracking +mergeErrorState :: Env k -> State -> State -> State +mergeErrorState env s s' + | _stErrOff s' > _stErrOff s || _stErrCommit s' > _stErrCommit s = + s { _stErrors = _stErrors s' + , _stErrOff = _stErrOff s' + , _stErrLine = _stErrLine s' + , _stErrCol = _stErrCol s' + , _stErrCommit = _stErrCommit s' + } + | _stErrOff s' == _stErrOff s && _stErrCommit s' == _stErrCommit s = + s { _stErrors = shrinkErrors env $ _stErrors s' <> _stErrors s } + | otherwise = s +{-# INLINE mergeErrorState #-} + +groupOn :: Eq e => (a -> e) -> [a] -> [NonEmpty a] +groupOn f = NE.groupBy ((==) `on` f) + +shrinkErrors :: Env k -> [ErrorContext] -> [ErrorContext] +shrinkErrors env = take (_optMaxContexts._envOptions $ env) . map (mergeErrorContexts env) . groupOn _ecContext . sortOn _ecContext + +-- | Shrink error context by deleting duplicates +-- and merging errors if possible. +mergeErrorContexts :: Env k -> NonEmpty ErrorContext -> ErrorContext +mergeErrorContexts env es@(ErrorContext{_ecContext}:| _) = ErrorContext + { _ecErrors = take (_optMaxErrorsPerContext._envOptions $ env) $ nubSort $ mergeEExpected $ concatMap _ecErrors $ NE.toList es + , _ecContext = _ecContext + } + +mergeEExpected :: [Error] -> [Error] +mergeEExpected es = [EExpected $ nubSort expects | not (null expects)] <> filter (null . asEExpected) es + where expects = concatMap asEExpected es + +nubSort :: Ord a => [a] -> [a] +nubSort = map head . group . sort + +asEExpected :: Error -> [String] +asEExpected (EExpected s) = s +asEExpected _ = [] + +defaultReportOptions :: ReportOptions +defaultReportOptions = ReportOptions + { _optMaxContexts = 20 + , _optMaxErrorsPerContext = 20 + , _optMaxLabelsPerContext = 5 + } + +-- | Run 'Reporter' with additional 'ReportOptions'. +runReporterWithOptions :: Chunk k => ReportOptions -> Reporter k a -> FilePath -> k -> Either Report a +runReporterWithOptions o p f k = + let (b, off, len) = unpackChunk k + in unReporter p (initialEnv o f b (off + len)) (initialState off) (\x _ -> Right x) (Left . getReport f) + +-- | Run 'Reporter' on the given 'ByteString', returning either +-- an error 'Report' or, if successful, the result. +runReporter :: Chunk k => Reporter k a -> FilePath -> k -> Either Report a +runReporter = runReporterWithOptions defaultReportOptions + +getReport :: FilePath -> State -> Report +getReport f s = Report f (_stErrLine s) (_stErrCol s) (_stErrors s) + +initialEnv :: ReportOptions -> FilePath -> Buffer k -> Int -> Env k +initialEnv _envOptions _envFile _envBuf _envEnd = Env + { _envFile + , _envBuf + , _envOptions + , _envEnd + , _envContext = [] + , _envHidden = False + , _envCommit = 0 + , _envRefLine = 1 + , _envRefCol = 1 + } + +initialState :: Int -> State +initialState _stOff = State + { _stOff + , _stLine = 1 + , _stCol = 1 + , _stErrOff = 0 + , _stErrLine = 0 + , _stErrCol = 0 + , _stErrCommit = 0 + , _stErrors = [] + } + +-- | Pretty string representation of 'Report'. +showReport :: Report -> String +showReport r = + "Parser errors at " <> _reportFile r + <> ", line " <> show (_reportLine r) + <> ", column " <> show (_reportCol r) + <> "\n\n" <> showErrors (_reportErrors r) + +-- | Pretty string representation of '[ErrorContext]'. +showErrors :: [ErrorContext] -> String +showErrors [] = "No errors" +showErrors es = intercalate "\n" $ map showErrorContext es + +showErrorContext :: ErrorContext -> String +showErrorContext ec = + intercalate ", " (map showError $ _ecErrors ec) + <> showContext (_ecContext ec) <> "." + +showContext :: [String] -> String +showContext [] = "" +showContext xs = " in context of " <> intercalate ", " xs diff --git a/src/Text/PariPari/Internal/Run.hs b/src/Text/PariPari/Internal/Run.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Run.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE Rank2Types #-} +module Text.PariPari.Internal.Run ( + runCharParser + , runSeqCharParser + , runCharParserWithOptions + , runSeqCharParserWithOptions + , runChunkParser + , runSeqChunkParser + , runChunkParserWithOptions + , runSeqChunkParserWithOptions +) where + +import Text.PariPari.Internal.Acceptor +import Text.PariPari.Internal.Class +import Text.PariPari.Internal.Chunk +import Text.PariPari.Internal.Reporter +import GHC.Conc (par) + +-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **in parallel**. +-- The 'FilePath' is used for error reporting. +-- When the acceptor does not return successfully, the result from the reporter +-- is awaited. +runCharParser :: CharChunk k => (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a +runCharParser = runCharParserWithOptions defaultReportOptions +{-# INLINE runCharParser #-} + +-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **sequentially**. +-- The 'FilePath' is used for error reporting. +-- When the acceptor does not return successfully, the result from the reporter +-- is awaited. +runSeqCharParser :: CharChunk k => (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a +runSeqCharParser = runSeqCharParserWithOptions defaultReportOptions +{-# INLINE runSeqCharParser #-} + +-- | Run parsers **in parallel** with additional 'ReportOptions'. +runCharParserWithOptions :: CharChunk k => ReportOptions -> (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a +runCharParserWithOptions o p f b = + let a = runAcceptor p f b + r = runReporterWithOptions o p f b + in case r `par` a of + Left _ -> r + Right x -> Right x +{-# INLINE runCharParserWithOptions #-} + +-- | Run parsers **sequentially** with additional 'ReportOptions'. +runSeqCharParserWithOptions :: CharChunk k => ReportOptions -> (forall p. CharParser k p => p a) -> FilePath -> k -> Either Report a +runSeqCharParserWithOptions o p f b = + let a = runAcceptor p f b + r = runReporterWithOptions o p f b + in case a of + Left _ -> r + Right x -> Right x +{-# INLINE runSeqCharParserWithOptions #-} + +-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **in parallel**. +-- The 'FilePath' is used for error reporting. +-- When the acceptor does not return successfully, the result from the reporter +-- is awaited. +runChunkParser :: CharChunk k => (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a +runChunkParser = runCharParserWithOptions defaultReportOptions +{-# INLINE runChunkParser #-} + +-- | Run fast 'Acceptor' and slower 'Reporter' on the given 'ByteString' **sequentially**. +-- The 'FilePath' is used for error reporting. +-- When the acceptor does not return successfully, the result from the reporter +-- is awaited. +runSeqChunkParser :: Chunk k => (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a +runSeqChunkParser = runSeqChunkParserWithOptions defaultReportOptions +{-# INLINE runSeqChunkParser #-} + +-- | Run parsers **in parallel** with additional 'ReportOptions'. +runChunkParserWithOptions :: Chunk k => ReportOptions -> (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a +runChunkParserWithOptions o p f b = + let a = runAcceptor p f b + r = runReporterWithOptions o p f b + in case r `par` a of + Left _ -> r + Right x -> Right x +{-# INLINE runChunkParserWithOptions #-} + +-- | Run parsers **sequentially** with additional 'ReportOptions'. +runSeqChunkParserWithOptions :: Chunk k => ReportOptions -> (forall p. ChunkParser k p => p a) -> FilePath -> k -> Either Report a +runSeqChunkParserWithOptions o p f b = + let a = runAcceptor p f b + r = runReporterWithOptions o p f b + in case a of + Left _ -> r + Right x -> Right x +{-# INLINE runSeqChunkParserWithOptions #-} diff --git a/src/Text/PariPari/Internal/Tracer.hs b/src/Text/PariPari/Internal/Tracer.hs new file mode 100644 --- /dev/null +++ b/src/Text/PariPari/Internal/Tracer.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +module Text.PariPari.Internal.Tracer ( + Tracer(..) + , runTracer +) where + +import Debug.Trace (trace) +import Text.PariPari.Internal.Class +import Text.PariPari.Internal.Chunk +import Text.PariPari.Internal.Reporter +import qualified Control.Monad.Fail as Fail + +-- | Parser which prints trace messages, when backtracking occurs. +newtype Tracer k a = Tracer { unTracer :: Reporter k a } + deriving (Semigroup, Monoid, Functor, Applicative, MonadPlus, Monad, Fail.MonadFail) + +deriving instance CharChunk k => ChunkParser k (Tracer k) +deriving instance CharChunk k => CharParser k (Tracer k) + +instance Chunk k => Alternative (Tracer k) where + empty = Tracer empty + + p1 <|> p2 = Tracer $ Reporter $ \env st ok err -> + let err' s = + let width = _stOff s -_stOff st + next = unReporter (unTracer p2) env (mergeErrorState env st s) ok err + in if width > 1 then + trace ("Backtracking " <> show width <> " bytes at line " <> show (_stLine s) + <> ", column " <> show (_stCol s) <> ", context " <> show (_envContext env) <> ": " + <> showChunk (packChunk @k (_envBuf env) (_stOff st) width)) next + else + next + in unReporter (unTracer p1) env st ok err' + +-- | Run 'Tracer' on the given 'ByteString', returning either +-- an error 'Report' or, if successful, the result. +runTracer :: Chunk k => Tracer k a -> FilePath -> k -> Either Report a +runTracer = runReporter . unTracer diff --git a/src/Text/PariPari/Reporter.hs b/src/Text/PariPari/Reporter.hs deleted file mode 100644 --- a/src/Text/PariPari/Reporter.hs +++ /dev/null @@ -1,421 +0,0 @@ -module Text.PariPari.Reporter ( - Reporter - , Report(..) - , runReporter - , runReporterWithOptions - , ErrorContext - , showReport - , showErrors - , ReportOptions(..) - , defaultReportOptions - , Tracer - , runTracer -) where - -import Control.Monad (void) -import Data.Function (on) -import Data.List (intercalate, sort, group, sortOn) -import Data.List.NonEmpty (NonEmpty(..)) -import Debug.Trace (trace) -import Foreign.ForeignPtr (ForeignPtr) -import GHC.Generics (Generic) -import Text.PariPari.Ascii -import Text.PariPari.Class -import Text.PariPari.Decode -import qualified Control.Monad.Fail as Fail -import qualified Data.ByteString.Internal as B -import qualified Data.List.NonEmpty as NE - -type ErrorContext = ([Error], [String]) - -data ReportOptions = ReportOptions - { _optMaxContexts :: !Int - , _optMaxErrorsPerContext :: !Int - , _optMaxLabelsPerContext :: !Int - } deriving (Eq, Show, Generic) - -data Report = Report - { _reportFile :: !FilePath - , _reportLine :: !Int - , _reportCol :: !Int - , _reportErrors :: [ErrorContext] - } deriving (Eq, Show, Generic) - -data Env = Env - { _envSrc :: !(ForeignPtr Word8) - , _envEnd :: !Int - , _envFile :: !FilePath - , _envOptions :: !ReportOptions - , _envHidden :: !Bool - , _envCommit :: !Int - , _envContext :: [String] - , _envRefLine :: !Int - , _envRefCol :: !Int - } - -data State = State - { _stOff :: !Int - , _stLine :: !Int - , _stCol :: !Int - , _stErrOff :: !Int - , _stErrLine :: !Int - , _stErrCol :: !Int - , _stErrCommit :: !Int - , _stErrors :: [ErrorContext] - } - --- | Parser which is optimized for good error reports. --- Performance is secondary, since the 'Reporter' is used --- as a fallback to the 'Acceptor'. -newtype Reporter a = Reporter - { unReporter :: forall b. Env -> State - -> (a -> State -> b) - -> (State -> b) - -> b - } - -instance Semigroup a => Semigroup (Reporter a) where - p1 <> p2 = (<>) <$> p1 <*> p2 - {-# INLINE (<>) #-} - -instance Monoid a => Monoid (Reporter a) where - mempty = pure mempty - {-# INLINE mempty #-} - -instance Functor Reporter where - fmap f p = Reporter $ \env st ok err -> - unReporter p env st (ok . f) err - {-# INLINE fmap #-} - -instance Applicative Reporter where - pure x = Reporter $ \_ st ok _ -> ok x st - {-# INLINE pure #-} - - f <*> a = Reporter $ \env st ok err -> - let ok1 f' s = - let ok2 a' s' = ok (f' a') s' - in unReporter a env s ok2 err - in unReporter f env st ok1 err - {-# INLINE (<*>) #-} - - p1 *> p2 = do - void p1 - p2 - {-# INLINE (*>) #-} - - p1 <* p2 = do - x <- p1 - void p2 - pure x - {-# INLINE (<*) #-} - -instance Alternative Reporter where - empty = Reporter $ \_ st _ err -> err st - {-# INLINE empty #-} - - p1 <|> p2 = Reporter $ \env st ok err -> - let err' s = unReporter p2 env (mergeStateErrors env st s) ok err - in unReporter p1 env st ok err' - {-# INLINE (<|>) #-} - -instance MonadPlus Reporter - -instance Monad Reporter where - p >>= f = Reporter $ \env st ok err -> - let ok' x s = unReporter (f x) env s ok err - in unReporter p env st ok' err - {-# INLINE (>>=) #-} - - fail msg = Fail.fail msg - {-# INLINE fail #-} - -instance Fail.MonadFail Reporter where - fail msg = failWith $ EFail msg - {-# INLINE fail #-} - -instance MonadParser Reporter where - getPos = get $ \_ st -> Pos (_stLine st) (_stCol st) - {-# INLINE getPos #-} - - getFile = get $ \env _ -> _envFile env - {-# INLINE getFile #-} - - getRefPos = get $ \env _ -> Pos (_envRefLine env) (_envRefCol env) - {-# INLINE getRefPos #-} - - withRefPos p = local (\st env -> env { _envRefLine = _stLine st, _envRefCol = _stCol st }) p - {-# INLINE withRefPos #-} - - label l p = local (const $ addLabel l) p - {-# INLINE label #-} - - hidden p = local (const $ \env -> env { _envHidden = True }) p - {-# INLINE hidden #-} - - commit p = local (const $ \env -> env { _envCommit = _envCommit env + 1 }) p - {-# INLINE commit #-} - - notFollowedBy p = Reporter $ \env st ok err -> - let ok' x _ = raiseError env st err $ EUnexpected $ show x - err' _ = ok () st - in unReporter p env st ok' err' - {-# INLINE notFollowedBy #-} - - lookAhead p = Reporter $ \env st ok err -> - let ok' x _ = ok x st - in unReporter p env st ok' err - {-# INLINE lookAhead #-} - - failWith e = Reporter $ \env st _ err -> raiseError env st err e - {-# INLINE failWith #-} - - eof = Reporter $ \env st ok err -> - if _stOff st >= _envEnd env then - ok () st - else - raiseError env st err EExpectedEnd - {-# INLINE eof #-} - - byte b = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> - if | _stOff >= _envEnd env -> err st - | b == byteAt (_envSrc env) _stOff -> - ok b st - { _stOff =_stOff + 1 - , _stLine = if b == asc_newline then _stLine + 1 else _stLine - , _stCol = if b == asc_newline then 1 else _stCol + 1 - } - | otherwise -> - raiseError env st err $ EExpected [showByte b] - {-# INLINE byte #-} - - byteSatisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> - let b = byteAt (_envSrc env) _stOff - in if | _stOff >= _envEnd env -> err st - | f b -> - ok b st - { _stOff =_stOff + 1 - , _stLine = if b == asc_newline then _stLine + 1 else _stLine - , _stCol = if b == asc_newline then 1 else _stCol + 1 - } - | otherwise -> - raiseError env st err $ EUnexpected $ showByte b - {-# INLINE byteSatisfy #-} - - bytes b@(B.PS p i n) = Reporter $ \env st@State{_stOff,_stCol} ok err -> - if n + _stOff <= _envEnd env && - bytesEqual (_envSrc env) _stOff p i n then - ok b st { _stOff = _stOff + n, _stCol = _stCol + n } - else - raiseError env st err $ EExpected [showBytes b] - {-# INLINE bytes #-} - - asBytes p = do - begin <- get (const _stOff) - p - end <- get (const _stOff) - src <- get (\env _ -> _envSrc env) - pure $ B.PS src begin (end - begin) - {-# INLINE asBytes #-} - - satisfy f = Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> - let (c, w) = utf8Decode (_envSrc env) _stOff - in if | c /= '\0' -> - if f c then - ok c st - { _stOff =_stOff + w - , _stLine = if c == '\n' then _stLine + 1 else _stLine - , _stCol = if c == '\n' then 1 else _stCol + 1 - } - else - raiseError env st err $ EUnexpected $ show c - | c == '\0' && _stOff >= _envEnd env -> err st - | otherwise -> raiseError env st err EInvalidUtf8 - {-# INLINE satisfy #-} - - char c = - let w = utf8Width c - in Reporter $ \env st@State{_stOff, _stLine, _stCol} ok err -> - if utf8DecodeFixed w (_envSrc env) _stOff == c then - ok c st - { _stOff =_stOff + w - , _stLine = if c == '\n' then _stLine + 1 else _stLine - , _stCol = if c == '\n' then 1 else _stCol + 1 - } - else - raiseError env st err $ EExpected [show c] - {-# INLINE char #-} - -raiseError :: Env -> State -> (State -> b) -> Error -> b -raiseError env st err e = err $ addError env st e -{-# INLINE raiseError #-} - --- | Reader monad, modify environment locally -local :: (State -> Env -> Env) -> Reporter a -> Reporter a -local f p = Reporter $ \env st ok err -> - unReporter p (f st env) st ok err -{-# INLINE local #-} - --- | Reader monad, get something from the environment -get :: (Env -> State -> a) -> Reporter a -get f = Reporter $ \env st ok _ -> ok (f env st) st -{-# INLINE get #-} - -addLabel :: String -> Env -> Env -addLabel l env = case _envContext env of - (l':_) | l == l' -> env - ls -> env { _envContext = take (_optMaxLabelsPerContext._envOptions $ env) $ l : ls } -{-# INLINE addLabel #-} - --- | Add parser error to the list of errors --- which are kept in the parser state. --- Errors of lower priority and at an earlier position. --- Furthermore the error is merged with existing errors if possible. -addError :: Env -> State -> Error -> State -addError env st e - | _stOff st > _stErrOff st || _envCommit env > _stErrCommit st, - Just e' <- mkError env e = - st { _stErrors = [e'] - , _stErrOff = _stOff st - , _stErrLine = _stLine st - , _stErrCol = _stCol st - , _stErrCommit = _envCommit env - } - | _stOff st == _stErrOff st && _envCommit env == _stErrCommit st, - Just e' <- mkError env e = - st { _stErrors = shrinkErrors env $ e' : _stErrors st } - | otherwise = st -{-# INLINE addError #-} - -mkError :: Env -> Error -> Maybe ErrorContext -mkError env e - | _envHidden env, (l:ls) <- _envContext env = Just $ ([EExpected [l]], ls) - | _envHidden env = Nothing - | otherwise = Just $ ([e], _envContext env) -{-# INLINE mkError #-} - --- | Merge errors of two states, used when backtracking -mergeStateErrors :: Env -> State -> State -> State -mergeStateErrors env s s' - | _stErrOff s' > _stErrOff s || _stErrCommit s' > _stErrCommit s = - s { _stErrors = _stErrors s' - , _stErrOff = _stErrOff s' - , _stErrLine = _stErrLine s' - , _stErrCol = _stErrCol s' - , _stErrCommit = _stErrCommit s' - } - | _stErrOff s' == _stErrOff s && _stErrCommit s' == _stErrCommit s = - s { _stErrors = shrinkErrors env $ _stErrors s' <> _stErrors s } - | otherwise = s -{-# INLINE mergeStateErrors #-} - -groupOn :: Eq e => (a -> e) -> [a] -> [NonEmpty a] -groupOn f = NE.groupBy ((==) `on` f) - -shrinkErrors :: Env -> [ErrorContext] -> [ErrorContext] -shrinkErrors env = take (_optMaxContexts._envOptions $ env) . map (mergeErrorContexts env) . groupOn snd . sortOn snd - --- | Shrink error context by deleting duplicates --- and merging errors if possible. -mergeErrorContexts :: Env -> NonEmpty ErrorContext -> ErrorContext -mergeErrorContexts env es@((_, ctx):| _) = (take (_optMaxErrorsPerContext._envOptions $ env) $ nubSort $ mergeEExpected $ concatMap fst $ NE.toList es, ctx) - -mergeEExpected :: [Error] -> [Error] -mergeEExpected es = [EExpected $ nubSort expects | not (null expects)] <> filter (null . asEExpected) es - where expects = concatMap asEExpected es - -nubSort :: Ord a => [a] -> [a] -nubSort = map head . group . sort - -asEExpected :: Error -> [String] -asEExpected (EExpected s) = s -asEExpected _ = [] - --- | Run 'Reporter' with additional 'ReportOptions'. -runReporterWithOptions :: ReportOptions -> Reporter a -> FilePath -> ByteString -> Either Report a -runReporterWithOptions o p f t = - let b = t <> "\0\0\0" - in unReporter p (initialEnv o f b) (initialState b) (\x _ -> Right x) (Left . getReport f) - --- | Run 'Reporter' on the given 'ByteString', returning either --- an error 'Report' or, if successful, the result. -runReporter :: Reporter a -> FilePath -> ByteString -> Either Report a -runReporter = runReporterWithOptions defaultReportOptions - -getReport :: FilePath -> State -> Report -getReport f s = Report f (_stErrLine s) (_stErrCol s) (_stErrors s) - -initialEnv :: ReportOptions -> FilePath -> ByteString -> Env -initialEnv _envOptions _envFile (B.PS _envSrc off len) = Env - { _envFile - , _envSrc - , _envOptions - , _envEnd = off + len - 3 - , _envContext = [] - , _envHidden = False - , _envCommit = 0 - , _envRefLine = 0 - , _envRefCol = 0 - } - -defaultReportOptions :: ReportOptions -defaultReportOptions = ReportOptions - { _optMaxContexts = 20 - , _optMaxErrorsPerContext = 20 - , _optMaxLabelsPerContext = 5 - } - -initialState :: ByteString -> State -initialState (B.PS _ _stOff _) = State - { _stOff - , _stLine = 1 - , _stCol = 1 - , _stErrOff = 0 - , _stErrLine = 0 - , _stErrCol = 0 - , _stErrCommit = 0 - , _stErrors = [] - } - --- | Pretty string representation of 'Report'. -showReport :: Report -> String -showReport r = - "Parser errors at " <> _reportFile r - <> ", line " <> show (_reportLine r) - <> ", column " <> show (_reportCol r) - <> "\n\n" <> showErrors (_reportErrors r) - --- | Pretty string representation of '[ErrorContext]'. -showErrors :: [ErrorContext] -> String -showErrors [] = "No errors" -showErrors es = intercalate "\n" $ map showErrorContext es - -showErrorContext :: ErrorContext -> String -showErrorContext (e, c) = intercalate ", " (map showError e) <> showContext c <> "." - -showContext :: [String] -> String -showContext [] = "" -showContext xs = " in context of " <> intercalate ", " xs - --- | Parser which prints trace messages, when backtracking occurs. -newtype Tracer a = Tracer { unTracer :: Reporter a } - deriving (Semigroup, Monoid, Functor, Applicative, MonadPlus, Monad, Fail.MonadFail, MonadParser) - -instance Alternative Tracer where - empty = Tracer empty - - p1 <|> p2 = Tracer $ Reporter $ \env st ok err -> - let err' s = - let width = _stOff s -_stOff st - next = unReporter (unTracer p2) env (mergeStateErrors env st s) ok err - in if width > 1 then - trace ("Back tracking " <> show width <> " bytes at line " <> show (_stLine s) - <> ", column " <> show (_stCol s) <> ", context " <> show (_envContext env) <> ": " - <> showBytes (B.PS (_envSrc env) (_stOff st) width)) next - else - next - in unReporter (unTracer p1) env st ok err' - --- | Run 'Tracer' on the given 'ByteString', returning either --- an error 'Report' or, if successful, the result. -runTracer :: Tracer a -> FilePath -> ByteString -> Either Report a -runTracer = runReporter . unTracer diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,492 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +module Main (main) where + +import Data.ByteString (ByteString) +import Data.Either (isLeft) +import Data.Text (Text) +import GHC.Stack (HasCallStack) +import Prelude hiding (getLine) +import Test.Tasty +import Test.Tasty.HUnit +import Text.PariPari +import Text.PariPari.Internal.Chunk (textToChunk, asc_a, asc_0, asc_9) +import qualified Data.Char as C +import qualified Data.List.NonEmpty as NE + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ testGroup "Chunk" + [ testGroup "Acceptor" $ chunkTests runAcceptor + , testGroup "Reporter" $ chunkTests runAcceptor + ] + + , testGroup "Char" + [ testGroup "Acceptor" + [ testGroup "Text" $ charTests @Text runAcceptor + , testGroup "ByteString" $ charTests @ByteString runAcceptor + ] + + , testGroup "Reporter" + [ testGroup "Text" $ charTests @Text runReporter + , testGroup "ByteString" $ charTests @ByteString runReporter + ] + ] + ] + +charTests :: forall k p e. (CharParser k p, CharChunk k, Eq e, Show e) + => (forall a. p a -> FilePath -> k -> Either e a) -> [TestTree] +charTests run = + [ testGroup "CharParser" $ + [ testCase "satisfy" $ do + ok (satisfy (== 'a')) "abc" 'a' + ok (satisfy (== 'a') <* eof) "a" 'a' + err (satisfy (== 'b')) "abc" + err (satisfy (== 'a')) "" + + -- because of sentinel + err (satisfy (== '\0')) "\0" + err (satisfy (== '\0')) "" + + , testCase "char" $ do + ok (char 'a') "abc" 'a' + ok (char 'a' <* eof) "a" 'a' + err (char 'b') "abc" + err (char 'a') "" + + , testCase "asciiSatisfy" $ do + ok (asciiSatisfy (== asc_a)) "abc" asc_a + ok (asciiSatisfy (== asc_a) <* eof) "a" asc_a + err (asciiSatisfy (== asc_0)) "abc" + err (asciiSatisfy (== asc_0)) "" + + -- because of sentinel + err (asciiSatisfy (== 0)) "\0" + err (asciiSatisfy (== 0)) "" + + , testCase "asciiByte" $ do + ok (asciiByte asc_a) "abc" asc_a + ok (asciiByte asc_a <* eof) "a" asc_a + ok (asciiByte 127 <* eof) "\x7F" 127 + err (asciiByte asc_0) "abc" + err (asciiByte asc_0) "" + ] + + , testGroup "Char Combinators" + [ testCase "string" $ do + ok (string "ab") "abc" "ab" + err (string "bc") "abc" + err (string "ab") "" + + , testCase "anyChar" $ do + ok anyChar "abc" 'a' + ok (anyChar <* eof) "a" 'a' + err anyChar "" + + , testCase "notChar" $ do + ok (notChar 'b') "abc" 'a' + ok (notChar 'b' <* eof) "a" 'a' + err (notChar 'a') "a" + err (notChar 'a') "" + + , testCase "char'" $ do + ok (char' 'a') "a" 'a' + ok (char' 'a' <* eof) "a" 'a' + ok (char' 'a') "A" 'A' + ok (char' 'A') "a" 'a' + ok (char' 'A') "A" 'A' + ok (char' '9') "9" '9' + err (char' 'a') "b" + err (char' 'a') "" + + , testCase "alphaNumChar" $ do + ok (alphaNumChar <* eof) "a" 'a' + ok alphaNumChar "9" '9' + err alphaNumChar "_" + err alphaNumChar "" + + , testCase "digitChar" $ do + ok (digitChar 10 <* eof) "9" '9' + ok (digitChar 36) "z" 'z' + err (digitChar 2) "2" + err (digitChar 2) "" + + , testCase "letterChar" $ do + ok (letterChar <* eof) "a" 'a' + err letterChar "9" + err letterChar "_" + err letterChar "" + + , testCase "lowerChar" $ do + ok (lowerChar <* eof) "a" 'a' + err lowerChar "A" + err lowerChar "9" + err lowerChar "_" + err lowerChar "" + + , testCase "upperChar" $ do + ok (upperChar <* eof) "A" 'A' + err upperChar "a" + err upperChar "9" + err upperChar "_" + err upperChar "" + + , testCase "symbolChar" $ do + ok (symbolChar <* eof) "+" '+' + err symbolChar "a" + err symbolChar "." + err symbolChar "" + + , testCase "punctuationChar" $ do + ok (punctuationChar <* eof) "." '.' + err punctuationChar "+" + err punctuationChar "a" + err punctuationChar "" + + , testCase "spaceChar" $ do + ok (spaceChar <* eof) " " ' ' + ok (spaceChar <* eof) "\n" '\n' + ok (spaceChar <* eof) "\r" '\r' + ok (spaceChar <* eof) "\t" '\t' + err spaceChar "a" + err spaceChar "" + + , testCase "asciiChar" $ do + ok (asciiChar <* eof) "a" 'a' + ok (asciiChar <* eof) "\x7F" '\x7F' + err asciiChar "\x80" + err asciiChar "" + + , testCase "categoryChar" $ do + ok (categoryChar C.UppercaseLetter <* eof) "A" 'A' + err (categoryChar C.UppercaseLetter) "a" + err (categoryChar C.UppercaseLetter) "" + + , testCase "digitByte" $ do + ok (digitByte 2 <* eof) "0" asc_0 + ok (digitByte 10 <* eof) "9" asc_9 + err (digitByte 10) "\0" + err (digitByte 10) "" + ] + + , testGroup "Integer Combinators" + [ testCase "decimal" $ do + ok @Integer (decimal <* eof) "0123" 123 + ok @Integer (decimal <* eof) "1234567890" 1234567890 + ok @Integer (decimal <* string "abc" <* eof) "123abc" 123 + err @Integer decimal "abc" + err @Integer decimal "-1" + err @Integer decimal "" + + , testCase "octal" $ do + ok @Integer (octal <* eof) "0123" 0o123 + ok @Integer (octal <* eof) "12345670" 0o12345670 + ok @Integer (octal <* string "abc" <* eof) "123abc" 0o123 + err @Integer octal "8abc" + err @Integer octal "-1" + err @Integer octal "" + + , testCase "hexadecimal" $ do + ok @Integer (hexadecimal <* eof) "0123" 0x123 + ok @Integer (hexadecimal <* eof) "123456789aBcDeF0" 0x123456789ABCDEF0 + ok @Integer (hexadecimal <* string "xyz" <* eof) "123xyz" 0x123 + err @Integer hexadecimal "gabc" + err @Integer hexadecimal "-1" + err @Integer hexadecimal "" + + , testCase "integer" $ do + err @Integer (integer (pure ()) 10) "abc" + ok @Integer (integer (char '_') 10) "1_2_3" 123 + ok @Integer (integer (char '_') 10 <* char '_') "1_2_3_" 123 + err @Integer (integer (char '_') 10) "_1_2_3" + ok @Integer (integer (optional $ char '_') 10) "123_456_789" 123456789 + err @Integer (integer (pure ()) 10) "-1" + err @Integer (integer (pure ()) 10) "" + + ok @Integer (integer (pure ()) 2) "101" 5 + ok @Integer (integer (pure ()) 7) "321" 162 + ok @Integer (integer (pure ()) 36) "XyZ" 44027 + + , testCase "integer'" $ do + err @(Integer, Int) (integer' (pure ()) 10) "abc" + ok @(Integer, Int) (integer' (char '_') 10) "1_2_3" (123, 3) + ok @(Integer, Int) (integer' (char '_') 10 <* char '_') "1_2_3_" (123, 3) + err @(Integer, Int) (integer' (char '_') 10) "_1_2_3" + ok @(Integer, Int) (integer' (optional $ char '_') 10) "123_456_789" (123456789, 9) + err @(Integer, Int) (integer' (pure ()) 10) "-1" + err @(Integer, Int) (integer' (pure ()) 10) "" + + ok @(Integer, Int) (integer' (pure ()) 2) "101" (5, 3) + ok @(Integer, Int) (integer' (pure ()) 7) "321" (162, 3) + ok @(Integer, Int) (integer' (pure ()) 36) "XyZ" (44027, 3) + + , testCase "signed" $ do + ok @Integer (signed decimal) "-123" (-123) + ok @Integer (signed decimal) "+123" 123 + err @Integer (signed decimal) "- 123" + err @Integer (signed decimal) "+ 123" + err @Integer (signed decimal) "" + + , testCase "digit" $ do + ok (digit 2) "1" 1 + ok (digit 10) "7" 7 + ok (digit 36) "Z" 35 + err (digit 10) "a" + err (digit 10) "" + ] + ] + where + ok :: (Eq a, Show a, HasCallStack) => p a -> Text -> a -> Assertion + ok p i o = run p "filename" (textToChunk @k i) @?= Right o + err :: (Eq a, Show a, HasCallStack) => p a -> Text -> Assertion + err p i = assertBool "err" $ isLeft $ run p "filename" (textToChunk @k i) + +chunkTests :: forall p e. (ChunkParser Text p, Eq e, Show e) + => (forall a. p a -> FilePath -> Text -> Either e a) -> [TestTree] +chunkTests run = + [ testGroup "ChunkParser" + [ testCase "getFile" $ do + ok getFile "" "filename" + + , testCase "getPos" $ do + ok getPos "" (Pos 1 1) + ok (element 'a' *> getPos) "abc" (Pos 1 2) + ok (element 'a' *> element '\n' *> getPos) "a\nb" (Pos 2 1) + ok (chunk "a\n" *> getPos) "a\nb" (Pos 1 3) -- chunk must not contain newlines! + ok (element 'a' *> element '\n' *> element 'b' *> getPos) "a\nb" (Pos 2 2) + + , testCase "getRefPos" $ do + ok getRefPos "" (Pos 1 1) + ok (element 'a' *> getRefPos) "abc" (Pos 1 1) + ok (element 'a' *> element '\n' *> withRefPos getRefPos) "a\nb" (Pos 2 1) + ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefPos) "a\nb" (Pos 2 2) + ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefPos)) "a\nb" (Pos 2 1) + + , testCase "notFollowedBy" $ do + ok (element 'a' <* notFollowedBy (element 'c')) "abc" 'a' + err (element 'a' <* notFollowedBy (element 'b')) "abc" + ok (element 'a' *> notFollowedBy (chunk "bd") *> element 'b') "abc" 'b' + err (element 'a' *> notFollowedBy (chunk "bc")) "abc" + ok (element 'a' *> notFollowedBy (element 'c') *> getPos) "abc" (Pos 1 2) + + , testCase "lookAhead" $ do + ok (lookAhead (element 'a')) "abc" 'a' + ok (lookAhead (element 'a') *> getPos) "abc" (Pos 1 1) + ok (lookAhead (chunk "ab") *> getPos) "abc" (Pos 1 1) + err (lookAhead (element 'b')) "abc" + err (lookAhead (chunk "bd")) "abc" + err (lookAhead (element 'a')) "" + + , testCase "failWith" $ + err (failWith (ECombinator "empty") :: p ()) "abc" + + , testCase "eof" $ do + ok eof "" () + ok (chunk "abc" *> eof) "abc" () + err eof "abc" + err eof "\0" + err (chunk "ab" *> eof) "abc" + + , testCase "label" $ do + ok (label "blub" $ element 'a') "abc" 'a' + err (label "blub" $ element 'b') "abc" + ok (element 'a' "blub") "abc" 'a' + + , testCase "hidden" $ do + ok (hidden $ element 'a') "abc" 'a' + err (hidden $ element 'b') "abc" + + , testCase "commit" $ do + ok (commit $ element 'a') "abc" 'a' + err (commit $ element 'b') "abc" + + , testCase "elementSatisfy" $ do + ok (elementSatisfy (== 'a')) "abc" 'a' + ok (elementSatisfy (== 'a') <* eof) "a" 'a' + err (elementSatisfy (== 'b')) "abc" + err (elementSatisfy (== 'a')) "" + + -- sentinel + ok (elementSatisfy (== '\0')) "\0" '\0' + ok (elementSatisfy (== '\0') <* eof) "\0" '\0' + err (elementSatisfy (== '\0')) "" + + , testCase "element" $ do + ok (element 'a') "abc" 'a' + ok (element 'a' <* eof) "a" 'a' + err (element 'b') "abc" + err (element 'a') "" + + -- sentinel + ok (element '\0') "\0" '\0' + ok (element '\0' <* eof) "\0" '\0' + err (element '\0') "" + + , testCase "chunk" $ do + ok (chunk "ab") "abc" "ab" + err (chunk "bc") "abc" + err (chunk "ab") "" + + , testCase "asChunk" $ do + ok (asChunk (void $ chunk "ab")) "abc" "ab" + ok (asChunk (void $ anyElement *> anyElement)) "abc" "ab" + ok (asChunk (skipCount 2 anyElement)) "abc" "ab" + err (asChunk (void $ chunk "bc")) "abc" + err (asChunk (void $ chunk "ab")) "" + ] + + , testGroup "Position Combinators" + [ testCase "getLine" $ do + ok getLine "" 1 + ok (element 'a' *> getLine) "abc" 1 + ok (element 'a' *> element '\n' *> getLine) "a\nb" 2 + ok (element 'a' *> element '\n' *> element 'b' *> getLine) "a\nb" 2 + + , testCase "getRefLine" $ do + ok getRefLine "" 1 + ok (element 'a' *> getRefLine) "abc" 1 + ok (element 'a' *> element '\n' *> withRefPos getRefLine) "a\nb" 2 + ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefLine) "a\nb" 2 + ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefLine)) "a\nb" 2 + + , testCase "getColumn" $ do + ok getColumn "" 1 + ok (element 'a' *> getColumn) "abc" 2 + ok (element 'a' *> element '\n' *> getColumn) "a\nb" 1 + ok (element 'a' *> element '\n' *> element 'b' *> getColumn) "a\nb" 2 + + , testCase "getRefColumn" $ do + ok getRefColumn "" 1 + ok (element 'a' *> getRefColumn) "abc" 1 + ok (element 'a' *> element '\n' *> withRefPos getRefColumn) "a\nb" 1 + ok (element 'a' *> element '\n' *> element 'b' *> withRefPos getRefColumn) "a\nb" 2 + ok (element 'a' *> element '\n' *> withRefPos (element 'b' *> getRefColumn)) "a\nb" 1 + + , testCase "withPos" $ do + ok (withPos $ element 'a') "abc" (Pos 1 1, 'a') + ok (element 'a' *> withPos (element 'b')) "abc" (Pos 1 2, 'b') + ok (element 'a' *> element '\n' *> withPos (element 'b')) "a\nb" (Pos 2 1, 'b') + + , testCase "withSpan" $ do + ok (withSpan $ chunk "ab") "abc" ((Pos 1 1, Pos 1 3), "ab") + ok (element 'a' *> withSpan (chunk "bcd")) "abcde" ((Pos 1 2, Pos 1 5), "bcd") + ok (element 'a' *> element '\n' *> withSpan (chunk "bcd")) "a\nbcde" ((Pos 2 1, Pos 2 4), "bcd") + ] + + , testGroup "Element Combinators" + [ testCase "anyElement" $ do + ok anyElement "abc" 'a' + err anyElement "" + + , testCase "notElement" $ do + ok (notElement 'b') "abc" 'a' + err (notElement 'a') "a" + err (notElement 'a') "" + ] + + , testGroup "MonadFail" + [ testCase "fail" $ do + err (failWith (ECombinator "empty") :: p ()) "abc" + ] + + , testGroup "Alternative" + [ testCase "(<|>)" $ do + ok (element 'b' <|> element 'a' <|> element 'c') "abc" 'a' + ok (chunk "abd" <|> chunk "abc" <|> chunk "abe") "abcdef" "abc" + + , testCase "empty" $ do + err (empty :: p ()) "abc" + err (empty :: p ()) "" + ] + + , testGroup "Basic Combinators" + [ testCase "optional" $ do + ok (optional (element 'a')) "abc" (Just 'a') + ok (optional (element 'b')) "abc" Nothing + ok (optional (element 'a')) "" Nothing + + , testCase "some" $ do + ok (some (element 'a')) "abc" (NE.fromList "a") + ok (some (element 'a')) "aabc" (NE.fromList "aa") + err (some (element 'b')) "abc" + err (some (element 'a')) "" + + , testCase "many" $ do + ok (many (element 'a')) "abc" "a" + ok (many (element 'a')) "aabc" "aa" + ok (many (element 'b')) "abc" "" + ok (many (element 'a')) "" "" + ] + ] + where + ok :: (Eq a, Show a, HasCallStack) => p a -> Text -> a -> Assertion + ok p i o = run p "filename" i @?= Right o + err :: (Eq a, Show a, HasCallStack) => p a -> Text -> Assertion + err p i = assertBool "err" $ isLeft $ run p "filename" i + + +{- + +Semigroup +Monoid +Functor +Applicative +Monad +MonadPlus +Alternative: + +TODO: + +Additional combinators: +endBy1 +someTill +sepBy1 +sepEndBy1 +between +choice +count +count' +eitherP +endBy +manyTill +option +sepBy +sepEndBy +skipMany +skipSome +skipCount +skipManyTill +skipSomeTill + +Identation: +align +indented +line +linefold + +Fraction: +fractionHex +fractionDec + +Char Combinators: +skipChars +takeChars +skipCharsWhile +takeCharsWhile +skipCharsWhile1 +takeCharsWhile1 + +Element Combinators: +takeElements +skipElements +skipElementsWhile +takeElementsWhile +skipElementsWhile1 +takeElementsWhile1 +-}