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)
mainEHC :: EHCOpts -> IO ()
mainEHC opts0
= do { args <- getArgs
; progName <- getProgName
; curDir <- getCurrentDirectory
; 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"
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
defaultEHCEnvironment :: EHCEnvironment
defaultEHCEnvironment
= EHCEnvironment Cfg.ehcDefaultVariant Cfg.ehcDefaultInplaceInstallDir
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
; pkgDb1 <- pkgDbFromDirs 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
; ehcioinfo <- newEHCIOInfo
; let searchPath = [emptyFileLoc]
++ ehcOptImportFileLocPath opts
++ [fileLocPkgDb]
opts3 = opts { ehcOptImportFileLocPath = searchPath
, ehcOptPkgDb = pkgDb3
}
crsi = (EHCompileRunStateInfo opts3
(astpipeForEHCOpts opts3)
uidStart uidStart
(initialHSSem opts3)
(initialEHSem opts3 fp)
(mkFileSuffMpHs opts3)
(initialCEnv)
initialCoreRunState
Nothing
(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
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 = runStateT (runCompilePhaseT c) s
compile2 :: EHCOpts -> FileSuffMp -> FileLocPath -> [FPath] -> [HsName] -> EHCompilePhase ()
compile2 opts fileSuffMpHs searchPath fpL topModNmL
= do {
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
_ -> ecuImpNmS e
| m <- Set.toList modNmS, let e = crCU m cr
]
`Set.difference` modNmS
; sequence
[ do { i@(m',_) <- import1 opts fileSuffMpHs searchPath (ECUS_Haskell HSOnlyImports) Nothing Nothing m
; return i
}
| m <- Set.toList ms
]
}