lib/Hcompta/Lib/Parsec.hs

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