{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Registry.Internal.TH where
import Control.Monad.Fail (fail)
import Data.Registry.Internal.Hedgehog
import Data.Text (splitOn)
import Hedgehog
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Protolude hiding (Type)
import Prelude (last)
newtype GeneratorOptions = GeneratorOptions
{ GeneratorOptions -> Bool
checked :: Bool
}
deriving (GeneratorOptions -> GeneratorOptions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GeneratorOptions -> GeneratorOptions -> Bool
$c/= :: GeneratorOptions -> GeneratorOptions -> Bool
== :: GeneratorOptions -> GeneratorOptions -> Bool
$c== :: GeneratorOptions -> GeneratorOptions -> Bool
Eq, Int -> GeneratorOptions -> ShowS
[GeneratorOptions] -> ShowS
GeneratorOptions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GeneratorOptions] -> ShowS
$cshowList :: [GeneratorOptions] -> ShowS
show :: GeneratorOptions -> String
$cshow :: GeneratorOptions -> String
showsPrec :: Int -> GeneratorOptions -> ShowS
$cshowsPrec :: Int -> GeneratorOptions -> ShowS
Show)
defaultGeneratorOptions :: GeneratorOptions
defaultGeneratorOptions :: GeneratorOptions
defaultGeneratorOptions = Bool -> GeneratorOptions
GeneratorOptions Bool
True
makeSelectGenerator :: Name -> [Con] -> ExpQ
makeSelectGenerator :: Name -> [Con] -> ExpQ
makeSelectGenerator Name
name [Con]
constructors = do
Pat
chooserParam <- [p|(chooser :: Gen Chooser)|]
[Pat]
otherParams <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Con -> Q Pat
parameterFor Name
name) [Con]
constructors
[Exp]
untaggedGenerators <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Con -> ExpQ
untagGenerator [Con]
constructors
Exp
expression <- forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"chooseOne")) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"chooser"))) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE [Exp]
untaggedGenerators)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Exp -> Exp
LamE (Pat
chooserParam forall a. a -> [a] -> [a]
: [Pat]
otherParams) Exp
expression
where
parameterFor :: Name -> Con -> Q Pat
parameterFor :: Name -> Con -> Q Pat
parameterFor Name
typeName Con
constructor = do
Name
constructorParam <- Con -> Q Name
constructorParameterName Con
constructor
Name
constructorTag <- Con -> Q Name
tagName Con
constructor
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
constructorParam) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Gen")) (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT (String -> Name
mkName String
"Tag")) (forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (forall a b. (Show a, StringConv String b) => a -> b
show Name
constructorTag)))) (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
typeName)))
makeConstructorGenerator :: Con -> ExpQ
makeConstructorGenerator :: Con -> ExpQ
makeConstructorGenerator Con
constructor = do
Name
constructorTag <- Con -> Q Name
tagName Con
constructor
Name
constructorType <- Con -> Q Name
nameOf Con
constructor
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
appTypeE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"tag")) (forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (forall a b. (Show a, StringConv String b) => a -> b
show Name
constructorTag)))) (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constructorType)
untagGenerator :: Con -> ExpQ
untagGenerator :: Con -> ExpQ
untagGenerator Con
constructor = do
Name
constructorParam <- Con -> Q Name
constructorParameterName Con
constructor
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"fmap")) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"unTag"))) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
constructorParam)
tagName :: Con -> Q Name
tagName :: Con -> Q Name
tagName Con
constructor = do
Text
name <- Con -> Q Text
constructorName Con
constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ forall a b. ConvertText a b => a -> b
toS Text
name
constructorParameterName :: Con -> Q Name
constructorParameterName :: Con -> Q Name
constructorParameterName Con
constructor = do
Text
name <- Con -> Q Text
constructorName Con
constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. ConvertText a b => a -> b
toS Text
name)
constructorName :: Con -> Q Text
constructorName :: Con -> Q Text
constructorName Con
constructor = do
Name
n <- Con -> Q Name
nameOf Con
constructor
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
splitOn Text
"." forall a b. (a -> b) -> a -> b
$ forall a b. (Show a, StringConv String b) => a -> b
show Name
n
nameOf :: Con -> Q Name
nameOf :: Con -> Q Name
nameOf (NormalC Name
n [BangType]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf (RecC Name
n [VarBangType]
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
nameOf Con
other = do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create generators for normal constructors and records, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"generators creation failed"
typesOf :: Con -> Q [Type]
typesOf :: Con -> Q [Type]
typesOf (NormalC Name
_ [BangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BangType]
types)
typesOf (RecC Name
_ [VarBangType]
types) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\(Name
_, Bang
_, Type
t) -> Type
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VarBangType]
types
typesOf Con
other = do
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"we can only create generators for normal constructors and records, got: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Con
other)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"generators creation failed"
assembleGeneratorsToRegistry :: GeneratorOptions -> Exp -> [Exp] -> ExpQ
assembleGeneratorsToRegistry :: GeneratorOptions -> Exp -> [Exp] -> ExpQ
assembleGeneratorsToRegistry GeneratorOptions
options Exp
selectorGenerator [Exp]
generators =
GeneratorOptions -> ExpQ -> ExpQ -> ExpQ
app GeneratorOptions
options (ExpQ -> ExpQ
funOf (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
selectorGenerator)) forall a b. (a -> b) -> a -> b
$
GeneratorOptions -> ExpQ -> ExpQ -> ExpQ
app GeneratorOptions
options (ExpQ -> ExpQ
genFunOf (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"choiceChooser"))) forall a b. (a -> b) -> a -> b
$
[Exp] -> ExpQ
go [Exp]
generators
where
go :: [Exp] -> ExpQ
go [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"generators creation failed"
go [Exp
g] = ExpQ -> ExpQ
genFunOf (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
g)
go (Exp
g:[Exp]
gs) =
GeneratorOptions -> ExpQ -> ExpQ -> ExpQ
app GeneratorOptions
options (ExpQ -> ExpQ
genFunOf (forall (f :: * -> *) a. Applicative f => a -> f a
pure Exp
g)) forall a b. (a -> b) -> a -> b
$
[Exp] -> ExpQ
go [Exp]
gs
app :: GeneratorOptions -> ExpQ -> ExpQ -> ExpQ
app :: GeneratorOptions -> ExpQ -> ExpQ -> ExpQ
app GeneratorOptions
options ExpQ
e1 ExpQ
e2 = do
let op :: String
op = if GeneratorOptions -> Bool
checked GeneratorOptions
options then String
"<:" else String
"<+"
forall (m :: * -> *).
Quote m =>
Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (forall a. a -> Maybe a
Just ExpQ
e1) (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
op)) (forall a. a -> Maybe a
Just ExpQ
e2)
genFunOf :: ExpQ -> ExpQ
genFunOf :: ExpQ -> ExpQ
genFunOf = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"genFun"))
funOf :: ExpQ -> ExpQ
funOf :: ExpQ -> ExpQ
funOf = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"fun"))