Pretty.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Ott.Pretty
-- Copyright   :  (c) Brent Yorgey 2011
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@cis.upenn.edu>
-- Stability   :  experimental
--
-- Ott (<http://www.cl.cam.ac.uk/~pes20/ott/>) is a tool for writing
-- formal definitions of programming languages and calculi.  Often the
-- Ott grammars one defines end up being ambiguous, and Ott signals
-- its displeasure by spewing forth several massive parse trees in a
-- format requiring formidable patience to read.  Finding the slight
-- differences between two such parse trees is an exercise in
-- seizure-inducing tedium.
--
-- To the rescue comes ottparse-pretty!  Simply paste in each parse
-- and it is shown to you in a nicely formatted tree form with all the
-- extra meaningless cruft removed.
--
-- This module implements the internals of the tool: a simple parser
-- and a set of tree transformations.
-----------------------------------------------------------------------------
module Text.Ott.Pretty where

import Text.Parsec
import Control.Applicative ((<$>), (<*>), (*>), (<*), pure)

import Data.Tree
import Data.List.Split

import Data.Generics.Uniplate.Data


type Parser a = Parsec String () a

type T = Tree String

-- | Parse a string dump of an Ott parse tree.
parseTree :: Parser T
parseTree = char '(' *> parseApp <* char ')' <* spaces
        <|> Node <$> parseId <*> pure [] <* spaces

-- | Parse an application, i.e. a parent node with one or more children.
parseApp :: Parser T
parseApp = Node <$> parseId <*> many1 parseTree

-- | Parse an identifier.
parseId :: Parser String
parseId = spaces *> many1 (alphaNum <|> char '_' <|> char ':' <|> char '\'') <* spaces

-- | \"Normalize\" a parse tree by deleting meaningless cruft.
normalizeTree :: T -> T
normalizeTree = transformBis [ [ transformer stripColonNames ]
                             , [ transformer deleteSteSt ]
                             , [ transformer deleteNonterm ]
                             , [ transformer replaceStNode ]
                             ]

deleteSteSt :: T -> T
deleteSteSt (Node "Ste_st" [c]) = c
deleteSteSt t = t

deleteNonterm :: T -> T
deleteNonterm (Node "St_nonterm" [n@(Node _ [])]) = n
deleteNonterm t = t

replaceStNode :: T -> T
replaceStNode (Node "St_node" (Node name [] : cs)) = Node name cs
replaceStNode t = t

stripColonNames :: T -> T
stripColonNames (Node s cs) =
  case split (dropDelims . dropBlanks $ onSublist ":") s of
    [_,n] -> Node n cs
    _     -> Node s cs