lib/Hcompta/Lib/Parsec.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE Rank2Types #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# OPTIONS_GHC -fno-warn-orphans #-}
   5 module Hcompta.Lib.Parsec where
   6
   7 import           Control.Monad (void)
   8 import           Control.Monad.Trans.Class (lift)
   9 import           Control.Monad.Trans.State (StateT(..), get, put)
  10 import           Data.Bool
  11 import           Data.Char (Char)
  12 import qualified Data.Char
  13 import           Data.Either
  14 import           Data.Eq (Eq(..))
  15 import           Data.Foldable (elem, notElem, foldl')
  16 import           Data.Functor (Functor(..))
  17 import           Data.Functor.Identity (Identity(..))
  18 import qualified Data.List
  19 import           Data.Maybe (Maybe(..))
  20 import           Data.Ord (Ord(..))
  21 import           Data.String (String)
  22 import           Prelude (($), (.), Integer, Integral(..), Monad(..), Num(..), Show(..), const, seq)
  23 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  24 import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
  25 import qualified Text.Parsec.Pos as R
  26
  27 -- * Combinators
  28
  29 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  30 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
  31 choice_try = Data.List.foldr ((<|>) . R.try) R.parserZero
  32 -- choice_try = R.choice . Data.List.map R.try
  33
  34 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
  35 many_separated
  36  :: Stream s m t
  37  => ParsecT s u m a
  38  -> ParsecT s u m b
  39  -> ParsecT s u m [a]
  40 many_separated p sep =
  41         many1_separated p sep <|> return []
  42
  43 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
  44 many1_separated
  45  :: Stream s m t
  46  => ParsecT s u m a
  47  -> ParsecT s u m b
  48  -> ParsecT s u m [a]
  49 many1_separated p sep = do
  50         x <- p
  51         xs <- R.many (R.try (sep >> p))
  52         return $ x:xs
  53 -- (:) <$> p <*> R.many (R.try (sep >> p))
  54
  55 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
  56 and_state
  57  :: Stream s m t
  58  => ParsecT s u m a
  59  -> ParsecT s u m (a, u)
  60 and_state p = do
  61         a <- p
  62         s <- R.getState
  63         return (a, s)
  64
  65 -- ** Fixed 'R.satisfy'
  66
  67 -- | Like 'R.updatePosChar' but without '\t' being special.
  68 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
  69 updatePosChar pos c =
  70         case c of
  71          '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
  72          _    -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
  73
  74 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
  75 updatePosString :: R.SourcePos -> String -> R.SourcePos
  76 updatePosString = foldl' updatePosChar
  77
  78 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
  79 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
  80 satisfy f = R.tokenPrim (\c -> show [c])
  81                         (\pos c _cs -> updatePosChar pos c)
  82                         (\c -> if f c then Just c else Nothing)
  83
  84 -- | Like 'R.string' but using fixed 'updatePosString'.
  85 string :: (Stream s m Char) => String -> ParsecT s u m String
  86 string = R.tokens show updatePosString
  87
  88 -- | Like 'R.char' but using fixed 'satisfy'.
  89 char :: (Stream s m Char) => Char -> ParsecT s u m Char
  90 char c = satisfy (==c)  <?> show [c]
  91
  92 -- | Like 'R.anyChar' but using fixed 'satisfy'.
  93 anyChar :: (Stream s m Char) => ParsecT s u m Char
  94 anyChar = satisfy (const True)
  95
  96 -- | Like 'R.oneOf' but using fixed 'satisfy'.
  97 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
  98 oneOf cs = satisfy (`elem` cs)
  99
 100 -- | Like 'R.noneOf' but using fixed 'satisfy'.
 101 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
 102 noneOf cs = satisfy (`notElem` cs)
 103
 104 -- ** Custom 'ParsecT' errors
 105
 106 -- | Use the 'StateT' monad transformer
 107 --   to attach custom errors to the 'ParsecT' monad.
 108 --
 109 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
 110 type Error_State e = StateT (R.SourcePos, [Error e])
 111 data Error e
 112  =   Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
 113  |   Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
 114  |   Error_At     R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
 115  deriving (Show)
 116
 117 instance Functor Error where
 118         fmap _ (Error_Parser e)     = Error_Parser e
 119         fmap f (Error_Custom pos e) = Error_Custom pos (f e)
 120         fmap f (Error_At pos es)    = Error_At pos $ fmap (fmap f) es
 121
 122 -- | Like 'R.parserFail'
 123 --   but fail with given custom error.
 124 fail_with :: (Stream s (Error_State e m) Char, Monad m)
 125  => String -> e -> ParsecT s u (Error_State e m) r
 126 fail_with msg err = do
 127         (sp, se) <- lift get
 128         rp <- R.getPosition -- NOTE: reported position
 129         _ <- (void R.anyChar <|> R.eof)
 130          -- NOTE: somehow commits that this character has an error
 131         p <- R.getPosition -- NOTE: compared position
 132         case () of
 133          _ | R.sourceLine   p  > R.sourceLine   sp ||
 134             (R.sourceLine   p == R.sourceLine   sp &&
 135              R.sourceColumn p  > R.sourceColumn sp)
 136            -> lift $ put (p, [Error_Custom rp err])
 137          _ | R.sourceLine   p == R.sourceLine   sp &&
 138              R.sourceColumn p == R.sourceColumn sp
 139            -> lift $ put (p, Error_Custom rp err:se)
 140          _ -> return ()
 141         R.parserFail msg
 142
 143 -- | Like 'R.runParserT' but return as error an 'Error' list
 144 runParserT_with_Error
 145  :: (Stream s (Error_State e m) Char, Monad m)
 146  => ParsecT s u (Error_State e m) r
 147  -> u -> R.SourceName -> s
 148  -> m (Either [Error e] r)
 149 runParserT_with_Error p u sn s = do
 150         (r, (sp, se)) <- runStateT
 151          (R.runParserT p u sn s)
 152          (R.initialPos sn, [])
 153         case r of
 154          Left pe | R.sourceLine   (R.errorPos pe)  < R.sourceLine   sp ||
 155                   (R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 156                    R.sourceColumn (R.errorPos pe)  < R.sourceColumn sp)
 157                  -> return $ Left $ se -- NOTE: custom errors detected at a greater position
 158          Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 159                    R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
 160                  -> return $ Left $ se -- NOTE: prefer custom errors
 161          Left pe -> return $ Left $ [Error_Parser pe]
 162          Right x -> return $ Right x
 163
 164 -- | Like 'R.runParserT_with_Error'
 165 --   but applied on the 'Identity' monad.
 166 runParser_with_Error
 167  :: (Stream s (Error_State e Identity) Char)
 168  => ParsecT s u (Error_State e Identity) r
 169  -> u -> R.SourceName -> s
 170  -> Either [Error e] r
 171 runParser_with_Error p u sn s =
 172         runIdentity $
 173         runParserT_with_Error p u sn s
 174
 175 -- | Like 'R.runParserT_with_Error'
 176 --   but propagate any failure to a calling 'ParsecT' monad.
 177 runParserT_with_Error_fail ::
 178  ( Stream s1 (Error_State ee m) Char
 179  , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
 180  , Monad m )
 181  => String
 182  -> (Error e -> Error ee)
 183  -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
 184  -> u -> R.SourceName -> s
 185  -> ParsecT s1 u1 (Error_State ee m) r
 186 runParserT_with_Error_fail msg map_ko p u sn s = do
 187         r <- runParserT_with_Error p u sn s
 188         case r of
 189          Right ok -> return ok
 190          Left ko -> do
 191                 rpos <- R.getPosition
 192                 _ <- commit_position
 193                 pos <- R.getPosition
 194                 lift $ put (pos, [Error_At rpos (fmap map_ko ko)])
 195                 fail msg
 196         where commit_position = (void R.anyChar) <|> R.eof
 197
 198 -- ** Mapping inner monad
 199
 200 -- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
 201 --   but also requiring a second 'Monad' constraint
 202 --   on the returned base container.
 203 --
 204 -- NOTE: This code is not used by Hcompta, still is left here
 205 -- because it was not trivial to write it,
 206 -- so eventually it may help others.
 207 hoist :: (Monad m, Monad n) => (forall a. m a -> n a) -> ParsecT s u m b -> ParsecT s u n b
 208 hoist nat m = R.mkPT $ \s -> do
 209         c <- nat $ R.runParsecT m s
 210         return $ case c of
 211                  R.Consumed mrep -> R.Consumed $ nat mrep
 212                  R.Empty    mrep -> R.Empty    $ nat mrep
 213
 214 -- | Map the type of a 'StateT'.
 215 --
 216 -- NOTE: This code is not used by Hcompta, still is left here
 217 -- because it was not trivial to write it,
 218 -- so eventually it may help others.
 219 smap :: Monad m => (s1 -> s0) -> (s0 -> s1) -> StateT s0 m a -> StateT s1 m a
 220 smap s1_to_s0 s0_to_s1 st =
 221         StateT (\s1_begin -> do
 222                 (a, s0_end) <- runStateT st (s1_to_s0 s1_begin)
 223                 return (a, s0_to_s1 s0_end))
 224
 225 -- * Numbers
 226
 227 -- | Return the 'Integer' obtained by multiplying the given digits
 228 --   with the power of the given base respective to their rank.
 229 integer_of_digits
 230  :: Integer -- ^ Base.
 231  -> [Char]  -- ^ Digits (MUST be recognised by 'Data.Char.digitToInt').
 232  -> Integer
 233 integer_of_digits base =
 234         foldl' (\x d ->
 235                 base*x + toInteger (Data.Char.digitToInt d)) 0
 236
 237 decimal :: Stream s m Char => ParsecT s u m Integer
 238 decimal = integer 10 R.digit
 239 hexadecimal :: Stream s m Char => ParsecT s u m Integer
 240 hexadecimal = R.oneOf "xX" >> integer 16 R.hexDigit
 241 octal :: Stream s m Char => ParsecT s u m Integer
 242 octal = R.oneOf "oO" >> integer 8 R.octDigit
 243
 244 -- | Parse an 'Integer'.
 245 integer :: Stream s m t
 246         => Integer
 247         -> ParsecT s u m Char
 248         -> ParsecT s u m Integer
 249 integer base digit = do
 250         digits <- R.many1 digit
 251         let n = integer_of_digits base digits
 252         seq n (return n)
 253
 254 -- * Whites
 255
 256 -- | Return 'True' if and only if the given 'Char' is an horizontal space.
 257 is_space_horizontal :: Char -> Bool
 258 is_space_horizontal c = c /= '\n' && c /= '\r' && Data.Char.isSpace c
 259
 260 -- | Like 'R.space' but using fixed 'satisfy'.
 261 space :: Stream s m Char => ParsecT s u m Char
 262 {-# INLINEABLE space #-}
 263 space = satisfy Data.Char.isSpace <?> "space"
 264
 265 -- | Like 'R.spaces' but using fixed 'satisfy'.
 266 spaces :: Stream s m Char => ParsecT s u m ()
 267 {-# INLINEABLE spaces #-}
 268 spaces = R.skipMany space <?> "spaces"
 269
 270 -- | Like 'R.tab' but using fixed 'satisfy'.
 271 tab :: (Stream s m Char) => ParsecT s u m Char
 272 {-# INLINEABLE tab #-}
 273 tab = char '\t' <?> "tab"
 274
 275 -- | Parse only a 'Char' which passes 'satisfy' 'is_space_horizontal'.
 276 space_horizontal :: Stream s m Char => ParsecT s u m Char
 277 {-# INLINEABLE space_horizontal #-}
 278 space_horizontal = satisfy is_space_horizontal <?> "horizontal-space"
 279
 280 new_line :: Stream s m Char => ParsecT s u m ()
 281 {-# INLINEABLE new_line #-}
 282 new_line = (void (R.try (string "\r\n") <|> R.try (string "\n"))) <?> "newline"