system-lifted (empty) → 0.2.0.1
raw patch · 9 files changed
+626/−0 lines, 9 filesdep +basedep +directorydep +eithersetup-changed
Dependencies added: base, directory, either, haskell-src-meta, template-haskell, text, time, transformers, unix
Files
- LICENSE +30/−0
- README.md +35/−0
- Setup.hs +2/−0
- example/main.hs +56/−0
- src/System/Directory/Lifted.hs +92/−0
- src/System/Environment/Lifted.hs +56/−0
- src/System/Lifted.hs +240/−0
- src/System/Posix/User/Lifted.hs +52/−0
- system-lifted.cabal +63/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, João Cristóvão++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * 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 João Cristóvão 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.
+ README.md view
@@ -0,0 +1,35 @@+system-lifted+=============++Lifted versions of Haskell System functions.++While haskell promotes the use of ```Maybe``` and ```Either``` as smart ways of dealing with errors, I found that the +support for their Monad Transformers counter-parts is less than stellar.++While some packages like [Errors](http://hackage.haskell.org/package/errors-1.4.5/docs/Control-Error-Util.html) simplify+this, they still add a lot of boilerplate to the code.++The goal of this project started out as a way to write cleaner directory related code in either one of the _error related_+monad transformers, namely ```EitherT```, ```ErrorT``` or ```MaybeT``` (non-determinism and ```ListT``` are not yet supported). ++This is achieved through typeclasses, and thus, by simply declaring some simple _template haskell_ at the start of a file:++```+type EitherIOText = EitherT Text++deriveSystemLiftedErrors "DisallowIOE [HardwareFault]" ''EitherIOText+deriveSystemDirectory ''EitherIOText+```++One could then write code like this:++```+getXdgConfigFolder :: EitherT IOException IO FilePath+getXdgConfigFolder = isRW =<< getEnv "XDG_CONFIG_HOME"+```++Currently the ```System.Directory``` and ```System.Environment``` are fully supported, and there is partial support for ```System.Unix.Users```.++More examples and wider ```System.``` support is planned. Contribuitions are welcomed.++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/main.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import System.Lifted+import System.Directory.Lifted+import qualified System.Directory as D++import Control.Monad.Trans.Either+import Control.Monad.Trans.Maybe+import Control.Applicative++import qualified Data.Text as T+import qualified Data.Text.IO as T+import GHC.IO.Exception++type EitherString = EitherT String++deriveSystemLiftedErrors "DisallowIOE [HardwareFault]" ''MaybeT+deriveSystemLiftedErrors "AllIOE" ''EitherString+deriveSystemDirectory ''MaybeT+deriveSystemDirectory ''EitherString++main :: IO ()+main = do+ m <- runMaybeT $ createDirectory "abc"+ r <- runEitherT $ bimapEitherT T.pack id $ do+ createDirectory "cde"+ createDirectory "cdd"+ print m+ case r of+ Left s -> T.putStrLn s+ Right _ -> putStrLn "OK"++ j <- runEitherT $ ioFilterT (DisallowIOE [HardwareFault]) $ do+ D.createDirectory "ajj"+ D.createDirectory "aji"+ case j of+ Left s -> Prelude.putStrLn s+ Right _ -> putStrLn "OK!"+ print j++ x <- runMaybeT $ joinMaybeMT (findFile ["."] "LICENSE")+ <|> getHomeDirectory+ print x++ putStrLn "end"++
+ src/System/Directory/Lifted.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}++module System.Directory.Lifted+ ( SystemDirectory (..)+ , Permissions (..)+ , deriveSystemDirectory+ ) where++import System.Lifted+import qualified System.Directory as D+import System.Directory (Permissions(..))+import Data.Time.Clock++import Language.Haskell.TH++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.:) = (.).(.)++-- | System.Directory as a Class.+-- Instances for MaybeT and EitherT (String|Text|IOException|())+class SystemDirectory e where+ createDirectory :: FilePath -> e IO ()+ createDirectoryIfMissing :: Bool -> FilePath -> e IO ()+ removeDirectory :: FilePath -> e IO ()+ removeDirectoryRecursive :: FilePath -> e IO ()+ renameDirectory :: FilePath -> FilePath -> e IO ()+ getDirectoryContents :: FilePath -> e IO [FilePath]+ getCurrentDirectory :: e IO FilePath+ setCurrentDirectory :: FilePath -> e IO ()+ getHomeDirectory :: e IO FilePath+ getAppUserDataDirectory :: String -> e IO FilePath+ getUserDocumentsDirectory :: e IO FilePath+ getTemporaryDirectory :: e IO FilePath+ removeFile :: FilePath -> e IO ()+ renameFile :: FilePath -> FilePath -> e IO ()+ copyFile :: FilePath -> FilePath -> e IO ()+ canonicalizePath :: FilePath -> e IO FilePath+ makeRelativeToCurrentDirectory :: FilePath -> e IO FilePath+ -- this may deserve a special case...+ findExecutable :: String -> e IO (Maybe FilePath)+ findFile :: [FilePath] -> String -> e IO (Maybe FilePath)+ doesFileExist :: FilePath -> e IO Bool+ doesDirectoryExist :: FilePath -> e IO Bool+ getPermissions :: FilePath -> e IO Permissions+ setPermissions :: FilePath -> Permissions -> e IO ()+ copyPermissions :: FilePath -> FilePath -> e IO ()+ getModificationTime :: FilePath -> e IO UTCTime++deriveSystemDirectory :: Name -> DecsQ+deriveSystemDirectory tp = let+ nm = conT tp+ in [d|++ instance SystemDirectory $nm where+ createDirectory = ioT . D.createDirectory+ createDirectoryIfMissing = ioT .: D.createDirectoryIfMissing+ removeDirectory = ioT . D.removeDirectory+ removeDirectoryRecursive = ioT . D.removeDirectoryRecursive+ renameDirectory orig = ioT . D.renameDirectory orig+ getDirectoryContents = ioT . D.getDirectoryContents+ getCurrentDirectory = ioT D.getCurrentDirectory+ setCurrentDirectory = ioT . D.setCurrentDirectory+ getHomeDirectory = ioT D.getHomeDirectory+ getAppUserDataDirectory = ioT . D.getAppUserDataDirectory+ getUserDocumentsDirectory = ioT D.getUserDocumentsDirectory+ getTemporaryDirectory = ioT D.getTemporaryDirectory+ removeFile = ioT . D.removeFile+ renameFile = ioT .: D.renameFile+ copyFile = ioT .: D.copyFile+ canonicalizePath = ioT . D.canonicalizePath+ makeRelativeToCurrentDirectory = ioT . D.makeRelativeToCurrentDirectory+ findExecutable = ioT . D.findExecutable+ findFile = ioT .: D.findFile+ doesFileExist = ioT . D.doesFileExist+ doesDirectoryExist = ioT . D.doesDirectoryExist+ getPermissions = ioT . D.getPermissions+ setPermissions = ioT .: D.setPermissions+ copyPermissions = ioT .: D.copyPermissions+ getModificationTime = ioT . D.getModificationTime+ |]++
+ src/System/Environment/Lifted.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}++module System.Environment.Lifted (+ SystemEnvironment (..)+ , deriveSystemEnvironment+) where++import System.Lifted+import qualified System.Environment as E++import Language.Haskell.TH++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.:) = (.).(.)++-- | System.Environment as a Class.+-- Instances for MaybeT and EitherT (String|Text|IOException|())+class SystemEnvironment e where+ getArgs :: e IO [String]+ getProgName :: e IO String+ getExecutablePath :: e IO FilePath+ getEnv :: String -> e IO String+ -- special case?+ lookupEnv :: String -> e IO (Maybe String)+ withArgs :: [String] -> IO a -> e IO a+ withProgName :: String -> IO a -> e IO a+ getEnvironment :: e IO [(String, String)]+++deriveSystemEnvironment :: Name -> DecsQ+deriveSystemEnvironment tp = let+ nm = conT tp+ in [d|++ instance SystemEnvironment $nm where+ getArgs = ioT E.getArgs+ getProgName = ioT E.getProgName+ getExecutablePath = ioT E.getExecutablePath+ getEnv = ioT . E.getEnv+ lookupEnv = ioT . E.lookupEnv+ withArgs = ioT .: E.withArgs+ withProgName = ioT .: E.withProgName+ getEnvironment = ioT E.getEnvironment+ |]++
+ src/System/Lifted.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}++module System.Lifted (+ HandlerList (..)+ , IOT (..)+ , deriveSystemLiftedErrors+ , IOExceptionHandling (..)+ , joinMaybeMT+ , joinMMT+ , joinMaybeET+ , joinMET+ , joinMaybeErrT+ , joinMErrT+ , joinEitherET+ , joinEET+ , errorTtoEitherT+ , evalEither+ , evalEitherT+ , reportEither+ , reportEitherT+ {-, showStr-}+ {-, tshow-}+) where++import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable++import Data.Functor.Identity+import Control.Monad (join)+import Control.Monad.IO.Class+import Control.Monad.Trans.Identity+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Either+import Control.Monad.Trans.Error+++import GHC.IO.Exception+import System.IO.Error+import System.Exit+import Control.Exception++import Language.Haskell.TH+import Language.Haskell.Meta.Parse++-- | Convert an Either value to a Maybe value+--+-- This function is provided with a different name convention on+-- @Data.Either.Combinators@:+--+-- @+-- 'eitherToMaybe' = 'rightToMaybe'+-- @+--+eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe = either (const Nothing) Just++data IOExceptionHandling = AllowIOE [IOErrorType]+ | DisallowIOE [IOErrorType]+ | AllIOE+ deriving (Eq,Typeable)++instance Show IOExceptionHandling where+ show (AllowIOE _) = "AllIOE"+ show (DisallowIOE _) = "DisallowIOE"+ show AllIOE = "AllIOE"+++processIOExcepts :: IOExceptionHandling -> IOException -> IOException+processIOExcepts ioeh ioe =+ case ioeh of+ -- | Provided a list of IOExceptions to allow (reported as Left or Nothing),+ -- throw a IOException if not in this list (White Listing).+ AllowIOE lst -> if ioeGetErrorType ioe `elem` lst+ then ioe+ else throw ioe++ -- | Provided a list of IOExceptions to forbid, rethrow a IOException if+ -- mentioned in this list (Black Listing).+ DisallowIOE lst -> if ioeGetErrorType ioe `elem` lst+ then throw ioe+ else ioe++ -- | No exception filtering done, all reported as Left or Nothing+ AllIOE -> ioe++-- | Do not rethrow any IO Exception+{-allowIOExcepts :: [IOErrorType] -> IOException -> IOException-}+{-allowIOExcepts _ ioe = ioe-}++class HandlerList errs a where+ handlerList :: errs -> [Handler a]++instance HandlerList (IOException -> IOException) String where+ handlerList f = [Handler (\(e::IOException) -> return . show . f $ e)]++instance HandlerList (IOException -> IOException) () where+ handlerList f = [Handler (\(e::IOException) -> evaluate (f e) >> return ())]++instance HandlerList (IOException -> IOException) Text where+ handlerList f = [Handler (\(e::IOException) -> return . T.pack . show . f $ e)]++instance HandlerList (IOException -> IOException) IOException where+ handlerList f = [Handler (\(e::IOException) -> return . f $ e)]+++-- One possibility is to define it for MaybeT, and leave it open+-- to EitherT. Does it make sense to define it also for ListT?+-- But then [] would mean failure, wouldn't it?+-- [()] success?+{-handlerListIoUnit :: IOExceptionHandling -> [Handler ()]-}+{-handlerListIoUnit f = handlerList (processIOExcepts f)-}++class Tries a b c | c -> a b where+ tries :: [Handler a] -> IO b -> IO c++instance Tries () b (Identity b) where+ tries _ io = fmap Identity io++instance Tries a b (Either a b) where+ tries handlers io = fmap Right io+ `catch` catchesHandler handlers++instance Tries () b (Maybe b) where+ tries handlers io = fmap Just io+ `catch` (fmap eitherToMaybe . catchesHandler handlers)++catchesHandler :: [Handler a] -> SomeException -> IO (Either a b)+catchesHandler handlers e = foldr tryHandler (throw e) handlers+ where tryHandler (Handler handler) res =+ case fromException e of+ Just e' -> fmap Left (handler e')+ Nothing -> res++class ToT n t m a | t -> n where+ toT :: m (n a) -> t m a++instance ToT Maybe MaybeT IO a where+ toT = MaybeT++instance ToT (Either b) (EitherT b) IO a where+ toT = EitherT++instance ToT Identity IdentityT IO a where+ toT = IdentityT . fmap runIdentity++instance ToT (Either b) (ErrorT b) IO a where+ toT = ErrorT++class IOT t m a where+ ioT :: m a -> t m a+ ioFilterT :: IOExceptionHandling -> m a -> t m a++evalTHStr :: String -> Q Exp+evalTHStr = return . either (\_ -> error "Error in template haskell") id+ . parseExp++-- | The io handlers is passed as string due to TH peculiarities (and+-- my lack of TH knoledge, mainly).+deriveSystemLiftedErrors :: String -> Name -> DecsQ+deriveSystemLiftedErrors ioh tp = let+ nm = conT tp+ iohv = evalTHStr ioh+ in [d|+ instance IOT $nm IO a where+ ioT iof = toT $ tries (handlerList (processIOExcepts $iohv)) iof+ ioFilterT ioeh iof = toT $ tries (handlerList (processIOExcepts ioeh)) iof+ |]++joinMaybeMT, joinMMT :: MaybeT IO (Maybe a) -> MaybeT IO a+joinMMT = joinMaybeMT+joinMaybeMT mbt = do+ mb <- liftIO $ runMaybeT mbt+ MaybeT . return $ maybe Nothing (maybe Nothing Just) mb+++joinMaybeET, joinMET :: b -> EitherT b IO (Maybe a) -> EitherT b IO a+joinMET = joinMaybeET+joinMaybeET e mbt = do+ mb <- liftIO $ runEitherT mbt+ hoistEither $ either Left (maybe (Left e) Right) mb++joinEitherET, joinEET :: EitherT b IO (Either b a) -> EitherT b IO a+joinEET = joinEitherET+joinEitherET eit = hoistEither . join =<< (liftIO . runEitherT $ eit)++joinMaybeErrT, joinMErrT :: (Error b)+ => b -> ErrorT b IO (Maybe a) -> ErrorT b IO a+joinMErrT = joinMaybeErrT+joinMaybeErrT e mbt = do+ mb <- liftIO $ runErrorT mbt+ ErrorT . return $ either Left (maybe (Left e) Right) mb++errorTtoEitherT :: ErrorT a IO b -> EitherT a IO b+errorTtoEitherT = EitherT . runErrorT++-- | Evaluate an @Either IOException a@ to either raise the exception+-- or return the right value+evalEither :: Either IOException a -> IO a+evalEither ei = case ei of+ Left e -> throwIO e+ Right p -> return p++-- | Evaluate an @EitherT IOException IO a@ to either raise the exception+-- or return the right value+evalEitherT :: EitherT IOException IO a -> IO a+evalEitherT eit = runEitherT eit >>= evalEither++-- | Show a string like value (@String@ or @Text@) without the annoying quotes+showStr :: (IsString s, Show s) => s -> String+showStr = Prelude.init . Prelude.tail . show++-- | Show as text+{-tshow :: (Show s) => s -> Text-}+{-tshow = T.pack . show-}++-- | Either return the right value or print the error message in the @Left@ value+-- and exit+reportEither :: (IsString e, Show e) => Either e a -> IO a+reportEither ei = case ei of+ Left e -> (putStrLn . showStr $ e) >> exitFailure+ Right p -> return p++-- | Either return the right value or print the error message in the @Left@ value+-- and exit+reportEitherT :: (IsString e, Show e) => EitherT e IO a -> IO a+reportEitherT eit = runEitherT eit >>= reportEither++
+ src/System/Posix/User/Lifted.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}++-- | This module is incomplete, it does not map all System.Posix.User.+-- Feel free to complete it.+module System.Posix.User.Lifted+ ( SystemPosixUser (..)+ , deriveSystemPosixUser+ , U.UserEntry(..)+ ) where++import System.Lifted+import qualified System.Posix.User as U+import System.Posix.Types++import Language.Haskell.TH++(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(.:) = (.).(.)++-- | System.Posix.User as a Class.+-- Instances for MaybeT and EitherT (String|Text|IOException|())+class SystemPosixUser e where+ getRealUserID :: e IO UserID+ getRealGroupID :: e IO GroupID+ getEffectiveUserID :: e IO UserID+ getEffectiveGroupID :: e IO GroupID+ getUserEntryForID :: UserID -> e IO U.UserEntry++deriveSystemPosixUser :: Name -> DecsQ+deriveSystemPosixUser tp = let+ nm = conT tp+ in [d|++ instance SystemPosixUser $nm where+ getRealUserID = ioT U.getRealUserID+ getRealGroupID = ioT U.getRealGroupID+ getEffectiveUserID = ioT U.getEffectiveUserID+ getEffectiveGroupID = ioT U.getEffectiveGroupID+ getUserEntryForID = ioT . U.getUserEntryForID+ |]++
+ system-lifted.cabal view
@@ -0,0 +1,63 @@+name: system-lifted+version: 0.2.0.1+synopsis: Lifted versions of System functions.+description: Lifted versions of functions provided in System.Directory,+ System.Environment and others.+ User can derive instances for EitherT, ErrorT, MaybeT, etc.+homepage: https://github.com/jcristovao/system-lifted+license: BSD3+license-file: LICENSE+author: João Cristóvão+maintainer: jmacristovao@gmail.com+category: System+build-type: Simple++extra-source-files: README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.16+++library+ exposed-modules: System.Lifted+ System.Directory.Lifted+ System.Environment.Lifted+ System.Posix.User.Lifted+ + other-extensions: FlexibleInstances+ , FlexibleContexts+ , MultiParamTypeClasses+ , ScopedTypeVariables+ , FunctionalDependencies+ , OverlappingInstances+ , UndecidableInstances+ , TemplateHaskell+ + build-depends: base >=4.6 && < 5.0+ , text >=0.11.3 && < 1.4+ , transformers >=0.3 && < 0.5+ , either >=4.1 && < 4.4+ , template-haskell >=2.8 && < 2.10+ , haskell-src-meta >=0.6.0.4 && < 0.7+ , directory >=1.2 && < 1.3+ , time >= 1.4.0 && < 1.5+ , unix >= 2.6 && < 2.8+ + hs-source-dirs: src+ ghc-options: -Wall + default-language: Haskell2010+ +executable main+ main-is: main.hs+ hs-source-dirs: src,example+ ghc-options: -Wall+ build-depends: base >=4.6 + , text >=0.11.3 + , transformers >=0.3 + , either >=4.1 + , template-haskell >=2.8 + , haskell-src-meta >=0.6.0.4+ , directory >=1.2 + , time >= 1.4.0+ , unix >= 2.6+ default-language: Haskell2010