bumper-0.5: src/Package.hs

-- * Contains helper functions to load and manipulate .cabal files
{-# LANGUAGE
    TypeOperators
  , TemplateHaskell
  , TupleSections
  #-}
module Package where

import Prelude hiding (readFile)

import Control.Applicative
import Control.Monad
import Data.Label
import Data.List
import Data.List.Split
import Data.Maybe
import Data.Version
import Distribution.Package hiding (Package)
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse
import Distribution.Text
import Distribution.Verbosity
import System.IO.Strict
import System.Process
import Text.Regex
import Version
import qualified Data.Map as M

data Package = Package
    { _name         :: PackageName
    , _path         :: String
    , _version      :: Version
    , _dependencies :: [Dependency]
    } deriving (Show, Eq)

$(mkLabels [''Package])

type Packages = [Package]

-- | Helper functions

lookupPackage :: PackageName -> Packages -> Maybe Package
lookupPackage s = find ((== s) . _name)

lookupPackages ::  [PackageName] -> Packages -> Packages
lookupPackages ns ps = catMaybes . map (flip lookupPackage ps) $ ns

hasPackage :: PackageName -> Packages -> Bool
hasPackage n = isJust . lookupPackage n

removePackage :: PackageName -> Packages -> Packages
removePackage s = filter ((/= s). _name)

removeAll :: [PackageName] -> Packages -> Packages
removeAll = flip $ foldr removePackage

-- | Loading packages
packages :: IO Packages
packages =
  do (_, hOut, _, _) <- runInteractiveCommand "find . -name *.cabal -type f"
     paths <- lines <$> hGetContents hOut
     forM paths $ \p ->
        do pkg <- flattenPackageDescription `liftM` readPackageDescription normal p
           return $ Package
                      { _name = pkgName $ package pkg
                      , _path = p
                      , _version = pkgVersion $ package pkg
                      , _dependencies = buildDepends pkg
                      }

getBaseVersions :: String -> Packages -> IO Packages
getBaseVersions ind ps =
 do (_, hOut, _, _) <- runInteractiveCommand $ "tar -tf " ++ ind
    gps <- lines <$> hGetContents hOut
    let vs = catMaybes $ map (parseVer . splitOn "/") gps
        parseVer (n:v:_) = fmap (PackageName n, ) $ simpleParse v
        parseVer _       = Nothing
        globver = M.fromListWith (\a b -> if a > b then a else b) vs
        updVer p = modify version (maybe id (\v -> if get version p < v then const v else id) $ M.lookup (_name p) globver) p
    return $ map updVer ps

-- | Manipulating package contents
whiteReg :: String
whiteReg = "[ \n\t]*"

modifyVersion :: Version -> String -> String
modifyVersion v s = subRegex (mkRegexWithOpts regex False False) s result
  where regex = "(version" ++ whiteReg ++ ":" ++ whiteReg ++ ") ([0-9.a-zA-Z]+)"
        result = "\\1 " ++ display v

modifyDependency :: Dependency -> String -> String
modifyDependency (Dependency nm range) s = subRegex (mkRegexWithOpts regex False False) s result
  where regex = "(build-depends" ++ whiteReg ++ ":" ++ "[^:]*"
              ++ "[ ,\n\t]" ++ display nm ++ whiteReg ++ ")[, ]([" ++ rangeChar ++ " \t\n]*[" ++ rangeChar ++ "])"
        rangeChar = "0-9.*&|()<>="
        result = "\\1 " ++ printRange range

-- | Data structure containing package modifications
type PackageChanges = (Maybe Version, [Dependency])

-- | Writing to packages
modifyPackage :: PackageChanges -> String -> String
modifyPackage (mv, deps) = flip (foldr modifyDependency) deps
                         . maybe id modifyVersion mv

updatePackage :: Package -> PackageChanges -> IO ()
updatePackage p ch = readFile (get path p) >>= writeFile (get path p) . modifyPackage ch