{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Deprecated.Text
-- Copyright   :  Duncan Coutts 2007
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- classes. The difference is that it uses a modern pretty printer and parser
-- system and the format is not expected to be Haskell concrete syntax but
-- rather the external human readable representation used by Cabal.
--
module Distribution.Deprecated.Text (
  Text(..),
  defaultStyle,
  display,
  flatStyle,
  simpleParse,
  stdParse,
  -- parse utils
  parsePackageName,
  ) where

import Distribution.Client.Compat.Prelude
import Prelude (read)

import           Distribution.Deprecated.ReadP ((<++))
import qualified Distribution.Deprecated.ReadP as Parse

import           Distribution.Parsec
import           Distribution.Pretty
import qualified Text.PrettyPrint          as Disp

import qualified Data.Set as Set

import Data.Version (Version (Version))

import qualified Distribution.Compiler                       as D
import qualified Distribution.License                        as D
import qualified Distribution.ModuleName                     as D
import qualified Distribution.Package                        as D
import qualified Distribution.PackageDescription             as D
import qualified Distribution.Simple.Setup                   as D
import qualified Distribution.System                         as D
import qualified Distribution.Types.PackageVersionConstraint as D
import qualified Distribution.Types.SourceRepo               as D
import qualified Distribution.Types.UnqualComponentName      as D
import qualified Distribution.Version                        as D
import qualified Distribution.Types.VersionRange.Internal    as D
import qualified Language.Haskell.Extension                  as E

-- | /Note:/ this class will soon be deprecated.
-- It's not yet, so that we are @-Wall@ clean.
class Text a where
  disp  :: a -> Disp.Doc
  default disp :: Pretty a => a -> Disp.Doc
  disp = pretty

  parse :: Parse.ReadP r a
  default parse :: Parsec a => Parse.ReadP r a
  parse = parsec

-- | Pretty-prints with the default style.
display :: Text a => a -> String
display = Disp.renderStyle defaultStyle . disp

simpleParse :: Text a => String -> Maybe a
simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str
                       , all isSpace s ] of
  []    -> Nothing
  (p:_) -> Just p

stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res
stdParse f = do
  cs   <- Parse.sepBy1 component (Parse.char '-')
  _    <- Parse.char '-'
  ver  <- parse
  let name = intercalate "-" cs
  return $! f ver (lowercase name)
  where
    component = do
      cs <- Parse.munch1 isAlphaNum
      if all isDigit cs then Parse.pfail else return cs
      -- each component must contain an alphabetic character, to avoid
      -- ambiguity in identifiers like foo-1 (the 1 is the version number).

lowercase :: String -> String
lowercase = map toLower

-- -----------------------------------------------------------------------------
-- Instances for types from the base package

instance Text Bool where
  parse = Parse.choice [ (Parse.string "True" Parse.+++
                          Parse.string "true") >> return True
                       , (Parse.string "False" Parse.+++
                          Parse.string "false") >> return False ]

instance Text Int where
  parse = fmap negate (Parse.char '-' >> parseNat) Parse.+++ parseNat

instance Text a => Text (Identity a) where
    disp = disp . runIdentity
    parse = fmap Identity parse

-- | Parser for non-negative integers.
parseNat :: Parse.ReadP r Int
parseNat = read `fmap` Parse.munch1 isDigit -- TODO: eradicateNoParse


instance Text Version where
  disp (Version branch _tags)     -- Death to version tags!!
    = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch))

  parse = do
      branch <- Parse.sepBy1 parseNat (Parse.char '.')
                -- allow but ignore tags:
      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)
      return (Version branch [])

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

instance Text D.Arch where
  parse = fmap (D.classifyArch D.Strict) ident

instance Text D.BuildType where
  parse = do
    name <- Parse.munch1 isAlphaNum
    case name of
      "Simple"    -> return D.Simple
      "Configure" -> return D.Configure
      "Custom"    -> return D.Custom
      "Make"      -> return D.Make
      "Default"   -> return D.Custom
      _           -> fail ("unknown build-type: '" ++ name ++ "'")

instance Text D.CompilerFlavor where
  parse = do
    comp <- Parse.munch1 isAlphaNum
    when (all isDigit comp) Parse.pfail
    return (D.classifyCompilerFlavor comp)

instance Text D.CompilerId where
  parse = do
    flavour <- parse
    version <- (Parse.char '-' >> parse) Parse.<++ return D.nullVersion
    return (D.CompilerId flavour version)

instance Text D.ComponentId where
  parse = D.mkComponentId `fmap` Parse.munch1 abi_char
   where abi_char c = isAlphaNum c || c `elem` "-_."

instance Text D.DefUnitId where
  parse = D.unsafeMkDefUnitId `fmap` parse

instance Text D.UnitId where
    parse = D.mkUnitId <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+")

instance Text D.Dependency where
  parse = do name <- parse
             Parse.skipSpaces
             libs <- Parse.option [D.LMainLibName]
                   $ (Parse.char ':' *>)
                   $ pure <$> parseLib name <|> parseMultipleLibs name
             Parse.skipSpaces
             ver <- parse Parse.<++ return D.anyVersion
             Parse.skipSpaces
             return $ D.Dependency name ver $ Set.fromList libs
    where makeLib pn ln | D.unPackageName pn == ln = D.LMainLibName
                        | otherwise = D.LSubLibName $ D.mkUnqualComponentName ln
          parseLib pn = makeLib pn <$> parsecUnqualComponentName
          parseMultipleLibs pn = Parse.between (Parse.char '{' *> Parse.skipSpaces)
                                         (Parse.skipSpaces <* Parse.char '}')
                                         $ parsecCommaList $ parseLib pn


instance Text E.Extension where
  parse = do
    extension <- Parse.munch1 isAlphaNum
    return (E.classifyExtension extension)

instance Text D.FlagName where
    -- Note:  we don't check that FlagName doesn't have leading dash,
    -- cabal check will do that.
    parse = D.mkFlagName . lowercase <$> parse'
      where
        parse' = (:) <$> lead <*> rest
        lead = Parse.satisfy (\c ->  isAlphaNum c || c == '_')
        rest = Parse.munch (\c -> isAlphaNum c ||  c == '_' || c == '-')

instance Text D.HaddockTarget where
    parse = Parse.choice [ Parse.string "for-hackage"     >> return D.ForHackage
                         , Parse.string "for-development" >> return D.ForDevelopment]

instance Text E.Language where
  parse = do
    lang <- Parse.munch1 isAlphaNum
    return (E.classifyLanguage lang)

instance Text D.License where
  parse = do
    name    <- Parse.munch1 (\c -> isAlphaNum c && c /= '-')
    version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
    return $! case (name, version :: Maybe D.Version) of
      ("GPL",               _      ) -> D.GPL  version
      ("LGPL",              _      ) -> D.LGPL version
      ("AGPL",              _      ) -> D.AGPL version
      ("BSD2",              Nothing) -> D.BSD2
      ("BSD3",              Nothing) -> D.BSD3
      ("BSD4",              Nothing) -> D.BSD4
      ("ISC",               Nothing) -> D.ISC
      ("MIT",               Nothing) -> D.MIT
      ("MPL",         Just version') -> D.MPL version'
      ("Apache",            _      ) -> D.Apache version
      ("PublicDomain",      Nothing) -> D.PublicDomain
      ("AllRightsReserved", Nothing) -> D.AllRightsReserved
      ("OtherLicense",      Nothing) -> D.OtherLicense
      _                              -> D.UnknownLicense $ name ++
                                        maybe "" (('-':) . display) version

instance Text D.Module where
    parse = do
        uid <- parse
        _ <- Parse.char ':'
        mod_name <- parse
        return (D.Module uid mod_name)

instance Text D.ModuleName where
  parse = do
    ms <- Parse.sepBy1 component (Parse.char '.')
    return (D.fromComponents ms)

    where
      component = do
        c  <- Parse.satisfy isUpper
        cs <- Parse.munch validModuleChar
        return (c:cs)

instance Text D.OS where
  parse = fmap (D.classifyOS D.Compat) ident

instance Text D.PackageVersionConstraint where
  parse = do name <- parse
             Parse.skipSpaces
             ver <- parse Parse.<++ return D.anyVersion
             Parse.skipSpaces
             return (D.PackageVersionConstraint name ver)

instance Text D.PkgconfigName where
  parse = D.mkPkgconfigName
          <$> Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-._")

instance Text D.Platform where
  -- TODO: there are ambigious platforms like: `arch-word-os`
  -- which could be parsed as
  --   * Platform "arch-word" "os"
  --   * Platform "arch" "word-os"
  -- We could support that preferring variants 'OtherOS' or 'OtherArch'
  --
  -- For now we split into arch and os parts on the first dash.
  parse = do
    arch <- parseDashlessArch
    _ <- Parse.char '-'
    os   <- parse
    return (D.Platform arch os)
      where
        parseDashlessArch :: Parse.ReadP r D.Arch
        parseDashlessArch = fmap (D.classifyArch D.Strict) dashlessIdent

        dashlessIdent :: Parse.ReadP r String
        dashlessIdent = liftM2 (:) firstChar rest
          where firstChar = Parse.satisfy isAlpha
                rest = Parse.munch (\c -> isAlphaNum c || c == '_')

instance Text D.RepoKind where
  parse = fmap D.classifyRepoKind ident

instance Text D.RepoType where
  parse = fmap D.classifyRepoType ident

instance Text D.UnqualComponentName where
  parse = D.mkUnqualComponentName <$> parsePackageName

instance Text D.PackageIdentifier where
  parse = do
    n <- parse
    v <- (Parse.char '-' >> parse) <++ return D.nullVersion
    return (D.PackageIdentifier n v)

instance Text D.PackageName where
  parse = D.mkPackageName <$> parsePackageName

instance Text D.Version where
  parse = do
      branch <- Parse.sepBy1 parseNat (Parse.char '.')
                -- allow but ignore tags:
      _tags  <- Parse.many (Parse.char '-' >> Parse.munch1 isAlphaNum)
      return (D.mkVersion branch)

instance Text D.VersionRange where
  parse = expr
   where
        expr   = do Parse.skipSpaces
                    t <- term
                    Parse.skipSpaces
                    (do _  <- Parse.string "||"
                        Parse.skipSpaces
                        e <- expr
                        return (D.unionVersionRanges t e)
                     Parse.+++
                     return t)
        term   = do f <- factor
                    Parse.skipSpaces
                    (do _  <- Parse.string "&&"
                        Parse.skipSpaces
                        t <- term
                        return (D.intersectVersionRanges f t)
                     Parse.+++
                     return f)
        factor = Parse.choice $ parens expr
                              : parseAnyVersion
                              : parseNoVersion
                              : parseWildcardRange
                              : map parseRangeOp rangeOps
        parseAnyVersion    = Parse.string "-any" >> return D.anyVersion
        parseNoVersion     = Parse.string "-none" >> return D.noVersion

        parseWildcardRange = do
          _ <- Parse.string "=="
          Parse.skipSpaces
          branch <- Parse.sepBy1 digits (Parse.char '.')
          _ <- Parse.char '.'
          _ <- Parse.char '*'
          return (D.withinVersion (D.mkVersion branch))

        parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces)
                                 (Parse.char ')' >> Parse.skipSpaces)
                                 (do a <- p
                                     Parse.skipSpaces
                                     return (D.VersionRangeParens a))
        digits = do
          firstDigit <- Parse.satisfy isDigit
          if firstDigit == '0'
            then return 0
            else do rest <- Parse.munch isDigit
                    return (read (firstDigit : rest)) -- TODO: eradicateNoParse

        parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse
        rangeOps = [ ("<",  D.earlierVersion),
                     ("<=", D.orEarlierVersion),
                     (">",  D.laterVersion),
                     (">=", D.orLaterVersion),
                     ("^>=", D.majorBoundVersion),
                     ("==", D.thisVersion) ]

-------------------------------------------------------------------------------
-- ParseUtils
-------------------------------------------------------------------------------

parsePackageName :: Parse.ReadP r String
parsePackageName = do
  ns <- Parse.sepBy1 component (Parse.char '-')
  return $ intercalate "-" ns
  where
    component = do
      cs <- Parse.munch1 isAlphaNum
      if all isDigit cs then Parse.pfail else return cs
      -- each component must contain an alphabetic character, to avoid
      -- ambiguity in identifiers like foo-1 (the 1 is the version number).


ident :: Parse.ReadP r String
ident = liftM2 (:) firstChar rest
  where firstChar = Parse.satisfy isAlpha
        rest = Parse.munch (\c -> isAlphaNum c || c == '_' || c == '-')

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

-------------------------------------------------------------------------------
-- Rest of instances, we don't seem to need
-------------------------------------------------------------------------------

-- instance Text D.AbiDependency
-- instance Text D.AbiHash
-- instance Text D.AbiTa
-- instance Text D.BenchmarkType
-- instance Text D.ExecutableScope
-- instance Text D.ExeDependency
-- instance Text D.ExposedModule
-- instance Text D.ForeignLibOption
-- instance Text D.ForeignLibType
-- instance Text D.IncludeRenaming
-- instance Text D.KnownExtension
-- instance Text D.LegacyExeDependency
-- instance Text D.LibVersionInfo
-- instance Text D.License
-- instance Text D.Mixin
-- instance Text D.ModuleReexport
-- instance Text D.ModuleRenaming
-- instance Text D.MungedPackageName
-- instance Text D.OpenModule
-- instance Text D.OpenUnitId
-- instance Text D.PackageVersionConstraint
-- instance Text D.PkgconfigDependency
-- instance Text D.TestType