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 hiding (satisfy, string, char, space, newline, crlf)
  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 -- ** Fixed 'R.satisfy'
  53
  54 -- | Like 'R.updatePosChar' but without '\t' being special.
  55 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
  56 updatePosChar pos c =
  57         case c of
  58          '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
  59          _    -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
  60
  61 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
  62 updatePosString :: R.SourcePos -> String -> R.SourcePos
  63 updatePosString pos s = foldl updatePosChar pos s
  64
  65 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
  66 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
  67 satisfy f = R.tokenPrim (\c -> show [c])
  68                         (\pos c _cs -> updatePosChar pos c)
  69                         (\c -> if f c then Just c else Nothing)
  70
  71 -- | Like 'R.string' but using fixed 'updatePosString'.
  72 string :: (Stream s m Char) => String -> ParsecT s u m String
  73 string s = R.tokens show updatePosString s
  74
  75 -- | Like 'R.char' but using fixed 'satisfy'.
  76 char :: (Stream s m Char) => Char -> ParsecT s u m Char
  77 char c = satisfy (==c)  <?> show [c]
  78
  79 -- | Like 'R.anyChar' but using fixed 'satisfy'.
  80 anyChar :: (Stream s m Char) => ParsecT s u m Char
  81 anyChar = satisfy (const True)
  82
  83 -- | Like 'R.oneOf' but using fixed 'satisfy'.
  84 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
  85 oneOf cs = satisfy (\c -> elem c cs)
  86
  87 -- | Like 'R.noneOf' but using fixed 'satisfy'.
  88 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
  89 noneOf cs = satisfy (\c -> not (elem c cs))
  90
  91 -- ** Custom 'ParsecT' errors
  92
  93 -- | Use the 'StateT' monad transformer
  94 --   to attach custom errors to the 'ParsecT' monad.
  95 --
  96 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
  97 type Error_State e = StateT (R.SourcePos, [Error e])
  98 data Error e
  99  =   Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
 100  |   Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
 101  |   Error_At     R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
 102  deriving (Show)
 103
 104 -- | Like 'R.parserFail'
 105 --   but fail with given custom error.
 106 fail_with :: (Stream s (Error_State e m) Char, Monad m)
 107  => String -> e -> ParsecT s u (Error_State e m) r
 108 fail_with msg err = do
 109         (sp, se) <- lift get
 110         rp <- R.getPosition -- NOTE: reported position
 111         _ <- ((R.anyChar >> return ()) <|> R.eof)
 112          -- NOTE: somehow commits that this character has an error
 113         p <- R.getPosition -- NOTE: compared position
 114         case () of
 115          _ | R.sourceLine   p  > R.sourceLine   sp ||
 116             (R.sourceLine   p == R.sourceLine   sp &&
 117              R.sourceColumn p  > R.sourceColumn sp)
 118            -> lift $ put (p, Error_Custom rp err:[])
 119          _ | R.sourceLine   p == R.sourceLine   sp &&
 120              R.sourceColumn p == R.sourceColumn sp
 121            -> lift $ put (p, Error_Custom rp err:se)
 122          _ -> return ()
 123         R.parserFail msg
 124
 125 -- | Like 'R.runParserT' but return as error an 'Error' list
 126 runParserT_with_Error
 127  :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
 128  => ParsecT s u (Error_State e m) r
 129  -> u -> R.SourceName -> s
 130  -> m (Either [Error e] r)
 131 runParserT_with_Error p u sn s = do
 132         (r, (sp, se)) <- runStateT
 133          (R.runParserT p u sn s)
 134          (R.initialPos sn, [])
 135         case r of
 136          Left pe | R.sourceLine   (R.errorPos pe)  < R.sourceLine   sp ||
 137                   (R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 138                    R.sourceColumn (R.errorPos pe)  < R.sourceColumn sp)
 139                  -> return $ Left $ se -- NOTE: custom errors detected at a greater position
 140          Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 141                    R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
 142                  -> return $ Left $ se -- NOTE: prefer custom errors
 143          Left pe -> return $ Left $ Error_Parser pe:[]
 144          Right x -> return $ Right x
 145
 146 -- | Like 'R.runParserT_with_Error'
 147 --   but applied on the 'Identity' monad.
 148 runParser_with_Error
 149  :: (Stream s (Error_State e Identity) Char, Show r, Show e)
 150  => ParsecT s u (Error_State e Identity) r
 151  -> u -> R.SourceName -> s
 152  -> Either [Error e] r
 153 runParser_with_Error p u sn s =
 154         runIdentity $
 155         runParserT_with_Error p u sn s
 156
 157 -- | Like 'R.runParserT_with_Error'
 158 --   but propagate any failure to a calling 'ParsecT' monad.
 159 runParserT_with_Error_fail ::
 160  ( Stream s1 (Error_State e m) Char
 161  , Stream s (Error_State e (ParsecT s1 u1 (Error_State e m))) Char
 162  , Monad m, Show r, Show e )
 163  => String
 164  -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State e m))) r
 165  -> u -> R.SourceName -> s
 166  -> ParsecT s1 u1 (Error_State e m) r
 167 runParserT_with_Error_fail msg p u sn s = do
 168         r <- runParserT_with_Error p u sn s
 169         case r of
 170          Right ok -> return ok
 171          Left ko -> do
 172                 rpos <- R.getPosition
 173                 _ <- commit_position
 174                 pos <- R.getPosition
 175                 lift $ put (pos, Error_At rpos ko:[])
 176                 fail msg
 177         where commit_position = (R.anyChar >> return ()) <|> R.eof
 178
 179 -- * Numbers
 180
 181 -- | Return the 'Integer' obtained by multiplying the given digits
 182 --   with the power of the given base respective to their rank.
 183 integer_of_digits
 184  :: Integer -- ^ Base.
 185  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 186  -> Integer
 187 integer_of_digits base =
 188         Data.List.foldl (\x d ->
 189                 base*x + toInteger (Data.Char.digitToInt d)) 0
 190
 191 decimal :: Stream s m Char => ParsecT s u m Integer
 192 decimal = integer 10 R.digit
 193 hexadecimal :: Stream s m Char => ParsecT s u m Integer
 194 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
 195 octal :: Stream s m Char => ParsecT s u m Integer
 196 octal = R.oneOf "oO" >> integer 8 R.octDigit
 197
 198 -- | Parse an 'Integer'.
 199 integer :: Stream s m t
 200         => Integer
 201         -> ParsecT s u m Char
 202         -> ParsecT s u m Integer
 203 integer base digit = do
 204         digits <- R.many1 digit
 205         let n = integer_of_digits base digits
 206         seq n (return n)
 207
 208 -- * Whites
 209
 210 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 211 is_space_horizontal :: Char -> Bool
 212 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 213
 214 -- | Like 'R.space' but using fixed 'satisfy'.
 215 space :: Stream s m Char => ParsecT s u m Char
 216 {-# INLINEABLE space #-}
 217 space = satisfy Data.Char.isSpace <?> "space"
 218
 219 -- | Like 'R.spaces' but using fixed 'satisfy'.
 220 spaces :: Stream s m Char => ParsecT s u m ()
 221 {-# INLINEABLE spaces #-}
 222 spaces = R.skipMany space <?> "spaces"
 223
 224 -- | Like 'R.tab' but using fixed 'satisfy'.
 225 tab :: (Stream s m Char) => ParsecT s u m Char
 226 {-# INLINEABLE tab #-}
 227 tab = char '\t' <?> "tab"
 228
 229 -- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
 230 space_horizontal :: Stream s m Char => ParsecT s u m Char
 231 {-# INLINEABLE space_horizontal #-}
 232 space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
 233
 234 new_line :: Stream s m Char => ParsecT s u m ()
 235 {-# INLINEABLE new_line #-}
 236 new_line = ((R.try (string "\r\n") <|> R.try (string "\n")) >> return ()) <?> "newline"