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

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

import Control.Monad
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.TH
import Language.Haskell.TH.Quote
import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char

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 Processable String (IO ()) where
  sh_ s = do
    runProcess_ (fromString s)

instance (Outputable a) => Processable String (IO a) where
  sh_ s = do
    fromLBS <$> readProcessInterleaved_ (fromString s)

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

instance (Outputable stdout, Outputable stderr) => Processable String (IO (ExitCode, stdout, stderr)) where
  sh_ s = do
    (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS err)) <$> 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 a
  = Lit String
  | Var Bool a
  deriving (Show)

expr :: (String -> b) -> (Bool -> a -> b) -> Expr a -> b
expr f _ (Lit a) = f a
expr _ g (Var q a) = g q a

unVar :: Expr a -> Maybe a
unVar (Lit _) = Nothing
unVar (Var _ a) = Just 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 ()]
    parser =
      many . choice $
        [ const (Lit "%") <$> string "%%",
          const (Var True ()) <$> string "'%'",
          const (Var False ()) <$> satisfy (== '%'),
          Lit <$> takeWhile1P Nothing (not . (`elem` "'%")),
          Lit <$> string "'%",
          Lit <$> string "'"
        ]

    makeExp :: [Expr ()] -> Q Exp
    makeExp exprs' = do
      exprs <-
        mapM
          (expr (pure . Lit) (\q _ -> Var q <$> newName "x"))
          exprs'
      lamE (map varP (mapMaybe unVar exprs)) . appE [|sh_|] $
        flip (foldM (flip go)) exprs =<< [|""|]

    go (Lit s) = appE [|flip (++) s|] . pure
    go (Var q n) = appE (appE [|flip (++)|] (appE [|if q then squote else dquote|] (varE n))) . pure