{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE Unsafe #-}

-- | Operations to connect dual constructions.
module Categorical.Dual
  ( importDuals,
    exportDuals,
    emptyDuals, -- shouldn’t export this
    shareDuals,
    dualType,
    dualExp,
    makeDualClass,
    makeDualDec,
    makeDualExp,
    labelDual,
    labelSelfDual,
    labelSemiDual,
  )
where

import safe Control.Applicative (pure, (<*>))
import safe Control.Arrow ((***))
import safe Control.Category (id, (.))
import safe Control.Lens (makeLenses, (%~), (&))
import safe Control.Monad (Monad, fail, join, (<=<), (=<<))
import safe Control.Monad.Trans.Class (lift)
import safe Control.Monad.Trans.Except
  ( ExceptT (ExceptT),
    runExceptT,
    throwE,
    withExceptT,
  )
import safe Data.Bitraversable (bisequence)
import safe Data.Data (Data)
import safe Data.Either (Either (Left, Right), either)
import safe Data.Eq (Eq)
import safe Data.Function (const, flip, ($))
import safe Data.Functor (fmap, (<$), (<$>))
import safe Data.List (nub)
import safe Data.Map (Map)
import safe Data.Map qualified as Map
import safe Data.Maybe (maybe)
import safe Data.Monoid (Monoid, mappend, mempty)
import safe Data.Semigroup (Semigroup, (<>))
import safe Data.String (String)
import safe Data.Traversable (sequenceA, traverse)
import safe Data.Tuple (swap, uncurry)
import safe Data.Void (Void)
import safe Language.Haskell.TH qualified as TH
import safe Language.Haskell.TH.Syntax
  ( Body (GuardedB, NormalB),
    Clause (Clause),
    Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC),
    Guard (NormalG, PatG),
    Match (Match),
    Name,
    Q,
    TySynEqn (TySynEqn),
    TypeFamilyHead (TypeFamilyHead),
    getQ,
    liftData,
    mkName,
    putQ,
    recover,
    reify,
  )
import safe Text.Show (Show, show)
import safe Prelude (undefined)

data DualMappings = DualMappings
  { DualMappings -> Map Name Type
_dualTypes :: Map Name TH.Type,
    DualMappings -> Map Name Exp
_dualValues :: Map Name TH.Exp
  }
  deriving stock (Typeable DualMappings
Typeable DualMappings =>
(forall (c :: Type -> Type).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> DualMappings -> c DualMappings)
-> (forall (c :: Type -> Type).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c DualMappings)
-> (DualMappings -> Constr)
-> (DualMappings -> DataType)
-> (forall (t :: Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c DualMappings))
-> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c DualMappings))
-> ((forall b. Data b => b -> b) -> DualMappings -> DualMappings)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> DualMappings -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> DualMappings -> r)
-> (forall u. (forall d. Data d => d -> u) -> DualMappings -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> DualMappings -> u)
-> (forall (m :: Type -> Type).
    Monad m =>
    (forall d. Data d => d -> m d) -> DualMappings -> m DualMappings)
-> (forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DualMappings -> m DualMappings)
-> (forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> DualMappings -> m DualMappings)
-> Data DualMappings
DualMappings -> Constr
DualMappings -> DataType
(forall b. Data b => b -> b) -> DualMappings -> DualMappings
forall a.
Typeable a =>
(forall (c :: Type -> Type).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: Type -> Type).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: Type -> Type -> Type) (c :: Type -> Type).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: Type -> Type).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: Type -> Type).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> DualMappings -> u
forall u. (forall d. Data d => d -> u) -> DualMappings -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DualMappings
forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DualMappings -> c DualMappings
forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DualMappings)
forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DualMappings)
$cgfoldl :: forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DualMappings -> c DualMappings
gfoldl :: forall (c :: Type -> Type).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> DualMappings -> c DualMappings
$cgunfold :: forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DualMappings
gunfold :: forall (c :: Type -> Type).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c DualMappings
$ctoConstr :: DualMappings -> Constr
toConstr :: DualMappings -> Constr
$cdataTypeOf :: DualMappings -> DataType
dataTypeOf :: DualMappings -> DataType
$cdataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DualMappings)
dataCast1 :: forall (t :: Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c DualMappings)
$cdataCast2 :: forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DualMappings)
dataCast2 :: forall (t :: Type -> Type -> Type) (c :: Type -> Type).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c DualMappings)
$cgmapT :: (forall b. Data b => b -> b) -> DualMappings -> DualMappings
gmapT :: (forall b. Data b => b -> b) -> DualMappings -> DualMappings
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> DualMappings -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> DualMappings -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> DualMappings -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DualMappings -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> DualMappings -> u
$cgmapM :: forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
gmapM :: forall (m :: Type -> Type).
Monad m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
$cgmapMp :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
gmapMp :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
$cgmapMo :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
gmapMo :: forall (m :: Type -> Type).
MonadPlus m =>
(forall d. Data d => d -> m d) -> DualMappings -> m DualMappings
Data, DualMappings -> DualMappings -> Bool
(DualMappings -> DualMappings -> Bool)
-> (DualMappings -> DualMappings -> Bool) -> Eq DualMappings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DualMappings -> DualMappings -> Bool
== :: DualMappings -> DualMappings -> Bool
$c/= :: DualMappings -> DualMappings -> Bool
/= :: DualMappings -> DualMappings -> Bool
Eq)

makeLenses ''DualMappings

instance Semigroup DualMappings where
  DualMappings Map Name Type
t Map Name Exp
v <> :: DualMappings -> DualMappings -> DualMappings
<> DualMappings Map Name Type
t' Map Name Exp
v' =
    -- NB: I reversed the order here, because I _think_ this is supposed to be
    --     right-biased?
    Map Name Type -> Map Name Exp -> DualMappings
DualMappings (Map Name Type
t' Map Name Type -> Map Name Type -> Map Name Type
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name Type
t) (Map Name Exp
v' Map Name Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Name Exp
v)

instance Monoid DualMappings where
  mappend :: DualMappings -> DualMappings -> DualMappings
mappend = DualMappings -> DualMappings -> DualMappings
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: DualMappings
mempty = Map Name Type -> Map Name Exp -> DualMappings
DualMappings Map Name Type
forall k a. Map k a
Map.empty Map Name Exp
forall k a. Map k a
Map.empty

-- | The empty set of duals, should only be used to initalize the duals for
--   `Prelude`.
emptyDuals :: Q DualMappings
emptyDuals :: Q DualMappings
emptyDuals = DualMappings -> Q DualMappings
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DualMappings -> Q DualMappings) -> DualMappings -> Q DualMappings
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Map Name Exp -> DualMappings
DualMappings Map Name Type
forall k a. Map k a
Map.empty Map Name Exp
forall k a. Map k a
Map.empty

reifyDuals :: DualMappings -> Q TH.Exp
reifyDuals :: DualMappings -> Q Exp
reifyDuals DualMappings
duals =
  [e|maybe $(DualMappings -> Q Exp
forall (m :: Type -> Type) a. (Quote m, Data a) => a -> m Exp
liftData DualMappings
duals) ($(DualMappings -> Q Exp
forall (m :: Type -> Type) a. (Quote m, Data a) => a -> m Exp
liftData DualMappings
duals) <>) <$> getQ|]

shareDuals :: DualMappings -> Q TH.Exp
shareDuals :: DualMappings -> Q Exp
shareDuals DualMappings
duals =
  [e|[] <$ (putQ . maybe $(DualMappings -> Q Exp
forall (m :: Type -> Type) a. (Quote m, Data a) => a -> m Exp
liftData DualMappings
duals) ($(DualMappings -> Q Exp
forall (m :: Type -> Type) a. (Quote m, Data a) => a -> m Exp
liftData DualMappings
duals) <>) =<< getQ)|]

-- TODO: Move this somewhere better
data AndMaybe a b = Only a | Indeed a b deriving stock (AndMaybe a b -> AndMaybe a b -> Bool
(AndMaybe a b -> AndMaybe a b -> Bool)
-> (AndMaybe a b -> AndMaybe a b -> Bool) -> Eq (AndMaybe a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq a, Eq b) => AndMaybe a b -> AndMaybe a b -> Bool
$c== :: forall a b. (Eq a, Eq b) => AndMaybe a b -> AndMaybe a b -> Bool
== :: AndMaybe a b -> AndMaybe a b -> Bool
$c/= :: forall a b. (Eq a, Eq b) => AndMaybe a b -> AndMaybe a b -> Bool
/= :: AndMaybe a b -> AndMaybe a b -> Bool
Eq, Int -> AndMaybe a b -> ShowS
[AndMaybe a b] -> ShowS
AndMaybe a b -> String
(Int -> AndMaybe a b -> ShowS)
-> (AndMaybe a b -> String)
-> ([AndMaybe a b] -> ShowS)
-> Show (AndMaybe a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> AndMaybe a b -> ShowS
forall a b. (Show a, Show b) => [AndMaybe a b] -> ShowS
forall a b. (Show a, Show b) => AndMaybe a b -> String
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> AndMaybe a b -> ShowS
showsPrec :: Int -> AndMaybe a b -> ShowS
$cshow :: forall a b. (Show a, Show b) => AndMaybe a b -> String
show :: AndMaybe a b -> String
$cshowList :: forall a b. (Show a, Show b) => [AndMaybe a b] -> ShowS
showList :: [AndMaybe a b] -> ShowS
Show)

andMaybe :: (a -> c) -> (a -> b -> c) -> a `AndMaybe` b -> c
andMaybe :: forall a c b. (a -> c) -> (a -> b -> c) -> AndMaybe a b -> c
andMaybe a -> c
f a -> b -> c
g = \case
  Only a
a -> a -> c
f a
a
  Indeed a
a b
b -> a -> b -> c
g a
a b
b

fromInfo :: TH.Info -> Q (TH.Type `AndMaybe` TH.Exp)
fromInfo :: Info -> Q (AndMaybe Type Exp)
fromInfo = \case
  TH.ClassI (TH.ClassD Cxt
_ Name
n [TyVarBndr BndrVis]
_ [FunDep]
_ [Dec]
_) [Dec]
_ -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Type -> AndMaybe Type Exp) -> Type -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only (Type -> Q (AndMaybe Type Exp)) -> Type -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
n
  TH.ClassI Dec
d [Dec]
_ -> String -> Q (AndMaybe Type Exp)
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q (AndMaybe Type Exp))
-> String -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ String
"unknown dec to extract name from: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Dec -> String
forall a. Show a => a -> String
show Dec
d
  TH.ClassOpI Name
n Type
t Name
_ -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Exp -> AndMaybe Type Exp) -> Exp -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> Exp -> AndMaybe Type Exp
forall a b. a -> b -> AndMaybe a b
Indeed Type
t (Exp -> Q (AndMaybe Type Exp)) -> Exp -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE Name
n
  TH.TyConI (TH.DataD Cxt
_ Name
n [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
_ [DerivClause]
_) -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Type -> AndMaybe Type Exp) -> Type -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only (Type -> Q (AndMaybe Type Exp)) -> Type -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
n
  TH.TyConI (TH.TySynD Name
n [TyVarBndr BndrVis]
_ Type
_) -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Type -> AndMaybe Type Exp) -> Type -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only (Type -> Q (AndMaybe Type Exp)) -> Type -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
n
  TH.TyConI (TH.NewtypeD Cxt
_ Name
n [TyVarBndr BndrVis]
_ Maybe Type
_ Con
_ [DerivClause]
_) -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Type -> AndMaybe Type Exp) -> Type -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only (Type -> Q (AndMaybe Type Exp)) -> Type -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
n
  TH.TyConI Dec
d -> String -> Q (AndMaybe Type Exp)
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q (AndMaybe Type Exp))
-> String -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ String
"unknown dec to extract name from: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Dec -> String
forall a. Show a => a -> String
show Dec
d
  TH.FamilyI Dec
d [Dec]
_ -> String -> Q (AndMaybe Type Exp)
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q (AndMaybe Type Exp))
-> String -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ String
"not yet getting type families – " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Dec -> String
forall a. Show a => a -> String
show Dec
d -- FIXME
  TH.PrimTyConI Name
n Int
_ Bool
_ -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Type -> AndMaybe Type Exp) -> Type -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only (Type -> Q (AndMaybe Type Exp)) -> Type -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT Name
n
  TH.DataConI Name
n Type
t Name
_ -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Exp -> AndMaybe Type Exp) -> Exp -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> Exp -> AndMaybe Type Exp
forall a b. a -> b -> AndMaybe a b
Indeed Type
t (Exp -> Q (AndMaybe Type Exp)) -> Exp -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.ConE Name
n
  TH.PatSynI Name
_ Type
_ -> String -> Q (AndMaybe Type Exp)
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"pattern synonym is not a type"
  TH.VarI Name
n Type
t Maybe Dec
_ -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> (Exp -> AndMaybe Type Exp) -> Exp -> Q (AndMaybe Type Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> Exp -> AndMaybe Type Exp
forall a b. a -> b -> AndMaybe a b
Indeed Type
t (Exp -> Q (AndMaybe Type Exp)) -> Exp -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.VarE Name
n
  TH.TyVarI Name
_ Type
t -> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (AndMaybe Type Exp -> Q (AndMaybe Type Exp))
-> AndMaybe Type Exp -> Q (AndMaybe Type Exp)
forall a b. (a -> b) -> a -> b
$ Type -> AndMaybe Type Exp
forall a b. a -> AndMaybe a b
Only Type
t

fromName :: Name -> Q (TH.Type `AndMaybe` TH.Exp)
fromName :: Name -> Q (AndMaybe Type Exp)
fromName = Info -> Q (AndMaybe Type Exp)
fromInfo (Info -> Q (AndMaybe Type Exp))
-> (Name -> Q Info) -> Name -> Q (AndMaybe Type Exp)
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q Info
reify

typeFromName :: Name -> Q TH.Type
typeFromName :: Name -> Q Type
typeFromName = (AndMaybe Type Exp -> Type) -> Q (AndMaybe Type Exp) -> Q Type
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Type -> Type)
-> (Type -> Exp -> Type) -> AndMaybe Type Exp -> Type
forall a c b. (a -> c) -> (a -> b -> c) -> AndMaybe a b -> c
andMaybe Type -> Type
forall a. a -> a
forall {k} (cat :: k -> k -> Type) (a :: k).
Category cat =>
cat a a
id Type -> Exp -> Type
forall a b. a -> b -> a
const) (Q (AndMaybe Type Exp) -> Q Type)
-> (Name -> Q (AndMaybe Type Exp)) -> Name -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Q (AndMaybe Type Exp)
fromName

expFromName :: Name -> Q TH.Exp
expFromName :: Name -> Q Exp
expFromName =
  (Type -> Q Exp)
-> (Type -> Exp -> Q Exp) -> AndMaybe Type Exp -> Q Exp
forall a c b. (a -> c) -> (a -> b -> c) -> AndMaybe a b -> c
andMaybe (\Type
t -> String -> Q Exp
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type -> String
forall a. Show a => a -> String
show Type
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not a value") (\Type
_ Exp
e -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Exp
e)
    (AndMaybe Type Exp -> Q Exp)
-> (Name -> Q (AndMaybe Type Exp)) -> Name -> Q Exp
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q (AndMaybe Type Exp)
fromName

-- | Returns a `TH.Type` that is the dual of the named type.
dualTypeName :: Map Name TH.Type -> Name -> ExceptT TH.Type Q TH.Type
dualTypeName :: Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
name =
  ExceptT Type Q Type
-> (Type -> ExceptT Type Q Type)
-> Maybe Type
-> ExceptT Type Q Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db (Type -> ExceptT Type Q Type)
-> (Q Type -> ExceptT Type Q Type) -> Q Type -> ExceptT Type Q Type
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Q Type -> ExceptT Type Q Type
forall (m :: Type -> Type) a. Monad m => m a -> ExceptT Type m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Type -> ExceptT Type Q Type) -> Q Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Q Type
typeFromName Name
name) Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Type -> ExceptT Type Q Type)
-> Maybe Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name Map Name Type
db

dualExpName :: DualMappings -> Name -> ExceptT (Either TH.Type TH.Exp) Q TH.Exp
dualExpName :: DualMappings -> Name -> ExceptT (Either Type Exp) Q Exp
dualExpName DualMappings
db Name
name =
  ExceptT (Either Type Exp) Q Exp
-> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp
-> ExceptT (Either Type Exp) Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db (Exp -> ExceptT (Either Type Exp) Q Exp)
-> (Q Exp -> ExceptT (Either Type Exp) Q Exp)
-> Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Q Exp -> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Exp -> ExceptT (Either Type Exp) Q Exp)
-> Q Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
expFromName Name
name) Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$
    Name -> Map Name Exp -> Maybe Exp
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
name (DualMappings -> Map Name Exp
_dualValues DualMappings
db)

retrieveDuals :: Q DualMappings
retrieveDuals :: Q DualMappings
retrieveDuals = Q DualMappings
-> (DualMappings -> Q DualMappings)
-> Maybe DualMappings
-> Q DualMappings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Q DualMappings
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"no duals imported") DualMappings -> Q DualMappings
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe DualMappings -> Q DualMappings)
-> Q (Maybe DualMappings) -> Q DualMappings
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q (Maybe DualMappings)
forall a. Typeable a => Q (Maybe a)
getQ

-- FIXME: This can get into an infinite loop in the case of missing duals.
dualType' :: Map Name TH.Type -> TH.Type -> ExceptT TH.Type Q TH.Type
dualType' :: Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db = \case
  TH.ForallT [TyVarBndr Specificity]
vs Cxt
c Type
t ->
    [TyVarBndr Specificity] -> Cxt -> Type -> Type
TH.ForallT [TyVarBndr Specificity]
vs (Cxt -> Type -> Type)
-> ExceptT Type Q Cxt -> ExceptT Type Q (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> ExceptT Type Q Type) -> Cxt -> ExceptT Type Q Cxt
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db) Cxt
c ExceptT Type Q (Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q Type
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
  TH.ForallVisT [TyVarBndr ()]
vs Type
t -> [TyVarBndr ()] -> Type -> Type
TH.ForallVisT [TyVarBndr ()]
vs (Type -> Type) -> ExceptT Type Q Type -> ExceptT Type Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
  TH.AppT (TH.AppT Type
TH.ArrowT Type
t) inner :: Type
inner@(TH.AppT (TH.AppT Type
TH.ArrowT Type
_) Type
_) -> do
    Type
t' <- Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
    Type -> Type -> Type
TH.AppT (Type -> Type -> Type
TH.AppT Type
TH.ArrowT Type
t') (Type -> Type) -> ExceptT Type Q Type -> ExceptT Type Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
inner
  TH.AppT (TH.AppT Type
TH.ArrowT Type
t) Type
t' ->
    Type -> Type -> Type
TH.AppT (Type -> Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Type -> Type
TH.AppT Type
TH.ArrowT (Type -> Type) -> ExceptT Type Q Type -> ExceptT Type Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t') ExceptT Type Q (Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q Type
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
  TH.AppT Type
t Type
t' -> Type -> Type -> Type
TH.AppT (Type -> Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t ExceptT Type Q (Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q Type
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t'
  TH.AppKindT Type
t Type
k -> Type -> Type -> Type
TH.AppKindT (Type -> Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q (Type -> Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t ExceptT Type Q (Type -> Type)
-> ExceptT Type Q Type -> ExceptT Type Q Type
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
k
  TH.SigT Type
t Type
k -> (Type -> Type -> Type) -> Type -> Type -> Type
forall a b c. (a -> b -> c) -> b -> a -> c
flip Type -> Type -> Type
TH.SigT Type
k (Type -> Type) -> ExceptT Type Q Type -> ExceptT Type Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
  TH.VarT Name
n -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.VarT Name
n
  TH.ConT Name
n -> Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
n
  TH.PromotedT Name
n -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.PromotedT Name
n
  TH.InfixT Type
_t Name
n Type
_t' -> Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
n -- t t'
  TH.UInfixT Type
_t Name
n Type
_t' -> Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
n -- t t'
  TH.ParensT Type
t -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TH.ParensT Type
t
  TH.TupleT Int
0 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT ''Void
  TH.TupleT Int
1 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TH.TupleT Int
1
  TH.TupleT Int
2 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT ''Either
  f :: Type
f@(TH.TupleT Int
_) -> Type -> ExceptT Type Q Type
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE Type
f
  TH.UnboxedTupleT Int
i -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TH.UnboxedSumT Int
i
  TH.UnboxedSumT Int
a -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TH.UnboxedTupleT Int
a
  Type
TH.ArrowT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.ArrowT
  Type
TH.EqualityT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.EqualityT
  Type
TH.ListT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.ListT
  TH.PromotedTupleT Int
0 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT ''Void
  TH.PromotedTupleT Int
1 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
TH.PromotedTupleT Int
1
  TH.PromotedTupleT Int
2 -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
TH.ConT ''Either
  f :: Type
f@(TH.PromotedTupleT Int
_) -> Type -> ExceptT Type Q Type
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE Type
f
  Type
TH.PromotedNilT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.PromotedNilT
  Type
TH.PromotedConsT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.PromotedConsT
  Type
TH.StarT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.StarT
  Type
TH.ConstraintT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.ConstraintT
  TH.LitT TyLit
l -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Type -> ExceptT Type Q Type) -> Type -> ExceptT Type Q Type
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
TH.LitT TyLit
l
  Type
TH.WildCardT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.WildCardT
  TH.ImplicitParamT String
n Type
t -> String -> Type -> Type
TH.ImplicitParamT String
n (Type -> Type) -> ExceptT Type Q Type -> ExceptT Type Q Type
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t
#if MIN_VERSION_template_haskell(2, 19, 0)
  TH.PromotedInfixT Type
_t Name
n Type
_t' -> Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
n -- t t'
  TH.PromotedUInfixT Type
_t Name
n Type
_t' -> Map Name Type -> Name -> ExceptT Type Q Type
dualTypeName Map Name Type
db Name
n -- t t'
#endif
#if MIN_VERSION_template_haskell(2, 17, 0)
  Type
TH.MulArrowT -> Type -> ExceptT Type Q Type
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Type
TH.MulArrowT
#endif

exceptT :: (Monad m) => (t1 -> m c) -> (t2 -> m c) -> ExceptT t1 m t2 -> m c
exceptT :: forall (m :: Type -> Type) t1 c t2.
Monad m =>
(t1 -> m c) -> (t2 -> m c) -> ExceptT t1 m t2 -> m c
exceptT t1 -> m c
f t2 -> m c
g =
  ( \case
      Left t1
a -> t1 -> m c
f t1
a
      Right t2
a -> t2 -> m c
g t2
a
  )
    (Either t1 t2 -> m c)
-> (ExceptT t1 m t2 -> m (Either t1 t2)) -> ExceptT t1 m t2 -> m c
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ExceptT t1 m t2 -> m (Either t1 t2)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT

-- | Returns a type that is the dual of the input type.
dualType :: TH.Type -> Q TH.Type
dualType :: Type -> Q Type
dualType Type
type' = do
  Map Name Type
duals <- DualMappings -> Map Name Type
_dualTypes (DualMappings -> Map Name Type)
-> Q DualMappings -> Q (Map Name Type)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Q DualMappings
retrieveDuals
  (Type -> Q Type)
-> (Type -> Q Type) -> ExceptT Type Q Type -> Q Type
forall (m :: Type -> Type) t1 c t2.
Monad m =>
(t1 -> m c) -> (t2 -> m c) -> ExceptT t1 m t2 -> m c
exceptT (\Type
t -> String -> Q Type
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q Type) -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String
"no dual for type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
t) Type -> Q Type
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ExceptT Type Q Type -> Q Type) -> ExceptT Type Q Type -> Q Type
forall a b. (a -> b) -> a -> b
$
    Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
duals Type
type'

dualGuard' :: DualMappings -> Guard -> ExceptT (Either TH.Type TH.Exp) Q Guard
dualGuard' :: DualMappings -> Guard -> ExceptT (Either Type Exp) Q Guard
dualGuard' DualMappings
db = \case
  NormalG Exp
e -> Exp -> Guard
NormalG (Exp -> Guard)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Guard
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  PatG [Stmt]
ss -> [Stmt] -> Guard
PatG ([Stmt] -> Guard)
-> ExceptT (Either Type Exp) Q [Stmt]
-> ExceptT (Either Type Exp) Q Guard
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db) [Stmt]
ss

dualDec' :: DualMappings -> TH.Dec -> ExceptT (Either TH.Type TH.Exp) Q TH.Dec
dualDec' :: DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
_db = Dec -> ExceptT (Either Type Exp) Q Dec
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

dualPat' :: DualMappings -> TH.Pat -> ExceptT (Either TH.Type TH.Exp) Q TH.Pat
dualPat' :: DualMappings -> Pat -> ExceptT (Either Type Exp) Q Pat
dualPat' DualMappings
db = \case
  TH.LitP Lit
l -> Pat -> ExceptT (Either Type Exp) Q Pat
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pat -> ExceptT (Either Type Exp) Q Pat)
-> Pat -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ Lit -> Pat
TH.LitP Lit
l
  TH.VarP Name
n -> Pat -> ExceptT (Either Type Exp) Q Pat
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Pat -> ExceptT (Either Type Exp) Q Pat)
-> Pat -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
TH.VarP Name
n
  TH.TupP [Pat]
ps -> [Pat] -> Pat
TH.TupP ([Pat] -> Pat)
-> ExceptT (Either Type Exp) Q [Pat]
-> ExceptT (Either Type Exp) Q Pat
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ExceptT (Either Type Exp) Q Pat)
-> [Pat] -> ExceptT (Either Type Exp) Q [Pat]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Pat -> ExceptT (Either Type Exp) Q Pat
dualPat' DualMappings
db) [Pat]
ps -- FIXME: should also Either?
  p :: Pat
p@(TH.UnboxedTupP [Pat]
_ps) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.UnboxedSumP Pat
_p Int
_a Int
_a') -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.InfixP Pat
_p Name
_n Pat
_p') -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.UInfixP Pat
_p Name
_n Pat
_p') -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.ParensP Pat
_p) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.TildeP Pat
_p) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.BangP Pat
_p) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.AsP Name
_n Pat
_p) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@Pat
TH.WildP -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.RecP Name
_n [FieldPat]
_fps) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.ListP [Pat]
_ps) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.SigP Pat
_p Type
_t) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
  p :: Pat
p@(TH.ViewP Exp
_e Pat
_p) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
#if MIN_VERSION_template_haskell(2, 22, 0)
  p@(TH.TypeP _t) -> lift . fail $ "unhandled pattern " <> show p
  p@(TH.InvisP _t) -> lift . fail $ "unhandled pattern " <> show p
#endif
#if MIN_VERSION_template_haskell(2, 18, 0)
  p :: Pat
p@(TH.ConP Name
_n Cxt
_ts [Pat]
_ps) -> Q Pat -> ExceptT (Either Type Exp) Q Pat
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> ExceptT (Either Type Exp) Q Pat)
-> (String -> Q Pat) -> String -> ExceptT (Either Type Exp) Q Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Q Pat
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> ExceptT (Either Type Exp) Q Pat)
-> String -> ExceptT (Either Type Exp) Q Pat
forall a b. (a -> b) -> a -> b
$ String
"unhandled pattern " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pat -> String
forall a. Show a => a -> String
show Pat
p
#else
  p@(TH.ConP _n _ps) -> lift . fail $ "unhandled pattern " <> show p
#endif

dualBody' :: DualMappings -> Body -> ExceptT (Either TH.Type TH.Exp) Q Body
dualBody' :: DualMappings -> Body -> ExceptT (Either Type Exp) Q Body
dualBody' DualMappings
db = \case
  GuardedB [(Guard, Exp)]
xs ->
    [(Guard, Exp)] -> Body
GuardedB ([(Guard, Exp)] -> Body)
-> ExceptT (Either Type Exp) Q [(Guard, Exp)]
-> ExceptT (Either Type Exp) Q Body
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Guard, Exp) -> ExceptT (Either Type Exp) Q (Guard, Exp))
-> [(Guard, Exp)] -> ExceptT (Either Type Exp) Q [(Guard, Exp)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ExceptT (Either Type Exp) Q Guard,
 ExceptT (Either Type Exp) Q Exp)
-> ExceptT (Either Type Exp) Q (Guard, Exp)
forall (t :: Type -> Type -> Type) (f :: Type -> Type) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence ((ExceptT (Either Type Exp) Q Guard,
  ExceptT (Either Type Exp) Q Exp)
 -> ExceptT (Either Type Exp) Q (Guard, Exp))
-> ((Guard, Exp)
    -> (ExceptT (Either Type Exp) Q Guard,
        ExceptT (Either Type Exp) Q Exp))
-> (Guard, Exp)
-> ExceptT (Either Type Exp) Q (Guard, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (DualMappings -> Guard -> ExceptT (Either Type Exp) Q Guard
dualGuard' DualMappings
db (Guard -> ExceptT (Either Type Exp) Q Guard)
-> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> (Guard, Exp)
-> (ExceptT (Either Type Exp) Q Guard,
    ExceptT (Either Type Exp) Q Exp)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db)) [(Guard, Exp)]
xs
  NormalB Exp
e -> Exp -> Body
NormalB (Exp -> Body)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Body
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e

dualMatch' :: DualMappings -> Match -> ExceptT (Either TH.Type TH.Exp) Q Match
dualMatch' :: DualMappings -> Match -> ExceptT (Either Type Exp) Q Match
dualMatch' DualMappings
db (Match Pat
p Body
b [Dec]
ds) =
  Pat -> Body -> [Dec] -> Match
Match (Pat -> Body -> [Dec] -> Match)
-> ExceptT (Either Type Exp) Q Pat
-> ExceptT (Either Type Exp) Q (Body -> [Dec] -> Match)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Pat -> ExceptT (Either Type Exp) Q Pat
dualPat' DualMappings
db Pat
p ExceptT (Either Type Exp) Q (Body -> [Dec] -> Match)
-> ExceptT (Either Type Exp) Q Body
-> ExceptT (Either Type Exp) Q ([Dec] -> Match)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Body -> ExceptT (Either Type Exp) Q Body
dualBody' DualMappings
db Body
b ExceptT (Either Type Exp) Q ([Dec] -> Match)
-> ExceptT (Either Type Exp) Q [Dec]
-> ExceptT (Either Type Exp) Q Match
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Dec -> ExceptT (Either Type Exp) Q Dec)
-> [Dec] -> ExceptT (Either Type Exp) Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
db) [Dec]
ds

dualExp' :: DualMappings -> TH.Exp -> ExceptT (Either TH.Type TH.Exp) Q TH.Exp
dualExp' :: DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db = \case
  v :: Exp
v@(TH.VarE Name
n) ->
    Q (Either (Either Type Exp) Exp) -> ExceptT (Either Type Exp) Q Exp
forall e (m :: Type -> Type) a. m (Either e a) -> ExceptT e m a
ExceptT (Q (Either (Either Type Exp) Exp)
 -> ExceptT (Either Type Exp) Q Exp)
-> (ExceptT (Either Type Exp) Q Exp
    -> Q (Either (Either Type Exp) Exp))
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Q (Either (Either Type Exp) Exp)
-> Q (Either (Either Type Exp) Exp)
-> Q (Either (Either Type Exp) Exp)
forall a. Q a -> Q a -> Q a
recover (Either (Either Type Exp) Exp -> Q (Either (Either Type Exp) Exp)
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Either (Either Type Exp) Exp -> Q (Either (Either Type Exp) Exp))
-> Either (Either Type Exp) Exp -> Q (Either (Either Type Exp) Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> Either (Either Type Exp) Exp
forall a. a -> Either (Either Type Exp) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Exp
v) (Q (Either (Either Type Exp) Exp)
 -> Q (Either (Either Type Exp) Exp))
-> (ExceptT (Either Type Exp) Q Exp
    -> Q (Either (Either Type Exp) Exp))
-> ExceptT (Either Type Exp) Q Exp
-> Q (Either (Either Type Exp) Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ExceptT (Either Type Exp) Q Exp -> Q (Either (Either Type Exp) Exp)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Either Type Exp) Q Exp
 -> ExceptT (Either Type Exp) Q Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ DualMappings -> Name -> ExceptT (Either Type Exp) Q Exp
dualExpName DualMappings
db Name
n
  TH.ConE Name
n -> DualMappings -> Name -> ExceptT (Either Type Exp) Q Exp
dualExpName DualMappings
db Name
n
  l :: Exp
l@(TH.LitE Lit
_) -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Exp
l
  TH.AppE Exp
a Exp
b -> Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Exp -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
a ExceptT (Either Type Exp) Q (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
b
  TH.AppTypeE Exp
e Type
t ->
    Exp -> Type -> Exp
TH.AppTypeE
      (Exp -> Type -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Type -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
      ExceptT (Either Type Exp) Q (Type -> Exp)
-> ExceptT (Either Type Exp) Q Type
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> Either Type Exp)
-> ExceptT Type Q Type -> ExceptT (Either Type Exp) Q Type
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Type
t)
  TH.InfixE Maybe Exp
a Exp
o Maybe Exp
b ->
    Maybe Exp -> Exp -> Maybe Exp -> Exp
TH.InfixE
      (Maybe Exp -> Exp -> Maybe Exp -> Exp)
-> ExceptT (Either Type Exp) Q (Maybe Exp)
-> ExceptT (Either Type Exp) Q (Exp -> Maybe Exp -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db) Maybe Exp
a
      ExceptT (Either Type Exp) Q (Exp -> Maybe Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Maybe Exp -> Exp)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
o
      ExceptT (Either Type Exp) Q (Maybe Exp -> Exp)
-> ExceptT (Either Type Exp) Q (Maybe Exp)
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db) Maybe Exp
b
  TH.UInfixE Exp
a Exp
o Exp
b ->
    Exp -> Exp -> Exp -> Exp
TH.UInfixE (Exp -> Exp -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Exp -> Exp -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
a ExceptT (Either Type Exp) Q (Exp -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Exp -> Exp)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
o ExceptT (Either Type Exp) Q (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
b
  TH.ParensE Exp
e -> Exp -> Exp
TH.ParensE (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.LamE [Pat]
p Exp
e -> [Pat] -> Exp -> Exp
TH.LamE [Pat]
p (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.LamCaseE [Match]
matches -> [Match] -> Exp
TH.LamCaseE ([Match] -> Exp)
-> ExceptT (Either Type Exp) Q [Match]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Match -> ExceptT (Either Type Exp) Q Match)
-> [Match] -> ExceptT (Either Type Exp) Q [Match]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Match -> ExceptT (Either Type Exp) Q Match
dualMatch' DualMappings
db) [Match]
matches
  TH.TupE [Maybe Exp]
es -> [Maybe Exp] -> Exp
TH.TupE ([Maybe Exp] -> Exp)
-> ExceptT (Either Type Exp) Q [Maybe Exp]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp))
-> [Maybe Exp] -> ExceptT (Either Type Exp) Q [Maybe Exp]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Exp -> ExceptT (Either Type Exp) Q Exp)
 -> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp))
-> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp
-> ExceptT (Either Type Exp) Q (Maybe Exp)
forall a b. (a -> b) -> a -> b
$ DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db) [Maybe Exp]
es -- FIXME: Doesn’t seem right.
  TH.UnboxedTupE [Maybe Exp]
es -> [Maybe Exp] -> Exp
TH.UnboxedTupE ([Maybe Exp] -> Exp)
-> ExceptT (Either Type Exp) Q [Maybe Exp]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp))
-> [Maybe Exp] -> ExceptT (Either Type Exp) Q [Maybe Exp]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Exp -> ExceptT (Either Type Exp) Q Exp)
 -> Maybe Exp -> ExceptT (Either Type Exp) Q (Maybe Exp))
-> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Maybe Exp
-> ExceptT (Either Type Exp) Q (Maybe Exp)
forall a b. (a -> b) -> a -> b
$ DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db) [Maybe Exp]
es
  TH.UnboxedSumE Exp
e Int
alt Int
ar ->
    Exp -> Int -> Int -> Exp
TH.UnboxedSumE (Exp -> Int -> Int -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Int -> Int -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e ExceptT (Either Type Exp) Q (Int -> Int -> Exp)
-> ExceptT (Either Type Exp) Q Int
-> ExceptT (Either Type Exp) Q (Int -> Exp)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> ExceptT (Either Type Exp) Q Int
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
alt ExceptT (Either Type Exp) Q (Int -> Exp)
-> ExceptT (Either Type Exp) Q Int
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Int -> ExceptT (Either Type Exp) Q Int
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Int
ar
  TH.CondE Exp
t Exp
c Exp
a ->
    Exp -> Exp -> Exp -> Exp
TH.CondE (Exp -> Exp -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Exp -> Exp -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
t ExceptT (Either Type Exp) Q (Exp -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Exp -> Exp)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
c ExceptT (Either Type Exp) Q (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
a
  TH.MultiIfE [(Guard, Exp)]
cases ->
    [(Guard, Exp)] -> Exp
TH.MultiIfE
      ([(Guard, Exp)] -> Exp)
-> ExceptT (Either Type Exp) Q [(Guard, Exp)]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Guard, Exp) -> ExceptT (Either Type Exp) Q (Guard, Exp))
-> [(Guard, Exp)] -> ExceptT (Either Type Exp) Q [(Guard, Exp)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((ExceptT (Either Type Exp) Q Guard,
 ExceptT (Either Type Exp) Q Exp)
-> ExceptT (Either Type Exp) Q (Guard, Exp)
forall (t :: Type -> Type -> Type) (f :: Type -> Type) a b.
(Bitraversable t, Applicative f) =>
t (f a) (f b) -> f (t a b)
bisequence ((ExceptT (Either Type Exp) Q Guard,
  ExceptT (Either Type Exp) Q Exp)
 -> ExceptT (Either Type Exp) Q (Guard, Exp))
-> ((Guard, Exp)
    -> (ExceptT (Either Type Exp) Q Guard,
        ExceptT (Either Type Exp) Q Exp))
-> (Guard, Exp)
-> ExceptT (Either Type Exp) Q (Guard, Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (DualMappings -> Guard -> ExceptT (Either Type Exp) Q Guard
dualGuard' DualMappings
db (Guard -> ExceptT (Either Type Exp) Q Guard)
-> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> (Guard, Exp)
-> (ExceptT (Either Type Exp) Q Guard,
    ExceptT (Either Type Exp) Q Exp)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db)) [(Guard, Exp)]
cases
  TH.LetE [Dec]
ds Exp
e -> [Dec] -> Exp -> Exp
TH.LetE ([Dec] -> Exp -> Exp)
-> ExceptT (Either Type Exp) Q [Dec]
-> ExceptT (Either Type Exp) Q (Exp -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> ExceptT (Either Type Exp) Q Dec)
-> [Dec] -> ExceptT (Either Type Exp) Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
db) [Dec]
ds ExceptT (Either Type Exp) Q (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.CaseE Exp
e [Match]
ms -> Exp -> [Match] -> Exp
TH.CaseE (Exp -> [Match] -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q ([Match] -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e ExceptT (Either Type Exp) Q ([Match] -> Exp)
-> ExceptT (Either Type Exp) Q [Match]
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Match -> ExceptT (Either Type Exp) Q Match)
-> [Match] -> ExceptT (Either Type Exp) Q [Match]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Match -> ExceptT (Either Type Exp) Q Match
dualMatch' DualMappings
db) [Match]
ms
  TH.CompE [Stmt]
ss -> [Stmt] -> Exp
TH.CompE ([Stmt] -> Exp)
-> ExceptT (Either Type Exp) Q [Stmt]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db) [Stmt]
ss
  TH.ArithSeqE Range
r -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Range -> Exp
TH.ArithSeqE Range
r
  TH.ListE [Exp]
es -> [Exp] -> Exp
TH.ListE ([Exp] -> Exp)
-> ExceptT (Either Type Exp) Q [Exp]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> ExceptT (Either Type Exp) Q Exp)
-> [Exp] -> ExceptT (Either Type Exp) Q [Exp]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db) [Exp]
es
  TH.SigE Exp
e Type
t ->
    Exp -> Type -> Exp
TH.SigE (Exp -> Type -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (Type -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e ExceptT (Either Type Exp) Q (Type -> Exp)
-> ExceptT (Either Type Exp) Q Type
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> Either Type Exp)
-> ExceptT Type Q Type -> ExceptT (Either Type Exp) Q Type
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Type
t)
  e :: Exp
e@(TH.RecConE Name
_ [FieldExp]
_) -> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Either Type Exp -> ExceptT (Either Type Exp) Q Exp)
-> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Either Type Exp
forall a b. b -> Either a b
Right Exp
e
  e :: Exp
e@(TH.RecUpdE Exp
_ [FieldExp]
_) -> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Either Type Exp -> ExceptT (Either Type Exp) Q Exp)
-> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Either Type Exp
forall a b. b -> Either a b
Right Exp
e
  TH.StaticE Exp
e -> Exp -> Exp
TH.StaticE (Exp -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.UnboundVarE Name
n -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
TH.UnboundVarE Name
n
  TH.LabelE String
l -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Exp
TH.LabelE String
l
  TH.ImplicitParamVarE String
n -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Exp
TH.ImplicitParamVarE String
n
#if MIN_VERSION_template_haskell(2, 22, 0)
  e@(TH.TypeE _) -> throwE $ Right e
#endif
#if MIN_VERSION_template_haskell(2, 21, 0)
  e :: Exp
e@(TH.TypedBracketE Exp
_) -> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Either Type Exp -> ExceptT (Either Type Exp) Q Exp)
-> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Either Type Exp
forall a b. b -> Either a b
Right Exp
e
  e :: Exp
e@(TH.TypedSpliceE Exp
_) -> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall (m :: Type -> Type) e a. Monad m => e -> ExceptT e m a
throwE (Either Type Exp -> ExceptT (Either Type Exp) Q Exp)
-> Either Type Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Either Type Exp
forall a b. b -> Either a b
Right Exp
e
#endif
#if MIN_VERSION_template_haskell(2, 19, 0)
  TH.LamCasesE [Clause]
cs -> [Clause] -> Exp
TH.LamCasesE ([Clause] -> Exp)
-> ExceptT (Either Type Exp) Q [Clause]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> ExceptT (Either Type Exp) Q Clause)
-> [Clause] -> ExceptT (Either Type Exp) Q [Clause]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Clause -> ExceptT (Either Type Exp) Q Clause
dualClause' DualMappings
db) [Clause]
cs
#endif
#if MIN_VERSION_template_haskell(2, 18, 0)
  TH.GetFieldE Exp
e String
f -> Exp -> String -> Exp
TH.GetFieldE (Exp -> String -> Exp)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q (String -> Exp)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e ExceptT (Either Type Exp) Q (String -> Exp)
-> ExceptT (Either Type Exp) Q String
-> ExceptT (Either Type Exp) Q Exp
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> String -> ExceptT (Either Type Exp) Q String
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure String
f
  TH.ProjectionE NonEmpty String
fs -> Exp -> ExceptT (Either Type Exp) Q Exp
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Exp -> ExceptT (Either Type Exp) Q Exp)
-> Exp -> ExceptT (Either Type Exp) Q Exp
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> Exp
TH.ProjectionE NonEmpty String
fs
#endif
#if MIN_VERSION_template_haskell(2, 17, 0)
  TH.DoE Maybe ModName
m [Stmt]
ss -> Maybe ModName -> [Stmt] -> Exp
TH.DoE Maybe ModName
m ([Stmt] -> Exp)
-> ExceptT (Either Type Exp) Q [Stmt]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db) [Stmt]
ss
  TH.MDoE Maybe ModName
m [Stmt]
ss -> Maybe ModName -> [Stmt] -> Exp
TH.MDoE Maybe ModName
m ([Stmt] -> Exp)
-> ExceptT (Either Type Exp) Q [Stmt]
-> ExceptT (Either Type Exp) Q Exp
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db) [Stmt]
ss
#else
  TH.DoE ss -> TH.DoE <$> traverse (dualStmt' db) ss
  TH.MDoE ss -> TH.MDoE <$> traverse (dualStmt' db) ss
#endif

dualClause' :: DualMappings -> Clause -> ExceptT (Either TH.Type TH.Exp) Q Clause
dualClause' :: DualMappings -> Clause -> ExceptT (Either Type Exp) Q Clause
dualClause' DualMappings
db (Clause [Pat]
ps Body
b [Dec]
ds) =
  [Pat] -> Body -> [Dec] -> Clause
Clause
    ([Pat] -> Body -> [Dec] -> Clause)
-> ExceptT (Either Type Exp) Q [Pat]
-> ExceptT (Either Type Exp) Q (Body -> [Dec] -> Clause)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pat -> ExceptT (Either Type Exp) Q Pat)
-> [Pat] -> ExceptT (Either Type Exp) Q [Pat]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Pat -> ExceptT (Either Type Exp) Q Pat
dualPat' DualMappings
db) [Pat]
ps
    ExceptT (Either Type Exp) Q (Body -> [Dec] -> Clause)
-> ExceptT (Either Type Exp) Q Body
-> ExceptT (Either Type Exp) Q ([Dec] -> Clause)
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Body -> ExceptT (Either Type Exp) Q Body
dualBody' DualMappings
db Body
b
    ExceptT (Either Type Exp) Q ([Dec] -> Clause)
-> ExceptT (Either Type Exp) Q [Dec]
-> ExceptT (Either Type Exp) Q Clause
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Dec -> ExceptT (Either Type Exp) Q Dec)
-> [Dec] -> ExceptT (Either Type Exp) Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
db) [Dec]
ds

dualStmt' :: DualMappings -> TH.Stmt -> ExceptT (Either TH.Type TH.Exp) Q TH.Stmt
dualStmt' :: DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db = \case
  TH.BindS Pat
p Exp
e -> Pat -> Exp -> Stmt
TH.BindS (Pat -> Exp -> Stmt)
-> ExceptT (Either Type Exp) Q Pat
-> ExceptT (Either Type Exp) Q (Exp -> Stmt)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Pat -> ExceptT (Either Type Exp) Q Pat
dualPat' DualMappings
db Pat
p ExceptT (Either Type Exp) Q (Exp -> Stmt)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Stmt
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.LetS [Dec]
ds -> [Dec] -> Stmt
TH.LetS ([Dec] -> Stmt)
-> ExceptT (Either Type Exp) Q [Dec]
-> ExceptT (Either Type Exp) Q Stmt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dec -> ExceptT (Either Type Exp) Q Dec)
-> [Dec] -> ExceptT (Either Type Exp) Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
db) [Dec]
ds
  TH.NoBindS Exp
e -> Exp -> Stmt
TH.NoBindS (Exp -> Stmt)
-> ExceptT (Either Type Exp) Q Exp
-> ExceptT (Either Type Exp) Q Stmt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
db Exp
e
  TH.ParS [[Stmt]]
sss -> [[Stmt]] -> Stmt
TH.ParS ([[Stmt]] -> Stmt)
-> ExceptT (Either Type Exp) Q [[Stmt]]
-> ExceptT (Either Type Exp) Q Stmt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Stmt] -> ExceptT (Either Type Exp) Q [Stmt])
-> [[Stmt]] -> ExceptT (Either Type Exp) Q [[Stmt]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db)) [[Stmt]]
sss
  TH.RecS [Stmt]
ss -> [Stmt] -> Stmt
TH.RecS ([Stmt] -> Stmt)
-> ExceptT (Either Type Exp) Q [Stmt]
-> ExceptT (Either Type Exp) Q Stmt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Stmt -> ExceptT (Either Type Exp) Q Stmt)
-> [Stmt] -> ExceptT (Either Type Exp) Q [Stmt]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Stmt -> ExceptT (Either Type Exp) Q Stmt
dualStmt' DualMappings
db) [Stmt]
ss

handleMissingDual :: ExceptT (Either TH.Type TH.Exp) Q a -> Q a
handleMissingDual :: forall a. ExceptT (Either Type Exp) Q a -> Q a
handleMissingDual =
  (Either Type Exp -> Q a)
-> (a -> Q a) -> ExceptT (Either Type Exp) Q a -> Q a
forall (m :: Type -> Type) t1 c t2.
Monad m =>
(t1 -> m c) -> (t2 -> m c) -> ExceptT t1 m t2 -> m c
exceptT
    ( String -> Q a
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
        (String -> Q a)
-> (Either Type Exp -> String) -> Either Type Exp -> Q a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String
"no dual for " <>)
        ShowS -> (Either Type Exp -> String) -> Either Type Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Type -> String) -> (Exp -> String) -> Either Type Exp -> String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((String
"type " <>) ShowS -> (Type -> String) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> String
forall a. Show a => a -> String
show) ((String
"expression " <>) ShowS -> (Exp -> String) -> Exp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Exp -> String
forall a. Show a => a -> String
show)
    )
    a -> Q a
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

-- | Convert an expression to its dual (i.e., an implementation for the dual
--   of the input expression’s type)
dualExp :: TH.Exp -> Q TH.Exp
dualExp :: Exp -> Q Exp
dualExp Exp
exp = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  ExceptT (Either Type Exp) Q Exp -> Q Exp
forall a. ExceptT (Either Type Exp) Q a -> Q a
handleMissingDual (ExceptT (Either Type Exp) Q Exp -> Q Exp)
-> ExceptT (Either Type Exp) Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ DualMappings -> Exp -> ExceptT (Either Type Exp) Q Exp
dualExp' DualMappings
duals Exp
exp

-- | Indicates that some name represents the dual of itself (e.g., `Functor`).
labelSelfDual :: Name -> Q [a]
labelSelfDual :: forall a. Name -> Q [a]
labelSelfDual Name
name = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  AndMaybe Type Exp
a <- Name -> Q (AndMaybe Type Exp)
fromName Name
name
  []
    [a] -> Q () -> Q [a]
forall a b. a -> Q b -> Q a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ
      ( (Type -> DualMappings)
-> (Type -> Exp -> DualMappings)
-> AndMaybe Type Exp
-> DualMappings
forall a c b. (a -> c) -> (a -> b -> c) -> AndMaybe a b -> c
andMaybe
          (\Type
t -> DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Type -> Identity (Map Name Type))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Type)
dualTypes ((Map Name Type -> Identity (Map Name Type))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Type -> Map Name Type) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Type
t)
          (\Type
_ Exp
e -> DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Exp -> Identity (Map Name Exp))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Exp)
dualValues ((Map Name Exp -> Identity (Map Name Exp))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Exp -> Map Name Exp) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Exp
e)
          AndMaybe Type Exp
a
      )

-- | This provides a mapping one way, but not the other. Useful for aliased
--   functions (`return`) and overconstrained versions (e.g., mapping
--  `traverse ↔ distribute` but also `mapM → distribute`).
labelSemiDual :: Name -> Name -> Q [a]
labelSemiDual :: forall a. Name -> Name -> Q [a]
labelSemiDual Name
name Name
coname = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  AndMaybe Type Exp
a <- Name -> Q (AndMaybe Type Exp)
fromName Name
name
  AndMaybe Type Exp
b <- Name -> Q (AndMaybe Type Exp)
fromName Name
coname
  [] [a] -> Q () -> Q [a]
forall a b. a -> Q b -> Q a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ case (AndMaybe Type Exp
a, AndMaybe Type Exp
b) of
    (Only Type
_, Only Type
t) -> DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ (DualMappings -> Q ()) -> DualMappings -> Q ()
forall a b. (a -> b) -> a -> b
$ DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Type -> Identity (Map Name Type))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Type)
dualTypes ((Map Name Type -> Identity (Map Name Type))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Type -> Map Name Type) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Type
t
    (Indeed Type
_ Exp
_, Indeed Type
_ Exp
e) -> DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ (DualMappings -> Q ()) -> DualMappings -> Q ()
forall a b. (a -> b) -> a -> b
$ DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Exp -> Identity (Map Name Exp))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Exp)
dualValues ((Map Name Exp -> Identity (Map Name Exp))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Exp -> Map Name Exp) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Exp
e
    (AndMaybe Type Exp
_, AndMaybe Type Exp
_) ->
      String -> Q ()
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$
        Name -> String
forall a. Show a => a -> String
show Name
name
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
coname
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"are not in the same namespace: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AndMaybe Type Exp -> String
forall a. Show a => a -> String
show AndMaybe Type Exp
a
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AndMaybe Type Exp -> String
forall a. Show a => a -> String
show AndMaybe Type Exp
b

labelDualDataT :: Name -> Name -> TH.Type -> TH.Type -> Q [a]
labelDualDataT :: forall a. Name -> Name -> Type -> Type -> Q [a]
labelDualDataT Name
name Name
coname Type
type' Type
cotype' = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  [] [a] -> Q () -> Q [a]
forall a b. a -> Q b -> Q a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ (DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Type -> Identity (Map Name Type))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Type)
dualTypes ((Map Name Type -> Identity (Map Name Type))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Type -> Map Name Type) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
coname Type
type' (Map Name Type -> Map Name Type)
-> (Map Name Type -> Map Name Type)
-> Map Name Type
-> Map Name Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Type -> Map Name Type -> Map Name Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Type
cotype'))

addDualExp :: Name -> Name -> TH.Exp -> TH.Exp -> Q DualMappings
addDualExp :: Name -> Name -> Exp -> Exp -> Q DualMappings
addDualExp Name
name Name
coname Exp
exp' Exp
coexp' = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  DualMappings -> Q DualMappings
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (DualMappings -> Q DualMappings) -> DualMappings -> Q DualMappings
forall a b. (a -> b) -> a -> b
$ DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Exp -> Identity (Map Name Exp))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Exp)
dualValues ((Map Name Exp -> Identity (Map Name Exp))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Exp -> Map Name Exp) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
coname Exp
exp' (Map Name Exp -> Map Name Exp)
-> (Map Name Exp -> Map Name Exp) -> Map Name Exp -> Map Name Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Exp
coexp')

labelDualExpT :: Name -> Name -> TH.Exp -> TH.Exp -> Q [a]
labelDualExpT :: forall a. Name -> Name -> Exp -> Exp -> Q [a]
labelDualExpT Name
name Name
coname Exp
exp' Exp
coexp' = do
  DualMappings
duals <- Q DualMappings
retrieveDuals
  [] [a] -> Q () -> Q [a]
forall a b. a -> Q b -> Q a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ (DualMappings
duals DualMappings -> (DualMappings -> DualMappings) -> DualMappings
forall a b. a -> (a -> b) -> b
& (Map Name Exp -> Identity (Map Name Exp))
-> DualMappings -> Identity DualMappings
Lens' DualMappings (Map Name Exp)
dualValues ((Map Name Exp -> Identity (Map Name Exp))
 -> DualMappings -> Identity DualMappings)
-> (Map Name Exp -> Map Name Exp) -> DualMappings -> DualMappings
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
coname Exp
exp' (Map Name Exp -> Map Name Exp)
-> (Map Name Exp -> Map Name Exp) -> Map Name Exp -> Map Name Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Exp -> Map Name Exp -> Map Name Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name Exp
coexp'))

-- | Indicate that two names are duals of each other.
labelDual :: Name -> Name -> Q [TH.Dec]
labelDual :: Name -> Name -> Q [Dec]
labelDual Name
name Name
coname = do
  AndMaybe Type Exp
a <- Name -> Q (AndMaybe Type Exp)
fromName Name
name
  AndMaybe Type Exp
b <- Name -> Q (AndMaybe Type Exp)
fromName Name
coname
  case (AndMaybe Type Exp
a, AndMaybe Type Exp
b) of
    (Only Type
a', Only Type
b') -> Name -> Name -> Type -> Type -> Q [Dec]
forall a. Name -> Name -> Type -> Type -> Q [a]
labelDualDataT Name
name Name
coname Type
a' Type
b'
    (Indeed Type
_ Exp
a', Indeed Type
_ Exp
b') -> Name -> Name -> Exp -> Exp -> Q [Dec]
forall a. Name -> Name -> Exp -> Exp -> Q [a]
labelDualExpT Name
name Name
coname Exp
a' Exp
b'
    (AndMaybe Type Exp
_, AndMaybe Type Exp
_) ->
      String -> Q [Dec]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q [Dec]) -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$
        Name -> String
forall a. Show a => a -> String
show Name
name
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" and "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
coname
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"are not in the same namespace: "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AndMaybe Type Exp -> String
forall a. Show a => a -> String
show AndMaybe Type Exp
a
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" "
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> AndMaybe Type Exp -> String
forall a. Show a => a -> String
show AndMaybe Type Exp
b

stripForall :: TH.Type -> TH.Type
stripForall :: Type -> Type
stripForall (TH.ForallT [TyVarBndr Specificity]
_ Cxt
_ Type
t) = Type
t
stripForall Type
t = Type
t

-- | Given a class, creates a new class that represents its dual, with the list
--   containing name mappings of methods to their duals.
makeDualClass :: Name -> String -> [(Name, String)] -> Q [TH.Dec]
makeDualClass :: Name -> String -> [(Name, String)] -> Q [Dec]
makeDualClass Name
name String
co [(Name, String)]
methods = do
  let coname :: Name
coname = String -> Name
mkName String
co
  Info
info <- Name -> Q Info
reify Name
name
  Type
type' <- Name -> Q Type
typeFromName Name
name
  case Info
info of
    TH.ClassI (TH.ClassD Cxt
ctx Name
_ [TyVarBndr BndrVis]
tVars [FunDep]
fds [Dec]
_) [Dec]
_ -> do
      Cxt
ctx' <- Cxt -> Cxt
forall a. Eq a => [a] -> [a]
nub (Cxt -> Cxt) -> Q Cxt -> Q Cxt
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Type) -> Cxt -> Q Cxt
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Type -> Q Type
dualType Cxt
ctx
      [(Name, Type)]
meths' <-
        ((Name, String) -> Q (Name, Type))
-> [(Name, String)] -> Q [(Name, Type)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          ( (Name, Q Type) -> Q (Name, Type)
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a.
Applicative f =>
(Name, f a) -> f (Name, a)
sequenceA
              ((Name, Q Type) -> Q (Name, Type))
-> ((Name, String) -> (Name, Q Type))
-> (Name, String)
-> Q (Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> Name
mkName (String -> Name)
-> (Name -> Q Type) -> (String, Name) -> (Name, Q Type)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: Type -> Type -> Type) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** ((Type -> Q Type
dualType (Type -> Q Type) -> (Type -> Type) -> Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Type -> Type
stripForall) (Type -> Q Type) -> (Name -> Q Type) -> Name -> Q Type
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Name -> Q Type
typeFromName))
              ((String, Name) -> (Name, Q Type))
-> ((Name, String) -> (String, Name))
-> (Name, String)
-> (Name, Q Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Name, String) -> (String, Name)
forall a b. (a, b) -> (b, a)
swap
          )
          [(Name, String)]
methods
      (Cxt -> Name -> [TyVarBndr BndrVis] -> [FunDep] -> [Dec] -> Dec
TH.ClassD Cxt
ctx' Name
coname [TyVarBndr BndrVis]
tVars [FunDep]
fds (((Name, Type) -> Dec) -> [(Name, Type)] -> [Dec]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Type -> Dec) -> (Name, Type) -> Dec
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Type -> Dec
TH.SigD) [(Name, Type)]
meths') :)
        ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Name -> Type -> Type -> Q [Dec]
forall a. Name -> Name -> Type -> Type -> Q [a]
labelDualDataT Name
name Name
coname Type
type' (Name -> Type
TH.ConT Name
coname)
    Info
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"not a type class"

makeDualExp :: String -> Q TH.Type -> Q TH.Exp -> String -> Q [TH.Dec]
makeDualExp :: String -> Q Type -> Q Exp -> String -> Q [Dec]
makeDualExp String
str Q Type
type' Q Exp
exp' String
costr = do
  let name :: Name
name = String -> Name
mkName String
str
      coname :: Name
coname = String -> Name
mkName String
costr

  [Q Dec] -> Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: Type -> Type) a. Applicative f => [f a] -> f [a]
sequenceA
    [ Name -> Type -> Dec
TH.SigD Name
name (Type -> Dec) -> Q Type -> Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type
type',
      Pat -> Body -> [Dec] -> Dec
TH.ValD (Name -> Pat
TH.VarP Name
name) (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body
NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
exp') Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [],
      Name -> Type -> Dec
TH.SigD Name
coname (Type -> Dec) -> Q Type -> Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Q Type
dualType (Type -> Q Type) -> Q Type -> Q Type
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Type
type'),
      Pat -> Body -> [Dec] -> Dec
TH.ValD (Name -> Pat
TH.VarP Name
coname) (Body -> [Dec] -> Dec) -> Q Body -> Q ([Dec] -> Dec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Body
NormalB (Exp -> Body) -> Q Exp -> Q Body
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Exp -> Q Exp
dualExp (Exp -> Q Exp) -> Q Exp -> Q Exp
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q Exp
exp')) Q ([Dec] -> Dec) -> Q [Dec] -> Q Dec
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []
    ]

-- | Creates a value that can be referenced in other modules to load the duals
--   defined in this module. Should be used at the bottom of any module that
--   uses this module.
exportDuals :: String -> Q [TH.Dec]
exportDuals :: String -> Q [Dec]
exportDuals String
name = do
  Type
typ <- [t|Q DualMappings|]
  Exp
exp <- DualMappings -> Q Exp
reifyDuals (DualMappings -> Q Exp) -> Q DualMappings -> Q Exp
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q DualMappings
retrieveDuals
  let name' :: Name
name' = String -> Name
mkName String
name
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
    [ Name -> Type -> Dec
TH.SigD Name
name' Type
typ,
      Pat -> Body -> [Dec] -> Dec
TH.ValD (Name -> Pat
TH.VarP Name
name') (Exp -> Body
NormalB Exp
exp) []
    ]

-- | Imports duals from other modules via the var created by `exportDuals` in
--   that other module.
importDuals :: Q DualMappings -> Q [a]
importDuals :: forall a. Q DualMappings -> Q [a]
importDuals Q DualMappings
duals = do
  Maybe DualMappings
oldDuals <- Q (Maybe DualMappings)
forall a. Typeable a => Q (Maybe a)
getQ
  DualMappings
newDuals <- Q DualMappings
duals
  [] [a] -> Q () -> Q [a]
forall a b. a -> Q b -> Q a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ DualMappings -> Q ()
forall a. Typeable a => a -> Q ()
putQ (DualMappings
-> (DualMappings -> DualMappings)
-> Maybe DualMappings
-> DualMappings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DualMappings
newDuals (DualMappings
newDuals <>) Maybe DualMappings
oldDuals)

errorMultipleNewNames :: Name -> Q a
errorMultipleNewNames :: forall a. Name -> Q a
errorMultipleNewNames Name
n =
  String -> Q a
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"declaration introduces multiple new names: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Show a => a -> String
show Name
n

errorNoNewName :: Q a
errorNoNewName :: forall a. Q a
errorNoNewName = String -> Q a
forall a. String -> Q a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"declaration doesn’t introduce a new name"

dualCon' :: Map Name TH.Type -> Name -> Con -> ExceptT TH.Type Q Con
dualCon' :: Map Name Type -> Name -> Con -> ExceptT Type Q Con
dualCon' Map Name Type
db Name
coname = \case
  NormalC Name
_ [BangType]
bts -> Name -> [BangType] -> Con
NormalC Name
coname ([BangType] -> Con)
-> ExceptT Type Q [BangType] -> ExceptT Type Q Con
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (BangType -> ExceptT Type Q BangType)
-> [BangType] -> ExceptT Type Q [BangType]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Type -> ExceptT Type Q Type)
-> BangType -> ExceptT Type Q BangType
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> (Bang, a) -> f (Bang, b)
traverse ((Type -> ExceptT Type Q Type)
 -> BangType -> ExceptT Type Q BangType)
-> (Type -> ExceptT Type Q Type)
-> BangType
-> ExceptT Type Q BangType
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db) [BangType]
bts
  -- TODO: Probably want to dualize field names, too.
  RecC Name
_ [VarBangType]
vbts -> Name -> [VarBangType] -> Con
RecC Name
coname ([VarBangType] -> Con)
-> ExceptT Type Q [VarBangType] -> ExceptT Type Q Con
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (VarBangType -> ExceptT Type Q VarBangType)
-> [VarBangType] -> ExceptT Type Q [VarBangType]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(Name
a, Bang
b, Type
c) -> (Type -> VarBangType)
-> ExceptT Type Q Type -> ExceptT Type Q VarBangType
forall a b. (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name
a,Bang
b,) (ExceptT Type Q Type -> ExceptT Type Q VarBangType)
-> ExceptT Type Q Type -> ExceptT Type Q VarBangType
forall a b. (a -> b) -> a -> b
$ Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
c) [VarBangType]
vbts
  InfixC BangType
bt Name
_ BangType
bt' ->
    BangType -> Name -> BangType -> Con
InfixC
      (BangType -> Name -> BangType -> Con)
-> ExceptT Type Q BangType
-> ExceptT Type Q (Name -> BangType -> Con)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> ExceptT Type Q Type)
-> BangType -> ExceptT Type Q BangType
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> (Bang, a) -> f (Bang, b)
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db) BangType
bt
      ExceptT Type Q (Name -> BangType -> Con)
-> ExceptT Type Q Name -> ExceptT Type Q (BangType -> Con)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Name -> ExceptT Type Q Name
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Name
coname
      ExceptT Type Q (BangType -> Con)
-> ExceptT Type Q BangType -> ExceptT Type Q Con
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Type -> ExceptT Type Q Type)
-> BangType -> ExceptT Type Q BangType
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> (Bang, a) -> f (Bang, b)
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db) BangType
bt'
  ForallC [TyVarBndr Specificity]
tvbs Cxt
cx Con
cn ->
    [TyVarBndr Specificity] -> Cxt -> Con -> Con
ForallC [TyVarBndr Specificity]
tvbs (Cxt -> Con -> Con)
-> ExceptT Type Q Cxt -> ExceptT Type Q (Con -> Con)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> ExceptT Type Q Type) -> Cxt -> ExceptT Type Q Cxt
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db) Cxt
cx ExceptT Type Q (Con -> Con)
-> ExceptT Type Q Con -> ExceptT Type Q Con
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Name -> Con -> ExceptT Type Q Con
dualCon' Map Name Type
db Name
coname Con
cn
  GadtC [Name]
_ns [BangType]
_bts Type
_t -> ExceptT Type Q Con
forall a. HasCallStack => a
undefined -- how do we handle the multiple names here
  RecGadtC [Name]
_ns [VarBangType]
_vbts Type
_t -> ExceptT Type Q Con
forall a. HasCallStack => a
undefined -- and here?

dualTySynEqn' :: Map Name TH.Type -> TySynEqn -> ExceptT TH.Type Q TySynEqn
dualTySynEqn' :: Map Name Type -> TySynEqn -> ExceptT Type Q TySynEqn
dualTySynEqn' Map Name Type
db (TySynEqn Maybe [TyVarBndr ()]
bs Type
t Type
t') =
  Maybe [TyVarBndr ()] -> Type -> Type -> TySynEqn
TySynEqn Maybe [TyVarBndr ()]
bs (Type -> Type -> TySynEqn)
-> ExceptT Type Q Type -> ExceptT Type Q (Type -> TySynEqn)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t ExceptT Type Q (Type -> TySynEqn)
-> ExceptT Type Q Type -> ExceptT Type Q TySynEqn
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> ExceptT Type Q Type
dualType' Map Name Type
db Type
t'

dualizeDec :: DualMappings -> Name -> TH.Dec -> Q [TH.Dec]
dualizeDec :: DualMappings -> Name -> Dec -> Q [Dec]
dualizeDec DualMappings
db Name
coname Dec
d =
  ExceptT (Either Type Exp) Q [Dec] -> Q [Dec]
forall a. ExceptT (Either Type Exp) Q a -> Q a
handleMissingDual (ExceptT (Either Type Exp) Q [Dec] -> Q [Dec])
-> ExceptT (Either Type Exp) Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (Dec
d :) ([Dec] -> [Dec]) -> (Dec -> [Dec]) -> Dec -> [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Dec -> [Dec]
forall a. a -> [a]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> [Dec])
-> ExceptT (Either Type Exp) Q Dec
-> ExceptT (Either Type Exp) Q [Dec]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Name -> Dec -> ExceptT (Either Type Exp) Q Dec
dualizeDec' DualMappings
db Name
coname Dec
d

dualizeDec' ::
  DualMappings -> Name -> TH.Dec -> ExceptT (Either TH.Type TH.Exp) Q TH.Dec
dualizeDec' :: DualMappings -> Name -> Dec -> ExceptT (Either Type Exp) Q Dec
dualizeDec' DualMappings
db Name
coname = \case
  TH.FunD Name
n [Clause]
cs -> do
    DualMappings
newMap <- Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings)
-> Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Exp -> Exp -> Q DualMappings
addDualExp Name
n Name
coname (Name -> Exp
TH.VarE Name
n) (Name -> Exp
TH.VarE Name
coname)
    Name -> [Clause] -> Dec
TH.FunD Name
coname ([Clause] -> Dec)
-> ExceptT (Either Type Exp) Q [Clause]
-> ExceptT (Either Type Exp) Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> ExceptT (Either Type Exp) Q Clause)
-> [Clause] -> ExceptT (Either Type Exp) Q [Clause]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Clause -> ExceptT (Either Type Exp) Q Clause
dualClause' DualMappings
newMap) [Clause]
cs
  -- TODO: Handle other vals
  TH.ValD (TH.VarP Name
n) Body
b [Dec]
ds -> do
    DualMappings
newMap <- Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings)
-> Q DualMappings -> ExceptT (Either Type Exp) Q DualMappings
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Exp -> Exp -> Q DualMappings
addDualExp Name
n Name
coname (Name -> Exp
TH.VarE Name
n) (Name -> Exp
TH.VarE Name
coname)
    Pat -> Body -> [Dec] -> Dec
TH.ValD (Name -> Pat
TH.VarP Name
coname)
      (Body -> [Dec] -> Dec)
-> ExceptT (Either Type Exp) Q Body
-> ExceptT (Either Type Exp) Q ([Dec] -> Dec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> DualMappings -> Body -> ExceptT (Either Type Exp) Q Body
dualBody' DualMappings
newMap Body
b
      ExceptT (Either Type Exp) Q ([Dec] -> Dec)
-> ExceptT (Either Type Exp) Q [Dec]
-> ExceptT (Either Type Exp) Q Dec
forall a b.
ExceptT (Either Type Exp) Q (a -> b)
-> ExceptT (Either Type Exp) Q a -> ExceptT (Either Type Exp) Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (Dec -> ExceptT (Either Type Exp) Q Dec)
-> [Dec] -> ExceptT (Either Type Exp) Q [Dec]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Dec -> ExceptT (Either Type Exp) Q Dec
dualDec' DualMappings
newMap) [Dec]
ds
  TH.ValD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.DataD Cxt
cx Name
_n [TyVarBndr BndrVis]
tvbs Maybe Type
k [Con
cn] [DerivClause]
dcs ->
    (Type -> Either Type Exp)
-> ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec)
-> ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec
forall a b. (a -> b) -> a -> b
$
      Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
TH.DataD
        (Cxt
 -> Name
 -> [TyVarBndr BndrVis]
 -> Maybe Type
 -> [Con]
 -> [DerivClause]
 -> Dec)
-> ExceptT Type Q Cxt
-> ExceptT
     Type
     Q
     (Name
      -> [TyVarBndr BndrVis]
      -> Maybe Type
      -> [Con]
      -> [DerivClause]
      -> Dec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> ExceptT Type Q Type) -> Cxt -> ExceptT Type Q Cxt
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db)) Cxt
cx
        ExceptT
  Type
  Q
  (Name
   -> [TyVarBndr BndrVis]
   -> Maybe Type
   -> [Con]
   -> [DerivClause]
   -> Dec)
-> ExceptT Type Q Name
-> ExceptT
     Type
     Q
     ([TyVarBndr BndrVis]
      -> Maybe Type -> [Con] -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Name -> ExceptT Type Q Name
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Name
coname
        ExceptT
  Type
  Q
  ([TyVarBndr BndrVis]
   -> Maybe Type -> [Con] -> [DerivClause] -> Dec)
-> ExceptT Type Q [TyVarBndr BndrVis]
-> ExceptT Type Q (Maybe Type -> [Con] -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [TyVarBndr BndrVis] -> ExceptT Type Q [TyVarBndr BndrVis]
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [TyVarBndr BndrVis]
tvbs
        ExceptT Type Q (Maybe Type -> [Con] -> [DerivClause] -> Dec)
-> ExceptT Type Q (Maybe Type)
-> ExceptT Type Q ([Con] -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Type -> ExceptT Type Q (Maybe Type)
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Type
k
        ExceptT Type Q ([Con] -> [DerivClause] -> Dec)
-> ExceptT Type Q [Con] -> ExceptT Type Q ([DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ((Con -> [Con] -> [Con]
forall a. a -> [a] -> [a]
: []) (Con -> [Con]) -> ExceptT Type Q Con -> ExceptT Type Q [Con]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Name -> Con -> ExceptT Type Q Con
dualCon' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Name
coname Con
cn)
        ExceptT Type Q ([DerivClause] -> Dec)
-> ExceptT Type Q [DerivClause] -> ExceptT Type Q Dec
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [DerivClause] -> ExceptT Type Q [DerivClause]
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [DerivClause]
dcs -- Should actually dualize this
  TH.DataD Cxt
_ Name
n [TyVarBndr BndrVis]
_ Maybe Type
_ [Con]
_ [DerivClause]
_ -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Dec -> ExceptT (Either Type Exp) Q Dec)
-> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Q Dec
forall a. Name -> Q a
errorMultipleNewNames Name
n
  TH.NewtypeD Cxt
cx Name
_n [TyVarBndr BndrVis]
tvbs Maybe Type
k Con
cn [DerivClause]
dcs ->
    (Type -> Either Type Exp)
-> ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec)
-> ExceptT Type Q Dec -> ExceptT (Either Type Exp) Q Dec
forall a b. (a -> b) -> a -> b
$
      Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Type
-> Con
-> [DerivClause]
-> Dec
TH.NewtypeD
        (Cxt
 -> Name
 -> [TyVarBndr BndrVis]
 -> Maybe Type
 -> Con
 -> [DerivClause]
 -> Dec)
-> ExceptT Type Q Cxt
-> ExceptT
     Type
     Q
     (Name
      -> [TyVarBndr BndrVis]
      -> Maybe Type
      -> Con
      -> [DerivClause]
      -> Dec)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> ExceptT Type Q Type) -> Cxt -> ExceptT Type Q Cxt
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db)) Cxt
cx
        ExceptT
  Type
  Q
  (Name
   -> [TyVarBndr BndrVis]
   -> Maybe Type
   -> Con
   -> [DerivClause]
   -> Dec)
-> ExceptT Type Q Name
-> ExceptT
     Type
     Q
     ([TyVarBndr BndrVis] -> Maybe Type -> Con -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Name -> ExceptT Type Q Name
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Name
coname
        ExceptT
  Type
  Q
  ([TyVarBndr BndrVis] -> Maybe Type -> Con -> [DerivClause] -> Dec)
-> ExceptT Type Q [TyVarBndr BndrVis]
-> ExceptT Type Q (Maybe Type -> Con -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [TyVarBndr BndrVis] -> ExceptT Type Q [TyVarBndr BndrVis]
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [TyVarBndr BndrVis]
tvbs
        ExceptT Type Q (Maybe Type -> Con -> [DerivClause] -> Dec)
-> ExceptT Type Q (Maybe Type)
-> ExceptT Type Q (Con -> [DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe Type -> ExceptT Type Q (Maybe Type)
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Type
k
        ExceptT Type Q (Con -> [DerivClause] -> Dec)
-> ExceptT Type Q Con -> ExceptT Type Q ([DerivClause] -> Dec)
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Map Name Type -> Name -> Con -> ExceptT Type Q Con
dualCon' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Name
coname Con
cn
        ExceptT Type Q ([DerivClause] -> Dec)
-> ExceptT Type Q [DerivClause] -> ExceptT Type Q Dec
forall a b.
ExceptT Type Q (a -> b) -> ExceptT Type Q a -> ExceptT Type Q b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> [DerivClause] -> ExceptT Type Q [DerivClause]
forall a. a -> ExceptT Type Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [DerivClause]
dcs -- Should actually dualize this
  TH.TySynD Name
_ [TyVarBndr BndrVis]
tvbs Type
t ->
    Name -> [TyVarBndr BndrVis] -> Type -> Dec
TH.TySynD Name
coname [TyVarBndr BndrVis]
tvbs (Type -> Dec)
-> ExceptT (Either Type Exp) Q Type
-> ExceptT (Either Type Exp) Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Type Exp)
-> ExceptT Type Q Type -> ExceptT (Either Type Exp) Q Type
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Type
t)
  TH.ClassD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.InstanceD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.SigD Name
_ Type
t -> Name -> Type -> Dec
TH.SigD Name
coname (Type -> Dec)
-> ExceptT (Either Type Exp) Q Type
-> ExceptT (Either Type Exp) Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Type Exp)
-> ExceptT Type Q Type -> ExceptT (Either Type Exp) Q Type
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left (Map Name Type -> Type -> ExceptT Type Q Type
dualType' (DualMappings -> Map Name Type
_dualTypes DualMappings
db) Type
t)
  TH.KiSigD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.ForeignD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.InfixD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.PragmaD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.DataFamilyD Name
_ [TyVarBndr BndrVis]
tvbs Maybe Type
k -> Dec -> ExceptT (Either Type Exp) Q Dec
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> ExceptT (Either Type Exp) Q Dec)
-> Dec -> ExceptT (Either Type Exp) Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> [TyVarBndr BndrVis] -> Maybe Type -> Dec
TH.DataFamilyD Name
coname [TyVarBndr BndrVis]
tvbs Maybe Type
k
  TH.DataInstD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.NewtypeInstD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.TySynInstD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.OpenTypeFamilyD (TypeFamilyHead Name
_n [TyVarBndr BndrVis]
tvbs FamilyResultSig
frs Maybe InjectivityAnn
ia) ->
    Dec -> ExceptT (Either Type Exp) Q Dec
forall a. a -> ExceptT (Either Type Exp) Q a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Dec -> ExceptT (Either Type Exp) Q Dec)
-> (TypeFamilyHead -> Dec)
-> TypeFamilyHead
-> ExceptT (Either Type Exp) Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TypeFamilyHead -> Dec
TH.OpenTypeFamilyD (TypeFamilyHead -> ExceptT (Either Type Exp) Q Dec)
-> TypeFamilyHead -> ExceptT (Either Type Exp) Q Dec
forall a b. (a -> b) -> a -> b
$ Name
-> [TyVarBndr BndrVis]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
coname [TyVarBndr BndrVis]
tvbs FamilyResultSig
frs Maybe InjectivityAnn
ia
  TH.ClosedTypeFamilyD (TypeFamilyHead Name
_n [TyVarBndr BndrVis]
tvbs FamilyResultSig
frs Maybe InjectivityAnn
ia) [TySynEqn]
tses ->
    TypeFamilyHead -> [TySynEqn] -> Dec
TH.ClosedTypeFamilyD (Name
-> [TyVarBndr BndrVis]
-> FamilyResultSig
-> Maybe InjectivityAnn
-> TypeFamilyHead
TypeFamilyHead Name
coname [TyVarBndr BndrVis]
tvbs FamilyResultSig
frs Maybe InjectivityAnn
ia)
      ([TySynEqn] -> Dec)
-> ExceptT (Either Type Exp) Q [TySynEqn]
-> ExceptT (Either Type Exp) Q Dec
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Either Type Exp)
-> ExceptT Type Q [TySynEqn]
-> ExceptT (Either Type Exp) Q [TySynEqn]
forall (m :: Type -> Type) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT Type -> Either Type Exp
forall a b. a -> Either a b
Left ((TySynEqn -> ExceptT Type Q TySynEqn)
-> [TySynEqn] -> ExceptT Type Q [TySynEqn]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Map Name Type -> TySynEqn -> ExceptT Type Q TySynEqn
dualTySynEqn' (Map Name Type -> TySynEqn -> ExceptT Type Q TySynEqn)
-> Map Name Type -> TySynEqn -> ExceptT Type Q TySynEqn
forall a b. (a -> b) -> a -> b
$ DualMappings -> Map Name Type
_dualTypes DualMappings
db) [TySynEqn]
tses)
  TH.RoleAnnotD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.StandaloneDerivD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.DefaultSigD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.PatSynD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.PatSynSigD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
  TH.ImplicitParamBindD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
#if MIN_VERSION_template_haskell(2, 20, 0)
  TH.TypeDataD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
#endif
#if MIN_VERSION_template_haskell(2, 19, 0)
  TH.DefaultD {} -> Q Dec -> ExceptT (Either Type Exp) Q Dec
forall (m :: Type -> Type) a.
Monad m =>
m a -> ExceptT (Either Type Exp) m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Q Dec
forall a. Q a
errorNoNewName
#endif

-- | Creates both the original declaration and its dual. Should only work for
--   declarations that introduce exactly one top-level name.
makeDualDec :: Q [TH.Dec] -> String -> Q [TH.Dec]
makeDualDec :: Q [Dec] -> String -> Q [Dec]
makeDualDec Q [Dec]
decs String
co = do
  let coname :: Name
coname = String -> Name
mkName String
co
  DualMappings
db <- Q DualMappings
retrieveDuals
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Q [[Dec]] -> Q [Dec]) -> ([Dec] -> Q [[Dec]]) -> [Dec] -> Q [Dec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Dec -> Q [Dec]) -> [Dec] -> Q [[Dec]]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (DualMappings -> Name -> Dec -> Q [Dec]
dualizeDec DualMappings
db Name
coname) ([Dec] -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Q [Dec]
decs