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