diff --git a/Control/Cond.hs b/Control/Cond.hs new file mode 100644 --- /dev/null +++ b/Control/Cond.hs @@ -0,0 +1,443 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Control.Cond + ( CondT(..), Cond + + -- * Executing CondT + , runCondT, runCond, applyCondT + + -- * Promotions + , guardM, guard_, guardM_, apply, consider + + -- * Boolean logic + , matches, if_, when_, unless_, or_, and_, not_ + + -- * Basic conditionals + , accept, ignore, norecurse, prune + + -- * Helper functions + , recurse, test + ) + where + +import Control.Applicative +import Control.Arrow ((***), first) +import Control.Monad hiding (mapM_, sequence_) +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Morph +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.Trans +import Control.Monad.Trans.Control +import Control.Monad.Trans.State (StateT(..), withStateT, evalStateT) +import Data.Foldable +import Data.Functor.Identity +import Data.Maybe (isJust) +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Prelude hiding (mapM_, foldr1, sequence_) + +data Recursor a m b = Stop + | Recurse (CondT a m b) + | Continue + deriving Functor + +instance Semigroup (Recursor a m b) where + Stop <> _ = Stop + _ <> Stop = Stop + Recurse n <> _ = Recurse n + _ <> Recurse n = Recurse n + _ <> _ = Continue + +instance Monoid (Recursor a m b) where + mempty = Continue + mappend = (<>) + +instance MFunctor (Recursor a) where + hoist _ Stop = Stop + hoist nat (Recurse n) = Recurse (hoist nat n) + hoist _ Continue = Continue + +type CondR a m b = (Maybe b, Recursor a m b) + +accept' :: Monad m => b -> CondR a m b +accept' x = (Just x, Continue) +{-# INLINE accept' #-} + +recurse' :: Monad m => CondR a m b +recurse' = (Nothing, Continue) +{-# INLINE recurse' #-} + +-- | 'CondT' and its related combinators form a DSL to express whether, given +-- an item of type 'a': that item passes the predicate, and/or if recursion +-- should be performed from that item, should it relate to the branch of a +-- tree. This is used to build predicates that can guide recursive traversals. +-- +-- For example, when recursing files in a directory tree, there are several +-- scenarios that 'CondT' maybe consider: +-- +-- - Whether the entry at a given path is of interest, independent from its +-- type (files or directories) +-- - If the path is a directory, if the directory should be recursed into. +-- +-- Yes or no answers are accepted for either criterion. This means that the +-- answer is "no" to both questions for a given directory, the combinator +-- 'prune' should be used both to ignore the entry itself, and to prevent +-- recursion into its contents. +-- +-- Several different predicate types may be promoted to 'CondT': +-- +-- [@Bool@] Using 'guard' +-- +-- [@m Bool@] Using 'guardM' +-- +-- [@a -> Bool@] Using 'guard_' +-- +-- [@a -> m Bool@] Using 'guardM_' +-- +-- [@a -> m (Maybe b)@] Using 'apply' +-- +-- [@a -> m (Maybe (b, a))@] Using 'consider' +-- +-- Here is a trivial example: +-- +-- @ +-- flip runCondT 42 $ do +-- guard_ even +-- liftIO $ putStrLn "42 must be even to reach here" +-- guard_ odd \<|\> guard_ even +-- guard_ (== 42) +-- @ +-- +-- If 'CondT' is executed using 'runCondT', it returns a @Maybe b@ if the +-- predicate matched. It should usually be run with 'applyCondT', which calls +-- a continuation indicating wether recursion should be performed. +newtype CondT a m b = CondT { getCondT :: StateT a m (CondR a m b) } + deriving Functor + +type Cond a = CondT a Identity + +instance (Monad m, Semigroup b) => Semigroup (CondT a m b) where + (<>) = liftM2 (<>) + {-# INLINE (<>) #-} + +instance (Monad m, Monoid b) => Monoid (CondT a m b) where + mempty = CondT $ return mempty + {-# INLINE mempty #-} + mappend = liftM2 mappend + {-# INLINE mappend #-} + +instance (Monad m, Functor m) => Applicative (CondT a m) where + pure = return + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad m => Monad (CondT a m) where + return = CondT . return . accept' + {-# INLINE return #-} + fail _ = mzero + {-# INLINE fail #-} + CondT m >>= k = CondT $ m >>= \case + (Nothing, Stop) -> return (Nothing, Stop) + (Nothing, Continue) -> return (Nothing, Continue) + (Nothing, Recurse n) -> return (Nothing, Recurse (n >>= k)) + (Just b, Stop) -> fmap (const Stop) `liftM` getCondT (k b) + (Just b, Continue) -> getCondT (k b) + (Just b, Recurse n) -> getCondT (k b) >>= \case + (v, Continue) -> return (v, Recurse (n >>= k)) + x@_ -> return x + {-# INLINEABLE (>>=) #-} + +instance Monad m => MonadReader a (CondT a m) where + ask = CondT $ gets accept' + {-# INLINE ask #-} + local f (CondT m) = CondT $ withStateT f m + {-# INLINE local #-} + reader f = liftM f ask + {-# INLINE reader #-} + +instance Monad m => MonadState a (CondT a m) where + get = CondT $ gets accept' + {-# INLINE get #-} + put s = CondT $ liftM accept' $ put s + {-# INLINE put #-} + state f = CondT $ state (fmap (first accept') f) + {-# INLINE state #-} + +instance (Monad m, Functor m) => Alternative (CondT a m) where + empty = CondT $ return recurse' + {-# INLINE empty #-} + CondT f <|> CondT g = CondT $ do + r <- f + case r of + x@(Just _, _) -> return x + _ -> g + {-# INLINEABLE (<|>) #-} + +instance Monad m => MonadPlus (CondT a m) where + mzero = CondT $ return recurse' + {-# INLINE mzero #-} + mplus (CondT f) (CondT g) = CondT $ do + r <- f + case r of + x@(Just _, _) -> return x + _ -> g + {-# INLINEABLE mplus #-} + +instance MonadThrow m => MonadThrow (CondT a m) where + throwM = CondT . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (CondT a m) where + catch (CondT m) c = CondT $ m `catch` \e -> getCondT (c e) + {-# INLINE catch #-} +#if MIN_VERSION_exceptions(0,6,0) + +instance MonadMask m => MonadMask (CondT a m) where +#endif + mask a = CondT $ mask $ \u -> getCondT (a $ q u) + where q u = CondT . u . getCondT + {-# INLINE mask #-} + uninterruptibleMask a = + CondT $ uninterruptibleMask $ \u -> getCondT (a $ q u) + where q u = CondT . u . getCondT + {-# INLINEABLE uninterruptibleMask #-} + +instance MonadBase b m => MonadBase b (CondT a m) where + liftBase m = CondT $ liftM accept' $ liftBase m + {-# INLINE liftBase #-} + +instance MonadIO m => MonadIO (CondT a m) where + liftIO m = CondT $ liftM accept' $ liftIO m + {-# INLINE liftIO #-} + +instance MonadTrans (CondT a) where + lift m = CondT $ liftM accept' $ lift m + {-# INLINE lift #-} + +#if MIN_VERSION_monad_control(1,0,0) +instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where + type StM (CondT r m) a = StM m (CondR r m a, r) + liftBaseWith f = CondT $ StateT $ \s -> + liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> + f $ \k -> runInBase $ runStateT (getCondT k) s + {-# INLINABLE liftBaseWith #-} + restoreM = CondT . StateT . const . restoreM + {-# INLINE restoreM #-} +#else +instance MonadBaseControl b m => MonadBaseControl b (CondT r m) where + newtype StM (CondT r m) a = + CondTStM { unCondTStM :: StM m (Result r m a, r) } + liftBaseWith f = CondT $ StateT $ \s -> + liftM (\x -> (accept' x, s)) $ liftBaseWith $ \runInBase -> f $ \k -> + liftM CondTStM $ runInBase $ runStateT (getCondT k) s + {-# INLINEABLE liftBaseWith #-} + restoreM = CondT . StateT . const . restoreM . unCondTStM + {-# INLINE restoreM #-} +#endif + +instance MFunctor (CondT a) where + hoist nat (CondT m) = CondT $ hoist nat (fmap (hoist nat) `liftM` m) + {-# INLINE hoist #-} + +runCondT :: Monad m => CondT a m b -> a -> m (Maybe b) +runCondT (CondT f) a = fst `liftM` evalStateT f a +{-# INLINE runCondT #-} + +runCond :: Cond a b -> a -> Maybe b +runCond = (runIdentity .) . runCondT +{-# INLINE runCond #-} + +-- | Case analysis by applying a condition to an input value. +applyCondT :: Monad m + => a -> CondT a m b -> m (Maybe a, Maybe (CondT a m b)) +applyCondT a c@(CondT (StateT s)) = go `liftM` s a + where + go (p, a') = (fmap (const a') *** recursorToMaybe c) p + + recursorToMaybe _ Stop = Nothing + recursorToMaybe p Continue = Just p + recursorToMaybe _ (Recurse n) = Just n + +{-# INLINE applyCondT #-} + +guardM :: MonadPlus m => m Bool -> m () +guardM = (>>= guard) +{-# INLINE guardM #-} + +guard_ :: (MonadPlus m, MonadReader a m) => (a -> Bool) -> m () +guard_ f = ask >>= guard . f +{-# INLINE guard_ #-} + +guardM_ :: (MonadPlus m, MonadReader a m) => (a -> m Bool) -> m () +guardM_ f = ask >>= guardM . f +{-# INLINE guardM_ #-} + +-- | Apply a value-returning predicate. Note that whether or not this return a +-- 'Just' value, recursion will be performed in the entry itself, if +-- applicable. +apply :: (MonadPlus m, MonadReader a m) => (a -> m (Maybe b)) -> m b +apply = asks >=> (>>= maybe mzero return) +{-# INLINE apply #-} + +-- | Consider an element, as 'apply', but returning a mutated form of the +-- element. This can be used to apply optimizations to speed future +-- conditions. +consider :: (MonadPlus m, Functor m, MonadState a m) + => (a -> m (Maybe (b, a))) -> m b +consider = gets >=> (>>= maybe mzero (\(b, a') -> b <$ put a')) +{-# INLINE consider #-} + +accept :: MonadPlus m => m () +accept = return () +{-# INLINE accept #-} + +-- | 'ignore' ignores the current entry, but allows recursion into its +-- descendents. This is the same as 'empty'. +ignore :: MonadPlus m => m b +ignore = mzero +{-# INLINE ignore #-} + +-- | 'norecurse' prevents recursion into the current entry's descendents, but +-- does not ignore the entry itself. +norecurse :: Monad m => CondT a m () +norecurse = CondT $ return (Just (), Stop) +{-# INLINE norecurse #-} + +-- | 'prune' is a synonym for both ignoring an entry and its descendents. It +-- is the same as @ignore >> norecurse@. +prune :: Monad m => CondT a m b +prune = CondT $ return (Nothing, Stop) +{-# INLINE prune #-} + +-- | Return True or False depending on whether the given condition matches or +-- not. This differs from simply stating the condition in that it itself +-- always succeeds. +-- +-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hs")) +-- Just True +-- >>> flip runCond "foo.hs" $ matches (guard =<< asks (== "foo.hi")) +-- Just False +matches :: (Monad m, Functor m) => CondT a m b -> CondT a m Bool +matches = liftM isJust . optional +{-# INLINE matches #-} + +-- | A variant of ifM which branches on whether the condition succeeds or not. +-- Note that @if_ x@ is equivalent to @ifM (matches x)@, and is provided +-- solely for convenience. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ if_ good (return "Success") (return "Failure") +-- Just "Success" +-- >>> flip runCond "foo.hs" $ if_ bad (return "Success") (return "Failure") +-- Just "Failure" +if_ :: Monad m => CondT a m r -> CondT a m b -> CondT a m b -> CondT a m b +if_ c x y = CondT $ do + t <- getCondT c + getCondT $ maybe y (const x) (fst t) +{-# INLINE if_ #-} + +-- | 'when_' is just like 'when', except that it executes the body if the +-- condition passes, rather than based on a Bool value. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ when_ good ignore +-- Nothing +-- >>> flip runCond "foo.hs" $ when_ bad ignore +-- Just () +when_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m () +when_ c x = if_ c x (return ()) +{-# INLINE when_ #-} + +-- | 'when_' is just like 'when', except that it executes the body if the +-- condition fails, rather than based on a Bool value. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ unless_ bad ignore +-- Nothing +-- >>> flip runCond "foo.hs" $ unless_ good ignore +-- Just () +unless_ :: Monad m => CondT a m r -> CondT a m () -> CondT a m () +unless_ c = if_ c (return ()) +{-# INLINE unless_ #-} + +-- | Check whether at least one of the given conditions is true. This is a +-- synonym for 'Data.Foldable.asum'. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ or_ [bad, good] +-- Just () +-- >>> flip runCond "foo.hs" $ or_ [bad] +-- Nothing +or_ :: Monad m => [CondT a m b] -> CondT a m b +or_ = Data.Foldable.msum +{-# INLINE or_ #-} + +-- | Check that all of the given conditions are true. This is a synonym for +-- 'Data.Foldable.sequence_'. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ and_ [bad, good] +-- Nothing +-- >>> flip runCond "foo.hs" $ and_ [good] +-- Just () +and_ :: Monad m => [CondT a m b] -> CondT a m () +and_ = sequence_ +{-# INLINE and_ #-} + +-- | 'not_' inverts the meaning of the given predicate. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> flip runCond "foo.hs" $ not_ bad >> return "Success" +-- Just "Success" +-- >>> flip runCond "foo.hs" $ not_ good >> return "Shouldn't reach here" +-- Nothing +not_ :: Monad m => CondT a m b -> CondT a m () +not_ c = when_ c ignore +{-# INLINE not_ #-} + +-- | 'recurse' changes the recursion predicate for any child elements. For +-- example, the following file-finding predicate looks for all @*.hs@ files, +-- but under any @.git@ directory looks only for a file named @config@: +-- +-- @ +-- if_ (name_ \".git\" \>\> directory) +-- (ignore \>\> recurse (name_ \"config\")) +-- (glob \"*.hs\") +-- @ +-- +-- NOTE: If this code had used @recurse (glob \"*.hs\"))@ instead in the else +-- case, it would have meant that @.git@ is only looked for at the top-level +-- of the search (i.e., the top-most element). +recurse :: Monad m => CondT a m b -> CondT a m b +recurse c = CondT $ fmap (const (Recurse c)) `liftM` getCondT c +{-# INLINE recurse #-} + +-- | A specialized variant of 'runCondT' that simply returns True or False. +-- +-- >>> let good = guard_ (== "foo.hs") :: Cond String () +-- >>> let bad = guard_ (== "foo.hi") :: Cond String () +-- >>> runIdentity $ test "foo.hs" $ not_ bad >> return "Success" +-- True +-- >>> runIdentity $ test "foo.hs" $ not_ good >> return "Shouldn't reach here" +-- False +test :: Monad m => a -> CondT a m b -> m Bool +test = (liftM isJust .) . flip runCondT +{-# INLINE test #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, John Wiegley + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of John Wiegley nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Pipes/Tree.hs b/Pipes/Tree.hs new file mode 100644 --- /dev/null +++ b/Pipes/Tree.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Pipes.Tree where + +import Control.Applicative +import Control.Comonad.Trans.Cofree +import Control.Cond +import Control.Exception +import Control.Monad +import Pipes +import System.Directory +import System.Posix.Files + +-- | A 'TreeT' is a tree of values, where the (possible) branches are +-- 'ListT's. +type TreeT m = CofreeT Maybe (ListT m) + +-- | Turn an old-style generated list into a 'ListT'. +selectEach :: Monad m => m [a] -> ListT m a +selectEach m = Select $ each =<< lift m + +-- | Return all files within a directory tree, hierarchically. +directoryFiles :: MonadIO m => FilePath -> TreeT m FilePath +directoryFiles path = CofreeT $ Select $ do + eres <- liftIO $ try $ getDirectoryContents path + case eres of + Left (_ :: IOException) -> return () + -- liftIO $ putStrLn $ + -- "Error reading directory " ++ path ++ ": " ++ show e + Right entries -> forM_ entries $ \entry -> + unless (entry `elem` [".", ".."]) $ do + let entryPath = path ++ "/" ++ entry + estat <- liftIO $ try $ getFileStatus entryPath + case estat of + Left (_ :: IOException) -> return () + Right stat -> + yield (entryPath :< if isDirectory stat + then Just (directoryFiles entryPath) + else Nothing) + +-- | Descend one level into a 'TreeT', yielding a list of values and their +-- possible associated trees. +descend :: Monad m => TreeT m a -> ListT m (a, Maybe (TreeT m a)) +descend (CofreeT (Select t)) = Select $ for t $ \(a :< mp) -> yield (a, mp) +{-# INLINE descend #-} + +-- | Perform a depth-first traversal of a 'TreeT', yielding a 'ListT' of its +-- contents. Note that breadth-first traversals cannot offer static memory +-- guarantees, so they are not provided by this module. +walk :: Monad m => TreeT m a -> ListT m a +walk (CofreeT (Select t)) = Select $ for t $ \(a :< mp) -> + yield a >> maybe (return ()) (enumerate . walk) mp +{-# INLINEABLE walk #-} + +-- | Given a 'TreeT', produce another 'TreeT' which yields only those elements +-- (and sub-trees) matching the given monadic conditional. This conditional +-- (see 'Control.Cond.CondT') can choose both elements and points of +-- recursion, making it capable of expressing any tree traversal in the form +-- of a predicate DSL. This differs from an expression-based traversal, like +-- XPath or Lens, in that effects in 'm' may be used to guide selection. +-- +-- For example, to print all Haskell files under the current directory: +-- +-- @ +-- let files = winnow (directoryFiles ".") $ do +-- path <- ask +-- liftIO $ putStrLn $ "Considering " ++ path +-- when (path @`elem@` [".@/@.git", ".@/@dist", ".@/@result"]) +-- prune -- ignore these, and don't recurse into them +-- guard_ (".hs" @`isInfixOf@`) -- implicitly references 'path' +-- runEffect $ for (enumerate (walk files)) $ liftIO . print +-- @ +winnow :: Monad m => TreeT m a -> CondT a m () -> TreeT m a +winnow (CofreeT (Select t)) p = CofreeT $ Select $ for t $ \(a :< mst) -> do + (mval, mnext) <- lift $ applyCondT a p + let mnext' = winnow <$> mst <*> mnext + case mval of + Nothing -> maybe (return ()) (enumerate . runCofreeT) mnext' + Just a' -> yield (a' :< mnext') diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hierarchy.cabal b/hierarchy.cabal new file mode 100644 --- /dev/null +++ b/hierarchy.cabal @@ -0,0 +1,63 @@ +name: hierarchy +version: 0.1.0 +synopsis: Pipes-based library for predicated traversal of generated trees +description: Pipes-based library for predicated traversal of generated trees +homepage: https://github.com/jwiegley/hierarchy +license: BSD3 +license-file: LICENSE +author: John Wiegley +maintainer: johnw@newartisans.com +copyright: Copyright 2015 (c) John Wiegley. All Rights Reserved. +category: Data +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Control.Cond + , Pipes.Tree + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , transformers >=0.3 && <0.5 + , transformers-base >=0.3 && <0.5 + , exceptions >=0.8 && <0.9 + , mmorph >=1.0 && <1.1 + , mtl >=2.1 && <2.3 + , monad-control >=1.0 && <1.1 + , semigroups >=0.16 && <0.17 + , free >=4.12 && <4.13 + , pipes >=4.1 && <4.2 + , directory >=1.2 && <1.3 + , unix >=2.7 && <2.8 + -- hs-source-dirs: + default-language: Haskell2010 + +Test-suite doctests + default-language: Haskell98 + type: exitcode-stdio-1.0 + main-is: doctest.hs + hs-source-dirs: test + build-depends: + base + , directory >=1.0 + , doctest >=0.8 + , filepath >=1.3 + , semigroups >=0.4 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + ghc-options: -Wall -fno-warn-deprecated-flags -threaded + hs-source-dirs: test + main-is: Main.hs + build-depends: + base >=3 + , hierarchy + , pipes >=4.1 && <4.2 + , directory >=1.2 && <1.3 + , unix >=2.7 && <2.8 + , transformers >=0.3 && <0.5 + , mtl >=2.1 && <2.3 + , hspec >=1.4.4 + , hspec-expectations >=0.3 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,44 @@ +module Main where + +import Control.Cond +import Control.Monad +import Control.Monad.Reader.Class +import Data.List +import Pipes +import Pipes.Prelude (toListM) +import Pipes.Tree +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "Sanity tests" $ do + it "Finds expected files in project" findsExpected + +findsExpected :: Expectation +findsExpected = do + let ignored = ["./.git", "./dist", "./result"] + + let files = winnow (directoryFiles ".") $ do + path <- ask + liftIO $ putStrLn $ "Considering " ++ path + when_ (guard_ (`elem` ignored)) $ do + liftIO $ putStrLn $ "Pruning " ++ path + prune + -- equivalently we can say (but won't reach here now)... + when (path `elem` ignored) $ do + liftIO $ putStrLn $ "Pruning " ++ path + prune + + guard_ (".hs" `isInfixOf`) + + -- We only reach the end if we have a file of interest, + -- however any directories we didn't prune will still be + -- descended into + liftIO $ putStrLn "We found a Haskell file!" + + found <- toListM $ enumerate (walk files) + found `shouldBe` [ "./Control/Cond.hs" + , "./Pipes/Tree.hs" + , "./Setup.hs" + , "./test/doctest.hs" + , "./test/Main.hs" ] diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,30 @@ +module Main where + +import Test.DocTest +import System.Directory +import System.FilePath +import Control.Applicative +import Control.Monad +import Data.List + +main :: IO () +main = getSources >>= \sources -> doctest $ + "-iControl" + : "-idist/build/autogen" + : "-optP-include" + : "-optPdist/build/autogen/cabal_macros.h" + : sources + +getSources :: IO [FilePath] +getSources = + filter (\n -> ".hs" `isSuffixOf` n) <$> go "./Control" + where + go dir = do + (dirs, files) <- getFilesAndDirectories dir + (files ++) . concat <$> mapM go dirs + +getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +getFilesAndDirectories dir = do + c <- map (dir ) . filter (`notElem` ["..", "."]) + <$> getDirectoryContents dir + (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c