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 import qualified Text.Parsec.Error as R
  14
  15 -- * Combinators
  16
  17 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  18 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
  19 choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
  20 -- choice_try = R.choice . Data.List.map R.try
  21
  22 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
  23 many_separated
  24  :: Stream s m t
  25  => ParsecT s u m a
  26  -> ParsecT s u m b
  27  -> ParsecT s u m [a]
  28 many_separated p sep =
  29         many1_separated p sep <|> return []
  30
  31 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
  32 many1_separated
  33  :: Stream s m t
  34  => ParsecT s u m a
  35  -> ParsecT s u m b
  36  -> ParsecT s u m [a]
  37 many1_separated p sep = do
  38         x <- p
  39         xs <- R.many (R.try (sep >> p))
  40         return $ x:xs
  41 -- (:) <$> p <*> R.many (R.try (sep >> p))
  42
  43 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
  44 and_state
  45  :: Stream s m t
  46  => ParsecT s u m a
  47  -> ParsecT s u m (a, u)
  48 and_state p = do
  49         a <- p
  50         s <- R.getState
  51         return (a, s)
  52
  53 -- ** Custom 'ParsecT' errors.
  54
  55 -- | Use the 'StateT' monad transformer
  56 --   to attach custom errors to the 'ParsecT' monad.
  57 type Error e = StateT (R.SourcePos, [e])
  58
  59 fail_with :: (Stream s (Error e m) Char, Monad m)
  60  => String -> e -> ParsecT s u (Error e m) r
  61 fail_with msg err = do
  62         (sp, se) <- lift get
  63         p <- R.getPosition
  64         case () of
  65          _ | R.sourceLine   p > R.sourceLine   sp &&
  66              R.sourceColumn p > R.sourceColumn sp
  67            -> lift $ put (p, err:[])
  68          _ | R.sourceLine   p == R.sourceLine   sp &&
  69              R.sourceColumn p == R.sourceColumn sp
  70            -> lift $ put (sp, err:se)
  71          _ -> return ()
  72         R.parserFail msg
  73
  74 runParserT_with_Error
  75  :: (Stream s (Error e m) Char, Monad m)
  76  => ParsecT s u (Error e m) r
  77  -> u -> R.SourceName -> s
  78  -> m (Either (R.ParseError, [e]) r)
  79 runParserT_with_Error p u sn s = do
  80         (r, (sp, se)) <- runStateT
  81          (R.runParserT p u sn s)
  82          (R.initialPos sn, [])
  83         case r of
  84          Left pe | R.sourceLine   (R.errorPos pe) < R.sourceLine   sp &&
  85                    R.sourceColumn (R.errorPos pe) < R.sourceColumn sp
  86                  -> return $ Left (R.newErrorUnknown sp, se)
  87          Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
  88                    R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
  89                  -> return $ Left (case se of {[] -> pe; _ -> R.newErrorUnknown sp}, se)
  90          Left pe -> return $ Left (pe, [])
  91          Right x -> return $ Right x
  92
  93 runParser_with_Error
  94  :: (Stream s (Error e Identity) Char)
  95  => ParsecT s u (Error e Identity) r
  96  -> u -> R.SourceName -> s
  97  -> Either (R.ParseError, [e]) r
  98 runParser_with_Error p u sn s =
  99         runIdentity $
 100         runParserT_with_Error p u sn s
 101
 102 -- * Numbers
 103
 104 -- | Return the 'Integer' obtained by multiplying the given digits
 105 --   with the power of the given base respective to their rank.
 106 integer_of_digits
 107  :: Integer -- ^ Base.
 108  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 109  -> Integer
 110 integer_of_digits base =
 111         Data.List.foldl (\x d ->
 112                 base*x + toInteger (Data.Char.digitToInt d)) 0
 113
 114 decimal :: Stream s m Char => ParsecT s u m Integer
 115 decimal = integer 10 R.digit
 116 hexadecimal :: Stream s m Char => ParsecT s u m Integer
 117 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
 118 octal :: Stream s m Char => ParsecT s u m Integer
 119 octal = R.oneOf "oO" >> integer 8 R.octDigit
 120
 121 -- | Parse an 'Integer'.
 122 integer :: Stream s m t
 123         => Integer
 124         -> ParsecT s u m Char
 125         -> ParsecT s u m Integer
 126 integer base digit = do
 127         digits <- R.many1 digit
 128         let n = integer_of_digits base digits
 129         seq n (return n)
 130
 131 -- * Whites
 132
 133 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 134 is_space_horizontal :: Char -> Bool
 135 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 136
 137 space_horizontal :: Stream s m Char => ParsecT s u m Char
 138 {-# INLINEABLE space_horizontal #-}
 139 space_horizontal = R.satisfy is_space_horizontal <?> "horizontal-space"
 140
 141 new_line :: Stream s m Char => ParsecT s u m ()
 142 {-# INLINEABLE new_line #-}
 143 new_line = ((R.try (R.string "\r\n") <|> R.try (R.string "\n")) >> return ()) <?> "newline"