stackage-to-hackage-1.0.0: src/Main.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ViewPatterns          #-}

import qualified Data.ByteString                as BS
import           Data.List                      (sort)
import           Data.List.Extra                (nubOn)
import           Data.Map.Strict                (lookup, toList)
import           Data.Maybe                     (fromMaybe, mapMaybe)
import           Data.Semigroup.Foldable        (fold1)
import           Data.Text                      (Text, concat, intercalate,
                                                 pack)
import           Data.Text.Encoding             (encodeUtf8)
import           Distribution.Pretty            (prettyShow)
import           Distribution.Types.PackageId   (PackageIdentifier (..))
import           Distribution.Types.PackageName (unPackageName)
import           OpenSSL                        (withOpenSSL)
import qualified Options.Applicative            as Opts
import           Prelude                        hiding (concat, head, lookup,
                                                 reverse)
import           Stackage
import           System.FilePath                (takeDirectory, (</>))

{- MANUAL TEST:
  LC_ALL=C cabal v2-run stackage-to-hackage -- tests/snapshot/stack.yaml
  LC_ALL=C cabal v2-run stackage-to-hackage -- tests/stackage/stack.yaml
  git diff tests
-}
main :: IO ()
main = withOpenSSL $ do
  Options{input} <- Opts.execParser $
                   Opts.info (Opts.helper <*> optionsParser) Opts.fullDesc
  text <- BS.readFile input
  stack <- readStack text
  let dir = (takeDirectory input)
  resolvers <- unroll dir stack
  let
    resolver = fold1 resolvers
    freeze = genFreeze resolver
    project = genProject stack resolver
  BS.writeFile (dir </> "cabal.project") (encodeUtf8 $ printProject project)
  BS.writeFile (dir </> "cabal.project.freeze") (encodeUtf8 $ printFreeze freeze)

printProject :: Project -> Text
printProject (Project (Ghc ghc) pkgs srcs) =
  concat [ "-- Generated by stackage-to-hackage from stack.yaml\n\n"
         , "with-compiler: ", ghc, "\n\n"
         , "packages:\n    ", packages, "\n\n"
         , sources, "\n"
         , "allow-older: *\n"
         , "allow-newer: *\n"
         ]
  where
    packages = intercalate "\n  , " ((<> "/"). pack <$> pkgs)
    sources = intercalate "\n" (source =<< srcs)
    source Git{repo, commit, subdirs} =
      let base = concat [ "source-repository-package\n    "
                        , "type: git\n    "
                        , "location: ", repo, "\n    "
                        , "tag: ", commit, "\n"]
      in if null subdirs
         then [base]
         else (\d -> concat [base, "    subdir: ", d, "\n"]) <$> subdirs

data Project = Project Ghc [FilePath] [Git] deriving (Show)

genProject :: Stack -> Resolver -> Project
genProject Stack{packages} Resolver{compiler, deps} = Project
  (fromMaybe (Ghc "ghc") compiler)
  (mapMaybe pickLocal packages)
  (nubOn repo $ mapMaybe pickGit deps)
  where
    pickLocal (Local p)    = Just p
    pickLocal (Location _) = Nothing
    pickGit (Hackage _ )  = Nothing
    pickGit (SourceDep g) = Just g

printFreeze :: Freeze -> Text
printFreeze (Freeze deps (Flags flags)) =
  concat [ "constraints: \n    ", constraints, "\n"]
  where
    constraints = intercalate "\n  , " (constrait <$> sort deps)
    constrait pkg =
      let name = (pack . unPackageName . pkgName $ pkg)
          ver  = (pack . prettyShow . pkgVersion $ pkg)
          base = concat [name, " ==", ver]
      in case lookup name flags of
        Nothing      -> base
        Just entries -> concat [ name, " ", (custom entries)
                               , "\n  , ", base]
    custom (toList -> lst) = intercalate " " $ (renderFlag <$> lst)
    renderFlag (name, True)  = "+" <> name
    renderFlag (name, False) = "-" <> name

data Freeze = Freeze [PackageIdentifier] Flags deriving (Show)

genFreeze :: Resolver -> Freeze
genFreeze Resolver{deps, flags} =
  let pkgs = mapMaybe pick deps
      uniqpkgs = nubOn pkgName pkgs
   in Freeze uniqpkgs flags
  where pick (Hackage p)   = Just p
        pick (SourceDep _) = Nothing

data Options = Options
  { input      :: FilePath
  }
optionsParser :: Opts.Parser Options
optionsParser = Options
  <$> file
  where
    file = Opts.strArgument
             (  Opts.metavar "FILENAME"
             <> Opts.help "Input stack.yaml")