{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Process.Shell
  ( sh,
    Quotable (..),
    ExitCodeException (..),
    DecodeException (..),
  )
where

import Control.Exception (Exception, throw)
import Control.Monad
import Control.Monad.Reader
import Data.Aeson
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
import Data.ByteString.UTF8 qualified as B
import Data.Functor.Identity
import Data.Maybe
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
import Data.Void
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Quote
import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char
import Prelude hiding (exp)

data Script = Script (LB.ByteString -> LB.ByteString) String

class Processable m r where
  sh_ :: m Script -> m r

instance (MonadIO m) => Processable m () where
  sh_ = ((\(Script _ s) -> liftIO (runProcess_ (fromString s))) =<<)

instance (MonadIO m, Outputable a) => Processable m a where
  sh_ = ((\(Script strip s) -> fmap (fromLBS . strip) (liftIO (readProcessInterleaved_ (fromString s)))) =<<)

instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (stdout, stderr) where
  sh_ = ((\(Script stripNL s) -> fmap (\(out, err) -> (fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess_ (fromString s)))) =<<)

instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable m (ExitCode, stdout, stderr) where
  sh_ = ((\(Script stripNL s) -> fmap (\(exitCode, out, err) -> (exitCode, fromLBS (stripNL out), fromLBS (stripNL err))) (liftIO (readProcess (fromString s)))) =<<)

class Outputable a where
  fromLBS :: LB.ByteString -> a

instance Outputable String where
  fromLBS = LB.toString

instance Outputable B.ByteString where
  fromLBS = LB.toStrict

instance Outputable LB.ByteString where
  fromLBS = id

instance Outputable T.Text where
  fromLBS = T.decodeUtf8 . fromLBS

instance Outputable LT.Text where
  fromLBS = LT.decodeUtf8

data DecodeException = DecodeException
  deriving (Show)

instance Exception DecodeException

instance (FromJSON a) => Outputable a where
  fromLBS = fromMaybe (throw DecodeException) . decode

class Quotable a where
  toString :: a -> String
  default toString :: (Show a) => a -> String
  toString = show

instance Quotable String where
  toString = id

instance Quotable Int

instance Quotable B.ByteString where
  toString = B.toString

instance Quotable LB.ByteString where
  toString = LB.toString

instance Quotable T.Text where
  toString = T.unpack

instance Quotable LT.Text where
  toString = LT.unpack

squote :: String -> String
squote s = "'" <> quote' s <> "'"
  where
    quote' [] = []
    quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs
    quote' (c : cs) = c : quote' cs

dquote :: String -> String
dquote s = "\"" <> quote' s <> "\""
  where
    quote' [] = []
    quote' ('\\' : c : cs) = c : quote' cs
    quote' ('"' : cs) = '\\' : '"' : quote' cs
    quote' (c : cs) = c : quote' cs

data Expr a
  = Lit String
  | Var Bool a

sh :: QuasiQuoter
sh = QuasiQuoter quoteExp undefined undefined undefined
  where
    quoteExp :: String -> Q Exp
    quoteExp =
      either (fail . errorBundlePretty) makeExp'
        . parse (parser <* eof) ""

    parser :: ParsecT Void String Identity ([Expr (Q Exp)], Bool)
    parser =
      (,)
        <$> ( many . choice . map try $
                [ do
                    -- TODO Splice arbitrary Haskell expressions
                    Var False . varE . mkName
                      <$> ( string "#{{"
                              *> takeWhile1P Nothing (/= '}')
                              <* string "}}"
                          ),
                  do
                    Var True . varE . mkName
                      <$> ( string "'#{{"
                              *> takeWhile1P Nothing (/= '}')
                              <* string "}}'"
                          ),
                  do
                    Var False . appE [|pure|] . varE . mkName
                      <$> ( string "#{"
                              *> takeWhile1P Nothing (/= '}')
                              <* string "}"
                          ),
                  do
                    Var True . appE [|pure|] . varE . mkName
                      <$> ( string "'#{"
                              *> takeWhile1P Nothing (/= '}')
                              <* string "}'"
                          ),
                  do
                    Lit <$> takeWhile1P Nothing (\c -> all (c /=) ['\'', '#', '\\']),
                  do
                    Lit . (: []) <$> satisfy ((||) <$> (== '\'') <*> (== '#')),
                  do
                    Lit . (: []) <$> satisfy (== '\\') <* lookAhead (satisfy (const True))
                ]
            )
        <*> (isNothing <$> optional (string "\\"))

    makeExp' :: ([Expr (Q Exp)], Bool) -> Q Exp
    makeExp' (exprs, False) = [|sh_ (Script id <$> $(makeExp exprs))|]
    makeExp' (exprs, True) = [|sh_ (Script stripTrailingNLs <$> $(makeExp exprs))|]

    makeExp :: [Expr (Q Exp)] -> Q Exp
    makeExp exprs = do
      exprs' :: [(Expr Name)] <-
        sequence
          [ case expr of
              Lit s -> pure (Lit s)
              Var q _ -> Var q <$> newName "arg"
            | expr <- exprs
          ]
      doE $
        [ BindS <$> (varP nam) <*> [|toString <$> $exp|]
          | (Var _ exp, Var _ nam) <- zip exprs exprs'
        ]
          ++ [ NoBindS <$> [|pure $(foldr (\a b -> [|$a ++ $b|]) [|""|] (map toExp exprs'))|]
             ]

    toExp :: Expr Name -> Q Exp
    toExp (Lit s) = [|s|]
    toExp (Var True nam) = [|squote $(varE nam)|]
    toExp (Var False nam) = [|dquote $(varE nam)|]

stripTrailingNLs :: LB.ByteString -> LB.ByteString
stripTrailingNLs s = maybe s (stripTrailingNLs) (LB.stripSuffix (LB.pack "\n") s)