{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Module    : Distribution.ArchLinux.PkgBuild
-- Copyright : (c) Don Stewart, 2008-2010
-- License   : BSD3
--
-- Maintainer: Don Stewart <dons@galois.com>
--

module Distribution.ArchLinux.PkgBuild (
         PkgBuild(..),
         emptyPkgBuild,
         AnnotatedPkgBuild(..),
         emptyPkg,
         ArchList(..),
         ArchDep(..),
         pkgnameFromArchDep,
         decodePackage,
         pkg2doc
       ) where

import Distribution.Text
import Distribution.Version
import Distribution.PackageDescription
import Distribution.Package
import Distribution.License

import Text.PrettyPrint
import Data.List
import Data.Monoid
import Debug.Trace

import Control.Monad
import Control.Monad.Instances
import Data.Char


--
-- | A data type to represent PKGBUILD files
--
data PkgBuild =
  PkgBuild
    { arch_pkgname :: String
        -- ^
        -- The name of the package. This has be a unix-friendly name
        -- as it will be used in the package filename.
    , arch_pkgver  :: Version
        -- ^ The version of the software as released from the authorii
        --  (e.g. ´2.7.1´).
    , arch_pkgrel  :: !Int
        -- ^
        --  This is the release number specific to the Arch Linux
        -- release. This allows package maintainers to make updates to
        -- the package´s configure flags, for example. A pkgrel of 1
        -- is typically used for each upstream software release and is
        -- incremented for intermediate PKGBUILD updates.
    , arch_pkgdesc :: String
        -- ^
        -- This should be a brief description of the package and its
        -- functionality. Try to keep the description to one line of text.
    , arch_arch    :: ArchList ArchArch
        -- ^
        -- Defines on which architectures the given package is
        -- available (e.g. arch=(´i686´ ´x86_64´)).
    , arch_url     :: String
        -- ^
        -- This field contains a URL that is associated with the software
        -- being packaged. This is typically the project´s website.
    , arch_license :: ArchList License
        -- ^
        -- This field specifies the license(s) that apply to the package.
        -- Commonly-used licenses are found in /usr/share/licenses/common. If
        -- you see the package´s license there, simply reference it in the
        -- license field (e.g.  license=(´GPL´)). If the package provides a
        -- license not found in /usr/share/licenses/common, then you should
        -- include the license in the package itself and set
        -- license=(´custom´) or license=(´custom:LicenseName´). The license
        -- should be placed in $pkgdir/usr/share/licenses/$pkgname when
        -- building the package. If multiple licenses are applicable for a
        -- package, list all of them: license=(´GPL´ ´FDL´).
    , arch_makedepends :: ArchList ArchDep
        -- ^
        -- An array of packages that this package depends on to build, but are
        -- not needed at runtime. Packages in this list follow the same format
        -- as depends.

    , arch_depends     :: ArchList ArchDep
        -- ^
        -- An array of packages that this package depends on to run. Packages
        -- in this list should be surrounded with single quotes and contain at
        -- least the package name. Entries can also include a version
        -- requirement of the form name<>version, where <> is one of five
        -- comparisons: >= (greater than or equal to), <= (less than or equal
        -- to), = (equal to), > (greater than), or < (less than).
    , arch_source      :: ArchList String
        -- ^
        -- An array of source files required to build the package. Source
        -- files must either reside in the same directory as the PKGBUILD
        -- file, or be a fully-qualified URL that makepkg will use to download
        -- the file. In order to make the PKGBUILD as useful as possible, use
        -- the $pkgname and $pkgver variables if possible when specifying the
        -- download location. Any files that are compressed will automatically
        -- be extracted, unless found in the noextract array listed below.
    , arch_md5sum      :: ArchList String
        -- ^
        -- This array contains an MD5 hash for every source file specified in
        -- the source array (in the same order). makepkg will use this to
        -- verify source file integrity during subsequent builds. To easily
        -- generate md5sums, run “makepkg -g >> PKGBUILD”. If desired, move
        -- the md5sums line to an appropriate location.  NOTE: makepkg
        -- supports multiple integrity algorithms and their corresponding
        -- arrays (i.e. sha1sums for the SHA1 algorithm); however, official
        -- packages use only md5sums for the time being.
    , arch_build        :: [String]
        -- ^
        -- The build hook
    , arch_package        :: [String]
        -- ^
        -- The packaging hook
    , arch_install      :: Maybe String
        -- ^
        -- Specifies a special install script that is to be included in the package. This
        -- file should reside in the same directory as the PKGBUILD, and will be copied
        -- into the package by makepkg. It does not need to be included in the source
        -- array (e.g.  install=pkgname.install).
            --
    , arch_options      :: ArchList ArchOptions
        -- ^
        -- This array allows you to override some of makepkg´s default behavior when
        -- building packages. To set an option, just include the option name in the
        -- options array. To reverse the default behavior, place an “!” at the front of
        -- the option. Only specify the options you specifically want to override, the
        -- rest will be taken from makepkg.conf(5).  NOTE: force is a special option only
        -- used in a PKGBUILD(5), do not use it unless you know what you are doing.

    }
    deriving (Show, Eq)

data ArchOptions
    = Strip
    deriving (Show, Eq)

--
-- | An empty PKGBUILD
--
emptyPkgBuild :: PkgBuild
emptyPkgBuild =
  PkgBuild
    { arch_pkgname     = display $ pkgName (package e)
    , arch_pkgver      = pkgVersion (package e)
    , arch_pkgrel      = 1
    , arch_pkgdesc     = synopsis e
    , arch_arch        = ArchList [Arch_X86, Arch_X86_64]
    , arch_url         = homepage e
    , arch_license     = ArchList [license e]
    , arch_depends     = ArchList []
    , arch_makedepends = ArchList []
    , arch_source      = ArchList []
    , arch_md5sum      = ArchList []
        -- sha1sums=('a08670e4c749850714205f425cb460ed5a0a56b2')
    , arch_build       = []
    , arch_package     = []
    , arch_install     = Nothing  -- executable
    , arch_options     = ArchList [Strip]
    }
  where
    e = emptyPackageDescription

------------------------------------------------------------------------
-- Extra pretty printer instances and types

newtype ArchDep = ArchDep Dependency
  deriving (Eq,Show)

instance Text ArchOptions where
  disp Strip = text "strip"
  parse = undefined

-- the PKGBUILD version spec is less expressive than cabal, we can
-- only handle simple intervals like (0,v) or (v,+infty)
mydisp :: VersionInterval -> Doc
mydisp (LowerBound v t, NoUpperBound) =
    case t of
        InclusiveBound -> if v==zeroVersion then empty else text ">=" <> disp v
        ExclusiveBound -> text ">" <> disp v
mydisp (LowerBound v1 _, UpperBound v2 t2) = text symbol <> disp v2
    where symbol | v1 == v2             = "="
                 | t2 == InclusiveBound = "<="
                 | t2 == ExclusiveBound = "<"

zeroVersion :: Version
zeroVersion = Version [0] []

instance Text ArchDep where
  disp (ArchDep (Dependency name ver)) =
    disp name <> mydisp (collapse intervals)
   where
      intervals = asVersionIntervals ver
      strName = display name
     --  >= (greater than or equal to), <= (less than or
     --  equal to), = (equal to), > (greater than), or <
     --
     --  Reduce intervals to a single one
      collapse l | null l        = trace ("WARNING: version requirement for " ++
                                       strName ++ " is logically impossible.")
                                       (head $ asVersionIntervals anyVersion)
                 | null $ tail l = head l
                 -- If there are multiple possible ranges, take the interval that contains all
                 | otherwise     = trace ("WARNING: multiple version ranges specified for " ++
                                       strName ++ ", using the extremal bounds instead.")
                                       (fst $ head l, snd $ last l)
  parse = undefined

--
-- | Extract just the package name from ArchDep
--
pkgnameFromArchDep :: ArchDep -> String
pkgnameFromArchDep (ArchDep (Dependency (PackageName p) _)) = p

--
-- | Valid linux platforms
--
data ArchArch = Arch_X86 | Arch_X86_64
    deriving (Show, Eq)

instance Text ArchArch where
    disp x = case x of
       Arch_X86      -> text "i686"
       Arch_X86_64   -> text "x86_64"
    parse = error "Text.parrse not defined for ArchList"

-- Lists with quotes
newtype ArchList a = ArchList [a]
  deriving (Show, Eq, Monoid, Functor)

instance Text String where
    disp s = text s
    parse = error "Text.parse not defined for String"

instance Text a => Text (ArchList a) where
    disp (ArchList xs) =
         parens (hcat
                (intersperse space
                    (map (quotes . disp) xs)))
    parse = error "Text.parse not defined for ArchList"

-- | Printing with no quotes
dispNoQuotes :: Text a => ArchList a -> Doc
dispNoQuotes (ArchList xs) =
         parens (hcat
                (intersperse space
                    (map disp xs)))


------------------------------------------------------------------------
-- Support for parsing PKGBULIDs

-- | A PKGBUILD data structure with additional metadata
data AnnotatedPkgBuild =
     AnnotatedPkgBuild
        {pkgBuiltWith :: Maybe Version   -- ^ version of cabal2arch used, if any
        ,pkgHeader    :: String          -- ^ header strings
        ,hkgName      :: String          -- ^ package name on Hackage
        ,pkgBody      :: PkgBuild }      -- ^ contents of pkgbuild file
    deriving (Eq, Show)

-- | Empty state structure
emptyPkg :: AnnotatedPkgBuild
emptyPkg = AnnotatedPkgBuild
    { pkgBuiltWith = Nothing
    , pkgHeader    = []
    , hkgName      = []
    , pkgBody      = emptyPkgBuild { arch_options = ArchList []
                                , arch_makedepends = ArchList []
                                }
    }

-- | Result type for pkgbuild parsers
type ResultP a = Either String a

decodePackage :: String -> ResultP AnnotatedPkgBuild
decodePackage s = runGetPKG (readPackage emptyPkg) s

-- | The type of pkgbuild parsers for String
newtype GetPKG a = GetPKG { un :: String -> Either String (a,String) }

instance Functor GetPKG where fmap = liftM

instance Monad GetPKG where
  return x       = GetPKG (\s -> Right (x,s))
  fail x         = GetPKG (\_ -> Left x)
  GetPKG m >>= f = GetPKG (\s -> case m s of
                                     Left err -> Left err
                                     Right (a,s1) -> un (f a) s1)

------------------------------------------------------------------------

-- | Run a PKG reader on an input String, returning a PKGBUILD
runGetPKG :: GetPKG a -> String -> ResultP a
runGetPKG (GetPKG m) s = case m s of
     Left err    -> Left err
     Right (a,t) -> case t of
                        [] -> Right a
                        _  -> Left $ "Invalid tokens at end of PKG string: "++ show (take 10 t)

getInput   :: GetPKG String
getInput    = GetPKG (\s -> Right (s,s))

setInput   :: String -> GetPKG ()
setInput s  = GetPKG (\_ -> Right ((),s))

-- 2010-10-29: This code is unused. Do we still need it?
-- (<$>) :: Functor f => (a -> b) -> f a -> f b
-- x <$> y = fmap x y

------------------------------------------------------------------------

-- read until end of line
line :: String -> GetPKG String
line s = case break (== '\n') s of
    (h , _ : rest) -> do
        setInput rest
        return h

-- | Recursively parse the pkgbuild
--
readPackage :: AnnotatedPkgBuild -> GetPKG AnnotatedPkgBuild
readPackage st = do
  cs <- getInput

  case cs of
    _ | "# Maintainer"       `isPrefixOf` cs -> do
            h <- line cs
            readPackage st { pkgHeader = h }

      | "# Package generated" `isPrefixOf` cs -> do
            h <- line cs
            let v = simpleParse
                    . reverse
                    . takeWhile (not . isSpace)
                    . reverse $ h
            readPackage st { pkgBuiltWith = v }

      | "_hkgname="  `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 9 h
            readPackage st { hkgName = s }

      | "pkgname="  `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 8 h
            readPackage st { pkgBody = (pkgBody st) { arch_pkgname = s } }

      | "pkgrel="   `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 7 h
            readPackage st { pkgBody = (pkgBody st) { arch_pkgrel = read s } }

      | "pkgver="   `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 7 h
            case simpleParse s of
                Nothing -> fail $ "Unable to parse package version"
                Just v  -> readPackage st { pkgBody = (pkgBody st) { arch_pkgver = v } }

      | "pkgdesc="  `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 8 h
            readPackage st { pkgBody = (pkgBody st) { arch_pkgdesc = s } }

      | "url="      `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 4 h
            readPackage st { pkgBody = (pkgBody st) { arch_url = s } }

      | "license="  `isPrefixOf` cs -> do
            h <- line cs
            let s = takeWhile (/= '\'')
                    . drop 1
                    . dropWhile (/= '\'')
                    . drop 8 $ h
                s' | "custom:" `isPrefixOf` s = drop 7 s
                   | otherwise                = s

            case simpleParse s' of
                Nothing -> readPackage st { pkgBody = (pkgBody st) { arch_license = ArchList [UnknownLicense s'] } }
                Just l  -> readPackage st { pkgBody = (pkgBody st) { arch_license = ArchList [l] } }

      | "depends=("  `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 9 h
            readPackage st { pkgBody = (pkgBody st) { arch_depends = readDepends s } }

      | "makedepends=("  `isPrefixOf` cs -> do
            h <- line cs
            let s = drop 13 h
            readPackage st { pkgBody = (pkgBody st) { arch_makedepends = readDepends s } }

    -- do these later:

      | "arch="     `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st
      | "options="  `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st
      | "source="   `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st
      | "install="  `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st
      | "md5sums="  `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st
      | "build()"   `isPrefixOf` cs
            -> do setInput [] ; return st
      | "package()"  `isPrefixOf` cs
            -> do setInput [] ; return st

    -- skip comments
      | "#" `isPrefixOf` cs
            -> do _ <- line cs ; readPackage st

      | otherwise -> fail $ "Malformed PKGBUILD: " ++ take 80 cs

--
-- | Read a quoted list of depends
--
readDepends :: String -> ArchList ArchDep
readDepends s =
  let s1 = dropWhile (\x -> x `elem` "' )") s
    in case s1 of
      "" -> ArchList []
      _ -> ArchList (d:ds)
        where dep = takeWhile (\x -> x `notElem` "' ") s1
              -- end of the dep field
              s2 = dropWhile (\x -> x `notElem` "' ") s1
              s3 = dropWhile (\x -> x `elem` "' ") s2
              d = str2archdep dep
              ArchList ds = readDepends s3

-- TODO : read version spec
str2archdep :: String -> ArchDep
str2archdep s = case v of
    Nothing -> ArchDep (Dependency (PackageName name) anyVersion)
    Just w -> ArchDep (Dependency (PackageName name) w)
  where name = takeWhile (\x -> x `notElem` "<=>") s
        vspec = dropWhile (\x -> x `notElem` "<=>") s
        v = simpleParse vspec

------------------------------------------------------------------------
-- Pretty printing:

--
-- | Translate an abstract PkgBuild file into a document structure
--

(<=>) :: Doc -> Doc -> Doc
x <=> y = x <> char '=' <> y

--
-- Print a PKGBUILD without comments
--
rawpkg2doc :: PkgBuild -> Doc
rawpkg2doc pkg = vcat
 [ text "pkgname"
    <=> text (arch_pkgname pkg)
 , text "pkgver"
    <=> disp (arch_pkgver pkg)
 , text "pkgrel"
    <=> int (arch_pkgrel pkg)
 , text "pkgdesc"
    <=> doubleQuotes (text $ escapeForBash $ arch_pkgdesc pkg)
 , text "url"
    <=> doubleQuotes (text (arch_url pkg))
 , text "license"
    <=> disp (arch_license pkg)
 , text "arch"
    <=> disp (arch_arch pkg)
 , text "makedepends"
    <=> disp (arch_makedepends pkg)
 , case arch_depends pkg of
        ArchList [] -> empty
        ArchList xs -> text "depends" <=> disp (ArchList (nub xs))
 , text "options" <=> disp (arch_options pkg)
 , text "source"
    <=> dispNoQuotes (arch_source pkg)
 , case arch_install pkg of
    Nothing -> empty
    Just p  -> text "install" <=> disp p
 , text "md5sums"
    <=> disp (arch_md5sum pkg)
 , hang
    (text "build() {") 4
             (vcat $ (map text) (arch_build pkg))
   $$ char '}'
 , hang
    (text "package() {") 4
             (vcat $ (map text) (arch_package pkg))
   $$ char '}'
 ]

--
-- | Helper function to escape strings for PKGBUILDs
--
escapeForBash :: String -> String
escapeForBash = concatMap escapeCharForBash

escapeCharForBash :: Char -> String
escapeCharForBash c = case c of
 '$'  ->  "\\$"
 '`'  -> "\\`"
 '"'  -> "\\\""
 '\\' -> "\\\\"
 '\n' -> " "
 x    -> [x]

instance Text PkgBuild where
  disp p = rawpkg2doc p
  parse = undefined

--
-- Display a PKGBUILD with header
--
instance Text AnnotatedPkgBuild where
  disp AnnotatedPkgBuild {
    pkgBuiltWith = ver,
    pkgHeader = header,
    hkgName = hkg,
    pkgBody = pkg
  } = vcat [ if null header then empty else text header
           , text "_hkgname" <=> text hkg
           , disp pkg ]
  parse = undefined

--
-- Display a full PKGBUILD with Maintainer name.
--
pkg2doc :: String -> AnnotatedPkgBuild -> Doc
pkg2doc email pkg = text "# Maintainer:" <+> text email $$ disp pkg