module Data.DeepLenses where import Control.Lens (Lens', makeClassy) import Language.Haskell.TH import Language.Haskell.TH.Datatype ( ConstructorInfo(ConstructorInfo), ConstructorVariant(RecordConstructor), DatatypeInfo(datatypeCons, datatypeName), reifyDatatype, ) import Language.Haskell.TH.Syntax (ModName(..), Name(Name), NameFlavour(NameQ, NameS, NameG), OccName(..)) class DeepLenses s s' where deepLens :: Lens' s s' data Field = Field { Field -> Name fieldName :: Name, Field -> Type fieldType :: Type } deriving Int -> Field -> ShowS [Field] -> ShowS Field -> String (Int -> Field -> ShowS) -> (Field -> String) -> ([Field] -> ShowS) -> Show Field forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Field] -> ShowS $cshowList :: [Field] -> ShowS show :: Field -> String $cshow :: Field -> String showsPrec :: Int -> Field -> ShowS $cshowsPrec :: Int -> Field -> ShowS Show data DT = DT { DT -> Name dtName :: Name, DT -> [Field] dtFields :: [Field] } deriving Int -> DT -> ShowS [DT] -> ShowS DT -> String (Int -> DT -> ShowS) -> (DT -> String) -> ([DT] -> ShowS) -> Show DT forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [DT] -> ShowS $cshowList :: [DT] -> ShowS show :: DT -> String $cshow :: DT -> String showsPrec :: Int -> DT -> ShowS $cshowsPrec :: Int -> DT -> ShowS Show dataType :: Name -> Q DT dataType :: Name -> Q DT dataType Name name = do DatatypeInfo info <- Name -> Q DatatypeInfo reifyDatatype Name name return $ Name -> [Field] -> DT DT (DatatypeInfo -> Name datatypeName DatatypeInfo info) ([ConstructorInfo] -> [Field] forall {l}. (IsList l, Item l ~ ConstructorInfo) => l -> [Field] fields ([ConstructorInfo] -> [Field]) -> [ConstructorInfo] -> [Field] forall a b. (a -> b) -> a -> b $ DatatypeInfo -> [ConstructorInfo] datatypeCons DatatypeInfo info) where fields :: l -> [Field] fields [ConstructorInfo Name _ [TyVarBndrUnit] _ [Type] _ [Type] types [FieldStrictness] _ (RecordConstructor [Name] names)] = (Name -> Type -> Field) -> [Name] -> [Type] -> [Field] forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith Name -> Type -> Field Field [Name] names [Type] types fields l _ = [] mkHoist :: TypeQ -> TypeQ -> BodyQ -> DecQ mkHoist :: Q Type -> Q Type -> BodyQ -> Q Dec mkHoist Q Type _ Q Type _ BodyQ body = do (VarE Name name) <- [|deepLens|] Name -> [Q Clause] -> Q Dec forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec funD Name name [[Q Pat] -> BodyQ -> [Q Dec] -> Q Clause forall (m :: * -> *). Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause clause [] BodyQ body []] deepLensesInstance :: TypeQ -> TypeQ -> BodyQ -> DecQ deepLensesInstance :: Q Type -> Q Type -> BodyQ -> Q Dec deepLensesInstance Q Type top Q Type local' BodyQ body = Q [Type] -> Q Type -> [Q Dec] -> Q Dec forall (m :: * -> *). Quote m => m [Type] -> m Type -> [m Dec] -> m Dec instanceD ([Q Type] -> Q [Type] forall (m :: * -> *). Quote m => [m Type] -> m [Type] cxt []) (Q Type -> Q Type -> Q Type forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT (Q Type -> Q Type -> Q Type forall (m :: * -> *). Quote m => m Type -> m Type -> m Type appT [t|DeepLenses|] Q Type top) Q Type local') [Q Type -> Q Type -> BodyQ -> Q Dec mkHoist Q Type top Q Type local' BodyQ body] idLenses :: Name -> DecQ idLenses :: Name -> Q Dec idLenses Name name = Q Type -> Q Type -> BodyQ -> Q Dec deepLensesInstance Q Type nt Q Type nt BodyQ body where nt :: Q Type nt = Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name name body :: BodyQ body = Q Exp -> BodyQ forall (m :: * -> *). Quote m => m Exp -> m Body normalB [|id|] eligibleForDeepError :: Name -> Q Bool eligibleForDeepError :: Name -> Q Bool eligibleForDeepError Name tpe = do (ConT Name name) <- [t|DeepLenses|] Name -> [Type] -> Q Bool isInstance Name name [Name -> Type ConT Name tpe, Name -> Type ConT Name tpe] modName :: NameFlavour -> Maybe ModName modName :: NameFlavour -> Maybe ModName modName (NameQ ModName mod') = ModName -> Maybe ModName forall a. a -> Maybe a Just ModName mod' modName (NameG NameSpace _ PkgName _ ModName mod') = ModName -> Maybe ModName forall a. a -> Maybe a Just ModName mod' modName NameFlavour _ = Maybe ModName forall a. Maybe a Nothing sameModule :: NameFlavour -> NameFlavour -> Bool sameModule :: NameFlavour -> NameFlavour -> Bool sameModule NameFlavour f1 NameFlavour f2 = case (NameFlavour -> Maybe ModName modName NameFlavour f1, NameFlavour -> Maybe ModName modName NameFlavour f2) of (Just ModName a, Just ModName b) | ModName a ModName -> ModName -> Bool forall a. Eq a => a -> a -> Bool == ModName b -> Bool True (Maybe ModName, Maybe ModName) _ -> Bool False lensName :: Name -> Name -> ExpQ lensName :: Name -> Name -> Q Exp lensName (Name OccName _ NameFlavour topFlavour) (Name (OccName String n) NameFlavour lensFlavour) = Name -> Q Exp forall (m :: * -> *). Quote m => Name -> m Exp varE (OccName -> NameFlavour -> Name Name (String -> OccName OccName (ShowS lensNams' String n)) NameFlavour flavour) where lensNams' :: ShowS lensNams' (Char '_' : String t) = String t lensNams' [] = [] lensNams' String a = String a flavour :: NameFlavour flavour | NameFlavour -> NameFlavour -> Bool sameModule NameFlavour topFlavour NameFlavour lensFlavour = NameFlavour NameS | Bool otherwise = NameFlavour lensFlavour fieldLenses :: Name -> [Name] -> Field -> DecsQ fieldLenses :: Name -> [Name] -> Field -> DecsQ fieldLenses Name top [Name] intermediate (Field Name name (ConT Name tpe)) = do Dec current <- Q Type -> Q Type -> BodyQ -> Q Dec deepLensesInstance (Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name top) (Name -> Q Type forall (m :: * -> *). Quote m => Name -> m Type conT Name tpe) (Q Exp -> BodyQ forall (m :: * -> *). Quote m => m Exp -> m Body normalB Q Exp body) [Dec] sub <- Name -> [Name] -> Name -> DecsQ dataLensesIfEligible Name top (Name name Name -> [Name] -> [Name] forall a. a -> [a] -> [a] : [Name] intermediate) Name tpe return (Dec current Dec -> [Dec] -> [Dec] forall a. a -> [a] -> [a] : [Dec] sub) where compose :: Name -> Q Exp -> Q Exp compose = Q Exp -> Q Exp -> Q Exp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE (Q Exp -> Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp -> Q Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . Q Exp -> Q Exp -> Q Exp forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp appE [|(.)|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp forall b c a. (b -> c) -> (a -> b) -> a -> c . Name -> Name -> Q Exp lensName Name top body :: Q Exp body = (Name -> Q Exp -> Q Exp) -> Q Exp -> [Name] -> Q Exp forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr Name -> Q Exp -> Q Exp compose (Name -> Name -> Q Exp lensName Name top Name name) ([Name] -> [Name] forall a. [a] -> [a] reverse [Name] intermediate) fieldLenses Name _ [Name] _ Field _ = [Dec] -> DecsQ forall (m :: * -> *) a. Monad m => a -> m a return [] dataLenses :: Name -> [Name] -> Name -> DecsQ dataLenses :: Name -> [Name] -> Name -> DecsQ dataLenses Name top [Name] intermediate Name local' = do (DT Name _ [Field] fields) <- Name -> Q DT dataType Name local' [[Dec]] -> [Dec] forall (m :: * -> *) a. Monad m => m (m a) -> m a join ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Field -> DecsQ) -> [Field] -> Q [[Dec]] forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (Name -> [Name] -> Field -> DecsQ fieldLenses Name top [Name] intermediate) [Field] fields dataLensesIfEligible :: Name -> [Name] -> Name -> DecsQ dataLensesIfEligible :: Name -> [Name] -> Name -> DecsQ dataLensesIfEligible Name top [Name] intermediate Name local' = do Bool eligible <- Name -> Q Bool eligibleForDeepError Name local' if Bool eligible then Name -> [Name] -> Name -> DecsQ dataLenses Name top [Name] intermediate Name local' else [Dec] -> DecsQ forall (m :: * -> *) a. Monad m => a -> m a return [] lensesForMainData :: Name -> DecsQ lensesForMainData :: Name -> DecsQ lensesForMainData Name name = do Dec idL <- Name -> Q Dec idLenses Name name [Dec] fields <- Name -> [Name] -> Name -> DecsQ dataLenses Name name [] Name name return (Dec idL Dec -> [Dec] -> [Dec] forall a. a -> [a] -> [a] : [Dec] fields) deepLenses :: Name -> DecsQ deepLenses :: Name -> DecsQ deepLenses Name name = do [Dec] lenses <- Name -> DecsQ makeClassy Name name [Dec] err <- Name -> DecsQ lensesForMainData Name name return $ [Dec] lenses [Dec] -> [Dec] -> [Dec] forall a. [a] -> [a] -> [a] ++ [Dec] err