Add Quasiquote support

src/Streamly/Coreutils/Chmod.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes #-}
 -- |
 -- Module      : Streamly.Coreutils.Chmod
 -- Copyright   : (c) 2022 Composewell Technologies
@@ -9,38 +10,29 @@
 -- change file mode bits.
 
 module Streamly.Coreutils.Chmod
-    (  chmod
+    ( chmod
     )
 where
 
 import Data.Bits ((.|.), Bits ((.&.), complement))
-import Data.Default.Class (Default(..))
-
+import Streamly.Coreutils.StringQ
 import qualified System.Posix as Posix
 
-data UserType = Owner | Group | Others deriving (Eq, Ord, Read, Show)
-
-data Permissions = Permissions
-  { readable :: Bool
-  , writable :: Bool
-  , executable :: Bool
-  } deriving (Eq, Ord, Read, Show)
-
-instance Default Permissions where
-    def = Permissions
-        { readable = False
-        , writable = False
-        , executable = False
-        }
-
 modifyBit :: Bool -> Posix.FileMode -> Posix.FileMode -> Posix.FileMode
 modifyBit False b m = m .&. complement b
 modifyBit True  b m = m .|. b
 
-chmod :: UserType -> Permissions -> FilePath -> IO ()
-chmod utype (Permissions r w e) path = do
+chmodWith :: UserType -> Permissions -> FilePath -> IO ()
+chmodWith utype (Permissions r w e) path = do
     case utype of
-        Owner -> do
+        Owner -> setOwnerPermissions
+        Group -> setGroupPermissions
+        Others -> setOthersPermissions
+        All -> setAllPermissions
+
+        where
+
+        setOwnerPermissions = do
             stat <- Posix.getFileStatus path
             Posix.setFileMode
                 path
@@ -49,7 +41,8 @@ chmod utype (Permissions r w e) path = do
                 . modifyBit r Posix.ownerReadMode
                 . Posix.fileMode $ stat
                 )
-        Group ->  do
+
+        setGroupPermissions = do
             stat <- Posix.getFileStatus path
             Posix.setFileMode
                 path
@@ -58,7 +51,8 @@ chmod utype (Permissions r w e) path = do
                 . modifyBit r Posix.groupReadMode
                 . Posix.fileMode $ stat
                 )
-        Others -> do
+
+        setOthersPermissions = do
             stat <- Posix.getFileStatus path
             Posix.setFileMode
                 path
@@ -67,3 +61,14 @@ chmod utype (Permissions r w e) path = do
                 . modifyBit r Posix.otherReadMode
                 . Posix.fileMode $ stat
                 )
+
+        setAllPermissions = do
+            setOwnerPermissions
+            setGroupPermissions
+            setOthersPermissions
+
+-- | Supports only override permissions bits
+-- >> chmod [perm|a=rwx|] "a.txt"
+--
+chmod :: UserTypePerm -> FilePath -> IO ()
+chmod pat = chmodWith (utype pat) (permssions pat)

src/Streamly/Coreutils/StringQ.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- Module      : Streamly.Coreutils.StringQ
+-- Copyright   : (c) 2022 Composewell Technologies
+-- License     : BSD-3-Clause
+-- Maintainer  : [email protected]
+-- Stability   : experimental
+-- Portability : GHC
+--
+-- change file mode bits.
+
+module Streamly.Coreutils.StringQ
+    (
+      perm
+    , UserType(..)
+    , Permissions(..)
+    , UserTypePerm(..)
+    )
+where
+
+import Control.Applicative (Alternative(..))
+import Control.Monad.Catch (MonadCatch)
+import Control.Monad.IO.Class (liftIO, MonadIO)
+import Data.Char (chr)
+import Data.Data (Data, Typeable)
+import Data.Default.Class (Default(..))
+import Language.Haskell.TH (Exp, Q, Pat)
+import Language.Haskell.TH.Quote (QuasiQuoter(..), dataToExpQ, dataToPatQ)
+import Streamly.Internal.Data.Parser (Parser)
+
+import qualified Streamly.Internal.Data.Fold as Fold
+import qualified Streamly.Internal.Data.Parser as Parser
+import qualified Streamly.Internal.Data.Stream.IsStream as Stream
+import qualified Streamly.Internal.Unicode.Char.Parser as Parser
+
+strParser :: MonadCatch m => Parser m Char String
+strParser =
+    let ut = Parser.char 'u'
+            <|> Parser.char 'g'
+            <|> Parser.char 'o'
+            <|> Parser.char 'a'
+        op = Parser.char '='    -- supports only override permissions bits
+        p1 = Parser.char (chr 0)
+            <|> Parser.char 'r'
+            <|> Parser.char 'w'
+            <|> Parser.char 'x'
+        r  = ut *> op
+        r1 = ut *> op *> p1
+        r2 = ut *> op *> p1 *> p1
+        r3 = ut *> op *> p1 *> p1 *> p1
+        s =  r <|> r1 <|> r2 <|> r3
+      in Parser.some s Fold.toList
+
+expandVars :: String -> IO ()
+expandVars ln =
+    case Stream.parse strParser (Stream.fromList ln) of
+        Left _ -> fail "Parsing of perm quoted string failed."
+        Right _ -> return ()
+
+data Permissions = Permissions
+  { readable :: Bool
+  , writable :: Bool
+  , executable :: Bool
+  } deriving (Eq, Ord, Read, Show, Typeable, Data)
+
+data UserType =
+      Owner
+    | Group
+    | Others
+    | All
+        deriving (Eq, Ord, Read, Show, Typeable, Data)
+
+data UserTypePerm =
+    UserTypePerm
+    { utype :: UserType
+    , permssions :: Permissions
+    } deriving (Eq, Ord, Read, Show, Typeable, Data)
+
+instance Default Permissions where
+    def = Permissions
+        { readable = False
+        , writable = False
+        , executable = False
+        }
+
+parseExpr :: MonadIO m => String -> m UserTypePerm
+parseExpr s = do
+    liftIO $ expandVars s
+    let ut = head s
+        bits = tail $ tail s
+    return $
+        case ut of
+            'u' -> UserTypePerm Owner $ setPermission bits
+            'g' -> UserTypePerm Group $ setPermission bits
+            'o' -> UserTypePerm Others $ setPermission bits
+            'a' -> UserTypePerm All $ setPermission bits
+            _ -> error "Invalid permissions"
+
+    where
+
+    setPermission bits =
+        case bits of
+            "rwx" -> Permissions True True True
+            "rw" -> Permissions True True False
+            "r" ->  Permissions True False False
+            "w" ->  Permissions False True False
+            "x" ->  Permissions False False True
+            "rx" ->  Permissions True False True
+            "wx" ->  Permissions False True True
+            _ ->  def
+
+quoteExprExp :: String -> Q Exp
+quoteExprExp s =  do
+    expr <- parseExpr s
+    dataToExpQ (const Nothing) expr
+
+quoteExprPat :: String -> Q Pat
+quoteExprPat s = do
+    expr <- parseExpr s
+    dataToPatQ (const Nothing) expr
+
+perm :: QuasiQuoter
+perm =
+    QuasiQuoter
+        { quoteExp = quoteExprExp
+        , quotePat = quoteExprPat
+        , quoteType = notSupported
+        , quoteDec = notSupported
+        }
+
+    where
+
+    notSupported = error "perm: Not supported."

streamly-coreutils.cabal

@@ -92,11 +92,13 @@ library
     , unix >= 2.7.0 && < 2.8
     , directory >= 1.2.2 && < 1.4
     , data-default-class >= 0.1 && < 0.2
+    , template-haskell >= 2.10.0 && < 2.19.0
   hs-source-dirs:      src
   exposed-modules:
       Streamly.Coreutils
     , Streamly.Coreutils.Chmod
     , Streamly.Coreutils.Common
+    , Streamly.Coreutils.StringQ
     , Streamly.Coreutils.Cp
     , Streamly.Coreutils.FileTest
     , Streamly.Coreutils.ShellWords