I need to extend the definition of left scan to Cofree structures, to accumulate annotations from the root of an annotated AST to the leaves, however I don't understand why my naive implementation scanCofree.. doesn't do anything.
Edit: my first definition of the program type Stmt is wrong, as it doesn't allow recursion where it matters. See answer below.
The definition for rose trees is as follows, and it does the right thing:
data Tree a = Node a [Tree a] deriving (Show)
scan :: (b -> a -> b) -> b -> Tree a -> Tree b
scan f a (Node x ns) = Node a' $ map (scan f a') ns
where
a' = f a x
t0 :: Tree Int
t0 = Node 3 [Node 5 [], Node 1 []]
> scan (+) 0 t0
Node 3 [Node 8 [],Node 4 []]
I wrote scanCofree naively following the one above:
data Cofree f a = a :< f (Cofree f a)
scanCofree :: Functor f =>
(b -> a -> b) -> b -> Cofree f a -> Cofree f b
scanCofree f a (x :< ns) = a' :< fmap (scanCofree f a') ns
where
a' = f a x
Let's say we have a simple imperative language Stmt with assignments and branching constructs
data Stmt a = SAssign Int -- id = ..
| SSeq [Stmt a] -- smt0; smt1; ..
| SIf (Stmt a) (Stmt a) -- branching
deriving (Show)
And we want to track the variables that are in scope at each statement :
binds :: Stmt a -> Cofree (StmtF a) [Id]
binds = annotate f
where
f = \case
SAssign i -> [i]
_ -> []
s0 = SSeq [SAssign 0,SIf (SAssign 1) (SAssign 2)]
I cannot figure out why scanCofree (<>) mempty does not do anything (acts like the identity function):
> binds s0
[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([1] :< SAssignF 1) ([2] :< SAssignF 2)]
> scanCofree (<>) mempty $ binds s0
[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([1] :< SAssignF 1) ([2] :< SAssignF 2)]
whereas I would like it to propagate the topmost [0] annotation to the levels below:
[] :< SSeqF [[0] :< SAssignF 0,[] :< SIfF ([0,1] :< SAssignF 1) ([0,2] :< SAssignF 2)]
Misc definitions:
-- | base functor of Stmt
data StmtF a x = SAssignF Id -- id = ...
| SSeqF [x] -- smt0; smt1; ..
| SIfF x x
deriving (Eq, Show, Functor, Foldable, Traversable)
$(deriveShow1 ''StmtF)
type instance Base (Stmt a) = StmtF a
instance Recursive (Stmt a) where
project = \case
SAssign i -> SAssignF i
SSeq xs -> SSeqF xs
SIf a b -> SIfF a b
instance Corecursive (Stmt a) where
embed = \case
SAssignF i -> SAssign i
SSeqF xs -> SSeq xs
SIfF a b -> SIf a b
annotate :: Recursive t
=> (t -> a)
-> t
-> Cofree (Base t) a
annotate alg t = alg t :< fmap (annotate alg) (project t)
-- from micro-recursion-schemes
instance (Show1 f) => Show1 (Cofree f) where
liftShowsPrec sp sl = go
where
goList = liftShowList sp sl
go d (a :< as) = showParen (d > 5) $
sp 6 a . showString " :< " . liftShowsPrec go goList 5 as
instance (Show1 f, Show a) => Show (Cofree f a) where
showsPrec = showsPrec1
instance Functor f => Functor (Cofree f) where
fmap f (a :< as) = f a :< fmap (fmap f) as
b <$ (_ :< as) = b :< fmap (b <$) as
instance Foldable f => Foldable (Cofree f) where
foldMap f = go where
go (a :< as) = f a `mappend` foldMap go as
{-# INLINE foldMap #-}
length = go 0 where
go s (_ :< as) = foldl' go (s + 1) as
instance Traversable f => Traversable (Cofree f) where
traverse f = go where
go (a :< as) = (:<) <$> f a <*> traverse go as
type family Base t :: Type -> Type
class Functor (Base t) => Recursive t where
project :: t -> Base t t
cata :: (Base t a -> a) -- ^ a (Base t)-algebra
-> t -- ^ fixed point
-> a -- ^ result
cata f = c where c = f . fmap c . project
As @Li-yaoXia pointed out, you need a recursion point at each constructor that needs to propagate information at the lower levels of the tree. My initial definition of Stmt was incorrect because the `SAssign` constructor that models variable binding was a "leaf".
This is a better definition that actually models nested variable scopes:
data Stmt a = SAssign Id (Stmt a) -- id = ..; smt
| SSeq [Stmt a] -- smt0; smt1; ..
| SIf (Stmt a) (Stmt a) -- branching
deriving (Show)
-- | base functor of Stmt
data StmtF a x = SAssignF Id x -- id = ...; smt
| SSeqF [x] -- smt0; smt1; ..
| SIfF x x
deriving (Eq, Show, Functor, Foldable, Traversable)
-- (adjust the Recursive and Corecursive instances as needed)
instance Semigroup (Stmt a) where
(<>) = undefined -- we only need mempty
instance Monoid (Stmt a) where
mempty = SSeq []
binds :: Stmt a -> Cofree (StmtF a) [Id]
binds = annotate f
where
f = \case
SAssign i _ -> [i]
_ -> []
s0 :: Stmt a
s0 = SAssign 0 (SIf (SAssign 1 mempty) (SAssign 2 mempty))
gives us at last
λ> scanCofree (<>) mempty $ binds s0
[0] :< SAssignF 0 ([0] :< SIfF ([0,1] :< SAssignF 1 ([0,1] :< SSeqF [])) ([0,2] :< SAssignF 2 ([0,2] :< SSeqF [])))