{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Algebra.TH
( deriveInstance
, deriveInstanceWith
, deriveInstanceWith_skipSignature
, deriveSuperclassInstances
, deriveSignature
, SignatureTH(..)
, OperationTH(..)
, SuperclassTH(..)
, getSignatureInfo
, buildSignatureDataType
, signatureInstances
) where
import Data.Algebra.Internal
import Data.Traversable (for)
import Control.Arrow ((***))
import Data.Monoid (Endo(..))
import Data.Maybe (catMaybes, fromMaybe)
import Data.Char (isAlpha)
import Data.List (nubBy)
import Data.Function (on)
import Language.Haskell.TH
import Data.Generics (Data, everywhere, mkT)
data SignatureTH = SignatureTH
{ SignatureTH -> Name
signatureName :: Name
, SignatureTH -> Name
typeVarName :: Name
, SignatureTH -> [OperationTH]
operations :: [OperationTH]
, SignatureTH -> [SuperclassTH]
superclasses :: [SuperclassTH]
}
data OperationTH = OperationTH
{ OperationTH -> Name
functionName :: Name
, OperationTH -> Name
operationName :: Name
, OperationTH -> Int
arity :: Int
, OperationTH -> Con
constructor :: Con
, OperationTH -> Fixity
fixity :: Fixity
}
data SuperclassTH = SuperclassTH
{ SuperclassTH -> Name
superclassName :: Name
, SuperclassTH -> Name
constrName :: Name
, SuperclassTH -> SignatureTH
signatureTH :: SignatureTH
}
getSignatureInfo :: Name -> Q SignatureTH
getSignatureInfo :: Name -> Q SignatureTH
getSignatureInfo Name
name = do
ClassI (ClassD Cxt
ctx Name
_ [TyVarBndr
tyvar] [FunDep]
_ [Dec]
decs) [Dec]
_ <- Name -> Q Info
reify Name
name
let tv :: Name
tv = TyVarBndr -> Name
tvName TyVarBndr
tyvar
let sigName :: Name
sigName = (String -> String) -> Name -> Name
changeName (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Signature") Name
name
[Maybe OperationTH]
ops <- [Dec] -> (Dec -> Q (Maybe OperationTH)) -> Q [Maybe OperationTH]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Dec]
decs ((Dec -> Q (Maybe OperationTH)) -> Q [Maybe OperationTH])
-> (Dec -> Q (Maybe OperationTH)) -> Q [Maybe OperationTH]
forall a b. (a -> b) -> a -> b
$ \case
SigD Name
nm (ForallT [TyVarBndr
tv'] Cxt
_ Type
tp) -> Name -> Type -> Name -> Name -> Q (Maybe OperationTH)
mkOp Name
nm Type
tp Name
tv (TyVarBndr -> Name
tvName TyVarBndr
tv')
SigD Name
nm Type
tp -> Name -> Type -> Name -> Name -> Q (Maybe OperationTH)
mkOp Name
nm Type
tp Name
tv Name
tv
Dec
_ -> Maybe OperationTH -> Q (Maybe OperationTH)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe OperationTH
forall a. Maybe a
Nothing
[Maybe SuperclassTH]
scs <- Cxt -> (Type -> Q (Maybe SuperclassTH)) -> Q [Maybe SuperclassTH]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Cxt
ctx ((Type -> Q (Maybe SuperclassTH)) -> Q [Maybe SuperclassTH])
-> (Type -> Q (Maybe SuperclassTH)) -> Q [Maybe SuperclassTH]
forall a b. (a -> b) -> a -> b
$ \case
(AppT (ConT Name
scName) (VarT Name
tv')) | Name
tv Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tv' -> do
SignatureTH
s <- Name -> Q SignatureTH
getSignatureInfo Name
scName
case SignatureTH
s of
SignatureTH Name
_ Name
_ [] [] -> Maybe SuperclassTH -> Q (Maybe SuperclassTH)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SuperclassTH
forall a. Maybe a
Nothing
SignatureTH
_ -> Maybe SuperclassTH -> Q (Maybe SuperclassTH)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SuperclassTH -> Q (Maybe SuperclassTH))
-> Maybe SuperclassTH -> Q (Maybe SuperclassTH)
forall a b. (a -> b) -> a -> b
$ SuperclassTH -> Maybe SuperclassTH
forall a. a -> Maybe a
Just (SuperclassTH -> Maybe SuperclassTH)
-> SuperclassTH -> Maybe SuperclassTH
forall a b. (a -> b) -> a -> b
$ Name -> Name -> SignatureTH -> SuperclassTH
SuperclassTH Name
scName ((String -> String) -> Name -> Name
changeName (Name -> String -> String
addScPrefix Name
name) Name
scName) SignatureTH
s
Type
_ -> Maybe SuperclassTH -> Q (Maybe SuperclassTH)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SuperclassTH
forall a. Maybe a
Nothing
SignatureTH -> Q SignatureTH
forall (m :: * -> *) a. Monad m => a -> m a
return (SignatureTH -> Q SignatureTH) -> SignatureTH -> Q SignatureTH
forall a b. (a -> b) -> a -> b
$ Name -> Name -> [OperationTH] -> [SuperclassTH] -> SignatureTH
SignatureTH Name
sigName Name
tv ([Maybe OperationTH] -> [OperationTH]
forall a. [Maybe a] -> [a]
catMaybes [Maybe OperationTH]
ops) ([Maybe SuperclassTH] -> [SuperclassTH]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SuperclassTH]
scs)
where
mkOp :: Name -> Type -> Name -> Name -> Q (Maybe OperationTH)
mkOp Name
nm Type
tp Name
tv Name
tv' = do
Info
dec <- Name -> Q Info
reify Name
nm
Fixity
fty <- 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
case Info
dec of
ClassOpI{} ->
Maybe OperationTH -> Q (Maybe OperationTH)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OperationTH -> Q (Maybe OperationTH))
-> Maybe OperationTH -> Q (Maybe OperationTH)
forall a b. (a -> b) -> a -> b
$ case Name -> Type -> Maybe (Int, Name -> Con)
buildOperation Name
tv' Type
tp of
Just (Int
ar, Name -> Con
mkCon) ->
let opName :: Name
opName = (String -> String) -> Name -> Name
changeName String -> String
addPrefix Name
nm
in OperationTH -> Maybe OperationTH
forall a. a -> Maybe a
Just (OperationTH -> Maybe OperationTH)
-> OperationTH -> Maybe OperationTH
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Int -> Con -> Fixity -> OperationTH
OperationTH Name
nm Name
opName Int
ar ((forall a. Data a => a -> a) -> Con -> Con
(forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Name -> Name -> Name -> Name
rename Name
tv' Name
tv)) (Name -> Con
mkCon Name
opName)) Fixity
fty
Maybe (Int, Name -> Con)
_ -> Maybe OperationTH
forall a. Maybe a
Nothing
Info
_ -> String -> Q (Maybe OperationTH)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Maybe OperationTH))
-> String -> Q (Maybe OperationTH)
forall a b. (a -> b) -> a -> b
$ String
"No support for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Info -> String
forall a. Show a => a -> String
show Info
dec
deriveSignature :: Name -> Q [Dec]
deriveSignature :: Name -> Q [Dec]
deriveSignature = ([(Name, [Dec])] -> [Dec]) -> Q [(Name, [Dec])] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([(Name, [Dec])] -> ((Name, [Dec]) -> [Dec]) -> [Dec]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd) ([(Name, [Dec])] -> [Dec])
-> ([(Name, [Dec])] -> [(Name, [Dec])]) -> [(Name, [Dec])] -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [Dec]) -> (Name, [Dec]) -> Bool)
-> [(Name, [Dec])] -> [(Name, [Dec])]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> ((Name, [Dec]) -> Name)
-> (Name, [Dec])
-> (Name, [Dec])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Name, [Dec]) -> Name
forall a b. (a, b) -> a
fst)) (Q [(Name, [Dec])] -> Q [Dec])
-> (Name -> Q [(Name, [Dec])]) -> Name -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q [(Name, [Dec])]
deriveSignature'
deriveSignature' :: Name -> Q [(Name, [Dec])]
deriveSignature' :: Name -> Q [(Name, [Dec])]
deriveSignature' Name
className = do
SignatureTH
s <- Name -> Q SignatureTH
getSignatureInfo Name
className
Maybe Name
mName <- String -> Q (Maybe Name)
lookupTypeName (Name -> String
nameBase (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ SignatureTH -> Name
signatureName SignatureTH
s)
[(Name, [Dec])]
scDecs <- [[(Name, [Dec])]] -> [(Name, [Dec])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, [Dec])]] -> [(Name, [Dec])])
-> Q [[(Name, [Dec])]] -> Q [(Name, [Dec])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SuperclassTH -> Q [(Name, [Dec])])
-> [SuperclassTH] -> Q [[(Name, [Dec])]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> Q [(Name, [Dec])]
deriveSignature' (Name -> Q [(Name, [Dec])])
-> (SuperclassTH -> Name) -> SuperclassTH -> Q [(Name, [Dec])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SuperclassTH -> Name
superclassName) (SignatureTH -> [SuperclassTH]
superclasses SignatureTH
s)
[(Name, [Dec])] -> Q [(Name, [Dec])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [Dec])] -> Q [(Name, [Dec])])
-> [(Name, [Dec])] -> Q [(Name, [Dec])]
forall a b. (a -> b) -> a -> b
$ if Maybe Name
mName Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Name
forall a. Maybe a
Nothing then (Name
className, SignatureTH -> [Dec]
buildSignatureDataType SignatureTH
s [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ Name -> SignatureTH -> [Dec]
signatureInstances Name
className SignatureTH
s) (Name, [Dec]) -> [(Name, [Dec])] -> [(Name, [Dec])]
forall a. a -> [a] -> [a]
: [(Name, [Dec])]
scDecs else []
deriveInstance :: Q Type -> Q [Dec]
deriveInstance :: Q Type -> Q [Dec]
deriveInstance Q Type
typ = Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith Q Type
typ (Q [Dec] -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
deriveInstanceWith :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith = Bool -> Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith' Bool
True
deriveInstanceWith_skipSignature :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith_skipSignature :: Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith_skipSignature = Bool -> Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith' Bool
False
deriveSuperclassInstances :: Q Type -> Q [Dec]
deriveSuperclassInstances :: Q Type -> Q [Dec]
deriveSuperclassInstances Q Type
qtyp = do
Type
typ <- Q Type
qtyp
case Type
typ of
ForallT [TyVarBndr]
_ Cxt
ctx (AppT (ConT Name
className) Type
typeName) ->
Cxt -> Name -> Type -> Q [Dec]
deriveSuperclassInstances' Cxt
ctx Name
className Type
typeName
AppT (ConT Name
className) Type
typeName ->
Cxt -> Name -> Type -> Q [Dec]
deriveSuperclassInstances' [] Name
className Type
typeName
deriveSuperclassInstances' :: Cxt -> Name -> Type -> Q [Dec]
deriveSuperclassInstances' :: Cxt -> Name -> Type -> Q [Dec]
deriveSuperclassInstances' Cxt
ctx Name
className Type
typeName = do
SignatureTH
s <- Name -> Q SignatureTH
getSignatureInfo Name
className
((Name, [Dec]) -> [Dec]) -> [(Name, [Dec])] -> [Dec]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name, [Dec]) -> [Dec]
forall a b. (a, b) -> b
snd ([(Name, [Dec])] -> [Dec]) -> Q [(Name, [Dec])] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignatureTH -> Cxt -> Type -> (Exp -> Exp) -> Q [(Name, [Dec])]
deriveSuperclassInstances'' SignatureTH
s Cxt
ctx Type
typeName Exp -> Exp
forall a. a -> a
id
deriveSuperclassInstances'' :: SignatureTH -> Cxt -> Type -> (Exp -> Exp) -> Q [(Name, [Dec])]
deriveSuperclassInstances'' :: SignatureTH -> Cxt -> Type -> (Exp -> Exp) -> Q [(Name, [Dec])]
deriveSuperclassInstances'' SignatureTH
s Cxt
ctx Type
typeName Exp -> Exp
wrap =
((Name, [Dec]) -> (Name, [Dec]) -> Bool)
-> [(Name, [Dec])] -> [(Name, [Dec])]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> ((Name, [Dec]) -> Name)
-> (Name, [Dec])
-> (Name, [Dec])
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Name, [Dec]) -> Name
forall a b. (a, b) -> a
fst) ([(Name, [Dec])] -> [(Name, [Dec])])
-> ([[(Name, [Dec])]] -> [(Name, [Dec])])
-> [[(Name, [Dec])]]
-> [(Name, [Dec])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(Name, [Dec])]] -> [(Name, [Dec])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, [Dec])]] -> [(Name, [Dec])])
-> Q [[(Name, [Dec])]] -> Q [(Name, [Dec])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SuperclassTH -> Q [(Name, [Dec])])
-> [SuperclassTH] -> Q [[(Name, [Dec])]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
(\(SuperclassTH Name
scName Name
conName SignatureTH
s') -> do
[Dec]
dec <- Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' Bool
False Cxt
ctx Name
scName Type
typeName (Exp -> Exp
wrap (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName)) ([Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
[(Name, [Dec])]
scs <- SignatureTH -> Cxt -> Type -> (Exp -> Exp) -> Q [(Name, [Dec])]
deriveSuperclassInstances'' SignatureTH
s' Cxt
ctx Type
typeName (Exp -> Exp
wrap (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
conName))
[(Name, [Dec])] -> Q [(Name, [Dec])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, [Dec])] -> Q [(Name, [Dec])])
-> [(Name, [Dec])] -> Q [(Name, [Dec])]
forall a b. (a -> b) -> a -> b
$ (Name
scName, [Dec]
dec) (Name, [Dec]) -> [(Name, [Dec])] -> [(Name, [Dec])]
forall a. a -> [a] -> [a]
: [(Name, [Dec])]
scs)
(SignatureTH -> [SuperclassTH]
superclasses SignatureTH
s)
deriveInstanceWith' :: Bool -> Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith' :: Bool -> Q Type -> Q [Dec] -> Q [Dec]
deriveInstanceWith' Bool
addSignature Q Type
qtyp Q [Dec]
dec = do
Type
typ <- Q Type
qtyp
case Type
typ of
ForallT [TyVarBndr]
_ Cxt
ctx (AppT (ConT Name
className) Type
typeName) ->
Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' Bool
addSignature Cxt
ctx Name
className Type
typeName Exp -> Exp
forall a. a -> a
id Q [Dec]
dec
AppT (ConT Name
className) Type
typeName ->
Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' Bool
addSignature [] Name
className Type
typeName Exp -> Exp
forall a. a -> a
id Q [Dec]
dec
deriveInstanceWith'' :: Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' :: Bool -> Cxt -> Name -> Type -> (Exp -> Exp) -> Q [Dec] -> Q [Dec]
deriveInstanceWith'' Bool
addSignature Cxt
ctx Name
className Type
typeName Exp -> Exp
wrap Q [Dec]
dec = do
[Dec]
given <- Q [Dec]
dec
SignatureTH
s <- Name -> Q SignatureTH
getSignatureInfo Name
className
let
givenLU :: [(String, (Name, Dec))]
givenLU =
[ (Name -> String
nameBase Name
nm, (Name
nm, Dec -> Dec
renamer Dec
f)) | f :: Dec
f@(FunD Name
nm [Clause]
_) <- [Dec]
given ] [(String, (Name, Dec))]
-> [(String, (Name, Dec))] -> [(String, (Name, Dec))]
forall a. [a] -> [a] -> [a]
++
[ (Name -> String
nameBase Name
nm, (Name
nm, Dec -> Dec
renamer Dec
v)) | v :: Dec
v@(ValD (VarP Name
nm) Body
_ [Dec]
_) <- [Dec]
given ]
renamer :: Dec -> Dec
renamer = [(Name, Name)] -> Dec -> Dec
forall a. Data a => [(Name, Name)] -> a -> a
renameAll [ (Name
nm, Name
nm') | (String
b, (Name
nm, Dec
_)) <- [(String, (Name, Dec))]
givenLU, Name
nm' <- OperationTH -> Name
functionName (OperationTH -> Name) -> [OperationTH] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignatureTH -> [OperationTH]
operations SignatureTH
s, Name -> String
nameBase Name
nm' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
b ]
impl :: [Dec]
impl =
[ Dec -> ((Name, Dec) -> Dec) -> Maybe (Name, Dec) -> Dec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(Name -> [Clause] -> Dec
FunD Name
fName [[Pat] -> Body -> [Dec] -> Clause
Clause ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args) (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'algebra) (Exp -> Exp
wrap ((Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
e Name
arg -> Exp -> Exp -> Exp
AppE Exp
e (Name -> Exp
VarE Name
arg)) (Name -> Exp
ConE Name
opName) [Name]
args)))) []])
(Name, Dec) -> Dec
forall a b. (a, b) -> b
snd Maybe (Name, Dec)
mgiven
| OperationTH Name
fName Name
opName Int
ar Con
_ Fixity
_ <- SignatureTH -> [OperationTH]
operations SignatureTH
s, let mgiven :: Maybe (Name, Dec)
mgiven = String -> [(String, (Name, Dec))] -> Maybe (Name, Dec)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Name -> String
nameBase Name
fName) [(String, (Name, Dec))]
givenLU, let args :: [Name]
args = Int -> [Name]
mkArgList Int
ar ]
([Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [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]
impl]) ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
if Bool
addSignature then Name -> Q [Dec]
deriveSignature Name
className else [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return []
buildSignatureDataType :: SignatureTH -> [Dec]
buildSignatureDataType :: SignatureTH -> [Dec]
buildSignatureDataType SignatureTH
s =
[Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] (SignatureTH -> Name
signatureName SignatureTH
s) [Name -> TyVarBndr
PlainTV (SignatureTH -> Name
typeVarName SignatureTH
s)] Maybe Type
forall a. Maybe a
Nothing
((OperationTH -> Con
constructor (OperationTH -> Con) -> [OperationTH] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignatureTH -> [OperationTH]
operations SignatureTH
s) [Con] -> [Con] -> [Con]
forall a. [a] -> [a] -> [a]
++ (Name -> SuperclassTH -> Con
buildSuperclassCon (SignatureTH -> Name
typeVarName SignatureTH
s) (SuperclassTH -> Con) -> [SuperclassTH] -> [Con]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SignatureTH -> [SuperclassTH]
superclasses SignatureTH
s))
[Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing ((Name -> Type) -> [Name] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
ConT [''Functor, ''Foldable, ''Traversable, ''Eq, ''Ord])]]
signatureInstances :: Name -> SignatureTH -> [Dec]
signatureInstances :: Name -> SignatureTH -> [Dec]
signatureInstances Name
nm SignatureTH
s = [Dec
asInst, Dec
showInst, Dec
sigTFInst]
where
signature :: Type
signature = Name -> Type
ConT (SignatureTH -> Name
signatureName SignatureTH
s)
sigTFInst :: Dec
sigTFInst = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT ''Signature) (Name -> Type
ConT Name
nm)) Type
signature)
typeInst :: Dec
typeInst = TySynEqn -> Dec
TySynInstD (Maybe [TyVarBndr] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Type -> Type -> Type
AppT (Name -> Type
ConT ''Class) Type
signature) (Name -> Type
ConT Name
nm))
asClauses :: [Clause]
asClauses =
[ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
opName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args)] (Exp -> Body
NormalB ((Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
e Name
arg -> Exp -> Exp -> Exp
AppE Exp
e (Name -> Exp
VarE Name
arg)) (Name -> Exp
VarE Name
fName) [Name]
args)) []
| OperationTH Name
fName Name
opName Int
ar Con
_ Fixity
_ <- SignatureTH -> [OperationTH]
operations SignatureTH
s, let args :: [Name]
args = Int -> [Name]
mkArgList Int
ar ]
asScClauses :: [Clause]
asScClauses =
[ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
ConP Name
conName [(Name -> Pat
VarP Name
v)]] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'evaluate) (Name -> Exp
VarE Name
v)) []
| SuperclassTH Name
_ Name
conName SignatureTH
_ <- SignatureTH -> [SuperclassTH]
superclasses SignatureTH
s, let v :: Name
v = String -> Name
mkName String
"v"]
asInst :: Dec
asInst = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''AlgebraSignature) Type
signature) [Dec
typeInst, Name -> [Clause] -> Dec
FunD 'evaluate ([Clause]
asClauses [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause]
asScClauses)]
showsPrecClauses :: [Clause]
showsPrecClauses =
[ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
d, Name -> [Pat] -> Pat
ConP Name
opName ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
args)] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> String -> Int -> [Name] -> Exp
forall a. Integral a => Name -> String -> a -> [Name] -> Exp
createShowsPrec Name
d (Name -> String
nameBase Name
fName) Int
prec [Name]
args) []
| OperationTH Name
fName Name
opName Int
ar Con
_ (Fixity Int
prec FixityDirection
_) <- SignatureTH -> [OperationTH]
operations SignatureTH
s, let args :: [Name]
args = Int -> [Name]
mkArgList Int
ar, let d :: Name
d = String -> Name
mkName String
"d" ]
showsPrecScClauses :: [Clause]
showsPrecScClauses =
[ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
d, Name -> [Pat] -> Pat
ConP Name
conName [(Name -> Pat
VarP Name
v)]] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showsPrec) (Name -> Exp
VarE Name
d)) (Name -> Exp
VarE Name
v)) []
| SuperclassTH Name
_ Name
conName SignatureTH
_ <- SignatureTH -> [SuperclassTH]
superclasses SignatureTH
s, let d :: Name
d = String -> Name
mkName String
"d", let v :: Name
v = String -> Name
mkName String
"v"]
createShowsPrec :: Name -> String -> a -> [Name] -> Exp
createShowsPrec Name
d String
name a
prec [Name
u,Name
v] | String -> Bool
isOperator String
name =
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showParen) (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
d)) (Name -> Exp
VarE '(>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
prec')))))) (Name -> Exp
VarE '($))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showsPrec) (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
prec1))) (Name -> Exp
VarE Name
u))) (Name -> Exp
VarE '(.))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showString) (Lit -> Exp
LitE (String -> Lit
StringL (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "))))) (Name -> Exp
VarE '(.))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showsPrec) (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
prec1))) (Name -> Exp
VarE Name
v)))))))
where
prec' :: Integer
prec' = a -> Integer
forall a. Integral a => a -> Integer
toInteger a
prec
prec1 :: Integer
prec1 = Integer
prec' Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
createShowsPrec Name
d String
name a
_ [Name]
args =
Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showParen) (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Name -> Exp
VarE Name
d)) (Name -> Exp
VarE '(>)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
10)))))) (Name -> Exp
VarE '($)) (Maybe Exp -> Exp) -> Maybe Exp -> Exp
forall a b. (a -> b) -> a -> b
$
(Maybe Exp -> Name -> Maybe Exp)
-> Maybe Exp -> [Name] -> Maybe Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe Exp -> Name -> Maybe Exp
addArg (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showString) (Lit -> Exp
LitE (String -> Lit
StringL String
name)))) [Name]
args
addArg :: Maybe Exp -> Name -> Maybe Exp
addArg Maybe Exp
expr Name
arg =
Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE Maybe Exp
expr (Name -> Exp
VarE '(.)) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showChar) (Lit -> Exp
LitE (Char -> Lit
CharL Char
' ')))) (Name -> Exp
VarE '(.))
(Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'showsPrec) (Lit -> Exp
LitE (Integer -> Lit
IntegerL Integer
11))) (Name -> Exp
VarE Name
arg)))))
showInst :: Dec
showInst = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) Type
a]
(Type -> Type -> Type
AppT (Name -> Type
ConT ''Show) (Type -> Type -> Type
AppT Type
signature Type
a))
[Name -> [Clause] -> Dec
FunD 'showsPrec ([Clause]
showsPrecClauses [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause]
showsPrecScClauses)]
a :: Type
a = Name -> Type
VarT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"a"
buildOperation :: Name -> Type -> Maybe (Int, Name -> Con)
buildOperation :: Name -> Type -> Maybe (Int, Name -> Con)
buildOperation Name
nm (VarT Name
nm') = if Name
nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
nm' then (Int, Name -> Con) -> Maybe (Int, Name -> Con)
forall a. a -> Maybe a
Just (Int
0, \Name
opName -> Name -> [BangType] -> Con
NormalC Name
opName []) else Maybe (Int, Name -> Con)
forall a. Maybe a
Nothing
buildOperation Name
nm (AppT (AppT Type
ArrowT Type
h) Type
t) = ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int)
-> ((Name -> Con) -> Name -> Con)
-> (Int, Name -> Con)
-> (Int, Name -> Con)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Con -> Con) -> (Name -> Con) -> Name -> Con
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Type -> Con -> Con
prependC Type
h)) ((Int, Name -> Con) -> (Int, Name -> Con))
-> Maybe (Int, Name -> Con) -> Maybe (Int, Name -> Con)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Type -> Maybe (Int, Name -> Con)
buildOperation Name
nm Type
t
buildOperation Name
_ Type
_ = Maybe (Int, Name -> Con)
forall a. Maybe a
Nothing
buildSuperclassCon :: Name -> SuperclassTH -> Con
buildSuperclassCon :: Name -> SuperclassTH -> Con
buildSuperclassCon Name
nm SuperclassTH
s = Name -> [BangType] -> Con
NormalC (SuperclassTH -> Name
constrName SuperclassTH
s) [(Bang
bangDef, Type -> Type -> Type
AppT (Name -> Type
ConT (SignatureTH -> Name
signatureName (SignatureTH -> Name) -> SignatureTH -> Name
forall a b. (a -> b) -> a -> b
$ SuperclassTH -> SignatureTH
signatureTH SuperclassTH
s)) (Name -> Type
VarT Name
nm))]
changeName :: (String -> String) -> Name -> Name
changeName :: (String -> String) -> Name -> Name
changeName String -> String
f = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
addPrefix :: String -> String
addPrefix :: String -> String
addPrefix String
s | String -> Bool
isOperator String
s = String
":%:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
addPrefix String
s = String
"Op_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
addScPrefix :: Name -> String -> String
addScPrefix :: Name -> String -> String
addScPrefix Name
nm String
s = String
"Sc_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
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
mkArgList :: Int -> [Name]
mkArgList :: Int -> [Name]
mkArgList Int
n = [ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"a" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i | Int
i <- [Int
1 .. Int
n] ]
renameAll :: Data a => [(Name, Name)] -> a -> a
renameAll :: [(Name, Name)] -> a -> a
renameAll [(Name, Name)]
m = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((Name -> Name) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT (Endo Name -> Name -> Name
forall a. Endo a -> a -> a
appEndo (((Name, Name) -> Endo Name) -> [(Name, Name)] -> Endo Name
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Name
a, Name
b) -> (Name -> Name) -> Endo Name
forall a. (a -> a) -> Endo a
Endo ((Name -> Name) -> Endo Name) -> (Name -> Name) -> Endo Name
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Name -> Name
rename Name
a Name
b) [(Name, Name)]
m)))
rename :: Name -> Name -> Name -> Name
rename :: Name -> Name -> Name -> Name
rename Name
a Name
b Name
c | Name
a Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
c = Name
b
rename Name
_ Name
_ Name
t = Name
t
prependC :: Type -> Con -> Con
prependC :: Type -> Con -> Con
prependC Type
st (NormalC Name
nm [BangType]
sts) = Name -> [BangType] -> Con
NormalC Name
nm ((Bang
bangDef, Type
st)BangType -> [BangType] -> [BangType]
forall a. a -> [a] -> [a]
:[BangType]
sts)
bangDef :: Bang
bangDef :: Bang
bangDef = SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness
tvName :: TyVarBndr -> Name
tvName :: TyVarBndr -> Name
tvName (PlainTV Name
nm) = Name
nm
tvName (KindedTV Name
nm Type
_) = Name
nm