{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Algebra.TH
-- Copyright   :  (c) Sjoerd Visscher 2013
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  sjoerd@w3future.com
-- Stability   :  experimental
-- Portability :  non-portable
-----------------------------------------------------------------------------
module Data.Algebra.TH
  ( deriveInstance
  , deriveInstanceWith
  , deriveInstanceWith_skipSignature
  , deriveSuperclassInstances
  , deriveSignature
  -- * Possibly useful internals
  , 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

-- | Derive a signature for an algebraic class.
--   For example:
--
-- > deriveSignature ''Monoid
--
--   The above would generate the following:
--
-- > data MonoidSignature a = Op_mempty | Op_mappend a a | Op_mconcat [a]
-- >   deriving (Functor, Foldable, Traversable, Eq, Ord)
-- >
-- > type instance Signature Monoid = MonoidSignature
-- >
-- > instance AlgebraSignature MonoidSignature where
-- >   type Class MonoidSignature = Monoid
-- >   evaluate Op_mempty = mempty
-- >   evaluate (Op_mappend a b) = mappend a b
-- >   evaluate (Op_mconcat ms) = mconcat ms
-- >
-- > instance Show a => Show (MonoidSignature a) where
-- >   showsPrec d Op_mempty          = showParen (d > 10) $ showString "mempty"
-- >   showsPrec d (Op_mappend a1 a2) = showParen (d > 10) $ showString "mappend" . showChar ' ' . showsPrec 11 a1 . showChar ' ' . showsPrec 11 a2
-- >   showsPrec d (Op_mconcat a1)    = showParen (d > 10) $ showString "mconcat" . showChar ' ' . showsPrec 11 a1
--
--   `deriveSignature` creates the signature data type and an instance for it of the
--   `AlgebraSignature` class. @DeriveTraversable@ is used the generate the `Traversable` instance of the signature.
--
--   This will do nothing if there is already a signature for the class in scope.
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 []

-- | Derive an instance for an algebraic class.
--   For example:
--
--   > deriveInstance [t| (Num m, Num n) => Num (m, n) |]
--
--   To be able to derive an instance for @a@ of class @c@, we need an instance of @`Algebra` f a@,
--   where @f@ is the signature of @c@.
--
--   `deriveInstance` will generate a signature for the class if there is no signature in scope.
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 []

-- | Derive an instance for an algebraic class with a given partial implementation.
--   For example:
--
-- > deriveInstanceWith [t| Num n => Num (Integer -> n) |]
-- >   [d|
-- >     fromInteger x y = fromInteger (x + y)
-- >   |]
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

-- | Derive an instance for an algebraic class with a given partial implementation,
--   but don't generate the signature. This is for when you want to derive several instances
--   of the same class, but can't splice the results directly. In that case 'deriveSignature'
--   can't detect it has already generated the signature earlier.
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

-- | Derive the instances for the superclasses too, all using the same context.
--   Usually you'd want to do this manually since you can often give a stricter context, for example:
--
-- > deriveSuperclassInstances [t| (Fractional m, Fractional n) => Fractional (m, n) |]
--
--   will derive an instance @(Fractional m, Fractional n) => Num (m, n)@ while the instance only
--   needs @(Num m, Num n)@.
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