directory-layout 0.4.0.1 → 0.6.0.0

raw patch · 20 files changed

+1447/−892 lines, 20 filesdep +Unixutilsdep +bifunctorsdep +bytestringdep −HUnitdep −QuickCheckdep −data-defaultdep ~basedep ~hspecdep ~lenssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: Unixutils, bifunctors, bytestring, free, template-haskell, transformers, unix, unordered-containers

Dependencies removed: HUnit, QuickCheck, data-default, directory-layout, mtl, process, semigroupoids, wordexp

Dependency ranges changed: base, hspec, lens, semigroups, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +46/−0
• LICENSE +27/−16
• README.md +5/−0
• Setup.hs +0/−2
• directory-layout.cabal +87/−69
• src/System/Directory/Layout.hs +40/−71
• src/System/Directory/Layout/Errored.hs +0/−117
• src/System/Directory/Layout/Internal.hs +249/−117
• src/System/Directory/Layout/Interpreter.hs +341/−0
• src/System/Directory/Layout/Lens.hs +0/−151
• src/System/Directory/Layout/QQ.hs +57/−0
• src/System/Directory/Layout/Traverse.hs +0/−131
• test/Doctest.hs +28/−0
• test/Spec.hs +1/−0
• test/System/Directory/Layout/InternalSpec.hs +106/−0
• test/System/Directory/Layout/InterpreterSpec.hs +416/−0
• test/System/Directory/LayoutSpec.hs +44/−0
• tests/Hspec.hs +0/−62
• tests/Main.hs +0/−144
• tests/doctests.hs +0/−12

@@ -0,0 +1,46 @@+0.6.0.0+=======++  * Complete rewrite++  * Added `pretty` and `spec` interpreters++  * Layout nodes can be configured with user/group and file permissions++  * Added symlinks with optionally checked source existence++  * File contents can be specified as raw bytes or text data++  * File can be declared the copy of another file++0.4.0.0+=======++  * Self-balancing `Semigroup`,`Apply`,`Applicative`,`Bind`, and `Monad` instance for `Node`.+    That way we have reasonable auto-derived `Eq` and `Ord` instances++  * Added `name`, `names`, `next`, `node` traversals and fixed `file` and `directory`++  * Added `Layout` construction from existing directories via `fromDirectory`++0.3.1.0+=======++  * Fixed build for GHC 7.4++0.3.0.0+=======++  * Removed parser stuff++  * Added `Default`, `Semigroup`, `Monoid`, and `Applicative` instances for `Layout`++  * Added "extractors" (`System.Directory.Layout.Lens`)++  * Added `Apply` and `Bind` instances for `Layout`++  * Added `Ord` instance for `Layout`++  * Added `Foldable` and `Traversable` instances for `Layout`++  * Rewrote Check and Make (unified errors, simpler implementation)

@@ -1,19 +1,30 @@-Copyright (C) 2012 Matvey Aksenov+Copyright (c) 2014, Matvey Aksenov -Permission is hereby granted, free of charge, to any person obtaining a copy of-this software and associated documentation files (the "Software"), to deal in-the Software without restriction, including without limitation the rights to-use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies-of the Software, and to permit persons to whom the Software is furnished to do-so, subject to the following conditions:+All rights reserved. -The above copyright notice and this permission notice shall be included in all-copies or substantial portions of the Software.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met: -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR-IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,-FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE-AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER-LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,-OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE-SOFTWARE.+    * 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 Matvey Aksenov 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.

@@ -0,0 +1,5 @@+# directory-layout+[![Hackage](https://budueba.com/hackage/directory-layout)](https://hackage.haskell.org/package/directory-layout)+[![Build Status](https://secure.travis-ci.org/supki/directory-layout.png?branch=master)](https://travis-ci.org/supki/directory-layout)++Directory layout DSL

@@ -1,4 +1,2 @@ import Distribution.Simple--main :: IO () main = defaultMain

@@ -1,80 +1,98 @@-name:          directory-layout-version:       0.4.0.1-synopsis:      Declare, construct and verify directory layout-description:   Language to express directory layouts-category:      System-license:       MIT-license-file:  LICENSE-author:        Matvey Aksenov-maintainer:    matvey.aksenov@gmail.com-build-type:    Simple-cabal-version: >= 1.10+name:                directory-layout+version:             0.6.0.0+synopsis:            Directory layout DSL+description:+  Making, fitting, printing directory layouts+license:             BSD3+license-file:        LICENSE+author:              Matvey Aksenov+maintainer:          matvey.aksenov@gmail.com+category:            System+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:+  README.md+  CHANGELOG.md +source-repository head+  type:     git+  location: https://github.com/supki/directory-layout++source-repository this+  type:     git+  location: https://github.com/supki/directory-layout+  tag:      0.6.0.0+ library-  default-language: Haskell2010+  default-language:+    Haskell2010+  build-depends:+      base                 >= 4.6   && < 5+    , bifunctors           >= 4+    , bytestring+    , directory+    , filepath+    , free                 >= 4.7+    , hspec                >= 1.8+    , lens                 >= 4.0.1+    , semigroups           >= 0.12+    , template-haskell+    , text                 >= 0.11+    , transformers         >= 0.3+    , unix+    , unordered-containers >= 0.2.3   exposed-modules:     System.Directory.Layout     System.Directory.Layout.Internal-    System.Directory.Layout.Errored-    System.Directory.Layout.Traverse-    System.Directory.Layout.Lens-  hs-source-dirs: src-  build-depends:-    base >= 4 && < 5,-    data-default,-    directory,-    filepath,-    lens,-    mtl,-    semigroupoids,-    semigroups,-    text+    System.Directory.Layout.Interpreter+    System.Directory.Layout.QQ+  hs-source-dirs:+    src   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+test-suite doctest+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0   build-depends:-    base >= 3 && < 5,-    directory-layout,-    doctest,-    lens,-    wordexp-  main-is: tests/doctests.hs-  ghc-options:-    -Wall-    -fno-warn-unused-do-bind+      base          == 4.*+    , directory+    , doctest+    , filepath+  hs-source-dirs:+    test+  main-is:+    Doctest.hs -test-suite layout-laws-  default-language: Haskell2010-  type: exitcode-stdio-1.0+test-suite spec+  default-language:+    Haskell2010+  type:+    exitcode-stdio-1.0   build-depends:-    base >= 3 && < 5,-    directory-layout,-    hspec,-    semigroups-  main-is: tests/Hspec.hs-  ghc-options:-    -Wall-    -fno-warn-unused-do-bind---source-repository head-  type: git-  location: https://github.com/supki/directory-layout+      base >= 4.6+    , bifunctors+    , bytestring+    , directory+    , filepath+    , free+    , hspec+    , lens >= 4+    , semigroups+    , template-haskell+    , text+    , transformers+    , unix+    , unordered-containers+    , Unixutils+  hs-source-dirs:+    src+    test+  main-is:+    Spec.hs+  other-modules:+    System.Directory.LayoutSpec+    System.Directory.Layout.InternalSpec+    System.Directory.Layout.InterpreterSpec

@@ -1,74 +1,43 @@--- | Language to express directory layouts+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+-- | Directory layout DSL module System.Directory.Layout-  ( -- * Layout declaration-    Node, Layout, file, file_, directory, directory_-    -- * Layout construction-  , fromDirectory-    -- * Layout traverses-  , make, check-    -- * Errors-  , LayoutException(..)+  ( -- * Describe layouts+    Layout+    -- ** Nodes+  , file+  , symlink+  , dir+  , dirs+  , emptydir+    -- ** Nodes augmentation+  , contents+  , Contents(..)+  , binary+  , text+  , dedent+  , copyOf+  , source+  , exists+  , User(..)+  , user+  , uid+  , username+  , Group(..)+  , group+  , gid+  , groupname+  , mode+  , anything+  , into+  , focus+    -- * Run layouts+  , module System.Directory.Layout.Interpreter   ) where -import           Control.Lens-import           Control.Monad ((>=>))-import qualified Control.Exception as E-import           Data.Default (def)-import           Data.Monoid (mconcat)-import           Data.Text (Text)-import qualified System.Directory as D-import           System.FilePath (combine)-import           System.FilePath.Lens (filename)--import System.Directory.Layout.Internal (Node(..), 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 t = F x (T t ()) def-{-# INLINE file #-}----- | Declare empty file-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 def-{-# INLINE directory #-}----- | Declare empty directory-directory_ :: FilePath -> Layout-directory_ x = D x def def-{-# INLINE directory_ #-}----- | Create layout from directory------ Canonicalizes path before traversing, generally understands only--- regular files and directories and ignores anything else it could not understand-fromDirectory :: FilePath -> IO (Either E.IOException Layout)-fromDirectory = E.try . (D.canonicalizePath >=> traverseDirectory)- where-  traverseDirectory :: FilePath -> IO Layout-  traverseDirectory path = getDirectoryContents path >>=-    traverse (traverseFilePath . combine path) <&> directory (path^.filename) . mconcat--  traverseFilePath :: FilePath -> IO Layout-  traverseFilePath path = do-    isFile      <- D.doesFileExist path-    isDirectory <- D.doesDirectoryExist path-    case (isFile, isDirectory) of-      (True, _) -> return (file_ (path^.filename))-      (_, True) -> traverseDirectory path-      -- Should be pretty rare in practice: broken symlinks and stuff-      (_, _)    -> return def--  getDirectoryContents :: FilePath -> IO [FilePath]-  getDirectoryContents = fmap (filter (not . (`elem` [".", ".."]))) . D.getDirectoryContents+import System.Directory.Layout.Internal+import System.Directory.Layout.Interpreter+import System.Directory.Layout.QQ

@@ -1,117 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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)-#if __GLASGOW_HASKELL__ >= 706-import           System.IO.Error-#else-import           System.IO.Error hiding (catch, try)-#endif--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 'D.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 'T.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)----- | 'D.doesFileExist' 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))---- | 'D.doesDirectoryExist' 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 'T.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,145 +1,277 @@--- | Free monad based directory layouts-module System.Directory.Layout.Internal-  ( Node(..), Layout-  ) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+-- | directory-layout internals+module System.Directory.Layout.Internal where -import Control.Applicative (Applicative(..), (<$>))-import Data.Foldable (Foldable(..))-import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault)-import Data.Monoid (Monoid(..))-import Unsafe.Coerce (unsafeCoerce)+import           Control.Applicative+import           Control.Lens+import           Control.Monad.Free+import           Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import           Data.Data (Data, Typeable)+import           Data.Foldable (Foldable)+import qualified Data.HashMap.Strict as HashMap+import           Data.Semigroup (Semigroup(..))+import           Data.String (IsString(..))+import           Data.Word (Word8)+import           Data.Text (Text)+#if __GLASGOW_HASKELL__ >= 708+import           GHC.Exts (IsList(..))+#endif+import           GHC.Generics (Generic)+import           System.FilePath ((</>))+import qualified System.Posix as Posix -import Data.Default (Default(..))-import Data.Functor.Apply (Apply(..))-import Data.Functor.Bind (Bind(..))-import Data.Semigroup (Semigroup(..))-import Data.Text (Text)+-- | Directory layout description+newtype Layout a = L { unL :: Free F a }+  deriving (Functor, Applicative, Monad, Foldable, Traversable, Typeable, Generic) +-- | The underlying 'Functor'+data F a =+    F String (Maybe Contents) Aux a+  | SL String FilePath Bool Aux a+  | D String a Aux a+  | E+    deriving (Eq, Functor, Foldable, Traversable, Typeable, Generic) --- | Type synonym to save some acrobatics-type Layout = Node ()+-- | Regular file contents+data Contents =+    Binary ByteString+  | Text Text+  | CopyOf FilePath+    deriving (Eq, Typeable, Data, Generic) +instance IsString Contents where+  fromString = Text . fromString --- | A representation of directory layouts+#if __GLASGOW_HASKELL__ >= 708+instance IsList Contents where+  type Item Contents = Word8+  fromList = Binary . ByteString.pack+  toList = error "Contents.toList: not implemented"+#endif++-- | Auxiliary data+data Aux = Aux (Maybe User) (Maybe Group) (Maybe Posix.FileMode)+    deriving (Show, Eq, Typeable, Generic)++-- | File owner+data User =+    UserID Posix.UserID+  | Username String+    deriving (Show, Eq, Typeable, Generic)++instance IsString User where+  fromString = Username++-- | File group+data Group =+    GroupID Posix.GroupID+  | Groupname String+    deriving (Show, Eq, Typeable, Generic)++instance IsString Group where+  fromString = Groupname++-- | Equality check does not care about the order the files are listed insofar+-- they are consistent, i.e. different things aren't named the same+instance Eq (Layout a) where+  L xs == L ys = go "." xs == go "." ys+   where+    go root (Free t@(F n _ _ m)) =+      HashMap.singleton (root </> n) (() <$ t) <> go root m+    go root (Free t@(SL n _ _ _ m)) =+      HashMap.singleton (root </> n) (() <$ t) <> go root m+    go root (Free t@(D n is _ m)) =+      HashMap.singleton (root </> n) (() <$ t) <> go (root </> n) is <> go root m+    go _ (Free E) = HashMap.empty+    go _ (Pure _) = HashMap.empty++instance Semigroup (Layout a) where+  (<>) = (>>)++-- | Regular file with some contents or empty ----- Invariants:+-- >>> let layout = file "foo"+file :: String -> Layout ()+file name = L (liftF (F name anything defaux ()))++-- | Symbolic link -----  * 'F' second argument is never @D _ _ _@ or @F _ _ _@ itself+-- >>> let layout = symlink "foo" "bar"+symlink+  :: String   -- link's name+  -> FilePath -- link's source+  -> Layout ()+symlink name s = L (liftF (SL name s False defaux ()))++-- | Directory -----  * 'F' third argument is never @T _ _@+-- >>> :{+-- let layout = dir "foo" $ do+--       file "bar"+--       file "baz"+-- :}+dir :: String -> Layout a -> Layout ()+dir name is = L (Free (D name (unL is >> liftF E) defaux (Pure ())))++-- | Empty directory -----  * 'D' second argument is never @T _ _@+-- >>> let layout = emptydir "foo"+emptydir :: String -> Layout ()+emptydir name = dir name (return ())++-- | A nested list of directories -----  * 'D' third argument is never @T _ _@-data Node a =-    E !a                          -- ^ Emptyness, nothing found here-  | T !Text !a                    -- ^ File contents-  | F !FilePath !Layout !(Node a) -- ^ File node-  | D !FilePath !Layout !(Node a) -- ^ Directory node-    deriving (Show, Read, Eq, Ord)+-- >>> :{+-- let layout = dirs ["foo", "bar"] $ do+--                file "qux"+--                file "quux"+-- :}+dirs :: [String] -> Layout () -> Layout ()+dirs names l = foldr dir l names -compareFilePath :: Node a -> Node b -> Ordering-compareFilePath (E _)      (E _)       = EQ-compareFilePath (E _)      _           = LT-compareFilePath _          (E _)       = GT-compareFilePath (T _ _)    (T _ _)     = EQ-compareFilePath (T _ _)    _           = LT-compareFilePath _          (T _ _)     = GT-compareFilePath (F fp _ _) (F fp' _ _) = compare fp fp'-compareFilePath (F _ _ _)  _           = LT-compareFilePath _          (F _ _ _)   = GT-compareFilePath (D fp _ _) (D fp' _ _) = compare fp fp'-{-# INLINE compareFilePath #-}+-- | The default (empty) auxiliary data+defaux :: Aux+defaux = Aux Nothing Nothing Nothing -instance Default a => Default (Node a) where-  def = E def-  {-# INLINE def #-}+-- | An optic into file contents+contents :: Traversal' (Layout a) (Maybe Contents)+contents f (L (Free (F n cs a x@(Pure _)))) = f cs <&> \cs' -> L (Free (F n cs' a x))+contents _ l = pure l+{-# INLINE contents #-} -instance Semigroup (Node a) where-  (<>) = (>>)-  {-# INLINE (<>) #-}+-- | Binary contents+--+-- >>> let layout = file "foo" & contents ?~ binary (ByteString.pack [1..10])+binary :: ByteString -> Contents+binary = Binary -instance Default a => Monoid (Node a) where-  mempty = def-  {-# INLINE mempty #-}+-- | Plain text contents+--+-- >>> let layout = file "foo" & contents ?~ text (Data.Text.pack "hello")+text :: Text -> Contents+text = Text -  mappend = (<>)-  {-# INLINE mappend #-}+-- | Contents are the copy of whose of the real file+--+-- >>> let layout = file "foo" & contents ?~ copyOf "/home/user/.vimrc"+copyOf :: FilePath -> Contents+copyOf = CopyOf -instance Functor Node where-  fmap = fmapDefault-  {-# INLINE fmap #-}+-- | Anything+--+-- >>> let layout = file "foo" & contents .~ anything+-- >>> let layout = file "foo" & user .~ anything+anything :: Maybe a+anything = Nothing -instance Apply Node where-  f <.> x =-    f >>- \f' ->-    x >>- \x' ->-    pure (f' x')-  {-# INLINE (<.>) #-}+-- | An optic into symbolic link source+--+-- >>> symlink "foo" "bar" ^? source+-- Just "bar"+source :: Traversal' (Layout a) String+source f (L (Free (SL n s e a x@(Pure _)))) = f s <&> \s' -> L (Free (SL n s' e a x))+source _ l = pure l+{-# INLINE source #-} -instance Applicative Node where-  pure = E-  {-# INLINE pure #-}+-- | An optic into symbolic link source expected existence+--+-- >>> let layout = symlink "foo" "bar" & exists .~ True+exists :: Traversal' (Layout a) Bool+exists f (L (Free (SL n s e a x@(Pure _)))) = f e <&> \e' -> L (Free (SL n s e' a x))+exists _ l = pure l+{-# INLINE exists #-} -  (<*>) = (<.>)-  {-# INLINE (<*>) #-}+-- | An optic into file auxiliary data+aux :: Traversal' (Layout a) Aux+aux f (L (Free (F n cs a x@(Pure _)))) = f a <&> \a' -> L (Free (F n cs a' x))+aux f (L (Free (SL n s e a x@(Pure _)))) = f a <&> \a' -> L (Free (SL n s e a' x))+aux f (L (Free (D n is a x@(Pure _)))) = f a <&> \a' -> L (Free (D n is a' x))+aux _ l = pure l+{-# INLINE aux #-} -instance Bind Node where-  E x         >>- f = f x-  T _ x       >>- f = f x-  n@(F _ _ x) >>- f = n >>* (x >>- f)-  n@(D _ _ x) >>- f = n >>* (x >>- f)-  {-# INLINE (>>-) #-}+-- | An optic into file owner+--+-- >>> let layout = file "foo" & user ?~ uid 0+user :: Traversal' (Layout a) (Maybe User)+user = aux . \f (Aux x y z) -> f x <&> \x' -> Aux x' y z -(>>*) :: Node a -> Node b -> Node b-a >>* b =-  case compareFilePath a b of-    GT -> case b of-      E _      -> unsafeCoerce a-      T _ _    -> unsafeCoerce a-      F f t l  -> F f t (a >>* l)-      D f l l' -> D f l (a >>* l')-    _  -> case a of-      E _     -> b-      T _ _   -> b-      F f t _ -> F f t b-      D f l _ -> D f l b-{-# INLINE (>>*) #-}+-- | Set the file owner by uid+uid :: Posix.UserID -> User+uid = UserID --- | All this crazy stuff is only to get do-notation basically.+-- | Set the file owner by username ----- Bind (@<-@) in that do-notation is useless at best--- (You only can get @()@s from 'Layout') and harmful at worst--- (If you manage to create your own 'Node' values with something more--- interesting than @()@)-instance Monad Node where-  return = pure-  {-# INLINE return #-}+-- >>> let layout = file "foo" & user ?~ username "root"+username :: String -> User+username = Username -  a >> b =-    case compareFilePath a b of-      GT -> case b of-        E _      -> unsafeCoerce a-        T _ _    -> unsafeCoerce a-        F f t l  -> F f t (a >> l)-        D f l l' -> D f l (a >> l')-      _  -> case a of-        E _      -> b-        T _ _    -> b-        F f t l  -> F f t (l  >> b)-        D f l l' -> D f l (l' >> b)-  {-# INLINE (>>) #-}+-- | An optic into file group+--+-- >>> let layout = file "foo" & group ?~ gid 0+group :: Traversal' (Layout a) (Maybe Group)+group = aux . \f (Aux x y z) -> f y <&> \y' -> Aux x y' z -  (>>=) = (>>-)-  {-# INLINE (>>=) #-}+-- | Set the file group by groupname+gid :: Posix.GroupID -> Group+gid = GroupID -instance Foldable Node where-  foldMap = foldMapDefault-  {-# INLINE foldMap #-}+-- | Set the file group by groupname+--+-- >>> let layout = file "foo" & group ?~ groupname "wheel"+groupname :: String -> Group+groupname = Groupname -instance Traversable Node 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 #-}+-- | An optic into file mode+--+-- >>> let layout = file "foo" & mode ?~ 0o100777+mode :: Traversal' (Layout a) (Maybe Posix.FileMode)+mode = aux . \f (Aux x y z) -> f z <&> \z' -> Aux x y z'++-- | An optic into directory contents+innards :: Traversal' (Layout a) (Layout a)+innards f (L (Free (D n is a x@(Pure _)))) = fmap unL (f (L is)) <&> \is' -> L (Free (D n is' a x))+innards _ l = pure l+{-# INLINE innards #-}++-- | An optic into the directory contents of the particular directory+--+-- >>> :{+-- dirs ["foo", "bar", "baz"] (symlink "qux" "quux")+--   ^? into "foo".into "bar".into "baz".focus "qux".source+-- :}+-- Just "quux"+into :: String -> Traversal' (Layout ()) (Layout ())+into s = focus s.innards++-- | An optic into the particular node+focus :: String -> Traversal' (Layout ()) (Layout ())+focus k f = fmap L . go . unL where+  go (Free (F n cs a x))+    | n == k =+      g (liftF (F n cs a ())) <&> \(Free (F _ cs' a' _)) -> Free (F n cs' a' x)+    | otherwise =+      go x <&> Free . F n cs a+  go (Free (D n is a x))+    | n == k =+      g (Free (D n is a (Pure ()))) <&> \(Free (D _ is' a' _)) -> Free (D n is' a' x)+    | otherwise =+      go x <&> Free . D n is a+  go (Free (SL n s e a x))+    | n == k =+      g (liftF (SL n s e a ())) <&> \(Free (SL _ s' e' a' _)) -> Free (SL n s' e' a' x)+    | otherwise =+      go x <&> Free . SL n s e a+  go (Free E) = pure (Free E)+  go (Pure x) = pure (Pure x)++  g = fmap unL . f . L+{-# INLINE focus #-}

@@ -0,0 +1,341 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+-- | A bunch of 'Layout' description interpreters+module System.Directory.Layout.Interpreter+  ( pretty+  , spec+  , Validation(..)+  , fit+  , FitError(..)+  , FitContentsError(..)+  , make+  , MakeError(..)+  ) where++import           Control.Applicative+import           Control.Exception (Exception(..), SomeException(..), throwIO, try)+import           Control.Monad+import           Control.Monad.Free+import           Data.Bifoldable (Bifoldable(..))+import           Data.Bifunctor (Bifunctor(..))+import           Data.Bitraversable (Bitraversable(..))+import           Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as ByteStringLazy+import           Data.Data (Data, Typeable)+import           Data.Foldable (Foldable, sequenceA_, for_)+import           Data.Functor.Compose (Compose(..))+import           Data.List.NonEmpty (NonEmpty)+import           Data.Maybe (fromMaybe)+import           Data.Semigroup (Semigroup(..))+import           Data.Text (Text)+import qualified Data.Text.IO as Text+import           Data.Traversable (Traversable)+import           Data.Typeable (cast)+import           GHC.Generics (Generic)+import           Numeric (showOct)+import           System.Directory (createDirectoryIfMissing)+import           System.FilePath (combine)+import           System.IO.Error (IOErrorType, ioeGetErrorType, ioeGetFileName, ioeGetLocation)+import qualified System.Posix as Posix+import           Test.Hspec (Spec, context, it)+import           Text.Printf (printf)++import           System.Directory.Layout.Internal++-- | Pretty print the directory layout+pretty :: Layout a -> String+pretty = unlines . iter go . unL . fmap (const []) where+  go f@(F _ _ _ other) = prettyF f : other+  go f@(SL _ _ _ _ other) = prettyF f : other+  go f@(D _ is _ other) = prettyF f : map indent is ++ other+  go E = []++  indent :: String -> String+  indent s = "┆ " ++ s++prettyF :: F a -> String+prettyF (F name cs _ _) = printf "‘%s’, %s" name (prettyC cs)+prettyF (SL name s _ _ _) = printf "‘%s’, a link to ‘%s’" name s+prettyF (D name _ _ _) = '/' : name+prettyF E = ""++prettyC :: Maybe Contents -> String+prettyC (Just (Binary _)) = "raw bytes"+prettyC (Just (Text _)) = "text"+prettyC (Just (CopyOf p)) = printf "(copy of ‘%s’)" p+prettyC Nothing = "anything"++-- | Interpret the directory layout as a 'Spec'+spec :: FilePath -> Layout a -> Spec+spec p = go p . unL where+  go root (Free f@(F _ _ _ m)) = do+    specF root f+    go root m+  go root (Free f@(SL _ _ _ _ m)) = do+    specF root f+    go root m+  go root (Free f@(D (combine root -> fullpath) is _ m)) = do+    specF root f+    context (printf "directory ‘%s’" fullpath) (go fullpath is)+    go root m+  go _ (Free E) = return ()+  go _ (Pure _) = return ()++specF :: FilePath -> F a -> Spec+specF root = go where+  go f@(F name cs _ _) = it (printf "has a %s file ‘%s’" (examplesC cs) name) (fitIO root f)+  go f@(SL name s _ _ _) = it (printf "has a symlink ‘%s’ pointing to ‘%s’" name s) (fitIO root f)+  go f@(D (combine root -> fullpath) _ _ _) = it (printf "has a subdirectory ‘%s’" fullpath) (fitIO root f)+  go E = return ()++examplesC :: Maybe Contents -> String+examplesC (Just (Binary _)) = "binary"+examplesC (Just (Text _)) = "plain text"+examplesC (Just (CopyOf p)) = printf "(copy of ‘%s’)" p+examplesC Nothing = "regular"++validate+  :: Exception e+  => (forall a. FilePath -> F a -> IO ()) -> FilePath -> Layout b -> IO (Validation (NonEmpty e) ())+validate g p = getCompose . go p . unL where+  go root (Free f@(F _ _ _ m)) =+    sequenceA_ [Compose (validateF root f), go root m]+  go root (Free f@(SL _ _ _ _ m)) =+    sequenceA_ [Compose (validateF root f), go root m]+  go root (Free f@(D (combine root -> fullpath) is _ m)) =+    sequenceA_ [Compose (validateF root f), go fullpath is, go root m]+  go _ (Free E) = pure ()+  go _ (Pure _) = pure ()++  validateF root l = first pure . fromEither <$> try (g root l)++-- | Check the real directory layout fits the description+fit :: FilePath -> Layout a -> IO (Validation (NonEmpty FitError) ())+fit = validate fitIO++fitIO :: FilePath -> F a -> IO ()+fitIO root = go where+  go (F (combine root -> fullpath) cs a _) = do+    for_ cs $ \cs' -> case cs' of+      Binary bs -> do+        real <- ByteString.readFile fullpath+        when (real /= bs) $+          throwIO (FitBadFileContents fullpath (FitBadBinary bs real))+      Text t -> do+        real <- Text.readFile fullpath+        when (real /= t) $+          throwIO (FitBadFileContents fullpath (FitBadText t real))+      CopyOf f -> do+        origin <- ByteStringLazy.readFile f+        copy <- ByteStringLazy.readFile fullpath+        when (origin /= copy) $+          throwIO (FitBadFileContents fullpath (FitBadCopyOf f))+    fitIOAux a fullpath+  go (SL (combine root -> fullpath) s e a _) = do+    path <- Posix.readSymbolicLink fullpath+    when (path /= s) $+      throwIO (FitBadLinkSource fullpath s path)+    when e $+      () <$ Posix.getFileStatus fullpath+    fitIOAux a fullpath+  go (D (combine root -> fullpath) _ a _) = () <$ do+    fitIOAux a fullpath+  go E = return ()++fitIOAux :: Aux -> FilePath -> IO ()+fitIOAux (Aux muid mgid mperm) path = do+  status <- Posix.getSymbolicLinkStatus path+  for_ muid $ \case+    UserID i ->+      unless (Posix.fileOwner status == i) $+        throwIO (FitBadOwnerUser path (UserID i) (UserID (Posix.fileOwner status)))+    Username name -> do+      i <- getUserID name+      n <- getUsername (Posix.fileOwner status)+      unless (Posix.fileOwner status == i) $+        throwIO (FitBadOwnerUser path (Username name) (Username n))+  for_ mgid $ \case+    GroupID i ->+      unless (Posix.fileGroup status == i) $+        throwIO (FitBadOwnerGroup path (GroupID i) (GroupID (Posix.fileGroup status)))+    Groupname name -> do+      i <- getGroupID name+      n <- getGroupname (Posix.fileGroup status)+      unless (Posix.fileGroup status == i) $+        throwIO (FitBadOwnerGroup path (Groupname name) (Groupname n))+  for_ mperm $ \perm ->+    unless (Posix.fileMode status == perm) $+      throwIO (FitBadFileMode path perm (Posix.fileMode status))++-- | Errors encountered while running 'fit'+data FitError =+    FitBadFileContents FilePath FitContentsError+  | FitBadLinkSource FilePath String {- expected -} String {- actual -}+  | FitBadOwnerUser FilePath User {- expected -} User {- actual -}+  | FitBadOwnerGroup FilePath Group {- expected -} Group {- actual -}+  | FitBadFileMode FilePath Posix.FileMode {- expected -} Posix.FileMode {- actual -}+  | FitIOException FilePath IOErrorType+    deriving (Eq, Typeable, Generic)++-- | Expected/actual file contents mismatch+data FitContentsError =+    FitBadBinary ByteString ByteString+  | FitBadText Text Text+  | FitBadCopyOf FilePath+    deriving (Eq, Typeable, Generic)++instance Show FitError where+  show (FitBadFileContents path mismatch) = unlines $+    printf "Bad contents at ‘%s’" path : showCE mismatch+   where+    showCE :: FitContentsError -> [String]+    showCE (FitBadBinary expected actual) =+      [ "expected:"+      , printf "  %s" (show (ByteString.unpack expected))+      , "actual:"+      , printf "  %s" (show (ByteString.unpack actual))+      ]+    showCE (FitBadText expected actual) =+      [ "expected:"+      , printf "  %s" (show expected)+      , "actual:"+      , printf "  %s" (show actual)+      ]+    showCE (FitBadCopyOf f) =+      [ "expected:"+      , printf "  a copy of ‘%s’" f+      , "actual:"+      , "  something else"+      ]+  show (FitBadLinkSource path expected actual) = unlines $+    [ printf "Bad symlink source at ‘%s’" path+    , "expected:"+    , printf "  ‘%s’" expected+    , "actual:"+    , printf "  ‘%s’" actual+    ]+  show (FitBadOwnerUser path expected actual) = unlines $+    [ printf "Bad owner user id at ‘%s’" path+    , "expected:"+    , printf "  %s" (show expected)+    , "actual:"+    , printf "  %s" (show actual)+    ]+  show (FitBadOwnerGroup path expected actual) = unlines $+    [ printf "Bad owner group id at ‘%s’" path+    , "expected:"+    , printf "  %s" (show expected)+    , "actual:"+    , printf "  %s" (show actual)+    ]+  show (FitBadFileMode path expected actual) = unlines $+    [ printf "Bad file permissions id at ‘%s’" path+    , "expected:"+    , printf "  %s" (showOct expected "")+    , "actual:"+    , printf "  %s" (showOct actual "")+    ]+  show (FitIOException eloc etype) =+    printf "Generic IO exception of type ‘%s’ happened at ‘%s’\n" (show etype) eloc++instance Exception FitError where+  toException = SomeException+  fromException e'@(SomeException e)+    | Just ioe <- fromException e' =+        Just (FitIOException (fromMaybe (ioeGetLocation ioe) (ioeGetFileName ioe)) (ioeGetErrorType ioe))+    | otherwise = cast e++-- | Make the real directory layout from the description+make :: FilePath -> Layout a -> IO (Validation (NonEmpty MakeError) ())+make = validate makeIO++makeIO :: FilePath -> F a -> IO ()+makeIO root = go where+  go (F (combine root -> fullpath) cs a _) = do+    case cs of+      Just (Binary bs) -> ByteString.writeFile fullpath bs+      Just (Text t) -> Text.writeFile fullpath t+      Just (CopyOf p) -> ByteStringLazy.readFile p >>= ByteStringLazy.writeFile fullpath+      Nothing -> ByteString.writeFile fullpath (ByteString.pack [])+    makeIOAux a fullpath+  go (SL (combine root -> fullpath) s _ a _) = do+    Posix.createSymbolicLink s fullpath+    makeIOAux a fullpath+  go (D (combine root -> fullpath) _ a _) = do+    createDirectoryIfMissing False fullpath+    makeIOAux a fullpath+  go E = return ()++makeIOAux :: Aux -> FilePath -> IO ()+makeIOAux (Aux muid mgid mperm) path = do+  for_ muid $ \case+    UserID i ->+      Posix.setSymbolicLinkOwnerAndGroup path i (-1)+    Username name -> do+      i <- getUserID name+      Posix.setSymbolicLinkOwnerAndGroup path i (-1)+  for_ mgid $ \case+    GroupID i ->+      Posix.setSymbolicLinkOwnerAndGroup path (-1) i+    Groupname name -> do+      i <- getGroupID name+      Posix.setSymbolicLinkOwnerAndGroup path (-1) i+  for_ mperm $+    Posix.setFileMode path++-- | Errors encountered while running 'make'+data MakeError =+  MakeIOException FilePath IOErrorType+  deriving (Show, Eq, Typeable, Generic)++instance Exception MakeError where+  toException = SomeException+  fromException e'@(SomeException e)+    | Just ioe <- fromException e' =+        Just (MakeIOException (fromMaybe (ioeGetLocation ioe) (ioeGetFileName ioe)) (ioeGetErrorType ioe))+    | otherwise = cast e++getUserID :: String -> IO Posix.UserID+getUserID = fmap Posix.userID . Posix.getUserEntryForName++getUsername :: Posix.UserID -> IO String+getUsername = fmap Posix.userName . Posix.getUserEntryForID++getGroupID :: String -> IO Posix.GroupID+getGroupID = fmap Posix.groupID . Posix.getGroupEntryForName++getGroupname :: Posix.GroupID -> IO String+getGroupname = fmap Posix.groupName . Posix.getGroupEntryForID++-- | This type is isomorphic to 'Either' but its 'Applicative' instance accumulates errors+data Validation e a = Error e | Result a+  deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Typeable, Data, Generic)++instance Bifunctor Validation where+  bimap f _ (Error a) = Error (f a)+  bimap _ g (Result a) = Result (g a)++instance Bifoldable Validation where+  bifoldMap f _ (Error a) = f a+  bifoldMap _ g (Result a) = g a++instance Bitraversable Validation where+  bitraverse f _ (Error a) = Error <$> f a+  bitraverse _ g (Result a) = Result <$> g a++instance Semigroup e => Applicative (Validation e) where+  pure = Result+  Error f  <*> Error x  = Error (f <> x)+  Error f  <*> _        = Error f+  _        <*> Error x  = Error x+  Result f <*> Result x = Result (f x)++fromEither :: Either e a -> Validation e a+fromEither = either Error Result

@@ -1,151 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--- | "Control.Lens" based extractors for 'Layout'-module System.Directory.Layout.Lens-  ( -- * Usage-    -- $setup-    text, name, names, next, file, directory, node-  ) where--import Control.Applicative ((<$>), (<*>), pure)--import Control.Lens-import Data.Text (Text)--import System.Directory.Layout.Internal (Node(..), 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 ())))----- | Target 'Text' from the current 'Layout' top (if possible)------ >>> layout ^? text--- Nothing--- >>> layout ^? file "foo" . text--- Just "not empty"--- >>> layout ^? directory "bar" . file "quux" . text--- Just "something"-text :: Prism' Layout Text-text = prism' (\t -> T t ()) $ \s -> case s of-  T t _ -> Just t-  _     -> Nothing-{-# INLINE text #-}---- | Target 'FilePath' from the current 'Layout' top (if possible)------ >>> layout ^? name--- Just "foo"--- >>> layout ^? directory "bar" . name--- Just "baz"--- >>> layout ^? directory "quux" . name--- Nothing--- >>> layout & name .~ "boo"--- F "boo" (T "not empty" ()) (D "bar" (F "baz" (E ()) (F "quux" (T "something" ()) (E ()))) (F "swaks" (E ()) (E ())))-name :: Traversal' Layout FilePath-name f = go- where-  go (E x)   = pure (E x)-  go (T t x) = pure (T t x)-  go (F n l x) = f n <&> \n' -> F n' l x-  go (D n l x) = f n <&> \n' -> D n' l x-{-# INLINE name #-}---- | Target all 'Filpath's from current 'Layout' layer------ >>> layout ^? names--- Just "foo"--- >>> layout ^.. names--- ["foo","bar","swaks"]--- >>> layout ^.. directory "bar" . names--- ["baz","quux"]--- >>> layout & directory "bar" . names %~ reverse--- F "foo" (T "not empty" ()) (D "bar" (F "zab" (E ()) (F "xuuq" (T "something" ()) (E ()))) (F "swaks" (E ()) (E ())))-names :: Traversal' Layout FilePath-names f = go- where-  go (E x)   = pure (E x)-  go (T t x) = pure (T t x)-  go (F n l x) = (\n' x' -> F n' l x') <$> f n <*> go x-  go (D n l x) = (\n' x' -> D n' l x') <$> f n <*> go x-{-# INLINE names #-}---- | Target next 'Node'------ >>> layout ^? name--- Just "foo"--- >>> layout ^? next . name--- Just "bar"--- >>> layout ^? next . next . name--- Just "swaks"--- >>> layout ^? next . next . next . name--- Nothing-next :: Traversal' Layout Layout-next f = go- where-  go (E x)   = pure (E x)-  go (T t x) = pure (T t x)-  go (F n l x) = f x <&> \x' -> F n l x'-  go (D n l x) = f x <&> \x' -> D n l x'-{-# INLINE next #-}---- | Target 'Layout' under the current 'Layout' top if it happens to be a file------ >>> 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 <&> \x' -> F k' l x'-  go (D n l x)  = go x <&> \x' -> D n l x'-{-# INLINE file #-}---- | Target 'Layout' under the current 'Layout' top if it happens to be a directory------ >>> 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 n l x)  = go x <&> \x' -> F n l x'-  go (D k' l x)-    | k == k'   = indexed f k l <&> \l' -> D k' l' x-    | otherwise = go x <&> \x' -> D k' l x'-{-# INLINE directory #-}---- | Target 'Layout' under the current 'Layout' top------ >>> layout ^? node "foo"--- Just (T "not empty" ())--- >>> layout ^? node "bar"--- Just (F "baz" (E ()) (F "quux" (T "something" ()) (E ())))--- >>> layout ^? node "what"--- Nothing-node :: FilePath -> IndexedTraversal' FilePath Layout Layout-node 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 <&> \x' -> F k' l x'-  go (D k' l x)-    | k == k'   = indexed f k l <&> \l' -> D k' l' x-    | otherwise = go x <&> \x' -> D k' l x'-{-# INLINE node #-}

@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Convenience quasiquoter to ease the pain working with multiline strings+module System.Directory.Layout.QQ (dedent) where++import Data.Char (isSpace)+import Data.List (intercalate)+import Language.Haskell.TH.Quote (QuasiQuoter(..))+import Language.Haskell.TH.Syntax (liftString)+import Language.Haskell.TH (Q, Exp)+++-- | A handy quasiquoter to work with the multiline file contents+--+-- Strips the longest common leading spaces segment. All spacey characters are treated+-- equally. The first line is ignored if it's spaces only.+--+-- >>> :set -XQuasiQuotes+-- >>> :{+-- putStr [dedent|+--   hello+--     world+--     !+--   |]+-- :}+-- hello+--   world+--   !+dedent :: QuasiQuoter+dedent = quoter $+  liftString . intercalate "\n" . stripCommonLeadingWhitespace . dropFirst (all isSpace) . lines++dropFirst :: (a -> Bool) -> [a] -> [a]+dropFirst _ [] = []+dropFirst p (x : xs)+  | p x = xs+  | otherwise = x : xs++stripCommonLeadingWhitespace :: [String] -> [String]+stripCommonLeadingWhitespace xs = map (drop (commonLeadingWhitespace xs)) xs++commonLeadingWhitespace :: [String] -> Int+commonLeadingWhitespace = minimumOr 0 . map (length . takeWhile isSpace)++minimumOr :: Ord a => a -> [a] -> a+minimumOr n [] = n+minimumOr _ xs = minimum xs++quoter :: (String -> Q Exp) -> QuasiQuoter+quoter quote = QuasiQuoter+  { quoteExp  = quote+  , quotePat  = failure "patterns"+  , quoteType = failure "types"+  , quoteDec  = failure "declarations"+  }+ where+  failure kind =+    fail $ "this quasiquoter does not support splicing " ++ kind

@@ -1,131 +0,0 @@--- | '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,28 @@+module Main where++import Control.Applicative+import Control.Monad+import Data.List (isSuffixOf)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.FilePath ((</>))+import Test.DocTest (doctest)+++main :: IO ()+main = sources "src" >>= doctest++sources :: FilePath -> IO [FilePath]+sources root = do+  files <- contents root+  liftM concat . forM files $ \file -> do+    let path = root </> file+    is_dir <- doesDirectoryExist path+    case is_dir of+      True              -> sources path+      _ | isSource path -> return [path]+        | otherwise     -> return []+ where+  isSource path = any (`isSuffixOf` path) [".hs", ".lhs"]++contents :: FilePath -> IO [FilePath]+contents dir = filter (`notElem` [".", ".."]) <$> getDirectoryContents dir

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module System.Directory.Layout.InternalSpec+  ( spec+  ) where++import           Control.Lens+import           Control.Monad.Free+import qualified Data.ByteString as ByteString+import           Data.Char (toUpper)+import           Test.Hspec++import           System.Directory.Layout.Internal++deriving instance Show Contents+deriving instance Show a => Show (F a)+deriving instance Show a => Show (Layout a)+++spec :: Spec+spec = do+  describe "Eq instance" $ do+    it "does not care about the order inside a layer" $+      l1 `shouldBe` l2++    it "does care about the file contents" $+      (l1 & into "bar".focus "baz".contents ?~ "baz'es innards") == l2 `shouldBe` False++    it "does care about the link source" $+      (l1 & focus "xyzzy".source.mapped %~ toUpper) == l2 `shouldBe` False++  describe "contents" $ do+    it "can change contents of the file to the specified text" $+      (file "foo" & contents ?~ "bar") `shouldBe` L (liftF (F "foo" (Just "bar") defaux ()))++    it "can change contents of the file to the specified bytes" $ do+      (file "foo" & contents ?~ binary (ByteString.pack [1..10]))+     `shouldBe`+      L (liftF (F "foo" (Just (binary (ByteString.pack [1..10]))) defaux ()))++    it "can change contents of the file to anything!" $+      (file "foo" & contents .~ anything) `shouldBe` L (liftF (F "foo" anything defaux ()))++  describe "source" $ do+    it "can change source of the symlink to the specified string" $+      (symlink "foo" "bar" & source .~ "baz") `shouldBe` symlink "foo" "baz"++  describe "ix" $ do+    it "can focus a file" $ do+      let l = do+            file "foo"+            file "bar"+            file "baz"++      (l & focus "bar".contents ?~ "qux") `shouldBe` do+         file "foo"+         file "bar"+           & contents ?~ "qux"+         file "baz"++    it "can focus a file inside the directory" $ do+      let l = do+            dir "foo" $+              dir "bar" $+                file "baz"++      (l & into "foo".into "bar".focus "baz".contents ?~ "qux") `shouldBe` do+         dir "foo" $+           dir "bar" $+             file "baz"+               & contents ?~ "qux"++    it "can focus a directory" $ do+      let l = do+            dir "foo" $+              dir "bar" $+                file "baz"++      (l & into "foo".focus "bar".mode ?~ 0o040777) `shouldBe` do+         dir "foo" $ do+           dir "bar" $ do+             file "baz"+          & mode ?~ 0o040777++l1, l2 :: Layout ()+l1 = do+  file "foo"+  dir "bar" $ do+    file "baz"+    file "qux"+      & contents ?~ "qux's innards"+    file "quux"+      & contents ?~ "quux's innards"+  file "xyz"+  symlink "xyzzy" "yzzyx"+l2 = do+  dir "bar" $ do+    file "baz"+    file "quux"+      & contents ?~ "quux's innards"+    file "qux"+      & contents ?~ "qux's innards"+  file "foo"+  symlink "xyzzy" "yzzyx"+  file "xyz"

@@ -0,0 +1,416 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module System.Directory.Layout.InterpreterSpec+  ( spec+  ) where++import           Control.Applicative+import           Control.Lens+import qualified Data.ByteString as ByteString+import           Data.Foldable (traverse_)+import           Data.List.NonEmpty (NonEmpty)+import           System.Directory (createDirectoryIfMissing)+import           System.FilePath ((</>))+import           System.IO.Error (doesNotExistErrorType, permissionErrorType)+import qualified System.Posix as Posix+import           Test.Hspec++import           SpecHelper+import           System.Directory.Layout hiding (spec)+++spec :: Spec+spec = do+  describe "Validation" $+    it "combines failures with the Semigroup instance's (<>)" $+      traverse_ tonel ([1, 2, 3, 4] :: [Int]) `shouldBe` errors [1,2,3,4]++  describe "fit" $ do+    it "tests regular file existence" $ do+      temporary $ \p -> do+        r <- fit p $ do+          file "foo"+        r `shouldBe` errors [FitIOException (p </> "foo") doesNotExistErrorType]++    it "does not test regular file contents" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") "foo"+        r <- fit p $ do+          file "foo"+        r `shouldBe` errors []++    it "tests text file existence" $ do+      temporary $ \p -> do+        r <- fit p $ do+          file "foo"+            & contents ?~ text "bar"+        r `shouldBe` errors [FitIOException (p </> "foo") doesNotExistErrorType]++    it "tests text file contents" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") "foo"+        r <- fit p $ do+          file "foo"+            & contents ?~ text "bar"+        r `shouldBe` errors+          [ FitBadFileContents (p </> "foo") $+              FitBadText "bar" "foo"+          ]++    it "tests text file contents specified with the quasiquoter" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") "foo"+        r <- fit p $ do+          file "foo"+            & contents ?~ [dedent|+                foo+                bar+                |]+        r `shouldBe` errors+          [ FitBadFileContents (p </> "foo") $+              FitBadText "foo\nbar\n" "foo"+          ]++    it "tests binary file existence" $ do+      temporary $ \p -> do+        r <- fit p $ do+          file "foo"+            & contents ?~ binary (ByteString.pack [1, 2, 3, 4])+        r `shouldBe` errors [FitIOException (p </> "foo") doesNotExistErrorType]++    it "tests binary file contents" $ do+      temporary $ \p -> do+        ByteString.writeFile (p </> "foo") (ByteString.pack [5, 6, 7, 8])+        r <- fit p $ do+          file "foo"+            & contents ?~ binary (ByteString.pack [1, 2, 3, 4])+        r `shouldBe` errors+         [ FitBadFileContents (p </> "foo") $+             FitBadBinary (ByteString.pack [1, 2, 3, 4]) (ByteString.pack [5, 6, 7, 8])+         ]++    it "tests copy file contents" $ do+      temporary $ \p -> do+        ByteString.writeFile (p </> "foo") (ByteString.pack [1, 2, 3, 4])+        ByteString.writeFile (p </> "bar") (ByteString.pack [5, 6, 7, 8])+        r <- fit p $ do+          file "foo"+            & contents ?~ copyOf (p </> "bar")+        r `shouldBe` errors+          [ FitBadFileContents (p </> "foo") $+              FitBadCopyOf (p </> "bar")+          ]++    it "tests copy file contents" $ do+      temporary $ \p -> do+        ByteString.writeFile (p </> "foo") (ByteString.pack [1, 2, 3, 4])+        ByteString.writeFile (p </> "bar") (ByteString.pack [1, 2, 3, 4])+        r <- fit p $ do+          file "foo"+            & contents ?~ copyOf (p </> "bar")+        r `shouldBe` errors []++    it "tests symbolic link existence" $ do+      temporary $ \p -> do+        r <- fit p $ do+          symlink "foo" "bar"+        r `shouldBe` errors [FitIOException (p </> "foo") doesNotExistErrorType]++    it "tests symbolic link source" $ do+      temporary $ \p -> do+        Posix.createSymbolicLink "baz" (p </> "foo")+        r <- fit p $ do+          symlink "foo" "bar"+        r `shouldBe` errors [FitBadLinkSource (p </> "foo") "bar" "baz"]++    it "combines multiple errors on one layer" $ do+      temporary $ \p -> do+        writeFile (p </> "bar") "qux"+        r <- fit p $ do+          file "foo"+          file "bar"+            & contents ?~ text "quux"+          file "baz"+        r `shouldBe` errors+          [ FitIOException (p </> "foo") doesNotExistErrorType+          , FitBadFileContents (p </> "bar") $+              FitBadText "quux" "qux"+          , FitIOException (p </> "baz") doesNotExistErrorType+          ]++    it "combines multiple errors on multiple layers" $ do+      temporary $ \p -> do+        createDirectoryIfMissing True (p </> "xyz" </> "xyzzy")+        writeFile (p </> "xyz" </> "xyzzy" </> "bar") "qux"+        r <- fit p $ do+          dirs ["xyz", "xyzzy"] $ do+            file "foo"+            file "bar"+              & contents ?~ text "quux"+          dir "boo" $+            file "hoo"+        r `shouldBe` errors+          [ FitIOException (p </> "xyz" </> "xyzzy" </> "foo") doesNotExistErrorType+          , FitBadFileContents (p </> "xyz" </> "xyzzy" </> "bar") $+              FitBadText "quux" "qux"+          , FitIOException (p </> "boo") doesNotExistErrorType+          , FitIOException (p </> "boo" </> "hoo") doesNotExistErrorType+          ]++    it "tests file owner user id" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") ""+        r <- fit p $ do+          file "foo"+            & user ?~ uid 0+        r `shouldBe` errors [FitBadOwnerUser (p </> "foo") (uid 0) (uid 1000)]++    it "tests file owner user name" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") ""+        n <- Posix.getEffectiveUserName+        r <- fit p $ do+          file "foo"+            & user ?~ username "root"+        r `shouldBe` errors [FitBadOwnerUser (p </> "foo") (username "root") (username n)]++    it "tests file owner group id" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") ""+        r <- fit p $ do+          file "foo"+            & group ?~ gid 0+        r `shouldBe` errors [FitBadOwnerGroup (p </> "foo") (gid 0) (gid 1000)]++    it "tests file owner group id" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") ""+        n <- Posix.getEffectiveUserName+        r <- fit p $ do+          file "foo"+            & group ?~ groupname "root"+        r `shouldBe` errors [FitBadOwnerGroup (p </> "foo") (groupname "root") (groupname n)]++    it "tests file permissions" $ do+      temporary $ \p -> do+        writeFile (p </> "foo") ""+        Posix.setFileMode (p </> "foo") 0o100644+        r <- fit p $ do+          file "foo"+            & mode ?~ 0o100777+        r `shouldBe` errors [FitBadFileMode (p </> "foo") 0o100777 0o100644]++    it "tests symbolic link's source exists" $ do+      temporary $ \p -> do+        let l = symlink "boo" "hoo"+        Posix.createSymbolicLink "hoo" (p </> "boo")+        fit p l `shouldReturn` errors []+        fit p (l & exists .~ True) `shouldReturn` errors [FitIOException (p </> "boo") doesNotExistErrorType]+        writeFile (p </> "hoo") ""+        fit p (l & exists .~ True) `shouldReturn` errors []++  describe "make" $ do+    -- examples use 'fit' because if the above spec passes then+    -- we can be reasonably sure 'fit' works as expected+    it "creates a file" $+      makefit $+        file "foo"++    it "creates a file with the specified text" $ do+      makefit $+        file "foo"+          & contents ?~ text "bar"++    it "creates a copy of the file with the specified text" $ do+      temporary $ \p -> do+        writeFile (p </> "qux") "quux"+        makefit $+          file "foo"+            & contents ?~ copyOf (p </> "qux")++    it "creates two files with the specified text" $ do+      makefit $ do+        file "foo"+          & contents ?~ text "bar"+        file "qux"+          & contents ?~ text "quux"++    it "creates two files and a symlink" $ do+      makefit $ do+        file "foo"+          & contents ?~ text "bar"+        file "qux"+          & contents ?~ text "quux"+        symlink "boo" "hoo"++    it "creates a directory with a file" $ do+      makefit $+        dir "foo" $+          file "bar"++    it "creates a directory with two files" $ do+      makefit $+        dir "foo" $ do+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+          file "quux"+            & contents ?~ binary (ByteString.pack [98, 121, 101])++    it "creates a nested directory with two files" $ do+      makefit $+        dirs ["foo", "bar"] $ do+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+          file "quux"+            & contents ?~ binary (ByteString.pack [98, 121, 101])++    it "creates a nested directory with two files and a directory" $ do+      makefit $+        dirs ["foo", "bar"] $ do+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+          file "quux"+            & contents ?~ binary (ByteString.pack [98, 121, 101])++    it "creates a tree of directories with files" $ do+      makefit $+        dir "foo" $ do+          dir "bar" $ do+            file "qux"+              & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+            file "quux"+              & contents ?~ binary (ByteString.pack [98, 121, 101])+          dir "baz" $+            symlink "boo" "hoo"++    it "changes the user id of the file owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+            & user ?~ uid 0+        r `shouldBe` errors [MakeIOException (p </> "qux") permissionErrorType]++    it "changes the user id of the symbolic link owner" $ do+      temporary $ \p -> do+        r <- make p $+          symlink "foo" "bar"+            & user ?~ uid 0+        r `shouldBe` errors [MakeIOException (p </> "foo") permissionErrorType]++    it "changes the user name of the file owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+            & user ?~ username "root"+        r `shouldBe` errors [MakeIOException (p </> "qux") permissionErrorType]++    it "changes the user name of the symbolic link owner" $ do+      temporary $ \p -> do+        r <- make p $+          symlink "foo" "bar"+            & user ?~ username "root"+        r `shouldBe` errors [MakeIOException (p </> "foo") permissionErrorType]++    it "changes the user id of the directory owner" $ do+      temporary $ \p -> do+        r <- make p $+          emptydir "boo"+            & user ?~ uid 0+        r `shouldBe` errors [MakeIOException (p </> "boo") permissionErrorType]++    it "changes the user name of the directory owner" $ do+      temporary $ \p -> do+        r <- make p $+          emptydir "boo"+            & user ?~ username "root"+        r `shouldBe` errors [MakeIOException (p </> "boo") permissionErrorType]++    it "changes the group id of the file owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+            & group ?~ gid 0+        r `shouldBe` errors [MakeIOException (p </> "qux") permissionErrorType]++    it "changes the group name of the file owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+            & group ?~ groupname "root"+        r `shouldBe` errors [MakeIOException (p </> "qux") permissionErrorType]++    it "changes the group id of the symbolic link owner" $ do+      temporary $ \p -> do+        r <- make p $+          symlink "foo" "bar"+            & group ?~ gid 0+        r `shouldBe` errors [MakeIOException (p </> "foo") permissionErrorType]++    it "changes the group name of the symbolic link owner" $ do+      temporary $ \p -> do+        r <- make p $+          symlink "foo" "bar"+            & group ?~ groupname "root"+        r `shouldBe` errors [MakeIOException (p </> "foo") permissionErrorType]++    it "changes the group id of the directory owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "boo"+            & group ?~ gid 0+        r `shouldBe` errors [MakeIOException (p </> "boo") permissionErrorType]++    it "changes the group name of the directory owner" $ do+      temporary $ \p -> do+        r <- make p $+          file "boo"+            & group ?~ groupname "root"+        r `shouldBe` errors [MakeIOException (p </> "boo") permissionErrorType]++    it "changes the file permissions" $ do+      makefit $+        file "qux"+          & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+          & mode ?~ 0o100777++    it "changes the directory permissions" $ do+      makefit $+        emptydir "boo"+          & mode ?~ 0o040777++    it "tolerates redundant directories" $ do+      makefit $ do+        dir "foo" $+          file "qux"+            & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+        dir "foo" $+          file "quux"+            & contents ?~ binary (ByteString.pack [98, 121, 101])++    it "the latter write wins" $ do+      temporary $ \p -> do+        let l = do+              dir "foo" $+                file "qux"+                  & contents ?~ binary (ByteString.pack [104, 101, 108, 108, 111])+              dir "foo" $+                file "qux"+                  & contents ?~ binary (ByteString.pack [98, 121, 101])+        _ <- make p l+        fit p l `shouldReturn` errors+          [ FitBadFileContents (p </> "foo" </> "qux") $ FitBadBinary+              (ByteString.pack [104, 101, 108, 108, 111])+              (ByteString.pack [98, 121, 101])+          ]++tonel :: a -> Validation (NonEmpty a) b+tonel = Error . pure++makefit :: Layout a -> IO ()+makefit l = temporary $ \p -> do+  make p l `shouldReturn` errors []+  fit p l `shouldReturn` errors []

@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module System.Directory.LayoutSpec+  ( spec+  ) where++import           Control.Lens+import           Test.Hspec++import           System.Directory.Layout hiding (spec)+import qualified System.Directory.Layout.Interpreter as L+++spec :: Spec+spec = do+  describe "directory-layout project structure" $ do+    rel L.spec project++project :: Layout ()+project = do+  dir "src" $ do+    dirs ["System", "Directory"] $ do+      dir "Layout" $ do+        file "Internal.hs"+        file "Interpreter.hs"+      file "Layout.hs"+  dir "test" $ do+    dirs ["System", "Directory"] $ do+      dir "Layout" $ do+        file "InternalSpec.hs"+        file "InterpreterSpec.hs"+      file "LayoutSpec.hs"+    file "Spec.hs"+      & contents ?~ [dedent|+        {-# OPTIONS_GHC -F -pgmF hspec-discover #-}+        |]+    file "SpecHelper.hs"+  file "LICENSE"+  file "Guardfile"+  file "Setup.hs"+  file "directory-layout.cabal"++rel :: (FilePath -> Layout a -> b) -> Layout a -> b+rel f = f "."

@@ -1,62 +0,0 @@-module Main where--import Control.Monad ((>=>))-import Data.Semigroup ((<>))-import System.Directory.Layout-import Test.Hspec---main :: IO ()-main = hspec $ do-  describe "basic equalities" $ do-    it "is sane" $ do-      layout_0 == layout_1  `shouldBe` False-      layout_1 == layout_1' `shouldBe` True-  describe "indentity monad laws" $ do-    it "holds for layout 0" $ do-      (layout_0 >>= return) `shouldBe` layout_0-      (return () >>= \() -> layout_0) `shouldBe` layout_0-    it "holds for layout 1" $ do-      (layout_1 >>= return) `shouldBe` layout_1-      (return () >>= \() -> layout_1) `shouldBe` layout_1-  describe "associativity monad law" $ do-    it "holds for layouts 2 and 3" $ do-      layout_2 (>>) `shouldBe` layout_3 (>>)-    it "holds for layouts 4 and 5" $ do-      layout_4 () `shouldBe` layout_5 ()-  describe "associativity semigroup law" $ do-    it "holds for layouts 2 and 3" $ do-      layout_2 (<>) `shouldBe` layout_3 (<>)---layout_0, layout_1, layout_1' :: Layout-layout_0 = do-  file_ "foo"-  file_ "bar"-  file_ "baz"-layout_1 = do-  file_ "foo"-  file_ "bar"-  directory "quux" $ do-    file_ "zem"-    file_ "zek"-  file_ "baz"-layout_1' = do-  file_ "foo"-  file_ "bar"-  directory "quux" $ do-    file_ "zek"-    file_ "zem"-  file_ "baz"--layout_2, layout_3 :: (Layout -> Layout -> Layout) -> Layout-layout_2 (#) =-  (file_ "foo" # file_ "bar") # file_ "baz"-layout_3 (#) =-  file_ "foo" # (file_ "bar" # file_ "baz")--layout_4, layout_5 :: () -> Layout-layout_4 =-  (const (file_ "foo") >=> const (file_ "bar")) >=> const (file_ "baz")-layout_5 =-  const (file_ "foo") >=> (const (file_ "bar") >=> const (file_ "baz"))

@@ -1,144 +0,0 @@-{-# 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" []

@@ -1,12 +0,0 @@-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"]