{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Lib.Parsec where
+import Control.Monad (void)
+import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), get, put)
-import Control.Monad.Trans.Class (lift, MonadTrans(..))
-import Control.Monad.Identity (Identity(..))
+import Data.Bool
+import Data.Char (Char)
import qualified Data.Char
+import Data.Either
+import Data.Eq (Eq(..))
+import Data.Foldable (elem, notElem, foldl')
+import Data.Functor (Functor(..))
+import Data.Functor.Identity (Identity(..))
import qualified Data.List
-import qualified Text.Parsec as R
+import Data.Maybe (Maybe(..))
+import Data.Ord (Ord(..))
+import Data.String (String)
+import Prelude ( ($), (.)
+ , Integer
+ , Integral(..)
+ , Monad(..)
+ , Num(..)
+ , Show(..)
+ , const
+ , seq
+ )
import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
+import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
import qualified Text.Parsec.Pos as R
-import qualified Text.Parsec.Error as R
-- * Combinators
-- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
-choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
+choice_try = Data.List.foldr ((<|>) . R.try) R.parserZero
-- choice_try = R.choice . Data.List.map R.try
-- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
s <- R.getState
return (a, s)
--- ** Custom 'ParsecT' errors.
+-- ** Fixed 'R.satisfy'
+
+-- | Like 'R.updatePosChar' but without '\t' being special.
+updatePosChar :: R.SourcePos -> Char -> R.SourcePos
+updatePosChar pos c =
+ case c of
+ '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
+ _ -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
+
+-- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
+updatePosString :: R.SourcePos -> String -> R.SourcePos
+updatePosString = foldl' updatePosChar
+
+-- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
+satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
+satisfy f = R.tokenPrim (\c -> show [c])
+ (\pos c _cs -> updatePosChar pos c)
+ (\c -> if f c then Just c else Nothing)
+
+-- | Like 'R.string' but using fixed 'updatePosString'.
+string :: (Stream s m Char) => String -> ParsecT s u m String
+string = R.tokens show updatePosString
+
+-- | Like 'R.char' but using fixed 'satisfy'.
+char :: (Stream s m Char) => Char -> ParsecT s u m Char
+char c = satisfy (==c) <?> show [c]
+
+-- | Like 'R.anyChar' but using fixed 'satisfy'.
+anyChar :: (Stream s m Char) => ParsecT s u m Char
+anyChar = satisfy (const True)
+
+-- | Like 'R.oneOf' but using fixed 'satisfy'.
+oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
+oneOf cs = satisfy (`elem` cs)
+
+-- | Like 'R.noneOf' but using fixed 'satisfy'.
+noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
+noneOf cs = satisfy (`notElem` cs)
+
+-- ** Custom 'ParsecT' errors
-- | Use the 'StateT' monad transformer
-- to attach custom errors to the 'ParsecT' monad.
-type Error e = StateT (R.SourcePos, [e])
+--
+-- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
+type Error_State e = StateT (R.SourcePos, [Error e])
+data Error e
+ = Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
+ | Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
+ | Error_At R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
+ deriving (Show)
+
+instance Functor Error where
+ fmap _ (Error_Parser e) = Error_Parser e
+ fmap f (Error_Custom pos e) = Error_Custom pos (f e)
+ fmap f (Error_At pos es) = Error_At pos $ fmap (fmap f) es
-fail_with :: (Stream s (Error e m) Char, Monad m)
- => String -> e -> ParsecT s u (Error e m) r
+-- | Like 'R.parserFail'
+-- but fail with given custom error.
+fail_with :: (Stream s (Error_State e m) Char, Monad m)
+ => String -> e -> ParsecT s u (Error_State e m) r
fail_with msg err = do
(sp, se) <- lift get
- p <- R.getPosition
+ rp <- R.getPosition -- NOTE: reported position
+ _ <- (void R.anyChar <|> R.eof)
+ -- NOTE: somehow commits that this character has an error
+ p <- R.getPosition -- NOTE: compared position
case () of
- _ | R.sourceLine p > R.sourceLine sp &&
- R.sourceColumn p > R.sourceColumn sp
- -> lift $ put (p, err:[])
+ _ | R.sourceLine p > R.sourceLine sp ||
+ (R.sourceLine p == R.sourceLine sp &&
+ R.sourceColumn p > R.sourceColumn sp)
+ -> lift $ put (p, [Error_Custom rp err])
_ | R.sourceLine p == R.sourceLine sp &&
R.sourceColumn p == R.sourceColumn sp
- -> lift $ put (sp, err:se)
+ -> lift $ put (p, Error_Custom rp err:se)
_ -> return ()
R.parserFail msg
+-- | Like 'R.runParserT' but return as error an 'Error' list
runParserT_with_Error
- :: (Stream s (Error e m) Char, Monad m)
- => ParsecT s u (Error e m) r
+ :: (Stream s (Error_State e m) Char, Monad m)
+ => ParsecT s u (Error_State e m) r
-> u -> R.SourceName -> s
- -> m (Either (R.ParseError, [e]) r)
+ -> m (Either [Error e] r)
runParserT_with_Error p u sn s = do
(r, (sp, se)) <- runStateT
(R.runParserT p u sn s)
(R.initialPos sn, [])
case r of
- Left pe | R.sourceLine (R.errorPos pe) < R.sourceLine sp &&
- R.sourceColumn (R.errorPos pe) < R.sourceColumn sp
- -> return $ Left (R.newErrorUnknown sp, se)
+ Left pe | R.sourceLine (R.errorPos pe) < R.sourceLine sp ||
+ (R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
+ R.sourceColumn (R.errorPos pe) < R.sourceColumn sp)
+ -> return $ Left $ se -- NOTE: custom errors detected at a greater position
Left pe | R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
- -> return $ Left (case se of {[] -> pe; _ -> R.newErrorUnknown sp}, se)
- Left pe -> return $ Left (pe, [])
+ -> return $ Left $ se -- NOTE: prefer custom errors
+ Left pe -> return $ Left $ [Error_Parser pe]
Right x -> return $ Right x
+-- | Like 'R.runParserT_with_Error'
+-- but applied on the 'Identity' monad.
runParser_with_Error
- :: (Stream s (Error e Identity) Char)
- => ParsecT s u (Error e Identity) r
+ :: (Stream s (Error_State e Identity) Char)
+ => ParsecT s u (Error_State e Identity) r
-> u -> R.SourceName -> s
- -> Either (R.ParseError, [e]) r
+ -> Either [Error e] r
runParser_with_Error p u sn s =
runIdentity $
runParserT_with_Error p u sn s
+-- | Like 'R.runParserT_with_Error'
+-- but propagate any failure to a calling 'ParsecT' monad.
+runParserT_with_Error_fail ::
+ ( Stream s1 (Error_State ee m) Char
+ , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
+ , Monad m )
+ => String
+ -> (Error e -> Error ee)
+ -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
+ -> u -> R.SourceName -> s
+ -> ParsecT s1 u1 (Error_State ee m) r
+runParserT_with_Error_fail msg map_ko p u sn s = do
+ r <- runParserT_with_Error p u sn s
+ case r of
+ Right ok -> return ok
+ Left ko -> do
+ rpos <- R.getPosition
+ _ <- commit_position
+ pos <- R.getPosition
+ lift $ put (pos, [Error_At rpos (fmap map_ko ko)])
+ fail msg
+ where commit_position = (void R.anyChar) <|> R.eof
+
+-- ** Mapping inner monad
+
+-- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
+-- but also requiring a second 'Monad' constraint
+-- on the returned base container.
+--
+-- NOTE: This code is not used by Hcompta, still is left here
+-- because it was not trivial to write it,
+-- so eventually it may help others.
+hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
+hoist nat m = R.mkPT $ \s -> do
+ c <- nat $ R.runParsecT m s
+ return $ case c of
+ R.Consumed mrep -> R.Consumed $ nat mrep
+ R.Empty mrep -> R.Empty $ nat mrep
+
+-- | Map the type of a 'StateT'.
+--
+-- NOTE: This code is not used by Hcompta, still is left here
+-- because it was not trivial to write it,
+-- so eventually it may help others.
+smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
+smap s1_to_s0 s0_to_s1 st =
+ StateT (\s1_begin -> do
+ (a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
+ return (a, s0_to_s1 s0_end))
+
-- * Numbers
-- | Return the 'Integer' obtained by multiplying the given digits
-> [Char] -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
-> Integer
integer_of_digits base =
- Data.List.foldl (\x d ->
+ foldl' (\x d ->
base*x + toInteger (Data.Char.digitToInt d)) 0
decimal :: Stream s m Char => ParsecT s u m Integer
is_space_horizontal :: Char -> Bool
is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
+-- | Like 'R.space' but using fixed 'satisfy'.
+space :: Stream s m Char => ParsecT s u m Char
+{-# INLINEABLE space #-}
+space = satisfy Data.Char.isSpace <?> "space"
+
+-- | Like 'R.spaces' but using fixed 'satisfy'.
+spaces :: Stream s m Char => ParsecT s u m ()
+{-# INLINEABLE spaces #-}
+spaces = R.skipMany space <?> "spaces"
+
+-- | Like 'R.tab' but using fixed 'satisfy'.
+tab :: (Stream s m Char) => ParsecT s u m Char
+{-# INLINEABLE tab #-}
+tab = char '\t' <?> "tab"
+
+-- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
space_horizontal :: Stream s m Char => ParsecT s u m Char
{-# INLINEABLE space_horizontal #-}
-space_horizontal = R.satisfy is_space_horizontal <?> "horizontal-space"
+space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
new_line :: Stream s m Char => ParsecT s u m ()
{-# INLINEABLE new_line #-}
-new_line = ((R.try (R.string "\r\n") <|> R.try (R.string "\n")) >> return ()) <?> "newline"
+new_line = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"
sourcephile / git / comptalang.git / blobdiff