module UHC.Light.Compiler.EHC.Main ( mainEHC ) where import System.Console.GetOpt import System.IO import System.Exit import System.Process import System.Environment import qualified UHC.Light.Compiler.Config as Cfg import UHC.Light.Compiler.EHC.Common import UHC.Light.Compiler.EHC.Main.Utils import qualified Control.Exception as CE import UHC.Light.Compiler.EHC.Environment import UHC.Light.Compiler.EHC.CompileUnit import UHC.Light.Compiler.EHC.CompileRun import UHC.Light.Compiler.EHC.InitialSetup import UHC.Light.Compiler.EHC.CompilePhase.TopLevelPhases import qualified Debug.Trace import qualified Data.Map as Map import qualified Data.Set as Set import Control.Monad.State import UHC.Util.Error import UHC.Util.Lens import UHC.Light.Compiler.EHC.BuildFunction import UHC.Light.Compiler.Base.Target import UHC.Light.Compiler.Base.Optimize (allOptimizeMp) import UHC.Light.Compiler.EHC.Main.Compile import qualified UHC.Light.Compiler.SourceCodeSig as Sig import UHC.Light.Compiler.EHC.CompilePhase.Module import UHC.Light.Compiler.Module.ImportExport (modBuiltin) import UHC.Light.Compiler.Module.ImportExport import UHC.Light.Compiler.Base.UnderDev import System.Directory import UHC.Light.Compiler.Base.PackageDatabase import UHC.Light.Compiler.Base.Parser2 import qualified UHC.Light.Compiler.ConfigCabal as Cfg (getDataDir) {-# LINE 106 "src/ehc/EHC/Main.chs" #-} mainEHC :: EHCOpts -> IO () mainEHC opts0 = do { args <- getArgs ; progName <- getProgName ; curDir <- getCurrentDirectory -- a non-empty data dir means we are running as cabal installed exec ; mbDataDir <- Cfg.getDataDir >>= \d -> return $ if null d then Nothing else Just d ; let opts1 = opts0 { ehcOptEnvironment = defaultEHCEnvironment , ehcProgName = p , ehcCurDir = curDir } where p = mkFPath "uhcl" -- hardbaked name oo@(o,n,errs) = ehcCmdLineOptsApply ([] ++ [\o -> if ehcOptIsUnderDev UnderDev_NameAnalysis o then o {ehcOptGenGenerics=False} else o] ++ (maybe [] (\d -> [\o -> o {ehcOptCfgInstallRoot = Just d}]) mbDataDir) ) args opts1 opts2 = maybe opts1 id o ; case opts2 of o | isNotOk (ehcOptMbTarget o) -> err $ "non existent target `" ++ fromNotOk (ehcOptMbTarget o) ++ "'" | isNotOk (ehcOptMbTargetFlavor o) -> err $ "non existent target flavor `" ++ fromNotOk (ehcOptMbTargetFlavor o) ++ "'" where err x = do { hPutStrLn stderr ("option error: " ++ x) ; exitFailure } _ -> return () ; userDir <- ehcenvDir (envkey opts2) ; let opts3 = opts2 { ehcOptUserDir = userDir , ehcOptOutputDir = let outputDir = maybe "." id (ehcOptOutputDir opts2) in case ehcOptPkgOpt opts2 of Just (PkgOption {pkgoptName=s}) -> case parsePkgKey s of Just k -> Just $ outputDir ++ "/" ++ mkInternalPkgFileBase k (Cfg.installVariant opts2) (ehcOptTarget opts2) (ehcOptTargetFlavor opts2) _ -> ehcOptOutputDir opts2 _ -> ehcOptOutputDir opts2 } ; case ehcOptImmQuit opts3 of Just immq -> let inputSuffixes = catMaybes [ s | (s,_,vis) <- mkFileSuffMpHs opts3, vis ] in handleImmQuitOption ehcCmdLineOpts inputSuffixes immq opts3 _ | null errs -> unless (null n) (doCompileRun n opts3) | otherwise -> do { putStr (head errs) ; exitFailure } } where envkey opts = mkEhcenvKey (Cfg.verFull Cfg.version) (fpathToStr $ ehcProgName opts) Cfg.ehcDefaultVariant {-# LINE 206 "src/ehc/EHC/Main.chs" #-} defaultEHCEnvironment :: EHCEnvironment defaultEHCEnvironment = EHCEnvironment Cfg.ehcDefaultVariant Cfg.ehcDefaultInplaceInstallDir {-# LINE 284 "src/ehc/EHC/Main.chs" #-} doCompilePrepare :: [String] -> EHCOpts -> IO (Maybe (EHCOpts,[FPath],[HsName],EHCompileRun m)) doCompilePrepare fnL@(fn:_) opts = do { let fpL@(fp:_) = map (mkTopLevelFPath "hs") fnL topModNmL@(topModNm:_) = map (mkHNm . fpathBase) fpL -- installVariant = Cfg.installVariant opts -- ; installRoot <- Cfg.installRootM opts -- ; userDir <- ehcenvDir (Cfg.verFull Cfg.version) -- ; let opts2 = opts -- {ehcOptUserDir = userDir} ; pkgDb1 <- pkgDbFromDirs opts ({- [ filePathCoalesceSeparator $ filePathUnPrefix $ Cfg.mkDirbasedInstallPrefix (filelocDir d) Cfg.INST_LIB_PKG "" (show (ehcOptTarget opts)) "" | d <- ehcOptPkgdirLocPath opts ] ++ [ filePathUnPrefix $ Cfg.mkDirbasedTargetVariantPkgPrefix installRoot installVariant (show (ehcOptTarget opts)) "" ] -} {- -} [ filePathUnPrefix d | d <- nub $ ehcOptPkgdirLocPath opts ++ [Cfg.mkInstallPkgdirUser opts, Cfg.mkInstallPkgdirSystem opts] ] ) ; let (pkgDb2,pkgErrs) = pkgDbSelectBySearchFilter (pkgSearchFilter Just PackageSearchFilter_ExposePkg (map tup123to1 $ pkgExposedPackages pkgDb1) ++ sort (ehcOptPackageSearchFilter opts) ) pkgDb1 pkgDb3 = pkgDbFreeze pkgDb2 -- ; putStrLn $ "db1 " ++ show pkgDb1 -- ; putStrLn $ "db2 " ++ show pkgDb2 -- ; putStrLn $ "db3 " ++ show pkgDb3 -- ; putStrLn (show $ ehcOptPackageSearchFilter opts) ; ehcioinfo <- newEHCIOInfo ; let searchPath = [emptyFileLoc] ++ ehcOptImportFileLocPath opts {- ++ [ mkPkgFileLoc (p, Nothing) $ filePathUnPrefix $ Cfg.mkDirbasedLibVariantTargetPkgPrefix (filelocDir d) "" (show (ehcOptTarget opts)) p | d <- ehcOptLibFileLocPath opts , p <- ehcOptLibPackages opts ] ++ [ mkPkgFileLoc p $ filePathUnPrefix $ Cfg.mkDirbasedTargetVariantPkgPrefix installRoot installVariant (show (ehcOptTarget opts)) p | p <- ( ehcOptLibPackages opts ++ (if ehcOptHideAllPackages opts then [] else Cfg.ehcAssumedPackages) ) ] -} ++ [fileLocPkgDb] opts3 = opts { ehcOptImportFileLocPath = searchPath , ehcOptPkgDb = pkgDb3 } {- this does not work in ghc 6.8.2 crsi = emptyEHCompileRunStateInfo { _crsiOpts = opts3 , _crsiHSInh = initialHSSem opts3 , _crsiEHInh = initialEHSem opts3 fp -- , crsiHIInh = initialHISem opts3 , crsiHSModInh = initialHSSemMod opts3 } -} crsi = (EHCompileRunStateInfo opts3 (astpipeForEHCOpts opts3) uidStart uidStart (initialHSSem opts3) (initialEHSem opts3 fp) (mkFileSuffMpHs opts3) (initialCEnv) initialCoreRunState -- initialCore2CoreRunSem Nothing -- (initialHISem opts3) (initialHSSemMod opts3) Map.empty Map.empty defaultOptim Map.empty ehcioinfo [] emptyBState ) initialState = mkEmptyCompileRun topModNm crsi ; return $ Just (opts3,fpL,topModNmL,initialState) } doCompileRun :: [String] -> EHCOpts -> IO () doCompileRun fnL@(fn:_) opts = do { mbPrep <- doCompilePrepare fnL opts ; if isJust mbPrep then do { let ( opts , fpL@(fp:_) , topModNmL@(topModNm:_) , initialState ) = fromJust mbPrep searchPath = ehcOptImportFileLocPath opts fileSuffMpHs = initialState ^. crStateInfo ^. crsiFileSuffMp ; when (ehcOptVerbosity opts >= VerboseDebug) (putStrLn $ "search path: " ++ show searchPath) ; _ <- if False -- ehcOptPriv opts then run initialState $ compile2 opts fileSuffMpHs searchPath fpL topModNmL else if ehcOptAltDriver opts then run initialState $ compileN_Alternate fpL topModNmL else run initialState $ compileN opts fileSuffMpHs searchPath fpL topModNmL ; return () } else exitFailure } where -- run s c = {- runErrorT $ -} runStateT (runCompilePhaseT c) s run s c = runStateT (runCompilePhaseT c) s -- init (to be moved elsewhere, TBD) -- initOther fileSuffMpHs = crsiFileSuffMp =: fileSuffMpHs -- experimental stuff trying to deal with orphan instances, ignore -- compile2 :: EHCCompileRunner m => EHCOpts -> FileSuffMp -> FileLocPath -> [FPath] -> [HsName] -> EHCompilePhaseT m () compile2 :: EHCOpts -> FileSuffMp -> FileLocPath -> [FPath] -> [HsName] -> EHCompilePhase () compile2 opts fileSuffMpHs searchPath fpL topModNmL = do { -- start with directly importing top modules, providing the filepath directly topModNmL' <- toplayer fpL topModNmL ; cpPP "topModNmL'" ; oneModNmL <- onelayer ; cpPP "oneModNmL" ; return () } where toplayer fpL topModNmL = zipWithM (\fp topModNm -> import1 opts fileSuffMpHs searchPath (ECUS_Haskell HSOnlyImports) (Just fp) Nothing topModNm) fpL topModNmL onelayer = do { cr <- get ; let modNmS = Map.keysSet $ _crCUCache cr ms = Set.unions [ case cuState e of -- ECUS_Haskell HIOnlyImports -> ecuTransClosedOrphanModS ecu _ -> ecuImpNmS e | m <- Set.toList modNmS, let e = crCU m cr ] `Set.difference` modNmS ; sequence -- or: cpSeq + return () [ do { i@(m',_) <- import1 opts fileSuffMpHs searchPath (ECUS_Haskell HSOnlyImports) Nothing Nothing m -- ; cpEhcFullProgModuleDetermineNeedsCompile m' ; return i } | m <- Set.toList ms ] } -- dbg {- showCompileOrder = do { cr <- get ; liftIO $ putStrLn $ "compile order: " ++ show (_crCompileOrder cr) } -}