{-# LANGUAGE FlexibleContexts #-}
module Distribution.Parsec.Class (
    Parsec(..),
    -- * Warnings
    parsecWarning,
    -- * Utilities
    parsecTestedWith,
    parsecToken,
    parsecToken',
    parsecFilePath,
    parsecQuoted,
    parsecMaybeQuoted,
    parsecCommaList,
    parsecOptCommaList,
    ) where

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

-- Instances

import           Distribution.Compiler
                 (CompilerFlavor (..), classifyCompilerFlavor)
import           Distribution.License                         (License (..))
import           Distribution.ModuleName                      (ModuleName)
import qualified Distribution.ModuleName                      as ModuleName
import           Distribution.System
                 (Arch (..), ClassificationStrictness (..), OS (..),
                 classifyArch, classifyOS)
import           Distribution.Text                            (display)
import           Distribution.Types.BenchmarkType
                 (BenchmarkType (..))
import           Distribution.Types.BuildType                 (BuildType (..))
import           Distribution.Types.Dependency                (Dependency (..))
import           Distribution.Types.ExeDependency             (ExeDependency (..))
import           Distribution.Types.LegacyExeDependency       (LegacyExeDependency (..))
import           Distribution.Types.PkgconfigDependency       (PkgconfigDependency (..))
import           Distribution.Types.PkgconfigName
                 (PkgconfigName, mkPkgconfigName)
import           Distribution.Types.GenericPackageDescription (FlagName, mkFlagName)
import           Distribution.Types.ModuleReexport
                 (ModuleReexport (..))
import           Distribution.Types.SourceRepo
                 (RepoKind, RepoType, classifyRepoKind, classifyRepoType)
import           Distribution.Types.TestType                  (TestType (..))
import           Distribution.Types.ForeignLib                (LibVersionInfo, mkLibVersionInfo)
import           Distribution.Types.ForeignLibType            (ForeignLibType (..))
import           Distribution.Types.ForeignLibOption          (ForeignLibOption (..))
import           Distribution.Types.ModuleRenaming
import           Distribution.Types.IncludeRenaming
import           Distribution.Types.Mixin
import           Distribution.Types.PackageName
                 (PackageName, mkPackageName)
import           Distribution.Types.UnqualComponentName
                 (UnqualComponentName, mkUnqualComponentName)
import           Distribution.Types.ExecutableScope
import           Distribution.Version
                 (Version, VersionRange (..), anyVersion, earlierVersion,
                 intersectVersionRanges, laterVersion, majorBoundVersion,
                 mkVersion, noVersion, orEarlierVersion, orLaterVersion,
                 thisVersion, unionVersionRanges, withinVersion)
import           Language.Haskell.Extension
                 (Extension, Language, classifyExtension, classifyLanguage)

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

-- |
--
-- TODO: implementation details: should be careful about consuming trailing whitespace?
-- Should we always consume it?
class Parsec a where
    parsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a

    -- | 'parsec' /could/ consume trailing spaces, this function /must/ consume.
    lexemeParsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a
    lexemeParsec = parsec <* P.spaces

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

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

-- TODO: use lexemeParsec

-- TODO avoid String
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

instance Parsec UnqualComponentName where
  parsec = mkUnqualComponentName <$> parsecUnqualComponentName

instance Parsec PackageName where
  parsec = mkPackageName <$> parsecUnqualComponentName

instance Parsec PkgconfigName where
  parsec = mkPkgconfigName <$> P.munch1 (\c -> isAlphaNum c || c `elem` "+-._")

instance Parsec ModuleName where
    parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.')
      where
        component = do
            c  <- P.satisfy isUpper
            cs <- P.munch validModuleChar
            return (c:cs)

        validModuleChar :: Char -> Bool
        validModuleChar c = isAlphaNum c || c == '_' || c == '\''

instance Parsec FlagName where
    parsec = mkFlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-')
      where
        -- http://hackage.haskell.org/package/cabal-debian-4.24.8/cabal-debian.cabal
        -- has flag with all digit component: pretty-112
        component :: P.Stream s Identity Char => P.Parsec s [PWarning] String
        component = P.munch1 (\c -> isAlphaNum c || c `elem` "_")

instance Parsec Dependency where
    parsec = do
        name <- lexemeParsec
        ver  <- parsec <|> pure anyVersion
        return (Dependency name ver)

instance Parsec ExeDependency where
    parsec = do
        name <- lexemeParsec
        _    <- P.char ':'
        exe  <- lexemeParsec
        ver  <- parsec <|> pure anyVersion
        return (ExeDependency name exe ver)

instance Parsec LegacyExeDependency where
    parsec = do
        name <- parsecMaybeQuoted nameP
        P.spaces
        verRange <- parsecMaybeQuoted parsec <|> pure anyVersion
        pure $ LegacyExeDependency name verRange
      where
        nameP = intercalate "-" <$> P.sepBy1 component (P.char '-')
        component = do
            cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
            if all isDigit cs then fail "invalid component" else return cs

instance Parsec PkgconfigDependency where
    parsec = do
        name <- parsec
        P.spaces
        verRange <- parsec <|> pure anyVersion
        pure $ PkgconfigDependency name verRange

instance Parsec Version where
    parsec = mkVersion <$>
        P.sepBy1 P.integral (P.char '.')
        <* tags
      where
        tags = do
            ts <- P.optionMaybe $ some $ P.char '-' *> some (P.satisfy isAlphaNum)
            case ts of
                Nothing -> pure ()
                -- TODO: make this warning severe
                Just _  -> parsecWarning PWTVersionTag "version with tags"

-- TODO: this is not good parsec code
-- use lexer, also see D.P.ConfVar
instance Parsec VersionRange where
    parsec = expr
      where
        expr   = do P.spaces
                    t <- term
                    P.spaces
                    (do _  <- P.string "||"
                        P.spaces
                        e <- expr
                        return (unionVersionRanges t e)
                     <|>
                     return t)
        term   = do f <- factor
                    P.spaces
                    (do _  <- P.string "&&"
                        P.spaces
                        t <- term
                        return (intersectVersionRanges f t)
                     <|>
                     return f)
        factor = P.choice
            $ parens expr
            : parseAnyVersion
            : parseNoVersion
            : parseWildcardRange
            : map parseRangeOp rangeOps
        parseAnyVersion    = P.string "-any" >> return anyVersion
        parseNoVersion     = P.string "-none" >> return noVersion

        parseWildcardRange = P.try $ do
          _ <- P.string "=="
          P.spaces
          branch <- some (P.integral <* P.char '.')
          _ <- P.char '*'
          return (withinVersion (mkVersion branch))

        parens p = P.between
            (P.char '(' >> P.spaces)
            (P.char ')' >> P.spaces)
            (do a <- p
                P.spaces
                return (VersionRangeParens a))

        -- TODO: make those non back-tracking
        parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec)
        rangeOps = [ ("<",  earlierVersion),
                     ("<=", orEarlierVersion),
                     (">",  laterVersion),
                     (">=", orLaterVersion),
                     ("^>=", majorBoundVersion),
                     ("==", thisVersion) ]

instance Parsec LibVersionInfo where
    parsec = do
        c <- P.integral
        (r, a) <- P.option (0,0) $ do
            _ <- P.char ':'
            r <- P.integral
            a <- P.option 0 $ do
                _ <- P.char ':'
                P.integral
            return (r,a)
        return $ mkLibVersionInfo (c,r,a)

instance Parsec Language where
    parsec = classifyLanguage <$> P.munch1 isAlphaNum

instance Parsec Extension where
    parsec = classifyExtension <$> P.munch1 isAlphaNum

instance Parsec RepoType where
    parsec = classifyRepoType <$> P.munch1 isIdent

instance Parsec RepoKind where
    parsec = classifyRepoKind <$> P.munch1 isIdent

instance Parsec License where
  parsec = do
    name    <- P.munch1 isAlphaNum
    version <- P.optionMaybe (P.char '-' *> parsec)
    return $! case (name, version :: Maybe Version) of
      ("GPL",               _      ) -> GPL  version
      ("LGPL",              _      ) -> LGPL version
      ("AGPL",              _      ) -> AGPL version
      ("BSD2",              Nothing) -> BSD2
      ("BSD3",              Nothing) -> BSD3
      ("BSD4",              Nothing) -> BSD4
      ("ISC",               Nothing) -> ISC
      ("MIT",               Nothing) -> MIT
      ("MPL",         Just version') -> MPL version'
      ("Apache",            _      ) -> Apache version
      ("PublicDomain",      Nothing) -> PublicDomain
      ("AllRightsReserved", Nothing) -> AllRightsReserved
      ("OtherLicense",      Nothing) -> OtherLicense
      _                              -> UnknownLicense $ name ++
                                        maybe "" (('-':) . display) version

instance Parsec BuildType where
  parsec = do
    name <- P.munch1 isAlphaNum
    return $ case name of
      "Simple"    -> Simple
      "Configure" -> Configure
      "Custom"    -> Custom
      "Make"      -> Make
      _           -> UnknownBuildType name

instance Parsec TestType where
  parsec = stdParse $ \ver name -> case name of
      "exitcode-stdio" -> TestTypeExe ver
      "detailed"       -> TestTypeLib ver
      _                -> TestTypeUnknown name ver

instance Parsec BenchmarkType where
    parsec = stdParse $ \ver name -> case name of
       "exitcode-stdio" -> BenchmarkTypeExe ver
       _                -> BenchmarkTypeUnknown name ver

instance Parsec ForeignLibType where
  parsec = do
    name <- P.munch1 (\c -> isAlphaNum c || c == '-')
    return $ case name of
      "native-shared" -> ForeignLibNativeShared
      "native-static" -> ForeignLibNativeStatic
      _               -> ForeignLibTypeUnknown

instance Parsec ForeignLibOption where
  parsec = do
    name <- P.munch1 (\c -> isAlphaNum c || c == '-')
    case name of
      "standalone" -> return ForeignLibStandalone
      _            -> fail "unrecognized foreign-library option"

instance Parsec OS where
    parsec = classifyOS Compat <$> parsecIdent

instance Parsec Arch where
    parsec = classifyArch Strict <$> parsecIdent

instance Parsec CompilerFlavor where
    parsec = classifyCompilerFlavor <$> component
      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 compiler name" else return cs

instance Parsec ModuleReexport where
    parsec = do
        mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':')
        origname <- parsec
        newname  <- P.option origname $ P.try $ do
            P.spaces
            _ <- P.string "as"
            P.spaces
            parsec
        return (ModuleReexport mpkgname origname newname)

instance Parsec ModuleRenaming where
    -- NB: try not necessary as the first token is obvious
    parsec = P.choice [ parseRename, parseHiding, return DefaultRenaming ]
      where
        parseRename = do
            rns <- P.between (P.char '(') (P.char ')') parseList
            P.spaces
            return (ModuleRenaming rns)
        parseHiding = do
            _ <- P.string "hiding"
            P.spaces
            hides <- P.between (P.char '(') (P.char ')')
                        (P.sepBy parsec (P.char ',' >> P.spaces))
            return (HidingRenaming hides)
        parseList =
            P.sepBy parseEntry (P.char ',' >> P.spaces)
        parseEntry = do
            orig <- parsec
            P.spaces
            P.option (orig, orig) $ do
                _ <- P.string "as"
                P.spaces
                new <- parsec
                P.spaces
                return (orig, new)

instance Parsec IncludeRenaming where
    parsec = do
        prov_rn <- parsec
        req_rn <- P.option defaultRenaming $ P.try $ do
            P.spaces
            _ <- P.string "requires"
            P.spaces
            parsec
        return (IncludeRenaming prov_rn req_rn)

instance Parsec Mixin where
    parsec = do
        mod_name <- parsec
        P.spaces
        incl <- parsec
        return (Mixin mod_name incl)

instance Parsec ExecutableScope where
  parsec = do
    name <- P.munch1 (\c -> isAlphaNum c || c == '-')
    return $ case name of
      "public"  -> ExecutablePublic
      "private" -> ExecutablePrivate
      _         -> ExecutableScopeUnknown

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

isIdent :: Char -> Bool
isIdent c = isAlphaNum c || c == '_' || c == '-'

parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange)
parsecTestedWith = do
    name <- lexemeParsec
    ver  <- parsec <|> pure anyVersion
    return (name, ver)

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] String
parsecFilePath = parsecToken

-- | Parse a benchmark/test-suite types.
stdParse
    :: P.Stream s Identity Char
    => (Version -> String -> a)
    -> P.Parsec s [PWarning] a
stdParse f = do
    -- TODO: this backtracks
    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 ":!#$%&*+./<=>?@\\^|-~"

parsecIdent :: P.Stream s Identity Char => P.Parsec s [PWarning] String
parsecIdent = (:) <$> firstChar <*> rest
  where
    firstChar = P.satisfy isAlpha
    rest      = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')