lib/Hcompta/Lib/Parsec.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 module Hcompta.Lib.Parsec where
   4
   5 import           Control.Monad.Trans.State (StateT(..), get, put)
   6 import           Control.Monad.Trans.Class (lift, MonadTrans(..))
   7 import           Control.Monad.Identity (Identity(..))
   8 import qualified Data.Char
   9 import qualified Data.List
  10 import qualified Text.Parsec as R
  11 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  12 import qualified Text.Parsec.Pos as R
  13
  14 -- * Combinators
  15
  16 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  17 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
  18 choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
  19 -- choice_try = R.choice . Data.List.map R.try
  20
  21 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
  22 many_separated
  23  :: Stream s m t
  24  => ParsecT s u m a
  25  -> ParsecT s u m b
  26  -> ParsecT s u m [a]
  27 many_separated p sep =
  28         many1_separated p sep <|> return []
  29
  30 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
  31 many1_separated
  32  :: Stream s m t
  33  => ParsecT s u m a
  34  -> ParsecT s u m b
  35  -> ParsecT s u m [a]
  36 many1_separated p sep = do
  37         x <- p
  38         xs <- R.many (R.try (sep >> p))
  39         return $ x:xs
  40 -- (:) <$> p <*> R.many (R.try (sep >> p))
  41
  42 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
  43 and_state
  44  :: Stream s m t
  45  => ParsecT s u m a
  46  -> ParsecT s u m (a, u)
  47 and_state p = do
  48         a <- p
  49         s <- R.getState
  50         return (a, s)
  51
  52 -- ** Custom 'ParsecT' errors
  53
  54 -- | Use the 'StateT' monad transformer
  55 --   to attach custom errors to the 'ParsecT' monad.
  56 --
  57 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
  58 type Error_State e = StateT (R.SourcePos, [Error e])
  59 data Error e
  60  =   Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
  61  |   Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
  62  |   Error_At     R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
  63  deriving (Show)
  64
  65 -- | Like 'R.parserFail'
  66 --   but fail with given custom error.
  67 fail_with :: (Stream s (Error_State e m) Char, Monad m)
  68  => String -> e -> ParsecT s u (Error_State e m) r
  69 fail_with msg err = do
  70         (sp, se) <- lift get
  71         rp <- R.getPosition -- NOTE: reported position
  72         _ <- ((R.anyChar >> return ()) <|> R.eof)
  73          -- NOTE: somehow commits that this character has an error
  74         p <- R.getPosition -- NOTE: compared position
  75         case () of
  76          _ | R.sourceLine   p  > R.sourceLine   sp ||
  77             (R.sourceLine   p == R.sourceLine   sp &&
  78              R.sourceColumn p  > R.sourceColumn sp)
  79            -> lift $ put (p, Error_Custom rp err:[])
  80          _ | R.sourceLine   p == R.sourceLine   sp &&
  81              R.sourceColumn p == R.sourceColumn sp
  82            -> lift $ put (p, Error_Custom rp err:se)
  83          _ -> return ()
  84         R.parserFail msg
  85
  86 -- | Like 'R.runParserT' but return as error an 'Error' list
  87 runParserT_with_Error
  88  :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
  89  => ParsecT s u (Error_State e m) r
  90  -> u -> R.SourceName -> s
  91  -> m (Either [Error e] r)
  92 runParserT_with_Error p u sn s = do
  93         (r, (sp, se)) <- runStateT
  94          (R.runParserT p u sn s)
  95          (R.initialPos sn, [])
  96         case r of
  97          Left pe | R.sourceLine   (R.errorPos pe)  < R.sourceLine   sp ||
  98                   (R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
  99                    R.sourceColumn (R.errorPos pe)  < R.sourceColumn sp)
 100                  -> return $ Left $ se -- NOTE: custom errors detected at a greater position
 101          Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 102                    R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
 103                  -> return $ Left $ se -- NOTE: prefer custom errors
 104          Left pe -> return $ Left $ Error_Parser pe:[]
 105          Right x -> return $ Right x
 106
 107 -- | Like 'R.runParserT_with_Error'
 108 --   but applied on the 'Identity' monad.
 109 runParser_with_Error
 110  :: (Stream s (Error_State e Identity) Char, Show r, Show e)
 111  => ParsecT s u (Error_State e Identity) r
 112  -> u -> R.SourceName -> s
 113  -> Either [Error e] r
 114 runParser_with_Error p u sn s =
 115         runIdentity $
 116         runParserT_with_Error p u sn s
 117
 118 -- | Like 'R.runParserT_with_Error'
 119 --   but propagate any failure to a calling 'ParsecT' monad.
 120 runParserT_with_Error_fail ::
 121  ( Stream s1 (Error_State e m) Char
 122  , Stream s (Error_State e (ParsecT s1 u1 (Error_State e m))) Char
 123  , Monad m, Show r, Show e )
 124  => String
 125  -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State e m))) r
 126  -> u -> R.SourceName -> s
 127  -> ParsecT s1 u1 (Error_State e m) r
 128 runParserT_with_Error_fail msg p u sn s = do
 129         r <- runParserT_with_Error p u sn s
 130         case r of
 131          Right ok -> return ok
 132          Left ko -> do
 133                 rpos <- R.getPosition
 134                 _ <- commit_position
 135                 pos <- R.getPosition
 136                 lift $ put (pos, Error_At rpos ko:[])
 137                 fail msg
 138         where commit_position = (R.anyChar >> return ()) <|> R.eof
 139
 140 -- * Numbers
 141
 142 -- | Return the 'Integer' obtained by multiplying the given digits
 143 --   with the power of the given base respective to their rank.
 144 integer_of_digits
 145  :: Integer -- ^ Base.
 146  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 147  -> Integer
 148 integer_of_digits base =
 149         Data.List.foldl (\x d ->
 150                 base*x + toInteger (Data.Char.digitToInt d)) 0
 151
 152 decimal :: Stream s m Char => ParsecT s u m Integer
 153 decimal = integer 10 R.digit
 154 hexadecimal :: Stream s m Char => ParsecT s u m Integer
 155 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
 156 octal :: Stream s m Char => ParsecT s u m Integer
 157 octal = R.oneOf "oO" >> integer 8 R.octDigit
 158
 159 -- | Parse an 'Integer'.
 160 integer :: Stream s m t
 161         => Integer
 162         -> ParsecT s u m Char
 163         -> ParsecT s u m Integer
 164 integer base digit = do
 165         digits <- R.many1 digit
 166         let n = integer_of_digits base digits
 167         seq n (return n)
 168
 169 -- * Whites
 170
 171 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 172 is_space_horizontal :: Char -> Bool
 173 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 174
 175 space_horizontal :: Stream s m Char => ParsecT s u m Char
 176 {-# INLINEABLE space_horizontal #-}
 177 space_horizontal = R.satisfy is_space_horizontal <?> "horizontal-space"
 178
 179 new_line :: Stream s m Char => ParsecT s u m ()
 180 {-# INLINEABLE new_line #-}
 181 new_line = ((R.try (R.string "\r\n") <|> R.try (R.string "\n")) >> return ()) <?> "newline"