A labelled, uninterestingly-heterogeneous rose tree implementation in PureScript, with a little dash of Coyoneda.

Tree.purs

module Data.Labelled.Tree where

-- Traditionally, we express a rose tree with a structure along the lines of
--
-- ```
-- data RoseTree a
--   = RoseTree a (Array (RoseTree a))
-- ```
--
-- As with many of our favourite "Haskell containers", this comes with an
-- annoying restriction: all its values have to be _the same type_. While this
-- is normally fine, we often want to express something like a "drill-down"
-- navigation, in which each level wraps the lower level in some constructor,
-- building up a compound type. For example, let's consider our favourite
-- mortgage example:
--
-- ```
-- data InitialProduct
--   = Fixed    FixedTerm
--   | Variable VariableTerm
--
-- data FixedTerm
--   = TwoYearFixed
--   | ThreeYearFixed
--   | FiveYearFixed
--   | TenYearFixed
--
-- data VariableTerm
--   = TwoYearVariable
--   | ThreeYearVariable
--   | FiveYearVariable
--   | LifetimeVariable
-- ```
--
-- We can visualise this as a neat little tree:
--
-- ```
-- Product -+- Fixed -+-  2
--          |         +-  3
--          |         +-  5
--          |         +- 10
--          |
--          +- Variable -+- 2
--                       +- 3
--                       +- 5
--                       +- Lifetime
-- ```
--
-- So... why can't we express this as a tree? Sure, we could wrap the leaves in
-- their outer constructors, but then how, for example, can we "show" labels
-- using the same function for both the wrapping constructors _and_ the leaves?
--
-- Well... never fear! The trick employed within this file is that, if we
-- define the forest as `Array (Coyoneda RoseTree a)` (i.e. the type within the
-- `RoseTree` can be _anything_ as long as we have a transformation from its
-- type back to `a`), this restriction goes away!

import Data.Array (null, uncons)
import Data.Coyoneda (Coyoneda, coyoneda, liftCoyoneda, lowerCoyoneda)
import Data.Foldable (foldMap)
import Data.Generic.Rep as G
import Data.Generic.Rep.Show (genericShow)
import Prelude

-- Before we get started, let's talk about the type I _wanted_:
--
-- ```
-- data Tree (c :: Type -> Constraint) (x :: Type) where
--   Tree
--     :: c x
--     => { head   :: x
--        , forest :: Array (Coyoneda (Tree c) x)
--        , label :: String
--        }
--     -> Tree c x
-- ```
--
-- We can see here that we constrain the values throughout the tree with some
-- particular constraint, which we can then use to perform operations on the
-- tree as a whole!

-- In PureScript, this kind of "constraint kind" trickery is quite difficult to
-- achieve, and not always possible! With this in mind, and given that I had
-- quite a specific use case (namely that I needed a way to "label" each node),
-- I've specialised the type, removed the constraint, and added a `label` key
-- to store the results of this operation.
newtype Tree value
  = Tree
      { head    :: value
      , forest  :: Array (Coyoneda Tree value)
      , label   :: String
      }

-- Tree is a pretty straightforward functor thanks to the `Coyoneda` instance,
-- which just composes the mapped function onto the "lowering" transformation.
derive instance functorTree :: Functor Tree

-- If we're just doing a regular 'Show', the values aren't necessarily so
-- important: at least for my use case, the labels tell us exactly what the
-- values are!
instance showTree :: Show a => Show (Tree a) where
  show (Tree tree)
    | null tree.forest = tree.label
    | otherwise        = tree.label <> ": "
                                    <> show (map lowerCoyoneda tree.forest)

-- When we `show (Fixed TwoYearFixed)`, we get... well, "Fixed TwoYearFixed".
-- However, what we want is slightly different: We want a way to give labels to
-- _the outermost constructor_, rather than the whole value. Thus, we make a
-- `Show`-like typeclass to achieve this. _Note that this *would* have been the
-- constraint passed into our constrained tree, had we been so polymorphic._
class Label (x :: Type) where
  label :: x -> String

---

-- Given the machinery above, we can now write some generics magic to achieve
-- my particular goal: create a tree of all possible vales of a type, labelling
-- each level by the wrapping "constructor". This means, depending of course on
-- how we labelled it, we're expecting something like:
--
-- ```
-- >>> options :: FixedOrVariable
-- [Fixed: [2,3,5,10],Variable: [2,3,5,Life]
-- ```
class Options (value :: Type) where
  options :: Array (Tree value)

-- The generics magic produces the subtrees for *each constructor*, where the
-- lowering operation simply wraps the value in that particular constructor.
-- We then use this as the "forest" in our generic instance of `Options`, and
-- take the head the first "lowered" tree as our top node.
class GOptions (rep :: Type) where
  goptions :: Array (Coyoneda Tree rep)

-- When we have more than one constructor, we'll want to translate this to more
-- than one top-level tree. To accomplish this, we generate the trees for
-- either side of the sum, and then concatenate the two results back together!
instance goptionsSum
    :: ( GOptions left
       , GOptions right
       )
    => GOptions (G.Sum left right) where
  goptions
     = map (map G.Inl) goptions
    <> map (map G.Inr) goptions

-- An argumentless constructor is a neat little base case: here, we just have
-- one possible choice, which is the argument-less constructor itself!
instance goptionsUnitConstructor
    :: GOptions (G.Constructor name G.NoArguments) where
  goptions
    = [ liftCoyoneda
          ( Tree
              { head: G.Constructor G.NoArguments
              , forest: []
              , label: ""
              }
          )
      ]

-- If we _do_ have an argument (note that we only support single-argument
-- constructors), we need to generate another layer of this tree: we create all
-- possible permutations of the argument, and then wrap them back up in the
-- `Constructor` and `Argument` wrappers for generics. Note that calling
-- `liftCoyoneda` here will mean that subsequent `map` operations are just
-- composed together into a function we run when we "lower" again.
else instance goptionsConstructor
    :: Options                                  inner
    => GOptions (G.Constructor name (G.Argument inner)) where
  goptions = uncons subtrees # foldMap \{ head: Tree tree } ->
      [ liftCoyoneda
        ( Tree
            { head:   tree.head
            , forest: map liftCoyoneda subtrees
            , label:  tree.label
            }
        )
      ]
    where
      subtrees :: Array (Tree (G.Constructor name (G.Argument inner)))
      subtrees = map (map (G.Constructor <<< G.Argument)) options

-- Finally, our `Options` implementation: we lower the trees given back from
-- the generic machinery, label the trees, and return them, "lowered", to the
-- user.
instance optionsGOptions
    :: ( G.Generic value rep
       , GOptions rep
       , Label value
       )
    => Options value where
  options = goptions <#> \option -> do
    let Tree tree = lowerCoyoneda (map G.to option)

    Tree
      { head:         tree.head
      , forest:       tree.forest
      , label:  label tree.head
      }