A binary tree whose shape `s` is encoded in the type, with an instance `Monoid (StructuredTree s a)` that appends the leaf values, and JSON serialization

StructuredTree.hs

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DeriveTraversable  #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE KindSignatures     #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE TypeInType         #-}
{-# LANGUAGE TypeOperators      #-}
module Tree(
  StructuredTree(..),
  TreeStructure(..),
  toSome,
  SomeStructuredTree(..)
) where

import           Control.DeepSeq
import           Data.Aeson
import qualified Data.Aeson.Types   as T
import           Data.Kind
import           Data.Semigroup
import           Data.Singletons
import           Data.Singletons.TH
import           GHC.Generics       (Generic)

data TreeStructure = Leaf | Node TreeStructure TreeStructure
  deriving (Eq, Ord, Show, Generic)

instance ToJSON TreeStructure
instance FromJSON TreeStructure
instance NFData TreeStructure

genSingletons [''TreeStructure]

data StructuredTree (s :: TreeStructure) a where
  ALeaf :: a -> StructuredTree 'Leaf a
  ANode :: StructuredTree l a -> StructuredTree r a -> StructuredTree ('Node l r) a

deriving instance Functor (StructuredTree s)
deriving instance Foldable (StructuredTree s)
deriving instance Traversable (StructuredTree s)
deriving instance Show a => Show (StructuredTree s a)

instance Semigroup a => Semigroup (StructuredTree s a) where
  (ALeaf l) <> (ALeaf r) = ALeaf (l <> r)
  (ANode ll lr) <> (ANode rl rr) = ANode (ll <> rl) (lr <> rr)

instance (Monoid a, Semigroup a, SingI s) => Monoid (StructuredTree s a) where
  mappend = (<>)
  mempty = go sing where
    go :: Monoid a => Sing s -> StructuredTree s a
    go = \case
      SLeaf -> ALeaf mempty
      SNode l r -> ANode (go l) (go r)

toSome :: SingI s => StructuredTree s a -> SomeStructuredTree a
toSome = MkSomeStructuredTree sing

data SomeStructuredTree :: * -> Type where
  MkSomeStructuredTree :: SingI (s :: TreeStructure) => Sing s -> StructuredTree s a -> SomeStructuredTree a

deriving instance Functor SomeStructuredTree
deriving instance Foldable SomeStructuredTree
deriving instance Traversable SomeStructuredTree

instance Show a => Show (SomeStructuredTree a) where
  show (MkSomeStructuredTree _ a) = show a

instance ToJSON a => ToJSON (SomeStructuredTree a) where
  toJSON (MkSomeStructuredTree s a) = go a where
    go :: ToJSON a => StructuredTree s a -> Value
    go (ALeaf a) = object [
      "t"   .= ("l" :: String),
      "v" .= a]
    go (ANode l r) = object [
      "t" .= ("n" :: String),
      "l"   .= go l,
      "r"   .= go r]

instance FromJSON a => FromJSON (SomeStructuredTree a) where
  parseJSON = withObject "SomeStructuredTree" $ \obj -> do
    t <- (obj .: "t") :: T.Parser String
    case t of
      -- leaf
      "l" ->
        MkSomeStructuredTree <$> pure SLeaf <*> (ALeaf <$> obj .: "v")
      -- node
      "n" -> do
        MkSomeStructuredTree ls lv <- obj .: "l" >>= parseJSON
        MkSomeStructuredTree rs rv <- obj .: "r" >>= parseJSON
        return (MkSomeStructuredTree (SNode ls rs) (ANode lv rv))

result :: SomeStructuredTree (Sum Int)
result = let qq = ANode (ALeaf Sum) (ALeaf (const $ Sum 1)) in
         case toSome qq of
            MkSomeStructuredTree t sq -> MkSomeStructuredTree t $ foldMap (\a -> (\f -> f a) <$> sq) [1..10] where