{-# 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 a where
  squote :: a -> String
  squote = squote . toString

  dquote :: a -> String
  dquote = dquote . toString

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

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

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

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

data Expr
  = Lit String
  | Var Bool (Q Exp)

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]
    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 =
      [|sh_ $(foldr (\a b -> [|$a ++ $b|]) [|""|] (map toExp exprs))|]

    toExp (Lit s) = [|s|]
    toExp (Var q exp) = [|(if q then squote else dquote) $exp|]