module System.Process.Quick.CallSpec
  ( FoldrConstr
  , genCallSpec
  , genArbitraryInstance
  , dataD'
  , seqA
  , programNameToHsIdentifier
  , module E
  ) where

import Control.Monad.Writer.Strict
import Data.HList
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax qualified as THS
import System.Directory
import System.Process.Quick.CallArgument
import System.Process.Quick.CallSpec.Type as E
import System.Process.Quick.Prelude
import Text.Casing
import Text.Regex

type FoldrConstr l a = (HFoldr (Mapcar (Fun CallArgumentGen (QR a))) [QR a] l [QR a])

dataD' :: Quote m => Name -> [m Con] -> [m DerivClause] -> m Dec
dataD' :: forall (m :: * -> *).
Quote m =>
Name -> [m Con] -> [m DerivClause] -> m Dec
dataD' Name
name = m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [m Con]
-> [m DerivClause]
-> m Dec
dataD (Cxt -> m Cxt
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) Name
name [] Maybe Kind
forall a. Maybe a
Nothing

genCallArgsRecord :: (Show (HList l), FoldrConstr l (Maybe VarBangType)) => Name -> HList l -> QR Dec
genCallArgsRecord :: forall (l :: [*]).
(Show (HList l), FoldrConstr l (Maybe VarBangType)) =>
Name -> HList l -> QR Dec
genCallArgsRecord Name
recordName HList l
l = do
  fields <- QR [VarBangType] -> QR [QR VarBangType]
forall (m :: * -> *) a. Monad m => m [a] -> m [m a]
seqA (QR [VarBangType] -> QR [QR VarBangType])
-> QR [VarBangType] -> QR [QR VarBangType]
forall a b. (a -> b) -> a -> b
$ [Maybe VarBangType] -> [VarBangType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe VarBangType] -> [VarBangType])
-> QR [Maybe VarBangType] -> QR [VarBangType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QR (Maybe VarBangType)] -> QR [Maybe VarBangType]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence (Fun CallArgumentGen (QR (Maybe VarBangType))
-> HList l -> [QR (Maybe VarBangType)]
forall (m :: * -> *) f (l :: [*]) e.
(Monad m, HMapOut f l (m e)) =>
f -> HList l -> [m e]
hMapM Fun CallArgumentGen (QR (Maybe VarBangType))
fieldDef HList l
l)
  dataD' recordName [recC recordName fields]
    [derivClause Nothing [[t|Data|], [t|Generic|], [t|Show|], [t|Eq|]]]
  where
    fieldDef :: Fun CallArgumentGen (QR (Maybe VarBangType))
fieldDef = (forall a.
 FunCxt CallArgumentGen a =>
 a -> FunApp (QR (Maybe VarBangType)) a)
-> Fun CallArgumentGen (QR (Maybe VarBangType))
forall k1 k2 (cxt :: k1) (getb :: k2).
(forall a. FunCxt cxt a => a -> FunApp getb a) -> Fun cxt getb
Fun a -> FunApp (QR (Maybe VarBangType)) a
a -> QR (Maybe VarBangType)
forall a.
FunCxt CallArgumentGen a =>
a -> FunApp (QR (Maybe VarBangType)) a
forall a. CallArgumentGen a => a -> QR (Maybe VarBangType)
fieldExpr :: Fun CallArgumentGen (QR (Maybe VarBangType))

funD' :: Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' :: forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' Name
fname [m Pat]
fparams m Exp
fbody =
  Name -> [m Clause] -> m Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
fname [[m Pat] -> m Body -> [m Dec] -> m Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [m Pat]
fparams (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
fbody) []]

type NonEmptyStr = NonEmpty Char

programNameToHsIdentifier :: String -> Maybe (NonEmpty Char)
programNameToHsIdentifier :: String -> Maybe (NonEmpty Char)
programNameToHsIdentifier = String -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (String -> Maybe (NonEmpty Char))
-> (String -> String) -> String -> Maybe (NonEmpty Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toPascal (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromSnake (String -> Identifier String)
-> (String -> String) -> String -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
underbarred
  where
    underbarred :: String -> String
underbarred String
s = Regex -> String -> String -> String
subRegex (String -> Regex
mkRegex String
"[^A-Za-z0-9_]") String
s String
"_"

seqA :: Monad m => m [a] -> m [m a]
seqA :: forall (m :: * -> *) a. Monad m => m [a] -> m [m a]
seqA = ((a -> m a) -> [a] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> [m a]) -> m [a] -> m [m a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

genArbitraryInstance :: Name -> QR Dec
genArbitraryInstance :: Name -> QR Dec
genArbitraryInstance Name
recordName =
  QR Cxt -> QR Kind -> [QR Dec] -> QR Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (Cxt -> QR Cxt
forall a. a -> QR a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t| Arbitrary $(Name -> QR Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
recordName) |]
    [ Name -> [QR Pat] -> QR Exp -> QR Dec
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' 'arbitrary [] [| genericArbitraryU |]
    ]

genCallSpecInstance :: FoldrConstr l Exp => [VerificationMethod] -> Name -> String -> HList l -> QR Dec
genCallSpecInstance :: forall (l :: [*]).
FoldrConstr l Exp =>
[VerificationMethod] -> Name -> String -> HList l -> QR Dec
genCallSpecInstance [VerificationMethod]
verMethods Name
recordName String
progName HList l
l =
  QR Cxt -> QR Kind -> [QR Dec] -> QR Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Kind -> [m Dec] -> m Dec
instanceD (Cxt -> QR Cxt
forall a. a -> QR a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [t| CallSpec $(Name -> QR Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
recordName) |]
  [ Name -> [QR Pat] -> QR Exp -> QR Dec
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' 'programName [ [p|_|] ] [| $(String -> QR Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
progName) |]
  , Name -> [QR Pat] -> QR Exp -> QR Dec
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' 'programArgs []
      [| concat . flap $([QR Exp] -> QR Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE (Fun CallArgumentGen (QR Exp) -> HList l -> [QR Exp]
forall (m :: * -> *) f (l :: [*]) e.
(Monad m, HMapOut f l (m e)) =>
f -> HList l -> [m e]
hMapM ((forall a. FunCxt CallArgumentGen a => a -> FunApp (QR Exp) a)
-> Fun CallArgumentGen (QR Exp)
forall k1 k2 (cxt :: k1) (getb :: k2).
(forall a. FunCxt cxt a => a -> FunApp getb a) -> Fun cxt getb
Fun a -> FunApp (QR Exp) a
a -> QR Exp
forall a. FunCxt CallArgumentGen a => a -> FunApp (QR Exp) a
forall a. CallArgumentGen a => a -> QR Exp
progArgExpr :: Fun CallArgumentGen (QR Exp)) HList l
l)) |]
  , Name -> [QR Pat] -> QR Exp -> QR Dec
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Exp -> m Dec
funD' 'verificationMethods [ [p|_|] ] ([VerificationMethod] -> QR Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [VerificationMethod] -> m Exp
THS.lift ([VerificationMethod] -> QR Exp) -> [VerificationMethod] -> QR Exp
forall a b. (a -> b) -> a -> b
$ [VerificationMethod] -> [VerificationMethod]
forall a. Ord a => [a] -> [a]
sort [VerificationMethod]
verMethods)
  ]

mkName' :: NonEmptyStr -> Name
mkName' :: NonEmpty Char -> Name
mkName' = String -> Name
mkName (String -> Name)
-> (NonEmpty Char -> String) -> NonEmpty Char -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> String
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | gen declaration of CallSpec record with CallSpec instance
genCallSpec ::
  (FoldrConstr l (Maybe VarBangType), FoldrConstr l Exp, Show (HList l)) =>
  [VerificationMethod] -> String -> HList l -> Q [Dec]
genCallSpec :: forall (l :: [*]).
(FoldrConstr l (Maybe VarBangType), FoldrConstr l Exp,
 Show (HList l)) =>
[VerificationMethod] -> String -> HList l -> Q [Dec]
genCallSpec [VerificationMethod]
verMethods String
progName HList l
l = do
  IO () -> Q ()
forall a. IO a -> Q a
runIO (IO () -> Q ()) -> (String -> IO ()) -> String -> Q ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe String) -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m () -> m ()
whenNothingM_ (String -> IO (Maybe String)
findExecutable String
progName) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Program " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall b a. (Show a, IsString b) => a -> b
show String
progName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not found"
  Q [Dec]
-> (NonEmpty Char -> Q [Dec]) -> Maybe (NonEmpty Char) -> Q [Dec]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Q [Dec]
err (Name -> Q [Dec]
g (Name -> Q [Dec])
-> (NonEmpty Char -> Name) -> NonEmpty Char -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Char -> Name
mkName') (String -> Maybe (NonEmpty Char)
programNameToHsIdentifier String
progName)
  where
    err :: Q [Dec]
err = String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"Call spec name is bad: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall b a. (Show a, IsString b) => a -> b
show String
progName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> HList l -> String
forall b a. (Show a, IsString b) => a -> b
show HList l
l
    g :: Name -> Q [Dec]
g Name
recName = do
      (a, w) <- WriterT [Dec] Q [Dec] -> Q ([Dec], [Dec])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [Dec] Q [Dec] -> Q ([Dec], [Dec]))
-> (QR [Dec] -> WriterT [Dec] Q [Dec])
-> QR [Dec]
-> Q ([Dec], [Dec])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QR [Dec] -> WriterT [Dec] Q [Dec]
forall a. QR a -> WriterT [Dec] Q a
unQR (QR [Dec] -> Q ([Dec], [Dec])) -> QR [Dec] -> Q ([Dec], [Dec])
forall a b. (a -> b) -> a -> b
$ [QR Dec] -> QR [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
        [ Name -> HList l -> QR Dec
forall (l :: [*]).
(Show (HList l), FoldrConstr l (Maybe VarBangType)) =>
Name -> HList l -> QR Dec
genCallArgsRecord Name
recName HList l
l
        , [VerificationMethod] -> Name -> String -> HList l -> QR Dec
forall (l :: [*]).
FoldrConstr l Exp =>
[VerificationMethod] -> Name -> String -> HList l -> QR Dec
genCallSpecInstance [VerificationMethod]
verMethods Name
recName String
progName HList l
l
        , Name -> QR Dec
genArbitraryInstance Name
recName
        ]
      pure $ w <> a