{-# LANGUAGE TemplateHaskell, CPP #-}
-- |
-- Module      : Data.Express.Express.Derive
-- Copyright   : (c) 2019-2024 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 <- [Q Type] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ [t| $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
c) $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
v) |]
#else
  -- template-haskell <= 2.9.0.0:
  cxt <- sequence [ classP c [return v]
#endif
                  | Name
c <- ''ExpressName -> [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
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
  let withTheReturnTypeOfs :: DecsQ
withTheReturnTypeOfs = [Int] -> DecsQ
deriveWithTheReturnTypeOfs ([Int] -> DecsQ) -> [Int] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [[Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns | (Name
_,[Name]
ns) <- [(Name, [Name])]
cs]
  let generalizableExpr :: DecsQ
generalizableExpr = DecsQ -> DecsQ
mergeIFns (DecsQ -> DecsQ) -> DecsQ -> DecsQ
forall a b. (a -> b) -> a -> b
$ (DecsQ -> DecsQ -> DecsQ) -> [DecsQ] -> DecsQ
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 DecsQ -> DecsQ -> DecsQ
mergeI
        [ do let retTypeOf :: Name
retTypeOf = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
ns) Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
             let exprs :: [Q Exp]
exprs = [[| expr $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
n) |] | Name
n <- [Name]
ns]
             let conex :: Q Exp
conex = [| $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
retTypeOf) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
c) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
asName) |]
             let root :: Q Exp
root = [| value $(String -> Q Exp
forall (m :: * -> *). Quote m => String -> m Exp
stringE (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
showJustName Name
c) $(Q Exp
conex) |]
             let rhs :: Q Exp
rhs = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Q Exp
e1 Q Exp
e2 -> [| $Q Exp
e1 :$ $Q Exp
e2 |]) Q Exp
root [Q Exp]
exprs
             [d| instance Express $(Type -> Q Type
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Type
nt) where
                   expr $(Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
asP Name
asName (Q Pat -> Q Pat) -> Q Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
c ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
ns)) = $Q Exp
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  =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Int] -> Q [[Dec]]) -> [Int] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> DecsQ) -> [Int] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> DecsQ
deriveWithTheReturnTypeOf ([Int] -> Q [[Dec]]) -> ([Int] -> [Int]) -> [Int] -> Q [[Dec]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
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
_  -> [Dec] -> DecsQ
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
  name :: String
name  =  String
"-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'>' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"

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