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