{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- Module : Test.Method.Label
-- Description:
-- License: BSD-3
-- Maintainer: autotaker@gmail.com
-- Stability: experimental
module Test.Method.Label (Label (..), (:|:) (..), deriveLabel) where

import Control.Method (Method (Args, Base))
import Control.Monad.IO.Class (MonadIO)
import Data.Char (isLower, toUpper)
import qualified Data.Kind as K
import qualified Data.List as L
import qualified Data.Map.Strict as M
import Data.Typeable (Typeable)
import Language.Haskell.TH
  ( Dec,
    DecQ,
    DecsQ,
    Name,
    Pred,
    Q,
    TyVarBndr (KindedTV, PlainTV),
    Type (AppT, ArrowT, ConT, ForallT, InfixT, ListT, SigT, TupleT, VarT),
    appE,
    appT,
    caseE,
    conE,
    conP,
    conT,
    cxt,
    dataD,
    gadtC,
    instanceD,
    lam1E,
    match,
    mkName,
    nameBase,
    newName,
    normalB,
    pprint,
    stringE,
    tySynEqn,
    tySynInstD,
    valD,
    varE,
    varP,
    varT,
  )
import qualified Language.Haskell.TH.Datatype as D
import Test.Method.Dynamic (Dynamic, DynamicShow, castMethod)

-- | Type class that represents @f@ denotes the type of field names of @InterfaceOf f@
class Typeable f => Label (f :: K.Type -> K.Type) where
  -- | Interface type corrensponding to @f@
  type InterfaceOf f

  -- | Construct a interface from polymorphic function that returns each field of the interface.
  toInterface ::
    ( forall m.
      ( Typeable m,
        Method m,
        MonadIO (Base m),
        Show (Args m)
      ) =>
      f m ->
      m
    ) ->
    InterfaceOf f

  showLabel :: f m -> String

  compareLabel :: f m1 -> f m2 -> Ordering
  compareLabel f m1
x f m2
y = f m1 -> String
forall (f :: * -> *) m. Label f => f m -> String
showLabel f m1
x String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` f m2 -> String
forall (f :: * -> *) m. Label f => f m -> String
showLabel f m2
y

-- | @f :|: g@ is the disjoint union of label @f@ and label @g@.
-- Use this type when you want to specify a protocol for multiple interfaces.
--
-- ==== Example
--
-- @
-- data FooService = FooService {
--   foo :: Int -> IO Bool,
--   ...
--   }
-- data BarService = BarService {
--   bar :: String -> IO (),
--   ...
--   }
-- deriveLabel ''FooService
-- deriveLabel ''BarService
--
-- proto :: ProtocolM (FooServiceLabel ':|:' BarServiceLabel) ()
-- proto = do
--   i1 <- decl $ whenArgs ('L' Foo) (==1) \`thenReturn\` True
--   void $ decl $ whenArgs ('R' Bar) (=="bar") \`thenReturn\` () \`dependsOn\` [i1]
--
-- main :: IO ()
-- main = withProtocol proto $ \\(fooService, barService) -> do
--   ...
-- @
data (:|:) f g a = L (f a) | R (g a)
  deriving ((:|:) f g a -> (:|:) f g a -> Bool
((:|:) f g a -> (:|:) f g a -> Bool)
-> ((:|:) f g a -> (:|:) f g a -> Bool) -> Eq ((:|:) f g a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
/= :: (:|:) f g a -> (:|:) f g a -> Bool
$c/= :: forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
== :: (:|:) f g a -> (:|:) f g a -> Bool
$c== :: forall (f :: * -> *) (g :: * -> *) a.
(Eq (f a), Eq (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
Eq, Eq ((:|:) f g a)
Eq ((:|:) f g a)
-> ((:|:) f g a -> (:|:) f g a -> Ordering)
-> ((:|:) f g a -> (:|:) f g a -> Bool)
-> ((:|:) f g a -> (:|:) f g a -> Bool)
-> ((:|:) f g a -> (:|:) f g a -> Bool)
-> ((:|:) f g a -> (:|:) f g a -> Bool)
-> ((:|:) f g a -> (:|:) f g a -> (:|:) f g a)
-> ((:|:) f g a -> (:|:) f g a -> (:|:) f g a)
-> Ord ((:|:) f g a)
(:|:) f g a -> (:|:) f g a -> Bool
(:|:) f g a -> (:|:) f g a -> Ordering
(:|:) f g a -> (:|:) f g a -> (:|:) f g a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
Eq ((:|:) f g a)
forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Ordering
forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> (:|:) f g a
min :: (:|:) f g a -> (:|:) f g a -> (:|:) f g a
$cmin :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> (:|:) f g a
max :: (:|:) f g a -> (:|:) f g a -> (:|:) f g a
$cmax :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> (:|:) f g a
>= :: (:|:) f g a -> (:|:) f g a -> Bool
$c>= :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
> :: (:|:) f g a -> (:|:) f g a -> Bool
$c> :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
<= :: (:|:) f g a -> (:|:) f g a -> Bool
$c<= :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
< :: (:|:) f g a -> (:|:) f g a -> Bool
$c< :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Bool
compare :: (:|:) f g a -> (:|:) f g a -> Ordering
$ccompare :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
(:|:) f g a -> (:|:) f g a -> Ordering
$cp1Ord :: forall (f :: * -> *) (g :: * -> *) a.
(Ord (f a), Ord (g a)) =>
Eq ((:|:) f g a)
Ord, Int -> (:|:) f g a -> ShowS
[(:|:) f g a] -> ShowS
(:|:) f g a -> String
(Int -> (:|:) f g a -> ShowS)
-> ((:|:) f g a -> String)
-> ([(:|:) f g a] -> ShowS)
-> Show ((:|:) f g a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Int -> (:|:) f g a -> ShowS
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
[(:|:) f g a] -> ShowS
forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
(:|:) f g a -> String
showList :: [(:|:) f g a] -> ShowS
$cshowList :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
[(:|:) f g a] -> ShowS
show :: (:|:) f g a -> String
$cshow :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
(:|:) f g a -> String
showsPrec :: Int -> (:|:) f g a -> ShowS
$cshowsPrec :: forall (f :: * -> *) (g :: * -> *) a.
(Show (f a), Show (g a)) =>
Int -> (:|:) f g a -> ShowS
Show)

instance (Label f, Label g) => Label (f :|: g) where
  type InterfaceOf (f :|: g) = (InterfaceOf f, InterfaceOf g)
  toInterface :: (forall m.
 (Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
 (:|:) f g m -> m)
-> InterfaceOf (f :|: g)
toInterface forall m.
(Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
(:|:) f g m -> m
k = (InterfaceOf f
f, InterfaceOf g
g)
    where
      f :: InterfaceOf f
f = (forall m.
 (Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
 f m -> m)
-> InterfaceOf f
forall (f :: * -> *).
Label f =>
(forall m.
 (Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
 f m -> m)
-> InterfaceOf f
toInterface ((:|:) f g m -> m
forall m.
(Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
(:|:) f g m -> m
k ((:|:) f g m -> m) -> (f m -> (:|:) f g m) -> f m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f m -> (:|:) f g m
forall (f :: * -> *) (g :: * -> *) a. f a -> (:|:) f g a
L)
      g :: InterfaceOf g
g = (forall m.
 (Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
 g m -> m)
-> InterfaceOf g
forall (f :: * -> *).
Label f =>
(forall m.
 (Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
 f m -> m)
-> InterfaceOf f
toInterface ((:|:) f g m -> m
forall m.
(Typeable m, Method m, MonadIO (Base m), Show (Args m)) =>
(:|:) f g m -> m
k ((:|:) f g m -> m) -> (g m -> (:|:) f g m) -> g m -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g m -> (:|:) f g m
forall (f :: * -> *) (g :: * -> *) a. g a -> (:|:) f g a
R)
  showLabel :: (:|:) f g m -> String
showLabel (L f m
x) = String
"L " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> f m -> String
forall (f :: * -> *) m. Label f => f m -> String
showLabel f m
x
  showLabel (R g m
x) = String
"R " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> g m -> String
forall (f :: * -> *) m. Label f => f m -> String
showLabel g m
x

-- |
-- Generate the label type from given interface type.
--
-- * Define GADT @XXXLabel m@ for interface @XXX@.
--
--     * @FieldX :: XXXLabel X@ for each field @fieldX :: X@ where @X@ is a standard type.
--     * @PolyFieldX :: XXXLabel ty[Dynamic/a]@ for each field of the form @polyFieldX :: (forall a. Typeable a => ty)@
--
--         * Type variable @a@ is substituted with @DynamicShow@ if @a@ is instances of 'Show' and 'Typeable'
--         * Type variable @a@ is substituted with @Dynamic@ if @a@ is an instance of 'Typeable' but not 'Show'
--         * Report an error if type variable @a@ is not an instance of 'Typeable'
--
-- * Define instance @Label XXXLabel@.
--
-- ==== Example
--
-- @
-- data API env = API {
--     _foo :: Int -> RIO env Int,
--     _bar :: forall a. (Show a, Typeable a) => String -> RIO env (Maybe a),
--     _baz :: forall b. (Typeable a) => b -> RIO env ()
--   }
-- @
--
-- @deriveLabel ''API@ will generate the following code.
--
-- @
-- data APILabel env m where
--     Foo :: APILabel env (Int -> RIO env Int)
--     Bar :: APILabel env (String -> RIO env (Maybe DynamicShow)) -- type variable \`a\` is replaced with 'DynamicShow'
--     Baz :: APILabel env (Dynamic -> RIO env ()) -- type variable \'b\' is replaced with 'Dynamic'
--
-- instance Label (APILabel env) where
--     type InterfaceOf (APILabel env) = API env
--     toInterface k = API (k Foo) (castMethod (k Bar)) (castMethod (k Baz))
--     showLabel x = case x of
--       Foo -> "Foo"
--       Bar -> "Bar"
--       Baz -> "Baz"
-- @
deriveLabel :: Name -> DecsQ
deriveLabel :: Name -> DecsQ
deriveLabel Name
name = do
  DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
name
  [TyVarBndr]
tyVars <- (Type -> Q TyVarBndr) -> [Type] -> Q [TyVarBndr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Q TyVarBndr
extractTyVar ([Type] -> Q [TyVarBndr]) -> [Type] -> Q [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Type]
D.datatypeInstTypes DatatypeInfo
info
  ConstructorInfo
consInfo <- case DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info of
    [ConstructorInfo
consInfo] -> ConstructorInfo -> Q ConstructorInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConstructorInfo
consInfo
    [ConstructorInfo]
_ -> String -> Q ConstructorInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ConstructorInfo) -> String -> Q ConstructorInfo
forall a b. (a -> b) -> a -> b
$ String
"Multiple constructors: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint Name
name
  [Name]
fieldNames <- case ConstructorInfo -> ConstructorVariant
D.constructorVariant ConstructorInfo
consInfo of
    D.RecordConstructor [Name]
names -> [Name] -> Q [Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Name]
names
    ConstructorVariant
_ -> String -> Q [Name]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q [Name]) -> String -> Q [Name]
forall a b. (a -> b) -> a -> b
$ String
"Constructor must be a record: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint (ConstructorInfo -> Name
D.constructorName ConstructorInfo
consInfo)
  [Name]
labelConNames <- (Name -> Q Name) -> [Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Q Name
fieldToLabel [Name]
fieldNames
  let fields :: [Type]
fields = ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
consInfo
      labelTy :: Type
labelTy = (Type -> Name -> Type) -> Type -> [Name] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (((Type -> Type) -> (Name -> Type) -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Type
VarT) ((Type -> Type) -> Name -> Type)
-> (Type -> Type -> Type) -> Type -> Name -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT) (Name -> Type
ConT Name
labelName) [Name]
tyVarNames
      labelName :: Name
labelName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Label") ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
name
      tyVarNames :: [Name]
tyVarNames = (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
bndrToName [TyVarBndr]
tyVars
      recordTy :: Type
recordTy = DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info
      recordConName :: Name
recordConName = ConstructorInfo -> Name
D.constructorName ConstructorInfo
consInfo
  Dec
labelDec <- ([TyVarBndr], [Type], Type, Name, [Name]) -> Q Dec
deriveLabelData ([TyVarBndr]
tyVars, [Type]
fields, Type
labelTy, Name
labelName, [Name]
labelConNames)
  Dec
labelInstDec <- ([TyVarBndr], Type, Type, Name, [Name]) -> Q Dec
deriveLabelInst ([TyVarBndr]
tyVars, Type
labelTy, Type
recordTy, Name
recordConName, [Name]
labelConNames)
  [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
labelDec, Dec
labelInstDec]

deriveLabelInst :: ([TyVarBndr], Type, Type, Name, [Name]) -> DecQ
deriveLabelInst :: ([TyVarBndr], Type, Type, Name, [Name]) -> Q Dec
deriveLabelInst ([TyVarBndr]
tyVars, Type
labelTy, Type
interfaceTy, Name
interfaceConName, [Name]
labelConNames) =
  CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt [TypeQ]
cxts) (Name -> TypeQ
conT ''Label TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
labelTy) [Q Dec
interfaceOfDec, Q Dec
toInterfaceDec, Q Dec
showLabelDec]
  where
    cxts :: [TypeQ]
cxts = [Name -> TypeQ
conT ''Typeable TypeQ -> TypeQ -> TypeQ
`appT` Name -> TypeQ
varT Name
n | Name
n <- TyVarBndr -> Name
bndrToName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TyVarBndr]
tyVars]
    interfaceOfDec :: Q Dec
interfaceOfDec = TySynEqnQ -> Q Dec
tySynInstD (Maybe [TyVarBndr] -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing (Name -> TypeQ
conT ''InterfaceOf TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
labelTy) (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interfaceTy))
    -- toInterface = \k -> API (castMethod $ k Foo) (castMethod $ k Bar) (castMethod $ k Baz)
    toInterfaceDec :: Q Dec
toInterfaceDec = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'toInterface) (ExpQ -> BodyQ
normalB ExpQ
bodyE) []
      where
        k :: Name
k = String -> Name
mkName String
"k"
        bodyE :: ExpQ
bodyE = PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
k) (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (ExpQ -> Name -> ExpQ) -> ExpQ -> [Name] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> Name -> ExpQ
step (Name -> ExpQ
conE Name
interfaceConName) [Name]
labelConNames
        step :: ExpQ -> Name -> ExpQ
step ExpQ
acc Name
labelCon = ExpQ
acc ExpQ -> ExpQ -> ExpQ
`appE` ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'castMethod) (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
k) (Name -> ExpQ
conE Name
labelCon))
    showLabelDec :: Q Dec
showLabelDec = PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP 'showLabel) (ExpQ -> BodyQ
normalB ExpQ
bodyE) []
      where
        x :: Name
x = String -> Name
mkName String
"x"
        bodyE :: ExpQ
bodyE = PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((Name -> MatchQ) -> [Name] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> MatchQ
showCase [Name]
labelConNames))
        showCase :: Name -> MatchQ
showCase Name
conName =
          PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName []) (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ String -> ExpQ
stringE (String -> ExpQ) -> String -> ExpQ
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
conName) []

-- |
-- @
-- data API env = API {
--   _foo :: RIO env Int,
--   _bar :: Text -> RIO env Bool,
-- }
-- >>>
-- data APILabel env m where
--   Foo :: APILabel env (RIO env Int)
--   Bar :: APILabel env (Text -> RIO env Bool)
-- @
deriveLabelData :: ([TyVarBndr], [Type], Type, Name, [Name]) -> Q Dec
deriveLabelData :: ([TyVarBndr], [Type], Type, Name, [Name]) -> Q Dec
deriveLabelData ([TyVarBndr]
tyVars, [Type]
fields, Type
labelTy, Name
labelName, [Name]
labelConNames) = do
  Name
m <- String -> Q Name
newName String
"m"
  CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [ConQ]
-> [DerivClauseQ]
-> Q Dec
dataD ([TypeQ] -> CxtQ
cxt []) Name
labelName ([TyVarBndr]
tyVars [TyVarBndr] -> [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndr
PlainTV Name
m]) Maybe Type
forall a. Maybe a
Nothing [ConQ]
consQ []
  where
    consQ :: [ConQ]
consQ = (Type -> Name -> ConQ) -> [Type] -> [Name] -> [ConQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> Name -> ConQ
toLabel [Type]
fields [Name]
labelConNames
    --  $cName :: $labelName x1 ... xn $fieldTy
    toLabel :: Type -> Name -> ConQ
toLabel Type
fieldTy Name
cName = [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC [Name
cName] [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
labelTy TypeQ -> TypeQ -> TypeQ
`appT` Type -> TypeQ
unquantify Type
fieldTy)

unquantify :: Type -> Q Type
unquantify :: Type -> TypeQ
unquantify _ty :: Type
_ty@(ForallT [TyVarBndr]
bndrs [Type]
ctx Type
ty) = do
  Map Name Type
tbl <- [(Name, Type)] -> Map Name Type
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Type)] -> Map Name Type)
-> Q [(Name, Type)] -> Q (Map Name Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TyVarBndr -> Q (Name, Type)) -> [TyVarBndr] -> Q [(Name, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Type -> [Type] -> TyVarBndr -> Q (Name, Type)
substBndr Type
_ty [Type]
ctx) [TyVarBndr]
bndrs
  Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl Type
ty
unquantify Type
ty = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty

substBndr :: Type -> [Pred] -> TyVarBndr -> Q (Name, Type)
substBndr :: Type -> [Type] -> TyVarBndr -> Q (Name, Type)
substBndr Type
ty [Type]
preds = Name -> Q (Name, Type)
go (Name -> Q (Name, Type))
-> (TyVarBndr -> Name) -> TyVarBndr -> Q (Name, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
bndrToName
  where
    go :: Name -> Q (Name, Type)
go Name
n
      | (Name -> Type
ConT ''Typeable Type -> Type -> Type
`AppT` Name -> Type
VarT Name
n) Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type]
preds
          Bool -> Bool -> Bool
&& (Name -> Type
ConT ''Show Type -> Type -> Type
`AppT` Name -> Type
VarT Name
n) Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type]
preds =
        (Name, Type) -> Q (Name, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Name -> Type
ConT ''DynamicShow)
      | (Name -> Type
ConT ''Typeable Type -> Type -> Type
`AppT` Name -> Type
VarT Name
n) Type -> [Type] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Type]
preds = (Name, Type) -> Q (Name, Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name
n, Name -> Type
ConT ''Dynamic)
      | Bool
otherwise =
        String -> Q (Name, Type)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (Name, Type)) -> String -> Q (Name, Type)
forall a b. (a -> b) -> a -> b
$
          String
"cannot unquantify: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
ty
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" because Typeable "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint Name
n
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" constraint is missing"

subst :: M.Map Name Type -> Type -> Q Type
subst :: Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl (VarT Name
x) = case Name -> Map Name Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
x Map Name Type
tbl of
  Just Type
t -> Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
  Maybe Type
Nothing -> Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> Type
VarT Name
x
subst Map Name Type
tbl (AppT Type
f Type
x) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> TypeQ -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl Type
f Q (Type -> Type) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl Type
x
subst Map Name Type
tbl (InfixT Type
x Name
op Type
y) = Type -> Name -> Type -> Type
InfixT (Type -> Name -> Type -> Type) -> TypeQ -> Q (Name -> Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl Type
x Q (Name -> Type -> Type) -> Q Name -> Q (Type -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
op Q (Type -> Type) -> TypeQ -> TypeQ
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Name Type -> Type -> TypeQ
subst Map Name Type
tbl Type
y
subst Map Name Type
_ Type
ArrowT = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ArrowT
subst Map Name Type
_ ty :: Type
ty@ConT {} = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
subst Map Name Type
_ ty :: Type
ty@TupleT {} = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
subst Map Name Type
_ ty :: Type
ty@Type
ListT = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty
subst Map Name Type
_ ty :: Type
ty@ForallT {} = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ String
"nested forall quantifier is not supported: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
ty
subst Map Name Type
_ Type
ty = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> TypeQ) -> String -> TypeQ
forall a b. (a -> b) -> a -> b
$ String
"conversion for " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
ty String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not implemented yet. Please raise an issue."

bndrToName :: TyVarBndr -> Name
bndrToName :: TyVarBndr -> Name
bndrToName (PlainTV Name
n) = Name
n
bndrToName (KindedTV Name
n Type
_) = Name
n

-- |
-- @
-- fieldToLabel (mkName "_hello") = pure (mkName \"Hello\")
-- @
fieldToLabel :: Name -> Q Name
fieldToLabel :: Name -> Q Name
fieldToLabel Name
fieldName = String -> Q Name
toConName String
trimed
  where
    base :: String
base = Name -> String
nameBase Name
fieldName
    trimed :: String
trimed = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
L.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isLower) String
base
    toConName :: String -> Q Name
toConName String
"" = String -> Q Name
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ String
"cannot convert field name to constructor name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name -> String
forall a. Ppr a => a -> String
pprint Name
fieldName
    toConName (Char
x : String
xs) = Name -> Q Name
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Q Name) -> Name -> Q Name
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
toUpper Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
xs

extractTyVar :: Type -> Q TyVarBndr
extractTyVar :: Type -> Q TyVarBndr
extractTyVar (SigT (VarT Name
x) Type
k) = TyVarBndr -> Q TyVarBndr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr -> Q TyVarBndr) -> TyVarBndr -> Q TyVarBndr
forall a b. (a -> b) -> a -> b
$ Name -> Type -> TyVarBndr
KindedTV Name
x Type
k
extractTyVar (VarT Name
x) = TyVarBndr -> Q TyVarBndr
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyVarBndr -> Q TyVarBndr) -> TyVarBndr -> Q TyVarBndr
forall a b. (a -> b) -> a -> b
$ Name -> TyVarBndr
PlainTV Name
x
extractTyVar Type
ty = String -> Q TyVarBndr
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q TyVarBndr) -> String -> Q TyVarBndr
forall a b. (a -> b) -> a -> b
$ String
"cannot extract type variable: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Ppr a => a -> String
pprint Type
ty