{-# 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 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 hiding (satisfy, string, char, space, newline, crlf)
+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
-- * 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.
-- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
updatePosString :: R.SourcePos -> String -> R.SourcePos
-updatePosString pos s = foldl updatePosChar pos s
+updatePosString = foldl' updatePosChar
-- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
-- | Like 'R.string' but using fixed 'updatePosString'.
string :: (Stream s m Char) => String -> ParsecT s u m String
-string s = R.tokens show updatePosString s
+string = R.tokens show updatePosString
-- | Like 'R.char' but using fixed 'satisfy'.
char :: (Stream s m Char) => Char -> ParsecT s u m Char
-- | Like 'R.oneOf' but using fixed 'satisfy'.
oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
-oneOf cs = satisfy (\c -> elem c cs)
+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 (\c -> not (elem c cs))
+noneOf cs = satisfy (`notElem` cs)
-- ** Custom 'ParsecT' errors
| 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
+
-- | Like 'R.parserFail'
-- but fail with given custom error.
fail_with :: (Stream s (Error_State e m) Char, Monad m)
fail_with msg err = do
(sp, se) <- lift get
rp <- R.getPosition -- NOTE: reported position
- _ <- ((R.anyChar >> return ()) <|> R.eof)
+ _ <- (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.sourceLine p == R.sourceLine sp &&
R.sourceColumn p > R.sourceColumn sp)
- -> lift $ put (p, Error_Custom rp err:[])
+ -> lift $ put (p, [Error_Custom rp err])
_ | R.sourceLine p == R.sourceLine sp &&
R.sourceColumn p == R.sourceColumn sp
-> lift $ put (p, Error_Custom rp err:se)
-- | Like 'R.runParserT' but return as error an 'Error' list
runParserT_with_Error
- :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
+ :: (Stream s (Error_State e m) Char, Monad m)
=> ParsecT s u (Error_State e m) r
-> u -> R.SourceName -> s
-> m (Either [Error e] r)
Left pe | R.sourceLine (R.errorPos pe) == R.sourceLine sp &&
R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
-> return $ Left $ se -- NOTE: prefer custom errors
- Left pe -> return $ Left $ Error_Parser pe:[]
+ 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_State e Identity) Char, Show r, Show e)
+ :: (Stream s (Error_State e Identity) Char)
=> ParsecT s u (Error_State e Identity) r
-> u -> R.SourceName -> s
-> Either [Error e] r
-- | Like 'R.runParserT_with_Error'
-- but propagate any failure to a calling 'ParsecT' monad.
runParserT_with_Error_fail ::
- ( Stream s1 (Error_State e m) Char
- , Stream s (Error_State e (ParsecT s1 u1 (Error_State e m))) Char
- , Monad m, Show r, Show e )
+ ( Stream s1 (Error_State ee m) Char
+ , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
+ , Monad m )
=> String
- -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State e m))) r
+ -> (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 e m) r
-runParserT_with_Error_fail msg p u sn s = do
+ -> 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
rpos <- R.getPosition
_ <- commit_position
pos <- R.getPosition
- lift $ put (pos, Error_At rpos ko:[])
+ lift $ put (pos, [Error_At rpos (fmap map_ko ko)])
fail msg
- where commit_position = (R.anyChar >> return ()) <|> R.eof
+ 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
-> [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
new_line :: Stream s m Char => ParsecT s u m ()
{-# INLINEABLE new_line #-}
-new_line = ((R.try (string "\r\n") <|> R.try (string "\n")) >> return ()) <?> "newline"
+new_line = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"
sourcephile / git / comptalang.git / blobdiff