Recursive Type Lensing

Question

I'm trying to create some code that can take any recursive grammar data type and any expression of that data type and produce a list of all sub-expressions of the same type, built up, kind of like a scan on the recursion of the type.

I've written two manual examples below for an accompanying toy calculator grammar type EExp. The first example uses prisms and lenses from the Lens library and will only work on the one eg1 example expression, whereas the second function just uses handrolled code but will work on any EExp expression.

Ideally I could use template haskell or something else to automatically build a recursive function that could focus on each of the sub expressions of an expression of any kind in that type (like a prism/lens), and therefore also easily print out a list of all the pieces of any expression given to it.

I'm a little bit stuck, though, with what to try or research next. Any help is really appreciated!

import qualified Control.Lens as Lens
import qualified Control.Lens.TH as LTH


-- Syntax for toy language

data EExp a
  = ELit a
  | EAdd (EExp a) (EExp a)
  | EMul (EExp a) (EExp a)
  | ESub (EExp a) (EExp a)
  deriving Show

-- build out a set of focus functions using lens / TH

LTH.makePrisms ''EExp


-- An example "text" in the Syntax

eg1 :: EExp Int
eg1 = EAdd
        (ELit 1)
        (EAdd (ELit 2) (ELit 0))

-- using lenses, we build out all the
-- EExp possibilities from the example "text":

lensedOptions :: Show a => EExp a -> [EExp a]
lensedOptions exp =
  let
    maybeGet l = Lens.preview l exp
    listMaybes =
      [ Just exp
      , maybeGet (_EAdd.(Lens._1))
      , maybeGet (_EAdd.(Lens._2))
      , maybeGet (_EAdd.(Lens._2)._EAdd.(Lens._1))
      , maybeGet (_EAdd.(Lens._2)._EAdd.(Lens._2))
      ]
  in
    maybe [] id $ sequenceA listMaybes

printEm :: IO ()
printEm = sequence_ $ map print $ lensedOptions eg1

-- using handwritten code, we build out all the
-- EExp possibilities from the example "text":


buildOptions :: Show a => EExp a -> [EExp a]
buildOptions exp =
  let
    buildBinOpts e1 e2 = [exp] ++ buildOptions e1 ++ buildOptions e2
  in
    case exp of
      ELit i -> [exp]
      EAdd e1 e2 ->
        buildBinOpts e1 e2
      EMul e1 e2 ->
        buildBinOpts e1 e2
      ESub e1 e2 ->
        buildBinOpts e1 e2

printEm2 :: IO ()
printEm2 = sequence_ $ map print $ buildOptions eg1

Answer 1

You are seeking the Control.Lens.Plated module.

First add a Data derivation:

{-# language DeriveDataTypeable #-}
import Data.Data
import Data.Data.Lens
import Control.Lens -- for universeOf function

data EExp a
  = ELit a
  | EAdd (EExp a) (EExp a)
  deriving (Show, Data) 

Then:

> buildOptions eg1
[EAdd (ELit 1) (EAdd (ELit 2) (ELit 0)),ELit 1,EAdd (ELit 2) (ELit 0),ELit 2,ELit 0]

> universeOf uniplate eg1
[EAdd (ELit 1) (EAdd (ELit 2) (ELit 0)),ELit 1,EAdd (ELit 2) (ELit 0),ELit 2,ELit 0]

The uniplate lens is doing the bulk of the magic here; using the information provided by the Data typeclass, it is able to walk one step into any Data-friendly data structure to find self-similar children. It is also doing some high-altitude caching gymnastics to make the traversals efficient, but we can safely ignore that.

universeOf uniplate repeatedly calls uniplate to find all transitive descendants.

For more information on Data.Data, check out the Scrap Your Boilerplate paper by Lämmel and SPJ.