directory-layout 0.3.1.0 → 0.4.0.0

raw patch · 5 files changed

+319/−86 lines, 5 filesdep +hspecdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: hspec

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• directory-layout.cabal +51/−31
• src/System/Directory/Layout.hs +38/−4
• src/System/Directory/Layout/Internal.hs +76/−34
• src/System/Directory/Layout/Lens.hs +92/−17
• tests/Hspec.hs +62/−0

@@ -1,5 +1,5 @@ name:          directory-layout-version:       0.3.1.0+version:       0.4.0.0 synopsis:      Declare, construct and verify directory layout description:   Language to express directory layouts category:      System@@ -12,47 +12,67 @@  library   default-language: Haskell2010-  exposed-modules: System.Directory.Layout-                   System.Directory.Layout.Internal-                   System.Directory.Layout.Errored-                   System.Directory.Layout.Traverse-                   System.Directory.Layout.Lens+  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 >= 3 && < 5,-                 directory,-                 filepath,-                 mtl,-                 data-default,-                 semigroups,-                 semigroupoids,-                 lens,-                 text-  ghc-options: -Wall-               -fno-warn-unused-do-bind+  build-depends:+    base >= 4 && < 5,+    data-default,+    directory,+    filepath,+    lens,+    mtl,+    semigroupoids,+    semigroups,+    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+  build-depends:+    base >= 3 && < 5,+    directory-layout,+    HUnit,+    process,+    QuickCheck   main-is: tests/Main.hs-  ghc-options: -Wall-               -fno-warn-unused-do-bind+  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+  build-depends:+    base >= 3 && < 5,+    directory-layout,+    doctest,+    lens,+    wordexp   main-is: tests/doctests.hs-  ghc-options: -Wall-               -fno-warn-unused-do-bind+  ghc-options:+    -Wall+    -fno-warn-unused-do-bind++test-suite layout-laws+  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

@@ -1,17 +1,26 @@ -- | Language to express directory layouts module System.Directory.Layout   ( -- * Layout declaration-    DL, Layout, file, file_, directory, directory_+    Node, Layout, file, file_, directory, directory_+    -- * Layout construction+  , fromDirectory     -- * Layout traverses   , make, check     -- * Errors   , LayoutException(..)   ) where -import Data.Default (def)-import Data.Text (Text)+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 (DL(..), Layout)+import System.Directory.Layout.Internal (Node(..), Layout) import System.Directory.Layout.Traverse (make, check) import System.Directory.Layout.Errored (LayoutException(..)) @@ -38,3 +47,28 @@ 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

@@ -1,12 +1,13 @@ -- | Free monad based directory layouts module System.Directory.Layout.Internal-  ( DL(..), Layout+  ( Node(..), Layout   ) where  import Control.Applicative (Applicative(..), (<$>)) import Data.Foldable (Foldable(..)) import Data.Traversable (Traversable(..), fmapDefault, foldMapDefault) import Data.Monoid (Monoid(..))+import Unsafe.Coerce (unsafeCoerce)  import Data.Default (Default(..)) import Data.Functor.Apply (Apply(..))@@ -16,10 +17,10 @@   -- | Type synonym to save some acrobatics-type Layout = DL ()+type Layout = Node ()  --- | Representation of directory layouts+-- | A representation of directory layouts -- -- Invariants: --@@ -30,72 +31,113 @@ --  * '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+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) -instance Default a => Default (DL a) where+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 #-}++instance Default a => Default (Node 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)+instance Semigroup (Node a) where+  (<>) = (>>)   {-# INLINE (<>) #-} -instance Default a => Monoid (DL a) where+instance Default a => Monoid (Node a) where   mempty = def   {-# INLINE mempty #-}    mappend = (<>)   {-# INLINE mappend #-} -instance Functor DL where+instance Functor Node where   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)+instance Apply Node where+  f <.> x =+    f >>- \f' ->+    x >>- \x' ->+    pure (f' x')   {-# INLINE (<.>) #-} -instance Applicative DL where+instance Applicative Node 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)+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 (>>-) #-} -instance Monad DL where+(>>*) :: 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 (>>*) #-}++-- | All this crazy stuff is only to get do-notation basically.+--+-- 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 #-} +  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 (>>) #-}+   (>>=) = (>>-)   {-# INLINE (>>=) #-} -instance Foldable DL where+instance Foldable Node where   foldMap = foldMapDefault   {-# INLINE foldMap #-} -instance Traversable DL where+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

@@ -1,27 +1,28 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}--- | "Control.Lens" based extractors for 'DL'+-- | "Control.Lens" based extractors for 'Layout' module System.Directory.Layout.Lens-  ( -- $setup-    text, file, directory+  ( -- * Usage+    -- $setup+    text, name, names, next, file, directory, node   ) where -import Control.Applicative (pure)+import Control.Applicative ((<$>), (<*>), pure)  import Control.Lens import Data.Text (Text) -import System.Directory.Layout.Internal (DL(..), Layout)+import System.Directory.Layout.Internal (Node(..), Layout)   -- $setup -- -- >>> :set -XOverloadedStrings--- >>> import           Control.Lens+-- >>> 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)+-- | Target 'Text' from the current 'Layout' top (if possible) -- -- >>> layout ^? text -- Nothing@@ -29,15 +30,71 @@ -- Just "not empty" -- >>> layout ^? directory "bar" . file "quux" . text -- Just "something"-text :: Prism Layout Layout Text Text+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 #-} --- | Look into the file in the current 'Layout' (if possible)+-- | 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"@@ -51,13 +108,11 @@   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 #-}+    | otherwise = go x <&> \x' -> F k' l x'+  go (D n l x)  = go x <&> \x' -> D n l x' {-# INLINE file #-} ---- | Go into the directory in the current 'Layout' (if possible)+-- | Target 'Layout' under the current 'Layout' top if it happens to be a directory -- -- >>> layout ^? directory "foo" -- Nothing@@ -68,9 +123,29 @@  where   go (E x)      = pure (E x)   go (T t x)    = pure (T t x)-  go (F _ _ x)  = go 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-  {-# INLINE go #-}+    | 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,62 @@+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"))