--
module Parser where
import qualified System.IO
import Data.Char(digitToInt,isUpper)
import GHC.Float(double2Float)
-- These are for defining parsers
import Text.Parsec hiding (State)
import Text.Parsec.Expr(Operator(..),Assoc(..),buildExpressionParser)
-- Replaces Text.Parsec.Token
import qualified LayoutToken as Token
-- This is for possible Monads underlying the Parsing Monad
import Control.Monad.State
import Data.Functor.Identity(Identity(..))
-- This is to catch errors when Parsing
import qualified Control.Exception
import Debug.Trace
-- import the Hughes Pretty Printing library qualified
import qualified Text.PrettyPrint.HughesPJ as PP
-- import a few widely used operations without qualification
import Text.PrettyPrint.HughesPJ(Doc,text,int,(),(<+>),($$),($+$),render)
-----------------------------------------------
-- running parsers
-- Extract a computation from the Parser Monad
runMParser parser parserState name tokens =
runIdentity (runParserT parser parserState name tokens)
-- Skip whitespace before you begin
parse1 file x = runMParser (whiteSp>> x) initColumns file
-- Raise an Haskell error if a parsing error occurs
parseWithName file x s =
case parse1 file x s of
Right(ans) -> ans
Left message -> error (show message)
-- Parse with a default name for the input
parse2 x s = parseWithName "keyboard input" x s
-- Parse and return the internal state
parse3 p s = putStrLn (show state)>> return object
where (object,state) = parse2 (do { x <- p; st <- getState; return(x,st)}) s -- Parse an t-object, return -- (t,rest-of-input-not-parsed) parse4 p s = parse2 (do { x <- p ; rest <- getInput ; return (x,rest)}) s -- Parse a string in an arbitray monad parseString x s = case parse1 s x s of Right(ans) -> return ans
Left message -> fail (show message)
-- Parse a File in the IO monad
parseFile parser file =
do possible <- Control.Exception.try (readFile file) case possible of Right contents -> return(parse4 parser contents)
{-
case parse1 file parser contents of
(Right ans,more) -> return (ans,more)
(Left message,more) -> error(show message)
-}
Left err -> error(show (err::IOError))
--------------------------------------------
-- A parser with internal state of a list of columns
-- use (updateState,setState,getState) to access the [Column]
-- for debugging only
traceP p = do { ((c,vs),_) <- getState; ans <- p; ((d,us),_) <- getState ; trace ("In "++show c++"\nOut "++show d) (return ans)} initColumns = [] type MParser a = ParsecT String -- The input is a sequence of Char [Column] -- The internal state for Layout tabs (Identity) -- The underlying monad is simple a -- the type of the object being parsed -- Based on Parsec's haskellStyle (which we can not use directly since -- Parsec gives it a too specific type). lbStyle = Token.LanguageDef { Token.commentStart = "{-" , Token.commentEnd = "-}" , Token.commentLine = "--" , Token.nestedComments = True , Token.identStart = lower , Token.identLetter = alphaNum <|> oneOf "_'"
, Token.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
, Token.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
, Token.caseSensitive = True
, Token.reservedOpNames =
["!","?","\\",":",".", "<", "=", "+", "-", "^", "()", "_", "@"] , Token.reservedNames = ["if","then","else","case","of","let","in"] } (haskellTP,Token.LayFun layout) = Token.makeTokenParser lbStyle "{" ";" "}" lexemE p = Token.lexeme haskellTP p arrow = lexemE(string "->")
larrow = lexemE(string "<-") dot = lexemE(char '.') parenS p = between (symboL "(") (symboL ")") p braceS p = between (symboL "{") (symboL "}") p bracketS p = between (symboL "[") (symboL "]") p symboL = Token.symbol haskellTP natural = lexemE(number 10 digit) whiteSp = Token.whiteSpace haskellTP idenT = Token.identifier haskellTP keyworD = Token.reserved haskellTP commA = Token.comma haskellTP resOp = Token.reservedOp haskellTP opeR = Token.operator haskellTP character c = lexemE(char c) --------------------------------------------------------------- number :: Integer -> MParser Char -> MParser Integer
number base baseDigit
= do{ digits <- many1 baseDigit ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
; seq n (return n)
}
signed p = do { f <- sign; n <- p ; return(f n)} where sign = (character '-'>> return (* (-1))) <|>
(character '+'>> return id) <|>
(return id)
int32:: MParser Int
int32 = do { n <- signed natural; return(fromInteger n)} ""
float32:: MParser Float
float32 = do { n <- Token.float haskellTP ; return(double2Float n)} ""
letParser declP expP =
do { pos <- getPosition -- This gets the SourcePos ; keyworD "let" ; ds <- layout declP (keyworD "in") ; exp <- expP ; return(ds,exp)} -------------------------------------------------- data Paragraph = Simple [String] (Maybe [Paragraph]) deriving Show wordChar = lower <|> upper <|> oneOf ".;,'?"
word = many1 wordChar
sentence = many (lexemE word)
paragraphP = do { s <- sentence ; zs <- (do { symboL "#" ; ps <- layout paragraphP (return ()) ; return(Just ps)}) <|> (return Nothing)
; return(Simple s zs)}
main =
do { (pp,x) <- parseFile paragraphP "paragraphs.txt" ; print pp ; print x } --