Example own Traversable

Example_own_traversable.daml

module Playground18 where

import DA.Foldable
import DA.Traversable

import Daml.Script

import Prelude hiding (mapA)

-- Goal : get a better understanding of the Traversable typeclass by implementing it on a binary tree

data Tree a
  = Leaf
  | Node with
    value : a
    left  : Tree a
    right : Tree a

-- first we define functoriality (with respect to the contained argument)
instance Functor Tree where
  -- (a -> b) -> t a -> t b
  fmap f Leaf = Leaf
  fmap f Node{..} = Node with value = f value, left = fmap f left, right = fmap f right

-- secondly, we implement foldability (with respect to the contained argument)
instance Foldable Tree where
  -- Monoid m => (a -> m) -> t a -> m
  foldMap f Leaf = mempty
  foldMap f Node{..} = foldMap f left <> f value <> foldMap f right

-- thirdly, we want to traverse the tree
-- applicative : given f (a -> b) and f a, I can put them together with <*>
instance Traversable Tree where
  -- basically by applying mapA with a carefully chosen action (my node builder + mapA f) I end up with the
  -- applicative partially applied to the left part of the tree (because applicative operators are left associative)
  -- we then use this applicative to build the rest of the tree
  -- it would be easy to change the order of application (using do notation)
  mapA f Leaf = pure Leaf
  mapA f Node{..} =
    let buildNode l c r = Node with left = l, value = c, right = r
    in buildNode <$> mapA f left <*> f value <*> mapA f right

template T with
    p : Party
    t : Text
  where signatory p

effectfulFunction : Party -> Text -> Script Text
effectfulFunction p t = do
  submit p do createCmd T with p,t
  pure t

script : Script ()
script = do

  p <- allocateParty "p"

  -- build tree
  --            a
  --          /   \
  --         b     e
  --        / \   / \
  --       c   d f   g
  let tree = Node
        with
          value = "a"
          left = Node
            with
              value = "b"
              left = Node
                with
                  value = "c"
                  left = Leaf
                  right = Leaf
              right = Node
                with
                  value = "d"
                  left = Leaf
                  right = Leaf
          right = Node
            with
              value = "e"
              left = Node
                with
                  value = "f"
                  left = Leaf
                  right = Leaf
              right = Node
                with
                  value = "g"
                  left = Leaf
                  right = Leaf

  -- traverse the tree, creating one contract per node
  x <- mapA (effectfulFunction p) tree

  pure ()