{-# LANGUAGE GADTs               #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Parsec.Class (
    Parsec(..),
    ParsecParser (..),
    runParsecParser,
    simpleParsec,
    lexemeParsec,
    eitherParsec,
    explicitEitherParsec,
    -- * CabalParsing & warnings
    CabalParsing (..),
    PWarnType (..),
    -- * Utilities
    parsecToken,
    parsecToken',
    parsecFilePath,
    parsecQuoted,
    parsecMaybeQuoted,
    parsecCommaList,
    parsecLeadingCommaList,
    parsecOptCommaList,
    parsecStandard,
    parsecUnqualComponentName,
    ) where

import Data.Char                     (digitToInt, intToDigit)
import Data.Functor.Identity         (Identity (..))
import Data.List                     (transpose)
import Distribution.CabalSpecVersion
import Distribution.Compat.Prelude
import Distribution.Parsec.FieldLineStream
import Distribution.Parsec.Common    (PWarnType (..), PWarning (..), Position (..))
import Numeric                       (showIntAtBase)
import Prelude ()

import qualified Distribution.Compat.CharParsing as P
import qualified Distribution.Compat.MonadFail   as Fail
import qualified Distribution.Compat.ReadP       as ReadP
import qualified Text.Parsec                     as Parsec

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

-- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields.
class Parsec a where
    parsec :: CabalParsing m => m a

-- | Parsing class which
--
-- * can report Cabal parser warnings.
--
-- * knows @cabal-version@ we work with
--
class (P.CharParsing m, MonadPlus m) => CabalParsing m where
    parsecWarning :: PWarnType -> String -> m ()

    parsecHaskellString :: m String
    parsecHaskellString = stringLiteral

    askCabalSpecVersion :: m CabalSpecVersion

instance t ~ Char => CabalParsing (ReadP.Parser r t) where
    parsecWarning _ _   = pure ()
    askCabalSpecVersion = pure cabalSpecLatest

-- | 'parsec' /could/ consume trailing spaces, this function /will/ consume.
lexemeParsec :: (CabalParsing m, Parsec a) => m a
lexemeParsec = parsec <* P.spaces

newtype ParsecParser a = PP { unPP
    :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a
    }

liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a
liftParsec p = PP $ \_ -> p

instance Functor ParsecParser where
    fmap f p = PP $ \v -> fmap f (unPP p v)
    {-# INLINE fmap #-}

    x <$ p = PP $ \v -> x <$ unPP p v
    {-# INLINE (<$) #-}

instance Applicative ParsecParser where
    pure = liftParsec . pure
    {-# INLINE pure #-}

    f <*> x = PP $ \v -> unPP f v <*> unPP x v
    {-# INLINE (<*>) #-}
    f  *> x = PP $ \v -> unPP f v  *> unPP x v
    {-# INLINE (*>) #-}
    f <*  x = PP $ \v -> unPP f v <*  unPP x v
    {-# INLINE (<*) #-}

instance Alternative ParsecParser where
    empty = liftParsec empty

    a <|> b = PP $ \v -> unPP a v <|> unPP b v
    {-# INLINE (<|>) #-}

    many p = PP $ \v -> many (unPP p v)
    {-# INLINE many #-}

    some p = PP $ \v -> some (unPP p v)
    {-# INLINE some #-}

instance Monad ParsecParser where
    return = pure

    m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v
    {-# INLINE (>>=) #-}
    (>>) = (*>)
    {-# INLINE (>>) #-}

    fail = Fail.fail

instance MonadPlus ParsecParser where
    mzero = empty
    mplus = (<|>)

instance Fail.MonadFail ParsecParser where
    fail = P.unexpected

instance P.Parsing ParsecParser where
    try p           = PP $ \v -> P.try (unPP p v)
    p <?> d         = PP $ \v -> unPP p v P.<?> d
    skipMany p      = PP $ \v -> P.skipMany (unPP p v)
    skipSome p      = PP $ \v -> P.skipSome (unPP p v)
    unexpected      = liftParsec . P.unexpected
    eof             = liftParsec P.eof
    notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v)

instance P.CharParsing ParsecParser where
    satisfy   = liftParsec . P.satisfy
    char      = liftParsec . P.char
    notChar   = liftParsec . P.notChar
    anyChar   = liftParsec P.anyChar
    string    = liftParsec . P.string

instance CabalParsing ParsecParser where
    parsecWarning t w = liftParsec $ Parsec.modifyState (PWarning t (Position 0 0) w :)
    askCabalSpecVersion = PP pure

-- | Parse a 'String' with 'lexemeParsec'.
simpleParsec :: Parsec a => String -> Maybe a
simpleParsec
    = either (const Nothing) Just
    . runParsecParser lexemeParsec "<simpleParsec>"
    . fieldLineStreamFromString

-- | Parse a 'String' with 'lexemeParsec'.
eitherParsec :: Parsec a => String -> Either String a
eitherParsec = explicitEitherParsec parsec

-- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted.
explicitEitherParsec :: ParsecParser a -> String -> Either String a
explicitEitherParsec parser
    = either (Left . show) Right
    . runParsecParser (parser <* P.spaces) "<eitherParsec>"
    . fieldLineStreamFromString

-- | Run 'ParsecParser' with 'cabalSpecLatest'.
runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a
runParsecParser p n = Parsec.runParser (unPP p cabalSpecLatest <* P.eof) [] n

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 :: CabalParsing m => m String
parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',')  P.<?> "identifier" ) >>= checkNotDoubleDash)

-- | @[^ ]@
parsecToken' :: CabalParsing m => m String
parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P.<?> "token") >>= checkNotDoubleDash)

checkNotDoubleDash ::  CabalParsing m => String -> m String
checkNotDoubleDash s = do
    when (s == "--") $ parsecWarning PWTDoubleDash $ unwords
        [ "Double-dash token found."
        , "Note: there are no end-of-line comments in .cabal files, only whole line comments."
        , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token"
        ]

    return s

parsecFilePath :: CabalParsing m => m FilePath
parsecFilePath = parsecToken

-- | Parse a benchmark/test-suite types.
parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m 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 :: CabalParsing m => m a -> m [a]
parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")

-- | Like 'parsecCommaList' but accept leading or trailing comma.
--
-- @
-- p (comma p)*  -- p `sepBy` comma
-- (comma p)*    -- leading comma
-- (p comma)*    -- trailing comma
-- @
parsecLeadingCommaList :: CabalParsing m => m a -> m [a]
parsecLeadingCommaList p = do
    c <- P.optional comma
    case c of
        Nothing -> P.sepEndBy1 lp comma <|> pure []
        Just _  -> P.sepBy1 lp comma
  where
    lp = p <* P.spaces
    comma = P.char ',' *> P.spaces P.<?> "comma"

parsecOptCommaList :: CabalParsing m => m a -> m [a]
parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)
  where
    comma = P.char ',' *>  P.spaces

-- | Content isn't unquoted
parsecQuoted :: CabalParsing m => m a -> m a
parsecQuoted = P.between (P.char '"') (P.char '"')

-- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@.
parsecMaybeQuoted :: CabalParsing m => m a -> m a
parsecMaybeQuoted p = parsecQuoted p <|> p

parsecUnqualComponentName :: CabalParsing m => m String
parsecUnqualComponentName = intercalate "-" <$> P.sepBy1 component (P.char '-')
  where
    component :: CabalParsing m => m String
    component = do
      cs <- P.munch1 isAlphaNum
      if all isDigit cs
        then fail "all digits in portion of unqualified component name"
        else return cs

stringLiteral :: forall m. P.CharParsing m => m String
stringLiteral = lit where
    lit :: m String
    lit = foldr (maybe id (:)) ""
        <$> P.between (P.char '"') (P.char '"' P.<?> "end of string") (many stringChar)
        P.<?> "string"

    stringChar :: m (Maybe Char)
    stringChar = Just <$> stringLetter
         <|> stringEscape
         P.<?> "string character"

    stringLetter :: m Char
    stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))

    stringEscape :: m (Maybe Char)
    stringEscape = P.char '\\' *> esc where
        esc :: m (Maybe Char)
        esc = Nothing <$ escapeGap
            <|> Nothing <$ escapeEmpty
            <|> Just <$> escapeCode

    escapeEmpty, escapeGap :: m Char
    escapeEmpty = P.char '&'
    escapeGap = P.skipSpaces1 *> (P.char '\\' P.<?> "end of string gap")

escapeCode :: forall m. P.CharParsing m => m Char
escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P.<?> "escape code"
  where
  charControl, charNum :: m Char
  charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@'))
  charNum = toEnum <$> num
    where
      num :: m Int
      num = bounded 10 maxchar
        <|> (P.char 'o' *> bounded 8 maxchar)
        <|> (P.char 'x' *> bounded 16 maxchar)
      maxchar = fromEnum (maxBound :: Char)

  bounded :: Int -> Int -> m Int
  bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0
                 <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "")
    where
      thedigits :: [m Char]
      thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']])

      toomuch :: m a
      toomuch = P.unexpected "out-of-range numeric escape sequence"

      bounded', bounded'' :: [m Char] -> [Int] -> m [Char]
      bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds)
                              <|> bounded'' dps bds
      bounded' []           _   = error "bounded called with base 0"
      bounded'' dps []         = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch
      bounded'' dps (bd : bds) = let anyd :: m Char
                                     anyd = P.choice dps

                                     nomore :: m ()
                                     nomore = P.notFollowedBy anyd <|> toomuch

                                     (low, ex : high) = splitAt bd dps
                                  in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore
                                     <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))
                                     <|> if not (null bds)
                                            then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore
                                            else empty
      atMost n p | n <= 0    = pure []
                 | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure []

  charEsc :: m Char
  charEsc = P.choice $ parseEsc <$> escMap

  parseEsc (c,code) = code <$ P.char c
  escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"

  charAscii :: m Char
  charAscii = P.choice $ parseAscii <$> asciiMap

  parseAscii (asc,code) = P.try $ code <$ P.string asc
  asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
  ascii2codes, ascii3codes :: [String]
  ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO"
                , "SI","EM","FS","GS","RS","US","SP"]
  ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK"
                ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK"
                ,"SYN","ETB","CAN","SUB","ESC","DEL"]
  ascii2, ascii3 :: String
  ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP"
  ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"