indentation (empty) → 0.1.0.0
raw patch · 7 files changed
+1039/−0 lines, 7 filesdep +basedep +mtldep +parsecsetup-changed
Dependencies added: base, mtl, parsec
Files
- LICENSE +27/−0
- Setup.hs +2/−0
- Text/Parsec/Indentation.hs +203/−0
- Text/Parsec/Indentation/Char.hs +43/−0
- Text/Parsec/Indentation/Token.hs +400/−0
- Text/Parser/Indentation/Implementation.hs +332/−0
- indentation.cabal +32/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Parsec/Indentation.hs view
@@ -0,0 +1,203 @@+{-# 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+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 (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 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 localIndentation #-}+localIndentation :: (Monad m) => IndentationRel -> ParsecT (IndentStream s) u m a -> ParsecT (IndentStream s) u m a+localIndentation = I.localIndentation localStateUnlessAbsMode++------------------------+-- 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+-}
+ Text/Parsec/Indentation/Char.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+module Text.Parsec.Indentation.Char where++import Text.Parsec+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
+ Text/Parsec/Indentation/Token.hs view
@@ -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)
+ Text/Parser/Indentation/Implementation.hs view
@@ -0,0 +1,332 @@+module Text.Parser.Indentation.Implementation where++-- Implements common code for "Indentation Senstivie Parising: Landin Revisited"+--+-- Primary functions are:+-- - TODO+-- Primary driver functions are:+-- - TODO++-- TODO:+-- Grace style indentation stream+-- Haskell style indentation stream++--import Control.Monad++------------------------+-- Indentations+------------------------++-- We use indent 1 for the first column. Not only is this consistent+-- with how Parsec counts columns, but it also allows 'Gt' to refer to+-- the first column by setting the indent to 0.+--data Indentation = Indentation# Int# deriving (Eq, Ord)+type Indentation = Int+data IndentationRel = Eq | Any | Const Indentation | Ge | Gt deriving (Show, Eq)++{-# INLINE infIndentation #-}+infIndentation :: Indentation+infIndentation = maxBound++{-+instance Num Indentation where++instance Show Indentation where+ show i@(Indentation# i') | i' == maxBound = "Infinity"+ | otherwise = show (Int# i')+-}++------------------------+-- Indentable Stream+------------------------++-- We store state information about the current indentation in the+-- Stream. Encoding the indentation state in the Stream is weird, but+-- the other two places where we could put it don't work. The monad+-- isn't rolledback when backtracking happens (which we need the+-- indentation state to do), and the user state isn't available when+-- we do an 'uncons'.++{-# INLINE mkIndentationState #-}+mkIndentationState :: Indentation -> Indentation -> Bool -> IndentationRel -> IndentationState+mkIndentationState lo hi mode rel+ | lo == infIndentation = error "mkIndentationState: minimum indentation 'infIndentation' is out of bounds"+ | lo > hi = error "mkIndentationState: minimum indentation is greater than maximum indent"+ | otherwise = IndentationState lo hi mode rel++-- THEOREM: indent sets are all describable by upper and lower bounds (maxBound is infinity)+-- GLOBAL INVARIANT: minIndentation /= infIndentation+-- GLOBAL INVARIANT: minIndentation <= maxIndentation+-- GLOBAL INVARIENT: lo <= lo' where lo and lo' are minIndentation respectively before and after a monadic action+-- GLOBAL INVARIENT: hi' <= hi where hi and hi' are maxIndentation respectively before and after a monadic action++data IndentationState = IndentationState {+ minIndentation :: {-# UNPACK #-} !Indentation, -- inclusive, must not equal infIndentation+ maxIndentation :: {-# UNPACK #-} !Indentation, -- inclusive, infIndentation (i.e., maxBound) means infinity+ absMode :: !Bool, -- true if we are in 'absolute' mode+ tokenRel :: !IndentationRel+ } deriving (Show)+ -- Our representation of maxIndentation will get us in trouble if things+ -- overflow. In future we may want to use a type representing+ -- Integer+Infinity However, this bug triggers *only* when there are+ -- a large number of nested 'Gt' indentations which shouldn't be all+ -- that common and 'local'++{-# INLINE indentationStateAbsMode #-}+indentationStateAbsMode :: IndentationState -> Bool+indentationStateAbsMode x = absMode x++{-# INLINE updateIndentation #-}+-- PRIVATE: Use assertIndentation instead+updateIndentation :: IndentationState -> Indentation -> (IndentationState -> a) -> (String -> a) -> a+updateIndentation (IndentationState lo hi mode rel) i ok err = updateIndentation' lo hi (if mode then Eq else rel) i ok' err' where+ ok' lo' hi' = ok (IndentationState lo' hi' False rel)+ err' = err++{-# INLINE updateIndentation' #-}+updateIndentation' :: Indentation -> Indentation -> IndentationRel -> Indentation -> (Indentation -> Indentation -> a) -> (String -> a) -> a+updateIndentation' lo hi rel i ok err =+ case rel of+ Any -> ok lo hi+ Const c | c == i -> ok lo hi+ | otherwise -> err' $ "indentation "++show c+ Eq | lo <= i && i <= hi -> ok i i+ | otherwise -> err' $ "an indentation between "++show lo++" and "++show hi+ Gt | lo < i -> ok lo (min (i-1) hi)+ | otherwise -> err' $ "an indentation greater than "++show lo+ Ge | lo <= i -> ok lo (min i hi)+ | otherwise -> err' $ "an indentation greater than or equal to "++show lo+ where err' place = err $ "Found a token at indentation "++show i++". Expecting a token at "++place++"."++-- TODO: error when hi is maxIndentation++-- There is no way to query the current indentation because multiple+-- indentations are tried in parallel and later parsing may disqualify+-- one of these indentations. However, we can assert that the current+-- indentation must have a particular relation, 'r', to a given+-- indentation, 'i'. The call 'assertIndent r i' does this. Calling+-- 'assertIndent r i' is equivalent to consuming a pseudo-token that has+-- been annotated with the relation 'r' at indentation 'i'.+--+-- Note that the absolute indentation mode may override 'r'.+{-+assertIndent :: (Monad m, Stream (IndentStream s) m t) => IndentRel -> Indent -> ParsecT (IndentStream s) u m ()+assertIndent r i = do+ IndentStream lo hi mode rel s <- getInput+ let ok s' = setInput (s' { absMode = mode }) -- Update input sets mode to False by default+ --ok lo' hi' = setInput (IndentStream lo' hi' mode rel s)+ err msg = unexpected $ "Indentation assertion '"++show r++" "++show i++"' failed. "++msg+ updateIndent lo hi mode r i s ok err+ --updateIndent lo hi (if mode then Eq else r) i ok err+-}++{-+{-# INLINE askTokenMode #-}+askTokenMode :: (Monad m) => ParsecT (IndentStream s) u m IndentRel+askTokenMode = liftM tokenRel getInput+-}++------------------------+-- Token Modes+------------------------++-- Token modes determine how the current indentation must relate to+-- the indentation of a token. Because several languages have special+-- rules for the first token of the production, we split the token+-- mode into two parts. The first part is the mode for the first+-- token in a grammatical form while the second part is the mode for+-- the other tokens in a grammatical form.+--+-- Because of this split, while token modes generally follow a reader+-- monad pattern, there is one important exception. Namely the+-- first-token mode may follow a state monad pattern. (Thus we have+-- the divergent names for the first-token and other-token query+-- operators.)++-- THEOREM: tokenMode == tokenMode'+-- THEOREM: firstTokenMode' == firstTokenMode \/ firstTokenMode' == otherTokenMode++type LocalState a = (IndentationState -> IndentationState) -- pre+ -> (IndentationState {-old-} -> IndentationState {-new-} -> IndentationState) -- post+ -> a -> a++{-# INLINE localTokenMode #-}+localTokenMode :: (LocalState a)+ -> (IndentationRel -> IndentationRel)+ -> a -> a+localTokenMode localState f_rel = localState pre post where+ pre i1 = i1 { tokenRel = f_rel (tokenRel i1) }+ post i1 i2 = i2 { tokenRel = tokenRel i1 }++{-# INLINE absoluteIndentation #-}+absoluteIndentation :: LocalState a -> a -> a+absoluteIndentation localState = localState pre post where+ pre i1 = i1 { absMode = True }+ post i1 i2 = i2 { absMode = absMode i1 } -- redundant if we assertNonAbsMode++{-# INLINE ignoreAbsoluteIndentation #-}+ignoreAbsoluteIndentation :: LocalState a -> a -> a+ignoreAbsoluteIndentation localState = localState pre post where+ pre i1 = i1 { absMode = False }+ post i1 i2 = i2 { absMode = absMode i1 }++--{-# INLINE askTokenMode #-}+--askTokenMode :: (Monad m) => ParsecT (IndentationStream s) u m IndentationRel+--askTokenMode = liftM tokenRel getInput+-- TODO: assertNotAbsMod/askAbsMode+-- when (absMode i2) (fail "absoluteIndentation: no tokens consumed") >>++------------------------+-- Local Indentations+------------------------++{-# INLINE localIndentation' #-}+-- PRIVATE: locally violates global invariants but used in a way that does not+localIndentation' :: LocalState a -> (Indentation -> Indentation) -> (Indentation -> Indentation) -> (Indentation -> Indentation -> Indentation) -> a -> a+localIndentation' localState f_lo f_hi f_hi' m = localState pre post m+ where pre (IndentationState lo hi mode rel) = IndentationState (f_lo lo) (f_hi hi) mode rel+ post (IndentationState lo hi _ _) i2 = i2 { minIndentation = lo, maxIndentation = f_hi' hi (maxIndentation i2) }+-- post (IndentationStream lo hi mode rel s) i2 = IndentationStream lo (f_hi' hi (maxIndentation i2)) mode rel s++-- 'localIndentation r p' specifies that the current indentation for 'p' must have relation 'r'+-- relative to the current indentation of the context in which 'localIndentation r p' is called.+{-# INLINE localIndentation #-}+-- NOTE: it is the responsibility of 'localState' to *not* use it's arguments if we are in absMode+localIndentation :: LocalState a -> IndentationRel -> a -> a+localIndentation localState Eq m = m+localIndentation localState Any m = localIndentation' localState (const 0) (const infIndentation) (const) m+localIndentation localState (Const c) m+ | c == infIndentation = error "localIndentation: Const indentation 'infIndentation' is out of bounds"+ | otherwise = localIndentation' localState (const c) (const c) (const) m+localIndentation localState Ge m = localIndentation' localState (id) (const infIndentation) (flip const) m+localIndentation localState Gt m = localIndentation' localState (+1) (const infIndentation) (f) ({-TODO: checkOverflow >>-} m) where+ f hi hi' | hi' == infIndentation || hi < hi' = hi+ | hi' > 0 = hi' - 1 -- Safe only b/c hi' > 0+ | otherwise = error "localIndentation: assertion failed: hi' > 0"+{-+ checkOverflow = do+ IndentationStream { minIndentation = lo } <- getState+ when (lo == infIndentation) $ fail "localIndentation: Overflow in indentation lower bound."+-}++----------------+-- 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))+-}++----------------+-- Unicode char+-- newtype UnicodeIndentStream++{-+----------------+-- Based on Char+mkCharIndentStream :: s -> CharIndentStream s+mkCharIndentStream s = CharIndentStream 1 s+data CharIndentStream s = CharIndentStream { charIndentStreamColumn :: !Indent,+ charIndentStreamStream :: s } deriving (Show)++instance (Stream s m Char) => Stream (CharIndentStream s) m (Indent, Char) where+ uncons (CharIndentStream i s) = do+ x <- uncons s+ case x of+ Nothing -> return Nothing+ Just (c, cs) -> return (Just ((i, c), CharIndentStream (f c) cs)) where+ f '\n' = 1+ f '\t' = i + 8 - ((i-1) `mod` 8)+ f _ = i + 1++charIndentStreamParser :: (Monad m) => ParsecT s u m t -> ParsecT (CharIndentStream s) u m (Indent, t)+charIndentStreamParser p = mkPT $ \state ->+ let go (Ok a state' e) = return (Ok (sourceColumn $ statePos state, a) (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)++----------------+-- 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.+indentStreamParser :: (Monad m) => ParsecT s u m (Indent, t) -> ParsecT (IndentStream s) u m t+indentStreamParser p = mkPT $ \state ->+ let IndentStream lo hi mode rel _ = stateInput state+ go f (Ok (i, a) state' e) = updateIndent lo hi (if mode then Eq else rel) i ok err where+ ok lo' hi' = return $ f $ return (Ok a (state' {stateInput = IndentStream lo' hi' False rel (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 = tokenStream (stateInput state) }) >>= consumed (go Consumed) (go Empty)++-- 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+-}+-}
+ indentation.cabal view
@@ -0,0 +1,32 @@+name: indentation+version: 0.1.0.0+synopsis: Indentation sensitive parsing combinators for Parsec+-- description:+license: BSD3+license-file: LICENSE+author: Michael D. Adams <http://michaeldadams.org/>+maintainer: Ömer Sinan Ağacan <omeragacan@gmail.com>+category: Parsing+build-type: Simple+cabal-version: >=1.10++homepage: https://bitbucket.org/mdmkolbe/indentation+bug-reports: https://bitbucket.org/mdmkolbe/indentation/issues++source-repository head+ type: git+ location: https://bitbucket.org/mdmkolbe/indentation.git++library+ exposed-modules: Text.Parser.Indentation.Implementation+ , Text.Parsec.Indentation+ , Text.Parsec.Indentation.Char+ , Text.Parsec.Indentation.Token++ build-depends: base >=4.6 && <4.7,+ parsec >=3.1 && <3.2,+ mtl >=2.1 && <2.2++ default-language: Haskell2010++ ghc-options: -Wall