module Ho.Library(
LibDesc(..),
readDescFile,
collectLibraries,
libModMap,
libHash,
libMgHash,
libProvides,
libName,
libBaseName,
libHoLib,
preprocess,
listLibraries
) where
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Version
import Data.Yaml.Syck
import System.Directory
import Text.Printf
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified System.FilePath as FP
import Ho.Binary
import Ho.ReadSource
import Ho.Type
import Name.Name(Module)
import Options
import PackedString(PackedString,packString,unpackPS)
import Util.Gen
import Util.YAML
import qualified FlagDump as FD
import qualified FlagOpts as FO
import qualified Support.MD5 as MD5
libModMap = hoModuleMap . libHoLib
libHash = hohHash . libHoHeader
libMgHash mg lib = MD5.md5String $ show (libHash lib,mg)
libProvides mg lib = [ m | (m,mg') <- Map.toList (libModMap lib), mg == mg']
libName lib = let HoHeader { hohName = ~(Right (name,vers)) } = libHoHeader lib in unpackPS name ++ "-" ++ showVersion vers
libVersion lib = let HoHeader { hohName = ~(Right (_name,vers)) } = libHoHeader lib in vers
libBaseName lib = let HoHeader { hohName = ~(Right (name,_vers)) } = libHoHeader lib in name
libModules l = let lib = libHoLib l in ([ m | (m,_) <- Map.toList (hoModuleMap lib)],Map.toList (hoReexports lib))
libVersionCompare l1 l2 = compare (libVersion l1) (libVersion l2)
instance ToNode Module where
toNode m = toNode $ show m
instance ToNode HoHash where
toNode m = toNode $ show m
instance ToNode PackedString where
toNode m = toNode $ unpackPS m
listLibraries :: IO ()
listLibraries = do
(_,byhashes) <- fetchAllLibraries
let libs = Map.toList byhashes
if not verbose then putStr $ showYAML (sort $ map (libName . snd) libs) else do
let f (h,l) = (show h,[
("Name",toNode (libName l)),
("BaseName",toNode (libBaseName l)),
("Version",toNode (showVersion $ libVersion l)),
("FilePath",toNode (libFileName l)),
("LibDeps",toNode [ h | (_,h) <- hohLibDeps (libHoHeader l)]),
("Exported-Modules",toNode $ mod ++ fsts rmod)
]) where
(mod,rmod) = libModules l
putStr $ showYAML (map f libs)
fetchAllLibraries :: IO (Map.Map PackedString [Library],Map.Map HoHash Library)
fetchAllLibraries = ans where
ans = do
(bynames',byhashes') <- unzip `fmap` concatMapM f (optHlPath options)
let bynames = Map.map (reverse . sortBy libVersionCompare) $ Map.unionsWith (++) bynames'
byhashes = Map.unions byhashes'
return (bynames,byhashes)
f fp = do
fs <- flip iocatch (\_ -> return [] ) $ getDirectoryContents fp
forM fs $ \e -> case reverse e of
('l':'h':'.':r) -> flip iocatch (\_ -> return mempty) $ do
lib <- readHlFile (fp ++ "/" ++ e)
return (Map.singleton (libBaseName lib) [lib], Map.singleton (libHash lib) lib)
_ -> return mempty
splitOn' :: (a -> Bool) -> [a] -> [[a]]
splitOn' f xs = split xs
where split xs = case break f xs of
(chunk,[]) -> [chunk]
(chunk,_:rest) -> chunk : split rest
splitVersion :: String -> (String,Data.Version.Version)
splitVersion s = ans where
ans = case reverse (splitOn' ('-' ==) s) of
(vrs:bs@(_:_)) | Just vrs <- runReadP parseVersion vrs -> (intercalate "-" (reverse bs),vrs)
_ -> (s,Data.Version.Version [] [])
collectLibraries :: [String] -> IO ([Library],[Library])
collectLibraries libs = ans where
ans = do
(bynames,byhashes) <- fetchAllLibraries
let f (pn,vrs) = lname pn vrs `mplus` lhash pn vrs where
lname pn vrs = do
xs <- Map.lookup (packString pn) bynames
(x:_) <- return $ filter isGood xs
return x
isGood lib = versionBranch vrs `isPrefixOf` versionBranch (libVersion lib)
lhash pn vrs = do
[] <- return $ versionBranch vrs
Map.lookup pn byhashes'
byhashes' = Map.fromList [ (show x,y) | (x,y) <- Map.toList byhashes]
let es' = [ (x,f $ splitVersion x) | x <- libs ]
es = [ l | (_,Just l) <- es' ]
bad = [ n | (n,Nothing) <- es' ]
unless (null bad) $ do
putErrLn "Libraries not found:"
forM_ bad $ \b -> putErrLn (" " ++ b)
exitFailure
checkForModuleConficts es
let f lmap _ [] = return lmap
f lmap lset ((ei,l):ls)
| libHash l `Set.member` lset = f lmap lset ls
| otherwise = case Map.lookup (libBaseName l) lmap of
Nothing -> f (Map.insert (libBaseName l) (ei,l) lmap) (Set.insert (libHash l) lset) (ls ++ newdeps)
Just (ei',l') | libHash l == libHash l' -> f (Map.insert (libBaseName l) (ei || ei',l) lmap) lset ls
Just (_,l') -> putErrDie $ printf "Conflicting versions of library '%s' are required. [%s]\n" (libName l) (show (libHash l,libHash l'))
where newdeps = [ (False,fromMaybe (error $ printf "Dependency '%s' with hash '%s' needed by '%s' was not found" (unpackPS p) (show h) (libName l)) (Map.lookup h byhashes)) | let HoHeader { hohLibDeps = ldeps } = libHoHeader l , (p,h) <- ldeps ]
finalmap <- f Map.empty Set.empty [ (True,l) | l <- es ]
checkForModuleConficts [ l | (_,l) <- Map.elems finalmap ]
when verbose $ forM_ (Map.toList finalmap) $ \ (n,(e,l)) ->
printf "-- Base: %s Exported: %s Hash: %s Name: %s\n" (unpackPS n) (show e) (show $ libHash l) (libName l)
return ([ l | (True,l) <- Map.elems finalmap ],[ l | (False,l) <- Map.elems finalmap ])
checkForModuleConficts ms = do
let mbad = Map.toList $ Map.filter (\c -> case c of [_] -> False; _ -> True) $ Map.fromListWith (++) [ (m,[l]) | l <- ms, m <- fst $ libModules l]
forM_ mbad $ \ (m,l) -> putErrLn $ printf "Module '%s' is exported by multiple libraries: %s" (show m) (show $ map libName l)
unless (null mbad) $ putErrDie "There were conflicting modules!"
parseLibraryDescription :: Monad m => String -> m [(String,String)]
parseLibraryDescription fs = g [] (lines (f [] fs)) where
f rs ('-':'-':xs) = f rs (dropWhile (/= '\n') xs)
f rs ('{':'-':xs) = eatCom rs xs
f rs (x:xs) = f (x:rs) xs
f rs [] = reverse rs
eatCom rs ('\n':xs) = eatCom ('\n':rs) xs
eatCom rs ('-':'}':xs) = f rs xs
eatCom rs (_:xs) = eatCom rs xs
eatCom rs [] = f rs []
g rs (s:ss) | all isSpace s = g rs ss
g rs (s:s':ss) | all isSpace s' = g rs (s:ss)
g rs (s:(h:cl):ss) | isSpace h = g rs ((s ++ h:cl):ss)
g rs (r:ss) | (':':bd') <- bd = g ((map toLower $ condenseWhitespace nm,condenseWhitespace bd'):rs) ss
| otherwise = fail $ "could not find ':' marker: " ++ show (rs,r:ss) where
(nm,bd) = break (== ':') r
g rs [] = return rs
condenseWhitespace xs = reverse $ dropWhile isSpace (reverse (dropWhile isSpace (cw xs))) where
cw (x:y:zs) | isSpace x && isSpace y = cw (' ':zs)
cw (x:xs) = x:cw xs
cw [] = []
procCabal :: [(String,String)] -> LibDesc
procCabal xs = f xs mempty mempty where
f [] dlm dsm = LibDesc (combineAliases dlm) dsm
f ((map toLower -> x,y):rs) dlm dsm | x `Set.member` list_fields = f rs (Map.insert x (spit y) dlm) dsm
| otherwise = f rs dlm (Map.insert x y dsm)
spit = words . map (\c -> if c == ',' then ' ' else c)
procYaml :: YamlNode -> LibDesc
procYaml MkNode { n_elem = EMap ms } = f ms mempty mempty where
f [] dlm dsm = LibDesc (combineAliases dlm) dsm
f ((n_elem -> EStr (map toLower . unpackBuf -> x),y):rs) dlm dsm = if x `Set.member` list_fields then dlist y else dsing y where
dlist (n_elem -> EStr y) = f rs (Map.insert x [unpackBuf y] dlm) dsm
dlist (n_elem -> ESeq ss) = f rs (Map.insert x [ unpackBuf y | (n_elem -> EStr y) <- ss ] dlm) dsm
dlist _ = f rs dlm dsm
dsing (n_elem -> EStr y) = f rs dlm (Map.insert x (unpackBuf y) dsm)
dsing _ = f rs dlm dsm
f (_:xs) dlm dsm = f xs dlm dsm
procYaml _ = LibDesc mempty mempty
list_fields = Set.fromList $ [
"exposed-modules",
"include-dirs",
"extensions",
"options",
"c-sources",
"include-sources",
"build-depends"
] ++ map fst alias_fields
++ map snd alias_fields
alias_fields = [
("other-modules","hidden-modules"),
("exported-modules","exposed-modules"),
("hs-source-dir","hs-source-dirs")
]
combineAliases mp = f alias_fields mp where
f [] mp = mp
f ((x,y):rs) mp = case Map.lookup x mp of
Nothing -> f rs mp
Just ys -> f rs $ Map.delete x $ Map.insertWith (++) y ys mp
data LibDesc = LibDesc (Map.Map String [String]) (Map.Map String String)
readDescFile :: FilePath -> IO LibDesc
readDescFile fp = do
wdump FD.Progress $ putErrLn $ "Reading: " ++ show fp
let doYaml opt = do
lbs <- LBS.readFile fp
dt <- preprocess opt fp lbs
desc <- iocatch (parseYamlBytes $ BS.concat (LBS.toChunks dt))
(\e -> putErrDie $ "Error parsing desc file '" ++ fp ++ "'\n" ++ show e)
when verbose2 $ do
yaml <- emitYaml desc
putStrLn yaml
return $ procYaml desc
doCabal = do
fc <- readFile fp
case parseLibraryDescription fc of
Left err -> fail $ "Error reading library description file: " ++ show fp ++ " " ++ err
Right ps -> return $ procCabal ps
case FP.splitExtension fp of
(_,".cabal") -> doCabal
(_,".yaml") -> doYaml options
(FP.takeExtension -> ".yaml",".m4") -> doYaml options { optFOptsSet = FO.M4 `Set.insert` optFOptsSet options }
_ -> putErrDie $ "Do not recoginize description file type: " ++ fp