module Data.Thorn.Fold (
unfixdata, unfixdataEx
, autoin, autoout, autohylo, autofold, autounfold
, unfixdataMutual, unfixdataMutualEx
, autoinMutual, autooutMutual, autohyloMutual, autofoldMutual, autounfoldMutual
) where
import Data.Thorn.Type
import Data.Thorn.Functor
import Language.Haskell.TH
import Control.Applicative
unfixdata :: TypeQ -> DecsQ
unfixdata = unfixdataEx ("Uf","") ("Uf","") ("&","") ("&","")
unfixdataEx ::
(String,String)
-> (String,String)
-> (String,String)
-> (String,String)
-> TypeQ
-> DecsQ
unfixdataEx (pretype,suftype) (predata,sufdata) (pretypeinfix,suftypeinfix) (predatainfix,sufdatainfix) t = do
(n, DataTx nm _ cxs) <- applyFixed 0 =<< type2typex [] [] =<< t
let modifytx (DataTx nm' vmp cxs') = if nm == nm' then VarTx $ mkName ("self") else DataTx nm' (map (\(nm'',tx) -> (nm'',modifytx tx)) vmp) (map modifycx cxs')
modifytx tx@(SeenDataTx nm' _) = if nm == nm' then VarTx $ mkName ("self") else modifytx tx
modifytx (TupleTx txs) = TupleTx (map modifytx txs)
modifytx (ArrowTx txa txb) = ArrowTx (modifytx txa) (modifytx txb)
modifytx (ListTx tx) = ListTx (modifytx tx)
modifytx tx = tx
modifycx (nm',txs) = (nm',map modifytx txs)
go (nm',txs) = do
ts <- map ((,) NotStrict) <$> mapM (typex2type . modifytx) txs
return $ NormalC (datanm nm') ts
cns <- mapM go cxs
return [DataD [] (typenm nm) (map var [0..n1] ++ [self]) cns []]
where typenm nm
| elem (head s) ['A'..'Z'] = mkName $ pretype ++ s ++ suftype
| head s == '(' = mkName $ ":" ++ pretypeinfix ++ init (drop 2 s) ++ suftypeinfix
| otherwise = mkName $ ":" ++ pretypeinfix ++ tail s ++ suftypeinfix
where s = nameBase nm
datanm nm
| elem (head s) ['A'..'Z'] = mkName $ predata ++ s ++ sufdata
| head s == '(' = mkName $ ":" ++ predatainfix ++ init (drop 2 s) ++ sufdatainfix
| otherwise = mkName $ ":" ++ predatainfix ++ tail s ++ sufdatainfix
where s = nameBase nm
var i = PlainTV $ mkName ("t" ++ show i)
self = PlainTV $ mkName ("self")
autoin ::
TypeQ
-> TypeQ
-> ExpQ
autoin u t = do
(_,DataTx _ _ cxsu) <- applyFixed 0 =<< type2typex [] [] =<< u
(_,DataTx _ _ cxst) <- applyFixed 0 =<< type2typex [] [] =<< t
u1 <- unique
u2 <- unique
let go ((nmu,txsu),(nmt,_)) = Match (ConP nmu (map newVarP [u2..u2+length txsu1])) (NormalB (applistE (ConE nmt) (map newVarE [u2..u2+length txsu1]))) []
return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
autoout ::
TypeQ
-> TypeQ
-> ExpQ
autoout u t = do
(_,DataTx _ _ cxsu) <- applyFixed 0 =<< type2typex [] [] =<< u
(_,DataTx _ _ cxst) <- applyFixed 0 =<< type2typex [] [] =<< t
u1 <- unique
u2 <- unique
let go ((nmu,txsu),(nmt,_)) = Match (ConP nmt (map newVarP [u2..u2+length txsu1])) (NormalB (applistE (ConE nmu) (map newVarE [u2..u2+length txsu1]))) []
return $ LamE [newVarP u1] (CaseE (newVarE u1) (map go (zip cxsu cxst)))
autohylo ::
TypeQ
-> ExpQ
autohylo u = do
(n,DataTx nm _ cxs) <- applyFixed 0 =<< type2typex [] [] =<< u
f <- autofmap u
u <- unique
return $ LamE [newVarP u, newVarP (u+1)] (LetE [ValD (newVarP (u+3))
(NormalB (LamE [newVarP (u+2)] (AppE (newVarE (u+1)) (applistE f (replicate (n1) (mkNameE "Prelude.id") ++ [newVarE (u+3)] ++ [AppE (newVarE u) (newVarE (u+2))])))))
[]] (newVarE (u+3)))
autofold ::
TypeQ
-> TypeQ
-> ExpQ
autofold u t = do
o <- autoout u t
h <- autohylo u
return $ AppE h o
autounfold ::
TypeQ
-> TypeQ
-> ExpQ
autounfold u t = do
i <- autoin u t
h <- autohylo u
u1 <- unique
return $ LamE [newVarP u1] (AppE (AppE h (newVarE u1)) i)
unfixdataMutual :: [TypeQ] -> DecsQ
unfixdataMutual = unfixdataMutualEx ("Uf","") ("Uf","") ("&","") ("&","")
unfixdataMutualEx ::
(String,String)
-> (String,String)
-> (String,String)
-> (String,String)
-> [TypeQ]
-> DecsQ
unfixdataMutualEx = undefined
autoinMutual :: [TypeQ] -> DecsQ
autoinMutual ts = fail "oh"
autooutMutual :: [TypeQ] -> DecsQ
autooutMutual ts = fail "oh"
autohyloMutual :: [TypeQ] -> DecsQ
autohyloMutual ts = fail "oh"
autofoldMutual :: [TypeQ] -> ExpQ
autofoldMutual ts = do fail "oh"
autounfoldMutual :: [TypeQ] -> ExpQ
autounfoldMutual ts = do fail "oh"