module Data.Yoko.TH
(
yokoTH, yokoTH_with,
YokoOptions(..), Mapping(..), yokoDefaults
) where
import Type.Spine (Spine, spineType_d_)
import Type.Serialize (serializeTypeAsHash_data)
import qualified Type.Ord as Ord
import Data.Yoko.TypeBasics (encode, Nat(..))
import Data.Yoko.W
import Data.Yoko.Representation
import Data.Yoko.View
import Data.Yoko.Invariant
import Language.Haskell.TH as TH hiding (Codomain)
import Language.Haskell.TH.Syntax as TH hiding (Codomain)
import qualified Language.Haskell.TH.SCCs as SCCs
import qualified Data.Yoko.TH.Internal as Int
import Data.Yoko.TH.Internal (tvbName, peelApp, peelAppAcc, expandSyn)
import qualified Control.Monad.Writer as Writer
import qualified Control.Monad.Trans as Trans
import Control.Monad (liftM, when, foldM)
import qualified Control.Arrow as Arrow
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.List as List
import Data.Maybe (catMaybes)
import Data.Kind (KindStar(..))
import Data.TypeFun
import Data.Record hiding (convert, Name)
import qualified Data.Record as R
import qualified Data.Record.Combinators as R
import Data.Record.Combinators ((!!!))
w0' :: (t p1 p0 -> s ) -> W' s t p1 p0; w0' = W'0
w1' :: (t p1 p0 -> s p0) -> W' s t p1 p0; w1' = W'1
w2' :: (t p1 p0 -> s p1 p0) -> W' s t p1 p0; w2' = W'2
convert r = R.convert $ R.withStyle r (Id KindStar)
data Target = Target deriving Show
data Renamer = Renamer deriving Show
data Mappings = Mappings deriving Show
data InvInsts = InvInsts deriving Show
data DCInsts = DCInsts deriving Show
data BindingGroup = BindingGroup deriving Show
data TargetData = TargetData deriving Show
data TargetType = TargetType deriving Show
data TargetCxt = TargetCxt deriving Show
data TargetTVBs = TargetTVBs deriving Show
data TargetPars = TargetPars deriving Show
data ConName = ConName deriving Show
data ConFields = ConFields deriving Show
instance R.Name Target where name = Target
instance R.Name Renamer where name = Renamer
instance R.Name Mappings where name = Mappings
instance R.Name InvInsts where name = InvInsts
instance R.Name DCInsts where name = DCInsts
instance R.Name BindingGroup where name = BindingGroup
instance R.Name TargetData where name = TargetData
instance R.Name TargetType where name = TargetType
instance R.Name TargetCxt where name = TargetCxt
instance R.Name TargetTVBs where name = TargetTVBs
instance R.Name TargetPars where name = TargetPars
instance R.Name ConName where name = ConName
instance R.Name ConFields where name = ConFields
data Mapping = Mapping
{containerTypeName :: Name, containerCtor :: Name, methodName :: Name}
data YokoOptions = YokoOptions
{
renamer :: (String -> String) -> (String -> String),
mappings :: [(Int, Mapping)] -> [(Int, Mapping)],
invInsts :: Bool -> Bool,
dcInsts :: [Name] -> [Name]}
yokoDefaults :: YokoOptions
yokoDefaults = YokoOptions id id id id
type M r = Writer.WriterT [Dec] Q
liftQ :: Q a -> M r a
liftQ = Trans.lift
runM :: M r () -> Q [Dec]
runM = fmap snd . Writer.runWriterT
generate :: [Dec] -> M r ()
generate = Writer.tell
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f = liftM concat . mapM f
yokoTH :: Name -> Q [Dec]
yokoTH n = yokoTH_with yokoDefaults n
yokoTH_with :: YokoOptions -> Name -> Q [Dec]
yokoTH_with options n = runM $ yoko0 $ X :&
Target := n :& Renamer := (mkName . renamer options (++ "_") . TH.nameBase)
:& Mappings := mappings options [(1, Mapping ''T1 'T1 'invmap),
(2, Mapping ''T2 'T2 'invmap2)]
:& InvInsts := invInsts options True
:& DCInsts := dcInsts options
yoko0 r@(convert -> X :& Target := n) = do
datatype <- liftQ $ Int.dataType n
scc <- do
scc <- liftQ $ SCCs.scc n
case scc of
Left n -> return $ Left n
Right ns -> fmap (Right . fst) $ foldM snoc (Map.empty, 0) $ Set.toAscList ns
where snoc (m, acc) n = liftQ (reify n) >>= return . \case
TyConI TySynD{} -> (Map.insert n Nothing m, acc)
_ -> (Map.insert n (Just acc) m, acc + 1)
yoko1 $ r :& TargetData := datatype :& BindingGroup := scc
conName :: Con -> Name
conName (NormalC n _) = n
conName (RecC n _) = n
conName (InfixC _ n _) = n
conName (ForallC _ _ c) = conName c
renameCon :: (Name -> Name) -> Con -> Con
renameCon f (NormalC n fields) = NormalC (f n) fields
renameCon f (RecC n fields) = RecC (f n) fields
renameCon f (InfixC fieldL n fieldR) = InfixC fieldL (f n) fieldR
renameCon f (ForallC tvbs cxt c) = ForallC tvbs cxt $ renameCon f c
tvbKind :: TyVarBndr -> Kind
tvbKind (PlainTV _) = StarT
tvbKind (KindedTV _ k) = k
tvbType :: TyVarBndr -> Type
tvbType = VarT . tvbName
compose :: Exp -> Exp -> Exp
compose l r = VarE '(.) `AppE` l `AppE` r
postConE :: Name -> Exp -> Exp
postConE n inj = compose (ConE n) inj
applyConT2TVBs :: Name -> [TyVarBndr] -> Type
applyConT2TVBs n tvbs = foldl ((. tvbType) . AppT) (ConT n) tvbs
conFields :: Con -> Q [StrictType]
conFields (NormalC _ fds) = return fds
conFields (RecC _ fds) = return $ map (\(_, x, y) -> (x, y)) fds
conFields (InfixC fdl _ fdr) = return [fdl, fdr]
conFields ForallC{} = Int.thFail "no support for existential types."
pat_exp :: Name -> Name -> Int -> (Pat, Exp)
pat_exp np ne k = (ConP np $ map VarP ns,
foldl ((. VarE) . AppE) (ConE ne) ns) where
ns = [ mkName $ "x" ++ show i | i <- [0..k 1] ]
simpleVal n exp = ValD (VarP n) (NormalB exp) []
halves :: [a] -> b -> (b -> b -> b) -> (a -> b) -> b
halves as nil appnd single = w (length as) as where
w _ [] = nil
w _ [a] = single a
w k as = w lk l `appnd` w rk r
where lk = k `div` 2 ; rk = k lk
(l, r) = List.splitAt lk as
toNat 0 = PromotedT 'Z
toNat n = PromotedT 'S `AppT` toNat (n 1)
data FieldRO = FieldRO {repF :: Exp, objF :: Exp}
namesIn :: Type -> Set Name
namesIn (ForallT tvbs _ ty) = namesIn ty `Set.difference` Set.fromList (map tvbName tvbs)
namesIn (AppT ty1 ty2) = namesIn ty1 `Set.union` namesIn ty2
namesIn (SigT ty _) = namesIn ty
namesIn (VarT n) = Set.singleton n
namesIn (ConT n) = Set.singleton n
namesIn _ = Set.empty
fieldRO :: [(Int, Mapping)] -> Either Name (Map Name (Maybe Int)) ->
[Name] ->
Type -> Q (Type, FieldRO)
fieldRO maps bg parNs = w' where
w' = uncurry w . peelApp
isRec = case bg of
Left _ -> const False
Right bg -> \n -> Map.member n bg
isPar n = n `elem` parNs
isImportant n = isRec n || isPar n
(nRecTy, nRecCtor) = case length parNs of
0 -> (''T0, 'T0)
1 -> (''T1, 'T1)
2 -> (''T2, 'T2)
w ty tys = case ty of
PromotedT{} -> Int.thFail $ "no support for promoted types."
PromotedTupleT{} -> Int.thFail $ "no support for promoted types."
PromotedNilT{} -> Int.thFail $ "no support for promoted types."
PromotedConsT{} -> Int.thFail $ "no support for promoted types."
StarT{} -> Int.thFail $ "no support for kinds."
ConstraintT{} -> Int.thFail $ "no support for constraint kinds."
LitT{} -> Int.thFail $ "no support for type literals."
AppT{} -> Int.thFail $ "impossible: AppT is guarded by peelApp."
ForallT{} -> Int.thFail $ "no support for ForallT."
UnboxedTupleT{} -> Int.thFail $ "no support for unboxed tuples."
SigT ty _ -> uncurry w $ peelAppAcc tys ty
VarT n | Just k <- List.findIndex (== n) $ reverse parNs ->
if null tys then return $
let (tyn, ctor, dtor) = case k of
0 -> (''Par0, 'Par0, 'unPar0)
1 -> (''Par1, 'Par1, 'unPar1)
in (ConT tyn, FieldRO (ConE ctor) (VarE dtor))
else Int.thFail $ "no support for poly- or higher-kinded parameters."
ConT n | Just lbl <- case bg of Left _ -> Nothing; Right bg -> Map.lookup n bg -> case lbl of
Nothing -> expandSyn ty tys >>= \case
Just (ty, tys) -> w ty tys
Nothing -> Int.thFail "impossible: expandSyn is guarded by yoko0."
Just lbl -> appliedRec lbl container tys'
where (foldl AppT ty -> container, tys') =
List.splitAt (length tys length parNs) tys
_ -> appliedDep container importants
where (foldl AppT ty -> container, importants) =
List.break (any isImportant . Set.toList . namesIn) tys
appliedRec lbl container tys = case null tys of
True -> return (ConT ''T0 `AppT` (PromotedT 'Rec `AppT` toNat lbl) `AppT` container, FieldRO (ConE 'T0) (VarE 'unT0))
False -> case lookup (length tys) maps of
Nothing -> Int.thFail $ "no case in the given YokoOptions for type constructors with " ++ show (length tys) ++ " arguments."
Just (Mapping {methodName = mn}) -> appliedType (ConT nRecTy `AppT` (PromotedT 'Rec `AppT` toNat lbl), nRecCtor, mn) container tys
appliedDep container tys = case null tys of
True -> return (ConT ''T0 `AppT` PromotedT 'Dep `AppT` container, FieldRO (ConE 'T0) (VarE 'unT0))
False -> case lookup (length tys) maps of
Nothing -> Int.thFail $ "no case in the given YokoOptions for type constructors with " ++ show (length tys) ++ " arguments."
Just (Mapping {containerTypeName = tyn, containerCtor = ctor, methodName = mn}) ->
appliedType (ConT tyn `AppT` PromotedT 'Dep, ctor, mn) container tys
appliedType (rTy, nCtor, nMap) ty tys = do
tys <- mapM w' tys
let snoc (tyL, fROL) (tyR, fROR) = (tyL `AppT` tyR, fROL `appRO` fROR)
appRO l r = FieldRO {repF = repF l `AppE` repF r `AppE` objF r,
objF = objF l `AppE` objF r `AppE` repF r}
post fRO = FieldRO {repF = ConE nCtor `compose` repF fRO,
objF = objF fRO `compose` dtor}
where dtor = let x = mkName "x" in LamE [ConP nCtor [VarP x]] (VarE x)
return $ Arrow.second post $ foldl snoc
(rTy `AppT` ty,
FieldRO {repF = VarE nMap, objF = VarE nMap}) tys
data ConRO = ConRO {repP :: [Pat], repE :: Exp, objP :: Pat, objE :: [Exp]}
yoko1 r@(convert -> X :&
Target := tyn :&
Renamer := rn :&
Mappings := maps :&
TargetData := Int.DataType tvbs cons :&
DCInsts := dcInsts
) = do
let activated = dcInsts $ either ((:[]) . conName) (map conName) cons
loc <- liftQ TH.location
let mkG n = Name (mkOccName $ nameBase n) $
NameG TcClsName (mkPkgName $ loc_package loc)
(mkModName $ loc_module loc)
nAndFieldss <- flip mapM (either (:[]) id cons) $ \con -> do
let n = conName con
n' = rn n
generate [Int.dataType2Dec n' $ Int.DataType tvbs $ Right [renameCon rn con]]
(>>= generate) $ liftQ $ serializeTypeAsHash_data (mkG n')
fmap ((,) n) $ liftQ $ conFields con
let tvbSplits = [ List.splitAt k tvbs
| k <- [length (drop 2 tvbs)..length tvbs] ]
(>>= generate) $ liftQ $ spineType_d_ tyn $ map tvbKind tvbs
(>>= generate) $ liftQ $ serializeTypeAsHash_data tyn
flip mapM_ tvbSplits $ \(tvbs, pars) ->
(flip mapM (either (:[]) id cons) $ \con -> do
let n = conName con
n' = rn n
((>>= generate) $ liftQ $ spineType_d_ (mkG n') $ map tvbKind tvbs)) >>
case filter ((/= StarT) . tvbKind) pars of
offenders@(_:_) -> liftQ $ Int.thWarn $ "not representing " ++ nameBase tyn ++ " with " ++ msg (length pars) ++ " because [" ++ List.intercalate "," (map (nameBase . tvbName) offenders) ++ "] involves poly- or higher-kinds."
where msg 1 = "1 parameter"
msg n = show n ++ " parameters"
[] -> do
cxt <- liftQ $ flip mapM tvbs $ \tvb ->
EqualP (PromotedT 'EQ) `fmap` do
let tv = [t| Spine $(return $ tvbType tvb) |]
[t| Ord.Compare $tv $tv |]
flip mapM_ nAndFieldss $ \(n, fields) -> do
yoko2 (n `elem` activated) $ r :&
TargetTVBs := tvbs :&
TargetPars := pars :&
TargetType := applyConT2TVBs tyn tvbs :&
TargetCxt := cxt :&
ConName := n :&
ConFields := fields
yoko3 $ r :&
TargetTVBs := tvbs :&
TargetPars := pars :&
TargetType := applyConT2TVBs tyn tvbs :&
TargetCxt := cxt
yoko2 activated (convert -> X :&
Renamer := rn :&
Mappings := maps :&
BindingGroup := bg :&
TargetType := ty :&
TargetPars := pars :&
TargetTVBs := tvbs :&
TargetCxt := cxt :&
ConName := n :&
ConFields := fields
) = do
let nW_rejoin = case length pars of
0 -> 'Sym0
1 -> 'Sym1
2 -> 'Sym2
let (nW_rep, nW_obj) = case length pars of
0 -> ('W0, 'w0')
1 -> ('W1, 'w1')
2 -> ('W2, 'w2')
let n' = rn n ; fd = applyConT2TVBs n' tvbs
generate
[TySynInstD ''Codomain [fd] ty,
TySynInstD ''Tag [fd] $ encode $ TH.nameBase n,
InstanceD cxt (ConT ''DC `AppT` fd)
[let (pat, exp) = pat_exp n' n $ length fields
in simpleVal 'rejoin $ ConE nW_rejoin `AppE` LamE [pat] exp]
]
when activated $ (>>= generate) $ do
(repTy, (conRO, _)) <- liftQ $ Arrow.second ($ 0) `fmap` halves fields
(return (ConT ''U, \s ->
(ConRO {repP = [], repE = ConE 'U,
objP = WildP, objE = []}, s)))
(\l r -> l >>= \(tyL, roL) -> r >>= \(tyR, roR) -> return $
(ConT ''(:*:) `AppT` tyL `AppT` tyR,
\s -> case roL s of
(roL, s) -> case roR s of
(roR, s) ->
(ConRO {repP = repP roL ++ repP roR,
repE = ConE '(:*:) `AppE` repE roL `AppE` repE roR,
objP = ConP '(:*:) [objP roL, objP roR],
objE = objE roL ++ objE roR}, s)))
(\(_, ty) ->
let post fRO s =
(ConRO {repP = [VarP n], repE = repF fRO `AppE` VarE n,
objP = VarP n, objE = [objF fRO `AppE` VarE n]},
s + 1)
where n = mkName $ "x" ++ show s
in Arrow.second post `fmap`
fieldRO maps bg (map tvbName pars) ty)
return
[ TySynInstD ''Rep [fd] (ConT ''C `AppT` fd `AppT` repTy),
InstanceD cxt (ConT ''Generic `AppT` fd)
[simpleVal 'rep $ (ConE nW_rep `AppE`) $ LamE [ConP n' (repP conRO)] $ ConE 'C `AppE` repE conRO,
simpleVal 'obj $ (VarE nW_obj `AppE`) $ LamE [ConP 'C [objP conRO]] $ foldl AppE (ConE n') $ objE conRO]]
yoko3 r@(convert -> X :&
Target := tyn :&
Renamer := rn :&
InvInsts := invInsts :&
TargetData := Int.DataType _ cons :&
BindingGroup := bg :&
TargetType := ty :&
TargetPars := pars :&
TargetTVBs := tvbs :&
TargetCxt := cxt
) = do
let (nW_disband, nNCtor) = case length pars of
0 -> ('W0, 'N0)
1 -> ('W1, 'N1)
2 -> ('W2, 'N2)
let invInst = case length pars of
0 -> Nothing
1 -> Just (''Invariant, 'invmap, 'gen_invmap)
2 -> Just (''Invariant2, 'invmap2, 'gen_invmap2)
(dcs, cases) <- liftQ $ halves (either (:[]) id cons)
(Int.thFail $ "`" ++ show (r !!! Target :: Name) ++ "' must have constructors.")
(\l r -> do
(l, ls) <- l; (r, rs) <- r
return $
(ConT ''(:+:) `AppT` l `AppT` r,
map (Arrow.first (postConE 'L)) ls ++
map (Arrow.first (postConE 'R)) rs))
(\con -> do
fields <- length `fmap` conFields con
return $ let n = conName con
in (ConT ''N `AppT` applyConT2TVBs (rn n) tvbs,
[(ConE nNCtor, (n, fields))]))
matches <- return $ flip map cases $ \(inj, (n, fds)) ->
let (pat, exp) = pat_exp n (rn n) fds
in Match pat (NormalB $ inj `AppE` exp) []
generate $ [TySynInstD ''DCs [ty] dcs,
InstanceD cxt (ConT ''DT `AppT` ty)
[simpleVal 'disband $ (ConE nW_disband `AppE`) $ LamCaseE matches]]
when invInsts $ flip (maybe (return ())) invInst $ \(cls, method, rhs) ->
generate [InstanceD cxt (ConT cls `AppT` ty) [ValD (VarP method) (NormalB (VarE rhs)) []]]
(>>= generate) $ do
rhs <- case fmap (Set.toAscList . Map.keysSet) bg of
Left _ -> return $ PromotedT 'NonRecDT
Right ns -> do
ns <- fmap catMaybes $ flip mapM ns $ \n -> liftQ (reify n) >>= \case
TyConI TySynD{} -> return Nothing
_ -> return $ Just n
let (l, _:r) = List.break (== tyn) ns
promo = foldr cons PromotedNilT where
cons n sofar = PromotedConsT `AppT` foldl AppT (ConT n) (map (VarT . tvbName) tvbs) `AppT` sofar
return $ PromotedT 'RecDT `AppT` promo l `AppT` promo r
return [TySynInstD ''DTs [ty] rhs]