    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE LambdaCase #-}
    module Hpack.Syntax.DependencyVersion (
      githubBaseUrl
    , GitRef
    , GitUrl

    , VersionConstraint(..)
    , versionConstraint
    , anyVersion
    , versionRange

    , DependencyVersion(..)
    , withDependencyVersion
    , dependencyVersion

    , SourceDependency(..)
    , objectDependency

    , versionConstraintFromCabal

    , scientificToVersion
    , cabalParse
    ) where

    import           Control.Applicative
    import           Data.Maybe
    import           Data.Scientific
    import           Data.Text (Text)
    import qualified Data.Text as T
    import qualified Data.HashMap.Strict as HashMap
    import           Text.PrettyPrint (renderStyle, Style(..), Mode(..))

    import           Distribution.Version (VersionRangeF(..))
    import qualified Distribution.Text as D
    import qualified Distribution.Version as D
    import qualified Distribution.Parsec.Class as D

    import           Data.Aeson.Config.FromValue

    githubBaseUrl :: String
    githubBaseUrl = "https://github.com/"

    type GitUrl = String
    type GitRef = String

    data VersionConstraint = AnyVersion | VersionRange String
      deriving (Eq, Show)

    instance FromValue VersionConstraint where
      fromValue = versionConstraint

    versionConstraint :: Value -> Parser VersionConstraint
    versionConstraint v = case v of
      Null -> return AnyVersion
      Number n -> return (numericVersionConstraint n)
      String s -> stringVersionConstraint s
      _ -> typeMismatch "Null, Number, or String" v

    anyVersion :: DependencyVersion
    anyVersion = DependencyVersion Nothing AnyVersion

    versionRange :: String -> DependencyVersion
    versionRange = DependencyVersion Nothing . VersionRange

    data DependencyVersion = DependencyVersion (Maybe SourceDependency) VersionConstraint
      deriving (Eq, Show)

    withDependencyVersion
      :: (DependencyVersion -> a)
      -> (Object -> DependencyVersion -> Parser a)
      -> Value
      -> Parser a
    withDependencyVersion k obj v = case v of
      Null -> return $ k anyVersion
      Object o -> objectDependency o >>= obj o
      Number n -> return $ k (DependencyVersion Nothing $ numericVersionConstraint n)
      String s -> k . DependencyVersion Nothing <$> stringVersionConstraint s
      _ -> typeMismatch "Null, Object, Number, or String" v

    dependencyVersion :: Value -> Parser DependencyVersion
    dependencyVersion = withDependencyVersion id (const return)

    data SourceDependency = GitRef GitUrl GitRef (Maybe FilePath) | Local FilePath
      deriving (Eq, Show)

    objectDependency :: Object -> Parser DependencyVersion
    objectDependency o = let
        version :: Parser VersionConstraint
        version = fromMaybe AnyVersion <$> (o .:? "version")

        local :: Parser SourceDependency
        local = Local <$> o .: "path"

        git :: Parser SourceDependency
        git = GitRef <$> url <*> ref <*> subdir

        url :: Parser String
        url =
              ((githubBaseUrl ++) <$> o .: "github")
          <|> (o .: "git")
          <|> fail "neither key \"git\" nor key \"github\" present"

        ref :: Parser String
        ref = o .: "ref"

        subdir :: Parser (Maybe FilePath)
        subdir = o .:? "subdir"

        source :: Parser (Maybe SourceDependency)
        source
          | any (`HashMap.member` o) ["path", "git", "github", "ref", "subdir"] = Just <$> (local <|> git)
          | otherwise = return Nothing

        in DependencyVersion <$> source <*> version

    numericVersionConstraint :: Scientific -> VersionConstraint
    numericVersionConstraint n = VersionRange ("==" ++ version)
      where
        version = scientificToVersion n

    stringVersionConstraint :: Text -> Parser VersionConstraint
    stringVersionConstraint s = parseVersionRange ("== " ++ input) <|> parseVersionRange input
      where
        input = T.unpack s

    scientificToVersion :: Scientific -> String
    scientificToVersion n = version
      where
        version = formatScientific Fixed (Just decimalPlaces) n
        decimalPlaces
          | e < 0 = abs e
          | otherwise = 0
        e = base10Exponent n

    parseVersionRange :: Monad m => String -> m VersionConstraint
    parseVersionRange = fmap versionConstraintFromCabal . parseCabalVersionRange

    parseCabalVersionRange :: Monad m => String -> m D.VersionRange
    parseCabalVersionRange = cabalParse "constraint"

    cabalParse :: (Monad m, D.Parsec a) => String -> String -> m a
    cabalParse subject s = case D.eitherParsec s of
      Right d -> return d
      Left _ ->fail $ unwords ["invalid",  subject, show s]

    versionConstraintFromCabal :: D.VersionRange -> VersionConstraint
    versionConstraintFromCabal range
      | D.isAnyVersion range = AnyVersion
      | otherwise = VersionRange . renderStyle style . D.disp $ toPreCabal2VersionRange range
      where
        style = Style OneLineMode 0 0

        toPreCabal2VersionRange :: D.VersionRange -> D.VersionRange
        toPreCabal2VersionRange = D.embedVersionRange . D.cataVersionRange f
          where
            f :: VersionRangeF (VersionRangeF D.VersionRange) -> VersionRangeF D.VersionRange
            f = \ case
              MajorBoundVersionF v -> IntersectVersionRangesF (D.embedVersionRange lower) (D.embedVersionRange upper)
                where
                  lower = OrLaterVersionF v
                  upper = EarlierVersionF (D.majorUpperBound v)

              AnyVersionF -> AnyVersionF
              ThisVersionF v -> ThisVersionF v
              LaterVersionF v -> LaterVersionF v
              OrLaterVersionF v -> OrLaterVersionF v
              EarlierVersionF v -> EarlierVersionF v
              OrEarlierVersionF v -> OrEarlierVersionF v
              WildcardVersionF v -> WildcardVersionF v
              UnionVersionRangesF a b -> UnionVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b)
              IntersectVersionRangesF a b -> IntersectVersionRangesF (D.embedVersionRange a) (D.embedVersionRange b)
              VersionRangeParensF a -> VersionRangeParensF (D.embedVersionRange a)