{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Duplicates a subset of the Stack ADT. It'd be nice if we could just re-use
-- the actual ADT, but stack isn't available as a library that we can build from
-- Hackage.
module StackageToHackage.Stackage where

import           Control.Applicative          (Alternative, empty, (<|>))
import           Control.Monad.Extra          (loopM, unlessM)
import qualified Data.ByteString              as BS
import           Data.ByteString.Lazy         (toStrict)
import           Data.List.NonEmpty           (NonEmpty(..), head, nonEmpty,
                                               reverse, (<|))
import           Data.Map.Strict              (Map)
import qualified Data.Map.Strict              as M
import           Data.Maybe                   (fromMaybe, listToMaybe, mapMaybe)
import           Data.Semigroup
import           Data.Text                    (Text, isSuffixOf, replace,
                                               takeWhile, unpack)
import           Data.YAML                    (FromYAML, Mapping, Node(..),
                                               Parser, Scalar(..), decodeStrict,
                                               parseYAML, withMap, withStr,
                                               (.!=), (.:), (.:?))
import           Distribution.Text            (simpleParse)
import           Distribution.Types.PackageId (PackageIdentifier(..))
import           Network.HTTP.Client          (httpLbs, parseRequest,
                                               responseBody)
import           Network.HTTP.Client.TLS      (getGlobalManager)
import           Prelude                      hiding (head, reverse, takeWhile)
import           System.Directory             (XdgDirectory(..),
                                               createDirectoryIfMissing,
                                               doesFileExist, getXdgDirectory)
import           System.FilePath              (takeDirectory, (</>))

data Stack = Stack
  { resolver  :: ResolverRef
  , compiler  :: Maybe Ghc
  , packages  :: [Package]
  , extraDeps :: [Dep]
  , flags     :: Flags
  -- TODO ghcOptions
  } deriving (Show)

localDirs :: Stack -> NonEmpty FilePath
localDirs Stack{packages} =
  fromMaybe (pure ".") $ nonEmpty $ mapMaybe locals packages
  where
    locals (Local p)    = Just p
    locals (Location _) = Nothing

newtype Ghc = Ghc Text
  deriving (Show)
  deriving newtype (FromYAML)

data Package = Local FilePath
             | Location Git
               deriving (Show)

data Git = Git
  { repo    :: Repo
  , commit  :: Commit
  , subdirs :: [Subdir]
  } deriving (Show)
type Repo = Text
type Commit = Text
type Subdir = Text

data Resolver = Resolver
  { resolver :: Maybe ResolverRef
  , compiler :: Maybe Ghc
  , deps     :: [Dep]
  , flags    :: Flags
  } deriving (Show)
instance Semigroup Resolver where
  (Resolver r c p f) <> (Resolver r' c' p' f') =
    Resolver (r <|> r') (c <|> c') (p <> p') (f <> f')

-- TODO: remote ResolverRefs
data ResolverRef = Canned Text
                 | Snapshot Text
                 deriving (Show)

-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Types-PackageId.html#t:PackageIdentifier
-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Parsec-Class.html#v:simpleParsec

data Dep = Hackage PkgId
         | SourceDep Git
         deriving (Show)

newtype Flags = Flags (Map PkgName (Map FlagName Bool))
              deriving (Show)
              deriving newtype (FromYAML, Semigroup)

type PkgName = Text
type FlagName = Text

-- the format used at https://github.com/commercialhaskell/stackage-snapshots
-- which is similar to the Resolver format.
data NewResolver = NewResolver
  { compiler :: Ghc
  , packages :: [NewDep]
  , flags    :: Flags
  } deriving (Show)

data NewDep = NewDep PkgId
              deriving (Show)

--------------------------------------------------------------------------------
-- Resolvers

readStack :: BS.ByteString -> IO Stack
readStack text = either fail pure $ decode1Strict text

type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver)
type Resolvers = NonEmpty Resolver

-- highest priority resolver first
unroll :: FilePath -> Stack -> IO Resolvers
unroll base stack = do
  let stack' = stack2resolver stack
  reverse <$> (loopM next (pure (Just base, stack')))
  where
    -- lowest priority (deepest) resolver first
    next :: RelativeResolvers -> IO (Either RelativeResolvers Resolvers)
    next rs = case head rs of
      (_, Resolver Nothing _ _ _)    -> pure $ Right (snd <$> rs)
      (dir, Resolver (Just r) _ _ _) -> (Left .  (<| rs)) <$> resolve dir r

-- if the Resolver is a local snapshot, also include its dir
resolve :: Maybe FilePath -> ResolverRef -> IO (Maybe FilePath, Resolver)
resolve _ (Canned lts) = do
  cached <- cache lts
  text <- (BS.readFile cached) <|> download
  update cached text
  either fail (\r -> pure (Nothing, r)) $ new2old <$> (decode1Strict $ text)
    where
      download =
        let path = unpack $ replace "." "/" (replace "-" "/" (replace "-0" "-" lts))
            raw = concat ["https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/", path, ".yaml"]
        in do
          manager <- getGlobalManager
          url <- parseRequest raw
          putStrLn ("Downloading: " <> raw)
          resp <- httpLbs url manager
          pure $ toStrict $ responseBody resp

      update file content = unlessM (doesFileExist file) (BS.writeFile file content)

resolve (Just base) (Snapshot path) = do
  let file = base </> (unpack path)
      dir = takeDirectory file
  text <- BS.readFile file
  either fail (\r -> pure (Just dir, r)) $ decode1Strict text

resolve Nothing _ = fail "Remote snapshots can't use relative paths."

cache :: Text -> IO FilePath
cache file = do
  dir <- getXdgDirectory XdgCache "stackage"
  createDirectoryIfMissing True dir
  pure $ dir </> (unpack file)

stack2resolver :: Stack -> Resolver
stack2resolver Stack{resolver, compiler, packages, extraDeps, flags} =
  Resolver (Just resolver) compiler (sourcedeps <> extraDeps) flags
  where sourcedeps = mapMaybe pick packages
        pick (Local _)    = Nothing
        pick (Location g) = Just . SourceDep $ g

new2old :: NewResolver -> Resolver
new2old NewResolver{compiler, packages, flags} =
  Resolver Nothing (Just compiler) (new2old' <$> packages) flags
  where
    new2old' (NewDep pkg) = Hackage pkg

--------------------------------------------------------------------------------
-- YAML boilerplate

-- https://github.com/haskell-hvr/HsYAML/pull/5
decode1Strict :: FromYAML a => BS.ByteString -> Either String a
decode1Strict text = do
  as <- decodeStrict text
  maybe (Left "expected unique") Right $ listToMaybe as

instance FromYAML Stack where
   parseYAML = withMap "Stack" $ \m -> Stack
       <$> m .: "resolver"
       <*> m .:? "compiler"
       <*> m .:? "packages" .!= mempty
       <*> m .:? "extra-deps" .!= mempty
       <*> m .:? "flags" .!= (Flags M.empty)

instance FromYAML Git where
  parseYAML = withMap "Git" $ \m -> Git
    <$> m .: "git"
    <*> m .: "commit"
    <*> m .:? "subdirs" .!= []

instance FromYAML ResolverRef where
  parseYAML = withStr "ResolverRef" $ \s ->
    if isSuffixOf ".yaml" s
    then (pure . Snapshot) s
    else (pure . Canned) s

instance FromYAML Package where
  parseYAML n = (local n) <|> (location n)
    where
      local = withStr "Local" $ pure . Local . unpack
      location = withMap "Location" $ \m ->
        Location <$> m .: "location"

instance FromYAML Dep where
   parseYAML n = hackage <|> source
     where
       hackage = Hackage <$> parseYAML n
       source = SourceDep <$> parseYAML n

instance FromYAML Resolver where
  parseYAML = withMap "Resolver" $ \m -> Resolver
    <$> m .:? "resolver"
    <*> m .:? "compiler"
    <*> m .:? "packages" .!= mempty
    <*> m .:? "flags" .!= (Flags M.empty)

instance FromYAML NewDep where
   parseYAML = withMap "NewDep" $ \m -> hackage' =<< m .: "hackage"
     where
       hackage' n = NewDep <$> parseYAML n

instance FromYAML NewResolver where
  parseYAML = withMap "NewResolver" $ \m -> NewResolver
    <$> (m .: "compiler" <|> m ..: ("resolver", "compiler"))
    <*> m .:? "packages" .!= mempty
    <*> m .:? "flags" .!= (Flags M.empty)
    where
      (..:) :: FromYAML a => Mapping -> (Text, Text) -> Parser a
      m1 ..: (k1, k2) =
        case M.lookup (Scalar (SStr k1)) m1 of
          Just (Mapping _ m2) -> m2 .: k2
          _ -> fail $ "key " ++ show k1 ++ " not found"

newtype PkgId = PkgId { unPkgId :: PackageIdentifier } deriving (Show)
instance FromYAML PkgId where
  parseYAML = withStr "PackageIdentifier" $ \s ->
    PkgId <$> (hoistMaybe . simpleParse . unpack) (takeWhile ('@' /=) s)

hoistMaybe :: Alternative m => Maybe a -> m a
hoistMaybe = maybe empty pure