directory-layout (empty) → 0.1.0.0

raw patch · 8 files changed

+481/−0 lines, 8 filesdep +basedep +directorydep +filepathsetup-changed

Dependencies added: base, directory, filepath, parsec, text, transformers

Files

LICENSE +19/−0
Setup.hs +4/−0
directory-layout.cabal +31/−0
src/System/Directory/Layout.hs +38/−0
src/System/Directory/Layout/Check.hs +126/−0
src/System/Directory/Layout/Internal.hs +32/−0
src/System/Directory/Layout/Make.hs +127/−0
src/System/Directory/Layout/Parser.hs +104/−0

+ LICENSE view

@@ -0,0 +1,19 @@+Copyright (C) 2012 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:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++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.

+ Setup.hs view

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

+ directory-layout.cabal view

@@ -0,0 +1,31 @@+name:          directory-layout+version:       0.1.0.0+synopsis:      Declare, construct and verify directory layout+description:   Friendly 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.8++library+  exposed-modules: System.Directory.Layout+                   System.Directory.Layout.Check+                   System.Directory.Layout.Make+                   System.Directory.Layout.Parser+                   System.Directory.Layout.Internal+  hs-source-dirs: src+  build-depends: base >= 3 && < 5,+                 directory,+                 filepath,+                 transformers,+                 parsec,+                 text+  ghc-options: -Wall+               -fno-warn-unused-do-bind++source-repository head+  type: git+  location: https://github.com/supki/directory-layout

+ src/System/Directory/Layout.hs view

@@ -0,0 +1,38 @@+{-# LANGUAGE UnicodeSyntax #-}+module System.Directory.Layout+  ( -- * Layout declaration+    DL, Layout, file, file_, directory, directory_+    -- * Layout construction+  , DLMakeWarning(..), make+    -- * Layout verification+  , DLCheckFailure(..), check+    -- * Layout parsers+  , layout, layout'+  ) where++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')+++-- | Declare file with specified contents+file ∷ FilePath → Text → Layout+file x c = F x (Just c) (return ())+++-- | Declare empty file+file_ ∷ FilePath → Layout+file_ x = F x Nothing (return ())+++-- | Declare directory with specified listing+directory ∷ FilePath → Layout → Layout+directory x d = D x d (return ())+++-- | Declare empty directory+directory_ ∷ FilePath → Layout+directory_ x = D x (return ()) (return ())

+ src/System/Directory/Layout/Check.hs view

@@ -0,0 +1,126 @@+{-# 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

+ src/System/Directory/Layout/Internal.hs view

@@ -0,0 +1,32 @@+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK hide #-}+module System.Directory.Layout.Internal+  ( DL(..), Layout+  ) where++import Data.Text (Text)+++-- | 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)+++-- | But type synonym is nicer+type Layout = DL ()+++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)+++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)

+ src/System/Directory/Layout/Make.hs view

@@ -0,0 +1,127 @@+{-# 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

+ src/System/Directory/Layout/Parser.hs view

@@ -0,0 +1,104 @@+{-# 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'