4033N/A{- |

1178N/AModule : $Header$

1178N/ACopyright : (c) Christian Maeder and Uni Bremen 2002-2003

1178N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

1178N/A

1178N/AMaintainer : maeder@tzi.de

1178N/AStability : provisional

1178N/APortability : portable

1178N/A

1178N/Ascanner for Casl tokens using Parsec <http://www.cs.uu.nl/~daan/parsec.html>

1178N/A

1178N/A <http://www.cofi.info/Documents/CASL/Summary/>

1178N/A from 25 March 2001

1178N/A C.4 Lexical Syntax

1178N/A-}

1178N/A

1178N/Amodule Common.Lexer where

2362N/A

2362N/Aimport Data.Char (digitToInt, isDigit)

2362N/Aimport Common.Id -- (Token(..), place)

1178N/Aimport Text.ParserCombinators.Parsec

4169N/Aimport qualified Text.ParserCombinators.Parsec.Pos as Pos

1178N/A

1178N/A-- * positions from "Text.ParserCombinators.Parsec.Pos" starting at (1,1)

4033N/A

4033N/A

0N/A-- | no-bracket-signs

1178N/AsignChars :: String

1178N/AsignChars = "!#$&*+-./:<=>?@\\^|~" ++ "�����������������"

1178N/A

4033N/A-- "\161\162\163\167\169\172\176\177\178\179\181\182\183\185\191\215\247"

1178N/A-- \172 neg \183 middle dot \215 times

1178N/A

4033N/AscanAnySigns :: GenParser Char st String

1178N/AscanAnySigns = many1 (oneOf signChars <?> "casl sign") <?> "signs"

1178N/A

4033N/A-- | casl letters

1178N/AcaslLetters :: String

1178N/AcaslLetters = ['A'..'Z'] ++ ['a'..'z'] ++

4033N/A "����������������������������������������������������������"

1178N/A

1178N/A-- see <http://www.htmlhelp.com/reference/charset/> starting from \192

1178N/A-- \208 ETH \215 times \222 THORN \240 eth \247 divide \254 thorn

4033N/A

1178N/AcaslLetter :: GenParser Char st Char

1178N/AcaslLetter = oneOf caslLetters <?> "casl letter"

1178N/A

1178N/Aprime :: GenParser Char st Char

1178N/Aprime = char '\'' -- also used for quoted chars

1178N/A

1178N/AscanLPD :: GenParser Char st Char

1178N/AscanLPD = caslLetter <|> digit <|> prime <?> "casl char"

1178N/A

1178N/A-- ----------------------------------------------

0N/A-- * Monad and Functor extensions

1178N/A-- ----------------------------------------------

1178N/A

1178N/Abind :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c

4033N/Abind f p q = do { x <- p; y <- q; return (f x y) }

1178N/A

1178N/Ainfixl <<

4033N/A

1178N/A(<<) :: (Monad m) => m a -> m b -> m a

1178N/A(<<) = bind const

4033N/A

1178N/Ainfixr 5 <:>

1178N/A

4033N/A(<:>) :: (Monad m) => m a -> m [a] -> m [a]

1178N/A(<:>) = bind (:)

1178N/A

0N/Ainfixr 5 <++>

4033N/A

1178N/A(<++>) :: (Monad m) => m [a] -> m [a] -> m [a]

1178N/A(<++>) = bind (++)

4033N/A

1178N/A-- Functor extension

0N/Asingle :: (Functor f, Monad m) => f a -> f (m a)

4033N/Asingle = fmap return

1178N/A

1178N/Aflat :: (Functor f) => f [[a]] -> f [a]

1178N/Aflat = fmap concat

1178N/A

4033N/A-- ----------------------------------------------

1178N/A-- * ParsecCombinator extension

1178N/A-- ----------------------------------------------

1178N/A

1178N/AfollowedWith :: GenParser tok st a -> GenParser tok st b -> GenParser tok st a

1178N/Ap `followedWith` q = try (p << lookAhead q)

1178N/A

4033N/AbegDoEnd :: (Monad f, Functor f) => f a -> f [a] -> f a -> f [a]

1178N/AbegDoEnd open p close = open <:> p <++> single close

0N/A

4033N/AenclosedBy :: (Monad f, Functor f) => f [a] -> f a -> f [a]

1178N/Ap `enclosedBy` q = begDoEnd q p q

0N/A

4033N/AcheckWith :: (Show a) => GenParser tok st a -> (a -> Bool)

1178N/A -> GenParser tok st a

4033N/Ap `checkWith` f = do x <- p

0N/A if f x then return x else unexpected (show x)

1178N/A

4033N/AseparatedBy :: GenParser tok st a -> GenParser tok st b

1178N/A -> GenParser tok st ([a], [b])

4033N/Ap `separatedBy` s = do r <- p

1178N/A option ([r], [])

1178N/A (do t <- s

0N/A (es, ts) <- separatedBy p s

1178N/A return (r:es, t:ts))

0N/A

4033N/A-- ----------------------------------------------

1178N/A-- * casl words

4033N/A-- ----------------------------------------------

0N/A

4033N/AscanLetterWord :: GenParser Char st String

1178N/AscanLetterWord = caslLetter <:> many scanLPD <?> "letter word"

4033N/A

1178N/AsingleUnderline :: GenParser Char st Char

1178N/AsingleUnderline = char '_' `followedWith` scanLPD

0N/A

4033N/AscanUnderlineWord :: GenParser Char st String

0N/AscanUnderlineWord = singleUnderline <:> many1 scanLPD

4033N/A

0N/AscanAnyWords, casl_words :: GenParser Char st String

4033N/AscanAnyWords = flat (scanLetterWord <:> many scanUnderlineWord) <?> "words"

0N/Acasl_words = scanAnyWords

4033N/A

1178N/AscanDot :: GenParser Char st Char

1178N/AscanDot = char '.' `followedWith` caslLetter

4033N/A

1178N/AscanDotWords :: GenParser Char st String

1178N/AscanDotWords = scanDot <:> scanAnyWords

1178N/A

1178N/A-- ----------------------------------------------

1178N/A-- * casl escape chars for quoted chars and literal strings

1178N/A-- ----------------------------------------------

1178N/A

4033N/A-- see ParsecToken.number

0N/Avalue :: Int -> String -> Int

4033N/Avalue base s = foldl (\x d -> base*x + (digitToInt d)) 0 s

1178N/A

4033N/AsimpleEscape :: GenParser Char st String

1178N/AsimpleEscape = single (oneOf "'\"\\ntrvbfa?")

1178N/A

4033N/AdecEscape :: GenParser Char st String

1178N/AdecEscape = count 3 digit `checkWith` \s -> value 10 s <= 255

4033N/A

1178N/AhexEscape :: GenParser Char st String

4033N/AhexEscape = char 'x' <:> count 2 hexDigit -- cannot be too big

1178N/A

1178N/AoctEscape :: GenParser Char st String

1178N/AoctEscape = char 'o' <:>

1178N/A count 3 octDigit `checkWith` \s -> value 8 s <= 255

4033N/A

0N/AescapeChar :: GenParser Char st String

4033N/AescapeChar = char '\\' <:>

0N/A (simpleEscape <|> decEscape <|> hexEscape <|> octEscape)

4033N/A

0N/A-- ----------------------------------------------

0N/A-- * chars for quoted chars and literal strings

4033N/A-- ----------------------------------------------

0N/A

4033N/Aprintable :: GenParser Char st String

1178N/Aprintable = single (satisfy (\c -> (c /= '\'') && (c /= '"')

4033N/A && (c /= '\\') && (c > '\026')))

1178N/A

4033N/AcaslChar :: GenParser Char st String

0N/AcaslChar = escapeChar <|> printable

1178N/A

4033N/AscanQuotedChar :: GenParser Char st String

0N/AscanQuotedChar = (caslChar <|> (char '"' >> return "\\\""))

1178N/A `enclosedBy` prime <?> "quoted char"

0N/A

1178N/A-- convert '"' to '\"' and "'" to "\'" (no support for ''')

4033N/A

0N/AscanString :: GenParser Char st String

4033N/AscanString = flat (many (caslChar <|> (char '\'' >> return "\\\'")))

0N/A `enclosedBy` char '"' <?> "literal string"

4033N/A

1178N/AisString :: Token -> Bool

4033N/AisString t = take 1 (tokStr t) == "\""

0N/A

4033N/AparseString :: Parser a -> String -> a

4033N/AparseString p s = case parse p "" s of

0N/A Left _ -> error "parseString"

4033N/A Right x -> x

0N/A

4033N/AsplitString :: Parser a -> String -> (a, String)

0N/AsplitString p s =

0N/A let ph = do hd <- p;

0N/A tl <- getInput;

1178N/A return (hd, tl)

1178N/A in parseString ph s

1178N/A

1178N/A-- ----------------------------------------------

1178N/A-- * digit, number, fraction, float

4033N/A-- ----------------------------------------------

1178N/A

4033N/AgetNumber :: GenParser Char st String

1178N/AgetNumber = many1 digit

4033N/A

4033N/AscanFloat :: GenParser Char st String

1178N/AscanFloat = getNumber <++> (option ""

4033N/A (char '.' <:> getNumber)

1178N/A <++> option ""

4033N/A (char 'E' <:> option "" (single (oneOf "+-"))

1178N/A <++> getNumber))

1178N/A

1178N/AscanDigit :: GenParser Char st String

4033N/AscanDigit = single digit

1178N/A

1178N/AisNumber :: Token -> Bool

1178N/AisNumber t = case tokStr t of

1178N/A c:_:_ -> isDigit c

4033N/A _ -> False

1178N/A

1178N/AisFloating :: Token -> Bool

1178N/A-- precondition: isNumber

1178N/AisFloating t = any (\c -> c == '.' || c == 'E') (tokStr t)

4033N/A

1178N/AisLitToken :: Token -> Bool

1178N/AisLitToken t = case tokStr t of

1178N/A c:_ -> c == '\"' || c == '\'' || isDigit c

1178N/A _ -> False

4033N/A

1178N/A-- ----------------------------------------------

1178N/A-- * nested comment outs

4033N/A-- ----------------------------------------------

1178N/A

4033N/AnotEndText :: Char -> GenParser Char st Char

1178N/AnotEndText c = try (char c << notFollowedBy (char '%'))

4033N/A

1178N/AnestCommentOut :: GenParser Char st Char

4033N/AnestCommentOut = try (string "%[") >>

1178N/A many (noneOf "]%"

4033N/A <|> notEndText ']'

1178N/A <|> nestCommentOut

4033N/A <|> char '%')

1178N/A >> char ']' >> char '%'

4033N/A

1178N/A-- ----------------------------------------------

1178N/A-- * skip whitespaces and nested comment out

4033N/A-- ----------------------------------------------

1178N/A

4033N/AwhiteChars :: String

1178N/AwhiteChars = "\n\r\t\v\f \160" -- non breaking space

4033N/A

4033N/Askip :: GenParser Char st ()

4033N/Askip = skipMany(oneOf (whiteChars)

4033N/A <|> nestCommentOut <?> "") >> return ()

4033N/A

4033N/AfromSourcePos :: Pos.SourcePos -> Pos

4033N/AfromSourcePos p =

1178N/A newPos (Pos.sourceName p) (Pos.sourceLine p) (Pos.sourceColumn p)

1178N/A

1178N/AgetPos :: GenParser tok st Pos

1178N/AgetPos = fmap fromSourcePos getPosition

4033N/A

1178N/A-- only skip to an annotation if it's on the same or next line

1178N/AskipSmart :: GenParser Char st ()

4033N/AskipSmart = do p <- getPosition

1178N/A try (do skip

1178N/A q <- getPosition

4033N/A if Pos.sourceLine q <= Pos.sourceLine p + 1

1178N/A then return ()

1178N/A else notFollowedBy (char '%') >> return ()

4033N/A )

1178N/A <|> return ()

1178N/A

4033N/A-- ----------------------------------------------

1178N/A-- * keywords WORDS or NO-BRACKET-SIGNS

4033N/A-- ----------------------------------------------

1178N/A

1178N/AkeyWord :: GenParser Char st a -> GenParser Char st a

1178N/AkeyWord p = try(p << notFollowedBy (scanLPD <|> singleUnderline))

4033N/A

0N/AkeySign :: GenParser Char st a -> GenParser Char st a

0N/AkeySign p = try(p << notFollowedBy (oneOf signChars))

0N/A

4033N/Areserved :: [String] -> GenParser Char st String -> GenParser Char st String

1178N/A-- "try" to avoid reading keywords

4033N/Areserved l p = try (p `checkWith` \r -> r `notElem` l)

0N/A

4033N/A-- ----------------------------------------------

1178N/A-- * lexical tokens with position

1178N/A-- ----------------------------------------------

4033N/A

1178N/ApToken :: GenParser Char st String -> GenParser Char st Token

1178N/ApToken parser = bind (\ p s -> Token s [p]) getPos (parser << skipSmart)

1178N/A

1178N/ApluralKeyword :: String -> GenParser Char st Token

4033N/ApluralKeyword s = pToken (keyWord (string s <++> option "" (string "s")))

4033N/A

4033N/A-- | check for keywords (depending on lexem class)

4033N/AtoKey :: String -> GenParser Char st String

1178N/AtoKey s = let p = string s in

1178N/A if last s `elem` "[]{}(),;" then p

4033N/A else if last s `elem` signChars then keySign p

1178N/A else keyWord p

1178N/A

1178N/A-- * some separator parsers

1178N/A

4033N/AasSeparator :: String -> GenParser Char st Token

0N/AasSeparator = pToken . string

1178N/A

1178N/AcommaT, semiT :: GenParser Char st Token

1178N/AcommaT = asSeparator ","

4033N/AsemiT = asSeparator ";"

1178N/A

1178N/AoBraceT, cBraceT :: GenParser Char st Token

4033N/AoBraceT = asSeparator "{"

1178N/AcBraceT = asSeparator "}"

1178N/A

4033N/AoBracketT, cBracketT, oParenT, cParenT :: GenParser Char st Token

1178N/AoBracketT = asSeparator "["

1178N/AcBracketT = asSeparator "]"

4033N/AoParenT = asSeparator "("

1178N/AcParenT = asSeparator ")"

1178N/A

4033N/Abraces :: GenParser Char st a -> GenParser Char st a

1178N/Abraces p = oBraceT >> p << cBraceT

1178N/A

4033N/AcommaSep1 :: GenParser Char st a -> GenParser Char st [a]

1178N/AcommaSep1 p = fmap fst $ separatedBy p commaT

1178N/A

4033N/AplaceS :: GenParser Char st String

1178N/AplaceS = try (string place) <?> place

1178N/A

4033N/AplaceT :: GenParser Char st Token

1178N/AplaceT = pToken placeS

1178N/A

4033N/A