parsimony (empty) → 1
raw patch · 12 files changed
+1234/−0 lines, 12 filesdep +basedep +bytestringdep +utf8-stringsetup-changed
Dependencies added: base, bytestring, utf8-string
Files
- LICENSE +22/−0
- Setup.hs +6/−0
- parsimony.cabal +45/−0
- src/Parsimony.hs +63/−0
- src/Parsimony/Char.hs +74/−0
- src/Parsimony/Combinator.hs +165/−0
- src/Parsimony/Error.hs +163/−0
- src/Parsimony/IO.hs +113/−0
- src/Parsimony/Pos.hs +93/−0
- src/Parsimony/Prim.hs +280/−0
- src/Parsimony/Stream.hs +127/−0
- src/Parsimony/UserState.hs +83/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright 1999-2000, Daan Leijen. All rights reserved.+Copyright 2009, Iavor S. Diatchki. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.+* Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++This software is provided by the copyright holders "as is" and any express or+implied warranties, including, but not limited to, the implied warranties of+merchantability and fitness for a particular purpose are disclaimed. In no+event shall the copyright holders be liable for any direct, indirect,+incidental, special, exemplary, or consequential damages (including, but not+limited to, procurement of substitute goods or services; loss of use, data,+or profits; or business interruption) however caused and on any theory of+liability, whether in contract, strict liability, or tort (including+negligence or otherwise) arising in any way out of the use of this software,+even if advised of the possibility of such damage.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ parsimony.cabal view
@@ -0,0 +1,45 @@+name: parsimony+version: 1+license: BSD3+license-file: LICENSE+author: Daan Leijen <daan@cs.uu.nl>, Iavor S. Diatchki <iavor.diatchki@gmail.com>+maintainer: iavor.diatchki@gmail.com+++category: Parsing+synopsis: Monadic parser combinators derived from Parsec+description:+ Parsimony is a generalized and simplified version of the+ industrial-strength parser combinator library Parsec.+ Like Parsec, it is simple, safe, well documented, convenient, + with good error messages, and fast. In addition, Parsimony+ adds support for working with differet types of input such as+ byte strings (for compact input representation) and+ lazy byte strings (for parsing large amounts of data).+ It also supports working with text in different character+ encodings such as UTF8.++cabal-version: >= 1.2+build-type: Simple++library+ hs-source-dirs:+ src+ exposed-modules:+ Parsimony+ Parsimony.Char+ Parsimony.Error+ Parsimony.IO+ Parsimony.Pos+ Parsimony.Stream+ Parsimony.UserState+ other-modules:+ Parsimony.Combinator+ Parsimony.Prim+ build-depends:+ base >= 3 && < 5,+ bytestring,+ utf8-string+ GHC-options: -O2 -Wall++
+ src/Parsimony.hs view
@@ -0,0 +1,63 @@+-----------------------------------------------------------------------------+-- |+-- Module : Parsimony+-- Copyright : (c) Iavor S. Diatchki 2009+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+--+-- The basics of the Parsimony library.+--+-----------------------------------------------------------------------------++module Parsimony+ ( -- * Basic Types+ Parser++ -- * Applying Parsers+ , parse, parseSource, runParser++ -- * Choices+ , (<|>), try, choice++ -- * Repetition+ , many, many1, skipMany1, match+ , sepBy, sepBy1+ , endBy, endBy1+ , sepEndBy, sepEndBy1+ , manyTill+ , count+ , foldMany++ -- * Optoinal content+ , option, optional++ -- * Delimeters and Combinators+ , (<*>), (<*), (*>), (<$>), (<$), pure+ , between, skip, eof++ -- * Look Ahead+ , notFollowedBy, notFollowedBy'+ , lookAhead, anyToken++ -- * Errors+ , (<?>), unexpected, empty, parseError, labels ++ -- * Parser State+ , State(..)+ , setState, updateState, mapState+ , getInput, setInput, updateInput+ , getPosition, setPosition, updatePosition+++ -- * Primitive Parsers+ , PrimParser+ , Reply(..)+ , primParser+ ) where++import Control.Applicative hiding(many)+import Parsimony.Prim+import Parsimony.Combinator+
+ src/Parsimony/Char.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : Parsimony.Char+-- Copyright : (c) Daan Leijen 1999-2001, (c) Iavor S. Diatchki 2009+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+--+-- Commonly used character parsers.+--+-----------------------------------------------------------------------------++module Parsimony.Char+ ( spaces, space+ , newline, tab+ , upper, lower, alphaNum, letter+ , digit, hexDigit, octDigit+ , char, string+ , anyChar, oneOf, noneOf+ , satisfy+ ) where++import Data.Char+import Parsimony.Prim+import Parsimony.Combinator+import Parsimony.Stream+++-----------------------------------------------------------+-- Character parsers+-----------------------------------------------------------+oneOf, noneOf :: Stream s Char => [Char] -> Parser s Char+oneOf cs = satisfy (\c -> elem c cs)+noneOf cs = satisfy (\c -> not (elem c cs))++spaces :: Stream s Char => Parser s ()+spaces = skipMany space <?> "white space"++space, newline, tab :: Stream s Char => Parser s Char+space = satisfy (isSpace) <?> "space"+newline = char '\n' <?> "new-line"+tab = char '\t' <?> "tab"++upper, lower, alphaNum, letter, digit, hexDigit, octDigit+ :: Stream s Char => Parser s Char+upper = satisfy (isUpper) <?> "uppercase letter"+lower = satisfy (isLower) <?> "lowercase letter"+alphaNum = satisfy (isAlphaNum) <?> "letter or digit"+letter = satisfy (isAlpha) <?> "letter"+digit = satisfy (isDigit) <?> "digit"+hexDigit = satisfy (isHexDigit) <?> "hexadecimal digit"+octDigit = satisfy (isOctDigit) <?> "octal digit"++char :: Stream s Char => Char -> Parser s Char+char c = satisfy (==c) <?> show [c]++anyChar :: Stream s Char => Parser s Char+anyChar = anyToken <?> "a character"++satisfy :: Stream s Char => (Char -> Bool) -> Parser s Char+satisfy f = try $ anyChar >>= \c ->+ if f c then return c+ else unexpected (show c)++string :: Stream s Char => String -> Parser s String+string [] = return []+string s@(c:cs) = try (char c) >> match show cs anyChar >> return s++++
+ src/Parsimony/Combinator.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- Module : Parsimony.Combinator+-- Copyright : (c) Daan Leijen 1999-2001, (c) Iavor S. Diatchki 2009+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+--+-- Commonly used generic combinators+--+-----------------------------------------------------------------------------++module Parsimony.Combinator where++import Parsimony.Prim+import Parsimony.Error+import Parsimony.Pos+import Parsimony.Stream+import Control.Applicative hiding (many)+++-- | The resulting parser behaves like one of the parsers in the list.+-- The chosen parser is the first one that (i) consumes some input,+-- or (ii) succeeds with a result.+choice :: [Parser t a] -> Parser t a+choice ps = foldr (<|>) empty ps++-- | Behaves like the parameter parser, unless it fails without consuming+-- any input. In that case we succeed with the given value.+option :: a -> Parser t a -> Parser t a+option x p = p <|> pure x++skip :: Parser t a -> Parser t ()+skip p = (p *> pure ()) <|> return ()++between :: Parser t open -> Parser t close+ -> Parser t a -> Parser t a+between o c p = o *> p <* c++-- | Skip at leats one occurance of input recognized by the parser.+skipMany1 :: Parser t a -> Parser t ()+skipMany1 p = p *> skipMany p++-- | Apply a parser repeatedly, and collect the results in a list.+many :: Parser t a -> Parser t [a]+many p = reverse <$> foldMany (flip (:)) [] p++-- | Apply a parser repeatedly, and collect the results in a list.+-- The resulting list is guaranteed to be at leats of length one.+many1 :: Parser t a -> Parser t [a]+many1 p = (:) <$> p <*> many p++sepBy :: Parser t a -> Parser t sep -> Parser t [a]+sepBy p sep = option [] (sepBy1 p sep)++sepBy1 :: Parser t a -> Parser t sep -> Parser t [a]+sepBy1 p sep = (:) <$> p <*> many (sep *> p)++endBy1,endBy :: Parser t a -> Parser t sep -> Parser t [a]+endBy1 p sep = many1 (p <* sep)+endBy p sep = many (p <* sep)++sepEndBy :: Parser t a -> Parser t sep -> Parser t [a]+sepEndBy p sep = option [] (sepEndBy1 p sep)++sepEndBy1 :: Parser t a -> Parser t sep -> Parser t [a]+sepEndBy1 p sep = sepBy1 p sep <* optional sep++-- directly recursive+count :: Int -> Parser t a -> Parser t [a]+count n p = sequence (replicate n p)+++--------------------------------------------------------------------------------++-- | Matches any token. Fails if there are no more tokens left.+anyToken :: Stream s t => Parser s t+anyToken = primParser getToken++-- | Matches the end of the input (i.e., when there are no more tokens+-- to extract).+eof :: Stream s t => Parser s ()+eof = notFollowedBy' showToken anyToken <?> "end of input"++-- | Succeeds if the given parser fails. The function is used+-- to display the result in error messages.+notFollowedBy' :: (a -> String) -> Parser t a -> Parser t ()+notFollowedBy' sh p = skip (try p >>= unexpected . sh)++-- | Succeeds if the given parser fails.+-- Uses the 'Show' instance of the result type in error messages.+notFollowedBy :: Show a => Parser t a -> Parser t ()+notFollowedBy = notFollowedBy' show++-- | Parse a list of values recognized by the given parser.+-- The sequence of values should be terminated by a pattern recognized+-- by the terminator patser.+-- The terminator is tried before the value pattern, so if there+-- is overlap between the two, the terminator is recognized.+manyTill :: Parser t a -> Parser t end -> Parser t [a]+manyTill p end = scan+ where scan = (end *> return []) <|> ((:) <$> p <*> scan)++getInput :: Parser t t+getInput = stateInput <$> getState++setInput :: t -> Parser t ()+setInput i = updateState (\s -> s { stateInput = i })++updateInput :: (t -> t) -> Parser t ()+updateInput f = updateState (\s -> s { stateInput = f (stateInput s) })++getPosition :: Parser t SourcePos+getPosition = statePos <$> getState++setPosition :: SourcePos -> Parser t ()+setPosition i = updateState (\s -> s { statePos = i })++updatePosition :: (SourcePos -> SourcePos) -> Parser t ()+updatePosition f = updateState (\s -> s { statePos = f (statePos s)})++setState :: State t -> Parser t ()+setState s = updateState (\_ -> s)+++++infix 0 <?>++-- | Specify the name to be used if the given parser fails.+(<?>) :: Parser t a -> String -> Parser t a+p <?> l = labels p [l]++++unexpected :: String -> Parser t a+unexpected x = parseError $ newErrorMessage $ UnExpect x+++++-- | Apply a parser to the given named input.+parseSource :: Parser t a -- ^ The parser to apply+ -> SourceName -- ^ A name for the input (used in errors)+ -> t -- ^ The input+ -> Either ParseError a++parseSource p s i = case runParser p $ State i $ initialPos s of+ Error err -> Left err+ Ok a _ -> Right a++-- | Apply a parser to the given input.+parse :: Parser t a -- ^ The parser to apply+ -> t -- ^ The input+ -> Either ParseError a++parse p = parseSource p ""+++++++
+ src/Parsimony/Error.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module : Parsimony.Error+-- Copyright : (c) Daan Leijen 1999-2001+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Parse errors+--+-----------------------------------------------------------------------------++module Parsimony.Error+ ( Message(SysUnExpect,UnExpect,Expect,Message)+ , messageString, messageCompare, messageEq++ , ParseError, errorPos, errorMessages, errorIsUnknown+ , showErrorMessages++ , newErrorMessage, newErrorUnknown+ , addErrorMessage, setErrorPos, setErrorMessage+ , mergeError+ )+ where+++import Parsimony.Pos+import Data.List (nub,sortBy)++-----------------------------------------------------------+-- Messages+-----------------------------------------------------------+data Message = SysUnExpect !String --library generated unexpect+ | UnExpect !String --unexpected something+ | Expect !String --expecting something+ | Message !String --raw message++messageToEnum :: Message -> Int+messageToEnum msg+ = case msg of SysUnExpect _ -> 0+ UnExpect _ -> 1+ Expect _ -> 2+ Message _ -> 3++messageCompare :: Message -> Message -> Ordering+messageCompare msg1 msg2+ = compare (messageToEnum msg1) (messageToEnum msg2)++messageString :: Message -> String+messageString msg+ = case msg of SysUnExpect s -> s+ UnExpect s -> s+ Expect s -> s+ Message s -> s++messageEq :: Message -> Message -> Bool+messageEq msg1 msg2+ = (messageCompare msg1 msg2 == EQ)+++-----------------------------------------------------------+-- Parse Errors+-----------------------------------------------------------+data ParseError = ParseError !SourcePos [Message]++errorPos :: ParseError -> SourcePos+errorPos (ParseError pos _) = pos++errorMessages :: ParseError -> [Message]+errorMessages (ParseError _ msgs)+ = sortBy messageCompare msgs++errorIsUnknown :: ParseError -> Bool+errorIsUnknown (ParseError _ msgs)+ = null msgs+++-----------------------------------------------------------+-- Create parse errors+-----------------------------------------------------------+newErrorUnknown :: SourcePos -> ParseError+newErrorUnknown pos+ = ParseError pos []++newErrorMessage :: Message -> SourcePos -> ParseError+newErrorMessage msg pos+ = ParseError pos [msg]++addErrorMessage :: Message -> ParseError -> ParseError+addErrorMessage msg (ParseError pos msgs)+ = ParseError pos (msg:msgs)++setErrorPos :: SourcePos -> ParseError -> ParseError+setErrorPos pos (ParseError _ msgs)+ = ParseError pos msgs++setErrorMessage :: Message -> ParseError -> ParseError+setErrorMessage msg (ParseError pos msgs)+ = ParseError pos (msg:filter (not . messageEq msg) msgs)+++mergeError :: ParseError -> ParseError -> ParseError+mergeError (ParseError pos msgs1) (ParseError _ msgs2)+ = ParseError pos (msgs1 ++ msgs2)++++-----------------------------------------------------------+-- Show Parse Errors+-----------------------------------------------------------+instance Show ParseError where+ show err+ = show (errorPos err) ++ ":" +++ showErrorMessages "or" "unknown parse error"+ "expecting" "unexpected" "end of input"+ (errorMessages err)+++-- | Language independent show function+showErrorMessages ::+ String -> String -> String -> String -> String -> [Message] -> String+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs+ | null msgs = msgUnknown+ | otherwise = concat $ map ("\n"++) $ clean $+ [showSysUnExpect,showUnExpect,showExpect,showMessages]+ where+ (sysUnExpect,msgs1) = span (messageEq (SysUnExpect "")) msgs+ (unExpect,msgs2) = span (messageEq (UnExpect "")) msgs1+ (expect,messages) = span (messageEq (Expect "")) msgs2++ showExpect = showMany msgExpecting expect+ showUnExpect = showMany msgUnExpected unExpect+ showSysUnExpect+ | not (null unExpect) || null sysUnExpect = ""+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput+ | otherwise = msgUnExpected ++ " " ++ firstMsg+ where+ firstMsg = messageString (head sysUnExpect)++ showMessages = showMany "" messages+++ --helpers+ showMany pre ms = case clean (map messageString ms) of+ [] -> ""+ cms | null pre -> commasOr cms+ | otherwise -> pre ++ " " ++ commasOr cms++ commasOr [] = ""+ commasOr [m] = m+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms++ commaSep = seperate ", " . clean+ -- semiSep = seperate "; " . clean++ seperate _ [] = ""+ seperate _ [m] = m+ seperate sep (m:ms) = m ++ sep ++ seperate sep ms++ clean = nub . filter (not.null)+
+ src/Parsimony/IO.hs view
@@ -0,0 +1,113 @@+----------------------------------------------------------------------------- +-- | +-- Module : Parsimony.IO +-- Copyright : (c) Iavor S. Diatchki 2009 +-- License : BSD3 +-- +-- Maintainer : iavor.diatchki@gmail.com +-- Stability : provisional +-- +-- Utilities for parsing content from files. +-- +----------------------------------------------------------------------------- + +module Parsimony.IO + ( parseFileASCII + , parseFileUTF8 + , parseLargeFileASCII + , parseLargeFileUTF8 + + , uparseFileASCII + , uparseFileUTF8 + , uparseLargeFileASCII + , uparseLargeFileUTF8 + ) where + +import Parsimony.Prim +import Parsimony.Error +import Parsimony.Stream +import Parsimony.Combinator +import Parsimony.UserState + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +-- | Parse a file containing ASCII encoded characters. +-- This functions loads the whole file in memory. +parseFileASCII :: FilePath + -> Parser (ASCII Strict.ByteString) a + -> IO (Either ParseError a) +parseFileASCII f p = + do bytes <- Strict.readFile f + return $ parseSource p f $ ascii bytes + +-- | Parse a file containing UTF8 encoded characters. +-- This functions loads the whole file in memory. +parseFileUTF8 :: FilePath + -> Parser (UTF8 Strict.ByteString) a + -> IO (Either ParseError a) +parseFileUTF8 f p = + do bytes <- Strict.readFile f + return $ parseSource p f $ utf8 bytes + +-- | Parse a file containing ASCII encoded characters. +-- This functions loads the file in chunks. +parseLargeFileASCII :: FilePath + -> Parser (ASCII Lazy.ByteString) a + -> IO (Either ParseError a) +parseLargeFileASCII f p = + do bytes <- Lazy.readFile f + return $ parseSource p f $ ascii bytes + +-- | Parse a file containing UTF8 encoded characters. +-- This functions loads the file in chunks. +parseLargeFileUTF8 :: FilePath + -> Parser (UTF8 Lazy.ByteString) a + -> IO (Either ParseError a) +parseLargeFileUTF8 f p = + do bytes <- Lazy.readFile f + return $ parseSource p f $ utf8 bytes + +-- With user state ------------------------------------------------------------- + +-- | Parse a file containing ASCII encoded characters, +-- using a parser with custom user state. +-- This functions loads the whole file in memory. +uparseFileASCII :: FilePath + -> ParserU u (ASCII Strict.ByteString) a + -> u -> IO (Either ParseError a) +uparseFileASCII f p u = + do bytes <- Strict.readFile f + return $ uparseSource p u f $ ascii bytes + +-- | Parse a file containing UTF8 encoded characters, +-- using a parser with custom user state. +-- This functions loads the whole file in memory. +uparseFileUTF8 :: FilePath + -> ParserU u (UTF8 Strict.ByteString) a + -> u -> IO (Either ParseError a) +uparseFileUTF8 f p u = + do bytes <- Strict.readFile f + return $ uparseSource p u f $ utf8 bytes + +-- | Parse a file containing ASCII encoded characters, +-- using a parser with custom user state. +-- This functions loads the file in chunks. +uparseLargeFileASCII :: FilePath + -> ParserU u (ASCII Lazy.ByteString) a + -> u -> IO (Either ParseError a) +uparseLargeFileASCII f p u = + do bytes <- Lazy.readFile f + return $ uparseSource p u f $ ascii bytes + +-- | Parse a file containing UTF8 encoded characters, +-- using a parser with custom user state. +-- This functions loads the file in chunks. +uparseLargeFileUTF8 :: FilePath + -> ParserU u (UTF8 Lazy.ByteString) a + -> u -> IO (Either ParseError a) +uparseLargeFileUTF8 f p u = + do bytes <- Lazy.readFile f + return $ uparseSource p u f $ utf8 bytes + +
+ src/Parsimony/Pos.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module : Parsimony.Pos+-- Copyright : (c) Daan Leijen 1999-2001+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Textual source positions.+--+-----------------------------------------------------------------------------++module Parsimony.Pos+ ( SourceName, Line, Column+ , SourcePos+ , sourceLine, sourceColumn, sourceName+ , incSourceLine, incSourceColumn+ , setSourceLine, setSourceColumn, setSourceName+ , newPos, initialPos+ , updatePosChar, updatePosString+ ) where++-----------------------------------------------------------+-- Source Positions, a file name, a line and a column.+-- upper left is (1,1)+-----------------------------------------------------------+type SourceName = String+type Line = Int+type Column = Int++data SourcePos = SourcePos { sourceName :: SourceName+ , sourceLine :: !Line+ , sourceColumn :: !Column+ }+ deriving (Eq,Ord)++newPos :: SourceName -> Line -> Column -> SourcePos+newPos name line column = SourcePos { sourceName = name+ , sourceLine = line+ , sourceColumn = column+ }++initialPos :: SourceName -> SourcePos+initialPos name = newPos name 1 1++incSourceLine :: SourcePos -> Line -> SourcePos+incSourceLine p n = setSourceLine p (n + sourceLine p)++incSourceColumn :: SourcePos -> Column -> SourcePos+incSourceColumn p n = setSourceColumn p (n + sourceColumn p)++setSourceName :: SourcePos -> SourceName -> SourcePos+setSourceName p n = p { sourceName = n }++setSourceLine :: SourcePos -> Line -> SourcePos+setSourceLine p n = p { sourceLine = n }++setSourceColumn :: SourcePos -> Column -> SourcePos+setSourceColumn p n = p { sourceColumn = n }++-----------------------------------------------------------+-- Update source positions on characters+-----------------------------------------------------------+updatePosString :: SourcePos -> String -> SourcePos+updatePosString pos string+ = forcePos (foldl updatePosChar pos string)++updatePosChar :: SourcePos -> Char -> SourcePos+updatePosChar p c+ = forcePos $+ case c of+ '\n' -> incSourceLine p 1+ '\t' -> incSourceColumn p (8 - ((sourceColumn p - 1) `mod` 8))+ _ -> incSourceColumn p 1+++forcePos :: SourcePos -> SourcePos+forcePos pos@(SourcePos _ line column)+ = seq line (seq column (pos))++-----------------------------------------------------------+-- Show positions+-----------------------------------------------------------+instance Show SourcePos where+ show (SourcePos name line column)+ | null name = showLineColumn+ | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn+ where+ showLineColumn = "(line " ++ show line +++ ", column " ++ show column +++ ")"
+ src/Parsimony/Prim.hs view
@@ -0,0 +1,280 @@+-----------------------------------------------------------------------------+-- |+-- Module : Parsimony.Prim+-- Copyright : (c) Daan Leijen 1999-2001, (c) Iavor S. Diatchki 2009+-- License : BSD3+--+-- Maintainer : iavor.diatchki@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- The primitive parser combinators.+--+-----------------------------------------------------------------------------++module Parsimony.Prim+ ( Parser, PrimParser, Reply(..)+ , runParser, primParser+ , parseError, try, lookAhead, labels+ , foldMany, skipMany, match+ , State(..), getState, updateState, mapState+ ) where++import Parsimony.Pos+import Parsimony.Error+import Control.Applicative(Applicative(..),Alternative(..))+import Control.Monad(liftM,ap,MonadPlus(..))+++-- | A parser constructing values of type 'a', with an input+-- buffer of type 't'.+data Parser t a = P { unP :: State t -> R t a }++-- NOTE: The order of the fields is important!+-- In the rest of the module we use the fact that pattern matching+-- happens left to right to ensure that if matching on the 'Bool'+-- fails, then we will not look at the 'Either' field.+data R s a = R !Bool (Reply s a)++data Reply s a = Ok !a !(State s)+ | Error !ParseError+++-- | The parser state.+data State t = State { stateInput :: !t -- ^ Token source+ , statePos :: !SourcePos -- ^ Current position+ }++type PrimParser s a = State s -> Reply s a++-- | Define a primitive parser.+-- Consumes input on success.+{-# INLINE primParser #-}+primParser :: PrimParser t a -> Parser t a+primParser prim = P $ \s -> case prim s of+ r@(Error _) -> R False r+ r -> R True r+++{-# INLINE runParser #-}+-- | Convert a parser into a 'PrimParser'.+runParser :: Parser t a -> PrimParser t a+runParser p s = case unP p s of+ R _ x -> x++-- | Access the current parser state.+-- Does not consume input.+{-# INLINE getState #-}+getState :: Parser t (State t)+getState = P $ \s -> R False (Ok s s)++-- | Modify the current parser state.+-- Returns the old state.+-- Does not consume input.+{-# INLINE updateState #-}+updateState :: (State s -> State s) -> Parser s ()+updateState f = P $ \s -> R False $! Ok () (f s)++-- | Change the input stream of a parser.+-- This is useful for extending the input stream with extra information.+-- The first function splits the extended state into a state+-- suitable for use by the given parser and some additional information.+-- The second function combines the extra infomration of the original+-- state with the new partial state, to compute a new extended state.+{-# INLINE mapState #-}+mapState :: (State big -> (State small,extra))+ -> (State small -> extra -> State big)+ -> Parser small a -> Parser big a+mapState extract inject p = P $ \big ->+ case extract big of+ (small,extra) ->+ case unP p small of+ -- XXX: strict+ R c r -> R c $ case r of+ Error err -> Error err+ Ok a small1 -> Ok a (inject small1 extra)++++-- | Fail with the given parser error without consuming any input.+-- The error is applied to the current source position.+{-# INLINE parseError #-}+parseError :: (SourcePos -> ParseError) -> Parser t a+parseError e = P $ \s -> R False $ Error $ e $ statePos s+++++-- | Allow a parser to back-track. The resulting parser behaves like+-- the input parser unless it fails. In that case, we backtrack+-- without consuming any input. Because we may have to back-track,+-- we keep a hold of the parser input so over-use of this function+-- may result in memory leaks.++{-# INLINE try #-}+try :: Parser t a -> Parser t a+try p = P $ \s ->+ case unP p s of+ R True (Error err) -> R False $ Error $ setErrorPos (statePos s) err+ other -> other+++-- | Applies the given parser without consuming any input.+{-# INLINE lookAhead #-}+lookAhead :: Parser t a -> Parser t a+lookAhead p = P $ \s ->+ R False $ case unP p s of+ R _ (Error err) -> Error err+ R _ (Ok a _) -> Ok a s++-- | The resulting parser behaves like the input parser,+-- except that in case of failure we use the given expectation+-- messages.+{-# INLINE labels #-}+labels :: Parser t a -> [String] -> Parser t a+labels p msgs0 = P $ \s ->+ case unP p s of+ R c r -> R c (addErr r)++ where setExpectErrors err [] = setErrorMessage (Expect "") err+ setExpectErrors err [msg] = setErrorMessage (Expect msg) err+ setExpectErrors err (msg:msgs) =+ foldr (\m e -> addErrorMessage (Expect m) e)+ (setErrorMessage (Expect msg) err) msgs++ addErr (Error e) = Error $ setExpectErrors e msgs0+ addErr r = r+++-- | Apply a parser repeatedly, combining the results with the+-- given functions. This function is similar to the strict 'foldl'.+-- We stop when an application of the parser fails without consuming any+-- input. If the parser fails after it has consumed some input, then+-- the repeated parser will also fail.++{-# INLINE foldMany #-}+foldMany :: (b -> a -> b) -> b -> Parser t a -> Parser t b+foldMany cons nil p = P (outer nil)+ where+ -- not consumed+ outer xs s =+ case unP p s of+ R False (Ok x s1) -> (outer $! cons xs x) s1+ R False (Error _) -> R False $ Ok xs s+ R True (Ok x s1) -> R True $ (inner $! cons xs x) s1+ R True (Error err) -> R True $ Error err++ -- consumed+ inner xs s =+ case unP p s of+ R _ (Ok x s1) -> (inner $! cons xs x) s1+ R False (Error _) -> Ok xs s+ R True (Error e) -> Error e+++-- | Apply a parser repeatedly, ignoring the results.+-- We stop when an application of the parser fails without consuming any+-- input. If the parser fails after it has consumed some input, then+-- the repeated parser will also fail.++{-# INLINE skipMany #-}+skipMany :: Parser t a -> Parser t ()+skipMany p = P outer+ -- pFold specialized for a common case++ -- NOTE: this is written like this because after the first iteration+ -- we already know weather the parser will be consuming input.+ where+ outer s =+ case unP p s of+ R False (Ok _ s1) -> outer s1+ R False (Error _) -> R False $ Ok () s+ R True (Ok _ s1) -> R True $ inner s1+ R True (Error err) -> R True $ Error err++ inner s =+ case unP p s of+ R _ (Ok _ s1) -> inner s1+ R False (Error _) -> Ok () s+ R True (Error e) -> Error e+++-- | Produces a parser that succeeds if it can extract the list of values+-- specified by the list.+-- The function argument specifies how to show the expectations in+-- error messages.+match :: (Eq a) => (a -> String) -> [a] -> Parser t a -> Parser t ()+match sh goal p = P (outer goal)++ where+ expected x = addErrorMessage (Expect (sh x))+ unexpected x pos = newErrorMessage (UnExpect (sh x)) pos++ -- not yet consumed+ outer [] s = R False $ Ok () s+ outer (x:xs) s =+ case unP (labels p [sh x]) s of+ R False (Ok a s1)+ | x == a -> outer xs s1+ | otherwise -> R False $ Error $ expected x $ unexpected a $ statePos s+ R False (Error e) -> R False $ Error e+ R True r -> R True $+ case r of+ Error e -> Error $ expected x e+ Ok a s1+ | x == a -> inner xs s1+ | otherwise -> Error $ expected x $ unexpected a $ statePos s++ -- we consumed something+ inner [] s = Ok () s+ inner (x:xs) s =+ case unP (labels p [sh x]) s of+ R _ (Ok a s1)+ | x == a -> inner xs s1+ | otherwise -> Error $ expected x $ unexpected a $ statePos s+ R _ (Error e) -> Error e++++-- Instances -------------------------------------------------------------------++instance Functor (Parser t) where+ fmap = liftM++instance Monad (Parser t) where+ return a = pure a+ p >>= f = P $ \s ->+ case unP p s of+ R True r -> R True $ case r of+ Error e -> Error e+ Ok a s1 ->+ case unP (f a) s1 of+ R _ r1 -> r1+ R False r -> case r of+ Error e -> R False $ Error e+ Ok a s1 -> unP (f a) s1++ fail m = parseError (newErrorMessage (Message m))++instance Applicative (Parser t) where+ pure a = P $ \s -> R False $ Ok a s+ (<*>) = ap++instance Alternative (Parser t) where+ empty = parseError newErrorUnknown+ p1 <|> p2 = P $ \s ->+ -- WARNING: It is important that we match the 'False' first+ -- because then we can quickly move to the second branch, without+ -- having to perform any actual parsing.+ case unP p1 s of+ R False (Error _) -> unP p2 s+ other -> other+++instance MonadPlus (Parser t) where+ mzero = empty+ mplus = (<|>)++++
+ src/Parsimony/Stream.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} -- Why? + +----------------------------------------------------------------------------- +-- | +-- Module : Parsimony.Char +-- Copyright : (c) Iavor S. Diatchki 2009 +-- License : BSD3 +-- +-- Maintainer : iavor.diatchki@gmail.com +-- Stability : provisional +-- +-- A generic way to extract tokens from a stream. +-- +----------------------------------------------------------------------------- + + + +module Parsimony.Stream + ( Token(..), Stream(..) + , ASCII, UTF8, ascii, utf8 + ) where + +import Parsimony.Prim +import Parsimony.Pos +import Parsimony.Error + +import qualified Data.ByteString as Strict (ByteString,uncons) +import qualified Data.ByteString.Lazy as Lazy (ByteString,uncons) +import Data.String.UTF8 (UTF8,UTF8Bytes,fromRep,replacement_char) +import qualified Data.String.UTF8 as UTF8 (uncons) +import Data.Word (Word8) +import Numeric (showHex) + +-- | A class describing useful token operations. +class Token token where + -- | How tokens affect file positions. + updatePos :: token -> SourcePos -> SourcePos + + -- | How to display tokens. + showToken :: token -> String + +instance Token Char where + updatePos c p = updatePosChar p c + showToken = show + +instance Token Word8 where + updatePos _ p = incSourceColumn p 1 + showToken b = "0x" ++ showHex b "" + + + + +-- We have the fun. dep. here because otherwise multiple +-- reads from a stream could give potentially different types of +-- tokens which leads to ambiguities. + +-- | Streams of tokens. +class Token token => Stream stream token | stream -> token where + getToken :: PrimParser stream token + +eof_err :: SourcePos -> Reply s a +eof_err p = Error $ newErrorMessage (UnExpect "end of input") p + +{-# INLINE genToken #-} +genToken :: Token t => (i -> Maybe (t,i)) -> PrimParser i t +genToken unc (State i p) = + case unc i of + Nothing -> eof_err p + Just (t,ts) -> Ok t State { stateInput = ts + , statePos = updatePos t p + } + +instance Token a => Stream [a] a where + getToken = genToken (\xs -> case xs of + [] -> Nothing + c : cs -> Just (c,cs)) + +instance Stream Strict.ByteString Word8 where + getToken = genToken Strict.uncons + +instance Stream Lazy.ByteString Word8 where + getToken = genToken Lazy.uncons + +-- Character encodings --------------------------------------------------------- + + +-- | The type of ASCII encoded content. +newtype ASCII content = ASCII content + +-- | Specify ASCII encoding for some content. +ascii :: content -> ASCII content +ascii = ASCII + +-- | Specify UTF8 encoding for some content. +utf8 :: content -> UTF8 content +utf8 = fromRep + +instance Stream a Word8 => Stream (ASCII a) Char where + getToken (State (ASCII buf) p) = + case getToken (State buf p) of + Error err -> Error err + Ok w (State b1 p1) -> Ok (toEnum (fromEnum w)) (State (ASCII b1) p1) + + +instance Stream (UTF8 [Word8]) Char where + getToken = genTokenChar + +instance Stream (UTF8 Strict.ByteString) Char where + getToken = genTokenChar + +instance Stream (UTF8 Lazy.ByteString) Char where + getToken = genTokenChar + + +{-# INLINE genTokenChar #-} +genTokenChar :: UTF8Bytes stream ix => PrimParser (UTF8 stream) Char +genTokenChar (State i p) = + case UTF8.uncons i of + Just (a,i1) + | a /= replacement_char -> Ok a (State i1 (updatePos a p)) + | otherwise -> Error $ newErrorMessage + (Message "invalid UTF8 character") p + Nothing -> eof_err p + +
+ src/Parsimony/UserState.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Why ??? + +----------------------------------------------------------------------------- +-- | +-- Module : Parsimony.UserState +-- Copyright : (c) Iavor S. Diatchki 2009 +-- License : BSD3 +-- +-- Maintainer : iavor.diatchki@gmail.com +-- Stability : provisional +-- +-- Support for parsers with custom state. +-- +----------------------------------------------------------------------------- + + + + +module Parsimony.UserState + ( ParserU, UserState(..) + , lifted + , getUserState, setUserState, updateUserState + , uparse, uparseSource + ) where + +import Parsimony.Prim +import Parsimony.Stream +import Parsimony.Pos +import Parsimony.Error +import Parsimony.Combinator + +-- NOTE: We could generalize this further by providing +-- a class that abstract over 'extract' and 'inject' + +-- | An input stream annotated with some user state. +data UserState user stream = UserState { userState :: !user + , parserStream :: !stream + } + +-- | The type of parsers with a user state. +type ParserU u s = Parser (UserState u s) + + +extract :: State (UserState u s) -> (State s, u) +extract s = (s { stateInput = xs }, u) + where UserState u xs = stateInput s + +inject :: State s -> u -> State (UserState u s) +inject s u = s { stateInput = UserState u (stateInput s) } + +instance Stream stream token => Stream (UserState user stream) token where + getToken s = + case extract s of + (s1,u) -> + case getToken s1 of + Error err -> Error err + Ok a s2 -> Ok a (inject s2 u) + +-- | Turn a parser without user space into ine that supports +-- user state manipulation. +lifted :: Parser s a -> ParserU u s a +lifted = mapState extract inject + +-- | Get the user state. +getUserState :: ParserU u s u +getUserState = userState `fmap` getInput + +-- | Set the user state. +setUserState :: u -> ParserU u s () +setUserState u = updateInput (\i -> i { userState = u }) + +-- | Update the user state. +updateUserState :: (u -> u) -> ParserU u s () +updateUserState f = updateInput (\i -> i { userState = f (userState i) }) + +uparse :: ParserU u s a -> u -> s -> Either ParseError a +uparse p u = uparseSource p u "" + +uparseSource :: ParserU u s a -> u -> SourceName -> s + -> Either ParseError a +uparseSource p u n s = parseSource p n (UserState u s) +