{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.DeriveLiftedInstances.Internal where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift)
import Data.Char (isAlpha)
import Data.Data (Data, gmapQl, cast)
import Data.Maybe (fromMaybe, catMaybes)
import Data.Traversable (for)
data Derivator = Derivator {
Derivator -> Q Exp -> Q Exp
res :: Q Exp -> Q Exp,
Derivator -> Name -> Q Exp -> Q Exp
op :: Name -> Q Exp -> Q Exp,
Derivator -> Type -> Q Exp -> Q Exp
arg :: Type -> Q Exp -> Q Exp,
Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp,
Derivator -> Q Exp -> Q Exp -> Q Exp
ap :: Q Exp -> Q Exp -> Q Exp
}
varExp :: Name -> Q Exp
varExp :: Name -> Q Exp
varExp = Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (Name -> Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE
varPat :: Name -> Q Pat
varPat :: Name -> Q Pat
varPat = Pat -> Q Pat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> (Name -> Pat) -> Name -> Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Pat
VarP
idDeriv :: Derivator
idDeriv :: Derivator
idDeriv = Derivator :: (Q Exp -> Q Exp)
-> (Name -> Q Exp -> Q Exp)
-> (Type -> Q Exp -> Q Exp)
-> ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp)
-> Derivator
Derivator {
res :: Q Exp -> Q Exp
res = Q Exp -> Q Exp
forall a. a -> a
id,
op :: Name -> Q Exp -> Q Exp
op = (Q Exp -> Q Exp) -> Name -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
arg :: Type -> Q Exp -> Q Exp
arg = (Q Exp -> Q Exp) -> Type -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = (Q Exp -> Q Exp) -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. a -> b -> a
const Q Exp -> Q Exp
forall a. a -> a
id,
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| $f $a |]
}
deriveInstance :: Derivator -> Q Type -> Q [Dec]
deriveInstance :: Derivator -> Q Type -> Q [Dec]
deriveInstance Derivator
deriv Q Type
qtyp = do
Type
typ <- Q Type
qtyp
case Type
typ of
ForallT [TyVarBndr]
_ Cxt
ctx (AppT (ConT Name
className) Type
typeName) ->
Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv Cxt
ctx Name
className Type
typeName
AppT (ConT Name
className) Type
typeName ->
Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv [] Name
className Type
typeName
Type
_ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String
"No support for type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
typ
deriveInstance' :: Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' :: Derivator -> Cxt -> Name -> Type -> Q [Dec]
deriveInstance' Derivator
deriv Cxt
ctx Name
className Type
typeName = do
ClassI (ClassD Cxt
_ Name
_ [KindedTV Name
tvn Type
_] [FunDep]
_ [Dec]
decs) [Dec]
_ <- Name -> Q Info
reify Name
className
[Maybe Dec]
impl <- [Dec] -> (Dec -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Dec]
decs ((Dec -> Q (Maybe Dec)) -> Q [Maybe Dec])
-> (Dec -> Q (Maybe Dec)) -> Q [Maybe Dec]
forall a b. (a -> b) -> a -> b
$ \case
SigD Name
nm Type
tp -> do
Info
dec <- Name -> Q Info
reify Name
nm
case Info
dec of
ClassOpI{} -> do
([Name]
argNames, Exp
body) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
deriv Name
tvn Type
tp (Derivator -> Name -> Q Exp -> Q Exp
op Derivator
deriv Name
nm (Name -> Q Exp
varExp Name
nm))
let args :: [Pat]
args = (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
argName -> if Name -> Exp -> Bool
forall d. Data d => Name -> d -> Bool
contains Name
argName Exp
body then Name -> Pat
VarP Name
argName else Pat
WildP) [Name]
argNames
Maybe Dec -> Q (Maybe Dec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Dec -> Q (Maybe Dec)) -> Maybe Dec -> Q (Maybe Dec)
forall a b. (a -> b) -> a -> b
$ Dec -> Maybe Dec
forall a. a -> Maybe a
Just (Dec -> Maybe Dec) -> Dec -> Maybe Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Clause] -> Dec
FunD Name
nm [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
args (Exp -> Body
NormalB Exp
body) []]
Info
_ -> String -> Q (Maybe Dec)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe Dec)) -> String -> Q (Maybe Dec)
forall a b. (a -> b) -> a -> b
$ String
"No support for declaration: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
dec
Dec
_ -> Maybe Dec -> Q (Maybe Dec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Dec
forall a. Maybe a
Nothing
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing Cxt
ctx (Type -> Type -> Type
AppT (Name -> Type
ConT Name
className) Type
typeName) ([Dec] -> Dec) -> [Dec] -> Dec
forall a b. (a -> b) -> a -> b
$ [Maybe Dec] -> [Dec]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Dec]
impl]
buildOperation :: Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation :: Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm (AppT (AppT Type
ArrowT Type
h) Type
t) Q Exp
e | Name -> Type -> Bool
hasVar Name
nm Type
h = do
Name
varNm <- String -> Q Name
newName String
"var"
([Name]
args, Exp
rhs) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t (Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
d Q Exp
e (Derivator -> (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var Derivator
d (Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument Name
nm Type
h) (Name -> Q Exp
varExp Name
varNm)))
([Name], Exp) -> Q ([Name], Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
varNm Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args, Exp
rhs)
buildOperation Derivator
d Name
nm (AppT (AppT Type
ArrowT Type
h) Type
t) Q Exp
e = do
Name
varNm <- String -> Q Name
newName String
"arg"
([Name]
args, Exp
rhs) <- Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t (Derivator -> Q Exp -> Q Exp -> Q Exp
ap Derivator
d Q Exp
e (Derivator -> Type -> Q Exp -> Q Exp
arg Derivator
d Type
h (Name -> Q Exp
varExp Name
varNm)))
([Name], Exp) -> Q ([Name], Exp)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
varNm Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
args, Exp
rhs)
buildOperation Derivator
d Name
nm (ForallT [TyVarBndr]
_ Cxt
_ Type
t) Q Exp
e = Derivator -> Name -> Type -> Q Exp -> Q ([Name], Exp)
buildOperation Derivator
d Name
nm Type
t Q Exp
e
buildOperation Derivator
d Name
nm Type
t Q Exp
e | Name -> Type -> Bool
isVar Name
nm Type
t = ([],) (Exp -> ([Name], Exp)) -> Q Exp -> Q ([Name], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Derivator -> Q Exp -> Q Exp
res Derivator
d Q Exp
e
| Bool
otherwise = ([],) (Exp -> ([Name], Exp)) -> Q Exp -> Q ([Name], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
e
buildArgument :: Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument :: Name -> Type -> Q Exp -> Q Exp -> Q Exp
buildArgument Name
nm (AppT Type
h Type
_) Q Exp
_ Q Exp
var | Name -> Type -> Bool
isVar Name
nm Type
h = Q Exp
var
buildArgument Name
nm (AppT Type
_ Type
h) Q Exp
over Q Exp
var = [| $over $(buildArgument nm h over var) |]
buildArgument Name
_ Type
_ Q Exp
_ Q Exp
var = Q Exp
var
isVar :: Name -> Type -> Bool
isVar :: Name -> Type -> Bool
isVar Name
nm (VarT Name
nm') = Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm'
isVar Name
nm (AppT Type
h Type
_) = Name -> Type -> Bool
isVar Name
nm Type
h
isVar Name
_ Type
_ = Bool
False
hasVar :: Name -> Type -> Bool
hasVar :: Name -> Type -> Bool
hasVar Name
nm (VarT Name
nm') = Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm'
hasVar Name
nm (AppT Type
f Type
a) = Name -> Type -> Bool
isVar Name
nm Type
f Bool -> Bool -> Bool
|| Name -> Type -> Bool
hasVar Name
nm Type
a
hasVar Name
_ Type
_ = Bool
False
tvName :: TyVarBndr -> Name
tvName :: TyVarBndr -> Name
tvName (PlainTV Name
nm) = Name
nm
tvName (KindedTV Name
nm Type
_) = Name
nm
contains :: Data d => Name -> d -> Bool
contains :: Name -> d -> Bool
contains Name
nm = (Bool -> Bool -> Bool)
-> Bool -> (forall d. Data d => d -> Bool) -> d -> Bool
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
gmapQl Bool -> Bool -> Bool
(||) Bool
False (\d
d -> Bool -> (Name -> Bool) -> Maybe Name -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Name -> d -> Bool
forall d. Data d => Name -> d -> Bool
contains Name
nm d
d) (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm) (Maybe Name -> Bool) -> Maybe Name -> Bool
forall a b. (a -> b) -> a -> b
$ d -> Maybe Name
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast d
d)
deriving instance Lift Fixity
deriving instance Lift FixityDirection
data ShowsPrec = ShowsPrec (Int -> String -> String) | ShowOp2 Fixity (Int -> String -> String) | ShowOp1 Fixity (Int -> String -> String)
instance Show ShowsPrec where
showsPrec :: Int -> ShowsPrec -> String -> String
showsPrec Int
d (ShowsPrec Int -> String -> String
f) = Int -> String -> String
f Int
d
showsPrec Int
d (ShowOp2 (Fixity Int
p FixityDirection
_) Int -> String -> String
f) = Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
0
showsPrec Int
_ (ShowOp1 Fixity
_ Int -> String -> String
f) = Bool -> (String -> String) -> String -> String
showParen Bool
True ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
0
showAp :: ShowsPrec -> ShowsPrec -> ShowsPrec
showAp :: ShowsPrec -> ShowsPrec -> ShowsPrec
showAp (ShowsPrec Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = (Int -> String -> String) -> ShowsPrec
ShowsPrec ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
d -> Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
f Int
10 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
g Int
11
showAp (ShowOp2 fx :: Fixity
fx@(Fixity Int
p FixityDirection
i) Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = Fixity -> (Int -> String -> String) -> ShowsPrec
ShowOp1 Fixity
fx ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
_ -> Int -> String -> String
g (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (FixityDirection
i FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityDirection
InfixL)) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
f Int
0
showAp (ShowOp1 (Fixity Int
p FixityDirection
i) Int -> String -> String
f) (ShowsPrec Int -> String -> String
g) = (Int -> String -> String) -> ShowsPrec
ShowsPrec ((Int -> String -> String) -> ShowsPrec)
-> (Int -> String -> String) -> ShowsPrec
forall a b. (a -> b) -> a -> b
$ \Int
d -> Bool -> (String -> String) -> String -> String
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
p) (Int -> String -> String
f Int
0 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
g (Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Bool -> Int
forall a. Enum a => a -> Int
fromEnum (FixityDirection
i FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
/= FixityDirection
InfixR)))
showAp ShowsPrec
_ ShowsPrec
_ = String -> ShowsPrec
forall a. HasCallStack => String -> a
error String
"Unexpected use of showAp"
showDeriv :: Derivator
showDeriv :: Derivator
showDeriv = Derivator
idDeriv {
op :: Name -> Q Exp -> Q Exp
op = \Name
nm Q Exp
_ -> let name :: String
name = Name -> String
nameBase Name
nm in if String -> Bool
isOperator String
name
then do
Fixity
fx <- Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity (Maybe Fixity -> Fixity) -> Q (Maybe Fixity) -> Q Fixity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q (Maybe Fixity)
reifyFixity Name
nm
[| ShowOp2 fx $ const $ showString $(pure . LitE . StringL $ name) |]
else
[| ShowsPrec $ const $ showString $(pure . LitE . StringL $ name) |],
arg :: Type -> Q Exp -> Q Exp
arg = \case
(VarT Name
_) -> Q Exp -> Q Exp -> Q Exp
forall a b. a -> b -> a
const [| ShowsPrec $ const (showString "#Unshowable#") |]
Type
_ -> \Q Exp
v -> [| ShowsPrec $ flip showsPrec $v |],
var :: (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp
var = \Q Exp -> Q Exp -> Q Exp
_ Q Exp
v -> [| ShowsPrec $ flip showsPrec $v |],
ap :: Q Exp -> Q Exp -> Q Exp
ap = \Q Exp
f Q Exp
a -> [| showAp $f $a |]
}
isOperator :: String -> Bool
isOperator :: String -> Bool
isOperator (Char
c:String
_) = Bool -> Bool
not (Char -> Bool
isAlpha Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_'
isOperator String
_ = Bool
False