module Data.Registry.TH (
  TypeclassOptions
, makeTypeclass
, makeTypeclassWith
) where

import           Data.Text                  as T (drop, splitOn)
import           Language.Haskell.TH
import           Language.Haskell.TH.Syntax
import           Protolude                  hiding (Type)

{-
  This module generates a typeclass for a given "record of functions". For this component:

data Logger m = Logger {
  _info :: Text -> m ()
, _error :: Text -> m ()
}

-- `makeTypeClass ''Logger` generates

class WithLogger m where
  info :: Text -> m ()
  error :: Text -> m ()

-- This requires the import of `Data.Generics.Product.Typed` from `generic-lens`
instance HasType (Logger m) s => WithLogger (ReaderT s m) where
  info t = ReaderT (\l -> _info (getTyped l) t)
  error t = ReaderT (\l -> _error (getType l) t)

-}

-- | Create the haskell code presented in the module description
makeTypeclass :: Name -> DecsQ
makeTypeclass :: Name -> DecsQ
makeTypeclass = TypeclassOptions -> Name -> DecsQ
makeTypeclassWith ((Text -> Text) -> (Text -> Text) -> TypeclassOptions
TypeclassOptions (Text
"With" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Int -> Text -> Text
T.drop Int
1))

-- | These generation options can be used to tweak the generated names
data TypeclassOptions = TypeclassOptions {
  -- adjust the typeclass name based on the component constructor name
  TypeclassOptions -> Text -> Text
_typeclassName :: Text -> Text
  -- adjust the typeclass function names based on the component function names
, TypeclassOptions -> Text -> Text
_functionName  :: Text -> Text
}

-- | Make a typeclass using some specific generation options
makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ
makeTypeclassWith :: TypeclassOptions -> Name -> DecsQ
makeTypeclassWith (TypeclassOptions Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker) Name
componentType = do
  Info
info <- Name -> Q Info
reify Name
componentType
  case Info
info of
    TyConI (DataD Cxt
_ Name
name [TyVarBndr]
typeVars Maybe Kind
_ [RecC Name
_ [VarBangType]
types] [DerivClause]
_) -> do
      [Dec]
readertInstance <- (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr]
typeVars [VarBangType]
types
      [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr]
typeVars [VarBangType]
types
             [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
readertInstance

    TyConI (NewtypeD Cxt
_ Name
name [TyVarBndr]
typeVars Maybe Kind
_ (RecC Name
_ [VarBangType]
types) [DerivClause]
_) -> do
      [Dec]
readertInstance <- (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr]
typeVars [VarBangType]
types
      [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> DecsQ) -> [Dec] -> DecsQ
forall a b. (a -> b) -> a -> b
$ (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr]
typeVars [VarBangType]
types
             [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [Dec]
readertInstance
    Info
other -> do
      Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only generate a typeclass for a record of functions, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Info -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Info
other)
      [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []


createTypeclass :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
createTypeclass :: (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> [Dec]
createTypeclass Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr]
typeVars [VarBangType]
types =
  let typeclassName :: Name
typeclassName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
typeclassNameMaker (Name -> Name
dropQualified Name
name)
      functions :: [Dec]
functions = (VarBangType -> Dec) -> [VarBangType] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration Text -> Text
functionNameMaker) [VarBangType]
types
  in [Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [Dec] -> Dec
ClassD [] Name
typeclassName [TyVarBndr]
typeVars [] [Dec]
functions]

-- | Create an instance definition using a ReaderT instance
--     instance WithLogger (ReaderT (Logger m) m) where ...
createReadertInstance :: (Text -> Text) -> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance :: (Text -> Text)
-> (Text -> Text) -> Name -> [TyVarBndr] -> [VarBangType] -> DecsQ
createReadertInstance Text -> Text
typeclassNameMaker Text -> Text
functionNameMaker Name
name [TyVarBndr
tvar] [VarBangType]
types =
  let tvarName :: Name
tvarName = case TyVarBndr
tvar of PlainTV Name
v -> Name
v; KindedTV Name
v Kind
_ -> Name
v
      typeclassName :: Name
typeclassName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
typeclassNameMaker (Name -> Name
dropQualified Name
name)
      functions :: [Dec]
functions = (VarBangType -> Dec) -> [VarBangType] -> [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance Text -> Text
functionNameMaker (String -> Name
mkName String
"ReaderT")) [VarBangType]
types
      typeclassT :: Kind
typeclassT = Name -> Kind
ConT Name
typeclassName
      components :: Name
components = String -> Name
mkName String
"c"
      componentTypeT :: Kind
componentTypeT = Name -> Kind
ConT Name
name
      componentsTypeT :: Kind
componentsTypeT = Name -> Kind
VarT Name
components
      readerT :: Kind
readerT = Name -> Kind
ConT (String -> Name
mkName String
"ReaderT")
      hasTypeT :: Kind
hasTypeT = Name -> Kind
ConT (String -> Name
mkName String
"HasType")
      tvarT :: Kind
tvarT   = Name -> Kind
VarT Name
tvarName
  in [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing
            [Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
hasTypeT (Kind -> Kind -> Kind
AppT Kind
componentTypeT Kind
tvarT)) Kind
componentsTypeT]
            (Kind -> Kind -> Kind
AppT Kind
typeclassT (Kind -> Kind -> Kind
AppT (Kind -> Kind -> Kind
AppT Kind
readerT Kind
componentsTypeT) Kind
tvarT))
            [Dec]
functions]

createReadertInstance Text -> Text
_ Text -> Text
_ Name
_ [TyVarBndr]
tvars [VarBangType]
_ = do
  Bool -> String -> Q ()
forall (m :: * -> *). Quasi m => Bool -> String -> m ()
qReport Bool
True (String
"can only generate a instance for a component typeclass when it has only one type variable, got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [TyVarBndr] -> String
forall a b. (Show a, ConvertText String b) => a -> b
show [TyVarBndr]
tvars)
  [Dec] -> DecsQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Make the function declaration of the typeclass based on the function name in the "record of functions"
makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration :: (Text -> Text) -> VarBangType -> Dec
makeFunctionDeclaration Text -> Text
functionNameMaker (Name
name, Bang
_, Kind
type') =
  Name -> Kind -> Dec
SigD ((Text -> Text) -> Name -> Name
modifyName Text -> Text
functionNameMaker (Name -> Name
dropQualified Name
name)) Kind
type'

-- | This produces: info p1 p2 = ReaderT (\component -> _info component p1 p2)
makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance :: (Text -> Text) -> Name -> VarBangType -> Dec
makeFunctionInstance Text -> Text
functionNameMaker Name
runnerName (Name
name, Bang
_, Kind
functionType) =
  let functionName :: Name
functionName = (Text -> Text) -> Name -> Name
modifyName Text -> Text
functionNameMaker (Name -> Name
dropQualified Name
name)
      readerT :: Exp
readerT = Name -> Exp
ConE Name
runnerName
      component :: Name
component = String -> Name
mkName String
"component"
      numberOfParameters :: Int
numberOfParameters = Kind -> Int
countNumberOfParameters Kind
functionType
      parameterNames :: [Name]
parameterNames = (\Int
i -> String -> Name
mkName (String
"p" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a b. (Show a, ConvertText String b) => a -> b
show Int
i)) (Int -> Name) -> [Int] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1..Int
numberOfParameters]
      parameters :: [Pat]
parameters = Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
parameterNames
      firstApplication :: Exp
firstApplication = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
name) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"getTyped")) (Name -> Exp
VarE Name
component))
      body :: Exp
body = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Exp
r Name
p -> Exp -> Exp -> Exp
AppE Exp
r (Name -> Exp
VarE Name
p)) Exp
firstApplication [Name]
parameterNames
  in
    Name -> [Clause] -> Dec
FunD Name
functionName [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
parameters (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE Exp
readerT ([Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
component] Exp
body))) []]

-- | count the number of parameters for a function type
countNumberOfParameters :: Type -> Int
countNumberOfParameters :: Kind -> Int
countNumberOfParameters (ForallT [TyVarBndr]
_ Cxt
_ Kind
t)          = Kind -> Int
countNumberOfParameters Kind
t
countNumberOfParameters (AppT (AppT Kind
ArrowT Kind
_) Kind
t) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+  Kind -> Int
countNumberOfParameters Kind
t
countNumberOfParameters Kind
_                        = Int
0

-- | Modify a template haskell name
modifyName :: (Text -> Text) -> Name -> Name
modifyName :: (Text -> Text) -> Name -> Name
modifyName Text -> Text
f Name
n = String -> Name
mkName (Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> (Name -> Text) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f (Text -> Text) -> (Name -> Text) -> Name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (Name -> String) -> Name -> String
forall a b. (a -> b) -> a -> b
$ Name
n)

-- | Remove the module name from a qualified name
dropQualified :: Name -> Name
dropQualified :: Name -> Name
dropQualified Name
name =  Name -> (Text -> Name) -> Maybe Text -> Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Name
name (String -> Name
mkName (String -> Name) -> (Text -> String) -> Text -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertText a b => a -> b
toS) ([Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMay (Text -> Text -> [Text]
T.splitOn Text
"." (Name -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show Name
name)))