derive-topdown (empty) → 0.0.0.1
raw patch · 7 files changed
+411/−0 lines, 7 filesdep +basedep +derivedep +mtlsetup-changed
Dependencies added: base, derive, mtl, template-haskell, template-haskell-util
Files
- LICENSE +20/−0
- README.md +110/−0
- Setup.hs +2/−0
- derive-topdown.cabal +28/−0
- src/Data/Derive/TopDown/Derive.hs +130/−0
- src/Data/Derive/TopDown/Generic.hs +85/−0
- src/Data/Derive/TopDown/Utils.hs +36/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 songzh + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,110 @@+# derive-topdown+This library will help you generate Haskell empty Generic instance and deriving type instances from the top automatically to the bottom.++An example to generate Out class for Person, Name and Address.+Out class in genericpretty package has to provide a default implementation for the function it declears.++ {-# LANGUAGE TemplateHaskell, DeriveGeneric,DeriveDataTypeable,TypeSynonymInstances #-}+ {-# OPTIONS_GHC -ddump-splices #-}+ module Data.Derive.TopDown.Test where + import Data.Derive.TopDown.Generic+ import Data.Derive.TopDown.Derive (derivings)+ import Text.PrettyPrint.GenericPretty (Out)+ import Data.DeriveTH+ import GHC.Generics++ data A a b = A a (B b) deriving (Show, Generic)+ data B a = B a deriving (Show, Generic)++ data Person = Person Names Address+ | Student Names Address deriving Generic+ data Names = Names String deriving Generic+ data Address = Address Gate deriving Generic+ type Gate = (String,Int)++ derivings ''Eq makeEq ''Person+ instances ''Out ''A+ instances ''Out ''Person++================================++ Data\Derive\TopDown\Test.hs:1:1: Splicing declarations+ derivings ''Eq makeEq ''Person+ ======>+ Data\Derive\TopDown\Test.hs:23:1-30+ instance Eq Names where+ (==) (Names x1) (Names y1) = (x1 == y1)+ instance Eq Address where+ (==) (Address x1) (Address y1) = (x1 == y1)+ instance Eq Person where+ (==) (Person x1 x2) (Person y1 y2) = ((x1 == y1) && (x2 == y2))+ (==) (Student x1 x2) (Student y1 y2) = ((x1 == y1) && (x2 == y2))+ (==) _ _ = False+ Data\Derive\TopDown\Test.hs:1:1: Splicing declarations+ instances ''Out ''A+ ======>+ Data\Derive\TopDown\Test.hs:24:1-19+ instance Out a_a1IiG => Out (B a_a1IiG)+ instance (Out a_a1IiH, Out b_a1IiI) => Out (A a_a1IiH b_a1IiI)+ Data\Derive\TopDown\Test.hs:1:1: Splicing declarations+ instances ''Out ''Person+ ======>+ Data\Derive\TopDown\Test.hs:25:1-24+ instance Out Names+ instance Out Address+ instance Out Person++For generating 4 empty instances++ instance Out Person+ instnace Out Nmads+ instance Out Address+ instance Out Gate++you just write:++ instances ''Out ''Person++For derive Eq typeclass you just write++ derivings ''Eq makeEq ''Person++It will generate all instances that Person dependend on including Person.++Do not forget to use :set -ddump-splices, you will get++ instances ''Out ''Person+ ======>+ ~\Test.hs:13:1-18+ instance Out Names+ instance Out Gate+ instance Out Address+ instance Out Person+ Ok, modules loaded: CompositeDataInstancesGen, Main.++You can also use instnaceList to generate a list of class. Solution 1 is to use derive package++ derivings ''Eq makeEq ''A ++If you enable -ddump-splices, you will get:++ Data\Derive\TopDown\Test.hs:1:1: Splicing declarations+ derives ''Eq makeEq ''A+ ======>+ Data\Derive\TopDown\Test.hs:18:1-25+ instance Eq a_1627720873 => Eq (B a_1627720873) where+ (==) (B x1) (B y1) = (x1 == y1)+ instance (Eq a_1627720874, Eq b_1627720875) =>+ Eq (A a_1627720874 b_1627720875) where+ (==) (A x1 x2) (A y1 y2) = ((x1 == y1) && (x2 == y2))++We have to specify makeEq or other Derivation values here and I am not sure how to eleminate it. ++Solution is is to use standalone deriving. it will be supposrt in GHC 7.10 standalone deriving will be supported and you do not need to write. Currently unimplemented. ++ deriving (Data, Typeable, Generic, Ord,Eq,Show)++for each data type declarations ever again. In stead you will be able to write:++ derivings instance [''Eq, ''Typeable, ''Generic] A+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ derive-topdown.cabal view
@@ -0,0 +1,28 @@+-- Initial derive-topdown.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: derive-topdown +version: 0.0.0.1 +synopsis: This library will help you generate Haskell empty Generic instances and deriving type instances from the top automatically to the bottom for composited data types. +-- description: +homepage: https://github.com/HaskellZhangSong/derive-topdown +license: MIT +license-file: LICENSE +author: songzh +maintainer: Haskell.Zhang.Song@hotmail.com +-- copyright: +stability: experimental +category: Development +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: + Data.Derive.TopDown.Generic + Data.Derive.TopDown.Derive + -- other-modules: + -- other-extensions: + build-depends: base ==4.* , template-haskell >= 2.9 , template-haskell-util >= 0.1.1.0 , mtl >= 2.2.1, derive >= 2.5.18 + hs-source-dirs: src + default-language: Haskell2010
+ src/Data/Derive/TopDown/Derive.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell , QuasiQuotes, RankNTypes #-} + +module Data.Derive.TopDown.Derive ( +derivings +) where + +import Data.Derive.TopDown.Utils +import Language.Haskell.TH +import Language.Haskell.TH.Utils + +import Control.Monad (forM) +import Data.List (foldl') +import Control.Monad.State +import Control.Monad.Trans (lift) +import Debug.Trace +import qualified Language.Haskell.TH.Syntax as S +import Data.DeriveTH + +-- | deriving from top +{-| +> data A a b = A a (B b) deriving (Show) +> data B a = B a deriving (Show) +> +> derivings ''Eq makeEq ''A +If you enable -ddump-splices, you will get: +> +> Data\Derive\TopDown\Test.hs:1:1: Splicing declarations +> derives ''Eq makeEq ''A +> ======> +> Data\Derive\TopDown\Test.hs:18:1-25 +> instance Eq a_1627720873 => Eq (B a_1627720873) where +> (==) (B x1) (B y1) = (x1 == y1) +> instance (Eq a_1627720874, Eq b_1627720875) => +> Eq (A a_1627720874 b_1627720875) where +> (==) (A x1 x2) (A y1 y2) = ((x1 == y1) && (x2 == y2)) + +This will make sense if you have a deep composited data types, nomally an AST of a language. +For now, you have to specify both of ''Eq and makeEq, I suppose ''Eq will be enough. +To look what typeclasses you can derive, see 'derive' library on hackage. +-} +derivings :: Name -> Derivation -> Name -> Q [Dec] +derivings className dv typeName = (fmap fst ((runStateT $ gen className typeName dv) [])) + +-- derivings :: Name -> Name -> Q [Dec] + +-- class name , type name +gen :: Name -> Name -> Derivation -> StateT [Type] Q [Dec] +gen cla tp dv = do + (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames + context <- lift $ applyContext cla typeNames + isMember <- if tvbs == [] + then lift $ isInstance cla [instanceType] + else lift $ isInstance cla [ForallT tvbs cxt instanceType] + table <- get + if isMember || elem instanceType table + then return [] + else do + let makeClassName = mkName $ "make" ++ nameBase cla + let tpname = nameBase tp + dec <- lift (derive dv tp) + modify (instanceType:) + let names = concatMap getCompositeType cons + xs <- mapM (\n -> gen cla n dv) names + return $ concat xs ++ dec + +---- Please ignore the following +---- I am trying to implement without specifying makeEq, or makeOrd ... +derivings' :: Name -> Name -> Q [Exp] +derivings' className typeName = (fmap fst ((runStateT $ gen' className typeName) [])) + +gen' :: Name -> Name -> StateT [Type] Q [Exp] +gen' cla tp = do + (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames + context <- lift $ applyContext cla typeNames + isMember <- if tvbs == [] + then lift $ isInstance cla [instanceType] + else lift $ isInstance cla [ForallT tvbs cxt instanceType] + table <- get + if isMember || elem instanceType table + then return [] + else do + let makeClassName = mkName $ "make" ++ nameBase cla + let tpname = nameBase tp + dec <- lift $ appExp [(varE (mkName "derive")), (varE makeClassName), (varE tp)] + -- ****** how to splice [Exp] to [Dec] ?! + lift [| derive $(varE makeClassName) tp |] + modify (instanceType:) + let names = concatMap getCompositeType cons + xs <- mapM (\n -> gen' cla n ) names + return $ concat xs ++ [dec] + +-- data D = D + +derivings'' :: Name -> Name -> Q Exp +derivings'' cla typ = do + let makeClassName = mkName $ "make" ++ nameBase cla + + a <- [| derive makeClassName (typ) |] + return a + + +instance S.Lift Name where + lift x = varE x + +{-- +isI = do + t <- [t| forall a. Eq a => [a] |] + t1 <- [t| Int |] + t2 <- [t| forall a. [a] |] + isInstance ''Eq [t] +-} +existentialTypeContainsClass :: Name -> Type -> Q Bool +existentialTypeContainsClass clss (ForallT _ cxt t) = return $ or $ map (boundByPred clss) cxt + +boundByPred :: Name -> Pred -> Bool +boundByPred _ (EqualP _ _) = False +boundByPred c (ClassP clss _) = c == clss + +t = [t| forall a b . (Eq a)=> (a,b) |] +t' = do + t1 <- t + return $ ForallT [PlainTV (mkName "a")] [ClassP ''Eq [VarT (mkName "a")]] t1 + +runTest = do + t1 <- t + existentialTypeContainsClass ''Eq t1
+ src/Data/Derive/TopDown/Generic.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell #-} +module Data.Derive.TopDown.Generic ((-->),instances, instanceList) where + +import Data.List (foldl') +import Control.Monad.State +import Control.Monad.Trans (lift) +import Language.Haskell.TH +import Data.Derive.TopDown.Utils +import Language.Haskell.TH.Utils +{-| +An example to generate Out class for Person, Name and Address. +Out class has to provide a default implementation for the function it declears. + +@ +data Person = Person Names Address + | Student Names Address + deriving (Show, Generic, Eq, Ord , Data,Typeable) +data Names = Names String + deriving (Show, Generic, Eq, Ord, Data, Typeable) +data Address = Address Gate + deriving (Show, Generic, Eq, Ord, Typeable, Data) + +type Gate = PF + +data PF = PF String deriving (Data, Typeable, Generic, Ord,Eq,Show) +@ +For generating 4 empty instances +> instance Out Person +> instnace Out Nmads +> instance Out Address +> instance Out Gate + +you just write: +@ +instances ''Out ''Person +@ +It will generate all instances that form Person and including Person. + +If you use :set -ddump-splices, you will get +> instances ''Out ''Person +> ======> +> ~\Test.hs:13:1-18 +> instance Out Names +> instance Out Gate +> instance Out Address +> instance Out Person +> Ok, modules loaded: CompositeDataInstancesGen, Main. +You can also use instnaceList to generate a list of class. +-} + +-- | synatx sugar +instances = deriveInstances +(-->) = deriveInstances + +-- | Generate instances for a list of classes with default implementation +instanceList :: Name -> [Name] -> Q [Dec] +instanceList cla ls = fmap concat $ mapM (instances cla) ls + +-- | Generate a single instance for a typeclass +deriveInstances :: Name -> Name -> Q [Dec] +deriveInstances className typeName = (fmap fst ((runStateT $ gen className typeName) [])) + +-- gen class name, type name +gen :: Name -> Name -> StateT [Type] Q [Dec] +gen cla tp = do + (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames + context <- lift $ applyContext cla typeNames + let declTypes = conT cla `appT` (return instanceType) + isMember <- if tvbs == [] + then lift $ isInstance cla [instanceType] + ---- Actually the following line will not word + else lift $ isInstance cla [ForallT tvbs cxt instanceType] + table <- get + if isMember || elem instanceType table + then return [] + else do + dec <- lift $ fmap (:[]) $ instanceD (return context) declTypes [] + modify (instanceType:) + let names = concatMap getCompositeType cons + xs <- mapM (\n -> gen cla n) names + return $ concat xs ++ dec + +
+ src/Data/Derive/TopDown/Utils.hs view
@@ -0,0 +1,36 @@+ +module Data.Derive.TopDown.Utils where +import Language.Haskell.TH +import Control.Monad (forM) +import Language.Haskell.TH.Utils + +getCxtTyVarCons :: Name -> Q (Cxt, [TyVarBndr], [Con]) +getCxtTyVarCons name = do + info <- reify name + case info of + TyConI dec -> + case dec of + DataD cxt _ tvbs cons _ -> return (cxt,tvbs,cons) + NewtypeD cxt _ tvbs con _ -> return (cxt,tvbs,[con]) + TySynD name vars type' -> do + let names = getTypeNames type' + res <- forM names getCxtTyVarCons -- a :: [(Cxt, [TyVarBndr], [Con])] + let (t1,t2,t3) = unzip3 res + return (concat t1, concat t2 , concat t3) + -- You mat need TypeSynonymInstances to derive for type synonym + _ -> error "must be data, newtype definition or type synonym!" + _ -> error "bad type name, quoted name is not a type!" + + + +getCxtTyVarCons' :: Type -> Q (Cxt, [TyVarBndr], [Con]) +getCxtTyVarCons'(ConT t) = undefined --return ([],[],[NormalC]) + +{-| +applyContext ''Eq [''a, ''b] will give (Eq a, Eq b) class constraint +-} + +applyContext :: Name -> [Name] -> Q [Pred] +applyContext con typeNames = return (map apply typeNames) + where apply t = ClassP con [VarT t] +