uhc-util-0.1.6.2: src/UHC/Util/CompileRun3.hs
{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleContexts, FlexibleInstances, TypeSynonymInstances, FunctionalDependencies, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables #-}
-------------------------------------------------------------------------
-- | Combinators for a compile run.
-- 20150807: experimental version, to provide with a forwarding mechanism for renamed compile units. As of now does not work with UHC, suspect a non intented name capture
-------------------------------------------------------------------------
module UHC.Util.CompileRun3
( CompileRunner
, CompileRunState(..)
, CompileRun(..)
, crCUCache, crCompileOrder, crTopModNm, crState, crStateInfo, crNmForward
, CompilePhase
, CompilePhaseT(runCompilePhaseT)
, CompileUnit(..)
, CompileUnitState(..)
, CompileRunError(..)
, CompileModName(..)
, CompileRunStateInfo(..)
, CompileParticipation(..)
, FileLocatable(..)
, mkEmptyCompileRun
, crCU
, crMbCU, crMbCUNotForwarded, crMbCUForwarded
, ppCR
, cpUpdStateInfo, cpUpdSI
, cpUpdCU
, cpUpdCUWithKey
, cpMbCU
, cpSetFail, cpSetStop, cpSetStopSeq, cpSetStopAllSeq
, cpSetOk, cpSetErrs, cpSetLimitErrs, cpSetLimitErrsWhen, cpSetInfos, cpSetCompileOrder
, cpSeq, cpSeqWhen
, cpEmpty
, cpFindFileForNameOrFPath
, cpFindFilesForFPathInLocations, cpFindFilesForFPath, cpFindFileForFPath
, cpImportGather, cpImportGatherFromMods, cpImportGatherFromModsWithImp
, cpPP, cpPPMsg
, forgetM
)
where
import Data.Maybe
import System.Exit
import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Fix
import Control.Applicative(Applicative(..))
import UHC.Util.Error as ME
-- import Control.Monad.Error as ME
import Control.Monad.State
import qualified Control.Exception as CE
import Control.Monad.Identity
import System.IO
import qualified Data.Map as Map
import UHC.Util.Pretty
import UHC.Util.Utils
import UHC.Util.FPath
import UHC.Util.Lens
-------------------------------------------------------------------------
-- Utility
-------------------------------------------------------------------------
-- forget result
forgetM :: Monad m => m a -> m ()
forgetM m
= do { _ <- m
; return ()
}
-------------------------------------------------------------------------
-- The way a CompileUnit can participate
-------------------------------------------------------------------------
data CompileParticipation
= CompileParticipation_NoImport
deriving (Eq, Ord)
-------------------------------------------------------------------------
-- Interfacing with actual state info
-------------------------------------------------------------------------
-- | Conversion from string to module name
class CompileModName n where
mkCMNm :: String -> n
-- | State of a compile unit
class CompileUnitState s where
cusDefault :: s
cusUnk :: s
cusIsUnk :: s -> Bool
cusIsImpKnown :: s -> Bool
-- | Per compile unit
class CompileUnit u n l s | u -> n l s where
cuDefault :: u
cuFPath :: u -> FPath
cuUpdFPath :: FPath -> u -> u
cuLocation :: u -> l
cuUpdLocation :: l -> u -> u
cuKey :: u -> n
cuUpdKey :: n -> u -> u
cuState :: u -> s
cuUpdState :: s -> u -> u
cuImports :: u -> [n]
cuParticipation :: u -> [CompileParticipation]
-- defaults
cuParticipation _ = []
-- | Error reporting
class {- FPathError e => -} CompileRunError e p | e -> p where
crePPErrL :: [e] -> PP_Doc
creMkNotFoundErrL :: p -> String -> [String] -> [FileSuffix] -> [e]
creAreFatal :: [e] -> Bool
-- defaults
crePPErrL _ = empty
creMkNotFoundErrL _ _ _ _ = []
creAreFatal _ = True
class CompileRunStateInfo i n p where
crsiImportPosOfCUKey :: n -> i -> p
-------------------------------------------------------------------------
-- Class alias covering all requirements
-------------------------------------------------------------------------
-- | Class alias for compile functionality
class
( CompileModName nm
, CompileUnitState state
, CompileUnit unit nm loc state
, CompileRunError err pos
, CompileRunStateInfo info nm pos
, MonadState (CompileRun nm unit info err) m
-- , MonadError (CompileRunState err) m
, MonadIO m
, Monad m
) => CompileRunner state nm pos loc unit info err m
where
-------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------
instance CompileRunError String ()
-------------------------------------------------------------------------
-- Locatable
-------------------------------------------------------------------------
class FileLocatable x loc | loc -> x where -- funcdep has unlogical direction, but well...
fileLocation :: x -> loc
noFileLocation :: loc
-------------------------------------------------------------------------
-- State
-------------------------------------------------------------------------
data CompileRunState err
= CRSOk -- continue
| CRSFail -- fail and stop
| CRSFailMsg String -- fail with a message and stop
| CRSStopSeq -- stop current cpSeq
| CRSStopAllSeq -- stop current cpSeq, but also the surrounding ones
| CRSStop -- stop completely
| CRSFailErrL String [err] (Maybe Int) -- fail with errors and stop
| CRSErrInfoL String Bool [err] -- just errors, continue
data CompileRun nm unit info err
= CompileRun
{ _crCUCache :: Map.Map nm unit -- cached compile units
, _crNmForward :: Map.Map nm nm -- Forwarding mechanism for name changes
, _crCompileOrder :: [[nm]]
, _crTopModNm :: nm
, _crState :: CompileRunState err
, _crStateInfo :: info
, _crOutputDebug :: Bool
}
mkLabel ''CompileRun
instance Error (CompileRunState err) where
noMsg = CRSOk
strMsg = CRSFailMsg
-- instance Monad m => MonadError (CompileRunState err) m
instance Show (CompileRunState err) where
show CRSOk = "CRSOk"
show CRSFail = "CRSFail"
show (CRSFailMsg s) = "CRSFail: " ++ s
show CRSStopSeq = "CRSStopSeq"
show CRSStopAllSeq = "CRSStopAllSeq"
show CRSStop = "CRSStop"
show (CRSFailErrL _ _ _) = "CRSFailErrL"
show (CRSErrInfoL _ _ _) = "CRSErrInfoL"
mkEmptyCompileRun :: n -> i -> CompileRun n u i e
mkEmptyCompileRun nm info
= CompileRun
{ _crCUCache = Map.empty
, _crNmForward = Map.empty
, _crCompileOrder = []
, _crTopModNm = nm
, _crState = CRSOk
, _crStateInfo = info
, _crOutputDebug = False
}
-------------------------------------------------------------------------
-- Monad impl (20140804 AD, not (yet?) put into action, too much code still breaks)
-------------------------------------------------------------------------
-- | 'CompileRun' as state in specific StateT variant with non standard >>=
-- newtype CompilePhaseT n u i e m a = CompilePhaseT {runCompilePhaseT :: CompileRun n u i e -> m (a, CompileRun n u i e)}
newtype CompilePhaseT n u i e m a
= CompilePhaseT {runCompilePhaseT :: m a}
type CompilePhase n u i e a = CompilePhaseT n u i e Identity a
instance CompileRunner state n pos loc u i e m => Functor (CompilePhaseT n u i e m) where
fmap = liftM
instance CompileRunner state n pos loc u i e m => Applicative (CompilePhaseT n u i e m) where
pure = return
(<*>) = ap
-- instance CompileRunner state n pos loc u i e m where
instance CompileRunner state n pos loc u i e m => Monad (CompilePhaseT n u i e m) where
return x = CompilePhaseT $ return x -- \cr -> return (x, cr)
cp >>= f = CompilePhaseT $ do -- \cr1 -> do
x <- {- cpHandleErr' $ -} runCompilePhaseT cp -- (x,cr2) <- runCompilePhaseT cp cr1
let modf f = do {modify f ; return x}
cr <- get
case _crState cr of
CRSFailErrL about es mbLim
-> do { let (showErrs,omitErrs) = maybe (es,[]) (flip splitAt es) mbLim
; liftIO (unless (null about) (hPutPPLn stderr (pp about)))
; liftIO $ unless (null showErrs) $
do { hPutPPLn stderr (crePPErrL showErrs)
; unless (null omitErrs) $ hPutStrLn stderr "... and more errors"
; hFlush stderr
}
; if creAreFatal es then liftIO exitFailure else modf crSetOk
}
CRSErrInfoL about doPrint is
-> do { if null is
then return x
else liftIO (do { hFlush stdout
; hPutPPLn stderr (about >#< "found errors" >-< e)
; return x
})
; if not (null is) then liftIO exitFailure else return x
}
where e = empty -- if doPrint then crePPErrL is else empty
CRSFailMsg msg
-> do { liftIO $ hPutStrLn stderr msg
; liftIO exitFailure
}
CRSFail
-> do { liftIO exitFailure
}
CRSStop
-> do { liftIO $ exitWith ExitSuccess
}
_ -> return x
cr <- get
case _crState cr of
CRSOk -> runCompilePhaseT (f x)
CRSStopSeq -> do { modf crSetOk ; return $ panic "Monad.CompilePhaseT.CRSStopSeq" }
CRSStopAllSeq -> do { modf crSetStopAllSeq ; return $ panic "Monad.CompilePhaseT.CRSStopAllSeq" }
crs -> return $ panic "Monad.CompilePhaseT._"
{-
case _crState cr of
CRSOk -> runCompilePhaseT (f x)
CRSStopSeq -> do { modf crSetOk ; ME.throwError CRSStopSeq }
CRSStopAllSeq -> do { modf crSetStopAllSeq ; ME.throwError CRSStopAllSeq }
crs -> ME.throwError crs
-}
instance MonadTrans (CompilePhaseT n u i e) where
lift = CompilePhaseT
instance (CompileRunner state n pos loc u i e m, MonadState s m) => MonadState s (CompilePhaseT n u i e m) where
get = lift get
put = lift . put
instance (CompileRunner state n pos loc u i e m, MonadIO m) => MonadIO (CompilePhaseT n u i e m) where
liftIO = lift . liftIO
instance (CompileRunner state n pos loc u i e m, MonadError e' m) => MonadError e' (CompilePhaseT n u i e m) where
throwError = lift . throwError
catchError m hdl = lift $ catchError (runCompilePhaseT m) (runCompilePhaseT . hdl)
instance (CompileRunner state n pos loc u i e m, MonadFix m) => MonadFix (CompilePhaseT n u i e m) where
mfix f = CompilePhaseT $ mfix $ \ ~a -> runCompilePhaseT (f a)
{-
instance (MonadFix m) => MonadFix (StateT s m) where
mfix f = StateT $ \ s -> mfix $ \ ~(a, _) -> runStateT (f a) s
-}
{-
instance (Show e, MonadIO m) => MonadError e m where
throwError e = CE.throwIO $ CE.ErrorCall $ show e
catchError m hdl = CE.catch m hdl
-}
{-
-}
{-
instance MonadError m => MonadError (CompilePhaseT n u i e m) where
liftIO = CompilePhaseT . liftIO
-}
{-
instance (Monad m, MonadIO m, Monad (CompilePhaseT n u i e m)) => MonadIO (CompilePhaseT n u i e m) where
liftIO = lift . liftIO
-}
-------------------------------------------------------------------------
-- Pretty printing
-------------------------------------------------------------------------
ppCR :: (PP n,PP u) => CompileRun n u i e -> PP_Doc
ppCR cr
= "CR" >#< show (_crState cr) >|< ":" >#<
( (ppBracketsCommasBlock $ map (\(n,u) -> pp n >#< "->" >#< pp u) $ Map.toList $ _crCUCache cr)
>-< ppBracketsCommas (map ppBracketsCommas $ _crCompileOrder $ cr)
)
crPP :: (PP n,PP u) => String -> CompileRun n u i e -> IO (CompileRun n u i e)
crPP m cr = do { hPutStrLn stderr (m ++ ":") ; hPutPPLn stderr (ppCR cr) ; hFlush stderr ; return cr }
crPPMsg :: (PP m) => m -> CompileRun n u i e -> IO (CompileRun n u i e)
crPPMsg m cr = do { hPutPPLn stdout (pp m) ; return cr }
cpPP :: (PP n, PP u, CompileRunner s n p l u i e m) => String -> CompilePhaseT n u i e m ()
cpPP m
= do { liftIO (hPutStrLn stderr (m ++ ":"))
; cr <- get
; liftIO (hPutPPLn stderr (ppCR cr))
; liftIO (hFlush stderr)
; return ()
}
cpPPMsg :: (PP msg, CompileRunner s n p l u i e m) => msg -> CompilePhaseT n u i e m ()
cpPPMsg m
= do { liftIO (hPutPPLn stdout (pp m))
; return ()
}
-------------------------------------------------------------------------
-- State manipulation, sequencing: compile unit
-------------------------------------------------------------------------
crResolveForward :: Ord n => CompileRun n u i e -> n -> Maybe (n, n)
crResolveForward cr = resolve
where resolve n = Map.lookup n (_crNmForward cr) >>= \n -> (resolve n <|> return (n,n))
crLiftResolvedForward
:: Ord n
=> Maybe (n -> Maybe (n,rslv))
-> (n -> CompileRun n u i e -> Maybe res)
-> n
-> CompileRun n u i e
-> Maybe (res, Maybe rslv)
crLiftResolvedForward resolve action modNm cr =
(action modNm cr >>= \r -> return (r,Nothing))
<|> (resolve >>= ($ modNm) >>= \(n,rslv) -> action n cr >>= \r -> return (r, Just rslv))
-- <|> (resolve >>= \f -> let (n,rslv) = f modNm in fmap (\r -> (r, Just rslv)) $ action n cr)
crMbCU' :: Ord n => n -> CompileRun n u i e -> Maybe u
crMbCU' modNm cr = Map.lookup modNm (_crCUCache cr)
crMbCU :: Ord n => n -> CompileRun n u i e -> Maybe u
crMbCU = crMbCUForwarded -- crMbCU' id
{-# INLINE crMbCU #-}
crMbCUNotForwarded :: Ord n => n -> CompileRun n u i e -> Maybe u
crMbCUNotForwarded modNm cr = fmap fst $ crLiftResolvedForward Nothing crMbCU' modNm cr
{-# INLINE crMbCUNotForwarded #-}
crMbCUForwarded' :: Ord n => n -> CompileRun n u i e -> Maybe (u, Maybe n)
crMbCUForwarded' modNm cr = crLiftResolvedForward (Just $ crResolveForward cr) crMbCU' modNm cr
crMbCUForwarded :: Ord n => n -> CompileRun n u i e -> Maybe u
crMbCUForwarded modNm cr = fmap fst $ crMbCUForwarded' modNm cr
{-
crMbCU' :: Ord n => n -> CompileRun n u i e -> Maybe (n,u)
crMbCU' modNm cr = (fmap ((,) modNm) $ Map.lookup modNm (_crCUCache cr)) <|> (Map.lookup modNm (_crNmForward cr) >>= flip crMbCU' cr)
crMbCU :: Ord n => n -> CompileRun n u i e -> Maybe u
crMbCU modNm cr = fmap snd $ crMbCU' modNm cr
-}
crCU :: (Show n,Ord n) => n -> CompileRun n u i e -> u
crCU modNm = panicJust ("crCU: " ++ show modNm) . crMbCU modNm
-------------------------------------------------------------------------
-- State manipulation, sequencing: non monadic
-------------------------------------------------------------------------
crSetOk :: CompileRun n u i e -> CompileRun n u i e
crSetOk = crState ^= CRSOk -- cr {_crState = CRSOk}
crSetFail :: CompileRun n u i e -> CompileRun n u i e
crSetFail = crState ^= CRSFail -- cr {_crState = CRSFail}
crSetStop :: CompileRun n u i e -> CompileRun n u i e
crSetStop = crState ^= CRSStop -- cr {_crState = CRSStop}
crSetStopSeq :: CompileRun n u i e -> CompileRun n u i e
crSetStopSeq = crState ^= CRSStopSeq -- cr {_crState = CRSStopSeq}
crSetStopAllSeq :: CompileRun n u i e -> CompileRun n u i e
crSetStopAllSeq = crState ^= CRSStopAllSeq -- cr {_crState = CRSStopAllSeq}
crSetErrs' :: Maybe Int -> String -> [e] -> CompileRun n u i e -> CompileRun n u i e
crSetErrs' limit about es cr
= case es of
[] -> cr
_ -> cr {_crState = CRSFailErrL about es limit}
crSetInfos' :: String -> Bool -> [e] -> CompileRun n u i e -> CompileRun n u i e
crSetInfos' msg dp is cr
= case is of
[] -> cr
_ -> cr {_crState = CRSErrInfoL msg dp is}
-------------------------------------------------------------------------
-- Compile unit observations
-------------------------------------------------------------------------
crCUState :: (Ord n,CompileUnit u n l s,CompileUnitState s) => n -> CompileRun n u i e -> s
crCUState modNm cr = maybe cusUnk cuState (crMbCU modNm cr)
crCUFPath :: (Ord n,CompileUnit u n l s) => n -> CompileRun n u i e -> FPath
crCUFPath modNm cr = maybe emptyFPath cuFPath (crMbCU modNm cr)
crCULocation :: (Ord n,FileLocatable u loc) => n -> CompileRun n u i e -> loc
crCULocation modNm cr = maybe noFileLocation fileLocation (crMbCU modNm cr)
-------------------------------------------------------------------------
-- Find file for FPath
-------------------------------------------------------------------------
cpFindFileForNameOrFPath :: (FPATH n) => String -> n -> FPath -> [(String,FPath)]
cpFindFileForNameOrFPath loc _ fp = searchFPathFromLoc loc fp
cpFindFilesForFPathInLocations
:: ( Ord n, Show n
, FPATH n, FileLocatable u loc, Show loc
, CompileRunner s n p loc u i e m
) => (loc -> n -> FPath -> [(loc,FPath,[e])]) -- ^ get the locations for a name, possibly with errors
-> ((FPath,loc,[e]) -> res) -- ^ construct a result given a found location
-> Bool -- ^ stop when first is found
-> [(FileSuffix,s)] -- ^ suffix info
-> [loc] -- ^ locations to search
-> Maybe n -- ^ possibly a module name
-> Maybe FPath -- ^ possibly a file path
-> CompilePhaseT n u i e m [res]
cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp
= do { cr <- get
; let cus = maybe cusUnk (flip crCUState cr) mbModNm
; if cusIsUnk cus
then do { let fp = maybe (mkFPath $ panicJust ("cpFindFileForFPath") $ mbModNm) id mbFp
modNm = maybe (mkCMNm $ fpathBase $ fp) id mbModNm
suffs' = map fst suffs
; fpsFound <- liftIO (searchLocationsForReadableFiles (\l f -> getfp l modNm f)
stopAtFirst locs suffs' fp
)
; case fpsFound of
[]
-> do { cpSetErrs (creMkNotFoundErrL (crsiImportPosOfCUKey modNm (_crStateInfo cr)) (fpathToStr fp) (map show locs) suffs')
; return []
}
((_,_,e@(_:_)):_)
-> do { cpSetErrs e
; return []
}
ffs@((ff,loc,_):_)
-> do { when (_crOutputDebug cr) $ liftIO $ do
putStrLn $ "cpFindFilesForFPathInLocations found: " ++ show modNm ++ ", " ++ fpathToStr ff
putStrLn $ " mbModNm=" ++ show mbModNm ++ ", fp=" ++ fpathToStr fp
; cpUpdCU' True modNm (cuUpdLocation loc . cuUpdFPath ff . cuUpdState cus . cuUpdKey modNm)
; return (map putres ffs)
}
where cus = case lookup (Just $ fpathSuff ff) suffs of
Just c -> c
Nothing -> case lookup (Just "*") suffs of
Just c -> c
Nothing -> cusUnk
}
else return (maybe [] (\nm -> [putres (crCUFPath nm cr,crCULocation nm cr,[])]) mbModNm)
}
cpFindFilesForFPath
:: forall e n u p i s m .
( Ord n, Show n
, FPATH n, FileLocatable u String
, CompileRunner s n p String u i e m
) => Bool -> [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhaseT n u i e m [FPath]
cpFindFilesForFPath
= cpFindFilesForFPathInLocations (\l n f -> map (tup12to123 ([]::[e])) $ cpFindFileForNameOrFPath l n f) tup123to1
cpFindFileForFPath
:: ( Ord n, Show n
, FPATH n, FileLocatable u String
, CompileRunner s n p String u i e m
) => [(FileSuffix,s)] -> [String] -> Maybe n -> Maybe FPath -> CompilePhaseT n u i e m (Maybe FPath)
cpFindFileForFPath suffs sp mbModNm mbFp
= do { fps <- cpFindFilesForFPath True suffs sp mbModNm mbFp
; return (listToMaybe fps)
}
-------------------------------------------------------------------------
-- Gather all imports
-------------------------------------------------------------------------
-- | recursively extract imported modules, providing a way to import + do the import
cpImportGatherFromModsWithImp
:: (Show n, Ord n, CompileRunner s n p l u i e m)
=> (u -> [n]) -- get imports
-> (Maybe prev -> n -> CompilePhaseT n u i e m (x,Maybe prev)) -- extract imports from 1 module
-> [n] -- to be imported modules
-> CompilePhaseT n u i e m ()
cpImportGatherFromModsWithImp getImports imp1Mod modNmL
= do { cr <- get
; cpSeq ( [ one Nothing modNm | modNm <- modNmL ]
++ [ cpImportScc ]
)
}
where one prev modNm
= do { (_,new) <- {- cpHandleErr' $ -} imp1Mod prev modNm
-- ; cpHandleErr
; cr <- get
; if CompileParticipation_NoImport `elem` cuParticipation (crCU modNm cr)
then cpDelCU modNm
else imps new modNm
}
imps prev m
= do { cr <- get
; let impL m = [ i | i <- getImports (crCU m cr), not (cusIsImpKnown (crCUState i cr)) ]
; cpSeq (map (\n -> one prev n) (impL m))
}
-- | recursively extract imported modules
cpImportGatherFromMods
:: (Show n, Ord n, CompileRunner s n p l u i e m)
=> (Maybe prev -> n -> CompilePhaseT n u i e m (x,Maybe prev)) -- extract imports from 1 module
-> [n] -- to be imported modules
-> CompilePhaseT n u i e m ()
cpImportGatherFromMods = cpImportGatherFromModsWithImp cuImports
-- | Abbreviation for cpImportGatherFromMods for 1 module
cpImportGather
:: (Show n,Ord n,CompileRunner s n p l u i e m)
=> (n -> CompilePhaseT n u i e m ()) -> n -> CompilePhaseT n u i e m ()
cpImportGather imp1Mod modNm
= cpImportGatherFromMods
(\_ n -> do { r <- imp1Mod n
; return (r,Nothing)
}
)
[modNm]
crImportDepL :: (CompileUnit u n l s) => CompileRun n u i e -> [(n,[n])]
crImportDepL = map (\cu -> (cuKey cu,cuImports cu)) . Map.elems . _crCUCache
cpImportScc :: (Ord n, CompileRunner s n p l u i e m) => CompilePhaseT n u i e m ()
cpImportScc = modify (\cr -> (cr {_crCompileOrder = scc (crImportDepL cr)}))
-------------------------------------------------------------------------
-- State manipulation, state update (Monadic)
-------------------------------------------------------------------------
cpUpdStateInfo, cpUpdSI :: CompileRunner s n p l u i e m => (i -> i) -> CompilePhaseT n u i e m ()
cpUpdStateInfo upd = crStateInfo =$: upd
{-
= do { cr <- get
; put (cr {_crStateInfo = upd (_crStateInfo cr)})
}
-}
cpUpdSI = cpUpdStateInfo
-------------------------------------------------------------------------
-- State manipulation, compile unit update (Monadic)
-------------------------------------------------------------------------
{-
cpUpdCUM :: (Ord n, CompileRunner s n p l u i e m) => n -> (u -> IO u) -> CompilePhaseT n u i e m ()
cpUpdCUM modNm upd
= do { cr <- get
; cu <- liftIO $ maybe (upd cuDefault) upd (crMbCU modNm cr)
; crCUCache =$: Map.insert modNm cu
}
-}
{-
cpUpdCUWithKey :: (Ord n, CompileRunner s n p l u i e m) => n -> (n -> u -> (n,u)) -> CompilePhaseT n u i e m n
cpUpdCUWithKey modNm upd
= do { cr <- get
; let (modNm',cu) = (maybe (upd modNm cuDefault) (upd modNm) (crMbCU modNm cr))
; crCUCache =$: Map.insert modNm' cu . Map.delete modNm
; return modNm'
}
-}
cpUpdCUWithKey' :: (Show n, Ord n, CompileRunner s n p l u i e m) => Bool -> n -> (n -> u -> (n,u)) -> CompilePhaseT n u i e m n
cpUpdCUWithKey' isNew modNm upd
= do { cr <- get
; when isNew $ crNmForward =$: Map.delete modNm
; modNm' <- case crMbCUForwarded' modNm cr of
Just (cu, Nothing) -> do
let (modNm',cu') = upd modNm cu
if modNm == modNm'
then crCUCache =$: Map.adjust (const cu') modNm
else do
crCUCache =$: Map.insert modNm' cu' . Map.delete modNm
crNmForward =$: Map.insert modNm modNm'
-- ???? TBD, modNm' may have been used as a name in the forwarding map, should be delete there?
return modNm'
Just (cu, Just modNmForw) -> do
-- modNmForw /= modNm
let (modNm',cu') = upd modNm cu
if modNm == modNm'
then crCUCache =$: Map.adjust (const cu') modNmForw
else -- modNm /= modNm' && modNmForw /= modNm
if modNmForw == modNm'
then do
crCUCache =$: Map.insert modNm' cu' . Map.delete modNmForw
crNmForward =$: Map.insert modNm modNm'
else do -- modNm /= modNm' && modNmForw /= modNm && modNmForw /= modNm'
crCUCache =$: Map.insert modNm' cu' . Map.delete modNmForw
crNmForward =$: Map.insert modNm modNm' . Map.insert modNmForw modNm' -- TBD: whole chain must be updated to point to modNm'
return modNm'
_ -> do
let (modNm',cu') = upd modNm cuDefault
crCUCache =$: Map.insert modNm' cu'
return modNm'
; cr <- get
; when (_crOutputDebug cr) $ liftIO $ do
putStrLn $ "cpUpdCUWithKey " ++ show modNm ++ " -> " ++ show modNm'
putStrLn $ " " ++ (show $ Map.keys $ cr ^. crCUCache)
putStrLn $ " " ++ (show $ cr ^. crNmForward)
; return modNm'
}
cpUpdCUWithKey :: (Show n, Ord n, CompileRunner s n p l u i e m) => n -> (n -> u -> (n,u)) -> CompilePhaseT n u i e m n
cpUpdCUWithKey = cpUpdCUWithKey' False
{-# INLINE cpUpdCUWithKey #-}
cpUpdCU' :: (Show n, Ord n, CompileRunner s n p l u i e m) => Bool -> n -> (u -> u) -> CompilePhaseT n u i e m ()
cpUpdCU' isNew modNm upd
= do { cpUpdCUWithKey' isNew modNm (\k u -> (k, upd u))
; return ()
}
cpUpdCU :: (Show n, Ord n, CompileRunner s n p l u i e m) => n -> (u -> u) -> CompilePhaseT n u i e m ()
cpUpdCU = cpUpdCU' False
{-# INLINE cpUpdCU #-}
-- | lookup unit
cpMbCU :: (Ord n,CompileRunner s n p l u i e m) => n -> CompilePhaseT n u i e m (Maybe u)
cpMbCU modNm = liftM (crMbCU modNm) get
-- | lookup unit, with forwarding of renamed keys
cpMbCUForwarded :: (Ord n,CompileRunner s n p l u i e m) => n -> CompilePhaseT n u i e m (Maybe u)
cpMbCUForwarded modNm = liftM (crMbCUForwarded modNm) get
-- | delete unit
cpDelCU :: (Ord n,CompileRunner s n p l u i e m) => n -> CompilePhaseT n u i e m ()
cpDelCU modNm = do
cr <- get
case crMbCUForwarded' modNm cr of
Just (_, Nothing) -> do
crCUCache =$: Map.delete modNm
Just (_, Just modNmForw) -> do
crCUCache =$: Map.delete modNmForw
_ -> return ()
-------------------------------------------------------------------------
-- State manipulation, sequencing (Monadic)
-------------------------------------------------------------------------
cpSetErrs :: CompileRunner s n p l u i e m => [e] -> CompilePhaseT n u i e m ()
cpSetErrs es
= modify (crSetErrs' Nothing "" es)
cpSetInfos :: CompileRunner s n p l u i e m => String -> Bool -> [e] -> CompilePhaseT n u i e m ()
cpSetInfos msg dp is
= modify (crSetInfos' msg dp is)
cpSetFail :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpSetFail
= modify crSetFail
cpSetStop :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpSetStop
= modify crSetStop
cpSetStopSeq :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpSetStopSeq
= modify crSetStopSeq
cpSetStopAllSeq :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpSetStopAllSeq
= modify crSetStopAllSeq
cpSetOk :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpSetOk = crState =: CRSOk
-- = modify (\cr -> (cr {_crState = CRSOk}))
cpSetCompileOrder :: CompileRunner s n p l u i e m => [[n]] -> CompilePhaseT n u i e m ()
cpSetCompileOrder nameLL = crCompileOrder =: nameLL
-- = modify (\cr -> (cr {_crCompileOrder = nameLL}))
cpSetLimitErrs, cpSetLimitErrsWhen :: CompileRunner s n p l u i e m => Int -> String -> [e] -> CompilePhaseT n u i e m ()
cpSetLimitErrs l a e
= modify (crSetErrs' (Just l) a e)
cpSetLimitErrsWhen l a e
= do { when (not (null e))
(cpSetLimitErrs l a e)
}
cpEmpty :: CompileRunner s n p l u i e m => CompilePhaseT n u i e m ()
cpEmpty = return ()
-- sequence of phases, each may stop the whole sequencing
cpSeq :: CompileRunner s n p l u i e m => [CompilePhaseT n u i e m ()] -> CompilePhaseT n u i e m ()
cpSeq = sequence_
{-
-}
{-
cpSeq [] = return ()
cpSeq (a:as) = do { a
; cpHandleErr
; cr <- get
; case _crState cr of
CRSOk -> cpSeq as
CRSStopSeq -> cpSetOk
CRSStopAllSeq -> cpSetStopAllSeq
_ -> return ()
}
-}
-- conditional sequence
cpSeqWhen :: CompileRunner s n p l u i e m => Bool -> [CompilePhaseT n u i e m ()] -> CompilePhaseT n u i e m ()
cpSeqWhen True as = cpSeq as
cpSeqWhen _ _ = return ()
-- handle possible error in sequence
{-
cpHandleErr :: CompileRunError e p => CompilePhase n u i e ()
cpHandleErr
= do { cr <- get
; case _crState cr of
CRSFailErrL about es (Just lim)
-> do { let (showErrs,omitErrs) = splitAt lim es
; liftIO (unless (null about) (hPutPPLn stderr (pp about)))
; liftIO (putErr' (if null omitErrs then return () else hPutStrLn stderr "... and more errors") showErrs)
; failOrNot es
}
CRSFailErrL about es Nothing
-> do { liftIO (unless (null about) (hPutPPLn stderr (pp about)))
; liftIO (putErr' (return ()) es)
; failOrNot es
}
CRSErrInfoL about doPrint is
-> do { if null is
then return ()
else liftIO (do { hFlush stdout
; hPutPPLn stderr (about >#< "found errors" >-< e)
})
; if not (null is) then liftIO exitFailure else return ()
}
where e = empty -- if doPrint then crePPErrL is else empty
CRSFail
-> do { liftIO exitFailure
}
CRSStop
-> do { liftIO $ exitWith ExitSuccess
}
_ -> return ()
}
where putErr' m e = if null e
then return ()
else do { hPutPPLn stderr (crePPErrL e)
; m
; hFlush stderr
}
failOrNot es = if creAreFatal es then liftIO exitFailure else cpSetOk
-}