module Data.Profunctor.Product.TH where
import Data.Profunctor (dimap)
import Data.Profunctor.Product (ProductProfunctor, p1, p2, p3, p4, p5, p6, p7,
p8, p9, p10, p11, p12, p13, p14, p15, p16, p17,
p18, p19, p20, p21, p22, p23, p24)
import Data.Profunctor.Product.Default (Default, def)
import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),
mkName, TyVarBndr(PlainTV, KindedTV),
Con(RecC, NormalC),
Strict(NotStrict), Clause(Clause),
Type(VarT, ForallT, AppT, ArrowT, ConT),
Body(NormalB), Q, classP,
Exp(ConE, VarE, InfixE, AppE, TupE),
Pat(TupP, VarP, ConP), Name,
Info(TyConI), reify)
import Control.Monad ((<=<))
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (second)
makeAdaptorAndInstance :: String -> Name -> Q [Dec]
makeAdaptorAndInstance adaptorNameS = returnOrFail <=< r makeAandIE <=< reify
where r = (return .)
returnOrFail (Right decs) = decs
returnOrFail (Left errMsg) = fail errMsg
makeAandIE = makeAdaptorAndInstanceE adaptorNameS
type Error = String
makeAdaptorAndInstanceE :: String -> Info -> Either Error (Q [Dec])
makeAdaptorAndInstanceE adaptorNameS info = do
(tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info
let numTyVars = length tyVars
numConTys = length conTys
adaptorNameN = mkName adaptorNameS
adaptorSig' = adaptorSig tyName numTyVars adaptorNameN
adaptorDefinition' = adaptorDefinition numTyVars conName adaptorNameN
instanceDefinition' = instanceDefinition tyName numTyVars numConTys
adaptorNameN conName
return ((\a b -> [a, adaptorDefinition', b]) <$> adaptorSig' <*> instanceDefinition')
dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name])
dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) =
do
(conName, conTys) <- extractConstructorStuff constructors
let tyVars' = map varNameOfBinder tyVars
return (tyName, tyVars', conName, conTys)
dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars constructor _deriving)) =
do
(conName, conTys) <- extractConstructorStuff [constructor]
let tyVars' = map varNameOfBinder tyVars
return (tyName, tyVars', conName, conTys)
dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtpe declaration to me"
varNameOfType :: Type -> Either Error Name
varNameOfType (VarT n) = Right n
varNameOfType x = Left $ "Found a non-variable type" ++ show x
varNameOfBinder :: TyVarBndr -> Name
varNameOfBinder (PlainTV n) = n
varNameOfBinder (KindedTV n _) = n
conStuffOfConstructor :: Con -> Either Error (Name, [Name])
conStuffOfConstructor (NormalC conName st) = do
conTys <- mapM (varNameOfType . snd) st
return (conName, conTys)
conStuffOfConstructor (RecC conName vst) = do
conTys <- mapM (varNameOfType . thrd) vst
return (conName, conTys)
where thrd = \(_,_,x) -> x
conStuffOfConstructor _ = Left "I can't deal with your constructor type"
constructorOfConstructors :: [Con] -> Either Error Con
constructorOfConstructors [single] = return single
constructorOfConstructors [] = Left "I need at least one constructor"
constructorOfConstructors _many = Left msg
where msg = "I can't deal with more than one constructor"
extractConstructorStuff :: [Con] -> Either Error (Name, [Name])
extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors
data MakeRecordT = MakeRecordT { typeName :: String
, constructorName :: String
, fieldNames :: [String]
, deriving_ :: [String]
, adaptorName :: String }
makeRecordData :: MakeRecordT -> Q [Dec]
makeRecordData r = return [datatype'] where
MakeRecordT tyName conName tyVars derivings _ = r
tyName' = mkName tyName
datatype' = datatype tyName' tyVars conName derivings
makeRecord :: MakeRecordT -> Q [Dec]
makeRecord r = decs
where MakeRecordT tyName conName tyVars derivings _ = r
decs = (\a i -> [datatype', a, adaptorDefinition', i])
<$> adaptorSig'
<*> instanceDefinition'
tyName' = mkName tyName
conName' = mkName conName
adaptorName' = mkName (adaptorName r)
numTyVars = length tyVars
datatype' = datatype tyName' tyVars conName derivings
adaptorSig' = adaptorSig tyName' numTyVars adaptorName'
adaptorDefinition' = adaptorDefinition numTyVars conName' adaptorName'
instanceDefinition' = instanceDefinition tyName' numTyVars numTyVars
adaptorName' conName'
datatype :: Name -> [String] -> String -> [String] -> Dec
datatype tyName tyVars conName derivings = datatype'
where datatype' = DataD [] tyName tyVars' [con] derivings'
fields = map toField tyVars
tyVars' = map (PlainTV . mkName) tyVars
con = RecC (mkName conName) fields
toField s = (mkName s, NotStrict, VarT (mkName s))
derivings' = map mkName derivings
instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec
instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec
where instanceDec = fmap (\i -> InstanceD i instanceType [defDefinition])
instanceCxt
instanceCxt = mapM (uncurry classP) (pClass:defClasses)
pClass = (''ProductProfunctor, [return (varTS "p")])
defaultPredOfVar :: String -> (Name, [Type])
defaultPredOfVar fn = (''Default, [varTS "p",
mkTySuffix "0" fn,
mkTySuffix "1" fn])
defClasses = map (second (map return) . defaultPredOfVar)
(allTyVars numTyVars)
pArg :: String -> Type
pArg s = pArg' tyName' s numTyVars
instanceType = appTAll (ConT ''Default)
[varTS "p", pArg "0", pArg "1"]
defDefinition = FunD 'def [Clause [] defBody []]
defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN)
defsN = replicate numConVars (VarE 'def)
adaptorSig :: Name -> Int -> Name -> Q Dec
adaptorSig tyName' numTyVars n = fmap (SigD n) adaptorType
where adaptorType = fmap (\a -> ForallT scope a adaptorAfterCxt) adaptorCxt
adaptorAfterCxt = before `appArrow` after
adaptorCxt = fmap (:[]) (classP ''ProductProfunctor [return (VarT (mkName "p"))])
before = appTAll (ConT tyName') pArgs
pType = VarT (mkName "p")
pArgs = map pApp tyVars
pApp :: String -> Type
pApp v = appTAll pType [mkVarTsuffix "0" v, mkVarTsuffix "1" v]
tyVars = allTyVars numTyVars
pArg :: String -> Type
pArg s = pArg' tyName' s numTyVars
after = appTAll pType [pArg "0", pArg "1"]
scope = concat [ [PlainTV (mkName "p")]
, map (mkTyVarsuffix "0") tyVars
, map (mkTyVarsuffix "1") tyVars ]
tupleAdaptors :: Int -> Name
tupleAdaptors n = case n of 1 -> 'p1
2 -> 'p2
3 -> 'p3
4 -> 'p4
5 -> 'p5
6 -> 'p6
7 -> 'p7
8 -> 'p8
9 -> 'p9
10 -> 'p10
11 -> 'p11
12 -> 'p12
13 -> 'p13
14 -> 'p14
15 -> 'p15
16 -> 'p16
17 -> 'p17
18 -> 'p18
19 -> 'p19
20 -> 'p20
21 -> 'p21
22 -> 'p22
23 -> 'p23
24 -> 'p24
_ -> error errorMsg
where errorMsg = "Data.Profunctor.Product.TH: "
++ show n
++ " is too many type variables for me!"
adaptorDefinition :: Int -> Name -> Name -> Dec
adaptorDefinition numConVars conName = flip FunD [clause]
where clause = Clause [] body wheres
toTupleN = mkName "toTuple"
fromTupleN = mkName "fromTuple"
toTupleE = VarE toTupleN
fromTupleE = VarE fromTupleN
theDimap = appEAll (VarE 'dimap) [toTupleE, fromTupleE]
pN = VarE (tupleAdaptors numConVars)
body = NormalB (theDimap `o` pN `o` toTupleE)
wheres = [toTuple conName (toTupleN, numConVars),
fromTuple conName (fromTupleN, numConVars)]
xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec
xTuple patCon retCon (funN, numTyVars) = FunD funN [clause]
where clause = Clause [pat] body []
pat = patCon varPats
body = NormalB (retCon varExps)
varPats = map varPS (allTyVars numTyVars)
varExps = map varS (allTyVars numTyVars)
fromTuple :: Name -> (Name, Int) -> Dec
fromTuple conName = xTuple patCon retCon
where patCon = TupP
retCon = appEAll (ConE conName)
toTuple :: Name -> (Name, Int) -> Dec
toTuple conName = xTuple patCon retCon
where patCon = ConP conName
retCon = TupE
pArg' :: Name -> String -> Int -> Type
pArg' tn s = appTAll (ConT tn) . map (varTS . (++s)) . allTyVars
allTyVars :: Int -> [String]
allTyVars numTyVars = map varA tyNums
where varA i = "a" ++ show i ++ "_"
tyNums :: [Int]
tyNums = [1..numTyVars]
o :: Exp -> Exp -> Exp
o x y = InfixE (Just x) (varS ".") (Just y)
varS :: String -> Exp
varS = VarE . mkName
varPS :: String -> Pat
varPS = VarP . mkName
mkTyVarsuffix :: String -> String -> TyVarBndr
mkTyVarsuffix s = PlainTV . mkName . (++s)
mkTySuffix :: String -> String -> Type
mkTySuffix s = varTS . (++s)
mkVarTsuffix :: String -> String -> Type
mkVarTsuffix s = VarT . mkName . (++s)
varTS :: String -> Type
varTS = VarT . mkName
appTAll :: Type -> [Type] -> Type
appTAll = foldl AppT
appEAll :: Exp -> [Exp] -> Exp
appEAll = foldl AppE
appArrow :: Type -> Type -> Type
appArrow l r = appTAll ArrowT [l, r]