{-# 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 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 hiding (Type)
import Language.Haskell.TH.Quote
import System.Process.Typed
import Text.Megaparsec
import Text.Megaparsec.Char
import Prelude hiding (exp)

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

instance (MonadIO m) => Processable m () where
  sh_ = (liftIO . runProcess_ . fromString =<<)

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

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

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

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)]
    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
            Var False . either fail (appE [|pure|] . pure) . parseExp
              <$> ( string "#{"
                      *> takeWhile1P Nothing (/= '}')
                      <* string "}"
                  ),
          do
            Var True . either fail (appE [|pure|] . pure) . parseExp
              <$> ( string "'#{"
                      *> takeWhile1P Nothing (/= '}')
                      <* string "}'"
                  ),
          do
            Lit <$> takeWhile1P Nothing ((&&) <$> (/= '#') <*> (/= '\'')),
          do
            Lit . (: []) <$> satisfy ((||) <$> (== '\'') <*> (== '#'))
        ]

    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
          ]
      [|
        sh_ $
          $( 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)|]