Run.hs

{-# LANGUAGE GADTs #-}

module UHC.Light.Compiler.EHC.BuildFunction.Run
( module UHC.Light.Compiler.EHC.BuildFunction
, bcall
, bderef )
where
import UHC.Light.Compiler.EHC.BuildFunction
import UHC.Light.Compiler.EHC.Common
import UHC.Light.Compiler.EHC.CompileRun
import UHC.Light.Compiler.EHC.CompileUnit
import UHC.Light.Compiler.EHC.FileSuffMp
import UHC.Light.Compiler.EHC.ASTHandler
import UHC.Light.Compiler.EHC.ASTHandler.Instances
import UHC.Util.Lens
import Data.Typeable
import qualified Data.Map as Map
import Control.Monad.State
import System.Directory
import UHC.Light.Compiler.Base.PackageDatabase




{-# LINE 53 "src/ehc/EHC/BuildFunction/Run.chs" #-}
-- | Execute a build function, possibly caching/memoizing a result
bcall :: forall res m . (Typeable res) => EHCCompileRunner m => BFun' res -> EHCompilePhaseT m res
bcall bfun = do
    bcache <- getl $ st ^* bstateCache

    mbCachedRes <- lkup bfun bcache
    case mbCachedRes of
      Just res -> return res
      _ -> do
        -- prepare
        start
        -- actual execution
        res <- case bfun of
          EcuOfName modNm -> do
               bcall $ EcuOfNameAndPath Nothing (modNm, Nothing)

          EHCOptsOf modNm -> do
               fmap (panicJust "EHCOptsOf") $ bderef (BRef_EHCOpts modNm)

          EcuOfNameAndPath mbPrev (modNm,mbFp) -> do
               opts <- bcall $ EHCOptsOf modNm
               let isTopModule = isJust mbFp
                   searchPath = ehcOptImportFileLocPath opts
                   adaptFileSuffMp = if isTopModule then (fileSuffMpHsNoSuff ++) else id
               fileSuffMpHs <- fmap (map tup123to12 . adaptFileSuffMp) $ getl $ crStateInfo ^* crsiFileSuffMp
               let searchPath' = prevSearchInfoAdaptedSearchPath mbPrev searchPath
               fpsFound <- cpFindFilesForFPathInLocations (fileLocSearch opts) tup123to1 False fileSuffMpHs searchPath' (Just modNm) mbFp
               when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ do
                    putStrLn $ show modNm ++ ": " ++ show (fmap fpathToStr mbFp) ++ ": " ++ show (map fpathToStr fpsFound)
                    putStrLn $ "searchPath: " ++ show searchPath'
               when isTopModule
                    (cpUpdCU modNm (ecuSetIsTopMod True))
               bmemo $ BRef_ECU modNm
               fmap (panicJust "EcuOfNameAndPath") $ cpMbCU modNm

          FPathSearchForFile suff fn -> do
               let fp    = mkTopLevelFPath suff fn
                   modNm = mkHNm $ fpathBase fp
               breturn (modNm, fp)

          ASTFromFile mf@(modNm,_) asttype skey tkey -> case asthandlerLookup asttype of
               Just (hdlr :: ASTHandler' res) -> case astsuffixLookup skey $ _asthdlrSuffixRel hdlr of
                 Just suffinfo -> do
                   ecu <- bcall $ EcuOfNameAndPath Nothing mf
                   let ref = BRef_AST modNm asttype skey tkey
                   -- (_,set) <- bderef'
                   -- TBD: the actual input
                   -- breturn ref
                   return Nothing
                 _ -> return Nothing
               _ -> return Nothing

          ModfTimeOfFile modNm asttype skey tkey -> case (asthandlerLookup' asttype $ \hdlr -> do
                                                              suffinfo <- astsuffixLookup skey $ _asthdlrSuffixRel hdlr
                                                              lens <- Map.lookup tkey $ _astsuffinfoModfTimeMp suffinfo
                                                              return (_astsuffinfoSuff suffinfo, lens)
                                                         ) of
                 Just (suff, lens) -> do
                        cr <- get
                        let (ecu,_,opts,fp) = crBaseInfo modNm cr
                        tm opts ecu ((lens ^=) . Just) (fpathSetSuff suff fp)
                 _ -> return Nothing
            where
              tm opts ecu store fp = do
                  let n = fpathToStr fp
                  nExists <- liftIO $ doesFileExist n
                  when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("meta info of: " ++ show (ecuModNm ecu) ++ ", file: " ++ n ++ ", exists: " ++ show nExists)
                  if nExists
                    then do
                      t <- liftIO $ fpathGetModificationTime fp
                      when (ehcOptVerbosity opts >= VerboseDebug) $ liftIO $ putStrLn ("time stamp of: " ++ show (ecuModNm ecu) ++ ", time: " ++ show t)
                      cpUpdCU modNm $ store t
                      return $ Just t
                    else return Nothing

          _ -> panic $ "BuildFunction.Run.bcall: not implemented: " ++ show bfun

        -- finalize
        end
        return res
  where
    st    = crStateInfo ^* crsiBState

    start = st ^* bstateCallStack =$: (BFun bfun :)
    end   = st ^* bstateCallStack =$: tail

    -- memoize
    bmemo :: Typeable f => f res -> EHCompilePhaseT m ()
    bmemo res = do
        (BFun bfun : _) <- getl $ st ^* bstateCallStack
        case cast bfun of
          Just bfun -> st ^* bstateCache =$: bcacheInsert bfun res
          _ -> panic $ "BuildFunction.Run.bcall.bmemo: " ++ show bfun

    -- memoize & return
    breturn :: res -> EHCompilePhaseT m res
    breturn res = do
        bmemo (Identity res)
        return res

    lkup :: BFun' res -> BCache -> EHCompilePhaseT m (Maybe res)
    lkup bfun bcache =
        case bcacheLookup bfun bcache of
          Just (res :: Identity res) -> return $ Just $ runIdentity res
          _ -> case bcacheLookup bfun bcache of
            Just (ref :: BRef res) -> bderef ref
            _ -> return Nothing

{-# LINE 181 "src/ehc/EHC/BuildFunction/Run.chs" #-}
-- | Dereference an indirection into compilation state, possibly with a result, and a setter
bderef' :: forall res m . (Typeable res, EHCCompileRunner m) => BRef res -> EHCompilePhaseT m (Maybe res, Maybe (res -> EHCompilePhaseT m ()))
bderef' bref = do
    cr <- get
    case bref of
      BRef_ECU modNm -> return (crMbCU modNm cr, Just $ \ecu -> cpUpdCU modNm (const ecu))
      BRef_EHCOpts modNm -> return (Just choose, Nothing)
        where opts = cr ^. crStateInfo ^. crsiOpts
              choose = maybe opts id $ crMbCU modNm cr >>= ecuMbOpts
      BRef_AST modNm asttype skey tkey -> case asthandlerLookup asttype of
          Just (hdlr :: ASTHandler' res) -> case astsuffixLookup skey $ _asthdlrSuffixRel hdlr of
            Just suffinfo -> case Map.lookup tkey $ _astsuffinfoASTLensMp suffinfo of
              Just l -> do
                ecu <- bcall $ EcuOfName modNm
                return (ecu ^. l, Just $ \ast -> cpUpdCU modNm $ l ^= Just ast)
              _ -> return (Nothing, Nothing)
            _ -> return (Nothing, Nothing)
          _ -> return (Nothing, Nothing)

-- | Dereference an indirection into compilation state
bderef :: forall res m . (Typeable res, EHCCompileRunner m) => BRef res -> EHCompilePhaseT m (Maybe res)
bderef bref = fmap fst $ bderef' bref