directory-layout 0.2.0.0 → 0.3.0.0

raw patch · 11 files changed

+615/−418 lines, 11 filesdep +HUnitdep +data-defaultdep +directory-layoutdep −parsecdep −transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, data-default, directory-layout, doctest, lens, mtl, process, semigroupoids, semigroups, wordexp

Dependencies removed: parsec, transformers

API changes (from Hackage documentation)

Files

• directory-layout.cabal +35/−8
• src/System/Directory/Layout.hs +20/−18
• src/System/Directory/Layout/Check.hs +0/−126
• src/System/Directory/Layout/Errored.hs +112/−0
• src/System/Directory/Layout/Internal.hs +85/−35
• src/System/Directory/Layout/Lens.hs +76/−0
• src/System/Directory/Layout/Make.hs +0/−127
• src/System/Directory/Layout/Parser.hs +0/−104
• src/System/Directory/Layout/Traverse.hs +131/−0
• tests/Main.hs +144/−0
• tests/doctests.hs +12/−0

@@ -1,5 +1,5 @@ name:          directory-layout-version:       0.2.0.0+version:       0.3.0.0 synopsis:      Declare, construct and verify directory layout description:   Language to express directory layouts category:      System@@ -8,22 +8,49 @@ author:        Matvey Aksenov maintainer:    matvey.aksenov@gmail.com build-type:    Simple-cabal-version: >= 1.8+cabal-version: >= 1.10  library+  default-language: Haskell2010   exposed-modules: System.Directory.Layout-                   System.Directory.Layout.Check-                   System.Directory.Layout.Make-                   System.Directory.Layout.Parser                    System.Directory.Layout.Internal+                   System.Directory.Layout.Errored+                   System.Directory.Layout.Traverse+                   System.Directory.Layout.Lens   hs-source-dirs: src   build-depends: base >= 3 && < 5,                  directory,                  filepath,-                 transformers,-                 parsec,-                 text,+                 mtl,+                 data-default,+                 semigroups,+                 semigroupoids,+                 lens,+                 text+  ghc-options: -Wall+               -fno-warn-unused-do-bind++test-suite basics-suite+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  build-depends: base >= 3 && < 5,+                 directory-layout,+                 HUnit,+                 process,                  QuickCheck+  main-is: tests/Main.hs+  ghc-options: -Wall+               -fno-warn-unused-do-bind++test-suite doctests+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  build-depends: base >= 3 && < 5,+                 directory-layout,+                 doctest,+                 wordexp,+                 lens+  main-is: tests/doctests.hs   ghc-options: -Wall                -fno-warn-unused-do-bind 

@@ -1,38 +1,40 @@-{-# LANGUAGE UnicodeSyntax #-}+-- | Language to express directory layouts module System.Directory.Layout   ( -- * Layout declaration     DL, Layout, file, file_, directory, directory_-    -- * Layout construction-  , DLMakeWarning(..), make-    -- * Layout verification-  , DLCheckFailure(..), check-    -- * Layout parsers-  , layout, layout'+    -- * Layout traverses+  , make, check+    -- * Errors+  , LayoutException(..)   ) where +import Data.Default (def) import Data.Text (Text)  import System.Directory.Layout.Internal (DL(..), Layout)-import System.Directory.Layout.Check (DLCheckFailure(..), check)-import System.Directory.Layout.Make (DLMakeWarning(..), make)-import System.Directory.Layout.Parser (layout, layout')+import System.Directory.Layout.Traverse (make, check)+import System.Directory.Layout.Errored (LayoutException(..))   -- | Declare file with specified contents-file ∷ FilePath → Text → Layout-file x c = F x (Just c) (return ())+file :: FilePath -> Text -> Layout+file x t = F x (T t ()) def+{-# INLINE file #-}   -- | Declare empty file-file_ ∷ FilePath → Layout-file_ x = F x Nothing (return ())+file_ :: FilePath -> Layout+file_ x = F x def def+{-# INLINE file_ #-}   -- | Declare directory with specified listing-directory ∷ FilePath → Layout → Layout-directory x d = D x d (return ())+directory :: FilePath -> Layout -> Layout+directory x d = D x d def+{-# INLINE directory #-}   -- | Declare empty directory-directory_ ∷ FilePath → Layout-directory_ x = D x (return ()) (return ())+directory_ :: FilePath -> Layout+directory_ x = D x def def+{-# INLINE directory_ #-}

@@ -1,126 +0,0 @@-{-# LANGUAGE UnicodeSyntax #-}--- | Check if current directory layout agrees with specified one------ For example, suppose there is a tree:------ @--- % tree--- .--- ├── baz--- │   └── twey--- └── foo---     ├── bar---     │   ├── quuz---     │   └── tatata---     └── quux--- @------ then you can write:------ @--- layout = do---   directory \"baz\" $---     file_ \"twey\"---   directory \"foo\" $ do---     directory \"bar\" $ do---       file_ \"quuz\"---       file_ \"tatata\"---     file_ \"quux\"--- @------ and running @check layout \".\"@ should result in @[]@-module System.Directory.Layout.Check-  ( DLCheckFailure(..), check-  ) where--import Control.Arrow (second)-import Control.Monad (unless, when)--import           Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local)-import           Control.Monad.Trans.Writer (WriterT, execWriterT, tell)-import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.Trans.Class (lift)-import           Data.Text (Text)-import qualified Data.Text.IO as T-import           System.FilePath ((</>), makeRelative)-import           System.Directory--import System.Directory.Layout.Internal----- | Check directory layout corresponds to specified one-check ∷ Layout-      → FilePath            -- ^ Root directory-      → IO [DLCheckFailure] -- ^ List of failures-check z fp = do-  d ← getCurrentDirectory-  fp' ← canonicalizePath fp-  setCurrentDirectory fp'-  xs ← runCheckT (fp', fp') (f z)-  setCurrentDirectory d-  return xs- where-  f (E _) = return ()-  f (F p Nothing x) = fileExists p >> f x-  f (F p (Just c) x) = fileExists p >>= \t → when t (fileContains p c) >> f x-  f (D p x y) = dirExists p >>= \t → when t (changeDir p (f x)) >> f y----- | Data type representing various failures--- that may occur while checking directory layout-data DLCheckFailure =-    FileDoesNotExist FilePath-  | FileWrongContents FilePath Text-  | DirectoryDoesNotExist FilePath-    deriving (Show, Read, Eq, Ord)---type CheckT = ReaderT (FilePath, FilePath) (WriterT [DLCheckFailure] IO)---runCheckT ∷ (FilePath, FilePath) → CheckT a → IO [DLCheckFailure]-runCheckT e = execWriterT . flip runReaderT e----- | File existence check--- emits 'FileDoesNotExist' on failure-fileExists ∷ FilePath → CheckT Bool-fileExists p = do-  (r, d) ← ask-  z ← io $ doesFileExist (d </> p)-  unless z $-    tell' [FileDoesNotExist (makeRelative r d </> p)]-  return z----- | Directory existence check--- emits 'DirectoryDoesNotExist' on failure-dirExists ∷ FilePath → CheckT Bool-dirExists p = do-  (r, d) ← ask-  z ← io $ doesDirectoryExist (d </> p)-  unless z $-    tell' [DirectoryDoesNotExist (makeRelative r d </> p)]-  return z----- | File contents check--- emits 'FileDoesNotExist' on failure-fileContains ∷ FilePath → Text → CheckT ()-fileContains p c = do-  (r, d) ← ask-  z ← io $ T.readFile (d </> p)-  unless (z == c) $-    tell' [FileWrongContents (makeRelative r d </> p) z]---changeDir ∷ FilePath → CheckT () → CheckT ()-changeDir fp = local (second (</> fp))---io ∷ IO a → CheckT a-io = liftIO---tell' ∷ [DLCheckFailure] → CheckT ()-tell' = lift . tell

@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Wrappers around exception throwing functions and related routines+module System.Directory.Layout.Errored+  ( LayoutException(..)+  , createDirectory, createFile+  , fileExists, directoryExists, readFile+  , anyfail+  , relative+  ) where++import           Control.Exception hiding (try)+import qualified Control.Exception as E+import           Prelude hiding (readFile)+import           System.IO.Error++import           Control.Lens+import           Control.Monad.Trans (MonadIO, liftIO)+import           Control.Monad.Writer.Class (MonadWriter, tell)+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified System.Directory as D+import           System.FilePath (makeRelative)+++try :: IO a -> IO (Either IOException a)+try = E.try++io :: MonadIO m => IO a -> m a+io = liftIO+++-- | Log failures+anyfail :: MonadWriter [w] m => m (Either w a) -> m ()+anyfail mewa = do+  ewa <- mewa+  case ewa of+    Left e -> tell [e]+    _      -> return ()+++-- | Information about cought exceptions in various routines+data LayoutException =+    CD IOErrorType FilePath      -- ^ 'createDirectory' exceptions+  | CF IOErrorType FilePath      -- ^ 'createFile' eceptions+  | FE IOErrorType FilePath      -- ^ 'fileExists' eceptions+  | DE IOErrorType FilePath      -- ^ 'directoryExists' eceptions+  | RF IOErrorType FilePath Text -- ^ 'readFile' eceptions+    deriving (Show, Eq)+++-- | IO-exceptions-free 'System.Directory.createDirectory'+createDirectory :: MonadIO m => FilePath -> m (Either LayoutException ())+createDirectory fp = io $ try (D.createDirectory fp) <&> \x -> case x of+  Right () -> Right ()+  Left  e  -> Left (CD (ioeGetErrorType e) fp)++-- | IO-exceptions-free 'Data.Text.writeFile'+createFile :: MonadIO m => FilePath -> Maybe Text -> m (Either LayoutException ())+createFile fp text = io $ try (createFileX fp text) <&> \x -> case x of+  Right () -> Right ()+  Left  e  -> Left (CF (ioeGetErrorType e) fp)++createFileX :: FilePath -> Maybe Text -> IO ()+createFileX fp text = do+  x <- D.doesFileExist fp+  if x then+    ioError (mkIOError alreadyExistsErrorType "?" Nothing (Just fp))+  else+    T.writeFile fp (maybe T.empty id text)+++-- | 'System.Directory.doesFileExists' that returns 'Either' instead of 'Bool'+fileExists :: MonadIO m => FilePath -> m (Either LayoutException ())+fileExists fp = io $ do+  p <- D.doesFileExist fp+  if p then+    return (Right ())+  else+    return (Left (FE doesNotExistErrorType fp))++-- | 'System.Directory.doesDirectoryExists' that returns 'Either' instead of 'Bool'+directoryExists :: MonadIO m => FilePath -> m (Either LayoutException ())+directoryExists fp = io $ do+  p <- D.doesDirectoryExist fp+  if p then+    return (Right ())+  else+    return (Left (DE doesNotExistErrorType fp))++-- | IO-exceptions-free 'Data.Text.readFile'+readFile :: MonadIO m => FilePath -> Text -> m (Either LayoutException ())+readFile fp text = io $ try (readFileX fp text) <&> \x -> case x of+  Right () -> Right ()+  Left  e  -> Left (RF (ioeGetErrorType e) fp text)++readFileX :: FilePath -> Text -> IO ()+readFileX fp text = do+  text' <- T.readFile fp+  if text /= text' then+    ioError (mkIOError userErrorType "?" Nothing (Just fp))+  else+    return ()+++-- | Make paths in 'LayoutException' relative to given 'FilePath'+relative :: FilePath -> LayoutException -> LayoutException+relative r (CD t fp)   = CD t (makeRelative r fp)+relative r (CF t fp)   = CF t (makeRelative r fp)+relative r (FE t fp)   = FE t (makeRelative r fp)+relative r (DE t fp)   = DE t (makeRelative r fp)+relative r (RF t fp c) = RF t (makeRelative r fp) c

@@ -1,53 +1,103 @@-{-# LANGUAGE UnicodeSyntax #-}-{-# OPTIONS_HADDOCK hide #-}+-- | Free monad based directory layouts module System.Directory.Layout.Internal   ( DL(..), Layout   ) where -import Control.Applicative-import Control.Arrow+import Control.Applicative (Applicative(..), (<$>))+import Data.Foldable (Foldable(..))+import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault)+import Data.Monoid (Monoid(..)) +import Data.Default (Default(..))+import Data.Functor.Apply (Apply(..))+import Data.Functor.Bind (Bind(..))+import Data.Semigroup (Semigroup(..)) import Data.Text (Text)-import Test.QuickCheck  --- | Abstract data type representing directory tree is nice-data DL f-  = E f-  | F FilePath (Maybe Text) (DL f)-  | D FilePath (DL ()) (DL f)-    deriving (Show, Read)+-- | Type synonym to save some acrobatics+type Layout = DL ()  --- | But type synonym is nicer-type Layout = DL ()+-- | Representation of directory layouts+--+-- Invariants:+--+--  * 'F' second argument is never @D _ _ _@ or @F _ _ _@ itself+--+--  * 'F' third argument is never @T _ _@+--+--  * 'D' second argument is never @T _ _@+--+--  * 'D' third argument is never @T _ _@+data DL a+  = E !a                        -- ^ Emptyness, nothing found here+  | T !Text !a                  -- ^ File contents+  | F !FilePath !Layout !(DL a) -- ^ File node+  | D !FilePath !Layout !(DL a) -- ^ Directory node+    deriving (Show, Read, Eq, Ord) +instance Default a => Default (DL a) where+  def = E def+  {-# INLINE def #-} +instance Semigroup (DL a) where+  E _      <> b   = b+  T _ _    <> b   = b+  F f t l  <> b   = F f t (l  <> b)+  D f l l' <> b   = D f l (l' <> b)+  {-# INLINE (<>) #-}++instance Default a => Monoid (DL a) where+  mempty = def+  {-# INLINE mempty #-}++  mappend = (<>)+  {-# INLINE mappend #-}+ instance Functor DL where-  fmap f (E x) = E (f x)-  fmap f (F fp c x) = F fp c (fmap f x)-  fmap f (D fp x y) = D fp x (fmap f y)+  fmap = fmapDefault+  {-# INLINE fmap #-} +instance Apply DL where+  E f      <.> E x      = E (f x)+  E f      <.> T t x    = T t (f x)+  T t f    <.> E x      = T t (f x)+  T t f    <.> T _ x    = T t (f x)+  f        <.> F fp c x = F fp c (f <.> x)+  f        <.> D fp l x = D fp l (f <.> x)+  F fp c f <.> x        = F fp c (f <.> x)+  D fp l f <.> x        = D fp l (f <.> x)+  {-# INLINE (<.>) #-} +instance Applicative DL where+  pure = E+  {-# INLINE pure #-}++  (<*>) = (<.>)+  {-# INLINE (<*>) #-}++instance Bind DL where+  E x      >>- f = f x+  T _ x    >>- f = f x+  F fp c x >>- f = F fp c (x >>- f)+  D fp x y >>- f = D fp x (y >>- f)+  {-# INLINE (>>-) #-}+ instance Monad DL where-  return = E-  E x >>= f = f x-  F fp c x >>= f = F fp c (x >>= f)-  D fp x y >>= f = D fp x (y >>= f)+  return = pure+  {-# INLINE return #-} +  (>>=) = (>>-)+  {-# INLINE (>>=) #-} --- Make arbitrary layout of reasonable size--- Frequencies are pretty /arbitrary/ chosen with layout construction termination in mind-instance Arbitrary a ⇒ Arbitrary (DL a) where-  arbitrary = snd <$> generator 0-   where-    generator ∷ Arbitrary a ⇒ Int → Gen (Int, DL a)-    generator n = frequency-      [ (8, do-          (n', g') ← generator (succ n)-          generator n' <&> second (D (show n) g'))-      , (20, generator (succ n) <&> second (F (show n) Nothing))-      , (10, arbitrary <&> \r → (n, E r))-      ]-     where-      (<&>) = flip fmap+instance Foldable DL where+  foldMap = foldMapDefault+  {-# INLINE foldMap #-}++instance Traversable DL where+  traverse f (E x)      = E      <$> f x+  traverse f (T t x)    = T t    <$> f x+  traverse f (F fp t x) = F fp t <$> traverse f x+  traverse f (D fp x y) = D fp x <$> traverse f y+  {-# INLINE traverse #-}

@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+-- | "Control.Lens" based extractors for 'DL'+module System.Directory.Layout.Lens+  ( -- $setup+    text, file, directory+  ) where++import Control.Applicative (pure)++import Control.Lens+import Data.Text (Text)++import System.Directory.Layout.Internal (DL(..), Layout)+++-- $setup+--+-- >>> :set -XOverloadedStrings+-- >>> import           Control.Lens+-- >>> let layout = F "foo" (T "not empty" ()) (D "bar" (F "baz" (E ()) (F "quux" (T "something" ()) (E ()))) (F "swaks" (E ()) (E ())))+++-- | Get 'Text' out of the current 'Layout' (if possible)+--+-- >>> layout ^? text+-- Nothing+-- >>> layout ^? file "foo" . text+-- Just "not empty"+-- >>> layout ^? directory "bar" . file "quux" . text+-- Just "something"+text :: Prism Layout Layout Text Text+text = prism' (\t -> T t ()) $ \s -> case s of+  T t _ -> Just t+  _     -> Nothing+{-# INLINE text #-}+++-- | Look into the file in the current 'Layout' (if possible)+--+-- >>> layout ^? file "biz"+-- Nothing+-- >>> layout ^? file "swaks"+-- Just (E ())+-- >>> layout ^? directory "bar" . file "baz"+-- Just (E ())+file :: FilePath -> IndexedTraversal' FilePath Layout Layout+file k f = go+ where+  go (E x)      = pure (E x)+  go (T t x)    = pure (T t x)+  go (F k' l x)+    | k == k'   = indexed f k l <&> \l' -> F k' l' x+    | otherwise = go x+  go (D _ _ x)  = go x+  {-# INLINE go #-}+{-# INLINE file #-}+++-- | Go into the directory in the current 'Layout' (if possible)+--+-- >>> layout ^? directory "foo"+-- Nothing+-- >>> layout ^? directory "bar"+-- Just (F "baz" (E ()) (F "quux" (T "something" ()) (E ())))+directory :: FilePath -> IndexedTraversal' FilePath Layout Layout+directory k f = go+ where+  go (E x)      = pure (E x)+  go (T t x)    = pure (T t x)+  go (F _ _ x)  = go x+  go (D k' l x)+    | k == k'   = indexed f k l <&> \l' -> D k' l' x+    | otherwise = go x+  {-# INLINE go #-}+{-# INLINE directory #-}

@@ -1,127 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UnicodeSyntax #-}--- | Make layout as specified------ For example, suppose you are in an empty directory------ @--- % tree--- .--- @------ and you've written simple layout:------ @--- layout = do---   directory \"baz\" $---     file_ \"twey\"---   directory \"foo\" $ do---     directory \"bar\" $ do---       file_ \"quuz\"---       file_ \"tatata\"---     file_ \"quux\"--- @------ then running it should result in this directory tree:------ @--- % tree--- .--- ├── baz--- │   └── twey--- └── foo---     ├── bar---     │   ├── quuz---     │   └── tatata---     └── quux--- @----module System.Directory.Layout.Make-  ( DLMakeWarning(..), make-  ) where--import Control.Arrow (second)--import           Control.Monad.Trans.Reader (ReaderT, runReaderT, ask, local)-import           Control.Monad.Trans.Writer (WriterT, execWriterT, tell)-import           Control.Monad.IO.Class (liftIO)-import           Control.Monad.Trans.Class (lift)-import           Data.Text (Text)-import qualified Data.Text.IO as T-import           System.FilePath ((</>), makeRelative)-import           System.Directory--import System.Directory.Layout.Internal----- | Infect file layout with stuff from script-make ∷ Layout-     → FilePath          -- ^ Root directory-     → IO [DLMakeWarning] -- ^ List of warnings-make z fp = do-  d ← getCurrentDirectory-  fp' ← canonicalizePath fp-  setCurrentDirectory fp'-  xs ← runRunT (fp', fp') (f z)-  setCurrentDirectory d-  return xs- where-  f (E _) = return ()-  f (F p Nothing x) = touchFile p >> f x-  f (F p (Just c) x) = touchFile p >> infectFile p c >> f x-  f (D p x y) = createDir p >> changeDir p (f x) >> f y----- | Data type representing various warnings--- that may occur while infecting directory layout-data DLMakeWarning =-    FileDoesExist FilePath-  | DirectoryDoesExist FilePath-    deriving (Show, Read, Eq, Ord)---type RunT = ReaderT (FilePath, FilePath) (WriterT [DLMakeWarning] IO)---runRunT ∷ (FilePath, FilePath) → RunT a → IO [DLMakeWarning]-runRunT e = execWriterT . flip runReaderT e----- | File creation--- emits 'FileDoesExist' if file exists already-touchFile ∷ FilePath → RunT ()-touchFile p = do-  (r, d) ← ask-  z ← io $ doesFileExist (d </> p)-  if z-    then tell' [FileDoesExist (makeRelative r d </> p)]-    else io $ T.writeFile (d </> p) ""---infectFile ∷ FilePath → Text → RunT ()-infectFile p c = do-  (_, d) ← ask-  io $ T.writeFile (d </> p) c----- | Directory creation--- emits 'DirectoryDoesExist' if directory exists already-createDir ∷ FilePath → RunT ()-createDir p = do-  (r, d) ← ask-  z ← io $ doesDirectoryExist (d </> p)-  if z-    then tell' [DirectoryDoesExist (makeRelative r d </> p)]-    else io $ createDirectory (d </> p)---changeDir ∷ FilePath → RunT () → RunT ()-changeDir fp = local (second (</> fp))---io ∷ IO a → RunT a-io = liftIO---tell' ∷ [DLMakeWarning] → RunT ()-tell' = lift . tell

@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UnicodeSyntax #-}--- | Parser for text format for DL data structure, for example------ @--- c/--- ..x--- ..y--- ....n--- ....n--- ....--- ..z--- ....t--- ....t--- ....--- d/--- @------ where '.' stands for space is equivalent of------ @--- do directory \"c\" $ do---      file_ \"x\"---      file \"y\" \"n\nn\n\"---      file \"z\" \"t\nt\n\"---    directory_ \"d\"--- @----module System.Directory.Layout.Parser-  ( layout, layout'-  ) where--import Control.Applicative-import Control.Arrow (left)-import Control.Monad (guard)-import Data.Functor.Identity (Identity)-import Data.List (intercalate)--import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import           Text.Parsec hiding ((<|>), many)-import           Text.Parsec.Text ()-import           Text.Parsec.Text.Lazy ()--import System.Directory.Layout.Internal----- | lazy 'Text' parser-layout ∷ LT.Text → Either String Layout-layout = glayout----- | strict 'Text' parser-layout' ∷ T.Text → Either String Layout-layout' = glayout---glayout ∷ Stream s Identity Char ⇒ s → Either String Layout-glayout = left show . parse (sequence_ <$> many (p_any 0)) "(layout parser)"---p_any ∷ Stream s Identity Char ⇒ Int → Parsec s u Layout-p_any n = try (p_directory n) <|> p_file n---p_directory ∷ Stream s Identity Char ⇒ Int → Parsec s u Layout-p_directory n = do-  name ← p_directory_name-  inner ← sequence_ <$> try (inners p_any n) <|> return (E ())-  return $ D name inner (E ())---p_file ∷ Stream s Identity Char ⇒ Int → Parsec s u Layout-p_file n = do-  name ← p_file_name-  inner ← Just . T.intercalate "\n" <$> try (inners (const p_text) n) <|> return Nothing-  return $ F name inner (E ())---inners ∷ Stream s Identity Char ⇒ (Int → Parsec s u a) → Int → Parsec s u [a]-inners p n = do-  indent ← length <$> many (char ' ')-  guard (indent > n)-  (:) <$> p indent <*> generous_many (string (replicate indent ' ') *> p indent)---generous_many ∷ Parsec s u a → Parsec s u [a]-generous_many p = f- where-  f = try ((:) <$> p <*> f) <|> return []-{-# INLINE generous_many #-}---p_directory_name ∷ Stream s Identity Char ⇒ Parsec s u String-p_directory_name = some (noneOf "/\n") <* char '/' <* char '\n'---p_file_name ∷ Stream s Identity Char ⇒ Parsec s u String-p_file_name = intercalate "." <$> ((some (noneOf "/.\n") `sepBy` char '.') <* char '\n')---p_text ∷ Stream s Identity Char ⇒ Parsec s u T.Text-p_text = T.pack <$> many (noneOf "\n") <* char '\n'

@@ -0,0 +1,131 @@+-- | 'Layout' traverses+module System.Directory.Layout.Traverse+  ( make, check+  ) where++import Prelude hiding (readFile)++import Control.Monad.Reader (ReaderT, runReaderT, ask, local)+import Control.Monad.Writer (WriterT, execWriterT)+import Data.Text (Text)+import System.FilePath ((</>))++import System.Directory.Layout.Internal+import System.Directory.Layout.Errored+++type RunT = ReaderT FilePath (WriterT [LayoutException] IO)++runRunT :: FilePath -> RunT a -> IO [LayoutException]+runRunT e = execWriterT . flip runReaderT e++applyTraverse :: (Layout -> RunT ()) -> Layout -> FilePath -> IO [LayoutException]+applyTraverse f z fp = map (relative fp) `fmap` runRunT fp (f z)++changeDir :: FilePath -> RunT () -> RunT ()+changeDir fp = local (</> fp)+++-- | Make layout as specified+--+-- For example, suppose you are in an empty directory+--+-- @+-- % tree+-- .+-- @+--+-- and you've written simple layout:+--+-- @+-- layout = do+--   directory \"baz\" $+--     file_ \"twey\"+--   directory \"foo\" $ do+--     directory \"bar\" $ do+--       file_ \"quuz\"+--       file_ \"tatata\"+--     file_ \"quux\"+-- @+--+-- then running it should result in this directory tree:+--+-- @+-- % tree+-- .+-- ├── baz+-- │   └── twey+-- └── foo+--     ├── bar+--     │   ├── quuz+--     │   └── tatata+--     └── quux+-- @+--+make :: Layout+     -> FilePath             -- ^ Root directory+     -> IO [LayoutException] -- ^ List of warnings+make = applyTraverse go+ where+  go (E _)           = return ()+  go (F p (E _) x)   = makeFile p Nothing >> go x+  go (F p (T t _) x) = makeFile p (Just t) >> go x+  go (D p x y)       = makeDirectory p >> changeDir p (go x) >> go y+  go _               = error "Broken DL () invariant"++makeFile :: FilePath -> Maybe Text -> RunT ()+makeFile p t = ask >>= \d -> anyfail $ createFile (d </> p) t++makeDirectory :: FilePath -> RunT ()+makeDirectory p = ask >>= \d -> anyfail $ createDirectory (d </> p)+++-- | Check directory layout agrees with specified one+--+-- For example, suppose there is a tree:+--+-- @+-- % tree+-- .+-- ├── baz+-- │   └── twey+-- └── foo+--     ├── bar+--     │   ├── quuz+--     │   └── tatata+--     └── quux+-- @+--+-- then you can write:+--+-- @+-- layout = do+--   directory \"baz\" $+--     file_ \"twey\"+--   directory \"foo\" $ do+--     directory \"bar\" $ do+--       file_ \"quuz\"+--       file_ \"tatata\"+--     file_ \"quux\"+-- @+--+-- and running @check layout \".\"@ should result in @[]@+check :: Layout+      -> FilePath             -- ^ Root directory+      -> IO [LayoutException] -- ^ List of failures+check = applyTraverse go+ where+  go :: Layout -> RunT ()+  go (E _)           = return ()+  go (F p (E _) x)   = checkFile p Nothing >> go x+  go (F p (T t _) x) = checkFile p (Just t) >> go x+  go (D p x y)       = checkDirectory p >> changeDir p (go x) >> go y+  go _               = error "Broken DL () invariant"++checkFile :: FilePath -> Maybe Text -> RunT ()+checkFile p t = ask >>= \d -> anyfail $ case t of+  Nothing -> fileExists (d </> p)+  Just t' -> readFile (d </> p) t'++checkDirectory :: FilePath -> RunT ()+checkDirectory p = ask >>= \d -> anyfail $ directoryExists (d </> p)

@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UnicodeSyntax #-}+module Main where++import Control.Exception (finally)+import System.Exit (exitSuccess, exitFailure)+import System.IO.Error++import System.Directory.Layout+import Test.HUnit hiding (assert)+import System.Process (rawSystem)+++main ∷ IO ()+main = do+  z ← runTestTT tests+  if errors z + failures z > 0+    then exitFailure+    else exitSuccess+ where+  tests = TestList+    [ TestLabel "trivia1" testTrivia1+    , TestLabel "trivia2" testTrivia2+    , TestLabel "dual1" testDual1+    ]+++testTrivia1 ∷ Test+testTrivia1 = TestCase $ do+  install+  check' >>= assertEqual "correct" []++  install+  rawSystem "rm" ["-rf", "directory-layout-test/x/y"]+  check' >>= assertEqual "deleted y"+    [ DE doesNotExistErrorType "x/y"+    , FE doesNotExistErrorType "x/y/s"+    , FE doesNotExistErrorType "x/y/v"+    ]++  install+  rawSystem "rm" ["-rf", "directory-layout-test/z"]+  check' >>= assertEqual "deleted z"+    [ DE doesNotExistErrorType "z"+    , RF doesNotExistErrorType "z/w" "text"+    ]++  install+  rawSystem "rm" ["-rf", "directory-layout-test/x/y/s"]+  check' >>= assertEqual "deleted s" [FE doesNotExistErrorType "x/y/s"]++  install+  writeFile "directory-layout-test/z/w" "foo"+  check' >>= assertEqual "changed z/w" [RF userErrorType "z/w" "text"]+ `finally`+  rawSystem "rm" ["-rf", "directory-layout-test"]+ where+  install = do+    rawSystem "mkdir" ["--parents", "directory-layout-test"]+    rawSystem "mkdir" ["--parents", "directory-layout-test/x/y"]+    rawSystem "mkdir" ["--parents", "directory-layout-test/z"]+    rawSystem "touch" ["directory-layout-test/x/y/s"]+    rawSystem "touch" ["directory-layout-test/x/y/v"]+    rawSystem "touch" ["directory-layout-test/z/w"]+    writeFile "directory-layout-test/z/w" "text"++  script = do+    directory "x" $+      directory "y" $ do+        file_ "s"+        file_ "v"+    directory "z" $+      file "w" "text"++  check' = check script "directory-layout-test"+++testTrivia2 ∷ Test+testTrivia2 = TestCase $ do+  rawSystem "mkdir" ["--parents", "directory-layout-test"]+  install+  check' >>= assertEqual "correct" []++  install+  rawSystem "rm" ["-rf", "directory-layout-test/x/y"]+  check' >>= assertEqual "deleted y"+    [ DE doesNotExistErrorType "x/y"+    , FE doesNotExistErrorType "x/y/s"+    , FE doesNotExistErrorType "x/y/v"+    ]++  install+  rawSystem "rm" ["-rf", "directory-layout-test/z"]+  check' >>= assertEqual "deleted z"+    [ DE doesNotExistErrorType "z"+    , RF doesNotExistErrorType "z/w" "text"+    ]++  install+  rawSystem "rm" ["-rf", "directory-layout-test/x/y/s"]+  check' >>= assertEqual "deleted s" [FE doesNotExistErrorType "x/y/s"]++  install+  writeFile "directory-layout-test/z/w" "foo"+  check' >>= assertEqual "changed z/w" [RF userErrorType "z/w" "text"]+ `finally`+  rawSystem "rm" ["-rf", "directory-layout-test"]+ where+  install = make script "directory-layout-test"++  script = do+    directory "x" $+      directory "y" $ do+        file_ "s"+        file_ "v"+    directory "z" $+      file "w" "text"++  check' = check script "directory-layout-test"+++testDual1 ∷ Test+testDual1 = TestCase $ do+  rawSystem "mkdir" ["--parents", "directory-layout-test"]+  let s = do+        directory "x" $ do+          directory_ "xx"+          directory "xy" $+            file "xyx" "test1"+          file "xz" "test2"+          file "xz'" "test3"+          file_ "xz''"+        directory "y" $ do+          file "yx" "test4"+          file "yy" "test5"+          file_ "yz"+        directory_ "z"+  test' s+ `finally`+  rawSystem "rm" ["-rf", "directory-layout-test"]+ where+  test' s = make' s >> check' s+  make' s = make s "directory-layout-test"+  check' s = check s "directory-layout-test" >>= assertEqual "dual" []

@@ -0,0 +1,12 @@+module Main where++import System.Wordexp.Simple+import Test.DocTest+++main :: IO ()+main = do+  x <- wordexp "cabal-dev/packages-*.conf"+  case x of+    y:_ | '*' `notElem` y -> doctest ["-isrc", "-package-db=" ++ y, "src/System/Directory/Layout/Lens.hs"]+    _                     -> doctest ["-isrc", "src/System/Directory/Layout/Lens.hs"]