{-# LANGUAGE EmptyDataDecls       #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Allows you to derive instances of GHC.Generics for compositional data types.
-- Warning: May slaughter your compile times.

{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- TH runs at compile time, so you get compile-time errors anyway
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- It warns for the instance declarations in TH which are never directly compiled -- GAH

module Data.Comp.Multi.Derive.Generic
  (
    makeGeneric
  , makeInstancesLike
  , GenericExample
  ) where

import Control.Monad ( liftM, filterM, mplus, msum )

import qualified Data.Comp.Multi.Term as M
import qualified Data.Comp.Multi.Ops  as M

import GHC.Generics ( Generic(..), (:*:)(..), (:+:)(..), K1(..), V1, Rec0, U1(..) )

import Language.Haskell.TH
import Data.Type.Equality

--------------------------------------------------------------------------------
-- Generic instances for general CDTs
--------------------------------------------------------------------------------
instance Generic (M.Sum '[] e l) where
  type Rep (M.Sum '[] e l) = V1

instance (Generic (f e l), Generic (M.Sum fs e l)) => Generic (M.Sum (f ': fs) e l) where
  type Rep (M.Sum (f ': fs) e l) = Rep (f e l) :+: Rep (M.Sum fs e l)

  from :: Sum (f : fs) e l -> Rep (Sum (f : fs) e l) x
from (M.Sum w :: Elem f (f : fs)
w a :: f e l
a) = case Elem f (f : fs) -> Either (f :~: f) (Elem f fs)
forall k (f :: k) (g :: k) (fs :: [k]).
Elem f (g : fs) -> Either (f :~: g) (Elem f fs)
M.contract Elem f (f : fs)
w of
    Right w0 :: Elem f fs
w0 -> Rep (Sum fs e l) x -> (:+:) (Rep (f e l)) (Rep (Sum fs e l)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Sum fs e l -> Rep (Sum fs e l) x
forall a x. Generic a => a -> Rep a x
from (Elem f fs -> f e l -> Sum fs e l
forall (f :: (* -> *) -> * -> *) (fs :: [(* -> *) -> * -> *])
       (h :: * -> *) e.
Elem f fs -> f h e -> Sum fs h e
M.Sum Elem f fs
w0 f e l
a))
    Left Refl -> Rep (f e l) x -> (:+:) (Rep (f e l)) (Rep (Sum fs e l)) x
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f e l -> Rep (f e l) x
forall a x. Generic a => a -> Rep a x
from f e l
a)

  to :: Rep (Sum (f : fs) e l) x -> Sum (f : fs) e l
to (L1 x) = Elem f (f : fs) -> f e l -> Sum (f : fs) e l
forall (f :: (* -> *) -> * -> *) (fs :: [(* -> *) -> * -> *])
       (h :: * -> *) e.
Elem f fs -> f h e -> Sum fs h e
M.Sum Elem f (f : fs)
forall k (f :: k) (fs :: [k]). Mem f fs => Elem f fs
M.witness (Rep (f e l) x -> f e l
forall a x. Generic a => Rep a x -> a
to Rep (f e l) x
x :: f e l)
  to (R1 x) = case Rep (Sum fs e l) x -> Sum fs e l
forall a x. Generic a => Rep a x -> a
to Rep (Sum fs e l) x
x :: M.Sum fs e l of
    M.Sum w :: Elem f fs
w a :: f e l
a -> Elem f (f : fs) -> f e l -> Sum (f : fs) e l
forall (f :: (* -> *) -> * -> *) (fs :: [(* -> *) -> * -> *])
       (h :: * -> *) e.
Elem f fs -> f h e -> Sum fs h e
M.Sum (Elem f fs -> Elem f (f : fs)
forall a (f :: a) (fs :: [a]) (g :: a).
Elem f fs -> Elem f (g : fs)
M.extend Elem f fs
w) f e l
a

instance (Generic (f (M.HFix f) l)) => Generic (M.HFix f l) where
  type Rep (M.HFix f l) = Rep (f (M.HFix f) l)
  from :: HFix f l -> Rep (HFix f l) x
from (M.Term x :: f (HFix f) l
x) = f (HFix f) l -> Rep (f (HFix f) l) x
forall a x. Generic a => a -> Rep a x
from f (HFix f) l
x
  to :: Rep (HFix f l) x -> HFix f l
to x :: Rep (HFix f l) x
x = f (HFix f) l -> HFix f l
forall (f :: (* -> *) -> * -> *) h (a :: * -> *) i.
f (Cxt h f a) i -> Cxt h f a i
M.Term (f (HFix f) l -> HFix f l) -> f (HFix f) l -> HFix f l
forall a b. (a -> b) -> a -> b
$ Rep (f (HFix f) l) x -> f (HFix f) l
forall a x. Generic a => Rep a x -> a
to Rep (f (HFix f) l) x
Rep (HFix f l) x
x

instance (Generic (f e l)) => Generic ((f M.:&: p) e l) where
  type Rep ((f M.:&: p) e l) = (Rep (f e l)) :*: Rec0 p
  from :: (:&:) f p e l -> Rep ((:&:) f p e l) x
from (t :: f e l
t M.:&: x :: p
x) = f e l -> Rep (f e l) x
forall a x. Generic a => a -> Rep a x
from f e l
t Rep (f e l) x -> K1 R p x -> (:*:) (Rep (f e l)) (K1 R p) x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: p -> K1 R p x
forall k i c (p :: k). c -> K1 i c p
K1 p
x
  to :: Rep ((:&:) f p e l) x -> (:&:) f p e l
to (t :*: K1 x) = Rep (f e l) x -> f e l
forall a x. Generic a => Rep a x -> a
to Rep (f e l) x
t f e l -> p -> (:&:) f p e l
forall k (f :: (* -> *) -> k -> *) a (g :: * -> *) (e :: k).
f g e -> a -> (:&:) f a g e
M.:&: p
x

--------------------------------------------------------------------------------
-- Creating users of Generic
--------------------------------------------------------------------------------

data GenericExample

makeInstancesLike :: [Name] -> [Type] -> Q [Dec] -> Q [Dec]
makeInstancesLike :: [Name] -> [Type] -> Q [Dec] -> Q [Dec]
makeInstancesLike cons :: [Name]
cons labs :: [Type]
labs example :: Q [Dec]
example = do
  [InstanceD ov :: Maybe Overlap
ov [] (AppT (ConT tc :: Name
tc) _) b :: [Dec]
b] <- Q [Dec]
example
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> Name -> Name -> Type -> [Dec] -> Dec
makeInstanceLike Maybe Overlap
ov Name
tc Name
c Type
l [Dec]
b | Name
c <- [Name]
cons, Type
l <- [Type]
labs]

makeInstanceLike :: Maybe Overlap -> Name -> Name -> Type -> [Dec] -> Dec
makeInstanceLike :: Maybe Overlap -> Name -> Name -> Type -> [Dec] -> Dec
makeInstanceLike ov :: Maybe Overlap
ov tc :: Name
tc c :: Name
c l :: Type
l b :: [Dec]
b =
  Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
ov [] (Type -> Type -> Type
AppT (Name -> Type
ConT Name
tc) (Type -> Type -> Type
AppT (Name -> Type
ConT Name
c) Type
l)) [Dec]
b

--------------------------------------------------------------------------------
-- Deriving Generic
--------------------------------------------------------------------------------

makeGeneric :: [Name] -> [Type] -> Q [Dec]
makeGeneric :: [Name] -> [Type] -> Q [Dec]
makeGeneric nms :: [Name]
nms tps :: [Type]
tps = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Name -> Type -> Q [Dec]
makeGenericInstance Name
n Type
t | Name
n <- [Name]
nms, Type
t <- [Type]
tps]

makeGenericInstance :: Name -> Type -> Q [Dec]
makeGenericInstance :: Name -> Type -> Q [Dec]
makeGenericInstance typNm :: Name
typNm lab :: Type
lab = do
    [(Name, [Type])]
cons <- (Info -> [(Name, [Type])]) -> Q Info -> Q [(Name, [Type])]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Info -> [(Name, [Type])]
simplifyDataInf (Q Info -> Q [(Name, [Type])]) -> Q Info -> Q [(Name, [Type])]
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
typNm
    [(Name, [Type])]
relCons <- ((Name, [Type]) -> Q Bool)
-> [(Name, [Type])] -> Q [(Name, [Type])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Type -> Name -> Q Bool
matchingCon Type
lab (Name -> Q Bool)
-> ((Name, [Type]) -> Name) -> (Name, [Type]) -> Q Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [Type]) -> Name
forall a b. (a, b) -> a
fst) [(Name, [Type])]
cons
    let mTyp :: TypeQ
mTyp = Name -> TypeQ
conT Name
typNm
    let mLab :: TypeQ
mLab = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
lab

    case [(Name, [Type])]
relCons of
      [] -> [d| instance Generic ($mTyp e $mLab) where
                  type Rep ($mTyp e $mLab) = V1
                  from = undefined
                  to = undefined
              |]

      xs :: [(Name, [Type])]
xs -> do let xts :: [[Type]]
xts = ((Name, [Type]) -> [Type]) -> [(Name, [Type])] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type]) -> [Type]
forall a b. (a, b) -> b
snd [(Name, [Type])]
xs


               [[Name]]
vars1 <- ([Type] -> Q [Name]) -> [[Type]] -> Q [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "x")) [[Type]]
xts
               [[Name]]
vars2 <- ([Type] -> Q [Name]) -> [[Type]] -> Q [[Name]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Q Name -> Type -> Q Name
forall a b. a -> b -> a
const (Q Name -> Type -> Q Name) -> Q Name -> Type -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Q Name
newName "x")) [[Type]]
xts
               Name
eNm   <- case [Maybe Name] -> Maybe Name
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Name] -> Maybe Name) -> [Maybe Name] -> Maybe Name
forall a b. (a -> b) -> a -> b
$ ([Type] -> Maybe Name) -> [[Type]] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe Name] -> Maybe Name
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum([Maybe Name] -> Maybe Name)
-> ([Type] -> [Maybe Name]) -> [Type] -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Type -> Maybe Name) -> [Type] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Maybe Name
getEVar) ([[Type]] -> [Maybe Name]) -> [[Type]] -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ ((Name, [Type]) -> [Type]) -> [(Name, [Type])] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type]) -> [Type]
forall a b. (a, b) -> b
snd [(Name, [Type])]
xs of
                          Just n :: Name
n  -> Name -> Q Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
                          Nothing -> String -> Q Name
newName "e"
               
               let e :: TypeQ
e   = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
VarT Name
eNm)
               let rep :: TypeQ
rep = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ [[Type]] -> Type
genericTp [[Type]]
xts


               let gPat :: [Pat]
gPat = [Pat] -> [Pat]
addSumPat ([Pat] -> [Pat]) -> [Pat] -> [Pat]
forall a b. (a -> b) -> a -> b
$ ([Name] -> Pat) -> [[Name]] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map [Name] -> Pat
makeGPat ([[Name]] -> [Pat]) -> [[Name]] -> [Pat]
forall a b. (a -> b) -> a -> b
$ [[Name]]
vars1
               let gExp :: [Exp]
gExp = [Exp] -> [Exp]
addSumExp ([Exp] -> [Exp]) -> [Exp] -> [Exp]
forall a b. (a -> b) -> a -> b
$ ([Name] -> Exp) -> [[Name]] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Name] -> Exp
makeGExp ([[Name]] -> [Exp]) -> [[Name]] -> [Exp]
forall a b. (a -> b) -> a -> b
$ [[Name]]
vars2
               let ePat :: [Pat]
ePat = ((Name, [Name]) -> Pat) -> [(Name, [Name])] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Name]) -> Pat
makeEPat ([(Name, [Name])] -> [Pat]) -> [(Name, [Name])] -> [Pat]
forall a b. (a -> b) -> a -> b
$ [Name] -> [[Name]] -> [(Name, [Name])]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Name, [Type]) -> Name) -> [(Name, [Type])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type]) -> Name
forall a b. (a, b) -> a
fst [(Name, [Type])]
xs) [[Name]]
vars2
               let eExp :: [Exp]
eExp = ((Name, [Name]) -> Exp) -> [(Name, [Name])] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Name]) -> Exp
makeEExp ([(Name, [Name])] -> [Exp]) -> [(Name, [Name])] -> [Exp]
forall a b. (a -> b) -> a -> b
$ [Name] -> [[Name]] -> [(Name, [Name])]
forall a b. [a] -> [b] -> [(a, b)]
zip (((Name, [Type]) -> Name) -> [(Name, [Type])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Type]) -> Name
forall a b. (a, b) -> a
fst [(Name, [Type])]
xs) [[Name]]
vars1

               Dec
inst' <- Q [Dec] -> Q Dec
forall r. Q [r] -> Q r
one [d| instance Generic ($mTyp $e $mLab) where
                                  type Rep ($mTyp $e $mLab) = $rep
                              |]

               Dec -> [Dec] -> Q [Dec]
forall (m :: * -> *). Monad m => Dec -> [Dec] -> m [Dec]
addDecs Dec
inst' ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
                   [ Name -> [Clause] -> Dec
FunD 'from (((Pat, Exp) -> Clause) -> [(Pat, Exp)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, Exp) -> Clause
mkClause ([(Pat, Exp)] -> [Clause]) -> [(Pat, Exp)] -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> [Exp] -> [(Pat, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pat]
ePat [Exp]
gExp)
                   , Name -> [Clause] -> Dec
FunD 'to   (((Pat, Exp) -> Clause) -> [(Pat, Exp)] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, Exp) -> Clause
mkClause ([(Pat, Exp)] -> [Clause]) -> [(Pat, Exp)] -> [Clause]
forall a b. (a -> b) -> a -> b
$ [Pat] -> [Exp] -> [(Pat, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Pat]
gPat [Exp]
eExp)
                   ]
             where
               one :: Q [r] -> Q r
one = ([r] -> r) -> Q [r] -> Q r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [r] -> r
forall a. [a] -> a
head
               addDecs :: Dec -> [Dec] -> m [Dec]
addDecs (InstanceD ov :: Maybe Overlap
ov c :: [Type]
c t :: Type
t ds :: [Dec]
ds) ds' :: [Dec]
ds' = [Dec] -> m [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> m [Dec]) -> [Dec] -> m [Dec]
forall a b. (a -> b) -> a -> b
$ [Maybe Overlap -> [Type] -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
ov [Type]
c Type
t ([Dec]
ds[Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++[Dec]
ds')]
               mkClause :: (Pat, Exp) -> Clause
mkClause (pat :: Pat
pat, expr :: Exp
expr) = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
expr) []

               getEVar :: Type -> Maybe Name
getEVar (AppT (VarT n :: Name
n) _) = Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n
               getEVar (AppT x :: Type
x y :: Type
y )       = Type -> Maybe Name
getEVar Type
x Maybe Name -> Maybe Name -> Maybe Name
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Type -> Maybe Name
getEVar Type
y
               getEVar _                 = Maybe Name
forall a. Maybe a
Nothing
           

genericTp :: [[Type]] -> Type
genericTp :: [[Type]] -> Type
genericTp ts :: [[Type]]
ts = Name -> [Type] -> Type
combine ''(:+:) ([Type] -> Type) -> [Type] -> Type
forall a b. (a -> b) -> a -> b
$ ([Type] -> Type) -> [[Type]] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> [Type] -> Type
combine ''(:*:)) ([[Type]] -> [Type]) -> [[Type]] -> [Type]
forall a b. (a -> b) -> a -> b
$ ([Type] -> [Type]) -> [[Type]] -> [[Type]]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> Type
AppT (Name -> Type
ConT ''Rec0))) [[Type]]
ts
  where
    combine :: Name -> [Type] -> Type
combine _ []     = Name -> Type
ConT ''U1
    combine _ [x :: Type
x]    = Type
x
    combine c :: Name
c (x :: Type
x:xs :: [Type]
xs) = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT Name
c) Type
x) (Name -> [Type] -> Type
combine Name
c [Type]
xs)

makeGPat :: [Name] -> Pat
makeGPat :: [Name] -> Pat
makeGPat []     = Name -> [Pat] -> Pat
ConP 'U1 []
makeGPat [n :: Name
n]    = Name -> [Pat] -> Pat
ConP 'K1 [Name -> Pat
VarP Name
n]
makeGPat (n :: Name
n:ns :: [Name]
ns) = Name -> [Pat] -> Pat
ConP '(:*:) [ Name -> [Pat] -> Pat
ConP 'K1 [Name -> Pat
VarP Name
n]
                              , [Name] -> Pat
makeGPat [Name]
ns 
                              ]

makeGExp :: [Name] -> Exp
makeGExp :: [Name] -> Exp
makeGExp []     = Name -> Exp
ConE 'U1
makeGExp [n :: Name
n]    = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'K1) (Name -> Exp
VarE Name
n)
makeGExp (n :: Name
n:ns :: [Name]
ns) = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE '(:*:)) (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'K1) (Name -> Exp
VarE Name
n))) ([Name] -> Exp
makeGExp [Name]
ns) 

makeEPat :: (Name, [Name]) -> Pat
makeEPat :: (Name, [Name]) -> Pat
makeEPat (c :: Name
c, ns :: [Name]
ns) = Name -> [Pat] -> Pat
ConP Name
c ((Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
ns)

makeEExp :: (Name, [Name]) -> Exp
makeEExp :: (Name, [Name]) -> Exp
makeEExp (c :: Name
c, ns :: [Name]
ns) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Exp -> Exp -> Exp
AppE (Name -> Exp
ConE Name
c) ((Name -> Exp) -> [Name] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Exp
VarE [Name]
ns)

addSumPat :: [Pat] -> [Pat]
addSumPat :: [Pat] -> [Pat]
addSumPat [p :: Pat
p]    = [Pat
p]
addSumPat (p :: Pat
p:ps :: [Pat]
ps) = [Name -> [Pat] -> Pat
ConP 'L1 [Pat
p]] [Pat] -> [Pat] -> [Pat]
forall a. [a] -> [a] -> [a]
++ (Pat -> Pat) -> [Pat] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map (\r :: Pat
r -> Name -> [Pat] -> Pat
ConP 'R1 [Pat
r]) ([Pat] -> [Pat]
addSumPat [Pat]
ps)

addSumExp :: [Exp] -> [Exp]
addSumExp :: [Exp] -> [Exp]
addSumExp [e :: Exp
e]    = [Exp
e]
addSumExp (e :: Exp
e:es :: [Exp]
es) = [Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'L1) Exp
e] [Exp] -> [Exp] -> [Exp]
forall a. [a] -> [a] -> [a]
++ (Exp -> Exp) -> [Exp] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\f :: Exp
f -> Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'R1) Exp
f) ([Exp] -> [Exp]
addSumExp [Exp]
es)

matchingCon :: Type -> Name -> Q Bool
matchingCon :: Type -> Name -> Q Bool
matchingCon t :: Type
t nm :: Name
nm = do
  (DataConI _ tp :: Type
tp parentNm :: Name
parentNm) <- Name -> Q Info
reify Name
nm
  Bool -> Q Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Q Bool) -> Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Bool
cxtlessUnifiable (Type -> Name -> Type
extractLab Type
tp Name
parentNm) Type
t


extractLab :: Type -> Name -> Type
extractLab :: Type -> Name -> Type
extractLab tp :: Type
tp par :: Name
par = Type -> Type
go Type
tp
  where
    go :: Type -> Type
go (ForallT _ ctx :: [Type]
ctx t :: Type
t)      = Type -> Type
go (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type -> Type
substCxt [Type]
ctx Type
t
    go (AppT (AppT (ConT n :: Name
n) _) t :: Type
t)
                 | Name
par Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = Type
t
    go (AppT _ t :: Type
t)           = Type -> Type
go Type
t

    -- My very ghetto way of handling contexts. Found a few
    -- examples where GHC substituted away equality constraints
    -- when getting the type of a data con; assumed it always did,
    -- and now paying the price.
    substCxt :: [Type] -> Type -> Type
substCxt [] t :: Type
t                                        = Type
t
    substCxt (AppT (AppT EqualityT (VarT n :: Name
n)) t' :: Type
t' : ctx :: [Type]
ctx) t :: Type
t = [Type] -> Type -> Type
substCxt [Type]
ctx (Type -> Name -> Type -> Type
tsubst Type
t' Name
n Type
t)
    substCxt (AppT (AppT EqualityT t' :: Type
t') (VarT n :: Name
n) : ctx :: [Type]
ctx) t :: Type
t = [Type] -> Type -> Type
substCxt [Type]
ctx (Type -> Name -> Type -> Type
tsubst Type
t' Name
n Type
t)
    substCxt (_ : ctx :: [Type]
ctx) t :: Type
t                                 = [Type] -> Type -> Type
substCxt [Type]
ctx Type
t
    
    tsubst :: Type -> Name -> Type -> Type
tsubst t :: Type
t n :: Name
n (AppT l :: Type
l r :: Type
r) = Type -> Type -> Type
AppT (Type -> Name -> Type -> Type
tsubst Type
t Name
n Type
l) (Type -> Name -> Type -> Type
tsubst Type
t Name
n Type
r)
    tsubst t :: Type
t n :: Name
n (VarT n' :: Name
n')
                | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = Type
t
    tsubst _ _ x :: Type
x          = Type
x
      
cxtlessUnifiable :: Type -> Type -> Bool
cxtlessUnifiable :: Type -> Type -> Bool
cxtlessUnifiable t :: Type
t u :: Type
u | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
u = Bool
True
cxtlessUnifiable (VarT _) _   = Bool
True
cxtlessUnifiable _ (VarT _)   = Bool
True
cxtlessUnifiable (AppT t1 :: Type
t1 u1 :: Type
u1)
                 (AppT t2 :: Type
t2 u2 :: Type
u2) = (Type -> Type -> Bool
cxtlessUnifiable Type
t1 Type
t2) Bool -> Bool -> Bool
&& (Type -> Type -> Bool
cxtlessUnifiable Type
u1 Type
u2)
cxtlessUnifiable _ _          = Bool
False

--------------------------------------------------------------------------------
-- Template Haskell utilities
--------------------------------------------------------------------------------

------------ These are copy/pasted from an internal module of comptrans

extractCon :: Con -> (Name, [Type])
extractCon :: Con -> (Name, [Type])
extractCon (NormalC nm :: Name
nm sts :: [BangType]
sts) = (Name
nm, (BangType -> Type) -> [BangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Type
forall a b. (a, b) -> b
snd [BangType]
sts)
extractCon (RecC nm :: Name
nm vsts :: [VarBangType]
vsts)   = (Name
nm, (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(_,_,x :: Type
x) -> Type
x) [VarBangType]
vsts)
extractCon (ForallC _ _ c :: Con
c)  = Con -> (Name, [Type])
extractCon Con
c
extractCon _                = String -> (Name, [Type])
forall a. HasCallStack => String -> a
error "Unsupported constructor type encountered"

simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf :: Info -> [(Name, [Type])]
simplifyDataInf (TyConI (DataD _ _ _ _ cons :: [Con]
cons _))   = (Con -> (Name, [Type])) -> [Con] -> [(Name, [Type])]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, [Type])
extractCon [Con]
cons
simplifyDataInf (TyConI (NewtypeD _ _ _ _ con :: Con
con _)) = [Con -> (Name, [Type])
extractCon Con
con]
simplifyDataInf _                                 = String -> [(Name, [Type])]
forall a. HasCallStack => String -> a
error "Attempted to run derive on non-nullary datatype"