Output.hs

module UHC.Light.Compiler.EHC.CompilePhase.Output
( cpOutputSomeModules
, cpOutputSomeModule
, cpOutputCore
, cpOutputHI )
where
import UHC.Util.Lens
import qualified UHC.Util.FastSeq as Seq
import qualified Data.Map as Map
import qualified Data.Set as Set
import Control.Monad.State
import UHC.Util.Lens
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.CompileRun
import qualified UHC.Light.Compiler.Config as Cfg
import UHC.Light.Compiler.EHC.ASTHandler.Instances
import qualified UHC.Light.Compiler.Core.ToGrin as Core2GrSem
import UHC.Light.Compiler.Core.Trf.EraseExtractTysigCore
import UHC.Util.Time
import System.Directory
import qualified UHC.Light.Compiler.SourceCodeSig as Sig
import qualified UHC.Light.Compiler.HI as HI
import qualified UHC.Util.Binary as Bin
import UHC.Util.Serialize
import UHC.Light.Compiler.Gam
import UHC.Light.Compiler.Module.ImportExport
import qualified UHC.Light.Compiler.EH.MainAG as EHSem
import UHC.Light.Compiler.Gam.Utils











{-# LINE 107 "src/ehc/EHC/CompilePhase/Output.chs" #-}
-- | Abstraction for writing some module to output with variation in suffices
cpOutputSomeModules
  :: EHCCompileRunner m
     => ASTHandler' mod -- (EHCOpts -> EHCompileUnit -> FPath -> FilePath -> mod -> IO Bool)
     -> ASTFileContent
     -> (Int -> String -> String)
     -> String
     -> HsName
     -> [(String,mod)]
     -> EHCompilePhaseT m [Maybe FPath]
cpOutputSomeModules astHdlr how mknmsuff suff modNm mods = do
    cr <- get
    let  (ecu,crsi,opts,fp) = crBaseInfo modNm cr
    forM (zip [1..] mods) $ \(nr,(nmsuff,mod)) -> do
      let fpC     = _asthdlrMkOutputFPath astHdlr opts modNm fp (suff ++ mknmsuff nr nmsuff) -- for now nmsuff after suff, but should be inside name
          fnC     = fpathToStr fpC
      okWrite <- if ecuSrcHasSuffix suff ecu
        then return False
        else liftIO $ do
          -- fpathEnsureExists fpC
          asthdlrOutputIO astHdlr how opts ecu modNm fpC fnC mod
      return $ if okWrite then Just fpC else Nothing

{-# LINE 132 "src/ehc/EHC/CompilePhase/Output.chs" #-}
-- | Abstraction for writing a module, using cpOutputSomeModules
cpOutputSomeModule
  :: EHCCompileRunner m
     => (EHCompileUnit -> mod)
     -> ASTHandler' mod
     -> ASTFileContent
     -> String
     -> String
     -> HsName
     -> EHCompilePhaseT m (Maybe FPath)
cpOutputSomeModule getMod astHdlr how nmsuff suff modNm
  =  do  {  cr <- get
         ;  let  (ecu,_,_,_) = crBaseInfo modNm cr
                 mod    = getMod ecu
         ;  cpMsg modNm VerboseALot $ "Emit " ++ _asthdlrName astHdlr
         ;  fmap head $ cpOutputSomeModules astHdlr how (\_ nm -> nm) suff modNm [(nmsuff,mod)]
         }

{-# LINE 188 "src/ehc/EHC/CompilePhase/Output.chs" #-}
cpOutputCore :: EHCCompileRunner m => ASTFileContent -> String -> String -> HsName -> EHCompilePhaseT m FPath
cpOutputCore how nmsuff suff modNm =
    fmap (panicJust "cpOutputGrin.cpOutputSomeModule") $
      cpOutputSomeModule (^. ecuCore) astHandler'_Core how nmsuff suff modNm

{-# LINE 254 "src/ehc/EHC/CompilePhase/Output.chs" #-}
cpOutputHI :: EHCCompileRunner m => String -> HsName -> EHCompilePhaseT m ()
cpOutputHI suff modNm
  =  do  {  cr <- get
         ;  let  (ecu,crsi,opts,fp) = crBaseInfo modNm cr
                 mmi    = panicJust "cpOutputHI.crsiModMp" $ Map.lookup modNm $ crsiModMp crsi
                 hii1   = ecu ^. ecuHIInfo
                 impNmS = ecuImpNmS ecu
                 hii2   = hii1 { HI.hiiValidity             = HI.HIValidity_Ok
                               , HI.hiiModuleNm             = modNm
                               , HI.hiiExps                 = mmiExps       mmi
                               , HI.hiiHiddenExps           = mmiHiddenExps mmi
                               , HI.hiiHasMain              = ecuHasMain ecu
                               , HI.hiiTarget               = ehcOptTarget opts
                               , HI.hiiTargetFlavor         = ehcOptTargetFlavor opts
                               , HI.hiiSrcTimeStamp         = Sig.timestamp
                               , HI.hiiSrcSig               = Sig.sig
                               , HI.hiiSrcVersionMajor      = Cfg.verMajor Cfg.version
                               , HI.hiiSrcVersionMinor      = Cfg.verMinor Cfg.version
                               , HI.hiiSrcVersionMinorMinor = Cfg.verMinorMinor Cfg.version
                               , HI.hiiSrcVersionSvn        = Cfg.verSvnRevision Cfg.version
                               , HI.hiiCompileFlags         = optsDiscrRecompileRepr opts
                               , HI.hiiCompiler             = Cfg.installVariant opts
                               , HI.hiiTransClosedUsedModMp = Map.unions $
                                                                Map.singleton modNm impNmS : [ ecuTransClosedUsedModMp $ crCU m cr | m <- Set.toList impNmS ]
                               , HI.hiiTransClosedOrphanModS= Set.unions $
                                                                [ Set.unions [if ecuIsOrphan me then Set.singleton m else Set.empty, ecuTransClosedOrphanModS me]
                                                                | m <- Set.toList impNmS
                                                                , let me = crCU m cr
                                                                ]
                               }
                 hii3   = hii2
                 fpH    = mkOutputFPath opts modNm fp suff
                 fnH    = fpathToStr fpH
         ;  cpMsg modNm VerboseALot "Emit HI"
         ;  hiExists <- liftIO $ doesFileExist fnH
         ;  when (hiExists)
                 (liftIO $ removeFile fnH)
         ;  when (ehcOptVerbosity opts > VerboseALot)
                 (do { liftIO $ putPPLn ("hii3: " >#< hii3)
                     ; liftIO $ putPPLn ("orph: " >#< vlist [ m >#< (fmap Set.toList $ HI.hiiMbOrphan $ me ^. ecuHIInfo) | m <- Set.toList impNmS, let me = crCU m cr ])
                     ; liftIO $ putPPLn ("used nms: " >#< (pp $ show $ ecuUsedNames ecu))
                     })
{-
         ;  liftIO $ do { fpathEnsureExists fpH
                        ; putSerializeFile fnH hii3
                        }
-}
         ;  liftIO $ asthdlrOutputIO astHandler'_HI ASTFileContent_Binary opts ecu modNm fpH fnH hii3
         ;  now <- liftIO $ getClockTime
         ;  cpUpdCU modNm ( ecuStoreHIInfoTime now
                          . ecuStoreHIInfo hii3
                          )
         }