{-# 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 = deriveWhenNeededOrWarn ''Express reallyDerive
where
reallyDerive = reallyDeriveGeneralizableWithRequisites
deriveGeneralizableIfNeeded :: Name -> DecsQ
deriveGeneralizableIfNeeded = deriveWhenNeeded ''Express reallyDerive
where
reallyDerive = reallyDeriveGeneralizableWithRequisites
deriveGeneralizableCascading :: Name -> DecsQ
deriveGeneralizableCascading = deriveWhenNeeded ''Express reallyDerive
where
reallyDerive t = concat
<$> sequence [ deriveListableCascading t
, deriveNameCascading t
, deriveExpressCascading t
, reallyDeriveGeneralizableCascading t ]
reallyDeriveGeneralizableWithRequisites :: Name -> DecsQ
reallyDeriveGeneralizableWithRequisites t = concat <$>
sequence [ deriveListableIfNeeded t
, deriveNameIfNeeded t
, deriveExpressIfNeeded t
, reallyDeriveGeneralizable t ]
reallyDeriveGeneralizable :: Name -> DecsQ
reallyDeriveGeneralizable t = do
isEq <- t `isInstanceOf` ''Eq
isOrd <- t `isInstanceOf` ''Ord
(nt,vs) <- normalizeType t
#if __GLASGOW_HASKELL__ >= 710
cxt <- sequence [ [t| $(conT c) $(return v) |]
#else
cxt <- sequence [ classP c [return v]
#endif
| c <- ''Generalizable:([''Eq | isEq] ++ [''Ord | isOrd])
, v <- vs]
cs <- typeConstructorsArgNames t
asName <- newName "x"
let generalizableBackground = do
n <- newName "x"
case (isEq, isOrd) of
(True, True) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [ value "==" ((==) -:> $(varE n))
, value "/=" ((/=) -:> $(varE n))
, value "<" ((<) -:> $(varE n))
, value "<=" ((<=) -:> $(varE n)) ] |]
(True, False) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [ value "==" ((==) -:> $(varE n))
, value "/=" ((/=) -:> $(varE n)) ] |]
(False, False) ->
[d| instance Generalizable $(return nt) where
background $(varP n) = [] |]
_ -> error $ "reallyDeriveGeneralizable " ++ show t ++ ": the impossible happened"
let generalizableInstances = do
n <- newName "x"
let lets = [letin n c ns | (c,ns) <- cs, not (null ns)]
let rhs = foldr0 (\e1 e2 -> [| $e1 . $e2 |]) [|id|] lets
[d| instance Generalizable $(return nt) where
subInstances $(varP n) = $rhs |]
cxt |=>| (generalizableBackground `mergeI` generalizableInstances)
reallyDeriveGeneralizableCascading :: Name -> DecsQ
reallyDeriveGeneralizableCascading t =
return . concat
=<< mapM reallyDeriveGeneralizable
=<< filterM (liftM not . isTypeSynonym)
=<< return . (t:) . delete t
=<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Generalizable)
letin :: Name -> Name -> [Name] -> ExpQ
letin x c ns = do
und <- VarE <$> lookupValN "undefined"
let lhs = conP c (map varP ns)
let rhs = return $ foldl AppE (ConE c) [und | _ <- ns]
let bot = foldl1 (\e1 e2 -> [| $e1 . $e2 |])
[ [| instances $(varE n) |] | n <- ns ]
[| let $lhs = $rhs `asTypeOf` $(varE x) in $bot |]