eventloop 0.8.0.1 → 0.8.1.0

raw patch · 3 files changed

+97/−2 lines, 3 files

Files

• eventloop.cabal +2/−1
• src/Eventloop/Module/DrawTrees.hs +3/−1
• src/Eventloop/Module/DrawTrees/RoseTreeGeneric.hs +92/−0

@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.8.0.1
+version:             0.8.1.0
 synopsis:            A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.
 description:         A different take on an IO system. Based on Amanda's IO loop, this eventloop takes a function that maps input events to output events. It can easily be extended by modules that represent IO devices or join multiple modules together.
                      Each module exists of a initialize and teardown function that are both called once at startup and shutting down. During run-time, a module can provice a preprocessor function (which transforms input events before they get to the eventloop),
@@ -65,6 +65,7 @@                        Eventloop.Module.Websocket.Mouse.Types,
                        Eventloop.Module.DrawTrees.DrawTrees,
                        Eventloop.Module.DrawTrees.Types,
+                       Eventloop.Module.DrawTrees.RoseTreeGeneric,
                        Eventloop.Module.BasicShapes.BasicShapes,
                        Eventloop.Module.BasicShapes.Types,
                        Eventloop.Module.BasicShapes.Classes,

@@ -1,7 +1,9 @@ module Eventloop.Module.DrawTrees
     ( module Eventloop.Module.DrawTrees.Types
     , module Eventloop.Module.DrawTrees.DrawTrees
+    , module Eventloop.Module.DrawTrees.RoseTreeGeneric
     ) where
     
 import Eventloop.Module.DrawTrees.Types
-import Eventloop.Module.DrawTrees.DrawTrees+import Eventloop.Module.DrawTrees.DrawTrees
+import Eventloop.Module.DrawTrees.RoseTreeGeneric

@@ -0,0 +1,92 @@+{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric,
+             DeriveAnyClass, TypeSynonymInstances, FlexibleInstances,
+             ScopedTypeVariables, StandaloneDeriving #-}
+module Eventloop.Module.DrawTrees.RoseTreeGeneric
+    ( ToRoseTree (..)
+    , genericToRoseTree
+    ) where
+
+import GHC.Generics
+import Eventloop.Module.DrawTrees.Types
+
+emptyNode = RoseNode "" []
+
+cleanTree = concatMap mergeProduct
+          . filter (/= emptyNode)
+
+mergeProduct (RoseNode "" xs) = xs
+mergeProduct r                = [r]
+
+-- | Convert to a 'RoseTree'
+class ToRoseTree a where
+  -- | Convert to a 'RoseTree'
+  toRoseTree :: a -> RoseTree
+  default toRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree
+  toRoseTree = genericToRoseTree
+
+-- | A version of 'toRoseTree' that works for any data type that has an
+-- instance for 'Generic'
+genericToRoseTree :: (Generic a, GToRoseTree (Rep a)) => a -> RoseTree
+genericToRoseTree = gtoRoseTree . from
+
+class GToRoseTree f where
+  gtoRoseTree :: f a -> RoseTree
+
+-- constants
+instance ToRoseTree c => GToRoseTree (K1 i c) where
+  gtoRoseTree = toRoseTree . unK1
+
+-- meta
+instance {-# OVERLAPPABLE #-} GToRoseTree f => GToRoseTree (M1 i c f) where
+  gtoRoseTree = gtoRoseTree . unM1
+
+-- constructors
+instance (Constructor c, GToRoseTree f) => GToRoseTree (C1 c f) where
+  gtoRoseTree = RoseNode (conName (undefined :: t c f p))
+              . cleanTree
+              . (:[])
+              . gtoRoseTree
+              . unM1
+
+-- unit
+instance GToRoseTree U1 where
+  gtoRoseTree U1 = emptyNode
+
+-- void
+instance GToRoseTree V1 where
+  gtoRoseTree _ = emptyNode
+
+-- product
+instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :*: g) where
+  gtoRoseTree (f1 :*: g1) = RoseNode "" (cleanTree [gtoRoseTree f1, gtoRoseTree g1])
+
+-- sum
+instance (GToRoseTree f, GToRoseTree g) => GToRoseTree (f :+: g) where
+  gtoRoseTree (L1 f1) = gtoRoseTree f1
+  gtoRoseTree (R1 g1) = gtoRoseTree g1
+
+instance ToRoseTree Int where
+  toRoseTree i = RoseNode (show i) []
+
+instance ToRoseTree Integer where
+  toRoseTree i = RoseNode (show i) []
+
+instance ToRoseTree Float where
+  toRoseTree f = RoseNode (show f) []
+
+instance ToRoseTree Double where
+  toRoseTree d = RoseNode (show d) []
+
+instance ToRoseTree Char where
+  toRoseTree c = RoseNode [c] []
+
+deriving instance ToRoseTree Bool
+deriving instance ToRoseTree Ordering
+deriving instance (ToRoseTree l, ToRoseTree r) => ToRoseTree (Either l r)
+deriving instance ToRoseTree a => ToRoseTree (Maybe a)
+
+instance {-# OVERLAPPABLE #-} ToRoseTree a => ToRoseTree [a] where
+  toRoseTree = RoseNode "" . cleanTree . map toRoseTree
+
+instance ToRoseTree String where
+  toRoseTree s = RoseNode s []