{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Test.Extrapolate.Generalizable.Derive
-- Copyright   : (c) 2017-2019 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of Extrapolate,
-- a library for generalization of counter-examples.
--
-- This is a module for deriving 'Generalizable' instances.
--
-- Needs GHC and Template Haskell (tested on GHC 8.0).
--
-- If Extrapolate does not compile under later GHCs, this module is the
-- probable culprit.
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 ((<$>)) -- for GHC <= 7.8
import Data.List (delete)


-- | Derives a 'Generalizable' instance for a given type 'Name'.
--
-- If needed, this function also automatically derivates
-- 'Listable', 'Express' and 'Name' instances using respectively
-- 'deriveListable', 'deriveExpress' and 'deriveName'.
--
-- Consider the following @Stack@ datatype:
--
-- > data Stack a = Stack a (Stack a) | Empty
--
-- Writing
--
-- > deriveGeneralizable ''Stack
--
-- will automatically derive the following 'Generalizable' instance:
--
-- > instance Generalizable a => Generalizable (Stack a) where
-- >   instances s = this "s" s
-- >               $ let Stack x y = Stack undefined undefined `asTypeOf` s
-- >                 in instances x
-- >                  . instances y
--
-- This function needs the @TemplateHaskell@ extension.
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

-- | Same as 'deriveGeneralizable' but does not warn when instance already exists
--   ('deriveGeneralizable' is preferable).
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

-- | Derives a 'Generalizable' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
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
  -- template-haskell <= 2.9.0.0:
  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)

-- Not only really derive Generalizable instances,
-- but cascade through argument types.
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 |]