Demonstration of a ParserT wrapping a Knot

knot.hs

-- This parses a simple language that allows word substitutions
-- to be defined.
--
-- Definitions are of the form WORD=WORD (where a WORD is a sequence
-- of letters).  They may occur anywhere in the document, and they
-- will cause the WORD on the left to be replaced by the WORD on
-- the right anywhere in the document (before or after the
-- definition).  Note that the WORD on the right may itself
-- be defined.  So, for example, the input
--
-- apple cat apple=orange orange=pear
--
-- will yield:
--
-- pear cat
--
-- The parser is a ParsecT wrapping a 'Knot' as defined in
-- http://mergeconflict.com/tying-the-knot-redux.  This is a
-- RWS monad in which the output of the writer is used as the
-- input to the reader.  This allows you to use 'asks' to
-- see if a reference is defined anywhere in the document, even
-- if you're still parsing the middle of the document, and
-- it allows you to use 'tell' to add a reference definition,
-- even if instances of the defined term have already been
-- parsed.

import Control.Monad.RWS
import Text.Parsec

-- Here we simplify by removing the state component.
type Knot k = RWS k k ()

tie :: Knot k a -> (a, k)
tie knot =
  let (a, _, k) = runRWS knot k ()
  in (a, k)

type RefList = [(String, String)]

type Parser a = ParsecT [Char] () (Knot RefList) a

main :: IO ()
main = do
  inp <- getContents
  case tie (runParserT pDoc () "" inp) of
       (Left e,  _) -> error (show e)
       (Right r, _) -> putStrLn r

pDoc :: Parser String
pDoc = fmap concat $ many $ pDef <|> pWord <|> pSpaces

pWord :: Parser String
pWord = do
  k <- many1 letter
  res <- lift $ asks (lookup k)
  return $ maybe k id res

pSpaces :: Parser String
pSpaces = many1 space

pDef :: Parser String
pDef = try $ do
  k <- many1 letter
  char '='
  v <- pWord
  spaces
  lift $ tell [(k,v)]
  return ""