module THLego.Instances where

import Language.Haskell.TH
import THLego.Helpers
import qualified THLego.Helpers as Helpers
import qualified THLego.Lambdas as Lambdas
import THLego.Prelude
import qualified TemplateHaskell.Compat.V0208 as Compat

-- * IsLabel

-- |
-- The most general template for 'IsLabel'.
isLabel :: TyLit -> Type -> Exp -> Dec
isLabel :: TyLit -> Type -> Exp -> Dec
isLabel TyLit
label Type
repType Exp
fromLabelExp =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [] Type
headType [Dec
fromLabelDec]
  where
    headType :: Type
headType =
      Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
repType]
    fromLabelDec :: Dec
fromLabelDec =
      Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] Body
body []]
      where
        body :: Body
body =
          Exp -> Body
NormalB Exp
fromLabelExp

-- ** Constructor

-- |
--
-- > instance (a ~ Text) => IsLabel "error" (a -> Result)
constructorIsLabel :: TyLit -> Type -> [Type] -> Exp -> Dec
constructorIsLabel :: TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType Cxt
memberTypes Exp
fromLabelExp =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing Cxt
paramPreds Type
headType [Dec
fromLabelDec]
  where
    paramPreds :: Cxt
paramPreds =
      Cxt
memberTypes
        forall a b. a -> (a -> b) -> b
& forall a b. (Name -> a -> b) -> [a] -> [b]
Helpers.mapWithAlphabeticName (\Name
n Type
t -> Type -> Cxt -> Type
multiAppT Type
EqualityT [Name -> Type
VarT Name
n, Type
t])
    headType :: Type
headType =
      Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
repType]
      where
        repType :: Type
repType =
          Cxt -> Type -> Type
arrowChainT Cxt
memberVarTypes Type
ownerType
          where
            memberVarTypes :: Cxt
memberVarTypes =
              forall a b. (Name -> a -> b) -> [a] -> [b]
Helpers.mapWithAlphabeticName (forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Type
VarT) Cxt
paramPreds
    fromLabelDec :: Dec
fromLabelDec =
      Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]

newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec
newtypeConstructorIsLabel :: TyLit -> Type -> Name -> Type -> Dec
newtypeConstructorIsLabel TyLit
label Type
ownerType Name
conName Type
memberType =
  TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName [Type
memberType]

sumConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumConstructorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
  TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType Cxt
memberTypes (Name -> Exp
ConE Name
conName)

enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec
enumConstructorIsLabel :: TyLit -> Type -> Name -> Dec
enumConstructorIsLabel TyLit
label Type
ownerType Name
conName =
  TyLit -> Type -> Name -> Cxt -> Dec
sumConstructorIsLabel TyLit
label Type
ownerType Name
conName []

-- |
-- 'IsLabel' instance which converts tuple to ADT.
tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
tupleAdtConstructorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
tupleAdtConstructorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
  TyLit -> Type -> Cxt -> Exp -> Dec
constructorIsLabel TyLit
label Type
ownerType [Type
memberType] Exp
fromLabelExp
  where
    memberType :: Type
memberType =
      Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes
    fromLabelExp :: Exp
fromLabelExp =
      Name -> Int -> Exp
Lambdas.tupleToProduct Name
conName (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes)

-- ** Mapper

-- |
-- Template of 'IsLabel' for instances mapping to mapper functions.
--
-- > instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person)
mapperIsLabel ::
  -- | Field label.
  TyLit ->
  -- | Type of the product.
  Type ->
  -- | Type of the mapper function.
  Type ->
  -- | 'fromLabel' definition expression.
  Exp ->
  -- | 'IsLabel' instance declaration.
  Dec
mapperIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type
memberPred] Type
headType [Dec
fromLabelDec]
  where
    projVarType :: Type
projVarType =
      Name -> Type
VarT (String -> Name
mkName String
"mapper")
    memberPred :: Type
memberPred =
      Type -> Cxt -> Type
multiAppT Type
EqualityT [Type
projVarType, Type
projectionType]
    headType :: Type
headType =
      Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
instanceType]
      where
        instanceType :: Type
instanceType =
          Cxt -> Type -> Type
arrowChainT [Type
projVarType, Type
ownerType] Type
ownerType
    fromLabelDec :: Dec
fromLabelDec =
      Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]

-- |
-- Template of 'IsLabel' for instances mapping to mapper functions.
--
-- > instance (mapper ~ (Text -> Text)) => IsLabel "name" (mapper -> Person -> Person)
productMapperIsLabel ::
  -- | Field label.
  TyLit ->
  -- | Type of the product.
  Type ->
  -- | Type of the member we\'re focusing on.
  Type ->
  -- | Constructor name.
  Name ->
  -- | Total amount of members in the product.
  Int ->
  -- | Offset of the member we're focusing on.
  Int ->
  -- | 'IsLabel' instance declaration.
  Dec
productMapperIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productMapperIsLabel TyLit
label Type
ownerType Type
memberType Name
conName Int
totalMemberTypes Int
offset =
  TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel
    TyLit
label
    Type
ownerType
    (Type -> Cxt -> Type
multiAppT Type
ArrowT [Type
memberType, Type
memberType])
    (Name -> Int -> Int -> Exp
Lambdas.productMapper Name
conName Int
totalMemberTypes Int
offset)

-- |
-- Template of 'IsLabel' for instances mapping to mapper functions.
--
-- > instance (mapper ~ (Int -> Text -> (Int, Text))) => IsLabel "error" (mapper -> Result -> Result)
sumMapperIsLabel ::
  -- | Field label.
  TyLit ->
  -- | Type of the product.
  Type ->
  -- | Constructor name.
  Name ->
  -- | Member types we\'re focusing on.
  [Type] ->
  -- | 'IsLabel' instance declaration.
  Dec
sumMapperIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumMapperIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
  TyLit -> Type -> Type -> Exp -> Dec
mapperIsLabel
    TyLit
label
    Type
ownerType
    (Cxt -> Type -> Type
arrowChainT Cxt
memberTypes (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes))
    (Name -> Int -> Exp
Lambdas.sumMapper Name
conName (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes))

-- ** Accessor

-- |
-- Template of 'IsLabel' for instances mapping to accessor functions.
accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel :: TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [Type
memberPred] Type
headType [Dec
fromLabelDec]
  where
    projVarType :: Type
projVarType =
      Name -> Type
VarT Name
aName
    memberPred :: Type
memberPred =
      Type -> Cxt -> Type
multiAppT Type
EqualityT [Type
projVarType, Type
projectionType]
    headType :: Type
headType =
      Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''IsLabel) [TyLit -> Type
LitT TyLit
label, Type
instanceType]
      where
        instanceType :: Type
instanceType =
          Type -> Cxt -> Type
multiAppT Type
ArrowT [Type
ownerType, Type
projVarType]
    fromLabelDec :: Dec
fromLabelDec =
      Name -> [Clause] -> Dec
FunD 'fromLabel [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
fromLabelExp) []]

-- |
-- Instance of 'IsLabel' for a member of a product type.
productAccessorIsLabel ::
  -- | Field label.
  TyLit ->
  -- | Type of the product.
  Type ->
  -- | Type of the member we\'re focusing on.
  Type ->
  -- | Constructor name.
  Name ->
  -- | Total amount of members in the product.
  Int ->
  -- | Offset of the member we're focusing on.
  Int ->
  -- | 'IsLabel' instance declaration.
  Dec
productAccessorIsLabel :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productAccessorIsLabel TyLit
label Type
ownerType Type
projectionType Name
conName Int
numMembers Int
offset =
  TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
  where
    fromLabelExp :: Exp
fromLabelExp =
      Name -> Int -> Int -> Exp
Lambdas.productGetter Name
conName Int
numMembers Int
offset

-- |
-- > instance (a ~ Maybe Text) => IsLabel "error" (Result -> a)
sumAccessorIsLabel :: TyLit -> Type -> Name -> [Type] -> Dec
sumAccessorIsLabel :: TyLit -> Type -> Name -> Cxt -> Dec
sumAccessorIsLabel TyLit
label Type
ownerType Name
conName Cxt
memberTypes =
  TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
  where
    projectionType :: Type
projectionType =
      Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes)
    fromLabelExp :: Exp
fromLabelExp =
      Name -> Int -> Exp
Lambdas.adtConstructorNarrower Name
conName (forall (t :: * -> *) a. Foldable t => t a -> Int
length Cxt
memberTypes)

enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec
enumAccessorIsLabel :: TyLit -> Type -> Name -> Dec
enumAccessorIsLabel TyLit
label Type
ownerType Name
conName =
  TyLit -> Type -> Type -> Exp -> Dec
accessorIsLabel TyLit
label Type
ownerType Type
projectionType Exp
fromLabelExp
  where
    projectionType :: Type
projectionType =
      Name -> Type
ConT ''Bool
    fromLabelExp :: Exp
fromLabelExp =
      Name -> Exp
Lambdas.enumConstructorToBool Name
conName

-- * 'HasField'

-- | The most general template for 'HasField'.
hasField :: TyLit -> Type -> Type -> [Clause] -> Dec
hasField :: TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD forall a. Maybe a
Nothing [] Type
headType [Dec
getFieldDec]
  where
    headType :: Type
headType =
      Type -> Cxt -> Type
multiAppT (Name -> Type
ConT ''HasField) [TyLit -> Type
LitT TyLit
fieldLabel, Type
ownerType, Type
projectionType]
    getFieldDec :: Dec
getFieldDec =
      Name -> [Clause] -> Dec
FunD 'getField [Clause]
getFieldFunClauses

-- |
-- 'HasField' instance which focuses on a variant of an enum
-- and projects it into 'Bool' signaling whether the value matches.
--
-- Generates code of the following pattern:
--
-- > instance HasField "fieldLabel" enumType Bool
enumHasField ::
  -- | Field label.
  TyLit ->
  -- | Enum type.
  Type ->
  -- | Name of the constructor.
  Name ->
  -- | 'HasField' instance declaration.
  Dec
enumHasField :: TyLit -> Type -> Name -> Dec
enumHasField TyLit
fieldLabel Type
ownerType Name
constructorName =
  TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
  where
    projectionType :: Type
projectionType =
      Name -> Type
ConT ''Bool
    getFieldFunClauses :: [Clause]
getFieldFunClauses =
      [Clause
matching, Clause
unmatching]
      where
        matching :: Clause
matching =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conP Name
constructorName []] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            bodyExp :: Exp
bodyExp =
              Name -> Exp
ConE 'True
        unmatching :: Clause
unmatching =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            bodyExp :: Exp
bodyExp =
              Name -> Exp
ConE 'False

-- |
-- Instance of 'HasField' for a constructor of a sum ADT,
-- projecting it into a 'Maybe' tuple of its members.
--
-- Generates code of the following pattern:
--
-- > instance HasField "fieldLabel" sumAdt (Maybe projectionType)
--
-- - When the amount of member types is 0, @projectionType@ is @()@.
-- - When the amount of member types is 1, it is that member type.
-- - Otherwise it is a tuple of those members.
sumHasField ::
  -- | Field label.
  TyLit ->
  -- | The ADT type.
  Type ->
  -- | Name of the constructor.
  Name ->
  -- | Member types of that constructor.
  [Type] ->
  -- | 'HasField' instance declaration.
  Dec
sumHasField :: TyLit -> Type -> Name -> Cxt -> Dec
sumHasField TyLit
fieldLabel Type
ownerType Name
constructorName Cxt
memberTypes =
  TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
  where
    projectionType :: Type
projectionType =
      Type -> Type -> Type
AppT (Name -> Type
ConT ''Maybe) (Cxt -> Type
appliedTupleOrSingletonT Cxt
memberTypes)
    getFieldFunClauses :: [Clause]
getFieldFunClauses =
      [Clause
matching, Clause
unmatching]
      where
        varNames :: [Name]
varNames =
          Cxt
memberTypes
            forall a b. a -> (a -> b) -> b
& forall a b. (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName (forall a b. a -> b -> a
const forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
        matching :: Clause
matching =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conP Name
constructorName [Pat]
pats] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            pats :: [Pat]
pats =
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames
            bodyExp :: Exp
bodyExp =
              Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Just) ([Exp] -> Exp
appliedTupleE (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Exp
VarE [Name]
varNames))
        unmatching :: Clause
unmatching =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            bodyExp :: Exp
bodyExp =
              Name -> Exp
ConE 'Nothing

-- |
-- Instance of 'HasField' for a member of a product type.
productHasField ::
  -- | Field label.
  TyLit ->
  -- | Type of the product.
  Type ->
  -- | Type of the member we\'re focusing on.
  Type ->
  -- | Constructor name.
  Name ->
  -- | Total amount of members in the product.
  Int ->
  -- | Offset of the member we're focusing on.
  Int ->
  -- | 'HasField' instance declaration.
  Dec
productHasField :: TyLit -> Type -> Type -> Name -> Int -> Int -> Dec
productHasField TyLit
fieldLabel Type
ownerType Type
projectionType Name
constructorName Int
totalMemberTypes Int
offset =
  TyLit -> Type -> Type -> [Clause] -> Dec
hasField TyLit
fieldLabel Type
ownerType Type
projectionType [Clause]
getFieldFunClauses
  where
    getFieldFunClauses :: [Clause]
getFieldFunClauses =
      [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conP Name
constructorName [Pat]
pats] (Exp -> Body
NormalB Exp
bodyExp) []]
      where
        pats :: [Pat]
pats =
          forall a. Int -> a -> [a]
replicate Int
offset Pat
WildP
            forall a. Semigroup a => a -> a -> a
<> forall a. a -> a -> Bool -> a
bool forall (f :: * -> *) a. Alternative f => f a
empty [Name -> Pat
VarP Name
aName] (Int
totalMemberTypes forall a. Ord a => a -> a -> Bool
> Int
0)
            forall a. Semigroup a => a -> a -> a
<> forall a. Int -> a -> [a]
replicate (Int
totalMemberTypes forall a. Num a => a -> a -> a
- Int
offset forall a. Num a => a -> a -> a
- Int
1) Pat
WildP
        bodyExp :: Exp
bodyExp =
          Name -> Exp
VarE Name
aName