{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module HaskellCI.Sh (
    Sh (..),
    isComment,
    MonadSh (..),
    sh,
    ShM (..),
    runSh,
    ShError (..),
    FromShError (..),
    ) where

import HaskellCI.Prelude

#ifdef MIN_VERSION_ShellCheck
import           ShellCheck.Checker    (checkScript)
import qualified ShellCheck.Interface  as SC
#endif

import HaskellCI.MonadErr

-------------------------------------------------------------------------------
-- shell command
-------------------------------------------------------------------------------

data Sh
    = Sh String       -- ^ command
    | Comment String  -- ^ comment
  deriving Int -> Sh -> ShowS
[Sh] -> ShowS
Sh -> String
(Int -> Sh -> ShowS)
-> (Sh -> String) -> ([Sh] -> ShowS) -> Show Sh
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sh] -> ShowS
$cshowList :: [Sh] -> ShowS
show :: Sh -> String
$cshow :: Sh -> String
showsPrec :: Int -> Sh -> ShowS
$cshowsPrec :: Int -> Sh -> ShowS
Show

isComment :: Sh -> Bool
isComment :: Sh -> Bool
isComment (Comment String
_) = Bool
True
isComment (Sh String
_)      = Bool
False

-------------------------------------------------------------------------------
-- class
-------------------------------------------------------------------------------

class Monad m => MonadSh m where
    -- | Write shell command
    sh' :: [Integer] -> String -> m ()

    -- | Write comment
    comment :: String -> m ()

    -- | Commented block.
    --
    -- If the block is empty (or comments only), nothing might be written.
    commentedBlock :: String -> m () -> m ()

sh :: MonadSh m => String -> m ()
sh :: String -> m ()
sh = [Integer] -> String -> m ()
forall (m :: * -> *). MonadSh m => [Integer] -> String -> m ()
sh'
    [ Integer
2034 -- VAR appears unused. Verify it or export it.
    , Integer
2086 -- SC2086: Double quote to prevent globbing and word splitting.
    , Integer
2002 -- SC2002: Useless cat. Consider 'cmd < file | ..' or 'cmd file | ..' instead.
    -- TODO: because HEREDOC doesn't work
    , Integer
2129 -- SC2129: Consider using { cmd1; cmd2; } >> file instead of individual redirects
    , Integer
2154 -- SC2154: PKGDIR_splitmix is referenced but not assigned.
    ]

-------------------------------------------------------------------------------
-- Errors
-------------------------------------------------------------------------------

data ShError
    = ShellCheckError String  -- ^ @ShellCheck@ disagrees.
    | ShError String          -- ^ made by 'fail'.
  deriving (Int -> ShError -> ShowS
[ShError] -> ShowS
ShError -> String
(Int -> ShError -> ShowS)
-> (ShError -> String) -> ([ShError] -> ShowS) -> Show ShError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ShError] -> ShowS
$cshowList :: [ShError] -> ShowS
show :: ShError -> String
$cshow :: ShError -> String
showsPrec :: Int -> ShError -> ShowS
$cshowsPrec :: Int -> ShError -> ShowS
Show)

instance Exception ShError where
    displayException :: ShError -> String
displayException (ShellCheckError String
s) = String
s
    displayException (ShError String
s)         = String
"PANIC " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

class FromShError e where
    fromShError :: ShError -> e

instance FromShError ShError where
    fromShError :: ShError -> ShError
fromShError = ShError -> ShError
forall a. a -> a
id

-------------------------------------------------------------------------------
-- implementation
-------------------------------------------------------------------------------

newtype ShM a = ShM { ShM a -> ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)
unShM :: ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a) }
  deriving (a -> ShM b -> ShM a
(a -> b) -> ShM a -> ShM b
(forall a b. (a -> b) -> ShM a -> ShM b)
-> (forall a b. a -> ShM b -> ShM a) -> Functor ShM
forall a b. a -> ShM b -> ShM a
forall a b. (a -> b) -> ShM a -> ShM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ShM b -> ShM a
$c<$ :: forall a b. a -> ShM b -> ShM a
fmap :: (a -> b) -> ShM a -> ShM b
$cfmap :: forall a b. (a -> b) -> ShM a -> ShM b
Functor)

runSh :: (MonadErr e m, FromShError e) => ShM () -> m [Sh]
runSh :: ShM () -> m [Sh]
runSh (ShM ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())
f) = case ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())
f [Sh] -> [Sh]
forall a. a -> a
id of
    Left ShError
err      -> e -> m [Sh]
forall e (m :: * -> *) a. MonadErr e m => e -> m a
throwErr (ShError -> e
forall e. FromShError e => ShError -> e
fromShError ShError
err)
    Right ([Sh] -> [Sh]
g, ()) -> [Sh] -> m [Sh]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sh] -> [Sh]
g [])

instance Applicative ShM where
    pure :: a -> ShM a
pure a
x = (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a)
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
shs -> ([Sh] -> [Sh], a) -> Either ShError ([Sh] -> [Sh], a)
forall a b. b -> Either a b
Right ([Sh] -> [Sh]
shs, a
x)
    <*> :: ShM (a -> b) -> ShM a -> ShM b
(<*>) = ShM (a -> b) -> ShM a -> ShM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ShM where
    return :: a -> ShM a
return = a -> ShM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

    ShM a
m >>= :: ShM a -> (a -> ShM b) -> ShM b
>>= a -> ShM b
k = (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], b)) -> ShM b
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], b)) -> ShM b)
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], b)) -> ShM b
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
shs0 -> do
        ([Sh] -> [Sh]
shs1, a
x) <- ShM a -> ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)
forall a.
ShM a -> ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)
unShM ShM a
m     [Sh] -> [Sh]
shs0
        ([Sh] -> [Sh]
shs2, b
y) <- ShM b -> ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], b)
forall a.
ShM a -> ([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)
unShM (a -> ShM b
k a
x) [Sh] -> [Sh]
shs1
        ([Sh] -> [Sh], b) -> Either ShError ([Sh] -> [Sh], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sh] -> [Sh]
shs2, b
y)

instance MonadErr ShError ShM where
    throwErr :: ShError -> ShM a
throwErr ShError
err = (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a)
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
_ -> ShError -> Either ShError ([Sh] -> [Sh], a)
forall a b. a -> Either a b
Left ShError
err

unsafeSh :: String -> ShM ()
unsafeSh :: String -> ShM ()
unsafeSh String
x = (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ())
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
shs -> ([Sh] -> [Sh], ()) -> Either ShError ([Sh] -> [Sh], ())
forall a b. b -> Either a b
Right ([Sh] -> [Sh]
shs ([Sh] -> [Sh]) -> ([Sh] -> [Sh]) -> [Sh] -> [Sh]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Sh
Sh String
x Sh -> [Sh] -> [Sh]
forall a. a -> [a] -> [a]
:),      ())

instance MonadSh ShM where
#ifndef MIN_VERSION_ShellCheck
    sh' _ = unsafeSh
#else
    sh' :: [Integer] -> String -> ShM ()
sh' [Integer]
excl String
cmd
        | [PositionedComment] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CheckResult -> [PositionedComment]
SC.crComments CheckResult
res) = String -> ShM ()
unsafeSh String
cmd
        | Bool
otherwise                = ShError -> ShM ()
forall e (m :: * -> *) a. MonadErr e m => e -> m a
throwErr (ShError -> ShM ()) -> ShError -> ShM ()
forall a b. (a -> b) -> a -> b
$ String -> ShError
ShellCheckError (String -> ShError) -> String -> ShError
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            (String
"ShellCheck! " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmd) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            [ String
"SC" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show (Comment -> Integer
SC.cCode Comment
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Comment -> String
SC.cMessage Comment
c
            | PositionedComment
pc <- CheckResult -> [PositionedComment]
SC.crComments CheckResult
res
            , let c :: Comment
c = PositionedComment -> Comment
SC.pcComment PositionedComment
pc
            ]
      where
        res :: CheckResult
res = Identity CheckResult -> CheckResult
forall a. Identity a -> a
runIdentity (Identity CheckResult -> CheckResult)
-> Identity CheckResult -> CheckResult
forall a b. (a -> b) -> a -> b
$ SystemInterface Identity -> CheckSpec -> Identity CheckResult
forall (m :: * -> *).
Monad m =>
SystemInterface m -> CheckSpec -> m CheckResult
checkScript SystemInterface Identity
iface CheckSpec
spec
        iface :: SystemInterface Identity
iface = [(String, String)] -> SystemInterface Identity
SC.mockedSystemInterface []
        spec :: CheckSpec
spec  = CheckSpec
SC.emptyCheckSpec
            { csFilename :: String
SC.csFilename          = String
"stdin"
            , csScript :: String
SC.csScript            = String
cmd
            , csExcludedWarnings :: [Integer]
SC.csExcludedWarnings  = [Integer]
excl
            , csShellTypeOverride :: Maybe Shell
SC.csShellTypeOverride = Shell -> Maybe Shell
forall a. a -> Maybe a
Just Shell
SC.Sh
            }
#endif
    comment :: String -> ShM ()
comment String
x = (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ())
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
shs -> ([Sh] -> [Sh], ()) -> Either ShError ([Sh] -> [Sh], ())
forall a b. b -> Either a b
Right ([Sh] -> [Sh]
shs ([Sh] -> [Sh]) -> ([Sh] -> [Sh]) -> [Sh] -> [Sh]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Sh
Comment String
x Sh -> [Sh] -> [Sh]
forall a. a -> [a] -> [a]
:), ())

    commentedBlock :: String -> ShM () -> ShM ()
commentedBlock String
c ShM ()
m = case ShM () -> Either ShError [Sh]
forall e (m :: * -> *).
(MonadErr e m, FromShError e) =>
ShM () -> m [Sh]
runSh ShM ()
m of
        Left ShError
err  -> ShError -> ShM ()
forall e (m :: * -> *) a. MonadErr e m => e -> m a
throwErr ShError
err
        Right [Sh]
shs
            | (Sh -> Bool) -> [Sh] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Sh -> Bool
isComment [Sh]
shs -> () -> ShM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise         -> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a.
(([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], a)) -> ShM a
ShM ((([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ())
-> (([Sh] -> [Sh]) -> Either ShError ([Sh] -> [Sh], ())) -> ShM ()
forall a b. (a -> b) -> a -> b
$ \[Sh] -> [Sh]
shs1 -> ([Sh] -> [Sh], ()) -> Either ShError ([Sh] -> [Sh], ())
forall a b. b -> Either a b
Right
                ([Sh] -> [Sh]
shs1 ([Sh] -> [Sh]) -> ([Sh] -> [Sh]) -> [Sh] -> [Sh]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Sh]
shs2 -> String -> Sh
Comment String
c Sh -> [Sh] -> [Sh]
forall a. a -> [a] -> [a]
: [Sh]
shs [Sh] -> [Sh] -> [Sh]
forall a. [a] -> [a] -> [a]
++ [Sh]
shs2), ())