{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

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

import Control.Monad
import Control.Monad.Trans
import Data.ByteString qualified as B
import Data.ByteString.Lazy 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.Meta.Parse
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char
import Prelude hiding (exp)

class Processable a r where
  sh_ :: a -> r

instance (Processable a r) => Processable (String -> a) (String -> r) where
  sh_ f x = sh_ (f x)

instance (MonadIO m) => Processable String (m ()) where
  sh_ s = do
    liftIO (runProcess_ (fromString s))

instance (MonadIO m, Outputable a) => Processable String (m a) where
  sh_ s = do
    fromLBS <$> liftIO (readProcessInterleaved_ (fromString s))

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

instance (MonadIO m, Outputable stdout, Outputable stderr) => Processable String (m (ExitCode, stdout, stderr)) where
  sh_ s = do
    (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS 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

class Quotable m a where
  toStringM :: (Monad m) => a -> m String
  default toStringM :: (Show a, Monad m) => a -> m String
  toStringM = pure . show

instance Quotable m String where
  toStringM = pure

instance (Monad m, Quotable m a) => Quotable m (m a) where
  toStringM mkA = toStringM =<< mkA

instance Quotable m Int

instance Quotable m B.ByteString where
  toStringM = pure . B.toString

instance Quotable m LB.ByteString where
  toStringM = pure . LB.toString

instance Quotable m T.Text where
  toStringM = pure . T.unpack

instance Quotable m LT.Text where
  toStringM = pure . 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)]
    parser =
      many . choice $
        [ do
            Var False . either fail pure . parseExp
              <$> ( string "#{"
                      *> takeWhile1P Nothing (/= '}')
                      <* string "}"
                  ),
          do
            Var True . either fail pure . parseExp
              <$> ( string "'#{"
                      *> takeWhile1P Nothing (/= '}')
                      <* string "}'"
                  ),
          do
            Lit <$> takeWhile1P Nothing ((&&) <$> (/= '#') <*> (/= '\''))
        ]

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

    toExp :: Expr Name -> Q Exp
    toExp (Lit s) = [|s|]
    toExp (Var q nam) =
      [|(if q then squote else dquote) $(varE nam)|]