{-# LANGUAGE TemplateHaskell, CPP #-}
module Test.Extrapolate.Generalizable.Derive
( deriveGeneralizable
, deriveGeneralizableIfNeeded
, deriveGeneralizableCascading
)
where
import Test.Extrapolate.Generalizable hiding (Name, isInstanceOf)
import Test.Extrapolate.Utils (foldr0)
import Test.LeanCheck.Derive (deriveListableIfNeeded, deriveListableCascading)
import Test.LeanCheck.Utils.TypeBinding ((-:>))
import Language.Haskell.TH
import Data.Express.Utils.TH
import Control.Monad (liftM, filterM)
import Data.Functor ((<$>))
import Data.List (delete)
deriveGeneralizable :: Name -> DecsQ
deriveGeneralizable :: Name -> DecsQ
deriveGeneralizable = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn ''Express Name -> DecsQ
reallyDerive
where
reallyDerive :: Name -> DecsQ
reallyDerive = Name -> DecsQ
reallyDeriveGeneralizableWithRequisites
deriveGeneralizableIfNeeded :: Name -> DecsQ
deriveGeneralizableIfNeeded :: Name -> DecsQ
deriveGeneralizableIfNeeded = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Express Name -> DecsQ
reallyDerive
where
reallyDerive :: Name -> DecsQ
reallyDerive = Name -> DecsQ
reallyDeriveGeneralizableWithRequisites
deriveGeneralizableCascading :: Name -> DecsQ
deriveGeneralizableCascading :: Name -> DecsQ
deriveGeneralizableCascading = Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Express 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
reallyDeriveGeneralizableCascading Name
t ]
reallyDeriveGeneralizableWithRequisites :: Name -> DecsQ
reallyDeriveGeneralizableWithRequisites :: Name -> DecsQ
reallyDeriveGeneralizableWithRequisites 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
reallyDeriveGeneralizable Name
t ]
reallyDeriveGeneralizable :: Name -> DecsQ
reallyDeriveGeneralizable :: Name -> DecsQ
reallyDeriveGeneralizable 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 <- ''GeneralizableName -> [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 generalizableBackground :: DecsQ
generalizableBackground = do
Name
n <- String -> Q Name
newName String
"x"
case (Bool
isEq, Bool
isOrd) of
(Bool
True, Bool
True) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [ value "==" ((==) -:> $(varE n))
, value "/=" ((/=) -:> $(varE n))
, value "<" ((<) -:> $(varE n))
, value "<=" ((<=) -:> $(varE n)) ] |]
(Bool
True, Bool
False) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [ value "==" ((==) -:> $(varE n))
, value "/=" ((/=) -:> $(varE n)) ] |]
(Bool
False, Bool
False) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [] |]
(Bool, Bool)
_ -> String -> DecsQ
forall a. HasCallStack => String -> a
error (String -> DecsQ) -> String -> DecsQ
forall a b. (a -> b) -> a -> b
$ String
"reallyDeriveGeneralizable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": the impossible happened"
let generalizableInstances :: DecsQ
generalizableInstances = do
Name
n <- String -> Q Name
newName String
"x"
let lets :: [ExpQ]
lets = [Name -> Name -> [Name] -> ExpQ
letin Name
n Name
c [Name]
ns | (Name
c,[Name]
ns) <- [(Name, [Name])]
cs, Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ns)]
let rhs :: ExpQ
rhs = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall a. (a -> a -> a) -> a -> [a] -> a
foldr0 (\ExpQ
e1 ExpQ
e2 -> [| $e1 . $e2 |]) [|id|] [ExpQ]
lets
[d| instance Generalizable $(return nt) where
subInstances $(varP n) = $rhs |]
[Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| (DecsQ
generalizableBackground DecsQ -> DecsQ -> DecsQ
`mergeI` DecsQ
generalizableInstances)
reallyDeriveGeneralizableCascading :: Name -> DecsQ
reallyDeriveGeneralizableCascading :: Name -> DecsQ
reallyDeriveGeneralizableCascading Name
t =
[Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> DecsQ) -> ([[Dec]] -> [Dec]) -> [[Dec]] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
([[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Name -> DecsQ) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> DecsQ
reallyDeriveGeneralizable
([Name] -> Q [[Dec]]) -> Q [Name] -> Q [[Dec]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Name -> Q Bool) -> [Name] -> Q [Name]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> Q Bool -> Q Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (Q Bool -> Q Bool) -> (Name -> Q Bool) -> Name -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Bool
isTypeSynonym)
([Name] -> Q [Name]) -> Q [Name] -> Q [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Name] -> Q [Name]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Q [Name]) -> ([Name] -> [Name]) -> [Name] -> Q [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name
tName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:) ([Name] -> [Name]) -> ([Name] -> [Name]) -> [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Name] -> [Name]
forall a. Eq a => a -> [a] -> [a]
delete Name
t
([Name] -> Q [Name]) -> Q [Name] -> Q [Name]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name
t Name -> (Name -> Q Bool) -> Q [Name]
`typeConCascadingArgsThat` (Name -> Name -> Q Bool
`isntInstanceOf` ''Generalizable)
letin :: Name -> Name -> [Name] -> ExpQ
letin :: Name -> Name -> [Name] -> ExpQ
letin Name
x Name
c [Name]
ns = do
Exp
und <- Name -> Exp
VarE (Name -> Exp) -> Q Name -> ExpQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
lookupValN String
"undefined"
let lhs :: PatQ
lhs = Name -> [PatQ] -> PatQ
conP Name
c ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
ns)
let rhs :: ExpQ
rhs = Exp -> ExpQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> ExpQ) -> Exp -> ExpQ
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
c) [Exp
und | Name
_ <- [Name]
ns]
let bot :: ExpQ
bot = (ExpQ -> ExpQ -> ExpQ) -> [ExpQ] -> ExpQ
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ExpQ
e1 ExpQ
e2 -> [| $e1 . $e2 |])
[ [| instances $(varE n) |] | Name
n <- [Name]
ns ]
[| let $lhs = $rhs `asTypeOf` $(varE x) in $bot |]