Add allM and anyM functions.

[matthijs/master-project/cλash.git] / cλash / CLasH / Utils.hs

diff --git a/cλash/CLasH/Utils.hs b/cλash/CLasH/Utils.hs
index 3ce4b9ef37c3c6e8dd8d0661fe8f78c8095cc277..2966757a038b1d2fefd6a9db51547a0bcf8d0bff 100644 (file)
--- a/cλash/CLasH/Utils.hs
+++ b/cλash/CLasH/Utils.hs
@@ -3,52 +3,11 @@ module CLasH.Utils where
 -- Standard Imports
 import qualified Maybe
 import Data.Accessor
 -- Standard Imports
 import qualified Maybe
 import Data.Accessor

+import qualified Data.Accessor.Monad.Trans.State as MonadState

 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State
 import qualified Data.Map as Map
 import qualified Control.Monad as Monad
 import qualified Control.Monad.Trans.State as State

-
--- GHC API
-import qualified CoreSyn
-import qualified CoreUtils
-import qualified HscTypes
-import qualified Outputable
-import qualified Var
-
--- Local Imports
-import CLasH.Utils.GhcTools
-import CLasH.Utils.Pretty
-  
-listBindings :: FilePath -> [FilePath] -> IO [()]
-listBindings libdir filenames = do
-  (cores,_,_,_,_) <- loadModules libdir filenames bogusFinder bogusFinder bogusFinder
-  let binds = concat $ map (CoreSyn.flattenBinds . HscTypes.cm_binds) cores
-  mapM (listBinding) binds
-    where
-      bogusFinder = (\x -> return $ Nothing)
-
-listBinding :: (CoreSyn.CoreBndr, CoreSyn.CoreExpr) -> IO ()
-listBinding (b, e) = do
-  putStr "\nBinder: "
-  putStr $ show b
-  putStr "\nType of Binder: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ Var.varType b
-  putStr "\n\nExpression: \n"
-  putStr $ prettyShow e
-  putStr "\n\n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr e
-  putStr "\n\nType of Expression: \n"
-  putStr $ Outputable.showSDoc $ Outputable.ppr $ CoreUtils.exprType e
-  putStr "\n\n"

   
   

--- | Show the core structure of the given binds in the given file.
-listBind :: FilePath -> [FilePath] -> String -> IO ()
-listBind libdir filenames name = do
-  (_,corebind,_,coreexpr,_) <- loadModules libdir filenames bindFinder bindFinder exprFinder
-  listBinding (Maybe.fromJust $ head corebind, Maybe.fromJust $ head coreexpr)
-    where
-      bindFinder  = findBind (hasVarName name)
-      exprFinder  = findExpr (hasVarName name)
-

 -- Make a caching version of a stateful computatation.
 makeCached :: (Monad m, Ord k) =>
   k -- ^ The key to use for the cache
 -- Make a caching version of a stateful computatation.
 makeCached :: (Monad m, Ord k) =>
   k -- ^ The key to use for the cache


@@ -57,17 +16,47 @@ makeCached :: (Monad m, Ord k) =>
   -> State.StateT s m v -- ^ The resulting value, from the cache or freshly
                         --   computed.
 makeCached key accessor create = do
   -> State.StateT s m v -- ^ The resulting value, from the cache or freshly
                         --   computed.
 makeCached key accessor create = do

-  cache <- getA accessor
+  cache <- MonadState.get accessor

   case Map.lookup key cache of
     -- Found in cache, just return
     Just value -> return value
     -- Not found, compute it and put it in the cache
     Nothing -> do
       value <- create
   case Map.lookup key cache of
     -- Found in cache, just return
     Just value -> return value
     -- Not found, compute it and put it in the cache
     Nothing -> do
       value <- create

-      modA accessor (Map.insert key value)
+      MonadState.modify accessor (Map.insert key value)

       return value
 
 unzipM :: (Monad m) =>
   m [(a, b)]
   -> m ([a], [b])
 unzipM = Monad.liftM unzip
       return value
 
 unzipM :: (Monad m) =>
   m [(a, b)]
   -> m ([a], [b])
 unzipM = Monad.liftM unzip

+
+catMaybesM :: (Monad m) =>
+  m [Maybe a]
+  -> m [a]
+catMaybesM = Monad.liftM Maybe.catMaybes
+
+concatM :: (Monad m) =>
+  m [[a]]
+  -> m [a]
+concatM = Monad.liftM concat
+
+isJustM :: (Monad m) => m (Maybe a) -> m Bool
+isJustM = Monad.liftM Maybe.isJust
+
+andM, orM :: (Monad m) => m [Bool] -> m Bool
+andM = Monad.liftM and
+orM = Monad.liftM or
+
+-- | Monadic versions of any and all. We reimplement them, since there
+-- is no ready-made lifting function for them.
+allM, anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
+allM f = andM . (mapM f)
+anyM f = orM . (mapM f)
+
+mapAccumLM :: (Monad m) => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
+mapAccumLM _ s []        =  return (s, [])
+mapAccumLM f s (x:xs)    =  do
+  (s',  y ) <- f s x
+  (s'', ys) <- mapAccumLM f s' xs
+  return (s'', y:ys)