Distribution/Parsec/Class.hs

    {-# LANGUAGE RankNTypes, FlexibleContexts #-}
    module Distribution.Parsec.Class (
        Parsec(..),
        ParsecParser,
        simpleParsec,
        -- * Warnings
        parsecWarning,
        PWarnType (..),
        -- * Utilities
        parsecToken,
        parsecToken',
        parsecFilePath,
        parsecQuoted,
        parsecMaybeQuoted,
        parsecCommaList,
        parsecOptCommaList,
        parsecStandard,
        parsecUnqualComponentName,
        ) where

    import           Data.Functor.Identity       (Identity (..))
    import qualified Distribution.Compat.Parsec  as P
    import           Distribution.Compat.Prelude
    import           Distribution.Parsec.Common  (PWarnType (..), PWarning (..), Position (..))
    import           Prelude ()
    import qualified Text.Parsec                 as Parsec
    import qualified Text.Parsec.Language        as Parsec
    import qualified Text.Parsec.Token           as Parsec

    -------------------------------------------------------------------------------
    -- Class
    -------------------------------------------------------------------------------

    -- |
    --
    -- TODO: implementation details: should be careful about consuming
    -- trailing whitespace?
    -- Should we always consume it?
    class Parsec a where
        parsec :: ParsecParser a

        -- | 'parsec' /could/ consume trailing spaces, this function /must/ consume.
        lexemeParsec :: ParsecParser a
        lexemeParsec = parsec <* P.spaces

    type ParsecParser a = forall s. P.Stream s Identity Char => P.Parsec s [PWarning] a

    -- | Parse a 'String' with 'lexemeParsec'.
    simpleParsec :: Parsec a => String -> Maybe a
    simpleParsec
        = either (const Nothing) Just
        . P.runParser (lexemeParsec <* P.eof) [] "<simpleParsec>"

    parsecWarning :: PWarnType -> String -> P.Parsec s [PWarning] ()
    parsecWarning t w =
        Parsec.modifyState (PWarning t (Position 0 0) w :)

    instance Parsec a => Parsec (Identity a) where
        parsec = Identity <$> parsec

    instance Parsec Bool where
        parsec = P.munch1 isAlpha >>= postprocess
          where
            postprocess str
                |  str == "True"  = pure True
                |  str == "False" = pure False
                | lstr == "true"  = parsecWarning PWTBoolCase caseWarning *> pure True
                | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False
                | otherwise       = fail $ "Not a boolean: " ++ str
              where
                lstr = map toLower str
                caseWarning =
                    "Boolean values are case sensitive, use 'True' or 'False'."

    -- | @[^ ,]@
    parsecToken :: P.Stream s Identity Char => P.Parsec s [PWarning] String
    parsecToken = parsecHaskellString <|> (P.munch1 (\x -> not (isSpace x) && x /= ',')  P.<?> "identifier" )

    -- | @[^ ]@
    parsecToken' :: P.Stream s Identity Char => P.Parsec s [PWarning] String
    parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P.<?> "token")

    parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] FilePath
    parsecFilePath = parsecToken

    -- | Parse a benchmark/test-suite types.
    parsecStandard
        :: (Parsec ver, P.Stream s Identity Char)
        => (ver -> String -> a)
        -> P.Parsec s [PWarning] a
    parsecStandard f = do
        cs   <- some $ P.try (component <* P.char '-')
        ver  <- parsec
        let name = map toLower (intercalate "-" cs)
        return $! f ver name
      where
        component = do
          cs <- P.munch1 isAlphaNum
          if all isDigit cs then fail "all digit component" else return cs
          -- each component must contain an alphabetic character, to avoid
          -- ambiguity in identifiers like foo-1 (the 1 is the version number).

    parsecCommaList
        :: P.Stream s Identity Char
        => P.Parsec s [PWarning] a
        -> P.Parsec s [PWarning] [a]
    parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces)

    parsecOptCommaList
        :: P.Stream s Identity Char
        => P.Parsec s [PWarning] a
        -> P.Parsec s [PWarning] [a]
    parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)
      where
        comma = P.char ',' *>  P.spaces

    -- | Content isn't unquoted
    parsecQuoted
         :: P.Stream s Identity Char
         => P.Parsec s [PWarning] a
         -> P.Parsec s [PWarning] a
    parsecQuoted = P.between (P.char '"') (P.char '"')

    -- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@.
    parsecMaybeQuoted
         :: P.Stream s Identity Char
         => P.Parsec s [PWarning] a
         -> P.Parsec s [PWarning] a
    parsecMaybeQuoted p = parsecQuoted p <|> p

    parsecHaskellString :: P.Stream s Identity Char => P.Parsec s [PWarning] String
    parsecHaskellString = Parsec.stringLiteral $ Parsec.makeTokenParser Parsec.emptyDef
        { Parsec.commentStart   = "{-"
        , Parsec.commentEnd     = "-}"
        , Parsec.commentLine    = "--"
        , Parsec.nestedComments = True
        , Parsec.identStart     = P.satisfy isAlphaNum
        , Parsec.identLetter    = P.satisfy isAlphaNum <|> P.oneOf "_'"
        , Parsec.opStart        = opl
        , Parsec.opLetter       = opl
        , Parsec.reservedOpNames= []
        , Parsec.reservedNames  = []
        , Parsec.caseSensitive  = True
        }
      where
        opl = P.oneOf ":!#$%&*+./<=>?@\\^|-~"

    parsecUnqualComponentName :: P.Stream s Identity Char => P.Parsec s [PWarning] String
    parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-')
      where
        component :: P.Stream s Identity Char => P.Parsec s [PWarning] String
        component = do
          cs <- P.munch1 isAlphaNum
          if all isDigit cs
            then fail "all digits in portion of unqualified component name"
            else return cs