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.Trans.State (StateT(..), get, put)
   8 -- import           Control.Monad.Trans.Class (lift, MonadTrans(..))
   9 import qualified Data.Char
  10 import           Data.Functor.Identity (Identity(..))
  11 import qualified Data.List
  12 import qualified Text.Parsec as R hiding (satisfy, string, char, space, newline, crlf)
  13 import           Text.Parsec (Stream, ParsecT, (<|>), (<?>))
  14 import qualified Text.Parsec.Pos as R
  15 import           Control.Monad.Trans.Class (lift)
  16
  17 -- * Combinators
  18
  19 -- | Like 'Text.Parsec.choice' but with 'Text.Parsec.try' on each case.
  20 choice_try :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a
  21 choice_try = Data.List.foldr (\a -> (<|>) (R.try a)) R.parserZero
  22 -- choice_try = R.choice . Data.List.map R.try
  23
  24 -- | Like 'Text.Parsec.sepBy' but without parsing an ending separator.
  25 many_separated
  26  :: Stream s m t
  27  => ParsecT s u m a
  28  -> ParsecT s u m b
  29  -> ParsecT s u m [a]
  30 many_separated p sep =
  31         many1_separated p sep <|> return []
  32
  33 -- | Like 'Text.Parsec.sepBy1' but without parsing an ending separator.
  34 many1_separated
  35  :: Stream s m t
  36  => ParsecT s u m a
  37  -> ParsecT s u m b
  38  -> ParsecT s u m [a]
  39 many1_separated p sep = do
  40         x <- p
  41         xs <- R.many (R.try (sep >> p))
  42         return $ x:xs
  43 -- (:) <$> p <*> R.many (R.try (sep >> p))
  44
  45 -- | Make a 'Text.Parsec.ParsecT' also return its user state.
  46 and_state
  47  :: Stream s m t
  48  => ParsecT s u m a
  49  -> ParsecT s u m (a, u)
  50 and_state p = do
  51         a <- p
  52         s <- R.getState
  53         return (a, s)
  54
  55 -- ** Fixed 'R.satisfy'
  56
  57 -- | Like 'R.updatePosChar' but without '\t' being special.
  58 updatePosChar :: R.SourcePos -> Char -> R.SourcePos
  59 updatePosChar pos c =
  60         case c of
  61          '\n' -> R.newPos (R.sourceName pos) (R.sourceLine pos + 1) 1
  62          _    -> R.newPos (R.sourceName pos) (R.sourceLine pos) (R.sourceColumn pos + 1)
  63
  64 -- | Like 'R.updatePosString' but using fixed 'updatePosChar'.
  65 updatePosString :: R.SourcePos -> String -> R.SourcePos
  66 updatePosString pos s = foldl updatePosChar pos s
  67
  68 -- | Like 'R.updatePosChar' but using fixed 'updatePosChar'.
  69 satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
  70 satisfy f = R.tokenPrim (\c -> show [c])
  71                         (\pos c _cs -> updatePosChar pos c)
  72                         (\c -> if f c then Just c else Nothing)
  73
  74 -- | Like 'R.string' but using fixed 'updatePosString'.
  75 string :: (Stream s m Char) => String -> ParsecT s u m String
  76 string s = R.tokens show updatePosString s
  77
  78 -- | Like 'R.char' but using fixed 'satisfy'.
  79 char :: (Stream s m Char) => Char -> ParsecT s u m Char
  80 char c = satisfy (==c)  <?> show [c]
  81
  82 -- | Like 'R.anyChar' but using fixed 'satisfy'.
  83 anyChar :: (Stream s m Char) => ParsecT s u m Char
  84 anyChar = satisfy (const True)
  85
  86 -- | Like 'R.oneOf' but using fixed 'satisfy'.
  87 oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
  88 oneOf cs = satisfy (\c -> elem c cs)
  89
  90 -- | Like 'R.noneOf' but using fixed 'satisfy'.
  91 noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
  92 noneOf cs = satisfy (\c -> not (elem c cs))
  93
  94 -- ** Custom 'ParsecT' errors
  95
  96 -- | Use the 'StateT' monad transformer
  97 --   to attach custom errors to the 'ParsecT' monad.
  98 --
  99 -- NOTE: this is a poor man's hack to overcome 'Parsec'’s limitation.
 100 type Error_State e = StateT (R.SourcePos, [Error e])
 101 data Error e
 102  =   Error_Parser R.ParseError -- ^ 'Error' raised by 'R.fail'.
 103  |   Error_Custom R.SourcePos e -- ^ 'Error' raised by 'fail_with'.
 104  |   Error_At     R.SourcePos [Error e] -- ^ 'Error' raised by 'runParserT_with_Error_fail'.
 105  deriving (Show)
 106
 107 instance Functor Error where
 108         fmap _ (Error_Parser e)     = Error_Parser e
 109         fmap f (Error_Custom pos e) = Error_Custom pos (f e)
 110         fmap f (Error_At pos es)    = Error_At pos $ map (fmap f) es
 111
 112 -- | Like 'R.parserFail'
 113 --   but fail with given custom error.
 114 fail_with :: (Stream s (Error_State e m) Char, Monad m)
 115  => String -> e -> ParsecT s u (Error_State e m) r
 116 fail_with msg err = do
 117         (sp, se) <- lift get
 118         rp <- R.getPosition -- NOTE: reported position
 119         _ <- ((R.anyChar >> return ()) <|> R.eof)
 120          -- NOTE: somehow commits that this character has an error
 121         p <- R.getPosition -- NOTE: compared position
 122         case () of
 123          _ | R.sourceLine   p  > R.sourceLine   sp ||
 124             (R.sourceLine   p == R.sourceLine   sp &&
 125              R.sourceColumn p  > R.sourceColumn sp)
 126            -> lift $ put (p, Error_Custom rp err:[])
 127          _ | R.sourceLine   p == R.sourceLine   sp &&
 128              R.sourceColumn p == R.sourceColumn sp
 129            -> lift $ put (p, Error_Custom rp err:se)
 130          _ -> return ()
 131         R.parserFail msg
 132
 133 -- | Like 'R.runParserT' but return as error an 'Error' list
 134 runParserT_with_Error
 135  :: (Stream s (Error_State e m) Char, Monad m, Show r, Show e)
 136  => ParsecT s u (Error_State e m) r
 137  -> u -> R.SourceName -> s
 138  -> m (Either [Error e] r)
 139 runParserT_with_Error p u sn s = do
 140         (r, (sp, se)) <- runStateT
 141          (R.runParserT p u sn s)
 142          (R.initialPos sn, [])
 143         case r of
 144          Left pe | R.sourceLine   (R.errorPos pe)  < R.sourceLine   sp ||
 145                   (R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 146                    R.sourceColumn (R.errorPos pe)  < R.sourceColumn sp)
 147                  -> return $ Left $ se -- NOTE: custom errors detected at a greater position
 148          Left pe | R.sourceLine   (R.errorPos pe) == R.sourceLine   sp &&
 149                    R.sourceColumn (R.errorPos pe) == R.sourceColumn sp
 150                  -> return $ Left $ se -- NOTE: prefer custom errors
 151          Left pe -> return $ Left $ Error_Parser pe:[]
 152          Right x -> return $ Right x
 153
 154 -- | Like 'R.runParserT_with_Error'
 155 --   but applied on the 'Identity' monad.
 156 runParser_with_Error
 157  :: (Stream s (Error_State e Identity) Char, Show r, Show e)
 158  => ParsecT s u (Error_State e Identity) r
 159  -> u -> R.SourceName -> s
 160  -> Either [Error e] r
 161 runParser_with_Error p u sn s =
 162         runIdentity $
 163         runParserT_with_Error p u sn s
 164
 165 -- | Like 'R.runParserT_with_Error'
 166 --   but propagate any failure to a calling 'ParsecT' monad.
 167 runParserT_with_Error_fail ::
 168  ( Stream s1 (Error_State ee m) Char
 169  , Stream s (Error_State e (ParsecT s1 u1 (Error_State ee m))) Char
 170  , Monad m, Show r, Show e, Show ee )
 171  => String
 172  -> (Error e -> Error ee)
 173  -> ParsecT s u (Error_State e (ParsecT s1 u1 (Error_State ee m))) r
 174  -> u -> R.SourceName -> s
 175  -> ParsecT s1 u1 (Error_State ee m) r
 176 runParserT_with_Error_fail msg map_ko p u sn s = do
 177         r <- runParserT_with_Error p u sn s
 178         case r of
 179          Right ok -> return ok
 180          Left ko -> do
 181                 rpos <- R.getPosition
 182                 _ <- commit_position
 183                 pos <- R.getPosition
 184                 lift $ put (pos, Error_At rpos (map map_ko ko):[])
 185                 fail msg
 186         where commit_position = (R.anyChar >> return ()) <|> R.eof
 187
 188 -- ** Mapping inner monad
 189
 190 -- | Like an instance Control.Functor.Morph.'MFunctor' of @R.ParsecT s u@
 191 --   but also requiring a second 'Monad' constraint
 192 --   on the returned base container.
 193 --
 194 -- NOTE: This code is not used by Hcompta, still is left here
 195 -- because it was not trivial to write it,
 196 -- so eventually it may help others.
 197
 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 = ((R.try (string "\r\n") <|> R.try (string "\n")) >> return ()) <?> "newline"