uhc-util 0.1.5.6 → 0.1.6.0

raw patch · 7 files changed

+892/−11 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/UHC/Util/CompileRun.hs +8/−2
• src/UHC/Util/CompileRun2.hs +18/−2
• src/UHC/Util/CompileRun3.hs +823/−0
• src/UHC/Util/FPath.hs +10/−2
• src/UHC/Util/Hashable.hs +10/−2
• src/UHC/Util/Utils.hs +20/−1
• uhc-util.cabal +3/−2

@@ -489,8 +489,14 @@   :: ( Ord n      , FPATH n, FileLocatable u loc, Show loc      , CompileUnitState s,CompileRunError e p,CompileUnit u n loc s,CompileModName n,CompileRunStateInfo i n p-     ) => (loc -> n -> FPath -> [(loc,FPath,[e])]) -> ((FPath,loc,[e]) -> res)-          -> Bool -> [(FileSuffix,s)] -> [loc] -> Maybe n -> Maybe FPath -> CompilePhase n u i e [res]+     ) => (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+       -> CompilePhase n u i e [res] cpFindFilesForFPathInLocations getfp putres stopAtFirst suffs locs mbModNm mbFp   = do { cr <- get        ; let cus = maybe cusUnk (flip crCUState cr) mbModNm

@@ -54,6 +54,7 @@ import           Data.Maybe import           System.Exit import           Control.Monad+import           Control.Monad.Fix import           Control.Applicative(Applicative(..)) import           Control.Monad.Error as ME import           Control.Monad.State@@ -301,7 +302,16 @@   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@@ -419,8 +429,14 @@   :: ( Ord n      , FPATH n, FileLocatable u loc, Show loc      , CompileRunner s n p loc u i e m-     ) => (loc -> n -> FPath -> [(loc,FPath,[e])]) -> ((FPath,loc,[e]) -> res)-          -> Bool -> [(FileSuffix,s)] -> [loc] -> Maybe n -> Maybe FPath -> CompilePhaseT n u i e m [res]+     ) => (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

@@ -0,0 +1,823 @@+{-# 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           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+-}+

@@ -54,6 +54,7 @@ where  import Data.Maybe+import Data.Typeable import Data.List import Control.Monad import System.IO@@ -111,7 +112,7 @@       , fpathBase       ::         !String       , fpathMbSuff     :: !(Maybe  String)       }-    deriving (Show,Eq,Ord,Generic)+    deriving (Show,Eq,Ord,Typeable,Generic)  -- | Empty FPath emptyFPath :: FPath@@ -374,7 +375,14 @@ searchFPathFromLoc :: FilePath -> FPath -> [(FilePath,FPath)] searchFPathFromLoc loc fp = [(loc,fpathPrependDir loc fp)] -searchLocationsForReadableFiles :: (loc -> FPath -> [(loc,FPath,[e])]) -> Bool -> [loc] -> FileSuffixes -> FPath -> IO [(FPath,loc,[e])]+-- | Search for file in locations, with possible suffices+searchLocationsForReadableFiles+  ::    (loc -> FPath -> [(loc,FPath,[e])])				-- ^ get the locations for a name, possibly with errors+     -> Bool											-- ^ stop when first is found+     -> [loc]											-- ^ locations to search+     -> FileSuffixes									-- ^ suffixes to try+     -> FPath											-- ^ search for a path+     -> IO [(FPath,loc,[e])] searchLocationsForReadableFiles getfp stopAtFirst locs suffs fp   = let select stop f fps           = foldM chk [] fps

@@ -7,9 +7,17 @@   )   where -import Data.Hashable-import UHC.Util.FPath+import           Data.Hashable+import qualified Data.Map as Map+import qualified Data.Set as Set+import           UHC.Util.FPath  -- Instances  instance Hashable FPath++instance Hashable a => Hashable (Set.Set a) where+  hashWithSalt = Set.foldl' hashWithSalt++instance (Hashable a, Hashable b) => Hashable (Map.Map a b) where+  hashWithSalt = Map.foldlWithKey (\salt a b -> salt `hashWithSalt` a `hashWithSalt` b)

@@ -29,10 +29,14 @@   , strWhite   , strPad   , strCapitalize+  , strToLower   , strToInt      , splitForQualified   +    -- * Show+  , showUnprefixedWithTypeable+       -- * Misc   , panic   @@ -62,7 +66,7 @@     -- * Graph   , scc   -    -- * MOnad+    -- * Monad   , firstMaybeM   )   where@@ -70,6 +74,7 @@ -- import UHC.Util.Pretty import Data.Char import Data.List+import Data.Typeable import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Graph as Graph@@ -213,9 +218,23 @@       (c:cs) -> toUpper c : cs       _      -> s +-- | Lower case+strToLower :: String -> String+strToLower = map toLower+{-# INLINE strToLower #-}+ -- | Convert string to Int strToInt :: String -> Int strToInt = foldl (\i c -> i * 10 + ord c - ord '0') 0++-------------------------------------------------------------------------+-- Split for qualified name+-------------------------------------------------------------------------++-- | Show, additionally removing type name prefix, assuming constructor names are prefixed with type name, possibly with additional underscore (or something like that)+showUnprefixedWithTypeable :: (Show x, Typeable x) => Int -> x -> String+showUnprefixedWithTypeable extralen x = drop prelen $ show x+  where prelen = (length $ show $ typeOf x) + extralen  ------------------------------------------------------------------------- -- Split for qualified name

@@ -1,5 +1,5 @@ Name:				uhc-util-Version:			0.1.5.6+Version:			0.1.6.0 cabal-version:      >= 1.6 License:			BSD3 Copyright:			Utrecht University, Department of Information and Computing Sciences, Software Technology group@@ -43,6 +43,7 @@     UHC.Util.Binary,     UHC.Util.CompileRun,     UHC.Util.CompileRun2,+    UHC.Util.CompileRun3,     UHC.Util.Control.Monad,     UHC.Util.Debug,     UHC.Util.DependencyGraph,@@ -68,4 +69,4 @@   Ghc-Options:		   HS-Source-Dirs:     	src   Build-Tools:		-  Extensions: NoMagicHash, DeriveGeneric+  Extensions: NoMagicHash, DeriveGeneric, DeriveDataTypeable