classyplate 0.3.0.0 → 0.3.0.1

raw patch · 9 files changed

+393/−28 lines, 9 filesdep +classyplatedep +criteriondep +paralleldep −type-listdep ~basedep ~template-haskell

Dependencies added: classyplate, criterion, parallel, uniplate

Dependencies removed: type-list

Dependency ranges changed: base, template-haskell

Files

classyplate.cabal +20/−6
examples/AutoUni.hs +10/−0
examples/DirectUni.hs +127/−0
examples/Example.hs +120/−0
examples/Generate.hs +40/−0
examples/Main.hs +60/−0
src/Data/Generics/ClassyPlate/Common.hs +0/−11
src/Data/Generics/ClassyPlate/Core.hs +0/−10
src/Data/Generics/ClassyPlate/TypePrune.hs +16/−1

classyplate.cabal view

@@ -1,17 +1,23 @@ name:                classyplate
-version:             0.3.0.0
+version:             0.3.0.1
 synopsis:            Fuseable type-class based generics
--- description:         
+description:         Defining generics that can be used efficiently on heterogenous data structures 
+  like syntax trees. Can access elements of multiple types at a single traversal. Non-invasive method
+  don't have to change the representation to use. All boilerplate code can be generated by the supplied
+  Template Haskell functions.
 license:             BSD3
 license-file:        LICENSE
 author:              Nemeth Boldizsar
 maintainer:          nboldi@elte.hu
--- copyright:           
 category:            Data
 build-type:          Simple
 extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
+source-repository head
+  type:     git
+  location: https://github.com/nboldi/classyplate.git
+
 library
   exposed-modules:     Data.Generics.ClassyPlate
                      , Data.Generics.ClassyPlate.Generate
@@ -19,8 +25,16 @@                      , Data.Generics.ClassyPlate.TypePrune
                      , Data.Generics.ClassyPlate.TH
                      , Data.Generics.ClassyPlate.Core
-  build-depends:       base             >=4.9   && <4.10
-                     , type-list        >=0.5   && <0.6
-                     , template-haskell >=2.11  && <2.12
+  build-depends:       base             >=4.10   && <4.11
+                     , template-haskell >=2.12  && <2.13
   hs-source-dirs:      src
   default-language:    Haskell2010
+
+benchmark measure
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   examples
+  main-is:          Main.hs
+  other-modules:    AutoUni, DirectUni, Example, Generate
+  build-depends:    base, criterion, classyplate, parallel, uniplate
+  ghc-options:      -O2
+  default-language: Haskell2010

+ examples/AutoUni.hs view

@@ -0,0 +1,10 @@+module AutoUni where
+
+import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.Data
+
+import Generate
+
+autoUni1 d = transformBi testFun1 (generateA d)
+autoUni2 d = transformBi testFun2 (generateA d)
+

+ examples/DirectUni.hs view

@@ -0,0 +1,127 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
+module DirectUni where
+
+import Data.Generics.Uniplate.Operations
+import Data.Generics.Uniplate.Direct
+
+import Example
+import Generate
+
+-- data A = ABC B C deriving (Show, Generic, Data)
+-- data B = B | BA A deriving (Show, Generic, Data)
+-- data C = CB B | CD D deriving (Show, Generic, Data)
+-- data D = DDE D E | D deriving (Show, Generic, Data)
+-- data E = E deriving (Show, Generic, Data)
+
+instance Uniplate A where
+    uniplate (ABC b c) = plate ABC |+ b |+ c
+
+instance Biplate A B where
+    biplate (ABC b c) = plate ABC |+ b |+ c
+
+instance Biplate A C where
+    biplate (ABC b c) = plate ABC |+ b |+ c
+
+instance Biplate A D where
+    biplate (ABC b c) = plate ABC |+ b |+ c
+
+instance Biplate A E where
+    biplate (ABC b c) = plate ABC |+ b |+ c
+
+
+instance Uniplate B where
+    uniplate (BA a) = plate BA |+ a
+    uniplate B = plate B
+
+instance Biplate B A where
+    biplate (BA a) = plate BA |* a
+    biplate B = plate B
+
+instance Biplate B C where
+    biplate (BA a) = plate BA |+ a
+    biplate B = plate B
+
+instance Biplate B D where
+    biplate (BA a) = plate BA |+ a
+    biplate B = plate B
+
+instance Biplate B E where
+    biplate (BA a) = plate BA |+ a
+    biplate B = plate B
+
+
+instance Uniplate C where
+    uniplate (CB b) = plate CB |+ b
+    uniplate (CD d) = plate CD |- d
+
+instance Biplate C A where
+    biplate (CB b) = plate CB |+ b
+    biplate (CD d) = plate CD |- d
+
+instance Biplate C B where
+    biplate (CB b) = plate CB |+ b
+    biplate (CD d) = plate CD |- d
+
+instance Biplate C D where
+    biplate (CB b) = plate CB |+ b
+    biplate (CD d) = plate CD |+ d
+
+instance Biplate C E where
+    biplate (CB b) = plate CB |+ b
+    biplate (CD d) = plate CD |+ d
+
+instance Uniplate D where
+    uniplate (DDE d e) = plate DDE |* d |- e 
+    uniplate D = plate D
+
+instance Biplate D A where
+    biplate (DDE d e) = plate DDE |- d |- e 
+    biplate D = plate D
+
+instance Biplate D B where
+    biplate (DDE d e) = plate DDE |- d |- e 
+    biplate D = plate D
+
+instance Biplate D C where
+    biplate (DDE d e) = plate DDE |- d |- e 
+    biplate D = plate D
+
+instance Biplate D E where
+    biplate (DDE d e) = plate DDE |+ d |* e 
+    biplate D = plate D
+
+instance Uniplate E where
+    uniplate E = plate E 
+
+instance Biplate E A where
+    biplate E = plate E 
+
+instance Biplate E B where
+    biplate E = plate E 
+
+instance Biplate E C where
+    biplate E = plate E 
+
+instance Biplate E D where
+    biplate E = plate E 
+
+
+instance Biplate A A where
+    biplate = plateSelf
+
+instance Biplate B B where
+    biplate = plateSelf
+
+instance Biplate C C where
+    biplate = plateSelf
+
+instance Biplate D D where
+    biplate = plateSelf
+
+instance Biplate E E where
+    biplate = plateSelf
+
+
+directUni1 d = transformBi testFun1 (generateA d)
+directUni2 d = transformBi testFun2 (generateA d)
+

+ examples/Example.hs view

@@ -0,0 +1,120 @@+{-# LANGUAGE Rank2Types, ConstraintKinds, KindSignatures, TypeFamilies, ScopedTypeVariables, MultiParamTypeClasses, AllowAmbiguousTypes
+           , FlexibleContexts, FlexibleInstances, UndecidableInstances, DataKinds, TypeApplications, DeriveGeneric, DeriveDataTypeable
+           , TypeOperators, PolyKinds, ScopedTypeVariables, TemplateHaskell, TupleSections #-}
+module Example where
+
+import GHC.Exts
+import Data.Maybe
+import GHC.Generics (Generic)
+import qualified GHC.Generics as GG
+import Data.Data (Data)
+import Control.Monad
+import Control.Parallel.Strategies
+
+import Data.Type.Bool
+
+import Data.Generics.ClassyPlate
+import Data.Generics.ClassyPlate.Generate
+import Debug.Trace
+
+
+-------------------------------- USAGE-SPECIFIC PART
+
+test :: A
+test = bottomUp @F trf $ ABC (BA (ABC B (CB B))) (CB B)
+
+class F a where
+  trf :: a -> a
+
+instance F B where
+  trf b = b
+
+instance F C where
+  trf c = CD D
+
+type instance AppSelector F A = 'False
+type instance AppSelector F B = 'True
+type instance AppSelector F C = 'True
+type instance AppSelector F D = 'False
+type instance AppSelector F E = 'False
+
+
+
+topDownTrav :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
+{-# INLINE topDownTrav #-}
+topDownTrav trf = descend @c (topDownTrav @c trf . trf)
+
+bottomUpTrav :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
+{-# INLINE bottomUpTrav #-}
+bottomUpTrav trf = descend @c (trf . bottomUpTrav @c trf)
+
+
+--------
+
+test2 = bottomUpM @Debug debugCs $ ABC (BA (ABC B (CB B))) (CD D)
+
+class Debug a where
+  debugCs :: a -> IO a
+
+instance Debug C where
+  debugCs c = print c >> return c
+  
+type instance AppSelector Debug a = DebugSelector a
+
+type family DebugSelector t where
+  DebugSelector C = 'True
+  DebugSelector _ = 'False
+
+--------
+
+test3 :: A
+test3 = bottomUp @(MonoMatch C) (monoApp (\c -> case c of CB b -> CB (BA (ABC b (CB B))); CD d -> CD D)) $ ABC (BA (ABC B (CB B))) (CB B)
+
+-------
+
+class DebugWhere a where
+  debugWhereCs :: a -> IO a
+  debugSubtree :: a -> Bool
+  debugSubtree _ = True
+
+instance DebugWhere C where
+  debugWhereCs c = print c >> return c
+
+instance DebugWhere D where
+  debugWhereCs c = return c
+  debugSubtree _ = False
+
+instance DebugWhere E where
+  debugWhereCs c = error "Should never go here" >> return c 
+
+type instance AppSelector DebugWhere a = DebugWhereSelector a
+
+type family DebugWhereSelector t where
+  DebugWhereSelector C = 'True
+  DebugWhereSelector D = 'True
+  DebugWhereSelector E = 'True
+  DebugWhereSelector _ = 'False
+
+test4 = selectiveTraverseM @DebugWhere (\e -> (, debugSubtree e) <$> debugWhereCs e) $ ABC (BA (ABC B (CB B))) (CD (DDE D E))
+
+
+-------------------------------- REPRESENTATION-SPECIFIC PART
+
+data A = ABC B C deriving (Show, Generic, Data)
+data B = B | BA A deriving (Show, Generic, Data)
+data C = CB B | CD D deriving (Show, Generic, Data)
+data D = DDE D E | D deriving (Show, Generic, Data)
+data E = E deriving (Show, Generic, Data)
+
+instance NFData A
+instance NFData B
+instance NFData C
+instance NFData D
+instance NFData E
+
+makeClassyPlate [] ''A
+makeClassyPlate [] ''B
+makeClassyPlate [] ''C
+makeClassyPlate [] ''D
+makeClassyPlate [] ''E
+

+ examples/Generate.hs view

@@ -0,0 +1,40 @@+module Generate where
+
+import Example
+
+generateA :: Int -> A
+generateA d = ABC (generateB (d - 1)) (generateC (d - 1))
+
+generateB :: Int -> B
+generateB d 
+  | d <= 0    = B 
+  | otherwise = BA (generateA (d - 1))
+
+generateC :: Int -> C
+generateC d 
+  | d `mod` 2 == 0 = CB (generateB (d - 1))
+  | otherwise      = CD (generateD (d - 1))
+
+generateD :: Int -> D
+generateD d 
+  | d <= 0    = D 
+  | otherwise = DDE (generateD (d - 1)) E
+
+sizeA (ABC b c) = 1 + sizeB b + sizeC c
+sizeB B = 1
+sizeB (BA a) = 1 + sizeA a
+sizeC (CB b) = 1 + sizeB b
+sizeC (CD d) = 1 + sizeD d
+sizeD D = 1
+sizeD (DDE d e) = 1 + sizeD d + 1
+
+
+---
+
+testFun1 :: D -> D
+{-# NOINLINE testFun1 #-}
+testFun1 d = d
+
+testFun2 :: C -> C
+{-# NOINLINE testFun2 #-}
+testFun2 c = c

+ examples/Main.hs view

@@ -0,0 +1,60 @@+{-# LANGUAGE TypeApplications, FlexibleContexts, RankNTypes, DataKinds, LambdaCase, ScopedTypeVariables, ConstraintKinds, AllowAmbiguousTypes #-}
+
+module Main where
+
+
+import Data.Generics.ClassyPlate
+import Example
+
+import DirectUni (directUni1, directUni2)
+import AutoUni (autoUni1, autoUni2)
+
+import Generate
+
+import Criterion.Main
+
+our1 d = bottomUp @(MonoMatch D) (monoApp testFun1) (generateA d)
+our2 d = bottomUp @(MonoMatch C) (monoApp testFun2) (generateA d)
+auto1 d = smartTraverse @(MonoMatch D) (monoApp testFun1) (generateA d)
+auto2 d = smartTraverse @(MonoMatch C) (monoApp testFun2) (generateA d)
+
+topDown1 d = topDown @(MonoMatch D) (monoApp testFun1) (generateA d)
+topDown2 d = topDown @(MonoMatch C) (monoApp testFun2) (generateA d)
+topDownSelective1 d = selectiveTraverse @(MonoMatch D) (\e -> (monoApp testFun1 e, True)) (generateA d)
+topDownSelective2 d = selectiveTraverse @(MonoMatch C) (\e -> (monoApp testFun2 e, True)) (generateA d)
+
+bottomUp1 d = bottomUpTrav @(MonoMatch D) (monoApp testFun1) (generateA d)
+bottomUp2 d = bottomUpTrav @(MonoMatch C) (monoApp testFun2) (generateA d)
+
+
+main = defaultMain
+  [ bench "generation" $ nf generateA 141
+  , bgroup "our"
+    [ bench "deep" $ nf our1 141
+    , bench "shallow" $ nf our2 141
+    ]
+  , bgroup "topdown"
+    [ bench "deep" $ nf topDown1 141
+    , bench "shallow" $ nf topDown2 141
+    ]
+  , bgroup "selective"
+    [ bench "deep" $ nf topDownSelective1 141
+    , bench "shallow" $ nf topDownSelective2 141
+    ]
+  , bgroup "bottomUp-desc"
+    [ bench "deep" $ nf bottomUp1 141
+    , bench "shallow" $ nf bottomUp2 141
+    ]
+  , bgroup "auto"
+    [ bench "deep" $ nf auto1 141
+    , bench "shallow" $ nf auto2 141
+    ]
+  , bgroup "autoUni" 
+    [ bench "deep" $ nf autoUni1 141
+    , bench "shallow" $ nf autoUni2 141
+    ]
+  , bgroup "directUni" 
+    [ bench "deep" $ nf directUni1 141
+    , bench "shallow" $ nf directUni2 141
+    ]
+  ]

src/Data/Generics/ClassyPlate/Common.hs view

@@ -24,7 +24,6 @@ 
 instance MonoMatch a a where
   monoApp = id
-  {-# INLINE monoApp #-}
 
 type instance AppSelector (MonoMatch a) b = TypEq a b
   
@@ -34,52 +33,42 @@ 
 -- | Go down one level in the data structure and apply the given polymorphic function
 descend :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
-{-# INLINE descend #-}
 descend = descend_ (undefined :: ClsToken c)
 
 descendM :: forall c b m . (ClassyPlate c b, Monad m) => (forall a . (ClassyPlate c a, c a) => a -> m a) -> b -> m b
-{-# INLINE descendM #-}
 descendM = descendM_ (undefined :: ClsToken c)
 
 
 -- | Traverse the data structure in a top-down fashion with a polymorphic function.
 topDown :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
-{-# INLINE topDown #-}
 topDown = topDown_ (undefined :: ClsToken c)
 
 topDownM :: forall c b m . (ClassyPlate c b, Monad m) => (forall a . (ClassyPlate c a, c a) => a -> m a) -> b -> m b
-{-# INLINE topDownM #-}
 topDownM = topDownM_ (undefined :: ClsToken c)
 
 -- | Traverse the data structure with a polymorphic function.
 bottomUp :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
-{-# INLINE bottomUp #-}
 bottomUp = bottomUp_ (undefined :: ClsToken c)
 
 -- | Traverse the data structure with a polymorphic monadic function.
 bottomUpM :: forall c b m . (ClassyPlate c b, Monad m) 
                 => (forall a . (ClassyPlate c a, c a) => a -> m a) -> b -> m b
-{-# INLINE bottomUpM #-}
 bottomUpM = bottomUpM_ (undefined :: ClsToken c)
 
 -- | Traverse the data structure selectively with a function specifying if need to go down on the subtrees.
 selectiveTraverse :: forall c b . ClassyPlate c b => (forall a . (ClassyPlate c a, c a) => a -> (a, Bool)) -> b -> b
-{-# INLINE selectiveTraverse #-}
 selectiveTraverse trf = descend @c ((\(e, go) -> if go then selectiveTraverse @c trf e else e) . trf)
 
 -- | Traverse the data structure selectively with a monadic function specifying if need to go down on the subtrees.
 selectiveTraverseM :: forall c b m . (Monad m, ClassyPlate c b) => (forall a . (ClassyPlate c a, c a) => a -> m (a, Bool)) -> b -> m b
-{-# INLINE selectiveTraverseM #-}
 selectiveTraverseM trf = descendM @c ((\(e, go) -> if go then selectiveTraverseM @c trf e else return e) <=< trf)
 
 -- | Traverse only those parts of the data structure that could possibly contain elements that the given function can be applied on
 smartTraverse :: forall c b . SmartClassyPlate c (ClassIgnoresSubtree c b) b 
               => (forall a . (ClassyPlate c a, c a) => a -> a) -> b -> b
-{-# INLINE smartTraverse #-}
 smartTraverse = smartTraverse_ (undefined :: FlagToken (ClassIgnoresSubtree c b)) (undefined :: ClsToken c)
 
 -- | Traverse only those parts of the data structure that could possibly contain elements that the given monadic function can be applied on
 smartTraverseM :: forall c b m . (SmartClassyPlate c (ClassIgnoresSubtree c b) b, Monad m) 
                => (forall a . (ClassyPlate c a, c a) => a -> m a) -> b -> m b
-{-# INLINE smartTraverseM #-}
 smartTraverseM = smartTraverseM_ (undefined :: FlagToken (ClassIgnoresSubtree c b)) (undefined :: ClsToken c)

src/Data/Generics/ClassyPlate/Core.hs view

@@ -51,25 +51,17 @@   appTDM :: Monad m => FlagToken flag -> ClsToken c -> (forall a . (ClassyPlate c a, c a) => a -> m a) -> (b -> m b) -> b -> m b
 
 instance (ClassyPlate c b, c b) => App 'True c b where
-  {-# INLINE app #-}
   app _ _ f a = f a
-  {-# INLINE appM #-}
   appM _ _ f a = f a
 
-  {-# INLINE appTD #-}
   appTD _ _ f _ a = f a
-  {-# INLINE appTDM #-}
   appTDM _ _ f _ a = f a
 
 instance App 'False c b where
-  {-# INLINE app #-}
   app _ _ _ a = a
-  {-# INLINE appM #-}
   appM _ _ _ a = return a
 
-  {-# INLINE appTD #-}
   appTD _ _ _ d a = d a
-  {-# INLINE appTDM #-}
   appTDM _ _ _ d a = d a
 
 -- | A class for traversals that use a polymorphic function to visit all applicable elements.
@@ -91,6 +83,4 @@ 
 instance (GoodOperationForAuto c b) => SmartClassyPlate c True b where
   smartTraverse_ _ t f a = app (undefined :: FlagToken (AppSelector c b)) t f a
-  {-# INLINE smartTraverse_ #-}
   smartTraverseM_ _ t f a = appM (undefined :: FlagToken (AppSelector c b)) t f a
-  {-# INLINE smartTraverseM_ #-}

src/Data/Generics/ClassyPlate/TypePrune.hs view

@@ -10,8 +10,23 @@ import GHC.Exts (Constraint)
 import GHC.Generics
 import Data.Type.Bool
-import Data.Type.List
 import GHC.TypeLits (Symbol, Nat)
+
+type family Union xs ys where
+  Union '[] ys = ys
+  Union (x ': xs) ys = Insert x (Union xs ys)
+
+type family Find x ys where
+  Find x '[]       = 'False
+  Find x (x ': ys) = 'True
+  Find x (y ': ys) = Find x ys
+
+type family Insert a xs where
+  Insert a '[]       = (a ': '[])
+  Insert a (a ': xs) = (a ': xs)
+  Insert a (x ': xs) = x ': (Insert a xs)
+
+--------------------------------
 
 -- | This type decides if the subtree of an element cannot contain an element that is transformed.
 type family ClassIgnoresSubtree (cls :: * -> Constraint) (typ :: *) :: Bool where