module System.Process.Quick.CallArgument where

import Control.Monad.Writer.Strict
import Data.HList
import Language.Haskell.TH as TH
import Refined as M hiding (NonEmpty)
import System.Process.Quick.OrphanArbitrary ()
import System.Process.Quick.Prelude hiding (Text)
import TH.Utilities qualified as TU

class Arbitrary a => CallArgument a where
  toExecString :: a -> [String]
  default toExecString :: Show a => a -> [String]
  toExecString = (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall b a. (Show a, IsString b) => a -> b
show

instance CallArgument a => CallArgument (Maybe a) where
  toExecString :: Maybe a -> [String]
toExecString = [String] -> (a -> [String]) -> Maybe a -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] a -> [String]
forall a. CallArgument a => a -> [String]
toExecString
instance (CallArgument a, CallArgument b) => CallArgument (Either a b) where
  toExecString :: Either a b -> [String]
toExecString = \case
    Left a
x -> a -> [String]
forall a. CallArgument a => a -> [String]
toExecString a
x
    Right b
x -> b -> [String]
forall a. CallArgument a => a -> [String]
toExecString b
x
instance CallArgument Int
instance CallArgument Integer
instance CallArgument Double
instance CallArgument Float
instance CallArgument Word
instance CallArgument Bool
instance CallArgument () where
  toExecString :: () -> [String]
toExecString ()
_ = []

-- | Disambiguate 'Refined.NonEmpty'
type NeList = NonEmpty

instance CallArgument a => CallArgument (NonEmpty a) where
  toExecString :: NonEmpty a -> [String]
toExecString = (a -> [String]) -> NonEmpty a -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [String]
forall a. CallArgument a => a -> [String]
toExecString

instance CallArgument a => CallArgument [a] where
  toExecString :: [a] -> [String]
toExecString = (a -> [String]) -> [a] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [String]
forall a. CallArgument a => a -> [String]
toExecString
instance {-# OVERLAPPING #-} CallArgument String where
  toExecString :: String -> [String]
toExecString = (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[])

instance (Typeable a, Predicate c a, CallArgument a) => CallArgument (Refined c a) where
  toExecString :: Refined c a -> [String]
toExecString = a -> [String]
forall a. CallArgument a => a -> [String]
toExecString (a -> [String]) -> (Refined c a -> a) -> Refined c a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Refined c a -> a
forall {k} (p :: k) x. Refined p x -> x
unrefine

newtype QR a
  = QR { forall a. QR a -> WriterT [Dec] Q a
unQR :: WriterT [Dec] Q a }
  deriving ((forall a b. (a -> b) -> QR a -> QR b)
-> (forall a b. a -> QR b -> QR a) -> Functor QR
forall a b. a -> QR b -> QR a
forall a b. (a -> b) -> QR a -> QR b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> QR a -> QR b
fmap :: forall a b. (a -> b) -> QR a -> QR b
$c<$ :: forall a b. a -> QR b -> QR a
<$ :: forall a b. a -> QR b -> QR a
Functor, Functor QR
Functor QR =>
(forall a. a -> QR a)
-> (forall a b. QR (a -> b) -> QR a -> QR b)
-> (forall a b c. (a -> b -> c) -> QR a -> QR b -> QR c)
-> (forall a b. QR a -> QR b -> QR b)
-> (forall a b. QR a -> QR b -> QR a)
-> Applicative QR
forall a. a -> QR a
forall a b. QR a -> QR b -> QR a
forall a b. QR a -> QR b -> QR b
forall a b. QR (a -> b) -> QR a -> QR b
forall a b c. (a -> b -> c) -> QR a -> QR b -> QR c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> QR a
pure :: forall a. a -> QR a
$c<*> :: forall a b. QR (a -> b) -> QR a -> QR b
<*> :: forall a b. QR (a -> b) -> QR a -> QR b
$cliftA2 :: forall a b c. (a -> b -> c) -> QR a -> QR b -> QR c
liftA2 :: forall a b c. (a -> b -> c) -> QR a -> QR b -> QR c
$c*> :: forall a b. QR a -> QR b -> QR b
*> :: forall a b. QR a -> QR b -> QR b
$c<* :: forall a b. QR a -> QR b -> QR a
<* :: forall a b. QR a -> QR b -> QR a
Applicative, Applicative QR
Applicative QR =>
(forall a b. QR a -> (a -> QR b) -> QR b)
-> (forall a b. QR a -> QR b -> QR b)
-> (forall a. a -> QR a)
-> Monad QR
forall a. a -> QR a
forall a b. QR a -> QR b -> QR b
forall a b. QR a -> (a -> QR b) -> QR b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. QR a -> (a -> QR b) -> QR b
>>= :: forall a b. QR a -> (a -> QR b) -> QR b
$c>> :: forall a b. QR a -> QR b -> QR b
>> :: forall a b. QR a -> QR b -> QR b
$creturn :: forall a. a -> QR a
return :: forall a. a -> QR a
Monad, Monad QR
Monad QR => (forall a. String -> QR a) -> MonadFail QR
forall a. String -> QR a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> QR a
fail :: forall a. String -> QR a
MonadFail, MonadWriter [Dec])

instance Quote QR where
  newName :: String -> QR Name
newName String
n = WriterT [Dec] Q Name -> QR Name
forall a. WriterT [Dec] Q a -> QR a
QR (WriterT [Dec] Q Name -> QR Name)
-> WriterT [Dec] Q Name -> QR Name
forall a b. (a -> b) -> a -> b
$ Q Name -> WriterT [Dec] Q Name
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
n)

class (Typeable a) => CallArgumentGen a where
  -- | field name in the record; constant value does not have a field
  cArgName :: a -> Maybe String
  -- | lambda expression projecting a call argument in CallSpec record to a list of strings
  -- Exp type is '\v -> [String]'
  progArgExpr :: a -> QR Exp
  -- | TH field definition of call argument in CallSpec record
  fieldExpr :: a -> QR (Maybe VarBangType)

newtype ConstArg = ConstArg String deriving (ConstArg -> ConstArg -> Bool
(ConstArg -> ConstArg -> Bool)
-> (ConstArg -> ConstArg -> Bool) -> Eq ConstArg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstArg -> ConstArg -> Bool
== :: ConstArg -> ConstArg -> Bool
$c/= :: ConstArg -> ConstArg -> Bool
/= :: ConstArg -> ConstArg -> Bool
Eq, Int -> ConstArg -> ShowS
[ConstArg] -> ShowS
ConstArg -> String
(Int -> ConstArg -> ShowS)
-> (ConstArg -> String) -> ([ConstArg] -> ShowS) -> Show ConstArg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstArg -> ShowS
showsPrec :: Int -> ConstArg -> ShowS
$cshow :: ConstArg -> String
show :: ConstArg -> String
$cshowList :: [ConstArg] -> ShowS
showList :: [ConstArg] -> ShowS
Show, Typeable)
instance CallArgumentGen ConstArg where
  cArgName :: ConstArg -> Maybe String
cArgName ConstArg
_ = Maybe String
forall a. Maybe a
Nothing
  progArgExpr :: ConstArg -> QR Exp
progArgExpr (ConstArg String
c) = [| const [ $(String -> QR Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE String
c)] |]
  fieldExpr :: ConstArg -> QR (Maybe VarBangType)
fieldExpr ConstArg
_ = Maybe VarBangType -> QR (Maybe VarBangType)
forall a. a -> QR a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe VarBangType
forall a. Maybe a
Nothing

defaultBang :: Bang
defaultBang :: Bang
defaultBang = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness

nameE :: String -> Q Exp
nameE :: String -> Q Exp
nameE = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name) -> ShowS -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
escapeFieldName

isValidFirstFieldLetter :: Char -> Bool
isValidFirstFieldLetter :: Char -> Bool
isValidFirstFieldLetter Char
c = Char -> Bool
isLetter Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

isValidFieldLetter :: Char -> Bool
isValidFieldLetter :: Char -> Bool
isValidFieldLetter Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

haskellKeyword :: Set String
haskellKeyword :: Set String
haskellKeyword = [Item (Set String)] -> Set String
forall l. IsList l => [Item l] -> l
fromList [ String
Item (Set String)
"type", String
Item (Set String)
"module", String
Item (Set String)
"import", String
Item (Set String)
"where", String
Item (Set String)
"class", String
Item (Set String)
"case", String
Item (Set String)
"in", String
Item (Set String)
"of" ]

mapFirst :: (a -> a) -> [a] -> [a]
mapFirst :: forall a. (a -> a) -> [a] -> [a]
mapFirst a -> a
_ [] = []
mapFirst a -> a
f (a
h:[a]
t) = a -> a
f a
h a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
t

escapeFieldName :: String -> String
escapeFieldName :: ShowS
escapeFieldName = \case
  [] -> Text -> String
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Empty field name"
  (Char
h:String
t) ->
    case (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isValidFirstFieldLetter [Char
h] String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isValidFieldLetter String
t of
      [] -> Text -> String
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Field name " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall b a. (Show a, IsString b) => a -> b
show (Char
hChar -> ShowS
forall a. a -> [a] -> [a]
:String
t) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is empty after filtration"
      String
"type" -> String
"type'"
      String
"mo" -> String
"type'"
      String
filteredFieldName
        | String
filteredFieldName String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`member` Set String
haskellKeyword -> String
filteredFieldName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
        | Bool
otherwise -> String
filteredFieldName

-- | Command line argument without preceeding key
newtype VarArg a = VarArg String deriving (VarArg a -> VarArg a -> Bool
(VarArg a -> VarArg a -> Bool)
-> (VarArg a -> VarArg a -> Bool) -> Eq (VarArg a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). VarArg a -> VarArg a -> Bool
$c== :: forall k (a :: k). VarArg a -> VarArg a -> Bool
== :: VarArg a -> VarArg a -> Bool
$c/= :: forall k (a :: k). VarArg a -> VarArg a -> Bool
/= :: VarArg a -> VarArg a -> Bool
Eq, Int -> VarArg a -> ShowS
[VarArg a] -> ShowS
VarArg a -> String
(Int -> VarArg a -> ShowS)
-> (VarArg a -> String) -> ([VarArg a] -> ShowS) -> Show (VarArg a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> VarArg a -> ShowS
forall k (a :: k). [VarArg a] -> ShowS
forall k (a :: k). VarArg a -> String
$cshowsPrec :: forall k (a :: k). Int -> VarArg a -> ShowS
showsPrec :: Int -> VarArg a -> ShowS
$cshow :: forall k (a :: k). VarArg a -> String
show :: VarArg a -> String
$cshowList :: forall k (a :: k). [VarArg a] -> ShowS
showList :: [VarArg a] -> ShowS
Show, Typeable)
instance (Typeable a, CallArgument a) => CallArgumentGen (VarArg a) where
  cArgName :: VarArg a -> Maybe String
cArgName (VarArg String
n) = String -> Maybe String
forall a. a -> Maybe a
Just String
n
  progArgExpr :: VarArg a -> QR Exp
progArgExpr (VarArg String
fieldName) =
    WriterT [Dec] Q Exp -> QR Exp
forall a. WriterT [Dec] Q a -> QR a
QR (WriterT [Dec] Q Exp -> QR Exp) -> WriterT [Dec] Q Exp -> QR Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> WriterT [Dec] Q Exp
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [| toExecString . $(String -> Q Exp
nameE String
fieldName) |]

  fieldExpr :: VarArg a -> QR (Maybe VarBangType)
fieldExpr (VarArg String
fieldName) =
    VarBangType -> Maybe VarBangType
forall a. a -> Maybe a
Just (VarBangType -> Maybe VarBangType)
-> (Type -> VarBangType) -> Type -> Maybe VarBangType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ ShowS
escapeFieldName String
fieldName, Bang
defaultBang,) (Type -> Maybe VarBangType) -> QR Type -> QR (Maybe VarBangType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QR Type
atRep
    where
      atRep :: QR Type
atRep = WriterT [Dec] Q Type -> QR Type
forall a. WriterT [Dec] Q a -> QR a
QR (WriterT [Dec] Q Type -> QR Type)
-> (Q Type -> WriterT [Dec] Q Type) -> Q Type -> QR Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Type -> WriterT [Dec] Q Type
forall (m :: * -> *) a. Monad m => m a -> WriterT [Dec] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> QR Type) -> Q Type -> QR Type
forall a b. (a -> b) -> a -> b
$ TypeRep -> Q Type
TU.typeRepToType (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a))

-- | Command line argument prefixed with a key
newtype KeyArg a = KeyArg String deriving (KeyArg a -> KeyArg a -> Bool
(KeyArg a -> KeyArg a -> Bool)
-> (KeyArg a -> KeyArg a -> Bool) -> Eq (KeyArg a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (a :: k). KeyArg a -> KeyArg a -> Bool
$c== :: forall k (a :: k). KeyArg a -> KeyArg a -> Bool
== :: KeyArg a -> KeyArg a -> Bool
$c/= :: forall k (a :: k). KeyArg a -> KeyArg a -> Bool
/= :: KeyArg a -> KeyArg a -> Bool
Eq, Int -> KeyArg a -> ShowS
[KeyArg a] -> ShowS
KeyArg a -> String
(Int -> KeyArg a -> ShowS)
-> (KeyArg a -> String) -> ([KeyArg a] -> ShowS) -> Show (KeyArg a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (a :: k). Int -> KeyArg a -> ShowS
forall k (a :: k). [KeyArg a] -> ShowS
forall k (a :: k). KeyArg a -> String
$cshowsPrec :: forall k (a :: k). Int -> KeyArg a -> ShowS
showsPrec :: Int -> KeyArg a -> ShowS
$cshow :: forall k (a :: k). KeyArg a -> String
show :: KeyArg a -> String
$cshowList :: forall k (a :: k). [KeyArg a] -> ShowS
showList :: [KeyArg a] -> ShowS
Show, Typeable)
instance (Typeable a, CallArgument a) => CallArgumentGen (KeyArg a) where
  cArgName :: KeyArg a -> Maybe String
cArgName (KeyArg String
n) = VarArg a -> Maybe String
forall a. CallArgumentGen a => a -> Maybe String
cArgName (forall a. String -> VarArg a
forall {k} (a :: k). String -> VarArg a
VarArg @a String
n)
  progArgExpr :: KeyArg a -> QR Exp
progArgExpr (KeyArg String
fieldName) =
    [| \x -> $(ConstArg -> QR Exp
forall a. CallArgumentGen a => a -> QR Exp
progArgExpr (String -> ConstArg
ConstArg String
fieldName)) x <> $(VarArg a -> QR Exp
forall a. CallArgumentGen a => a -> QR Exp
progArgExpr (forall a. String -> VarArg a
forall {k} (a :: k). String -> VarArg a
VarArg @a String
fieldName)) x |]
  fieldExpr :: KeyArg a -> QR (Maybe VarBangType)
fieldExpr (KeyArg String
fieldName) = VarArg a -> QR (Maybe VarBangType)
forall a. CallArgumentGen a => a -> QR (Maybe VarBangType)
fieldExpr (forall a. String -> VarArg a
forall {k} (a :: k). String -> VarArg a
VarArg @a String
fieldName)