content: {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TupleSections #-}
  module NixFromNpm.Npm.Version where
  
  import qualified Data.Text as T
  import qualified Data.HashMap.Strict as H
  
  import Data.SemVer
  import Data.Aeson
  import qualified Data.Aeson.Types as Aeson
  
  import NixFromNpm.Common
  import NixFromNpm.Npm.PackageMap
  import NixFromNpm.Git.Types hiding (Tag)
  import Text.Parsec (ParseError)
  
  data NpmVersionRange
    = SemVerRange SemVerRange
    -- ^ The most common: parsing from a semver range.
    | Tag Name
    -- ^ From an npm "tag"; this mapping lives in the package metadata.
    | NpmUri URI
    -- ^ From a URL (e.g. a tarball or zip file)
    | GitIdentifier GitIdentifier
    -- ^ From one of the "known" git services (e.g. github, bitbucket).
    | LocalPath FilePath
    -- ^ From a local file path.
    | InvalidVersion Text
    -- ^ An invalid version string: this results in a downstream failure
    -- but allows us to ignore an invalid version unless we actually
    -- need to resolve it. While proper Haskell idioms might dictate we
    -- use an Either or similar here, this is somewhat of a path of
    -- least resistance.
    deriving (Eq, Ord)
  
  data NpmVersionError
    = UnsupportedVersionType NpmVersionRange
    | UnsupportedUriScheme String
    | UnsupportedGitSource GitSource
    | VersionSyntaxError Text
    | UnrecognizedVersionFormat Text
    deriving (Show, Eq, Typeable)
  
  instance Exception NpmVersionError
  
  instance Show NpmVersionRange where
    show (SemVerRange rng) = show rng
    show (Tag name) = unpack name
    show (NpmUri uri) = uriToString uri
    show (GitIdentifier ident) = show ident
    show (LocalPath pth) = show pth
    show (InvalidVersion v) = "Version string unable to be parsed: " <> show v
  
  showPair :: PackageName -> SemVer -> Text
  showPair name version = tshow name <> "@" <> tshow version
  
  showPairs :: [(PackageName, SemVer)] -> Text
  showPairs = mapJoinBy ", " (uncurry showPair)
  
  showRangePair :: PackageName -> NpmVersionRange -> Text
  showRangePair name range = tshow name <> "@" <> tshow range
  
  showDeps :: [(PackageName, NpmVersionRange)] -> Text
  showDeps ranges = mapJoinBy ", " (uncurry showRangePair) ranges
  
  parseNpmVersionRange :: Text -> Maybe NpmVersionRange
  parseNpmVersionRange t = do
    SemVerRange <$> eitherToMaybe (parseSemVerRange t)
    <|> GitIdentifier <$> parseGitId (unpack t)
    <|> NpmUri <$> parseURI (unpack t)
    <|> LocalPath <$> asPath
    <|> Tag <$> asTag
    where
      asPath = case unpack t of
        '/':_ -> Just $ fromText t
        '.':'/':_ -> Just $ fromText t
        '.':'.':'/':_ -> Just $ fromText t
        '~':'/':_ -> Just $ fromText t
        _ -> Nothing
      asTag = if t == "" || " " `isInfixOf` t then Nothing else Just t
  
  instance FromJSON NpmVersionRange where
    parseJSON v = case v of
      String s -> case parseNpmVersionRange s of
        Nothing -> return $ InvalidVersion s
        Just range -> return range
      -- NOTE: I couldn't find a mention of this format for specifying
      -- versions in the official package.json documentation. However,
      -- this was encountered in the wild:
      --
      --   https://github.com/adnelson/nixfromnpm/issues/138
      --
      -- Making a special case for it here seems pretty harmless,
      -- especially if it was at one point supported. Alternatively, we
      -- could allow parsing dev dependencies and such-like to fail.
      Object m -> case H.lookup "version" m of
        Just v -> parseJSON v
        Nothing -> fail "no 'version' key found in dependency object"
      _ -> Aeson.typeMismatch "string" v
  
  -- | A package name can be passed in directly, or a version range can be
  -- specified with a @.
  parseNameAndRange :: MonadIO m => Text -> m (PackageName, NpmVersionRange)
  parseNameAndRange name = do
    let badFormat err =
          UnrecognizedVersionFormat (name <> " (" <> err <> help <> ")")
        help = case T.find (== '%') name of
          Nothing -> ""
          Just _ -> " (use '@' instead of '%' to indicate a version range)"
  
    -- TODO use ExceptT for these, or switch to parsec
    let parseName n = case parsePackageName n of
          Left err -> throw $ badFormat err
          Right pkgName -> pure pkgName
  
    let parseRange r = case parseNpmVersionRange r of
          Nothing -> throw $ VersionSyntaxError r
          Just range -> pure range
  
    case T.split (== '@') name of
      -- No namespace, no version range
      [_] -> (, SemVerRange anyVersion) <$> parseName name
  
      -- Namespace but no version range
      ["", _] -> (, SemVerRange anyVersion) <$> parseName name
  
      -- Namespace and range
      "" : name' : ranges ->
        -- In case a '@' appears in the range, treat the range as a list
        -- and join on '@'
        (,) <$> parseName ("@" <> name') <*> parseRange (joinBy "@" ranges)
  
      -- No namespace, but with range
      name' : ranges ->
        (,) <$> parseName name' <*> parseRange (joinBy "@" ranges)
  
      -- Anything else is invalid.
      _ -> throw $ badFormat $ "Not in format <name> or <name>@<range>" <> help
  