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