Translation.hs

{-# LANGUAGE FlexibleContexts #-}
{-
 - Copyright 2011 Per Magnus Therning
 -
 - Licensed under the Apache License, Version 2.0 (the "License");
 - you may not use this file except in compliance with the License.
 - You may obtain a copy of the License at
 -
 -     http://www.apache.org/licenses/LICENSE-2.0
 -
 - Unless required by applicable law or agreed to in writing, software
 - distributed under the License is distributed on an "AS IS" BASIS,
 - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 - See the License for the specific language governing permissions and
 - limitations under the License.
 -}

module Util.Translation where

import PkgDB as DB
import Util.Misc
import Util.Dist

import Prelude hiding ( (<$>) )
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Trans.Except
import Data.Char
import Data.List
import Data.Maybe
import Data.Monoid hiding ((<>))
import Data.Version
import Distribution.Package as P
import Distribution.PackageDescription as PD
import Distribution.Text
import System.Directory
import System.Exit
import System.FilePath
import System.Process
import System.Unix.Directory
import Text.PrettyPrint.ANSI.Leijen hiding((</>))

import qualified Data.ByteString.Lazy as BSL (writeFile)

-- {{{1 ShQuotedString
newtype ShQuotedString = ShQuotedString String
    deriving (Eq, Show)

instance Pretty ShQuotedString where
    pretty (ShQuotedString s) = char '"' <> text quotStr <> char '"'
        where
            quotStr = shEsc $ unwords $ lines s

-- {{{1 ShArray
newtype ShArray = ShArray [String]
    deriving (Eq, Show)

instance Monoid ShArray where
    mempty = ShArray []
    (ShArray a) `mappend` (ShArray b) = ShArray $ a ++ b

instance Pretty ShArray where
    pretty (ShArray a) = encloseSep (char '(') (char ')') (char ' ') (map (\ t -> char '"' <> text t <> char '"') a)

-- {{{1 ShVar
data ShVar a = ShVar String a
    deriving (Eq, Show)

{-# ANN shVarNewValue "HLint: ignore Eta reduce" #-}
shVarNewValue (ShVar n _) v = ShVar n v
shVarAppendValue (ShVar n v1) v2 = ShVar n (v1 `mappend` v2)
shVarValue (ShVar _ v) = v
shVarName (ShVar n _) = n
shVarRefName (ShVar n _) = "${" ++ n ++ "}"

instance Pretty a => Pretty (ShVar a) where
    pretty (ShVar n v) = text n <> char '=' <> pretty v

-- {{{1 ArchPkg
data ArchPkg = ArchPkg
    { apPkgName :: String
    , apHkgName :: String
    , apHasLibrary :: Bool
    , apLicenseFile :: Maybe FilePath
    , apCabalPatch :: Maybe FilePath
    , apPkgbuildPatch :: Maybe FilePath
    , apInstallPatch :: Maybe FilePath
    , apBuildPatch :: Maybe FilePath
    -- shell bits
    , apShHkgName :: ShVar String
    , apShPkgName :: ShVar String
    , apShPkgVer :: ShVar Version
    , apShPkgRel :: ShVar Int
    , apShXRev :: ShVar String
    , apShPkgDesc :: ShVar ShQuotedString
    , apShUrl :: ShVar ShQuotedString
    , apShLicence :: ShVar ShArray
    , apShMakeDepends :: ShVar ShArray
    , apShDepends :: ShVar ShArray
    , apShSource :: ShVar ShArray
    , apShInstall :: Maybe (ShVar ShQuotedString)
    , apShSha256Sums :: ShVar ShArray
    , apFlags :: FlagAssignment
    } deriving (Eq, Show)

-- {{{2 baseArchPkg
baseArchPkg = ArchPkg
    { apPkgName = ""
    , apHkgName = ""
    , apHasLibrary = False
    , apLicenseFile = Nothing
    , apCabalPatch = Nothing
    , apPkgbuildPatch = Nothing
    , apInstallPatch = Nothing
    , apBuildPatch = Nothing
    , apShHkgName = ShVar "_hkgname" ""
    , apShPkgName = ShVar "pkgname" ""
    , apShPkgVer = ShVar "_ver" (Version [] [])
    , apShPkgRel = ShVar "pkgrel" 0
    , apShXRev = ShVar "_xrev" "0"
    , apShPkgDesc = ShVar "pkgdesc" (ShQuotedString "")
    , apShUrl = ShVar "url" (ShQuotedString "http://hackage.haskell.org/package/${_hkgname}")
    , apShLicence = ShVar "license" (ShArray [])
    , apShMakeDepends = ShVar "makedepends" (ShArray [])
    , apShDepends = ShVar "depends" (ShArray [])
    , apShSource = ShVar "source" (ShArray ["http://hackage.haskell.org/packages/archive/${_hkgname}/${_ver}/${_hkgname}-${_ver}.tar.gz", "original.cabal"])
    , apShInstall = Just $ ShVar "install" (ShQuotedString "${pkgname}.install")
    -- this is a trick to make sure that the user's setting for integrity
    -- checking in makepkg.conf isn't used, as long as this array contains
    -- something non-empty it will overrule
    , apShSha256Sums = ShVar "sha256sums" (ShArray ["0"])
    , apFlags = []
    }

-- {{{2 Pretty instance
instance Pretty ArchPkg where
    pretty (ArchPkg
        { apHasLibrary = hasLib
        , apLicenseFile = licenseFile
        , apCabalPatch = cabalPatchFile
        , apBuildPatch = buildPatchFile
        , apShHkgName = hkgName
        , apShPkgName = pkgName
        , apShPkgVer = pkgVer
        , apShPkgRel = pkgRel
        , apShXRev = xrev
        , apShPkgDesc = pkgDesc
        , apShUrl = url
        , apShLicence = pkgLicense
        , apShMakeDepends = makeDepends
        , apShDepends = depends
        , apShSource = source
        , apShInstall = install
        , apShSha256Sums = sha256sums
        , apFlags = flags
        }) = vsep
            [ text "# custom variables"
            , pretty hkgName
            , maybe empty (pretty . ShVar "_licensefile") licenseFile
            , pretty pkgVer
            , pretty xrev
            , empty, text "# PKGBUILD options/directives"
            , pretty pkgName
            , text "pkgver=${_ver}_${_xrev}"
            , pretty pkgRel
            , pretty pkgDesc
            , pretty url
            , pretty pkgLicense
            , text "arch=('i686' 'x86_64')"
            , pretty makeDepends
            , pretty depends
            , text "options=('strip' 'staticlibs')"
            , pretty source
            , maybe empty pretty install
            , pretty sha256sums
            , empty, text "# PKGBUILD functions"
            , empty
            , prepareFunction
            , empty
            , if hasLib then libBuildFunction else exeBuildFunction
            , empty
            , if hasLib then libPackageFunction else exePackageFunction
            , empty
            ]
            where
                prepareFunction = text "prepare() {" <>
                    nest 4 (empty <$>
                        text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$>
                        text "cp \"${srcdir}/original.cabal\" \"${srcdir}/${_hkgname}-${_ver}/${_hkgname}.cabal\"" <$>
                        empty <$>
                        maybe (text "# no source patch") (\ _ ->
                            text "patch -p4 < \"${srcdir}/source.patch\"")
                            buildPatchFile
                        ) <$>
                    char '}'
                libBuildFunction = text "build() {" <>
                    nest 4 (empty <$>
                        text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$>
                        empty <$>
                        nest 4 (text "runhaskell Setup configure -O --enable-library-profiling --enable-shared \\" <$>
                            text "--prefix=/usr --docdir=\"/usr/share/doc/${pkgname}\" \\" <$>
                            text "--libsubdir=\\$compiler/site-local/\\$pkgid" <> confFlags) <$>
                        text "runhaskell Setup build" <$>
                        text "runhaskell Setup haddock --hoogle --html" <$>
                        text "runhaskell Setup register --gen-script" <$>
                        text "runhaskell Setup unregister --gen-script" <$>
                        text "sed -i -r -e \"s|ghc-pkg.*unregister[^ ]* |&'--force' |\" unregister.sh"
                        ) <$>
                    char '}'

                exeBuildFunction = text "build() {" <>
                    nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$>
                        empty <$>
                        text "runhaskell Setup configure -O --prefix=/usr --docdir=\"/usr/share/doc/${pkgname}\"" <> confFlags <$>
                        text "runhaskell Setup build"
                        ) <$>
                    char '}'

                confFlags = if null flags
                    then empty
                    else text " \\" <>
                        nest 4 (empty <$> (hsep . map (uncurry (<>)) $ zip (repeat $ text "-f") (map prettyFlag flags)))

                libPackageFunction = text "package() {" <>
                    nest 4 (empty <$>
                        text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$>
                        empty <$>
                        text "install -D -m744 register.sh   \"${pkgdir}/usr/share/haskell/${pkgname}/register.sh\"" <$>
                        text "install    -m744 unregister.sh \"${pkgdir}/usr/share/haskell/${pkgname}/unregister.sh\"" <$>
                        text "install -d -m755 \"${pkgdir}/usr/share/doc/ghc/html/libraries\"" <$>
                        text "ln -s \"/usr/share/doc/${pkgname}/html\" \"${pkgdir}/usr/share/doc/ghc/html/libraries/${_hkgname}\"" <$>
                        text "runhaskell Setup copy --destdir=\"${pkgdir}\"" <$>
                        maybe empty (\ _ -> text "install -D -m644 \"${_licensefile}\" \"${pkgdir}/usr/share/licenses/${pkgname}/LICENSE\"" <$>
                            text "rm -f \"${pkgdir}/usr/share/doc/${pkgname}/${_licensefile}\"") licenseFile
                        ) <$>
                    char '}'

                exePackageFunction = text "package() {" <>
                    nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$>
                        text "runhaskell Setup copy --destdir=\"${pkgdir}\""
                        ) <$>
                    char '}'

-- {{{1 ArchInstall
data ArchInstall = ArchInstall
    { aiShPkgName :: ShVar String
    } deriving (Eq, Show)

-- {{{2 baseArchInstall
baseArchInstall = ArchInstall
    { aiShPkgName = ShVar "pkgname" ""
    }

-- {{{2 ArchInstall from ArchPackage
aiFromAP (ArchPkg { apShPkgName = pkgName }) =
    ArchInstall { aiShPkgName = pkgName }

-- {{{2 Pretty instance
instance Pretty ArchInstall where
    pretty (ArchInstall
        { aiShPkgName = pkgName
        }) = vsep
            [ text "# custom variables"
            , pretty pkgName
            , pretty (ShVar "HS_DIR" "usr/share/haskell/${pkgname}")
            , empty, text "# functions"
            , postInstallFunction
            , empty, preUpgradeFunction
            , empty, postUpgradeFunction
            , empty, preRemoveFunction
            , empty, postRemoveFunction
            , empty
            ]
            where
                postInstallFunction = text "post_install() {" <>
                    nest 4 (empty <$> text "${HS_DIR}/register.sh --verbose=0" <$>
                        text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$>
                    char '}'
                preUpgradeFunction = text "pre_upgrade() {" <>
                    nest 4 (empty <$> text "${HS_DIR}/unregister.sh --verbose=0") <$>
                    char '}'
                postUpgradeFunction = text "post_upgrade() {" <>
                    nest 4 (empty <$> text "${HS_DIR}/register.sh --verbose=0" <$>
                        text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$>
                    char '}'
                preRemoveFunction = text "pre_remove() {" <>
                    nest 4 (empty <$> text "${HS_DIR}/unregister.sh --verbose=0") <$>
                    char '}'
                postRemoveFunction = text "post_remove() {" <>
                    nest 4 (empty <$> text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$>
                    char '}'

-- {{{1 extra instances
instance Pretty Version where
    pretty (Version b _) = encloseSep empty empty (char '.') (map pretty b)

prettyFlag (FlagName n, True) = text n
prettyFlag (FlagName n, False) = text $ '-' : n

-- {{{1 translate
-- TODO:
--  • translation of extraLibDepends-libs to Arch packages
translate :: Version -> Int -> CblDB -> FlagAssignment -> PackageDescription -> ArchPkg
translate ghcVer ghcRel db fa pd = let
        ap = baseArchPkg
        (PackageName hkgName) = packageName pd
        pkgVer = packageVersion pd
        pkgRel = maybe 1 pkgRelease (lookupPkg db hkgName)
        xrev = show $ Util.Dist.pkgXRev pd
        hasLib = isJust (library pd)
        licFn = let l = licenseFiles pd in if null l then Nothing else Just (head l)
        archName = (if hasLib then "haskell-" else "") ++ map toLower hkgName
        pkgDesc = synopsis pd
        url = if null (homepage pd) then "http://hackage.haskell.org/package/${_hkgname}" else homepage pd
        lic = display (license pd)
        makeDepends = if hasLib then [] else ghcVersionDep ghcVer ghcRel : calcExactDeps db pd
        depends = if hasLib then ghcVersionDep ghcVer ghcRel : calcExactDeps db pd else []
        extraLibDepends = maybe [] (extraLibs . libBuildInfo) (library pd)
        install = if hasLib then apShInstall ap else Nothing
    in ap
        { apPkgName = archName
        , apHkgName = hkgName
        , apHasLibrary = hasLib
        , apLicenseFile = licFn
        , apShHkgName = shVarNewValue (apShHkgName ap) hkgName
        , apShPkgName = shVarNewValue (apShPkgName ap) archName
        , apShPkgVer = shVarNewValue (apShPkgVer ap) pkgVer
        , apShPkgRel = shVarNewValue (apShPkgRel ap) pkgRel
        , apShXRev = shVarNewValue (apShXRev ap) xrev
        , apShPkgDesc = shVarNewValue (apShPkgDesc ap) (ShQuotedString pkgDesc)
        , apShUrl = shVarNewValue (apShUrl ap) (ShQuotedString url)
        , apShLicence = shVarNewValue (apShLicence ap) (ShArray [lic])
        , apShMakeDepends = shVarNewValue (apShMakeDepends ap) (ShArray makeDepends)
        , apShDepends = shVarNewValue (apShDepends ap) (ShArray $ depends ++ extraLibDepends)
        , apShInstall = install
        , apFlags = fa
        }

-- Calculate exact dependencies based on the package in a CblDB.  We assume the
-- same db has been used to finalise the package so it's all right to use
-- fromJust.
-- TODO:
--  • this is most likely too simplistic to create the Arch package names
--  correctly for all possible dependencies
calcExactDeps db pd = map depString deps
    where
        remPkgs = map DB.pkgName (filter isGhcPkg db) ++ [pkgNameStr pd]
        deps = filter (not . (`elem` remPkgs)) (map depName (buildDepends pd))

        depString n = "haskell-" ++ name ++ "=" ++ ver ++ "_" ++ xrev ++ "-" ++ rel
            where
                pkg = fromJust $ lookupPkg db n
                name = map toLower $ DB.pkgName pkg
                ver = display $ DB.pkgVersion pkg
                xrev = show $ DB.pkgXRev pkg
                rel = show $ pkgRelease pkg

-- {{{1 stuff with patches
-- {{{2 addPatches
addPatches patchDir ap = let
        hkgName = apHkgName ap
        sources = apShSource ap
        fi tF fF v = if v then tF else fF
        cabalPatchFn = patchDir </> hkgName <.> "cabal"
        pkgbuildPatchFn = patchDir </> hkgName <.> "pkgbuild"
        installPatchFn = patchDir </> hkgName <.> "install"
        buildPatchFn = patchDir </> hkgName <.> "source"
    in do
        cabalPatch <- doesFileExist cabalPatchFn >>= fi (liftM Just $ canonicalizePath cabalPatchFn) (return Nothing)
        pkgBuildPatch <- doesFileExist pkgbuildPatchFn >>= fi (liftM Just $ canonicalizePath pkgbuildPatchFn) (return Nothing)
        installPatch <- doesFileExist installPatchFn >>= fi (liftM Just $ canonicalizePath installPatchFn) (return Nothing)
        buildPatch <- doesFileExist buildPatchFn >>= fi (liftM Just $ canonicalizePath buildPatchFn) (return Nothing)
        let sources' = shVarAppendValue sources
                (ShArray $ catMaybes [maybe Nothing (const $ Just "source.patch") buildPatch])
        return ap
            { apCabalPatch = cabalPatch
            , apPkgbuildPatch = pkgBuildPatch
            , apInstallPatch = installPatch
            , apBuildPatch = buildPatch
            , apShSource = sources'
            }

-- {{{2 copyPatches
copyPatches destDir ap = let
        cabalPatch = apCabalPatch ap
        buildPatch = apBuildPatch ap
    in do
        maybe (return ()) (\ fn -> copyFile fn (destDir </> "cabal.patch")) cabalPatch
        maybe (return ()) (\ fn -> copyFile fn (destDir </> "source.patch")) buildPatch

-- {{{1 addHashes
addHashes ap cbl tmpDir = let
        hashes = map (filter (`elem` "1234567890abcdef")) . lines . drop 11
        pkgbuildFn = tmpDir </> "PKGBUILD"
        cblFn = tmpDir </> "original.cabal"
        pkgbuildPatch = apPkgbuildPatch ap
    in do
        liftIO $ copyPatches tmpDir ap
        liftIO $ writeFile pkgbuildFn (show $ pretty ap)
        maybe (return ()) (void . applyPatch pkgbuildFn) pkgbuildPatch
        liftIO $ BSL.writeFile cblFn cbl
        (ec, out, _) <- liftIO $ withWorkingDirectory tmpDir (readProcessWithExitCode "makepkg" ["-g"] "")
        case ec of
            ExitFailure _ ->
                throwE $ "makepkg: error while calculating the source hashes for " ++ apHkgName ap
            ExitSuccess ->
                return (if "sha256sums=(" `isPrefixOf` out then replaced else ap)
                    where
                        replaced = ap { apShSha256Sums = shVarNewValue (apShSha256Sums ap) (ShArray $ hashes out) }