module Ho.Build (
module Ho.Type,
dumpHoFile,
parseFiles,
preprocess,
preprocessHs,
buildLibrary
) where
import Control.Concurrent
import Control.Monad.Identity
import Data.IORef
import Data.List hiding(union)
import Data.Maybe
import Data.Monoid(Monoid(..))
import Data.Tree
import Data.Version(Version,parseVersion,showVersion)
import System.FilePath as FP
import System.Mem
import Text.Printf
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.UTF8 as LBSU
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Text.PrettyPrint.HughesPJ as PPrint
import DataConstructors
import Doc.DocLike
import Doc.PPrint
import Doc.Pretty
import E.E
import E.Rules
import E.Show
import E.Traverse(emapE)
import E.TypeCheck()
import FrontEnd.Class
import FrontEnd.FrontEnd
import FrontEnd.HsSyn
import FrontEnd.Infix
import FrontEnd.SrcLoc
import FrontEnd.Warning(warn,processIOErrors,WarnType(..))
import Ho.Binary
import Ho.Collected()
import Ho.Library
import Ho.ReadSource
import Ho.Type
import Name.Name
import Options
import PackedString(PackedString,packString,unpackPS)
import Support.TempDir
import Util.Gen
import Util.SetLike
import Util.YAML
import Version.Config(version)
import Version.Version(versionString)
import qualified FlagDump as FD
import qualified FlagOpts as FO
import qualified Support.MD5 as MD5
import qualified Util.Graph as G
type LibraryName = PackedString
findFirstFile :: [FilePath] -> IO (LBS.ByteString,FilePath)
findFirstFile [] = fail "findFirstFile: file not found"
findFirstFile (x:xs) = flip iocatch (\e -> findFirstFile xs) $ do
bs <- LBS.readFile x
return (bs,x)
data ModDone
= ModNotFound
| ModLibrary !Bool ModuleGroup Library
| Found SourceCode
data Done = Done {
hoCache :: Maybe FilePath,
knownSourceMap :: Map.Map SourceHash (Module,[(Module,SrcLoc)]),
validSources :: Set.Set SourceHash,
loadedLibraries :: Map.Map LibraryName Library,
hosEncountered :: Map.Map HoHash (FilePath,HoHeader,HoIDeps,Ho),
modEncountered :: Map.Map Module ModDone
}
hosEncountered_u f r@Done{hosEncountered = x} = r{hosEncountered = f x}
knownSourceMap_u f r@Done{knownSourceMap = x} = r{knownSourceMap = f x}
loadedLibraries_u f r@Done{loadedLibraries = x} = r{loadedLibraries = f x}
modEncountered_u f r@Done{modEncountered = x} = r{modEncountered = f x}
validSources_u f r@Done{validSources = x} = r{validSources = f x}
replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix
hoFile :: Maybe FilePath -> FilePath -> Maybe Module -> SourceHash -> FilePath
hoFile cacheDir fp mm sh = case (cacheDir,optHoDir options) of
(Nothing,Nothing) -> replaceSuffix "ho" fp
(Nothing,Just hdir) -> case mm of
Nothing -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"
Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where
ft '/' = '.'
ft x = x
(Just hdir,_) -> hdir ++ "/" ++ MD5.md5show32 sh ++ ".ho"
findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath)
findHoFile done_ref fp mm sh = do
done <- readIORef done_ref
let honame = hoFile (hoCache done) fp mm sh
writeIORef done_ref (done { validSources = Set.insert sh (validSources done) })
if sh `Set.member` validSources done || optIgnoreHo options then return (False,honame) else do
onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) ->
case hohHash hoh `Map.lookup` hosEncountered done of
Just (fn,_,_,a) -> return (True,fn)
Nothing -> do
modifyIORef done_ref (knownSourceMap_u $ (`mappend` (hoIDeps hidep)))
modifyIORef done_ref (validSources_u $ Set.union (Set.fromList . map snd $ hoDepends hidep))
modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,hidep,ho))
return (True,honame)
onErr :: IO a -> IO b -> (b -> IO a) -> IO a
onErr err good cont = join $ iocatch (good >>= return . cont) (\_ -> return err)
fetchSource :: Opt -> IORef Done -> [FilePath] -> Maybe (Module,SrcLoc) -> IO Module
fetchSource _ _ [] _ = fail "No files to load"
fetchSource modOpt done_ref fs mm = do
let killMod = case mm of
Nothing -> fail $ "Could not load file: " ++ show fs
Just (m,sloc) -> do
warn sloc (MissingModule m) $ printf "Module '%s' not found." (show m)
modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m
onErr killMod (findFirstFile fs) $ \ (lbs,fn) -> do
let hash = MD5.md5lazy $ (LBSU.fromString version) `mappend` lbs
(foundho,mho) <- findHoFile done_ref fn (fmap fst mm) hash
done <- readIORef done_ref
(mod,m,ds) <- case mlookup hash (knownSourceMap done) of
Just (m,ds) -> return (Left lbs,m,ds)
Nothing -> do
(hmod,_) <- parseHsSource modOpt fn lbs
let m = hsModuleName hmod
ds = hsModuleRequires hmod
writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)
case optAnnotate options of
Just _ -> return (Left lbs,m,ds)
_ -> return (Right hmod,m,ds)
case mm of
Just (m',_) | m /= m' -> do
putErrLn $ "Skipping file" <+> fn <+> "because its module declaration of" <+> show m <+> "does not equal the expected" <+> show m'
killMod
_ -> do
let sc (Right mod) = SourceParsed sinfo mod
sc (Left lbs) = SourceRaw sinfo lbs
sinfo = SI { sourceHash = hash, sourceDeps = ds, sourceFP = fn, sourceHoName = mho, sourceModName = m }
modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))
fn' <- shortenPath fn
mho' <- shortenPath mho
putProgressLn $ if foundho
then printf "%-23s [%s] <%s>" (show m) fn' mho'
else printf "%-23s [%s]" (show m) fn'
mapM_ (resolveDeps modOpt done_ref) ds
return m
resolveDeps :: Opt -> IORef Done -> (Module,SrcLoc) -> IO ()
resolveDeps modOpt done_ref (m,sloc) = do
done <- readIORef done_ref
case m `mlookup` modEncountered done of
Just (ModLibrary False _ lib) | not ("jhc-prim-" `isPrefixOf` libName lib) -> putErrDie $ printf "ERROR: Attempt to import module '%s' which is a member of the library '%s'.\nPerhaps you need to add '-p%s' to the command line?" (show m) (libName lib) (libName lib)
Just _ -> return ()
Nothing -> fetchSource modOpt done_ref (map fst $ searchPaths modOpt (show m)) (Just (m,sloc)) >> return ()
type LibInfo = (Map.Map Module ModuleGroup, Map.Map ModuleGroup [ModuleGroup], Set.Set Module,Map.Map ModuleGroup HoBuild,Map.Map ModuleGroup HoTcInfo)
data CompNode = CompNode !HoHash [CompNode] !(IORef CompLink)
data CompLink
= CompLinkUnit CompUnit
| CompCollected CollectedHo CompUnit
| CompTcCollected HoTcInfo CompUnit
| CompLinkLib (ModuleGroup,LibInfo) CompUnit
compLinkCompUnit (CompLinkUnit cu) = cu
compLinkCompUnit (CompCollected _ cu) = cu
compLinkCompUnit (CompTcCollected _ cu) = cu
compLinkCompUnit (CompLinkLib _ cu) = cu
instance MapKey Module where
showMapKey = show
instance MapKey MD5.Hash where
showMapKey = show
dumpDeps targets memap cug = case optDeps options of
Nothing -> return ()
Just fp -> do
let (sfps,sdps,ls) = collectDeps memap cug
let yaml = Map.fromList [
("Target",toNode targets),
("LibraryDesc",toNode [ fp | BuildHl fp <- [optMode options]]),
("LibraryDeps",toNode ls),
("ModuleSource",toNode sfps),
("ModuleDeps",toNode sdps)
]
writeFile fp (showYAML yaml)
collectDeps memap cs = mconcatMap f [ cu | (_,(_,cu)) <- cs] where
f (CompSources ss) = mconcat [ (Map.singleton (sourceModName s) (sourceFP s),Map.singleton (sourceModName s) (fsts $ sourceDeps s),mempty) | s <- map sourceInfo ss ]
f (CompLibrary _ lib) = (mempty,mempty,Map.singleton (libHash lib) (libFileName lib))
f (CompHo _hoh idep _ho) = (Map.fromList [ (sourceModName $ sourceInfo src, sourceFP $ sourceInfo src) | s <- fsts ss, Just (Found src) <- [Map.lookup s memap] ],Map.fromList [ (mms,fsts mms') | s <- snds ss, Just (mms,mms') <- [Map.lookup s (hoIDeps idep)] ],mempty) where
ss = [ s | s <- hoDepends idep ]
f _ = mempty
type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]
data CompUnit
= CompHo HoHeader HoIDeps Ho
| CompSources [SourceCode]
| CompTCed ((HoTcInfo,TiData,[(HoHash,HsModule)],[String]))
| CompDummy
| CompLibrary Ho Library
instance Show CompUnit where
showsPrec _ = shows . providesModules
data SourceInfo = SI {
sourceHash :: SourceHash,
sourceDeps :: [(Module,SrcLoc)],
sourceFP :: FilePath,
sourceModName :: Module,
sourceHoName :: FilePath
}
data SourceCode
= SourceParsed { sourceInfo :: !SourceInfo, sourceModule :: HsModule }
| SourceRaw { sourceInfo :: !SourceInfo, sourceLBS :: LBS.ByteString }
sourceIdent = show . sourceModName . sourceInfo
class ProvidesModules a where
providesModules :: a -> [Module]
providesModules _ = []
instance ProvidesModules HoIDeps where
providesModules = fsts . hoDepends
instance ProvidesModules HoLib where
providesModules = Map.keys . hoModuleMap
instance ProvidesModules CompUnit where
providesModules (CompHo _ hoh _) = providesModules hoh
providesModules (CompSources ss) = concatMap providesModules ss
providesModules (CompLibrary ho libr) = libProvides (hoModuleGroup ho) libr
providesModules CompDummy = []
providesModules (CompTCed _) = error "providesModules: bad1."
instance ProvidesModules CompLink where
providesModules (CompLinkUnit cu) = providesModules cu
providesModules (CompCollected _ cu) = providesModules cu
providesModules (CompTcCollected _ cu) = providesModules cu
providesModules (CompLinkLib _ _) = error "providesModules: bad2c."
instance ProvidesModules SourceCode where
providesModules sp = [sourceModName (sourceInfo sp)]
toCompUnitGraph :: Done -> [Module] -> IO (HoHash,CompUnitGraph)
toCompUnitGraph done roots = do
let fs m = map inject $ maybe (error $ "can't find deps for: " ++ show m) (fsts . snd) (Map.lookup m (knownSourceMap done))
fs' m libr = fromMaybe (error $ "can't find deps for: " ++ show m) (Map.lookup m (hoModuleDeps $ libHoLib libr))
foundMods = [ ((m,Left (sourceHash $ sourceInfo sc)),fs (sourceHash $ sourceInfo sc)) | (m,Found sc) <- Map.toList (modEncountered done)]
foundMods' = Map.elems $ Map.fromList [ (mg,((mg,Right lib),fs' mg lib)) | (_,ModLibrary _ mg lib) <- Map.toList (modEncountered done)]
fullModMap = Map.unions (map libModMap $ Map.elems (loadedLibraries done))
inject m = Map.findWithDefault m m fullModMap
gr = G.newGraph (foundMods ++ foundMods') (fst . fst) snd
gr' = G.sccGroups gr
phomap = Map.fromListWith (++) (concat [ [ (m,[hh]) | (m,_) <- hoDepends idep ] | (hh,(_,_,idep,_)) <- Map.toList (hosEncountered done)])
sources = Map.fromList [ (m,sourceHash $ sourceInfo sc) | (m,Found sc) <- Map.toList (modEncountered done)]
when (dump FD.SccModules) $ do
mapM_ (putErrLn . show) $ map (map $ fst . fst) gr'
putErrLn $ drawForest (map (fmap (show . fst . fst)) (G.dff gr))
cug_ref <- newIORef []
hom_ref <- newIORef (Map.map ((,) False) $ hosEncountered done)
ms <- forM gr' $ \ns -> do
r <- newIORef (Left ns)
return (Map.fromList [ (m,r) | ((m,_),_) <- ns ])
let mods = Map.unions ms
lmods m = fromMaybe (error $ "modsLookup: " ++ show m) (Map.lookup m mods)
let f m = do
rr <- readIORef (lmods m)
case rr of
Right hh -> return hh
Left ns -> g ns
g ms@(((m,Left _),_):_) = do
let amods = map (fst . fst) ms
pm (fromMaybe [] (Map.lookup m phomap)) $ do
let deps = Set.toList $ Set.fromList (concat $ snds ms) `Set.difference` (Set.fromList amods)
deps' <- snub `fmap` mapM f deps
let mhash = MD5.md5String (concatMap (show . fst) ms ++ show deps')
writeIORef (lmods m) (Right mhash)
modifyIORef cug_ref ((mhash,(deps',CompSources $ map fs amods)):)
return mhash
g [((mg,Right lib),ds)] = do
let Just hob = Map.lookup mg $ libBuildMap lib
Just hot = Map.lookup mg $ libTcMap lib
ho = Ho { hoModuleGroup = mg, hoBuild = hob, hoTcInfo = hot }
myHash = libMgHash mg lib
deps <- snub `fmap` mapM f ds
writeIORef (lmods mg) (Right myHash)
modifyIORef cug_ref ((myHash,(deps,CompLibrary ho lib)):)
return myHash
g _ = error "Build.toCompUnitGraph: bad."
pm :: [HoHash] -> IO HoHash -> IO HoHash
pm [] els = els
pm (h:hs) els = hvalid h `iocatch` (\_ -> pm hs els)
hvalid h = do
ll <- Map.lookup h `fmap` readIORef hom_ref
case ll of
Nothing -> fail "Don't know anything about this hash"
Just (True,_) -> return h
Just (False,af@(fp,hoh,idep,ho)) -> do
fp <- shortenPath fp
isGood <- iocatch ( mapM_ cdep (hoDepends idep) >> mapM_ hvalid (hoModDepends idep) >> return True) (\_ -> return False)
let isStale = not . null $ map (show . fst) (hoDepends idep) `intersect` optStale options
libsGood = all (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) == Just h) (hohLibDeps hoh)
noGood forced = do
putProgressLn $ printf "Stale: <%s>%s" fp forced
modifyIORef hom_ref (Map.delete h)
fail "stale file"
case (isStale,isGood && libsGood) of
(False,True) -> do
putProgressLn $ printf "Fresh: <%s>" fp
hs <- mapM f (hoModuleGroupNeeds idep)
modifyIORef cug_ref ((h,(hs ++ hoModDepends idep,CompHo hoh idep ho)):)
modifyIORef hom_ref (Map.insert h (True,af))
return h
(True,_) -> noGood " (forced)"
(_,False) -> noGood ""
cdep (_,hash) | hash == MD5.emptyHash = return ()
cdep (mod,hash) = case Map.lookup mod sources of
Just hash' | hash == hash' -> return ()
_ -> fail "Can't verify module up to date"
fs m = case Map.lookup m (modEncountered done) of
Just (Found sc) -> sc
_ -> error $ "fs: " ++ show m
mapM_ f (map inject roots)
cug <- readIORef cug_ref
let (rhash,cug') = mkPhonyCompUnit roots cug
let gr = G.newGraph cug' fst (fst . snd)
gr' = G.transitiveReduction gr
when (dump FD.SccModules) $ do
putErrLn "ComponentsDeps:"
mapM_ (putErrLn . show) [ (snd $ snd v, map (snd . snd) vs) | (v,vs) <- G.fromGraph gr']
return (rhash,[ (h,([ d | (d,_) <- ns ],cu)) | ((h,(_,cu)),ns) <- G.fromGraph gr' ])
parseFiles
:: Opt
-> [FilePath]
-> [String]
-> [Either Module FilePath]
-> (CollectedHo -> Ho -> IO CollectedHo)
-> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho))
-> IO (CompNode,CollectedHo)
parseFiles options targets elibs need ifunc func = do
putProgressLn "Finding Dependencies..."
(ksm,chash,cug) <- loadModules options targets (snub $
if optNoAuto options then optHls options ++ elibs else
optAutoLoads options ++ optHls options ++ elibs) bogusASrcLoc need
cnode <- processCug cug chash
when (optStop options == StopParse) exitSuccess
performGC
putProgressLn "Typechecking..."
typeCheckGraph options cnode
if isJust (optAnnotate options) then exitSuccess else do
when (optStop options == StopTypeCheck) exitSuccess
performGC
putProgressLn "Compiling..."
cho <- compileCompNode ifunc func ksm cnode
return (cnode,cho)
loadModules
:: Opt
-> [FilePath]
-> [String]
-> SrcLoc
-> [Either Module FilePath]
-> IO (Map.Map SourceHash (Module,[(Module,SrcLoc)]),HoHash,CompUnitGraph)
loadModules modOpt targets libs sloc need = do
theCache <- findHoCache
case theCache of
Just s -> putProgressLn $ printf "Using Ho Cache: '%s'" s
Nothing -> return ()
done_ref <- newIORef Done {
hoCache = theCache,
knownSourceMap = Map.empty,
validSources = Set.empty,
loadedLibraries = Map.empty,
hosEncountered = Map.empty,
modEncountered = Map.empty
}
(es,is) <- collectLibraries libs
let combModMap es = Map.unions [ Map.map ((,) l) (hoModuleMap $ libHoLib l) | l <- es]
explicitModMap = combModMap es
implicitModMap = combModMap is
reexported = Set.fromList [ m | l <- es, (m,_) <- Map.toList $ hoReexports (libHoLib l) ]
modEnc exp emap = Map.fromList [ (m,ModLibrary (exp || Set.member m reexported) mg l) | (m,(l,mg)) <- Map.toList emap ]
modifyIORef done_ref (loadedLibraries_u $ Map.union $ Map.fromList [ (libBaseName lib,lib) | lib <- es ++ is])
modifyIORef done_ref (modEncountered_u $ Map.union (modEnc True explicitModMap))
modifyIORef done_ref (modEncountered_u $ Map.union (modEnc False implicitModMap))
forM_ (concatMap libExtraFiles (es ++ is)) $ \ef -> do
fileInTempDir ("cbits/" ++ unpackPS (extraFileName ef)) $ \fn -> BS.writeFile fn (extraFileData ef)
done <- readIORef done_ref
forM_ (Map.elems $ loadedLibraries done) $ \ lib -> do
let libsBad = filter (\ (p,h) -> fmap (libHash) (Map.lookup p (loadedLibraries done)) /= Just h) (hohLibDeps $ libHoHeader lib)
unless (null libsBad) $ do
putErr $ printf "Library Dependencies not met. %s needs\n" (libName lib)
forM_ libsBad $ \ (p,h) -> putErr $ printf " %s (hash:%s)\n" (unpackPS p) (show h)
putErrDie "\n"
ms1 <- forM (rights need) $ \fn -> do
fetchSource modOpt done_ref [fn] Nothing
forM_ (map (,sloc) $ lefts need) $ resolveDeps modOpt done_ref
processIOErrors
done <- readIORef done_ref
let needed = (ms1 ++ lefts need)
(chash,cug) <- toCompUnitGraph done needed
dumpDeps targets (modEncountered done) cug
return (Map.filterWithKey (\k _ -> k `Set.member` validSources done) (knownSourceMap done),chash,cug)
processCug :: CompUnitGraph -> HoHash -> IO CompNode
processCug cug root = mdo
let mmap = Map.fromList xs
lup x = maybe (error $ "processCug: " ++ show x) id (Map.lookup x mmap)
f (h,(ds,cu)) = do
cur <- newIORef (CompLinkUnit cu)
return $ (h,CompNode h (map lup ds) cur)
xs <- mapM f cug
Just x <- return $ Map.lookup root mmap
return $ x
mkPhonyCompUnit :: [Module] -> CompUnitGraph -> (HoHash,CompUnitGraph)
mkPhonyCompUnit need cs = (fhash,(fhash,(fdeps,CompDummy)):cs) where
fhash = MD5.md5String $ show (sort fdeps)
fdeps = [ h | (h,(_,cu)) <- cs, not . null $ providesModules cu `intersect` need ]
printModProgress :: Int -> Int -> IO Int -> [HsModule] -> IO ()
printModProgress _ _ _ [] = return ()
printModProgress _ _ tickProgress ms | not progress = mapM_ (const tickProgress) ms
printModProgress fmtLen maxModules tickProgress ms = f "[" ms where
f bl ms = do
curModule <- tickProgress
case ms of
[x] -> g curModule bl "]" x
(x:xs) -> do g curModule bl "-" x; putErrLn ""; f "-" xs
_ -> error "Build.printModProgress: bad."
g curModule bl el modName = putErr $ printf "%s%*d of %*d%s %-17s" bl fmtLen curModule fmtLen maxModules el (show $ hsModuleName modName)
countNodes cn = do
seen <- newIORef Set.empty
let h (CompNode hh deps ref) = do
s <- readIORef seen
if hh `Set.member` s then return Set.empty else do
writeIORef seen (Set.insert hh s)
ds <- mapM h deps
cm <- readIORef ref >>= g
return (Set.unions (cm:ds))
g cn = case cn of
CompLinkUnit cu -> return $ f cu
CompTcCollected _ cu -> return $ f cu
CompCollected _ cu -> return $ f cu
CompLinkLib _ _ -> error "Build.countNodes: bad."
f cu = case cu of
CompTCed (_,_,_,ss) -> Set.fromList ss
CompSources sc -> Set.fromList (map sourceIdent sc)
_ -> Set.empty
h cn
typeCheckGraph :: Opt -> CompNode -> IO ()
typeCheckGraph modOpt cn = do
cur <- newMVar (1::Int)
maxModules <- Set.size `fmap` countNodes cn
let f (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of
CompTcCollected ctc _ -> return ctc
CompLinkUnit lu -> do
deps' <- randomPermuteIO deps
ctc <- mconcat `fmap` mapM f deps'
case lu of
CompDummy -> do
writeIORef ref (CompTcCollected ctc CompDummy)
return ctc
CompHo hoh idep ho -> do
let ctc' = hoTcInfo ho `mappend` ctc
writeIORef ref (CompTcCollected ctc' lu)
return ctc'
CompLibrary ho _libr -> do
let ctc' = hoTcInfo ho `mappend` ctc
writeIORef ref (CompTcCollected ctc' lu)
return ctc'
CompSources sc -> do
let mods = sort $ map (sourceModName . sourceInfo) sc
modules <- forM sc $ \x -> case x of
SourceParsed { sourceInfo = si, sourceModule = sm } ->
return (sourceHash si, sm, error "SourceParsed in AnnotateSource")
SourceRaw { sourceInfo = si, sourceLBS = lbs } -> do
(mod,lbs') <- parseHsSource modOpt (sourceFP si) lbs
case optAnnotate modOpt of
Just fp -> do
let ann = LBSU.fromString $ unlines [
"{- --ANNOTATE--",
"Module: " ++ show (sourceModName si),
"Deps: " ++ show (sort $ fsts $ sourceDeps si),
"Siblings: " ++ show mods,
"-}"]
LBS.writeFile (fp ++ "/" ++ show (hsModuleName mod) ++ ".hs") (ann `LBS.append` lbs')
_ -> return ()
return (sourceHash si,mod,lbs')
showProgress (map snd3 modules)
(htc,tidata) <- doModules ctc (map snd3 modules)
let ctc' = htc `mappend` ctc
writeIORef ref (CompTcCollected ctc' (CompTCed ((htc,tidata,[ (x,y) | (x,y,_) <- modules],map (sourceHoName . sourceInfo) sc))))
return ctc'
_ -> error "Build.typeCheckGraph: bad1."
_ -> error "Build.typeCheckGraph: bad2."
showProgress ms = printModProgress fmtLen maxModules tickProgress ms
fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int
tickProgress = modifyMVar cur $ \val -> return (val+1,val)
f cn
return ()
compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo)
-> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho))
-> Map.Map SourceHash (Module,[(Module,SrcLoc)])
-> CompNode
-> IO CollectedHo
compileCompNode ifunc func ksm cn = do
cur <- newMVar (1::Int)
ksm_r <- newIORef ksm
let tickProgress = modifyMVar cur $ \val -> return (val+1,val)
maxModules <- Set.size `fmap` countNodes cn
let showProgress ms = printModProgress fmtLen maxModules tickProgress ms
fmtLen = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int
let f (CompNode hh deps ref) = readIORef ref >>= g where
g cn = case cn of
CompCollected ch _ -> return ch
CompTcCollected _ cl -> h cl
CompLinkUnit cu -> h cu
_ -> error "Build.compileCompNode: bad."
h cu = do
deps' <- randomPermuteIO deps
cho <- mconcat `fmap` mapM f deps'
case cu of
CompDummy -> do
writeIORef ref (CompCollected cho CompDummy)
return cho
(CompHo hoh idep ho) -> do
cho <- choLibDeps_u (Map.union $ Map.fromList (hohLibDeps hoh)) `fmap` ifunc cho ho
writeIORef ref (CompCollected cho cu)
return cho
(CompLibrary ho Library { libHoHeader = hoh }) -> do
cho <- ifunc cho ho
let Right (ln,_) = hohName hoh
lh = hohHash hoh
cho' = (choLibDeps_u (Map.insert ln lh) cho)
writeIORef ref (CompCollected cho' cu)
return cho'
CompTCed ((htc,tidata,modules,shns)) -> do
(hdep,ldep) <- fmap mconcat . forM deps $ \ (CompNode h _ ref) -> do
cl <- readIORef ref
case compLinkCompUnit cl of
CompLibrary ho _ -> return ([],[hoModuleGroup ho])
CompDummy {} -> return ([],[])
_ -> return ([h],[])
showProgress (snds modules)
let (mgName:_) = sort $ map (hsModuleName . snd) modules
(cho',newHo) <- func cho mempty { hoModuleGroup = mgName, hoTcInfo = htc } tidata
modifyIORef ksm_r (Map.union $ Map.fromList [ (h,(hsModuleName mod, hsModuleRequires mod)) | (h,mod) <- modules])
ksm <- readIORef ksm_r
let hoh = HoHeader {
hohVersion = error "hohVersion",
hohName = Left mgName,
hohHash = hh,
hohArchDeps = [],
hohLibDeps = Map.toList (choLibDeps cho')
}
idep = HoIDeps {
hoIDeps = ksm,
hoDepends = [ (hsModuleName mod,h) | (h,mod) <- modules],
hoModDepends = hdep,
hoModuleGroupNeeds = ldep
}
recordHoFile (mapHoBodies eraseE newHo) idep shns hoh
writeIORef ref (CompCollected cho' (CompHo hoh idep newHo))
return cho'
CompSources _ -> error "sources still exist!?"
f cn
hsModuleRequires x = snub ((toModule "Jhc.Prim.Prim",bogusASrcLoc):ans) where
noPrelude = FO.Prelude `Set.notMember` optFOptsSet (hsModuleOpt x)
ans = (if noPrelude then id else ((preludeModule,bogusASrcLoc):)) [ (hsImportDeclModule y,hsImportDeclSrcLoc y) | y <- hsModuleImports x]
searchPaths :: Opt -> String -> [(String,String)]
searchPaths modOpt m = ans where
f m | (xs,'.':ys) <- span (/= '.') m = let n = (xs ++ "/" ++ ys) in m:f n
| otherwise = [m]
ans = [ (root ++ suf,root ++ ".ho") | i <- optIncdirs modOpt, n <- f m, suf <- [".hs",".lhs",".hsc"], let root = i ++ "/" ++ n]
mapHoBodies :: (E -> E) -> Ho -> Ho
mapHoBodies sm ho = ho { hoBuild = g (hoBuild ho) } where
g ho = ho { hoEs = map f (hoEs ho) , hoRules = runIdentity (E.Rules.mapBodies (return . sm) (hoRules ho)) }
f (t,e) = (t,sm e)
eraseE :: E -> E
eraseE e = runIdentity $ f e where
f (EVar tv) = return $ EVar tvr { tvrIdent = tvrIdent tv }
f e = emapE f e
buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo)
-> (CollectedHo -> Ho -> TiData -> IO (CollectedHo,Ho))
-> FilePath
-> IO ()
buildLibrary ifunc func = ans where
ans fp = do
(desc,name,vers,hmods,emods,modOpts,sources) <- parse fp
vers <- runReadP parseVersion vers
let allMods = emodSet `Set.union` hmodSet
emodSet = Set.fromList emods
hmodSet = Set.fromList hmods
let outName = case optOutName modOpts of
Nothing -> name ++ "-" ++ showVersion vers ++ ".hl"
Just fn -> fn
(rnode@(CompNode lhash _ _),cho) <- parseFiles modOpts [outName] [] (map Left $ Set.toList allMods) ifunc func
(_,(mmap,mdeps,prvds,lcor,ldef)) <- let
f (CompNode hs cd ref) = do
cl <- readIORef ref
case cl of
CompLinkLib l _ -> return l
CompCollected _ y -> g hs cd ref y
_ -> error "Build.buildLibrary: bad1."
g hh deps ref cn = do
deps <- mapM f deps
let (mg,mll) = case cn of
CompDummy -> (error "modgroup of dummy",mempty)
CompLibrary ho lib -> (hoModuleGroup ho,mempty)
CompHo hoh hidep ho -> (mg,(
Map.fromList $ zip (providesModules hidep) (repeat mg),
Map.singleton mg (sort $ fsts deps),
Set.fromList $ providesModules hidep,
Map.singleton mg (hoBuild ho'),
Map.singleton mg (hoTcInfo ho')
)) where
mg = hoModuleGroup ho
ho' = mapHoBodies eraseE ho
_ -> error "Build.buildLibrary: bad2."
res = (mg,mconcat (snds deps) `mappend` mll)
writeIORef ref (CompLinkLib res cn)
return res
in f rnode
let unknownMods = Set.toList $ Set.filter (`Set.notMember` allMods) prvds
mapM_ ((putStrLn . ("*** Module depended on in library that is not in export list: " ++)) . show) unknownMods
mapM_ ((putStrLn . ("*** We are re-exporting the following modules from other libraries: " ++)) . show) $ Set.toList (allMods Set.\\ prvds)
let hoh = HoHeader {
hohHash = lhash,
hohName = Right (packString name,vers),
hohLibDeps = Map.toList (choLibDeps cho),
hohArchDeps = [],
hohVersion = error "hohVersion"
}
let pdesc = [(packString n, packString v) | (n,v) <- ("jhc-hl-filename",outName):("jhc-description-file",fp):("jhc-compiled-by",versionString):desc, n /= "exposed-modules" ]
libr = HoLib {
hoReexports = Map.fromList [ (m,m) | m <- Set.toList $ allMods Set.\\ prvds ],
hoMetaInfo = pdesc,
hoModuleMap = mmap,
hoModuleDeps = mdeps
}
putProgressLn $ "Writing Library: " ++ outName
efs <- mapM fetchExtraFile sources
recordHlFile Library { libHoHeader = hoh, libHoLib = libr, libTcMap = ldef,
libBuildMap = lcor, libFileName = outName, libExtraFiles = efs }
parse fp = do
putProgressLn $ "Creating library from description file: " ++ show fp
LibDesc dlist dsing <- readDescFile fp
when verbose2 $ do
mapM_ print (Map.toList dlist)
mapM_ print (Map.toList dsing)
let jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ Map.lookup x dsing
mfield x = maybe [] id $ Map.lookup x dlist
name <- jfield "name"
vers <- jfield "version"
let (modOpts,flags) = (lproc bopt,modOptions) where
Just bopt = fileOptions options modOptions `mplus` Just options
(pfs,nfs,_) = languageFlags (mfield "extensions")
lproc opt = opt { optFOptsSet = Set.union pfs (optFOptsSet opt) Set.\\ nfs }
dirs = [ "-i" ++ dd x | x <- mfield "hs-source-dirs" ]
++ [ "-I" ++ dd x | x <- mfield "include-dirs" ]
++ [ "-p" ++ x | x <- mfield "build-depends" ]
modOptions = (mfield "options" ++ dirs)
dd "." = FP.takeDirectory fp
dd ('.':'/':x) = dd x
dd x = FP.takeDirectory fp FP.</> x
when verbose $
print (flags,optFOptsSet modOpts)
let hmods = map toModule $ snub $ mfield "hidden-modules"
emods = map toModule $ snub $ mfield "exposed-modules"
sources = map (FP.takeDirectory fp FP.</>) $ snub $ mfield "c-sources" ++ mfield "include-sources"
return (Map.toList dsing,name,vers,hmods,emods,modOpts,sources)
fetchExtraFile fp = do
c <- BS.readFile fp
return ExtraFile { extraFileName = packString (FP.takeFileName fp),
extraFileData = c }
instance DocLike d => PPrint d MD5.Hash where
pprint h = tshow h
instance DocLike d => PPrint d SrcLoc where
pprint sl = tshow sl
instance DocLike d => PPrint d Version where
pprint sl = text $ showVersion sl
instance DocLike d => PPrint d PackedString where
pprint sl = text (unpackPS sl)
dumpHoFile :: String -> IO ()
dumpHoFile fn = ans where
ans = do
putStrLn fn
case reverse fn of
'l':'h':'.':_ -> doHl fn
'o':'h':'.':_ -> doHo fn
_ -> putErrDie "Error: --show-ho requires a .hl or .ho file"
vindent xs = vcat (map (" " ++) xs)
showList nm xs = when (not $ null xs) $ putStrLn $ (nm ++ ":\n") <> vindent xs
doHoh hoh = do
putStrLn $ "Version:" <+> pprint (hohVersion hoh)
putStrLn $ "Hash:" <+> pprint (hohHash hoh)
putStrLn $ "Name:" <+> pprint (hohName hoh)
showList "LibDeps" (map pprint . sortUnder fst $ hohLibDeps hoh)
showList "ArchDeps" (map pprint . sortUnder fst $ hohArchDeps hoh)
doHl fn = do
l <- readHlFile fn
doHoh $ libHoHeader l
showList "MetaInfo" (sort [text (unpackPS k) <> char ':' <+> show v |
(k,v) <- hoMetaInfo (libHoLib l)])
showList "ModuleMap" (map pprint . sortUnder fst $ Map.toList $ hoModuleMap $ libHoLib l)
showList "ModuleDeps" (map pprint . sortUnder fst $ Map.toList $ hoModuleDeps $ libHoLib l)
showList "ModuleReexports" (map pprint . sortUnder fst $ Map.toList $ hoReexports $ libHoLib l)
forM_ (Map.toList $ libBuildMap l) $ \ (g,hoB) -> do
print g
doHoB hoB
doHo fn = do
(hoh,idep,ho) <- readHoFile fn
doHoh hoh
let hoB = hoBuild ho
hoE = hoTcInfo ho
showList "Dependencies" (map pprint . sortUnder fst $ hoDepends idep)
showList "ModDependencies" (map pprint $ hoModDepends idep)
showList "IDepCache" (map pprint . sortUnder fst $ Map.toList $ hoIDeps idep)
putStrLn $ "Modules contained:" <+> tshow (keys $ hoExports hoE)
putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE)
putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoE)
putStrLn $ "hoFixities:" <+> tshow (size $ hoFixities hoE)
putStrLn $ "hoKinds:" <+> tshow (size $ hoKinds hoE)
putStrLn $ "hoClassHierarchy:" <+> tshow (length $ classRecords $ hoClassHierarchy hoE)
putStrLn $ "hoTypeSynonyms:" <+> tshow (size $ hoTypeSynonyms hoE)
wdump FD.Exports $ do
putStrLn "---- exports information ----";
putStrLn $ (pprint $ hoExports hoE :: String)
wdump FD.Defs $ do
putStrLn "---- defs information ----";
putStrLn $ (pprint $ hoDefs hoE :: String)
when (dump FD.Kind) $ do
putStrLn "---- kind information ----";
putStrLn $ (pprint $ hoKinds hoE :: String)
when (dump FD.ClassSummary) $ do
putStrLn "---- class summary ---- "
printClassSummary (hoClassHierarchy hoE)
when (dump FD.Class) $
do {putStrLn "---- class hierarchy ---- ";
printClassHierarchy (hoClassHierarchy hoE)}
wdump FD.Types $ do
putStrLn " ---- the types of identifiers ---- "
putStrLn $ PPrint.render $ pprint (hoAssumps hoE)
doHoB hoB
doHoB hoB = do
putStrLn $ "hoDataTable:" <+> tshow (size $ hoDataTable hoB)
putStrLn $ "hoEs:" <+> tshow (size $ hoEs hoB)
putStrLn $ "hoRules:" <+> tshow (size $ hoRules hoB)
let rules = hoRules hoB
wdump FD.Rules $ putStrLn " ---- user rules ---- " >> printRules RuleUser rules
wdump FD.Rules $ putStrLn " ---- user catalysts ---- " >> printRules RuleCatalyst rules
wdump FD.RulesSpec $ putStrLn " ---- specializations ---- " >> printRules RuleSpecialization rules
wdump FD.Datatable $ do
putStrLn " ---- data table ---- "
putDocM putStr (showDataTable (hoDataTable hoB))
putChar '\n'
wdump FD.Core $ do
putStrLn " ---- lambdacube ---- "
mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB)
printCheckName'' :: DataTable -> TVr -> E -> IO ()
printCheckName'' _dataTable tvr e = do
when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr)
putStrLn (render $ hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)))
putStrLn (render $ hang 4 (pprint tvr <+> equals <+> pprint e))