ehaskell-0.7: GetCodeText.hs

module GetCodeText (
  getCodeText
, CodeText(..)
) where

import Text.ParserCombinators.MTLParse
import Control.Monad.Tools
import Types

type SymCodePair = ( (String, String), CodeText )

symCodePairs :: [ SymCodePair ]
symCodePairs = [
   ( (""   , "" ), Code         )
 , ( ("%"  , "%"), CodeTop      )
 , ( (""   , "-"), CodeBegin    )
 , ( ("-"  , "-"), CodeCont     )
 , ( ("-"  , "" ), CodeEnd      )
 , ( ("="  , "" ), CodeEq       )
 , ( ("==" , "" ), CodeEqEq     )
 , ( ("=$" , "" ), CodeEqShow   )
 , ( ("==$", "" ), CodeEqEqShow )
 ]

getCodeText :: String -> [ (CodeText, String) ]
getCodeText = fst . myHead . runParse parseCodeText . (,) ""
  where
  myHead (h:_) = h
  myHead _     = error "parseCodeText in module GetCodeText: parse error"

parseCodeText :: Parse Char [ (CodeText, String) ]
parseCodeText
  = ( fmap concat $ list $ parseText >:> (fmap (:[]) parseCode) ) >++>
    (fmap (:[]) parseText) >>= endOfInput

parseText :: Parse Char (CodeText, String)
parseText = do
  txt <- list $ do
    still (parseNot () $ tokens "<%")
    spot $ const True
  return (Text, txt)

parseCode :: Parse Char (CodeText, String)
parseCode =
  (tokens "<%" >> msum (map parseCodeGen symCodePairs) >>= skipRet (tokens "%>"))
    `mplus` (tokens "<%-%>" >> return (CodeEnd, ""))
    `mplus` (tokens "<%--%>" >> return (CodeCont, ""))

parseCodeGen :: SymCodePair -> Parse Char (CodeText, String)
parseCodeGen ((b, e), c) = do
  tokens b
  still $ spot $ flip notElem "%-=$"
  code <- fmap concat $ list $
    do { still (parseNot () $ tokens "%>");
         fmap (:[]) $ spot $ flip notElem "()\""; }
      `mplus` parseDQ `mplus` parseParen
  still $ spotBack (/='-')
  tokens e
  return (c, code)

parseDQ :: Parse Char String
parseDQ = do
  token '"'
  ret <- fmap concat $ list $ (fmap (:[]) $ spot $ flip notElem "\\\"") `mplus`
		              (token '\\' >:> (fmap (:[]) $ spot $ const True))
  token '"'
  return $ '"' : ret ++ "\""

parseParen :: Parse Char String
parseParen = do
  token '('
  ret <- fmap concat $ list $ ( fmap (:[]) $ spot $ flip notElem "()" )
                                `mplus` parseParen
  token ')'
  return $ '(' : ret ++ ")"