lhc-0.6.20090126: src/Ho/Build.hs
module Ho.Build (
module Ho.Type,
dumpHoFile,
compileModules,
doDependency,
buildLibrary
) where
import Codec.Compression.GZip
import Control.Monad.Identity
import Control.Concurrent
import Data.Binary
import Data.Char
import Data.Monoid
import Data.IORef
import Data.Tree
import Data.List hiding(union)
import Maybe
import Monad
import Text.Printf
import Prelude hiding(print,putStrLn)
import System.IO hiding(print,putStrLn)
import System.Posix.Files
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Text.PrettyPrint.ANSI.Leijen as PPrint
import Data.DeriveTH
import Data.Derive.All
import PackedString(packString)
import CharIO
import DataConstructors
import Directory
import Doc.DocLike
import Doc.PPrint
import Doc.Pretty
import E.E
import E.Rules
import E.Traverse(emapE)
import E.TypeCheck()
import FrontEnd.Class
import FrontEnd.HsParser
import FrontEnd.Infix
import FrontEnd.ParseMonad
import FrontEnd.Syn.Options
import FrontEnd.Unlit
import FrontEnd.Warning
import FrontEnd.SrcLoc
import RawFiles(prelude_m4)
import Ho.Binary()
import Ho.Library
import Ho.Collected()
import Ho.Type
import FrontEnd.HsSyn
import Options
import Support.CFF
import Util.FilterInput
import Util.Gen hiding(putErrLn,putErr,putErrDie)
import Util.SetLike
import LHCVersion
import Data.GraphViz as GV
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified FlagDump as FD
import qualified FlagOpts as FO
import qualified Util.Graph as G
import qualified Data.Graph.Inductive as GI
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Codec.Binary.UTF8.String as UTF8
import System.FilePath (takeExtension)
--
-- Ho File Format
--
-- ho files are standard CFF format files (PNG-like) as described in the Support.CFF modules.
--
-- the CFF magic for the files is the string "LHC"
--
-- JHDR - header info, contains a list of modules contained and dependencies that need to be checked to read the file
-- LIBR - only present if this is a library, contains library metainfo
-- IDEP - immutable import information
-- RDRT - redirect to another file for systems without symlinks
-- DEFS - definitions and exports for modules, all that is needed for name resolution
-- TCIN - type checking information
-- CORE - compiled core and associated data
-- GRIN - compiled grin code
--
--
cff_magic = chunkType "LHC"
cff_rdrt = chunkType "RDRT"
cff_jhdr = chunkType "JHDR"
cff_core = chunkType "CORE"
cff_defs = chunkType "DEFS"
cff_idep = chunkType "IDEP"
shortenPath :: String -> IO String
shortenPath x@('/':_) = do
cd <- getCurrentDirectory
pwd <- lookupEnv "PWD"
h <- lookupEnv "HOME"
let f d = do
d <- d
'/':rest <- getPrefix d x
return rest
return $ fromJust $ f (return cd) `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x
shortenPath x = return x
instance DocLike d => PPrint d MD5.MD5Digest where
pprintPrec _ h = tshow h
instance (DocLike d, PPrint d a) => PPrint d (Maybe a) where
pprintPrec _ Nothing = text "Nothing"
pprintPrec x (Just a) = pprintPrec x a
findFirstFile :: String -> [(FilePath,a)] -> IO (LBS.ByteString,FilePath,a)
findFirstFile err [] = FrontEnd.Warning.err "missing-dep" ("Module not found: " ++ err) >> fail ("Module not found: " ++ err) -- return (error "findFirstFile not found","",undefined)
findFirstFile err ((x,a):xs) = flip catch (\e -> findFirstFile err xs) $ do
bs <- LBS.readFile x
return (bs,x,a)
data ModDone
= ModNotFound
| ModLibrary String HoHash
| Found SourceCode
data SourceCode
= SourceParsed { sourceHash :: SourceHash, sourceDeps :: [Module]
, sourceModule :: HsModule, sourceFP :: FilePath, sourceHoName :: FilePath }
| SourceRaw { sourceHash :: SourceHash, sourceDeps :: [Module]
, sourceModName :: Module, sourceLBS :: LBS.ByteString, sourceFP :: FilePath, sourceHoName :: FilePath }
data Done = Done {
knownSourceMap :: Map.Map SourceHash (Module,[Module]),
hosEncountered :: Map.Map HoHash (FilePath,HoHeader,Ho),
modEncountered :: Map.Map Module ModDone
}
$(derive makeMonoid ''Done)
$(derive makeUpdate ''Done)
fileOrModule f = case takeExtension f of
".hs" -> Right f
".lhs" -> Right f
_ -> Left $ Module f
{-# NOINLINE doDependency #-}
doDependency :: [String] -> IO ()
doDependency as = do
done_ref <- newIORef mempty;
let f (Right f) = fetchSource done_ref [f] Nothing >> return ()
f (Left m) = resolveDeps done_ref m
mapM_ (f . fileOrModule) as
sm <- knownSourceMap `fmap` readIORef done_ref
mapM_ print $ melems sm
replaceSuffix suffix fp = reverse (dropWhile ('.' /=) (reverse fp)) ++ suffix
hoFile :: FilePath -> Maybe Module -> SourceHash -> FilePath
hoFile fp mm sh = case optHoDir options of
Nothing -> replaceSuffix "ho" fp
Just hdir -> case mm of
Nothing -> hdir ++ "/" ++ show sh ++ ".ho"
Just m -> hdir ++ "/" ++ map ft (show m) ++ ".ho" where
ft '/' = '.'
ft x = x
findHoFile :: IORef Done -> FilePath -> Maybe Module -> SourceHash -> IO (Bool,FilePath)
findHoFile done_ref fp mm sh = do
done <- readIORef done_ref
let honame = hoFile fp mm sh
if sh `Map.member` knownSourceMap done || optIgnoreHo options then return (False,honame) else do
onErr (return (False,honame)) (readHoFile honame) $ \ (hoh,hidep,ho) -> do
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 (hosEncountered_u $ Map.insert (hohHash hoh) (honame,hoh,ho))
return (True,honame)
onErr :: IO a -> IO b -> (b -> IO a) -> IO a
onErr err good cont = catch (good >>= \c -> return (cont c)) (\_ -> return err) >>= id
fetchSource :: IORef Done -> [FilePath] -> Maybe Module -> IO Module
fetchSource _ [] _ = fail "No files to load"
fetchSource done_ref fs mm = do
let mod = maybe (head fs) show mm
killMod = case mm of
Nothing -> fail $ "Could not load file: " ++ show fs
Just m -> modifyIORef done_ref (modEncountered_u $ Map.insert m ModNotFound) >> return m
onErr killMod (findFirstFile mod [ (f,undefined) | f <- fs]) $ \ (lbs,fn,_) -> do
let hash = MD5.md5 lbs
(foundho,mho) <- findHoFile done_ref fn mm hash
done <- readIORef done_ref
(mod,m,ds) <- case mlookup hash (knownSourceMap done) of
Just (m,ds) -> do return (Left lbs,m,ds)
Nothing -> do
hmod <- parseHsSource fn lbs
let m = hsModuleName hmod
ds = hsModuleRequires hmod
writeIORef done_ref (knownSourceMap_u (Map.insert hash (m,ds)) done)
return (Right hmod,m,ds)
case mm of
Just m' | m /= m' -> do
putErrLn $ "Skipping file" <+> fn <+> "because it's module declaration of" <+> show m <+> "does not equal the expected" <+> show m'
killMod
_ -> do
let sc (Right mod) = SourceParsed hash ds mod fn mho
sc (Left lbs) = SourceRaw hash ds m lbs fn mho
modifyIORef done_ref (modEncountered_u $ Map.insert m (Found (sc mod)))
fn' <- shortenPath fn
mho' <- shortenPath mho
case foundho of
False -> putVerboseLn $ printf "%-23s [%s]" (show m) fn'
True -> putVerboseLn $ printf "%-23s [%s] <%s>" (show m) fn' mho'
mapM_ (resolveDeps done_ref) ds
return m
resolveDeps :: IORef Done -> Module -> IO ()
resolveDeps done_ref m = do
done <- readIORef done_ref
if isJust $ m `mlookup` modEncountered done then return () else do
fetchSource done_ref (map fst $ searchPaths (show m)) (Just m)
return ()
sourceIdent SourceParsed { sourceModule = m } = show $ hsModuleName m
sourceIdent SourceRaw { sourceModName = fp } = show fp
data CompUnit
= CompHo (Maybe String) HoHeader Ho
| CompSources [SourceCode]
| CompPhony
| CompCollected CollectedHo CompUnit
class ProvidesModules a where
providesModules :: a -> [Module]
providesModules _ = []
instance ProvidesModules HoHeader where
providesModules hoh = fsts $ hohDepends hoh
instance ProvidesModules CompUnit where
providesModules (CompHo _ hoh _) = providesModules hoh
providesModules (CompSources ss) = concatMap providesModules ss
providesModules CompPhony = []
providesModules (CompCollected _ cu) = providesModules cu
instance ProvidesModules SourceCode where
providesModules SourceParsed { sourceModule = mod } = [hsModuleName mod]
providesModules SourceRaw { sourceModName = n } = [n]
type CompUnitGraph = [(HoHash,([HoHash],CompUnit))]
showCUnit (hash,(deps,cu)) = printf "%s : %s" (show hash) (show deps) ++ "\n" ++ f cu where
f (CompHo (Just s) _ _) = s
f (CompHo _ _ _) = "ho"
f (CompSources ss) = show $ map sourceIdent ss
-- | this walks the loaded modules and ho files, discarding out of
-- date ho files and organizing modules into their binding groups.
-- the result is an acyclic graph where the nodes are ho files, sets
-- of mutually recursive modules, or libraries.
-- there is a strict ordering of
-- source >= ho >= library
-- in terms of dependencies
toCompUnitGraph :: Done -> [Module] -> IO CompUnitGraph
toCompUnitGraph done roots = do
let fs m = maybe (error $ "can't find deps for: " ++ show m) snd (Map.lookup m (knownSourceMap done))
gr :: G.Graph ((Module, SourceHash), [Module]) Module
gr = G.newGraph [ ((m,sourceHash sc),fs (sourceHash sc)) | (m,Found sc) <- Map.toList (modEncountered done)] (fst . fst) snd
gr' = G.sccGroups gr
-- Note: tred(1) is VERY handy with these graphs!
when (dump FD.DepGraph) $ do
let nodes = zip [0..] [(m,sourceHash sc) | (m,Found sc) <- (Map.toList (modEncountered done))]
nodeMap = Map.fromList [ (sh, n) | (n,(sh,_)) <- nodes ]
gri :: GI.Gr (Module, SourceHash) ()
gri = GI.mkGraph nodes [ (n,n2,())
| (n,(_,sh)) <- nodes,
n2 <- concatMap (maybeToList . (`Map.lookup` nodeMap)) (fs sh)
]
sccMap = Map.fromList [(n, ns) | ns <- (map.map) (fst.fst) gr', n <- ns]
cluster ln@(_,(m,_)) = case (fromJust $ Map.lookup m sccMap) of
[_] -> N ln
ms -> C ms (N ln)
fcluster _ = [Style Dashed]
fnode (_,(m,_)) = [Label (show m)]
fedge _ = []
writeFile "deps.dot" (show $ clusterGraphToDot gri [GV.Unknown "aspect" "2,10"]
cluster fcluster fnode fedge)
let lmods = Map.mapMaybe ( \ x -> case x of ModLibrary _ h -> Just h ; _ -> Nothing) (modEncountered done)
phomap = Map.fromListWith (++) (concat [ [ (m,[hh]) | (m,_) <- hohDepends hoh ] | (hh,(_,hoh,_)) <- Map.toList (hosEncountered done)])
sources = Map.fromList [ (m,sourceHash 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 [ (m,r) | ((m,_),_) <- ns ]
let mods = Map.fromList (concat ms)
let f m | Just h <- Map.lookup m lmods = hvalid h
f m = do
rr <- readIORef $ maybe (error $ "toCompUnitGraph: " ++ show m) id (Map.lookup m mods)
case rr of
Right hh -> return hh
Left ns -> g ns
g ms@(((m,_),ds):_) = 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.md5 . L.pack $ (concatMap (show . fst) ms ++ show deps')
writeIORef (fromJust $ Map.lookup m mods) (Right mhash)
let cunit = CompSources $ map fs amods
modifyIORef cug_ref ((mhash,(deps',cunit)):)
return mhash
pm :: [HoHash] -> IO HoHash -> IO HoHash
pm [] els = els
pm (h:hs) els = hvalid h `catch` (\_ -> 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,ho)) -> do
fp <- shortenPath fp
let stale = map (show . fst) (hohDepends hoh) `intersect` optStale options
good <- catch ( mapM_ cdep (hohDepends hoh) >> mapM_ hvalid (hohModDepends hoh) >> return True) (\_ -> return False)
if good && null stale then do
putVerboseLn $ printf "Fresh: <%s>" fp
let lib = case ".ho" `isSuffixOf` fp of
True -> Nothing
False -> Just fp
modifyIORef cug_ref ((h,(hohModDepends hoh,CompHo lib hoh ho)):)
modifyIORef hom_ref (Map.insert h (True,af))
return h
else do
putVerboseLn $ if null stale
then printf "Stale: <%s>" fp
else printf "Stale: <%s> (forced)" fp
modifyIORef hom_ref (Map.delete h)
fail "don't know this file"
cdep (_,Nothing) = return ()
cdep (mod,Just 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 roots
readIORef cug_ref
compileModules :: [Either Module String] -- ^ Either a module or filename to find
-> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file
-> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
-> IO CollectedHo -- ^ Final accumulated ho
compileModules need ifunc func = do
(needed,cug) <- loadModules (optHls options) need
processCug cug >>= mkPhonyCompNode needed >>= compileCompNode ifunc func
-- this takes a list of modules or files to load, and produces a compunit graph
loadModules :: [String] -- ^ libraries to load
-> [Either Module String] -- ^ a list of modules or filenames
-> IO ([Module],CompUnitGraph) -- ^ the resulting acyclic graph of compilation units
loadModules libs need = do
done_ref <- newIORef mempty
unless (null libs) $ putVerboseLn $ "Loading libraries:" <+> show libs
forM_ (optHls options) $ \l -> do
(n',fn) <- findLibrary l
(hoh,_,ho) <- catch (readHoFile fn) $ \_ ->
fail $ "Error loading library file: " ++ fn
putVerboseLn $ printf "Library: %-15s <%s>" n' fn
modifyIORef done_ref (hosEncountered_u $ Map.insert (hohHash hoh) (n',hoh,ho))
modifyIORef done_ref (modEncountered_u $ Map.union (Map.fromList [ (m,ModLibrary n' (hohHash hoh)) | m <- providesModules hoh]))
ms1 <- forM (rights need) $ \fn -> do
fetchSource done_ref [fn] Nothing
forM_ (lefts need) $ resolveDeps done_ref
processIOErrors
done <- readIORef done_ref
let needed = (ms1 ++ lefts need)
cug <- toCompUnitGraph done needed
return (needed,cug)
data CompNode = CompNode HoHash [CompNode] (IORef CompUnit)
processCug :: CompUnitGraph -> IO [CompNode]
processCug cug = 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 cu
return $ (h,CompNode h (map lup ds) cur)
xs <- mapM f cug
return $ snds xs
mkPhonyCompNode :: [Module] -> [CompNode] -> IO CompNode
mkPhonyCompNode need cs = do
xs <- forM cs $ \cn@(CompNode _ _ cu) -> readIORef cu >>= \u -> return $ if null $ providesModules u `intersect` need then [] else [cn]
let hash = MD5.md5 . L.pack $ show [ h | CompNode h _ _ <- concat xs ]
CompNode hash (concat xs) `fmap` newIORef CompPhony
compileCompNode :: (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file
-> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
-> CompNode
-> IO CollectedHo
compileCompNode ifunc func cn = do ns <- countNodes cn
cur <- newMVar (1::Int)
f (Set.size ns) cur cn where
countNodes (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of
CompCollected _ _ -> return Set.empty
CompPhony -> mconcat `fmap` mapM countNodes deps
CompHo _ hoh _ -> do ds <- mconcat `fmap` mapM countNodes deps
return $ ds `Set.union` Set.fromList (map (show.fst) (hohDepends hoh))
CompSources sc -> do ds <- mconcat `fmap` mapM countNodes deps
return $ ds `Set.union` Set.fromList (map sourceIdent sc)
tickProgress cur
= modifyMVar cur $ \val -> return (val+1,val)
showProgress maxModules cur ms
= forM_ ms $ \modName ->
do curModule <- tickProgress cur
let l = ceiling (logBase 10 (fromIntegral maxModules+1) :: Double) :: Int
printf "[%*d of %*d] %s\n" l curModule l maxModules (show $ hsModuleName modName)
f n cur (CompNode hh deps ref) = readIORef ref >>= \cn -> case cn of
CompCollected ch _ -> return ch
CompPhony -> do
xs <- mconcat `fmap` mapM (f n cur) deps
writeIORef ref (CompCollected xs CompPhony)
return xs
CompHo _ hoh ho -> do
cho <- mconcat `fmap` mapM (f n cur) deps
forM_ (hohDepends hoh) $ \_ -> tickProgress cur
cho <- ifunc cho ho
writeIORef ref (CompCollected cho cn)
return cho
CompSources sc -> do
let hdep = [ h | CompNode h _ _ <- deps]
cho <- mconcat `fmap` mapM (f n cur) deps
modules <- forM sc $ \x -> case x of
SourceParsed { sourceHash = h,sourceModule = mod } -> return (h,mod)
SourceRaw { sourceHash = h,sourceLBS = lbs, sourceFP = fp } -> do
mod <- parseHsSource fp lbs
return (h,mod)
showProgress n cur (snds modules)
(cho',newHo) <- func cho (snds modules)
let hoh = HoHeader {
hohDepends = [ (hsModuleName mod,Just h) | (h,mod) <- modules],
hohModDepends = hdep,
hohHash = hh,
hohMetaInfo = []
}
idep = HoIDeps $ Map.fromList [ (h,(hsModuleName mod,hsModuleRequires mod)) | (h,mod) <- modules]
recordHoFile newHo idep (map sourceHoName sc) hoh
writeIORef ref (CompCollected cho' (CompHo Nothing hoh newHo))
return cho'
findModule :: [Either Module String] -- ^ Either a module or filename to find
-> (CollectedHo -> Ho -> IO CollectedHo) -- ^ Process initial ho loaded from file
-> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho)) -- ^ Process set of mutually recursive modules to produce final Ho
-> IO (CollectedHo,[(Module,MD5.MD5Digest)],Ho) -- ^ (Final accumulated ho,just the ho read to satisfy this command)
findModule need ifunc func = do
(needed,cug) <- loadModules (optHls options) need
cnodes <- processCug cug
rnode <- mkPhonyCompNode needed cnodes
cho <- compileCompNode ifunc func rnode
return (cho,undefined,undefined)
-- Read in a Ho file.
readHoFile :: FilePath -> IO (HoHeader,HoIDeps,Ho)
readHoFile fn = do
bs <- BS.readFile fn
(ct,mp) <- bsCFF bs
True <- return $ ct == cff_magic
let fc ct = case lookup ct mp of
Nothing -> error $ "No chunk '" ++ show ct ++ "' found in file " ++ fn
Just x -> decode . decompress $ L.fromChunks [x]
return (fc cff_jhdr,fc cff_idep,mempty { hoExp = fc cff_defs, hoBuild = fc cff_core})
recordHoFile ::
Ho -- ^ File to record
-> HoIDeps
-> [FilePath] -- ^ files to write to
-> HoHeader -- ^ file header
-> IO ()
recordHoFile ho idep fs header = do
if optNoWriteHo options then do
wdump FD.Progress $ do
fs' <- mapM shortenPath fs
putErrLn $ "Skipping Writing Ho Files: " ++ show fs'
else do
let removeLink' fn = catch (removeLink fn) (\_ -> return ())
let g (fn:fs) = do
f fn
mapM_ (l fn) fs
return ()
g [] = error "Ho.g: shouldn't happen"
l fn fn' = do
wdump FD.Progress $ do
fn_ <- shortenPath fn
fn_' <- shortenPath fn'
when (optNoWriteHo options) $ putErr "Skipping "
putErrLn $ "Linking haskell object file:" <+> fn_' <+> "to" <+> fn_
if optNoWriteHo options then return () else do
let tfn = fn' ++ ".tmp"
removeLink' tfn
createLink fn tfn
rename tfn fn'
f fn = do
wdump FD.Progress $ do
when (optNoWriteHo options) $ putErr "Skipping "
fn' <- shortenPath fn
putErrLn $ "Writing haskell object file:" <+> fn'
if optNoWriteHo options then return () else do
let tfn = fn ++ ".tmp"
let theho = mapHoBodies eraseE ho
cfflbs = mkCFFfile cff_magic [
(cff_jhdr, compress $ encode header),
(cff_idep, compress $ encode idep),
(cff_defs, compress $ encode $ hoExp theho),
(cff_core, compress $ encode $ hoBuild theho)]
LBS.writeFile tfn cfflbs
rename tfn fn
g fs
hsModuleRequires x = Module "Lhc.Prim":ans where
noPrelude = or $ not (optPrelude options):[ opt == c | opt <- hsModuleOptions x, c <- ["-N","--noprelude"]]
ans = snub $ (if noPrelude then id else (Module "Prelude":)) [ hsImportDeclModule y | y <- hsModuleImports x]
searchPaths :: String -> [(String,String)]
searchPaths 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 options, n <- f m, suf <- [".hs",".lhs"], let root = i ++ "/" ++ n]
m4Prelude :: IO FilePath
m4Prelude = writeFile "/tmp/lhc_prelude.m4" prelude_m4 >> return "/tmp/lhc_prelude.m4"
langmap = [
"m4" ==> "m4",
"cpp" ==> "cpp",
"foreignfunctioninterface" ==> "ffi",
"noimplicitprelude" ==> "--noprelude",
"unboxedtuples" ==> "unboxed-tuples"
] where x ==> y = (x,if head y == '-' then y else "-f" ++ y)
parseHsSource :: String -> LBS.ByteString -> IO HsModule
parseHsSource fn lbs = do
let txt = UTF8.decode $ LBS.unpack lbs
let f s = opt where
Just opt = fileOptions opts `mplus` Just options
popts = parseOptions $ if "shl." `isPrefixOf` reverse fn then unlit fn s else s
opts' = concat [ words as | (x,as) <- popts, x `elem` ["OPTIONS","LHC_OPTIONS","OPTIONS_LHC"]]
opts = opts' ++ [ "--noprelude" | ("NOPRELUDE",_) <- popts] ++ langs
langs = catMaybes $ map (flip lookup langmap) $ concat [ words (map (\c -> if c == ',' then ' ' else toLower c) as) | ("LANGUAGE",as) <- popts ]
let fopts s = s `member` optFOptsSet initialOpts
initialOpts = f (take 4096 txt)
incFlags = [ "-I" ++ d | d <- optIncdirs options ++ optIncs initialOpts]
defFlags = ("-D__LHC__=" ++ version):[ "-D" ++ d | d <- optDefs initialOpts]
s <- case () of
_ | fopts FO.Cpp -> readSystem "cpp" $ ["-CC","-traditional"] ++ incFlags ++ defFlags ++ [fn]
| fopts FO.M4 -> do
m4p <- m4Prelude
readSystem "m4" $ ["-s", "-P"] ++ incFlags ++ defFlags ++ [m4p,fn]
| otherwise -> return txt
let s' = if "shl." `isPrefixOf` reverse fn then unlit fn s'' else s''
s'' = case s of
'#':' ':_ -> '\n':s -- line pragma
'#':'l':'i':'n':'e':' ':_ -> '\n':s -- line pragma
'#':'!':_ -> dropWhile (/= '\n') s -- hashbang
_ -> s
wdump FD.Preprocessed $ do
putStrLn s'
case runParserWithMode (parseModeOptions $ f s) { parseFilename = fn } parse s' of
ParseOk ws e -> processErrors ws >> return e
ParseFailed sl err -> putErrDie $ show sl ++ ": " ++ err
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
---------------------------------
-- library specific routines
---------------------------------
buildLibrary :: (CollectedHo -> Ho -> IO CollectedHo)
-> (CollectedHo -> [HsModule] -> IO (CollectedHo,Ho))
-> FilePath
-> IO ()
buildLibrary ifunc func = ans where
ans fp = do
(desc,name,hmods,emods) <- parse fp
let allmods = sort (emods ++ hmods)
(needed,cug) <- loadModules (optHls options) (map Left allmods)
rnode@(CompNode lhash _ _) <- processCug cug >>= mkPhonyCompNode needed
compileCompNode ifunc func rnode
(prvds,ho,ldeps) <- let
f (CompNode hs cd ref) = do
deps <- mconcat `fmap` mapM f cd
d <- readIORef ref >>= hunit hs
return $ d `mappend` deps
hunit hs x = case x of
CompHo (Just s) _ _ -> return (mempty,mempty,Map.singleton hs s)
CompHo Nothing hoh ho -> return (Set.fromList $ providesModules hoh,Map.singleton hs ho,mempty)
CompCollected _ u -> hunit hs u
CompPhony -> return mempty
in f rnode
--(cho,libDeps,ho) <- findModule (map Left (emods ++ hmods)) ifunc func
let unknownMods = Set.toList $ Set.filter (`notElem` allmods) prvds
mapM_ ((putStrLn . ("*** Module included in library that is not in export list: " ++)) . show) unknownMods
let outName = case optOutName options of
"hs.out" -> name ++ ".hl"
fn -> fn
let pdesc = [(n, packString v) | (n,v) <- ("lhc-hl-filename",outName):("lhc-description-file",fp):("lhc-compiled-by",versionString):desc, n /= "exposed-modules" ]
let hoh = HoHeader {
hohHash = lhash,
hohDepends = [ (m,Nothing) | m <- Set.toList prvds ],
hohModDepends = Map.keys ldeps,
hohMetaInfo = pdesc
}
recordHoFile (mconcat $ Map.elems ho) (HoIDeps Map.empty) [outName] hoh
-- parse library description file
parse fp = do
putVerboseLn $ "Creating library from description file: " ++ show fp
desc <- readDescFile fp
when verbose2 $ mapM_ print desc
let field x = lookup x desc
jfield x = maybe (fail $ "createLibrary: description lacks required field " ++ show x) return $ field x
mfield x = maybe [] (words . map (\c -> if c == ',' then ' ' else c)) $ field x
name <- jfield "name"
vers <- jfield "version"
let hmods = map Module $ snub $ mfield "hidden-modules"
emods = map Module $ snub $ mfield "exposed-modules"
return (desc,name ++ "-" ++ vers,hmods,emods)
------------------------------------
-- dumping contents of a ho file
------------------------------------
instance DocLike d => PPrint d SrcLoc where
pprint sl = tshow sl
vindent xs = vcat (map (" " ++) xs)
{-# NOINLINE dumpHoFile #-}
dumpHoFile :: String -> IO ()
dumpHoFile fn = do
(hoh,idep,ho) <- readHoFile fn
let hoB = hoBuild ho
hoE = hoExp ho
putStrLn fn
putStrLn $ "HoHash:" <+> pprint (hohHash hoh)
when (not $ Map.null (hoIDeps idep)) $ putStrLn $ "IDeps:\n" <> vindent (map pprint . Map.toList $ hoIDeps idep)
when (not $ Prelude.null (hohDepends hoh)) $ putStrLn $ "Dependencies:\n" <> vindent (map pprint . sortUnder fst $ hohDepends hoh)
when (not $ Prelude.null (hohModDepends hoh)) $ putStrLn $ "ModDependencies:\n" <> vindent (map pprint $ hohModDepends hoh)
when (not $ Prelude.null (hohMetaInfo hoh)) $ putStrLn $ "MetaInfo:\n" <> vindent (sort [text (' ':' ':k) <> char ':' <+> show v | (k,v) <- hohMetaInfo hoh])
putStrLn $ "Modules contained:" <+> tshow (mkeys $ hoExports hoE)
putStrLn $ "number of definitions:" <+> tshow (size $ hoDefs hoE)
putStrLn $ "hoAssumps:" <+> tshow (size $ hoAssumps hoB)
putStrLn $ "hoFixities:" <+> tshow (size $ hoFixities hoB)
putStrLn $ "hoKinds:" <+> tshow (size $ hoKinds hoB)
putStrLn $ "hoClassHierarchy:" <+> tshow (size $ hoClassHierarchy hoB)
putStrLn $ "hoTypeSynonyms:" <+> tshow (size $ hoTypeSynonyms hoB)
putStrLn $ "hoDataTable:" <+> tshow (size $ hoDataTable hoB)
putStrLn $ "hoEs:" <+> tshow (size $ hoEs hoB)
putStrLn $ "hoRules:" <+> tshow (size $ hoRules hoB)
wdump FD.Exports $ do
putStrLn "---- exports information ----";
CharIO.putStrLn $ (pprint $ hoExports hoE :: String)
wdump FD.Defs $ do
putStrLn "---- defs information ----";
CharIO.putStrLn $ (pprint $ hoDefs hoE :: String)
when (dump FD.Kind) $ do
putStrLn "---- kind information ----";
CharIO.putStrLn $ (pprint $ hoKinds hoB :: String)
when (dump FD.ClassSummary) $ do
putStrLn "---- class summary ---- "
printClassSummary (hoClassHierarchy hoB)
when (dump FD.Class) $
do {putStrLn "---- class hierarchy ---- ";
printClassHierarchy (hoClassHierarchy 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 CharIO.putStr (showDataTable (hoDataTable hoB))
putChar '\n'
wdump FD.Types $ do
putStrLn " ---- the types of identifiers ---- "
putStrLn $ show (pprint (hoAssumps hoB) :: PPrint.Doc)
wdump FD.Core $ do
putStrLn " ---- lambdacube ---- "
mapM_ (\ (v,lc) -> putChar '\n' >> printCheckName'' (hoDataTable hoB) v lc) (hoEs hoB)
where
printCheckName'' :: DataTable -> TVr -> E -> IO ()
printCheckName'' _dataTable tvr e = do
when (dump FD.EInfo || verbose2) $ putStrLn (show $ tvrInfo tvr)
putStrLn (show (hang 4 (pprint tvr <+> text "::" <+> pprint (tvrType tvr)) :: PPrint.Doc))
putStrLn (show (hang 4 (pprint tvr <+> equals <+> pprint e) :: PPrint.Doc))