diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# 0.0 + +* Split `indentation` into separate `indentation-core`, `indentation-parsec` and `indentation-trifecta` packages. + Keep the original `indentation` for backward compatability and as a general roll-up package. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2014, Michael D. Adams +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this +list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its contributors +may be used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 HOLDER OR CONTRIBUTORS 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/indentation-parsec.cabal b/indentation-parsec.cabal new file mode 100644 --- /dev/null +++ b/indentation-parsec.cabal @@ -0,0 +1,70 @@ +name: indentation-parsec +version: 0.0 +synopsis: Indentation sensitive parsing combinators for Parsec +description: Indentation sensitive parsing combinators for Parsec + . + See + . + __Michael D. Adams and Ömer S. Ağacan__. + Indentation-sensitive parsing for Parsec. + In /Proceedings of the 2014 ACM SIGPLAN Symposium on Haskell/, + Haskell ’14, pages 121–132. + ACM, New York, NY, USA, September 2014. ISBN 978-1-4503-3041-1. + . + . + This package provides indentation combinators for + Parsec. For Trifecta, install + indentation-trifecta. For backward compatability + or to install both, install indentation. + + +license: BSD3 +license-file: LICENSE +author: Michael D. Adams +maintainer: Ömer Sinan Ağacan + Aleksey Kliger +category: Parsing +build-type: Simple +cabal-version: >=1.10 +extra-source-files: CHANGELOG.md + src/Text/Parsec/Indentation/Examples/*.hs + +homepage: https://bitbucket.org/adamsmd/indentation +bug-reports: https://bitbucket.org/adamsmd/indentation/issues +tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 + +source-repository head + type: git + location: https://bitbucket.org/adamsmd/indentation.git + +library + hs-source-dirs: src + build-depends: base >=4.6 && <4.10, + mtl >=2.1, + indentation-core == 0.0, + parsec >=3.1.5 + exposed-modules: Text.Parsec.Indentation + , Text.Parsec.Indentation.Char + , Text.Parsec.Indentation.Token + + default-language: Haskell2010 + + ghc-options: -Wall + +test-suite test-indentation + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: all-tests.hs + build-depends: + parsec + other-modules: + ParensParsec + build-depends: + base >= 4 && < 5 + , tasty >= 0.10 + , tasty-hunit >= 0.9 + , indentation-parsec diff --git a/src/Text/Parsec/Indentation.hs b/src/Text/Parsec/Indentation.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Indentation.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, TupleSections #-} +{-# OPTIONS -Wall #-} +module Text.Parsec.Indentation (module Text.Parsec.Indentation, I.IndentationRel(..), Indentation, infIndentation) where + +-- Implements "Indentation Senstivie Parising: Landin Revisited" +-- +-- Primary functions are: +-- - 'localIndent': +-- - 'absoluteIndent': +-- - 'localTokenMode': +-- +-- Primary driver functions are: +-- - TODO + +-- TODO: +-- Grace style indentation stream + +import Control.Monad +--import Text.Parsec.Prim +import Text.Parsec.Prim (ParsecT, mkPT, runParsecT, + Stream(..), Consumed(..), Reply(..), + State(..), getInput, setInput) +import Text.Parsec.Error (Message (Message), addErrorMessage) +import Text.Parser.Indentation.Implementation as I + +------------------------ +-- Indentable Stream +------------------------ + +data IndentStream s = IndentStream { indentationState :: !IndentationState, tokenStream :: !s } deriving (Show) +--data IndentationToken t = IndentationToken !t | InvalidIndentation String +type IndentationToken t = t + +{-# INLINE mkIndentStream #-} +mkIndentStream :: Indentation -> Indentation -> Bool -> IndentationRel -> s -> IndentStream s +mkIndentStream lo hi mode rel s = IndentStream (mkIndentationState lo hi mode rel) s + +instance (Monad m, Stream s m (t, Indentation)) => Stream (IndentStream s) m (IndentationToken t) where + uncons (IndentStream is s) = do + x <- uncons s + case x of + Nothing -> return Nothing + Just ((t, i), s') -> return $ updateIndentation is i ok err where + ok is' = Just ({-IndentationToken-} t, IndentStream is' s') + err _ = Nothing --(InvalidIndentation msg, IndentStream is s) + -- HACK: Sigh! We have no way to properly signal the + -- sort of failure that occurs here. We would do 'fail + -- "Invalid indentation. "++msg', but that triggers a + -- non-backtracking error. 'return Nothing' will make + -- Parsec think the stream is empty (which is wrong), + -- but at least it is a backtracking error. The + -- fundamental problem is that 'm' *not* ParsecT (where + -- we could signal a parsing error) but is whatever + -- monad 'm' happens to be the argument to ParsecT. + +{-# INLINE localState #-} +localState :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a) +localState pre post m = do + IndentStream is s <- getInput + setInput (IndentStream (pre is) s) + x <- m + IndentStream is' s' <- getInput + setInput (IndentStream (post is is') s') + return x + +{-# INLINE localStateUnlessAbsMode #-} +localStateUnlessAbsMode :: (Monad m) => LocalState (ParsecT (IndentStream s) u m a) +localStateUnlessAbsMode pre post m = do + a <- liftM (indentationStateAbsMode . indentationState) getInput + if a then m else localState pre post m + + +------------------------ +-- Operations +------------------------ + +{-# INLINE localTokenMode #-} +localTokenMode :: (Monad m) => (IndentationRel -> IndentationRel) -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +localTokenMode = I.localTokenMode localState + +{-# INLINE localIndentation #-} +localIndentation :: (Monad m) => IndentationRel -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +localIndentation = I.localIndentation localStateUnlessAbsMode + +{-# INLINE absoluteIndentation #-} +absoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +absoluteIndentation = I.absoluteIndentation localState +-- post _ i2 = when (absMode i2) (fail "absoluteIndent: no tokens consumed") >> + +{-# INLINE ignoreAbsoluteIndentation #-} +ignoreAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +ignoreAbsoluteIndentation = I.ignoreAbsoluteIndentation localState + +{-# INLINE localAbsoluteIndentation #-} +localAbsoluteIndentation :: (Monad m) => ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +localAbsoluteIndentation = I.localAbsoluteIndentation localState + +------------------------ +-- Indent Stream Impls +------------------------ + +streamToList :: (Monad m, Stream s m t) => s -> m [t] +streamToList s = do + x <- uncons s + case x of + Nothing -> return [] + Just (c, s') -> do s'' <- streamToList s' + return (c : s'') + +---------------- +-- SourcePos + +{- +mkSourcePosIndentStream s = SourcePosIndentStream s +newtype SourcePosIndentStream s = SourcePosIndentStream s +instance (Stream s m t) => Stream (SourcePosIndentStream s) m (Indent, t) where + uncons (SourcePosIndentStream s) = do + col <- liftM sourceColumn $ getPosition + x <- uncons s + case x of + Nothing -> return Nothing + Just x -> return (Just ((col, x), SourcePosIndentStream s)) +-} + + +---------------- +-- TODO: parser based on first non-whitespace char + +---------------- +-- First token of line indents + +---------------- +-- Based on Indents + +-- Note that if 'p' consumes input but is at the wrong indentation, then +-- 'indentStreamParser p' signals an error but does *not* consume input. +-- This allows Parsec primitives like 'string' to be properly backtracked. +{-# INLINE indentStreamParser #-} +indentStreamParser :: (Monad m) => ParsecT s u m (t, Indentation) -> ParsecT (IndentStream s) u m (IndentationToken t) +indentStreamParser p = mkPT $ \state -> + let IndentStream is s = stateInput state + go f (Ok (a, i) state' e) = updateIndentation is i ok err where + ok is' = return $ f $ return (Ok ({-IndentationToken-} a) (state' {stateInput = IndentStream is' (stateInput state') }) e) + err msg = return $ Empty $ return $ Error (Message ("Invalid indentation. "++msg++show ((stateInput state) { tokenStream = ""})) `addErrorMessage` e) + go f (Error e) = return $ f $ return (Error e) + in runParsecT p (state { stateInput = s }) >>= consumed (go Consumed) (go Empty) + +{-# INLINE consumed #-} +consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b +consumed c _ (Consumed m) = m >>= c +consumed _ e (Empty m) = m >>= e + +-- lifting operator +-- token, tokens, tokenPrim, tokenPrimEx ??? +-- whiteSpace +-- ByteString +-- ByteString.Lazy +-- Text + +{- +delimitedLayout :: Stream (IndentStream s) m t => + ParsecT (IndentStream s) u m open -> Bool -> + ParsecT (IndentStream s) u m close -> Bool -> + ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a +delimitedLayout open openAny close closeAny body = between open' close' (localIndent (Const 0) body) where + open' | openAny = localIndent (Const 0) open + | otherwise = open + close' | closeAny = localIndent (Const 0) close + | otherwise = close + +indentedLayout :: Stream (IndentStream s) m t => + (Maybe (ParsecT (IndentStream s) u m sep)) -> + ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m [a] +indentedLayout (Nothing ) clause = localIndent Gt $ many $ absoluteIndent $ clause +indentedLayout (Just sep) clause = liftM concat $ localIndent Gt $ many $ absoluteIndent $ sepBy1 clause sep +-} + +{- +layout p = delimitedLayout (symbol "{") False (symbol "}") True (semiSep p) + <|> indentedLayout (Just semi) p + +identifier pred = liftM fromString $ try $ identifier >>= \x -> guard (pred x) >> return x +operator pred = liftM fromString $ try $ operator >>= \x -> guard (pred x) >> return x + +reserved name = (if name `elem` middleKeywords then localFirstTokenMode (const Ge) else id) $ reserved name + +Numbers, Integers and Naturals are custom + +dotSep +dotSep1 + +-} + +{- +test :: String +test = foo where + foo = "abc \ +\def" ++ "" + +test2 :: Int +test2 = foo where + foo = let { x = 1; + } in x + + +--- All code indented? + foo = 3 + bar = 4 +-} diff --git a/src/Text/Parsec/Indentation/Char.hs b/src/Text/Parsec/Indentation/Char.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Indentation/Char.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-} +module Text.Parsec.Indentation.Char where + +import Text.Parsec.Prim (ParsecT, mkPT, runParsecT, + Stream(..), + Consumed(..), Reply(..), + State(..)) +import Text.Parsec.Pos (sourceColumn) +import Text.Parser.Indentation.Implementation (Indentation) + +---------------- +-- Unicode char +-- newtype UnicodeIndentStream + +---------------- +-- Based on Char +{-# INLINE mkCharIndentStream #-} +mkCharIndentStream :: s -> CharIndentStream s +mkCharIndentStream s = CharIndentStream 1 s +data CharIndentStream s = CharIndentStream { charIndentStreamColumn :: {-# UNPACK #-} !Indentation, + charIndentStreamStream :: !s } deriving (Show) + +instance (Stream s m Char) => Stream (CharIndentStream s) m (Char, Indentation) where + uncons (CharIndentStream i s) = do + x <- uncons s + case x of + Nothing -> return Nothing + Just (c, cs) -> return (Just ((c, i), CharIndentStream (updateColumn i c) cs)) + +{-# INLINE updateColumn #-} +updateColumn :: Integral a => a -> Char -> a +updateColumn _ '\n' = 1 +updateColumn i '\t' = i + 8 - ((i-1) `mod` 8) +updateColumn i _ = i + 1 + +{-# INLINE charIndentStreamParser #-} +charIndentStreamParser :: (Monad m) => ParsecT s u m t -> ParsecT (CharIndentStream s) u m (t, Indentation) +charIndentStreamParser p = mkPT $ \state -> + let go (Ok a state' e) = return (Ok (a, sourceColumn $ statePos state) (state' { stateInput = CharIndentStream (sourceColumn $ statePos state') (stateInput state') }) e) + go (Error e) = return (Error e) + in runParsecT p (state { stateInput = charIndentStreamStream (stateInput state) }) + >>= consumed (return . Consumed . go) (return . Empty . go) + +{-# INLINE consumed #-} +consumed :: (Monad m) => (a -> m b) -> (a -> m b) -> Consumed (m a) -> m b +consumed c _ (Consumed m) = m >>= c +consumed _ e (Empty m) = m >>= e diff --git a/src/Text/Parsec/Indentation/Examples/ISWIM.hs b/src/Text/Parsec/Indentation/Examples/ISWIM.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Indentation/Examples/ISWIM.hs @@ -0,0 +1,61 @@ +module Text.Parsec.Indentation.Examples.ISWIM where + +-- Encodes example TODO from the paper TODO. +-- Note that because Parsec doesn't support full backtracking +-- this +-- + +import Control.Applicative ((<$>)) +import Text.Parsec +import Text.Parsec.Indentation +import Text.Parsec.Indentation.Char + +data ID = ID String deriving (Show, Eq) +data Expr + = Where Expr ID Expr -- expr -> expr 'where' ID '=' |expr|>= + | Plus Expr Expr -- expr -> expr '+' expr + | Minus Expr -- expr -> '-' expr + | Parens Expr -- expr -> '(' expr* ')' + | Var ID -- expr -> ID + deriving (Show, Eq) + +runParse :: String -> Either ParseError Expr +runParse input + = case runParser expr () "" (mkIndentStream 0 infIndentation True Ge (mkCharIndentStream input)) of + Left err -> Left err + Right a -> Right a + +-- Note that this grammar DOES NOT WORK as written because it contains +-- a left recursion. (It diverges.) However, it provides a good +-- first example to see how to use the combinators in +-- Text.Parsec.Indentation. + +tok s = string s >> localTokenMode (const Any) (ignoreAbsoluteIndentation (many (char ' ' <|> char '\n'))) +ident = choice (map f ["v", "w", "x", "y", "z"]) + where f x = tok x >> return (ID x) + +expr = choice $ map try + [ do e1 <- expr_nonrec + tok "where" + i <- ident + tok "=" + e2 <- localIndentation Ge (absoluteIndentation expr) + return (Where e1 i e2) + , do e1 <- expr_nonrec + tok "+" + e2 <- expr + return (Plus e1 e2) + , expr_nonrec + ] + +expr_nonrec = choice + [ tok "-" >> (Minus <$> expr) + , Parens <$> between (tok "(") (tok ")") (localIndentation Any expr) + , Var <$> ident + ] + + +input1 = "x + v where\n\ + \ x = -(\n\ + \y + z) + w" +output1 = runParse input1 diff --git a/src/Text/Parsec/Indentation/Examples/Parens.hs b/src/Text/Parsec/Indentation/Examples/Parens.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Indentation/Examples/Parens.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} +module Text.Parsec.Indentation.Examples.Parens where + +-- Encodes example TODO from the paper TODO. +-- Note that because Parsec doesn't support full backtracking +-- this + +import Control.Applicative +import Text.Parsec +import Text.Parsec.Indentation + +data A + = Par A -- '(' A ')' + | Bra A -- '[' A ']' + | Seq A A -- A A + | Nil -- epsilon + deriving (Show, Eq) + +a :: (Monad m, Stream s m (Char, Indentation)) => ParsecT (IndentStream s) () m A +a = choice [ Seq <$> a' <*> a, a', return Nil ] + +a' :: (Monad m, Stream s m (Char, Indentation)) => ParsecT (IndentStream s) () m A +a' = choice + [ Par <$> + between (localTokenMode (const Eq) $ char '(') + (localTokenMode (const Eq) $ char ')') + (localIndentation Gt a) + , Bra <$> + between (localTokenMode (const Ge) $ char '[') + (localTokenMode (const Ge) $ char ']') + (localIndentation Gt a) + ] + + +runParse input + = case runParser a () "" (mkIndentStream 0 infIndentation True Gt input) of + Left err -> Left (show err) + Right a -> Right a + +input1 = [('(', 1), + ('[', 4), + ('(', 5), + (')', 5), + (']', 7), + (')', 1)] +output1 = runParse input1 + +input2 = [('(', 1), + ('[', 8), + ('(', 6), + (')', 6), + ('[', 8), + (']', 9), + (']', 4), + ('(', 3), + (')', 3), + (')', 1)] +output2 = runParse input2 diff --git a/src/Text/Parsec/Indentation/Token.hs b/src/Text/Parsec/Indentation/Token.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/Indentation/Token.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-} +{-# OPTIONS -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} +module Text.Parsec.Indentation.Token where + +import Control.Monad.Identity +import Data.Char +import Data.List (nub, sort) +import Text.Parsec +import Text.Parsec.Token + +import Text.Parsec.Indentation +import Text.Parsec.Indentation.Char (CharIndentStream(..), charIndentStreamParser) + +type IndentLanguageDef st = GenLanguageDef (IndentStream (CharIndentStream String)) st Identity + +makeIndentLanguageDef :: (Monad m) => GenLanguageDef s st m -> GenLanguageDef (IndentStream (CharIndentStream s)) st m +makeIndentLanguageDef l = l { + identStart = indentStreamParser (charIndentStreamParser (identStart l)), + identLetter = indentStreamParser (charIndentStreamParser (identLetter l)), + opStart = indentStreamParser (charIndentStreamParser (opStart l)), + opLetter = indentStreamParser (charIndentStreamParser (opLetter l)) + } + +-- TODO: makeTokenParser :: (Stream (IndentStream s) m Char) +makeTokenParser :: (Stream s m (Char, Indentation)) + => GenLanguageDef (IndentStream s) u m -> GenTokenParser (IndentStream s) u m +makeTokenParser languageDef + = TokenParser{ identifier = identifier + , reserved = reserved + , operator = operator + , reservedOp = reservedOp + + , charLiteral = charLiteral + , stringLiteral = stringLiteral + , natural = natural + , integer = integer + , float = float + , naturalOrFloat = naturalOrFloat + , decimal = decimal + , hexadecimal = hexadecimal + , octal = octal + + , symbol = symbol + , lexeme = lexeme + , whiteSpace = whiteSpace + , parens = parens + , braces = braces + , angles = angles + , brackets = brackets + , squares = brackets + , semi = semi + , comma = comma + , colon = colon + , dot = dot + , semiSep = semiSep + , semiSep1 = semiSep1 + , commaSep = commaSep + , commaSep1 = commaSep1 + } + where + + ----------------------------------------------------------- + -- Bracketing + ----------------------------------------------------------- + parens p = between (symbol "(") (symbol ")") p + braces p = between (symbol "{") (symbol "}") p + angles p = between (symbol "<") (symbol ">") p + brackets p = between (symbol "[") (symbol "]") p + + semi = symbol ";" + comma = symbol "," + dot = symbol "." + colon = symbol ":" + + commaSep p = sepBy p comma + semiSep p = sepBy p semi + + commaSep1 p = sepBy1 p comma + semiSep1 p = sepBy1 p semi + + + ----------------------------------------------------------- + -- Chars & Strings + ----------------------------------------------------------- + charLiteral = lexeme (between (char '\'') + (char '\'' "end of character") + characterChar ) + "character" + + characterChar = charLetter <|> charEscape + "literal character" + + charEscape = do{ char '\\'; escapeCode } + charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) + + + + stringLiteral = lexeme ( + do{ str <- between (char '"') + (localTokenMode (const Any) (char '"' "end of string")) + (localTokenMode (const Any) (many stringChar)) + ; return (foldr (maybe id (:)) "" str) + } + "literal string") + + stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + + stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + + stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + + escapeEmpty = char '&' + escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + + + + -- escape codes + escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + + charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + + charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + + charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + + charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + + -- escape code tables + escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + + ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] + ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + + ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] + ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + + ----------------------------------------------------------- + -- Numbers + ----------------------------------------------------------- + naturalOrFloat = lexeme (natFloat) "number" + + float = lexeme floating "float" + integer = lexeme int "integer" + natural = lexeme nat "natural" + + + -- floats + floating = do{ n <- decimal + ; fractExponent n + } + + + natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + + zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + + decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + + fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + + fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } + + fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + + exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + + + -- integers and naturals + int = do{ f <- lexeme sign + ; n <- nat + ; return (f n) + } + + sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + + nat = zeroNumber <|> decimal + + zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + + decimal = number 10 digit + hexadecimal = do{ oneOf "xX"; number 16 hexDigit } + octal = do{ oneOf "oO"; number 8 octDigit } + + number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } + + ----------------------------------------------------------- + -- Operators & reserved ops + ----------------------------------------------------------- + reservedOp name = + lexeme $ try $ + do{ string name + ; notFollowedBy (opLetter languageDef) ("end of " ++ show name) + } + + operator = + lexeme $ try $ + do{ name <- oper + ; if (isReservedOp name) + then unexpected ("reserved operator " ++ show name) + else return name + } + + oper = + do{ c <- (opStart languageDef) + ; cs <- many (opLetter languageDef) + ; return (c:cs) + } + "operator" + + isReservedOp name = + isReserved (sort (reservedOpNames languageDef)) name + + + ----------------------------------------------------------- + -- Identifiers & Reserved words + ----------------------------------------------------------- + reserved name = + lexeme $ try $ + do{ caseString name + ; notFollowedBy (identLetter languageDef) ("end of " ++ show name) + } + + caseString name + | caseSensitive languageDef = string name + | otherwise = do{ walk name; return name } + where + walk [] = return () + walk (c:cs) = do{ caseChar c msg; walk cs } + + caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) + | otherwise = char c + + msg = show name + + + identifier = + lexeme $ try $ + do{ name <- ident + ; if (isReservedName name) + then unexpected ("reserved word " ++ show name) + else return name + } + + + ident + = do{ c <- identStart languageDef + ; cs <- many (identLetter languageDef) + ; return (c:cs) + } + "identifier" + + isReservedName name + = isReserved theReservedNames caseName + where + caseName | caseSensitive languageDef = name + | otherwise = map toLower name + + + isReserved names name + = scan names + where + scan [] = False + scan (r:rs) = case (compare r name) of + LT -> scan rs + EQ -> True + GT -> False + + theReservedNames + | caseSensitive languageDef = sort reserved + | otherwise = sort . map (map toLower) $ reserved + where + reserved = reservedNames languageDef + + + + ----------------------------------------------------------- + -- White space & symbols + ----------------------------------------------------------- + symbol name + = lexeme (string name) + + lexeme p + = do{ x <- p; whiteSpace; return x } + + whiteSpace = ignoreAbsoluteIndentation (localTokenMode (const Any) whiteSpace') + whiteSpace' + | noLine && noMulti = skipMany (simpleSpace "") + | noLine = skipMany (simpleSpace <|> multiLineComment "") + | noMulti = skipMany (simpleSpace <|> oneLineComment "") + | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + noLine = null (commentLine languageDef) + noMulti = null (commentStart languageDef) + + simpleSpace = + skipMany1 (satisfy isSpace) + + oneLineComment = + do{ try (string (commentLine languageDef)) + ; skipMany (satisfy (/= '\n')) + ; return () + } + + multiLineComment = + do { try (string (commentStart languageDef)) + ; inComment + } + + inComment + | nestedComments languageDef = inCommentMulti + | otherwise = inCommentSingle + + inCommentMulti + = do{ try (string (commentEnd languageDef)) ; return () } + <|> do{ multiLineComment ; inCommentMulti } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } + <|> do{ oneOf startEnd ; inCommentMulti } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) + + inCommentSingle + = do{ try (string (commentEnd languageDef)); return () } + <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } + <|> do{ oneOf startEnd ; inCommentSingle } + "end of comment" + where + startEnd = nub (commentEnd languageDef ++ commentStart languageDef) diff --git a/tests/ParensParsec.hs b/tests/ParensParsec.hs new file mode 100644 --- /dev/null +++ b/tests/ParensParsec.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} +module ParensParsec where + +import Control.Applicative +import Text.Parsec +import Text.Parsec.Indentation +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, assertEqual, assertFailure, Assertion) + + +data A + = Par A -- '(' A ')' + | Bra A -- '[' A ']' + | Seq A A -- A A + | Nil -- epsilon + deriving (Show, Eq) + +a :: (Monad m, Stream s m (Char, Indentation)) => ParsecT (IndentStream s) () m A +a = choice [ Seq <$> a' <*> a, a', return Nil ] + +a' :: (Monad m, Stream s m (Char, Indentation)) => ParsecT (IndentStream s) () m A +a' = choice + [ Par <$> + between (localTokenMode (const Eq) $ char '(') + (localTokenMode (const Eq) $ char ')') + (localIndentation Gt a) + , Bra <$> + between (localTokenMode (const Ge) $ char '[') + (localTokenMode (const Ge) $ char ']') + (localIndentation Gt a) + ] + + +runParse input + = case runParser a () "" (mkIndentStream 0 infIndentation True Gt input) of + Left err -> Left (show err) + Right a -> Right a + +-- conveniences for tests +parL = Par . listToSeq +braL = Bra . listToSeq + +listToSeq [] = Nil +listToSeq (x:xs) = Seq x $ listToSeq xs + +input1 = [('(', 1), + ('[', 4), + ('(', 5), + (')', 5), + (']', 7), + (')', 1)] +output1 = runParse input1 +expected1 = listToSeq [ parL [braL [parL []]] + ] + +input2 = [('(', 1), + ('[', 8), + ('(', 6), + (')', 6), + ('[', 8), + (']', 9), + (']', 4), + ('(', 3), + (')', 3), + (')', 1)] +output2 = runParse input2 +expected2 = listToSeq [ parL [ braL [ parL [] + , braL [] + ] + , parL [] + ] + ] + +assertParsedOk :: (Show err, Show a, Eq a) => Either err a -> a -> Assertion +assertParsedOk actual expected = + case actual of + Right ok -> assertEqual "parsing succeeded, but " expected ok + Left err -> assertFailure ("parse failed with " ++ show err + ++ ", expected" ++ show expected) + +allTests :: TestTree +allTests = + testGroup "parens (parsec)" + [ testCase "1" $ assertParsedOk output1 expected1 + , testCase "2" $ assertParsedOk output2 expected2 + ] diff --git a/tests/all-tests.hs b/tests/all-tests.hs new file mode 100644 --- /dev/null +++ b/tests/all-tests.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Test.Tasty (defaultMain, testGroup) +import qualified ParensParsec + +main = + defaultMain $ testGroup "All tests" $ + [ + ParensParsec.allTests + ]