Recursive Type Lensing

Viewed 400

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
1 Answers
Related