{-# 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 []