definitive-filesystem (empty) → 1.2

raw patch · 3 files changed

+223/−0 lines, 3 filesdep +arraydep +basedep +bytestring

Dependencies added: array, base, bytestring, clock, containers, deepseq, definitive-base, definitive-reactive, directory, filepath, old-locale, primitive, time, unix, vector

Files

• IO/Filesystem.hs +161/−0
• LICENSE +39/−0
• definitive-filesystem.cabal +23/−0

@@ -0,0 +1,161 @@+{-# LANGUAGE RankNTypes, ImplicitParams, LambdaCase #-}+module IO.Filesystem (+  -- * Exported modules+  module System.FilePath,module Definitive,++  -- * The File interface+  File(..),DirEntry(..),+  getFile,+  +  workingDirectory,+  Location(..),+  pathTo,getConfig,++  -- ** A useful monad for manipulating the filesystem as a state+  FS(..),Filesystem,file,+  +  -- ** Status+  modTime,+  +  -- ** Useful Lenses+  contents,children,child,descendant,subEntry,anyEntry,entryName,entryFile,+  named,withExtension,+  fileName,entry,text,bytes+  ) where++import Definitive+import Control.DeepSeq+import IO.Time+import System.Directory +import System.FilePath ((</>),FilePath)+import System.IO.Unsafe+import System.Posix.Process (getProcessID)+import Data.Time.Clock.POSIX+import qualified Prelude as P++data File = File (Maybe String) (Maybe Bytes)+          | Directory (Map String File) +instance Show File where+  show (File _ _) = "File"+  show (Directory d) = show d+instance Semigroup File where+  Directory d + Directory d' = Directory ((d*d')+(d+d'))+  a + _ = a+instance Monoid File where zero = File zero zero++data DirEntry = DirEntry FilePath File+              deriving Show+instance Lens1 String String DirEntry DirEntry where+  l'1 = from _DirEntry.l'1+instance Lens2 File File DirEntry DirEntry where+  l'2 = from _DirEntry.l'2+fileName :: Lens' DirEntry String+fileName = l'1+entry :: Lens' DirEntry File+entry = l'2++il :: IO a -> IO a+il = unsafeInterleaveIO+getFile :: FilePath -> IO File+getFile path = do+  d <- doesDirectoryExist path+  if d then do+    files <- unsafeInterleaveIO (getDirectoryContents path)+    return $ Directory $ fromList [+      (name,unsafePerformIO (getFile (path</>name)))+      | name <- files, not (name`elem`[".",".."])]+    else File<$>il (tryMay $ force<$>P.readFile path)+         <*>il (tryMay $ readBytes path)++_File :: ((Maybe String,Maybe Bytes):+:Map String File) :<->: File+_File = iso f' f+  where f (File x y) = Left (x,y)+        f (Directory d) = Right d+        f' = uncurry File <|> Directory+_DirEntry :: (FilePath,File) :<->: DirEntry+_DirEntry = iso (uncurry DirEntry) (\ ~(DirEntry p f) -> (p,f))+contents :: Traversal' File (Maybe String,Maybe Bytes)+contents = from _File.t'l+children :: Traversal' File (Map String File)+children = from _File.t'r+child :: Traversal' File File+child = children.traverse+descendant :: Fold' File File+descendant = id .+ child.descendant+subEntry :: Traversal' DirEntry DirEntry+subEntry = entryFile.children.keyed.traverse._DirEntry+anyEntry :: Fold' DirEntry DirEntry+anyEntry = id .+ subEntry.anyEntry+entryName :: Lens' DirEntry String+entryName = from _DirEntry.l'1+entryFile :: Lens' DirEntry File+entryFile = from _DirEntry.l'2+text :: Traversal' File String+text = contents.lens fst (const (,zero)).folded+bytes :: Traversal' File Bytes+bytes = contents.l'2.folded++named :: (String -> Bool) -> Traversal' DirEntry DirEntry+named p = sat (\(DirEntry name _) -> p name)+withExtension :: String -> Traversal' DirEntry DirEntry+withExtension e = named (\s -> drop (length s-(length e+1)) s==('.':e))++-- |The working directory, as a DirEntry+workingDirectory :: IO DirEntry+workingDirectory = DirEntry "." <$> (getFile =<< getCurrentDirectory)++modTime :: FilePath -> IO (TimeVal Seconds)+modTime p = try (return minBound) (getModificationTime p <&> pure . realToFrac . utcTimeToPOSIXSeconds)++data Location = Here | Cache | Owner | System++pathTo :: ( ?progName :: FilePath ) => Location -> FilePath+pathTo Here = getCurrentDirectory^.thunk+pathTo Cache = (getTemporaryDirectory^.thunk) </> ?progName + "-" + show (getProcessID^.thunk) +pathTo Owner = getHomeDirectory^.thunk </> "." + ?progName+pathTo System = "/usr/share" </> ?progName++getConfig :: ( ?progName :: FilePath ) => IO File+getConfig = sum<$>sequence [getFile (pathTo d) | d <- [Owner,System]]++instance NFData File where+  rnf (File _ (Just b)) = rnf b+  rnf (File (Just a) _) = rnf a+  rnf (Directory d) = rnf d+  rnf _ = ()++{-|+The FS monad is a wrapper around the IO monad that provides a+MonadState instance for interacting with the filesystem through the+Filesystem type.++Thus, you may use lenses to access the representation of files as+though they were variables, like so :++> runFS $ (file "x.bmp".bytes.serial.from bmp) fs ^>= \r ->+>     file "foo".bytes.serial.from jpg =- r++-}+newtype FS a = FS { runFS :: IO a }+               deriving (Functor,Unit,Applicative,Monad,MonadFix)+instance MonadState Filesystem FS where+  get = FS (return zero)+  put (Filesystem fs) = FS $ fs`deepseq`for_ (fs^.keyed) $ \(k,f) -> remove k >> putFile k f+    where putFile k (File _ (Just b)) = writeBytes k b+          putFile k (File (Just s) _) = P.writeFile k s+          putFile _ (File _ _) = unit+          putFile k (Directory d) = for_ (d^.keyed) $ \(k',f) -> putFile (k+k') f+          remove f = doesDirectoryExist f >>= \case+            True -> getDirectoryContents f >>= \c -> traverse_ (remove . (f+)) ([]+refuse (`elem`[".",".."]) c)+                                                     >> removeDirectory f+            False -> try unit (removeFile f)+  +newtype Filesystem = Filesystem (Map String File)+                   deriving (Semigroup,Monoid)+instance DataMap Filesystem String File where+  at k = lens f g+    where f (Filesystem m) = Just $ fromMaybe (getFile k^.thunk) $ m^.at k+          g (Filesystem m) x = Filesystem (insert k (fold x) m)++file :: String -> Lens' Filesystem File+file f = at f.folded

@@ -0,0 +1,39 @@+THE FREE BEER PUBLIC LICENSE+--------++The Free Beer Public License is designed to provide free (as in beer,+hence the name), unlimited access to any content for anyone who wishes+it, without restrictions such as property rights or affordability.++This license embodies the philosophy that all software (and more+generally all good ideas) is designed to solve a particular problem,+and that the only way to judge its quality is by how well it solves+that problem, rather than other unrelated criteria such as sellability+or merchandability.++All kinds of works may be licensed under the FBPL, as long as the+aforementioned works are within the legal rights of the provider to+give.++TERMS AND CONDITIONS+--------------------++### 1. Free as in Beer++The provider of this work shall make it available, free of any charge,+monetary or otherwise, to the consumer, to use without restrictions or+any kind of supervision.++### 2. Freely taken is freely given++The consumer of this work may redistribute it as well as derived works+in any way he or she chooses, as long as the work itself and any+derived work remain Free as in Beer, as per the first clause.++### 3. The Burden of Proof++The provider of this work shall also supply explanations for how the+work was realized if requested, in the form of source code for example, or+supply the means to access such explanations.++Every such explanation shall be Free as in Beer, as per the first clause.

@@ -0,0 +1,23 @@+-- content information+name:          definitive-filesystem+category:      Filesystem+synopsis:      A library that enable you to interact with the filesystem in a definitive way.+description:   ++-- meta-information+author:        Marc Coiffier+maintainer:    marc.coiffier@gmail.com+version:       1.2+license:       OtherLicense+license-file:  LICENSE++-- build information+build-type:    Simple+cabal-version: >=1.10++library+  exposed-modules: IO.Filesystem+  build-depends: base (== 4.6.*), definitive-base (== 1.2.*), containers (== 0.5.*), deepseq (== 1.3.*), array (== 0.5.*), bytestring (== 0.10.*), vector (== 0.10.*), primitive (== 0.5.*), definitive-reactive (== 1.0.*), clock (== 0.4.*), directory (== 1.2.*), filepath (== 1.3.*), time (== 1.4.*), old-locale (== 1.0.*), unix (== 2.7.*)+  default-extensions: TypeSynonymInstances NoMonomorphismRestriction StandaloneDeriving GeneralizedNewtypeDeriving TypeOperators RebindableSyntax FlexibleInstances FlexibleContexts FunctionalDependencies TupleSections MultiParamTypeClasses Rank2Types+  ghc-options: -Wall -fno-warn-orphans -threaded+  default-language: Haskell2010