module Data.Constructor.Extract.TH (
    extractConstructor,
    extractConstructorsOf,

    -- * Internal
    dataConstructorName,
    dataDeclarationName,
) where

import Data.Constructor.Extract.Class
import Data.Constructor.Extract.Internal
import Data.Constructor.Extract.Options
import Language.Haskell.TH

-- | Using a constructor's 'Name', generates a new data type with only this constructor.
extractConstructor :: Name -> ExtractOptions -> DecsQ
extractConstructor :: Name -> ExtractOptions -> DecsQ
extractConstructor Name
name ExtractOptions
opts = do
    dataAndCon <- Name -> Q DataAndCon
dataAndConFromName Name
name
    return
        [ generateDataDeclaration dataAndCon opts
        , generateExtractedConInstance dataAndCon opts
        ]

-- | Calls 'extractConstructor' for each constructor of the data type whone 'Name' is passed as parameter.
extractConstructorsOf :: Name -> ExtractOptions -> DecsQ
extractConstructorsOf :: Name -> ExtractOptions -> DecsQ
extractConstructorsOf Name
rawDataName ExtractOptions
opts =
    Name -> Q [Name]
conNamesFromTypeName Name
rawDataName
        Q [Name] -> ([Name] -> DecsQ) -> DecsQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> ([Name] -> Q [[Dec]]) -> [Name] -> DecsQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> DecsQ) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> ExtractOptions -> DecsQ
`extractConstructor` ExtractOptions
opts))

generateDataDeclaration :: DataAndCon -> ExtractOptions -> Dec
generateDataDeclaration :: DataAndCon -> ExtractOptions -> Dec
generateDataDeclaration d :: DataAndCon
d@MkDataAndCon{[Name]
[BangType]
Name
dataName :: Name
dataTypeArgNames :: [Name]
conName :: Name
conArgs :: [BangType]
conArgs :: DataAndCon -> [BangType]
conName :: DataAndCon -> Name
dataTypeArgNames :: DataAndCon -> [Name]
dataName :: DataAndCon -> Name
..} opts :: ExtractOptions
opts@MkExtractOptions{[Name]
String -> String
newDataName :: String -> String
newConName :: String -> String
deriveClasses :: [Name]
deriveClasses :: ExtractOptions -> [Name]
newConName :: ExtractOptions -> String -> String
newDataName :: ExtractOptions -> String -> String
..} =
    Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
dataDecName [TyVarBndr BndrVis]
typeBnd Maybe Kind
forall a. Maybe a
Nothing [Con
con] [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing (Name -> Kind
ConT (Name -> Kind) -> [Name] -> Cxt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
deriveClasses)]
  where
    con :: Con
con = Name -> [BangType] -> Con
NormalC (DataAndCon -> ExtractOptions -> Name
dataConstructorName DataAndCon
d ExtractOptions
opts) [BangType]
conArgs
    dataDecName :: Name
dataDecName = DataAndCon -> ExtractOptions -> Name
dataDeclarationName DataAndCon
d ExtractOptions
opts
    typeBnd :: [TyVarBndr BndrVis]
typeBnd = (Name -> BndrVis -> TyVarBndr BndrVis
forall flag. Name -> flag -> TyVarBndr flag
`PlainTV` BndrVis
BndrReq) (Name -> TyVarBndr BndrVis) -> [Name] -> [TyVarBndr BndrVis]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataAndCon -> [Name]
conTypeArgNames DataAndCon
d

dataDeclarationName :: DataAndCon -> ExtractOptions -> Name
dataDeclarationName :: DataAndCon -> ExtractOptions -> Name
dataDeclarationName MkDataAndCon{[Name]
[BangType]
Name
conArgs :: DataAndCon -> [BangType]
conName :: DataAndCon -> Name
dataTypeArgNames :: DataAndCon -> [Name]
dataName :: DataAndCon -> Name
dataName :: Name
dataTypeArgNames :: [Name]
conName :: Name
conArgs :: [BangType]
..} MkExtractOptions{[Name]
String -> String
deriveClasses :: ExtractOptions -> [Name]
newConName :: ExtractOptions -> String -> String
newDataName :: ExtractOptions -> String -> String
newDataName :: String -> String
newConName :: String -> String
deriveClasses :: [Name]
..} = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
newDataName (Name -> String
nameBase Name
conName)

dataConstructorName :: DataAndCon -> ExtractOptions -> Name
dataConstructorName :: DataAndCon -> ExtractOptions -> Name
dataConstructorName MkDataAndCon{[Name]
[BangType]
Name
conArgs :: DataAndCon -> [BangType]
conName :: DataAndCon -> Name
dataTypeArgNames :: DataAndCon -> [Name]
dataName :: DataAndCon -> Name
dataName :: Name
dataTypeArgNames :: [Name]
conName :: Name
conArgs :: [BangType]
..} MkExtractOptions{[Name]
String -> String
deriveClasses :: ExtractOptions -> [Name]
newConName :: ExtractOptions -> String -> String
newDataName :: ExtractOptions -> String -> String
newDataName :: String -> String
newConName :: String -> String
deriveClasses :: [Name]
..} = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
newConName (Name -> String
nameBase Name
conName)

generateExtractedConInstance :: DataAndCon -> ExtractOptions -> Dec
generateExtractedConInstance :: DataAndCon -> ExtractOptions -> Dec
generateExtractedConInstance d :: DataAndCon
d@MkDataAndCon{[Name]
[BangType]
Name
conArgs :: DataAndCon -> [BangType]
conName :: DataAndCon -> Name
dataTypeArgNames :: DataAndCon -> [Name]
dataName :: DataAndCon -> Name
dataName :: Name
dataTypeArgNames :: [Name]
conName :: Name
conArgs :: [BangType]
..} ExtractOptions
opts =
    Maybe Overlap -> Cxt -> Kind -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Kind
instanceType [Dec
fromDec, Dec
toDec]
  where
    instanceType :: Kind
instanceType = Name -> Kind
ConT ''ExtractedConstructor Kind -> Kind -> Kind
`AppT` Kind
instanceFromTypeArg Kind -> Kind -> Kind
`AppT` Kind
instanceToTypeArg
    instanceFromTypeArg :: Kind
instanceFromTypeArg = Kind -> [Name] -> Kind
applyTypeVar (Name -> Kind
ConT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ DataAndCon -> ExtractOptions -> Name
dataDeclarationName DataAndCon
d ExtractOptions
opts) (DataAndCon -> [Name]
conTypeArgNames DataAndCon
d)
    instanceToTypeArg :: Kind
instanceToTypeArg = Kind -> [Name] -> Kind
applyTypeVar (Name -> Kind
ConT Name
dataName) [Name]
dataTypeArgNames
    applyTypeVar :: Kind -> [Name] -> Kind
applyTypeVar = (Kind -> Name -> Kind) -> Kind -> [Name] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Kind
rest Name
tyArg -> Kind
rest Kind -> Kind -> Kind
`AppT` Name -> Kind
VarT Name
tyArg)
    --
    genConstructorName :: Name
genConstructorName = DataAndCon -> ExtractOptions -> Name
dataConstructorName DataAndCon
d ExtractOptions
opts
    fieldNames :: [Name]
fieldNames = (Int -> BangType -> Name) -> [Int] -> [BangType] -> [Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i BangType
_ -> String -> Name
mkName (String -> Name) -> (String -> String) -> String -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"f" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i) [(Int
0 :: Int) ..] [BangType]
conArgs
    applyArgs :: Exp -> [Name] -> Exp
applyArgs = (Exp -> Name -> Exp) -> Exp -> [Name] -> Exp
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Exp
rest Name
field -> Exp
rest Exp -> Exp -> Exp
`AppE` Name -> Exp
VarE Name
field)
    conArgPatterns :: [Pat]
conArgPatterns = Name -> Pat
VarP (Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fieldNames
    --
    fromDec :: Dec
fromDec =
        let
            body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> [Name] -> Exp
applyArgs (Name -> Exp
ConE Name
conName) [Name]
fieldNames
         in
            Name -> [Clause] -> Dec
FunD 'fromEC [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP (DataAndCon -> ExtractOptions -> Name
dataConstructorName DataAndCon
d ExtractOptions
opts) [] [Pat]
conArgPatterns] Body
body []]
    --
    toDec :: Dec
toDec =
        let
            body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Just Exp -> Exp -> Exp
`AppE` Exp -> [Name] -> Exp
applyArgs (Name -> Exp
ConE Name
genConstructorName) [Name]
fieldNames
         in
            Name -> [Clause] -> Dec
FunD
                'toEC
                [ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Cxt -> [Pat] -> Pat
ConP Name
conName [] [Pat]
conArgPatterns] Body
body []
                , [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Nothing) []
                ]