Utils.hs

{-# LANGUAGE Safe #-}
{- arch-tag: Parsec utilities
Copyright (c) 2004-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : Text.ParserCombinators.Parsec.Utils
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Written by John Goerzen, jgoerzen\@complete.org

-}

module Text.ParserCombinators.Parsec.Utils(-- * Generalized Utilities
                       -- | These functions are generalized versions of
                       -- ones you might see in the Char parser.
                       GeneralizedToken, GeneralizedTokenParser,
                       togtok, tokeng, satisfyg, oneOfg, noneOfg,
                       specificg, allg,
                       -- * Other Utilities
                       notMatching
                      ) where

import safe Text.ParserCombinators.Parsec
    ( (<?>),
      (<|>),
      getPosition,
      many,
      token,
      unexpected,
      try,
      SourcePos,
      GenParser )

type GeneralizedToken a = (SourcePos, a)
type GeneralizedTokenParser a st b = GenParser (GeneralizedToken a) st b

{- | Generate (return) a 'GeneralizedToken'. -}
togtok :: a -> GenParser b st (GeneralizedToken a)
togtok tok = do
              x <- getPosition
              return (x, tok)

{- | Retrieve the next token from a 'GeneralizedToken' stream.
   The given function should return the value to use, or Nothing
   to cause an error. -}
tokeng :: (Show a) => (a -> Maybe b) -> GeneralizedTokenParser a st b
tokeng test =
    token (show . snd) (fst) (test . snd)

{- | A shortcut to 'tokeng'; the test here is just a function that returns
a Bool.  If the result is true; return that value -- otherwise, an error.
-}
satisfyg :: (Show a) => (a -> Bool) -> GeneralizedTokenParser a st a
satisfyg test = tokeng (\t -> if test t then Just t else Nothing)

{- | Matches one item in a list and returns it. -}
oneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a
oneOfg i = satisfyg (\x -> elem x i)

{- | Matches all items and returns them -}
allg :: (Show a) => GeneralizedTokenParser a st [a]
allg = many $ satisfyg (\_ -> True)

{- | Matches one item not in a list and returns it. -}
noneOfg :: (Eq a, Show a) => [a] -> GeneralizedTokenParser a st a
noneOfg l = satisfyg (\x -> not (elem x l))

{- | Matches one specific token and returns it. -}
specificg :: (Eq a, Show a) => a -> GeneralizedTokenParser a st a
specificg i = satisfyg (== i) <?> show i

{- Matches a list of tokens and returns it. -}
{-
listg :: (Eq a, Show a) => [GeneralizedToken a] -> GeneralizedTokenParser a st [GeneralizedToken a]
listg l = tokens (show . map fst) nextpos l
          where
          tokpos = fst
          nextpos
          nextposs _ _ (tok:toks) = tokpos tok
          nextposs _ tok [] = tokpos tok
          nextpos pos x = nextposs pos [x]
-}

{- | Running @notMatching p msg@ will try to apply parser p.
If it fails, returns ().  If it succeds, cause a failure and raise
the given error message.  It will not consume input in either case. -}
notMatching :: GenParser a b c -> String -> GenParser a b ()
notMatching p errormsg =
    let maybeRead = try (do
                         x <- p
                         return (Just x)
                        )
                    <|> return Nothing
        workerFunc =  do
                      x <- maybeRead
                      case x of
                             Nothing -> return ()
                             Just _  -> unexpected errormsg
        in
        try workerFunc