diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/main.hs b/example/main.hs new file mode 100644 --- /dev/null +++ b/example/main.hs @@ -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" + + diff --git a/src/System/Directory/Lifted.hs b/src/System/Directory/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/System/Directory/Lifted.hs @@ -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 + |] + + diff --git a/src/System/Environment/Lifted.hs b/src/System/Environment/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Lifted.hs @@ -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 + |] + + diff --git a/src/System/Lifted.hs b/src/System/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/System/Lifted.hs @@ -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 + + diff --git a/src/System/Posix/User/Lifted.hs b/src/System/Posix/User/Lifted.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/User/Lifted.hs @@ -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 + |] + + diff --git a/system-lifted.cabal b/system-lifted.cabal new file mode 100644 --- /dev/null +++ b/system-lifted.cabal @@ -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