{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Data.Express.Express.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 'Express' typeclass instances.
module Data.Express.Express.Derive
  ( deriveExpress
  , deriveExpressCascading
  , deriveExpressIfNeeded
  )
where

import Data.Express.Core
import Data.Express.Express

import Control.Monad
import Data.Char
import Data.List
import Data.Express.Utils.TH
import Data.Express.Utils.List
import Data.Express.Utils.String
import Language.Haskell.TH.Lib

-- | Derives an 'Express' instance for the given type 'Name'.
--
-- This function needs the @TemplateHaskell@ extension.
--
-- If '-:', '->:', '->>:', '->>>:', ... are not in scope,
-- this will derive them as well.
deriveExpress :: Name -> DecsQ
deriveExpress :: Name -> DecsQ
deriveExpress  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeededOrWarn ''Express Name -> DecsQ
reallyDeriveExpress

-- | Same as 'deriveExpress' but does not warn when instance already exists
--   ('deriveExpress' is preferable).
deriveExpressIfNeeded :: Name -> DecsQ
deriveExpressIfNeeded :: Name -> DecsQ
deriveExpressIfNeeded  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Express Name -> DecsQ
reallyDeriveExpress

-- | Derives a 'Express' instance for a given type 'Name'
--   cascading derivation of type arguments as well.
deriveExpressCascading :: Name -> DecsQ
deriveExpressCascading :: Name -> DecsQ
deriveExpressCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
deriveWhenNeeded ''Express Name -> DecsQ
reallyDeriveExpressCascading

reallyDeriveExpress :: Name -> DecsQ
reallyDeriveExpress :: Name -> DecsQ
reallyDeriveExpress 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 <- ''Expressforall 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 generalizableExpr :: DecsQ
generalizableExpr = DecsQ -> DecsQ
mergeIFns forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 DecsQ -> DecsQ -> DecsQ
mergeI
        [ do let retTypeOf :: Name
retTypeOf = 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 exprs :: [Q Exp]
exprs = [[| expr $(varE n) |] | Name
n <- [Name]
ns]
             let conex :: Q Exp
conex = [| $(varE retTypeOf) $(conE c) $(varE asName) |]
             let root :: Q Exp
root = [| value $(stringE $ showJustName c) $(conex) |]
             let rhs :: Q Exp
rhs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e1 Q Exp
e2 -> [| $e1 :$ $e2 |]) Q Exp
root [Q Exp]
exprs
             [d| instance Express $(return nt) where
                   expr $(asP asName $ conP c (map varP ns)) = $rhs |]
        | (Name
c,[Name]
ns) <- [(Name, [Name])]
cs
        ]
  DecsQ
withTheReturnTypeOfs DecsQ -> DecsQ -> DecsQ
|++| ([Type]
cxt [Type] -> DecsQ -> DecsQ
|=>| DecsQ
generalizableExpr)

-- Not only really derive Express instances,
-- but cascade through argument types.
reallyDeriveExpressCascading :: Name -> DecsQ
reallyDeriveExpressCascading :: Name -> DecsQ
reallyDeriveExpressCascading  =  Name -> (Name -> DecsQ) -> Name -> DecsQ
reallyDeriveCascading ''Express Name -> DecsQ
reallyDeriveExpress

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