{-# 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 :: forall x. Sum (f : fs) e l -> Rep (Sum (f : fs) e l) x
from (M.Sum Elem f (f : fs)
w 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 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
forall x. Sum fs e l -> Rep (Sum fs e l) x
from (Elem f fs -> f e l -> Sum fs e l
forall (f :: Fragment) (fs :: Signature) (h :: Family) e.
Elem f fs -> f h e -> Sum fs h e
M.Sum Elem f fs
w0 f e l
a))
    Left f :~: f
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 x. f e l -> Rep (f e l) x
forall a x. Generic a => a -> Rep a x
from f e l
a)

  to :: forall x. Rep (Sum (f : fs) e l) x -> Sum (f : fs) e l
to (L1 Rep (f e l) x
x) = Elem f (f : fs) -> f e l -> Sum (f : fs) e l
forall (f :: Fragment) (fs :: Signature) (h :: Family) 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
forall x. Rep (f e l) x -> f e l
to Rep (f e l) x
x :: f e l)
  to (R1 Rep (Sum fs e l) x
x) = case Rep (Sum fs e l) x -> Sum fs e l
forall a x. Generic a => Rep a x -> a
forall x. Rep (Sum fs e l) x -> Sum fs e l
to Rep (Sum fs e l) x
x :: M.Sum fs e l of
    M.Sum Elem f fs
w f e l
a -> Elem f (f : fs) -> f e l -> Sum (f : fs) e l
forall (f :: Fragment) (fs :: Signature) (h :: Family) 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 :: forall x. HFix f l -> Rep (HFix f l) x
from (M.Term f (HFix f) l
x) = f (HFix f) l -> Rep (f (HFix f) l) x
forall 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 :: forall x. Rep (HFix f l) x -> HFix f l
to Rep (HFix f l) x
x = f (HFix f) l -> HFix f l
forall (f :: Fragment) h (a :: Family) 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
forall x. Rep (f (HFix f) l) x -> f (HFix f) l
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 :: forall x. (:&:) f p e l -> Rep ((:&:) f p e l) x
from (f e l
t M.:&: p
x) = f e l -> Rep (f e l) x
forall 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 :: forall x. Rep ((:&:) f p e l) x -> (:&:) f p e l
to (Rep (f e l) x
t :*: K1 p
x) = Rep (f e l) x -> f e l
forall a x. Generic a => Rep a x -> a
forall x. Rep (f e l) x -> f e l
to Rep (f e l) x
t f e l -> p -> (:&:) f p e l
forall (f :: Fragment) a (g :: Family) e.
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 [Name]
cons [Type]
labs Q [Dec]
example = do
  [InstanceD Maybe Overlap
ov [] (AppT (ConT Name
tc) Type
_) [Dec]
b] <- Q [Dec]
example
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: Family) 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 Maybe Overlap
ov Name
tc Name
c Type
l [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 [Name]
nms [Type]
tps = ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: Family) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: Family) 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 :: Family) (m :: Family) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: Family) a. Monad m => [m a] -> m [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 Name
typNm Type
lab = do
    [(Name, [Type])]
cons <- (Info -> [(Name, [Type])]) -> Q Info -> Q [(Name, [Type])]
forall (m :: Family) 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 :: Family) 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 :: Q Type
mTyp = Name -> Q Type
forall (m :: Family). Quote m => Name -> m Type
conT Name
typNm
    let mLab :: Q Type
mLab = Type -> Q Type
forall a. a -> Q a
forall (m :: Family) a. Monad m => a -> m a
return Type
lab

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

      [(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 :: Family) (m :: Family) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Family) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: Family) (m :: Family) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Family) a b. Monad m => (a -> m b) -> [a] -> m [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
forall (m :: Family). Quote m => String -> m Name
newName String
"x")) [[Type]]
xts
               [[Name]]
vars2 <- ([Type] -> Q [Name]) -> [[Type]] -> Q [[Name]]
forall (t :: Family) (m :: Family) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Family) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Type -> Q Name) -> [Type] -> Q [Name]
forall (t :: Family) (m :: Family) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Family) a b. Monad m => (a -> m b) -> [a] -> m [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
forall (m :: Family). Quote m => String -> m Name
newName String
"x")) [[Type]]
xts
               Name
eNm   <- case [Maybe Name] -> Maybe Name
forall (t :: Family) (m :: Family) 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 :: Family) (m :: Family) 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 Name
n  -> Name -> Q Name
forall a. a -> Q a
forall (m :: Family) a. Monad m => a -> m a
return Name
n
                          Maybe Name
Nothing -> String -> Q Name
forall (m :: Family). Quote m => String -> m Name
newName String
"e"
               
               let e :: Q Type
e   = Type -> Q Type
forall a. a -> Q a
forall (m :: Family) a. Monad m => a -> m a
return (Name -> Type
VarT Name
eNm)
               let rep :: Q Type
rep = Type -> Q Type
forall a. a -> Q a
forall (m :: Family) a. Monad m => a -> m a
return (Type -> Q Type) -> Type -> Q Type
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 ($Q Type
mTyp $Q Type
e $Q Type
mLab) where
                                  type Rep ($Q Type
mTyp $Q Type
e $Q Type
mLab) = $Q Type
rep
                              |]

               Dec -> [Dec] -> Q [Dec]
forall {m :: Family}. 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 :: Family) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [r] -> r
forall a. HasCallStack => [a] -> a
head
               addDecs :: Dec -> [Dec] -> m [Dec]
addDecs (InstanceD Maybe Overlap
ov [Type]
c Type
t [Dec]
ds) [Dec]
ds' = [Dec] -> m [Dec]
forall a. a -> m a
forall (m :: Family) 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, Exp
expr) = [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pat] (Exp -> Body
NormalB Exp
expr) []

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

genericTp :: [[Type]] -> Type
genericTp :: [[Type]] -> Type
genericTp [[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
_ []     = Name -> Type
ConT ''U1
    combine Name
_ [Type
x]    = Type
x
    combine Name
c (Type
x:[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 -> [Type] -> [Pat] -> Pat
ConP 'U1 [] []
makeGPat [Name
n]    = Name -> [Type] -> [Pat] -> Pat
ConP 'K1 [] [Name -> Pat
VarP Name
n]
makeGPat (Name
n:[Name]
ns) = Name -> [Type] -> [Pat] -> Pat
ConP '(:*:) [] [ Name -> [Type] -> [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 [Name
n]    = Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'K1) (Name -> Exp
VarE Name
n)
makeGExp (Name
n:[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 (Name
c, [Name]
ns) = Name -> [Type] -> [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 (Name
c, [Name]
ns) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Family) 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 [Pat
p]    = [Pat
p]
addSumPat (Pat
p:[Pat]
ps) = [Name -> [Type] -> [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 (\Pat
r -> Name -> [Type] -> [Pat] -> Pat
ConP 'R1 [] [Pat
r]) ([Pat] -> [Pat]
addSumPat [Pat]
ps)

addSumExp :: [Exp] -> [Exp]
addSumExp :: [Exp] -> [Exp]
addSumExp [Exp
e]    = [Exp
e]
addSumExp (Exp
e:[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 (\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 Type
t Name
nm = do
  (DataConI Name
_ Type
tp Name
parentNm) <- Name -> Q Info
reify Name
nm
  Bool -> Q Bool
forall a. a -> Q a
forall (m :: Family) 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 Type
tp Name
par = Type -> Type
go Type
tp
  where
    go :: Type -> Type
go (ForallT [TyVarBndr Specificity]
_ [Type]
ctx 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 Name
n) Type
_) Type
t)
                 | Name
par Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n = Type
t
    go (AppT Type
_ 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 [] Type
t                                        = Type
t
    substCxt (AppT (AppT Type
EqualityT (VarT Name
n)) Type
t' : [Type]
ctx) Type
t = [Type] -> Type -> Type
substCxt [Type]
ctx (Type -> Name -> Type -> Type
tsubst Type
t' Name
n Type
t)
    substCxt (AppT (AppT Type
EqualityT Type
t') (VarT Name
n) : [Type]
ctx) Type
t = [Type] -> Type -> Type
substCxt [Type]
ctx (Type -> Name -> Type -> Type
tsubst Type
t' Name
n Type
t)
    substCxt (Type
_ : [Type]
ctx) Type
t                                 = [Type] -> Type -> Type
substCxt [Type]
ctx Type
t
    
    tsubst :: Type -> Name -> Type -> Type
tsubst Type
t Name
n (AppT Type
l 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 Type
t Name
n (VarT Name
n')
                | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = Type
t
    tsubst Type
_ Name
_ Type
x          = Type
x
      
cxtlessUnifiable :: Type -> Type -> Bool
cxtlessUnifiable :: Type -> Type -> Bool
cxtlessUnifiable Type
t Type
u | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
u = Bool
True
cxtlessUnifiable (VarT Name
_) Type
_   = Bool
True
cxtlessUnifiable Type
_ (VarT Name
_)   = Bool
True
cxtlessUnifiable (AppT Type
t1 Type
u1)
                 (AppT Type
t2 Type
u2) = (Type -> Type -> Bool
cxtlessUnifiable Type
t1 Type
t2) Bool -> Bool -> Bool
&& (Type -> Type -> Bool
cxtlessUnifiable Type
u1 Type
u2)
cxtlessUnifiable Type
_ Type
_          = 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 Name
nm [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 Name
nm [VarBangType]
vsts)   = (Name
nm, (VarBangType -> Type) -> [VarBangType] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
_,Bang
_,Type
x) -> Type
x) [VarBangType]
vsts)
extractCon (ForallC [TyVarBndr Specificity]
_ [Type]
_ Con
c)  = Con -> (Name, [Type])
extractCon Con
c
extractCon Con
_                = String -> (Name, [Type])
forall a. HasCallStack => String -> a
error String
"Unsupported constructor type encountered"

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