Scrap Your Reprinter: Example
=============================

Reprinting takes a source file and its (possible transformed) AST and
"stitches" them together into a new source file. This library provides
a generic reprinting algorithm that works on any AST with some modest
requirements. Where any changes to the AST have been made the
reprinting algorithm can be parameterised to hook into
application-specific functionality for handling nodes in the AST that
have been marked as transformed (e.g., applying a pretty printer to
these parts).

This module gives an introduction to library usage. For a better view
of the library itself, [the 2017
paper](https://www.cs.kent.ac.uk/people/staff/dao7/publ/reprinter2017.pdf)
goes over implementation in depth. (This module is adapted from
Section 3.4.)

We demonstrate the library on a limited integer expression language (reused for
the library tests). This is a literate Haskell/Markdown file, so feel free to
follow along in GHCi or your favourite text viewer.

\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances  #-}

module Text.Reprinter.Example where

import Text.Reprinter
import Control.Monad.State      -- for later example
import Data.Char                -- for parsing
\end{code}

Introduction
------------
*(Section 1 of the 2017 paper covers this in better detail.)*

A compiler translates source code to a target language. Sometimes when writing
language tools, you may find yourself writing a compiler where the source and
target languages are the same; automated code refactoring tools in IDEs
provide a common set of examples. Such tools must be careful not to remove
*secondary notation* like whitespace and comments. This, in short, can be a
pain to do well.

The reprinter library allows you to write a reprinter for any algebraic data
type supporting a minimal interface the algorithm needs to track changes.

This module designs a whitespace-flexible language with comments, and uses the
library to allow reprinting that preserves such secondary notation.

Language definition
-------------------
Let's take a language targeting integer addition, plus variable assignments. Our
top-level type will be an SSA-like list of *variable declaration-assignments*:

\begin{code}
type AST a = [Decl a]
data Decl a = Decl a Span String (Expr a)
    deriving (Decl a -> Decl a -> Bool
(Decl a -> Decl a -> Bool)
-> (Decl a -> Decl a -> Bool) -> Eq (Decl a)
forall a. Eq a => Decl a -> Decl a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Decl a -> Decl a -> Bool
$c/= :: forall a. Eq a => Decl a -> Decl a -> Bool
== :: Decl a -> Decl a -> Bool
$c== :: forall a. Eq a => Decl a -> Decl a -> Bool
Eq, Typeable (Decl a)
DataType
Constr
Typeable (Decl a)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Decl a -> c (Decl a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Decl a))
-> (Decl a -> Constr)
-> (Decl a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Decl a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Decl a)))
-> ((forall b. Data b => b -> b) -> Decl a -> Decl a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Decl a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Decl a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Decl a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Decl a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Decl a -> m (Decl a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Decl a -> m (Decl a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Decl a -> m (Decl a))
-> Data (Decl a)
Decl a -> DataType
Decl a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Decl a))
(forall b. Data b => b -> b) -> Decl a -> Decl a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Decl a -> c (Decl a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Decl a)
forall a. Data a => Typeable (Decl a)
forall a. Data a => Decl a -> DataType
forall a. Data a => Decl a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Decl a -> Decl a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Decl a -> u
forall a u. Data a => (forall d. Data d => d -> u) -> Decl a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Decl a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Decl a -> c (Decl a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Decl a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Decl a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Decl a -> u
forall u. (forall d. Data d => d -> u) -> Decl a -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Decl a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Decl a -> c (Decl a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Decl a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Decl a))
$cDecl :: Constr
$tDecl :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
gmapMp :: (forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
gmapM :: (forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Decl a -> m (Decl a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Decl a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Decl a -> u
gmapQ :: (forall d. Data d => d -> u) -> Decl a -> [u]
$cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Decl a -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Decl a -> r
gmapT :: (forall b. Data b => b -> b) -> Decl a -> Decl a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Decl a -> Decl a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Decl a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Decl a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Decl a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Decl a))
dataTypeOf :: Decl a -> DataType
$cdataTypeOf :: forall a. Data a => Decl a -> DataType
toConstr :: Decl a -> Constr
$ctoConstr :: forall a. Data a => Decl a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Decl a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Decl a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Decl a -> c (Decl a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Decl a -> c (Decl a)
$cp1Data :: forall a. Data a => Typeable (Decl a)
Data, Typeable, Int -> Decl a -> ShowS
[Decl a] -> ShowS
Decl a -> String
(Int -> Decl a -> ShowS)
-> (Decl a -> String) -> ([Decl a] -> ShowS) -> Show (Decl a)
forall a. Show a => Int -> Decl a -> ShowS
forall a. Show a => [Decl a] -> ShowS
forall a. Show a => Decl a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Decl a] -> ShowS
$cshowList :: forall a. Show a => [Decl a] -> ShowS
show :: Decl a -> String
$cshow :: forall a. Show a => Decl a -> String
showsPrec :: Int -> Decl a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Decl a -> ShowS
Show)
\end{code}

A `Decl a span var expr` represents the assignment of the value of an
expression `expr` to a variable `var`. The AST is composed of a sequence
(list) of these `Decl`s.

Expressions are formed of variables, literals, and additions over expressions:

\begin{code}
data Expr a
  = Plus a Span (Expr a) (Expr a)
  | Var a Span String
  | Const a Span Int
    deriving (Expr a -> Expr a -> Bool
(Expr a -> Expr a -> Bool)
-> (Expr a -> Expr a -> Bool) -> Eq (Expr a)
forall a. Eq a => Expr a -> Expr a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr a -> Expr a -> Bool
$c/= :: forall a. Eq a => Expr a -> Expr a -> Bool
== :: Expr a -> Expr a -> Bool
$c== :: forall a. Eq a => Expr a -> Expr a -> Bool
Eq, Typeable (Expr a)
DataType
Constr
Typeable (Expr a)
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Expr a -> c (Expr a))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Expr a))
-> (Expr a -> Constr)
-> (Expr a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Expr a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Expr a)))
-> ((forall b. Data b => b -> b) -> Expr a -> Expr a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Expr a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Expr a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Expr a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Expr a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Expr a -> m (Expr a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Expr a -> m (Expr a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Expr a -> m (Expr a))
-> Data (Expr a)
Expr a -> DataType
Expr a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Expr a))
(forall b. Data b => b -> b) -> Expr a -> Expr a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Expr a -> c (Expr a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Expr a)
forall a. Data a => Typeable (Expr a)
forall a. Data a => Expr a -> DataType
forall a. Data a => Expr a -> Constr
forall a.
Data a =>
(forall b. Data b => b -> b) -> Expr a -> Expr a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Expr a -> u
forall a u. Data a => (forall d. Data d => d -> u) -> Expr a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Expr a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Expr a -> c (Expr a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Expr a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Expr a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Expr a -> u
forall u. (forall d. Data d => d -> u) -> Expr a -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Expr a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Expr a -> c (Expr a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Expr a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Expr a))
$cConst :: Constr
$cVar :: Constr
$cPlus :: Constr
$tExpr :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
gmapMp :: (forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
gmapM :: (forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Expr a -> m (Expr a)
gmapQi :: Int -> (forall d. Data d => d -> u) -> Expr a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Expr a -> u
gmapQ :: (forall d. Data d => d -> u) -> Expr a -> [u]
$cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Expr a -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Expr a -> r
gmapT :: (forall b. Data b => b -> b) -> Expr a -> Expr a
$cgmapT :: forall a.
Data a =>
(forall b. Data b => b -> b) -> Expr a -> Expr a
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Expr a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Expr a))
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c (Expr a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Expr a))
dataTypeOf :: Expr a -> DataType
$cdataTypeOf :: forall a. Data a => Expr a -> DataType
toConstr :: Expr a -> Constr
$ctoConstr :: forall a. Data a => Expr a -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Expr a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Expr a)
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Expr a -> c (Expr a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Expr a -> c (Expr a)
$cp1Data :: forall a. Data a => Typeable (Expr a)
Data, Typeable, Int -> Expr a -> ShowS
[Expr a] -> ShowS
Expr a -> String
(Int -> Expr a -> ShowS)
-> (Expr a -> String) -> ([Expr a] -> ShowS) -> Show (Expr a)
forall a. Show a => Int -> Expr a -> ShowS
forall a. Show a => [Expr a] -> ShowS
forall a. Show a => Expr a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Expr a] -> ShowS
$cshowList :: forall a. Show a => [Expr a] -> ShowS
show :: Expr a -> String
$cshow :: forall a. Show a => Expr a -> String
showsPrec :: Int -> Expr a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Expr a -> ShowS
Show)
\end{code}

For our reprinting algorithm, every refactorable node in the AST must
store position information (`Span`, i.e., the start and end point of
this piece of syntax in the source code text) and whether it's been
refactored (and thus needs reprinting). In this case, we've
parameterised our AST over an arbitrary type `a`, which we specialise
in the rest of this file to `Bool` to represent whether this node has
been refactored or not. In a more complex AST, you could add this as a
field to an existing node annotation record type.

Note that the algorithm requires ASTs to have `Data` and `Typeable` instances.
Deriving these automatically requires the `DeriveDataTypeable` language pragma.

*(Section 1.1 in the 2017 paper gives an illustrated step-by-step example of a
transformation and reprint.)*

Concrete syntax and goals
-------------------------
Let's digress for a while to discuss our language's concrete syntax, since
reprinting uses abstract and concrete syntax simultaneously. Our language is
going to look something like this:

\begin{code}
exBasic :: String
exBasic :: String
exBasic = String
"x = +(0,1)\n"
\end{code}

We permit arbitrary spacing for prettier code, like so:

\begin{code}
exPrettier :: String
exPrettier :: String
exPrettier = [String] -> String
unlines
  [ String
"var = +(0  , 1)"
  , String
"x   = +(var, 2)"
  ]
\end{code}

And lines can be empty, or comments:

\begin{code}
exComment :: String
exComment :: String
exComment = [String] -> String
unlines
  [ String
"// slightly superfluous variable"
  , String
"zero = 0"
  , String
""
  , String
"// somewhat useful variable"
  , String
"x = +(zero, 1)"
  ]
\end{code}

Knowing all this, our aim is to take a formatted program source, parse it, apply
a transformation to the AST, then reprint the program while keeping the original
formatting. Starting with the given source (taken from the 2017 paper)

\begin{code}
exPaper :: String
exPaper :: String
exPaper = [String] -> String
unlines
  [ String
"x = +(1,2)"
  , String
"y  =  +(x,0)"
  , String
"// Calculate z"
  , String
"z  =  +( 1,  +(+(0,x) ,y) )"
  ]
\end{code}

We'll produce the following refactored and reprinted output:

    > putStr exPaper
    x = +(1,2)
    y  =  +(x,0)
    // Calculate z
    z  =  +( 1,  +(+(0,x) ,y) )
    > (putStr . refactor) exPaper
    x = +(1,2)
    y  =  x
    // Calculate z
    z  =  +( 1,  +(x ,y) )

Writing a transformation
------------------------
Putting concrete syntax aside, let's write a transformation for our AST - a
refactoring. A nice obvious one is replacing `x+0` (and `0+x`) expressions with
just `x`.

\begin{code}
refactorZero :: AST Bool -> AST Bool
refactorZero :: AST Bool -> AST Bool
refactorZero = (Decl Bool -> Decl Bool) -> AST Bool -> AST Bool
forall a b. (a -> b) -> [a] -> [b]
map ((Decl Bool -> Decl Bool) -> AST Bool -> AST Bool)
-> (Decl Bool -> Decl Bool) -> AST Bool -> AST Bool
forall a b. (a -> b) -> a -> b
$ \(Decl Bool
a Span
s String
n Expr Bool
e) -> Bool -> Span -> String -> Expr Bool -> Decl Bool
forall a. a -> Span -> String -> Expr a -> Decl a
Decl Bool
a Span
s String
n (Expr Bool -> Expr Bool
go Expr Bool
e)
  where
    go :: Expr Bool -> Expr Bool
go (Plus Bool
_ Span
s Expr Bool
e (Const Bool
_ Span
_ Int
0)) = Expr Bool -> Span -> Expr Bool
markRefactored (Expr Bool -> Expr Bool
go Expr Bool
e) Span
s
    go (Plus Bool
_ Span
s (Const Bool
_ Span
_ Int
0) Expr Bool
e) = Expr Bool -> Span -> Expr Bool
markRefactored (Expr Bool -> Expr Bool
go Expr Bool
e) Span
s
    go (Plus Bool
a Span
s Expr Bool
e1 Expr Bool
e2) = Bool -> Span -> Expr Bool -> Expr Bool -> Expr Bool
forall a. a -> Span -> Expr a -> Expr a -> Expr a
Plus Bool
a Span
s (Expr Bool -> Expr Bool
go Expr Bool
e1) (Expr Bool -> Expr Bool
go Expr Bool
e2)
    go Expr Bool
e = Expr Bool
e

    markRefactored :: Expr Bool -> Span -> Expr Bool
markRefactored (Plus Bool
_ Span
_ Expr Bool
e1 Expr Bool
e2) Span
s = Bool -> Span -> Expr Bool -> Expr Bool -> Expr Bool
forall a. a -> Span -> Expr a -> Expr a -> Expr a
Plus Bool
True Span
s Expr Bool
e1 Expr Bool
e2
    markRefactored (Var Bool
_ Span
_ String
n) Span
s      = Bool -> Span -> String -> Expr Bool
forall a. a -> Span -> String -> Expr a
Var Bool
True Span
s String
n
    markRefactored (Const Bool
_ Span
_ Int
i) Span
s    = Bool -> Span -> Int -> Expr Bool
forall a. a -> Span -> Int -> Expr a
Const Bool
True Span
s Int
i
\end{code}

Note that when marking nodes as refactored (`markRefactored`), we
replace the `Span` of the refactored node with the span of the
original `x+0` node- this allows the reprinting algorithm to replace
the original part of the source code with the new refactored node.

In concrete syntax, we're making changes like:

    + ( x , 0 )    becomes
    x

See how `x` is pulled out. The `+(x,y)` expression is directly replaced with
`x`, so we make sure to use the original span. Any comments following the
expression will be `shifted' - *not* removed, because the reprinter only makes
changes when a node in the AST indicates it has been refactored. Parts of a
source file that aren't captured in the AST will be printed with no changes.

Reprinter plumbing
------------------
We have an AST and a transformation on it. Next, we need to tell the reprinter
how to use our AST.

\begin{code}
-- FlexibleInstances used to define this without a wrapper
instance Refactorable (Expr Bool) where
  isRefactored :: Expr Bool -> Maybe RefactorType
isRefactored (Plus Bool
True Span
_ Expr Bool
_ Expr Bool
_) = RefactorType -> Maybe RefactorType
forall a. a -> Maybe a
Just RefactorType
Replace
  isRefactored (Var Bool
True Span
_ String
_)    = RefactorType -> Maybe RefactorType
forall a. a -> Maybe a
Just RefactorType
Replace
  isRefactored (Const Bool
True Span
_ Int
_)  = RefactorType -> Maybe RefactorType
forall a. a -> Maybe a
Just RefactorType
Replace
  isRefactored Expr Bool
_                 = Maybe RefactorType
forall a. Maybe a
Nothing

  getSpan :: Expr Bool -> Span
getSpan (Plus Bool
_ Span
s Expr Bool
_ Expr Bool
_) = Span
s
  getSpan (Var Bool
_ Span
s String
_)    = Span
s
  getSpan (Const Bool
_ Span
s Int
_)  = Span
s
\end{code}

Your AST's `Refactorable` instances will depend on how you store annotations in
your tree. Likely you store refactoring information inside a larger record type.
Perhaps you disallow refactoring at the type level for certain nodes. In this
case, we're only writing an instance for `Expr`s, because we don't reprint
`Decl`s directly. (If we wrote a variable renaming transformation, then it would
be needed.)

We're almost there. Next we define a generic query over the AST that determines
what we do for each node in the AST. This reprinting is straightforward:

  * If an `Expr` is marked as refactored, replace it with the updated `Expr`
    pretty-printed (AST -> concrete syntax)
  * Else skip (if the node was a `Decl`, or an unrefactored `Expr`)

Reprintings of this type can be generated with `genReprinting`. A later example
writes the reprinting directly to annotate all nodes of a certain type. For now,
let's code that reprinting and the required pretty printer:

\begin{code}
-- See the 2017 paper and SYB documentation for more info on 'extQ' queries.
exprReprinter :: Reprinting String Identity
exprReprinter :: node -> Identity (Maybe (RefactorType, String, Span))
exprReprinter = node -> Identity (Maybe (RefactorType, String, Span))
forall (m :: * -> *) a b. Monad m => a -> m (Maybe b)
catchAll (node -> Identity (Maybe (RefactorType, String, Span)))
-> (Expr Bool -> Identity (Maybe (RefactorType, String, Span)))
-> node
-> Identity (Maybe (RefactorType, String, Span))
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Expr Bool -> Identity (Maybe (RefactorType, String, Span))
forall (m :: * -> *).
Monad m =>
Expr Bool -> m (Maybe (RefactorType, String, Span))
reprintExpr
  where
    reprintExpr :: Expr Bool -> m (Maybe (RefactorType, String, Span))
reprintExpr Expr Bool
x = (Expr Bool -> m String)
-> Expr Bool -> m (Maybe (RefactorType, String, Span))
forall (m :: * -> *) t i.
(Monad m, Refactorable t, Typeable t, StringLike i) =>
(t -> m i) -> t -> m (Maybe (RefactorType, i, Span))
genReprinting (String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String)
-> (Expr Bool -> String) -> Expr Bool -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr Bool -> String
forall a. Expr a -> String
prettyExpr) (Expr Bool
x :: Expr Bool)

-- | Print an expression in canonical string form.
prettyExpr :: Expr a -> String
prettyExpr :: Expr a -> String
prettyExpr (Plus a
_ Span
_ Expr a
e1 Expr a
e2) = String
"+(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr a -> String
forall a. Expr a -> String
prettyExpr Expr a
e1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr a -> String
forall a. Expr a -> String
prettyExpr Expr a
e2 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
prettyExpr (Var a
_ Span
_ String
n)      = String
n
prettyExpr (Const a
_ Span
_ Int
n)    = Int -> String
forall a. Show a => a -> String
show Int
n

-- Note that we don't define a pretty printer for declarations, as we're not
-- refactoring on that level, so won't ever reprint them.
\end{code}

`catchAll \`extQ\` reprintExpr` essentially says "try casting my argument to
use in `reprintExpr`, else default to `catchAll`" where `catchAll` always
returns `Nothing` (meaning no refactoring/don't reprint). See the 2017 paper and
Scrap Your Boilerplate (SYB) materials for more details.

Finally, we put together a function that parses, runs our refactoring, then
reprints.

\begin{code}
-- | Parse and refactor, then run the reprinter with the original source and
--   updated AST.
refactor :: String -> String
refactor :: ShowS
refactor String
s =
      Identity String -> String
forall a. Identity a -> a
runIdentity
    (Identity String -> String) -> (String -> Identity String) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AST Bool -> String -> Identity String)
-> String -> AST Bool -> Identity String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Reprinting String Identity -> AST Bool -> String -> Identity String
forall (m :: * -> *) ast i.
(Monad m, Data ast, StringLike i) =>
Reprinting i m -> ast -> i -> m i
reprint Reprinting String Identity
exprReprinter) String
s
    (AST Bool -> Identity String)
-> (String -> AST Bool) -> String -> Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AST Bool -> AST Bool
refactorZero
    (AST Bool -> AST Bool)
-> (String -> AST Bool) -> String -> AST Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AST Bool
parse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
s

\end{code}

Further example: reprinting `After`
-----------------------------------
Using a monadic reprinter, we can write more complex reprintings. This example
from the 2017 paper annotates every variable declaration with its value.
Declarations are evaluated in order, building up a variable-value association
list. The list is stored in the `State` monad, which is passed along through the
reprinting.

\begin{code}
commentPrinter :: Reprinting String (State [(String, Int)])
commentPrinter :: node -> State [(String, Int)] (Maybe (RefactorType, String, Span))
commentPrinter = node -> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall (m :: * -> *) a b. Monad m => a -> m (Maybe b)
catchAll (node
 -> State [(String, Int)] (Maybe (RefactorType, String, Span)))
-> (Decl Bool
    -> State [(String, Int)] (Maybe (RefactorType, String, Span)))
-> node
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` Decl Bool
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
decl
  where
    decl :: Decl Bool
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
decl (Decl Bool
_ Span
s String
v Expr Bool
e) = do
      Maybe Int
val <- Expr Bool -> State [(String, Int)] (Maybe Int)
forall a. Expr a -> State [(String, Int)] (Maybe Int)
eval (Expr Bool
e :: Expr Bool)
      case Maybe Int
val of
        Maybe Int
Nothing -> Maybe (RefactorType, String, Span)
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RefactorType, String, Span)
 -> State [(String, Int)] (Maybe (RefactorType, String, Span)))
-> Maybe (RefactorType, String, Span)
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall a b. (a -> b) -> a -> b
$ Maybe (RefactorType, String, Span)
forall a. Maybe a
Nothing -- declaration expression referenced a
                                    -- variable before assignment: no annotation
        Just Int
val -> do
          ([(String, Int)] -> [(String, Int)])
-> StateT [(String, Int)] Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((String
v,Int
val) (String, Int) -> [(String, Int)] -> [(String, Int)]
forall a. a -> [a] -> [a]
:)    -- add mapping to environment
          let msg :: String
msg = String
" // " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
val
          Maybe (RefactorType, String, Span)
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (RefactorType, String, Span)
 -> State [(String, Int)] (Maybe (RefactorType, String, Span)))
-> Maybe (RefactorType, String, Span)
-> State [(String, Int)] (Maybe (RefactorType, String, Span))
forall a b. (a -> b) -> a -> b
$ (RefactorType, String, Span) -> Maybe (RefactorType, String, Span)
forall a. a -> Maybe a
Just (RefactorType
After, String
msg, Span
s)

eval :: Expr a -> State [(String, Int)] (Maybe Int)
eval :: Expr a -> State [(String, Int)] (Maybe Int)
eval (Plus a
_ Span
_ Expr a
e1 Expr a
e2) = do
  Maybe Int
e1' <- Expr a -> State [(String, Int)] (Maybe Int)
forall a. Expr a -> State [(String, Int)] (Maybe Int)
eval Expr a
e1
  Maybe Int
e2' <- Expr a -> State [(String, Int)] (Maybe Int)
forall a. Expr a -> State [(String, Int)] (Maybe Int)
eval Expr a
e2
  Maybe Int -> State [(String, Int)] (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> State [(String, Int)] (Maybe Int))
-> Maybe Int -> State [(String, Int)] (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) (Int -> Int -> Int) -> Maybe Int -> Maybe (Int -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
e1' Maybe (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
e2'
eval (Const a
_ Span
_ Int
i) = Maybe Int -> State [(String, Int)] (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> State [(String, Int)] (Maybe Int))
-> Maybe Int -> State [(String, Int)] (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
eval (Var a
_ Span
_ String
s) = StateT [(String, Int)] Identity [(String, Int)]
forall s (m :: * -> *). MonadState s m => m s
get StateT [(String, Int)] Identity [(String, Int)]
-> ([(String, Int)] -> State [(String, Int)] (Maybe Int))
-> State [(String, Int)] (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Int -> State [(String, Int)] (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> State [(String, Int)] (Maybe Int))
-> ([(String, Int)] -> Maybe Int)
-> [(String, Int)]
-> State [(String, Int)] (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(String, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s

refactorComment :: String -> String
refactorComment :: ShowS
refactorComment String
input =
      (State [(String, Int)] String -> [(String, Int)] -> String)
-> [(String, Int)] -> State [(String, Int)] String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [(String, Int)] String -> [(String, Int)] -> String
forall s a. State s a -> s -> a
evalState []
    (State [(String, Int)] String -> String)
-> (String -> State [(String, Int)] String) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AST Bool -> String -> State [(String, Int)] String)
-> String -> AST Bool -> State [(String, Int)] String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Reprinting String (StateT [(String, Int)] Identity)
-> AST Bool -> String -> State [(String, Int)] String
forall (m :: * -> *) ast i.
(Monad m, Data ast, StringLike i) =>
Reprinting i m -> ast -> i -> m i
reprint Reprinting String (StateT [(String, Int)] Identity)
commentPrinter) String
input
    (AST Bool -> State [(String, Int)] String)
-> (String -> AST Bool) -> String -> State [(String, Int)] String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AST Bool
parse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
input
\end{code}

Unscrapped boilerplate: parser for example language
---------------------------------------------------
The remainder of this module defines a simple monadic parser for the language.
It attempts to generate a position-tagged AST from a `String`.

\begin{code}
parse :: String -> AST Bool
parse :: String -> AST Bool
parse String
s = State (String, Position) (AST Bool)
-> (String, Position) -> AST Bool
forall s a. State s a -> s -> a
evalState State (String, Position) (AST Bool)
parseDecl (String
s, Position
initPosition)

type Parser = State (String, Position)

parseDecl :: Parser (AST Bool)
parseDecl :: State (String, Position) (AST Bool)
parseDecl = do
   (String
xs, Position
p1) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
   case String
xs of
       [] -> AST Bool -> State (String, Position) (AST Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return []
       (Char
'\n':String
xs) -> do
         (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
xs, Position -> Position
advanceLine Position
p1)
         State (String, Position) (AST Bool)
parseDecl
       String
_ -> do
         case String -> Maybe (String, String)
commentPrefix String
xs of
           Just (String
comment, String
rest) -> do
             (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
rest, Position
p1)
             State (String, Position) (AST Bool)
parseDecl
           Maybe (String, String)
Nothing -> do
             String
name <- (Char -> Bool) -> Parser String
many Char -> Bool
isAlpha
             Parser String
spaces
             Char -> StateT (String, Position) Identity ()
char Char
'='
             Parser String
spaces
             Expr Bool
expr <- Parser (Expr Bool)
parseExpr
             Position
p2 <- Parser Position
getPos
             Char -> StateT (String, Position) Identity ()
char Char
'\n'
             (String
xs, Position
p') <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
             (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
xs, Position -> Position
advanceLine Position
p')
             AST Bool
rest <- State (String, Position) (AST Bool)
parseDecl
             AST Bool -> State (String, Position) (AST Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (AST Bool -> State (String, Position) (AST Bool))
-> AST Bool -> State (String, Position) (AST Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Span -> String -> Expr Bool -> Decl Bool
forall a. a -> Span -> String -> Expr a -> Decl a
Decl Bool
False (Position
p1, Position
p2) String
name Expr Bool
expr Decl Bool -> AST Bool -> AST Bool
forall a. a -> [a] -> [a]
: AST Bool
rest

commentPrefix :: String -> Maybe (String, String)
commentPrefix :: String -> Maybe (String, String)
commentPrefix [] = Maybe (String, String)
forall a. Maybe a
Nothing
commentPrefix (Char
' ':String
xs) = String -> Maybe (String, String)
commentPrefix String
xs
commentPrefix (Char
'/':Char
'/':String
xs) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> Maybe (String, String))
-> (String, String) -> Maybe (String, String)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') String
xs
commentPrefix String
_ = Maybe (String, String)
forall a. Maybe a
Nothing

parseExpr :: Parser (Expr Bool)
parseExpr :: Parser (Expr Bool)
parseExpr = do
    Position
p1 <- Parser Position
getPos
    Bool
isPlus <- Char -> Parser Bool
charP Char
'+'
    if Bool
isPlus then do
      Char -> StateT (String, Position) Identity ()
char Char
'('
      Parser String
spaces
      Expr Bool
n <- Parser (Expr Bool)
parseExpr
      Parser String
spaces
      Char -> Parser Bool
charP Char
','
      Parser String
spaces
      Expr Bool
m <- Parser (Expr Bool)
parseExpr
      Parser String
spaces
      Char -> StateT (String, Position) Identity ()
char Char
')'
      Position
p2 <- Parser Position
getPos
      Expr Bool -> Parser (Expr Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Bool -> Parser (Expr Bool))
-> Expr Bool -> Parser (Expr Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Span -> Expr Bool -> Expr Bool -> Expr Bool
forall a. a -> Span -> Expr a -> Expr a -> Expr a
Plus Bool
False (Position
p1, Position
p2) Expr Bool
n Expr Bool
m
    else do
       Bool
isVar <- (Char -> Bool) -> Parser Bool
peekChar Char -> Bool
isAlpha
       if Bool
isVar then do
           String
name <- (Char -> Bool) -> Parser String
many Char -> Bool
isAlpha
           Position
p2 <- Parser Position
getPos
           Expr Bool -> Parser (Expr Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Bool -> Parser (Expr Bool))
-> Expr Bool -> Parser (Expr Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Span -> String -> Expr Bool
forall a. a -> Span -> String -> Expr a
Var Bool
False (Position
p1, Position
p2) String
name
       else do
           String
num <- (Char -> Bool) -> Parser String
many Char -> Bool
isDigit
           Position
p2 <- Parser Position
getPos
           Expr Bool -> Parser (Expr Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Bool -> Parser (Expr Bool))
-> Expr Bool -> Parser (Expr Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Span -> Int -> Expr Bool
forall a. a -> Span -> Int -> Expr a
Const Bool
False (Position
p1, Position
p2) (Int -> Expr Bool) -> Int -> Expr Bool
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Read a => String -> a
read String
num

-- Some monadic parser helpers (standard)

getPos :: Parser Position
getPos :: Parser Position
getPos = do
   (String
_, Position
p) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
   Position -> Parser Position
forall (m :: * -> *) a. Monad m => a -> m a
return Position
p

many :: (Char -> Bool) -> Parser String
many :: (Char -> Bool) -> Parser String
many Char -> Bool
p = do
    (String
xs, Position
pos) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
    case String
xs of
      (Char
x:String
xs) | Char -> Bool
p Char
x -> do
          (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
xs, Position -> Position
advanceCol Position
pos)
          String
ys <- (Char -> Bool) -> Parser String
many Char -> Bool
p
          String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Parser String) -> String -> Parser String
forall a b. (a -> b) -> a -> b
$ Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: String
ys
      String
_ -> String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

spaces :: Parser String
spaces = (Char -> Bool) -> Parser String
many (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ')

char :: Char -> Parser ()
char :: Char -> StateT (String, Position) Identity ()
char Char
c = do
    (String
xs, Position
pos) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
    case String
xs of
       (Char
x:String
xs') -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
                then do
                  (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
xs', Position -> Position
advanceCol Position
pos)
                  () -> StateT (String, Position) Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                else String -> StateT (String, Position) Identity ()
forall a. HasCallStack => String -> a
error (String -> StateT (String, Position) Identity ())
-> String -> StateT (String, Position) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Expecting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
x]
       [] -> String -> StateT (String, Position) Identity ()
forall a. HasCallStack => String -> a
error (String -> StateT (String, Position) Identity ())
-> String -> StateT (String, Position) Identity ()
forall a b. (a -> b) -> a -> b
$ String
"Expecting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
c] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" but got empty"

charP :: Char -> Parser Bool
charP :: Char -> Parser Bool
charP Char
c =  do
    (String
xs, Position
pos) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
    case String
xs of
       (Char
x:String
xs') -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
                then do
                   (String, Position) -> StateT (String, Position) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (String
xs', Position -> Position
advanceCol Position
pos)
                   Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
       [] -> String -> Parser Bool
forall a. HasCallStack => String -> a
error (String -> Parser Bool) -> String -> Parser Bool
forall a b. (a -> b) -> a -> b
$ String
"Expecting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
" but got empty")

peekChar :: (Char -> Bool) -> Parser Bool
peekChar :: (Char -> Bool) -> Parser Bool
peekChar Char -> Bool
p =  do
    (String
xs, Position
pos) <- StateT (String, Position) Identity (String, Position)
forall s (m :: * -> *). MonadState s m => m s
get
    case String
xs of
       (Char
x:String
_) -> if Char -> Bool
p Char
x
                then Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                else Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
\end{code}