{-# LANGUAGE TemplateHaskell, CPP #-}
module Conjure.Conjurable.Derive
( deriveConjurable
, deriveConjurableCascading
, deriveConjurableIfNeeded
)
where
import Test.LeanCheck
import Test.LeanCheck.Derive
import Test.LeanCheck.Utils
import Conjure.Expr hiding (mkName, Name, isInstanceOf)
import Conjure.Conjurable hiding (Name)
import Data.Express.Utils (primeCycle)
import Data.Express.Utils.TH
import Control.Monad
import Data.Char
import Data.List
import Language.Haskell.TH.Lib
#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif
deriveConjurable :: Name -> DecsQ
deriveConjurable :: Name -> DecsQ
deriveConjurable = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn ''Conjurable Name -> DecsQ
reallyDerive
where
reallyDerive :: Name -> DecsQ
reallyDerive = Name -> DecsQ
reallyDeriveConjurableWithRequisites
deriveConjurableIfNeeded :: Name -> DecsQ
deriveConjurableIfNeeded :: Name -> DecsQ
deriveConjurableIfNeeded = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Conjurable Name -> DecsQ
reallyDerive
where
reallyDerive :: Name -> DecsQ
reallyDerive = Name -> DecsQ
reallyDeriveConjurableWithRequisites
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Conjurable Name -> DecsQ
reallyDerive
where
reallyDerive :: Name -> DecsQ
reallyDerive Name
t = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> DecsQ
deriveListableCascading Name
t
, Name -> DecsQ
deriveNameCascading Name
t
, Name -> DecsQ
deriveExpressCascading Name
t
, Name -> DecsQ
reallyDeriveConjurableCascading Name
t ]
reallyDeriveConjurableWithRequisites :: Name -> DecsQ
reallyDeriveConjurableWithRequisites :: Name -> DecsQ
reallyDeriveConjurableWithRequisites Name
t = [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[DecsQ] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> DecsQ
deriveListableIfNeeded Name
t
, Name -> DecsQ
deriveNameIfNeeded Name
t
, Name -> DecsQ
deriveExpressIfNeeded Name
t
, Name -> DecsQ
reallyDeriveConjurable Name
t ]
reallyDeriveConjurable :: Name -> DecsQ
reallyDeriveConjurable :: Name -> DecsQ
reallyDeriveConjurable Name
t = do
Bool
isEq <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Eq
Bool
isOrd <- Name
t Name -> Name -> Q Bool
`isInstanceOf` ''Ord
(Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
#if __GLASGOW_HASKELL__ >= 710
[Type]
cxt <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ [t| $(conT c) $(return v) |]
#else
cxt <- sequence [ classP c [return v]
#endif
| Name
c <- [''Conjurable, ''Listable, ''Express] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''Eq | Bool
isEq] [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [''Ord | Bool
isOrd]
, Type
v <- [Type]
vs]
[(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
Name
asName <- String -> Q Name
newName String
"x"
let withTheReturnTypeOfs :: DecsQ
withTheReturnTypeOfs = [Int] -> DecsQ
deriveWithTheReturnTypeOfs ([Int] -> DecsQ) -> [Int] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [[Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns | (Name
_,[Name]
ns) <- [(Name, [Name])]
cs]
let inst :: DecsQ
inst = [d| instance Conjurable $(return nt) where
conjureExpress = reifyExpress
conjureEquality = reifyEquality
conjureTiers = reifyTiers |]
[Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| DecsQ
inst
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading = Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading ''Conjurable Name -> DecsQ
reallyDeriveConjurable
deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs =
([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Int] -> Q [[Dec]]) -> [Int] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> DecsQ) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> DecsQ
deriveWithTheReturnTypeOf ([Int] -> Q [[Dec]]) -> ([Int] -> [Int]) -> [Int] -> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubSort
deriveWithTheReturnTypeOf :: Int -> DecsQ
deriveWithTheReturnTypeOf :: Int -> DecsQ
deriveWithTheReturnTypeOf Int
n = do
Maybe Name
mf <- String -> Q (Maybe Name)
lookupValueName String
name
case Maybe Name
mf of
Maybe Name
Nothing -> Int -> DecsQ
reallyDeriveWithTheReturnTypeOf Int
n
Just Name
_ -> [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
name :: String
name = String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf Int
n = do
Dec
td <- Name -> Q Type -> DecQ
sigD Name
name Q Type
theT
[Dec]
vd <- [d| $(varP name) = const |]
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ Dec
tdDec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[Dec]
vd
where
theT :: Q Type
theT = Q Type -> Q Type
forall a. a -> a
bind [t| $(theFunT) -> $(last vars) -> $(theFunT) |]
theFunT :: Q Type
theFunT = (Q Type -> Q Type -> Q Type) -> [Q Type] -> Q Type
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Type -> Q Type -> Q Type
funT [Q Type]
vars
funT :: Q Type -> Q Type -> Q Type
funT Q Type
t1 Q Type
t2 = [t| $(t1) -> $(t2) |]
vars :: [Q Type]
vars = (String -> Q Type) -> [String] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Type
varT (Name -> Q Type) -> (String -> Name) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) ([String] -> [Q Type])
-> ([String] -> [String]) -> [String] -> [Q Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
primeCycle ([String] -> [Q Type]) -> [String] -> [Q Type]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> String
forall a. a -> [a] -> [a]
:String
"") [Char
'a'..Char
'z']
name :: Name
name = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
#if __GLASGOW_HASKELL__ >= 800
bind :: a -> a
bind = a -> a
forall a. a -> a
id
#else
bind = toBoundedQ
#endif