hub-1.0.0: Hub/PackageDB.hs
--
-- >>> Hub.PackageDB <<<
--
-- Sometimes the hub has to tangle with the Package DB format (mostly hub
-- erase): this package provides the tools.
--
-- (c) 2011-2012 Chris Dornan
module Hub.PackageDB
( PkgNick(..)
, PkgName
, PkgVrsn
, PkgHash
, iden2nick
, parsePkgNick
, parsePkgNick'
, prettyPkgNick
, eraseClosure
, importLibraryDirs
, PkgIden(..)
, Package(..)
, packageDB
, DepGraph(..)
, dep_graph
) where
import Data.Char
import Data.List
import Data.Array
import qualified Data.Map as Map
import Data.Graph.Inductive
import Text.Printf
import System.Directory
import Hub.System
import Hub.Oops
import Hub.Prog
import Hub.Hub
-- Package as identified on the CL
data PkgNick = PKN
{ namePKN :: PkgName
, vrsnPKN :: Maybe PkgVrsn
} deriving (Eq,Ord,Show)
-- Fully qualified package as referenced in a package configuration file.
data PkgIden = PKI
{ namePKI :: PkgName
, vrsnPKI :: PkgVrsn
, idenPKI :: PkgHash
} deriving (Eq,Ord,Show)
type PkgName = String
type PkgVrsn = String
type PkgHash = String
iden2nick :: PkgIden -> PkgNick
iden2nick pki = PKN (namePKI pki) (Just $ vrsnPKI pki)
eraseClosure :: Hub -> [PkgNick] -> IO ([PkgNick],[PkgNick])
eraseClosure hub pkns =
do pdb <- packageDB hub
pkis <- mapM (resolve_pkg_nick pdb) pkns
return (map pki2pkn pkis,map pki2pkn $ erase_deps pdb pkis)
importLibraryDirs :: Hub -> IO [FilePath]
importLibraryDirs hub =
do pdb <- packageDB hub
return $ usort $ concat $ map dirs $ Map.elems pdb
where
dirs pkg = import_dirsPKG pkg ++ library_dirsPKG pkg
parsePkgNick :: String -> IO PkgNick
parsePkgNick s = maybe fl return $ parsePkgNick' s
where
fl = oops HubO $ printf "%s: invalid package name" s
parsePkgNick' :: String -> Maybe PkgNick
parsePkgNick' s =
case is_val of
True | is_vr -> Just $ PKN nm (Just vr)
| otherwise -> Just $ PKN s Nothing
False -> Nothing
where
is_val = case s of
[] -> False
c:cs -> fval_c c && all sval_c cs
is_vr = not (null nm) && not (null vr) && all vr_c vr
nm = reverse r_nm
vr = reverse r_vr
r_nm = cl_d rst2
(r_vr,rst2) = break ('-'==) $ reverse s
cl_d ('-':t) = t
cl_d x = x
vr_c '.' = True
vr_c c = isDigit c
fval_c c = isAlpha c || c=='_'
sval_c c = isAlpha c || isDigit c || c `elem` "-_.=+#~"
prettyPkgNick :: PkgNick -> String
prettyPkgNick pkn =
case vrsnPKN pkn of
Nothing -> namePKN pkn
Just vr -> printf "%s-%s" (namePKN pkn) vr
pki2pkn :: PkgIden -> PkgNick
pki2pkn pki = PKN (namePKI pki) (Just(vrsnPKI pki))
--
-- Calculating the Erase Dependencies
--
erase_deps :: PackageDB -> [PkgIden] -> [PkgIden]
erase_deps pdb pkis = map v2pki $ (\\ vs) $ usort $ concat $ map (pre gr) vs
where
vs = [ v | Just v<-map pki2mbv pkis ]
pki2mbv = flip Map.lookup $ assgnDG dg
v2pki = (arrayDG dg!)
gr = trc $ graphDG dg
dg = dep_graph pdb
usort :: Ord a => [a] -> [a]
usort = foldr no_dups [] . sort
where
no_dups x [] = [x]
no_dups x (x':xs) = if x==x' then x:xs else x:x':xs
--
-- Building the Dependency Graph
--
data DepGraph = DG
{ assgnDG :: Map.Map PkgIden Int
, arrayDG :: Array Int PkgIden
, graphDG :: Gr PkgIden ()
} deriving (Show)
dep_graph :: PackageDB -> DepGraph
dep_graph pdb = DG asgn arry (mkGraph ndes edgs)
where
ndes = map (\(x,y)->(y,x)) $ Map.toList asgn
edgs = [ (x',y',()) | (x,y)<-deps,
Just x'<-[Map.lookup x asgn],
Just y'<-[Map.lookup y asgn] ]
deps = [ (idPKG pkg,dep) | pkg<-Map.elems pdb, dep<-dependsPKG pkg ]
arry = listArray (0,Map.size asgn-1) $ Map.keys asgn
asgn = Map.fromList $ zip (sort $ Map.keys pdb) [0..]
--
-- Resolving Package Nicks into Package Ids
--
resolve_pkg_nick :: PackageDB -> PkgNick -> IO PkgIden
resolve_pkg_nick pdb pkn =
case match_pkg_nick pdb pkn of
[] -> oops HubO $ printf "%s: does not match any user packages in the hub" $ prettyPkgNick pkn
[pki] -> return pki
_ -> oops HubO $ printf "%s: matches multiple user packages in the hub" $ prettyPkgNick pkn
match_pkg_nick :: PackageDB -> PkgNick -> [PkgIden]
match_pkg_nick pdb pkn =
[ pki | pki <- Map.keys pdb,
namePKN pkn==namePKI pki
&& maybe True (==vrsnPKI pki) (vrsnPKN pkn)]
--
-- Reconstructing the Package DB
--
type PackageDB = Map.Map PkgIden Package
data Package = PKG
{ idPKG :: PkgIden
, import_dirsPKG :: [FilePath]
, library_dirsPKG :: [FilePath]
, dependsPKG :: [PkgIden]
} deriving (Show)
packageDB :: Hub -> IO PackageDB
packageDB hub =
do cts <- package_dump hub
return $ packages [ package $ record rec | rec<-records cts ]
package_dump :: Hub -> IO String
package_dump hub =
do tf <- tmpFile "pkg-dump.txt"
let ee = EE (RedirctRS tf) DiscardRS []
execP HubO ee UserMDE hub Ghc_pkgP ["dump"]
ct <- readAFile tf
removeFile tf
return ct
packages :: [Package] -> Map.Map PkgIden Package
packages pkgs = Map.fromList [(idPKG pkg,pkg) | pkg<-pkgs ]
package :: Map.Map String [String] -> Package
package mp = PKG
(s2pr (lu "id" sgl))
(lu "import-dirs" lst)
(lu "library-dirs" lst)
(lu "depends" prs)
where
lu ky f = f $ Map.lookup ky mp
sgl Nothing = ""
sgl (Just lns) = trim $ unlines lns
lst Nothing = []
lst (Just lns) = map trim lns
prs Nothing = []
prs (Just lns) = map (s2pr . trim) lns
s2pr :: String -> PkgIden
s2pr s = PKI (reverse r_nm) (reverse r_vr) (reverse r_hs)
where
r_nm = cl_d rst2
(r_vr,rst2) = break ('-'==) $ cl_d rst1
(r_hs,rst1) = break ('-'==) $ reverse s
cl_d ('-':t) = t
cl_d x = x
records :: String -> [[String]]
records cts = rec [] $ lines cts
where
rec acc [] = [ reverse acc | not $ null acc ]
rec acc (ln:lns) =
case ln of
"" -> rec acc lns
_ | ln=="---" -> reverse acc:rec [] lns
| otherwise -> rec (ln:acc) lns
record :: [String] -> Map.Map String [String]
record lns = Map.fromList $ fields lns
fields :: [String] -> [(String,[String])]
fields [] = []
fields (ln:lns) = (tag,rst:cnt):fields lns'
where
(tag,rst) = case words ln of
[] -> ("","")
w:ws -> (cln w,unwords ws)
(cnt,lns') = span chk lns
chk [] = False
chk (c:_) = isSpace c
cln tg = case reverse tg of
':':r_tg -> reverse r_tg
_ -> tg