{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Conjure.Conjurable.Derive
-- Copyright   : (c) 2019-2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Allows automatic derivation of 'Conjurable' typeclass instances.
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

-- | Derives an 'Conjurable' instance for the given type 'Name'.
--
-- This function needs the @TemplateHaskell@ extension.
--
-- If '-:', '->:', '->>:', '->>>:', ... are not in scope,
-- this will derive them as well.
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
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

-- | Same as 'deriveConjurable' but does not warn when instance already exists
--   ('deriveConjurable' is preferable).
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
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

-- | Derives a 'Conjurable' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
--
-- For now,
-- this function only derives
-- 'conjureEquality',
-- 'conjureTiers' and
-- 'conjureExpress'
-- and does not derive
-- 'conjureSubTypes',
-- 'conjureArgumentCases' and
-- 'conjureSize'.
-- These will be added in future versions.
-- If you plan to use features that depend on these functionalities,
-- please define your instances manually.
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading :: Name -> DecsQ
deriveConjurableCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Conjurable Name -> DecsQ
reallyDerive
  where
  reallyDerive :: Name -> DecsQ
reallyDerive Name
t  =  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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  =  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  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 <- 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 <- [''Conjurable, ''Listable, ''Express] forall a. [a] -> [a] -> [a]
++ [''Eq | Bool
isEq] forall a. [a] -> [a] -> [a]
++ [''Ord | Bool
isOrd]
                  , Type
v <- [Type]
vs]
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  Name
asName <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  let withTheReturnTypeOfs :: DecsQ
withTheReturnTypeOfs = [Int] -> DecsQ
deriveWithTheReturnTypeOfs forall a b. (a -> b) -> a -> b
$ [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 |]
  -- withTheReturnTypeOfs |++| (cxt |=>| inst)
  [Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| DecsQ
inst DecsQ -> DecsQ -> DecsQ
`addFun` Name -> DecsQ
deriveSize Name
t DecsQ -> DecsQ -> DecsQ
`mergeI` Name -> DecsQ
deriveSubTypes Name
t DecsQ -> DecsQ -> DecsQ
`mergeI` Name -> DecsQ
deriveCases Name
t
-- TODO: derive conjureCases, e.g.:
-- conjureCases mx  =  [ value "Nothing" (Nothing -: mx)
--                     , value "Just" (Just ->: mx) :$ hole x
--                     ]

deriveCases :: Name -> DecsQ
deriveCases :: Name -> DecsQ
deriveCases Name
t  =  do
  Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  let lets :: [ExpQ]
lets = [Name -> Name -> [Name] -> ExpQ
letin Name
n Name
c [Name]
ns | (Name
c,[Name]
ns) <- [(Name, [Name])]
cs]
  let rhs :: ExpQ
rhs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ExpQ
e1 ExpQ
e2 -> [| $e1 : $e2 |]) [|[]|] [ExpQ]
lets
  [d| instance Conjurable $(return nt) where
        conjureCases $(varP n) = $rhs |]
  where
  letin :: Name -> Name -> [Name] -> ExpQ
  letin :: Name -> Name -> [Name] -> ExpQ
letin Name
x Name
c [Name]
ns = do
    Exp
und <- Name -> Exp
VarE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
lookupValN String
"undefined"
    let lhs :: Q Pat
lhs = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)
    let rhs :: ExpQ
rhs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 retTypeOf :: ExpQ
retTypeOf = forall (m :: * -> *). Quote m => Name -> m Exp
varE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns) Char
'>' forall a. [a] -> [a] -> [a]
++ String
":"
    let ins :: ExpQ
ins = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
e1 ExpQ
e2 -> [| $e1 :$ $e2 |])
                [| value $(stringE $ nameBase c) ($retTypeOf $(conE c) $(varE x)) |]
                [ [| hole $(varE n) |] | Name
n <- [Name]
ns ]
    [| let $lhs = $rhs `asTypeOf` $(varE x) in $ins |]

deriveSubTypes :: Name -> DecsQ
deriveSubTypes :: Name -> DecsQ
deriveSubTypes Name
t  =  do
  Name
n <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  (Type
nt,[Type]
vs) <- Name -> Q (Type, [Type])
normalizeType Name
t
  [(Name, [Name])]
cs <- Name -> Q [(Name, [Name])]
typeConstructorsArgNames Name
t
  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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
ns)]
  let rhs :: ExpQ
rhs = forall a. (a -> a -> a) -> a -> [a] -> a
foldr0 (\ExpQ
e1 ExpQ
e2 -> [| $e1 . $e2 |]) [|id|] [ExpQ]
lets
  [d| instance Conjurable $(return nt) where
        conjureSubTypes $(varP n) = $rhs |]
  where
  letin :: Name -> Name -> [Name] -> ExpQ
  letin :: Name -> Name -> [Name] -> ExpQ
letin Name
x Name
c [Name]
ns = do
    Exp
und <- Name -> Exp
VarE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
lookupValN String
"undefined"
    let lhs :: Q Pat
lhs = forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)
    let rhs :: ExpQ
rhs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\ExpQ
e1 ExpQ
e2 -> [| $e1 . $e2 |])
                     [ [| conjureType $(varE n) |] | Name
n <- [Name]
ns ]
    [| let $lhs = $rhs `asTypeOf` $(varE x) in $bot |]

deriveSize :: Name -> DecsQ
deriveSize :: Name -> DecsQ
deriveSize Name
t  =  ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"conjureSize")) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Clause]
deriveSizeClauses Name
t

deriveSizeClauses :: Name -> Q [Clause]
deriveSizeClauses :: Name -> Q [Clause]
deriveSizeClauses Name
t  =  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Type] -> Q Clause
mkClause) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Name -> Q [(Name, [Type])]
typeConstructors Name
t
  where
  mkClause :: Name -> [Type] -> Q Clause
  mkClause :: Name -> [Type] -> Q Clause
mkClause Name
n [Type]
as  =  forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pat Q Body
body []
    where
    ns :: [Name]
ns  =  forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
as) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Name
mkName (String -> [String]
variableNamesFromTemplate String
"x")
    pat :: [Q Pat]
pat  =  [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
n [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
n | Name
n <- [Name]
ns]]
    body :: Q Body
body  =  forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ExpQ
e Name
n -> [| $e + conjureSize $(varE n) |]) [| 1 |] [Name]
ns

-- Not only really derive Conjurable instances,
-- but cascade through argument types.
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading :: Name -> DecsQ
reallyDeriveConjurableCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading ''Conjurable Name -> DecsQ
reallyDeriveConjurable

deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs :: [Int] -> DecsQ
deriveWithTheReturnTypeOfs  =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> DecsQ
deriveWithTheReturnTypeOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
  name :: String
name  =  String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
n Char
'>' forall a. [a] -> [a] -> [a]
++ String
":"

reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf :: Int -> DecsQ
reallyDeriveWithTheReturnTypeOf Int
n  =  do
  Dec
td <- forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
name Q Type
theT
  [Dec]
vd <- [d| $(varP name) = const |]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Dec
tdforall a. a -> [a] -> [a]
:[Dec]
vd
  where
  theT :: Q Type
theT  =  forall {a}. a -> a
bind [t| $(theFunT) -> $(last vars) -> $(theFunT) |]
  theFunT :: Q Type
theFunT  =  forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall {m :: * -> *}. Quote m => m Type -> m Type -> m Type
funT [Q Type]
vars
  funT :: m Type -> m Type -> m Type
funT m Type
t1 m Type
t2  =  [t| $(t1) -> $(t2) |]
  vars :: [Q Type]
vars  =  forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Quote m => Name -> m Type
varT forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
primeCycle forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
:String
"") [Char
'a'..Char
'z']
  name :: Name
name  =  String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"-" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
n Char
'>' forall a. [a] -> [a] -> [a]
++ String
":"
#if __GLASGOW_HASKELL__ >= 800
  bind :: a -> a
bind  =  forall {a}. a -> a
id -- unbound variables are automatically bound
#else
  bind  =  toBoundedQ
#endif

addFun :: DecsQ -> DecsQ -> DecsQ
DecsQ
qds1 addFun :: DecsQ -> DecsQ -> DecsQ
`addFun` DecsQ
qds2 = do [Dec]
ds1 <- DecsQ
qds1
                        [Dec]
ds2 <- DecsQ
qds2
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Dec]
ds1 [Dec] -> [Dec] -> [Dec]
`m` [Dec]
ds2
  where
#if __GLASGOW_HASKELL__ < 800
  [InstanceD   c ts ds1] `m` ds2 = [InstanceD   c ts (ds1 ++ ds2)]
#else
  [InstanceD Maybe Overlap
o [Type]
c Type
ts [Dec]
ds1] m :: [Dec] -> [Dec] -> [Dec]
`m` [Dec]
ds2 = [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
o [Type]
c Type
ts ([Dec]
ds1 forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)]
#endif