{- HetCATS/CASL/Lexer.hs

$Id$

Authors: Christian Maeder

Year: 2002

scanner for CASL tokens and extensions to parsec

http://www.cs.uu.nl/~daan/parsec.html)

-- extended with "consumeNothing"

http://www.cofi.info/Documents/CASL/Summary/

from 25 March 2001

C.4 Lexical Syntax

-}

module Common.Lexer where

import Data.Char (digitToInt, isDigit)

import Common.Id (Token(..), place)

import Control.Monad (MonadPlus (mplus), liftM2)

import Common.Lib.Parsec

-- ----------------------------------------------

-- no-bracket-signs

-- ----------------------------------------------

signChars :: String

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

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

-- \172 neg \183 middle dot \215 times

scanAnySigns :: GenParser Char st String

scanAnySigns = many1 (oneOf signChars <?> "casl sign") <?> "signs"

-- ----------------------------------------------

-- casl letters

-- ----------------------------------------------

caslLetters :: String

caslLetters = ['A'..'Z'] ++ ['a'..'z'] ++

"����������������������������������������������������������"

-- see http://www.htmlhelp.com/reference/charset/ starting from \192

-- \208 ETH \215 times \222 THORN \240 eth \247 divide \254 thorn

caslLetter :: GenParser Char st Char

caslLetter = oneOf caslLetters <?> "casl letter"

prime :: GenParser Char st Char

prime = char '\'' -- also used for quoted chars

scanLPD :: GenParser Char st Char

scanLPD = caslLetter <|> digit <|> prime <?> "casl char"

-- ----------------------------------------------

-- Monad/Functor extensions

-- ----------------------------------------------

bind :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c

bind f p q = do { x <- p; y <- q; return (f x y) }

infixl <<

(<<) :: (Monad m) => m a -> m b -> m a

(<<) = bind const

infixr 5 <:>

(<:>) :: (Monad m) => m a -> m [a] -> m [a]

(<:>) = liftM2 (:)

infixr 5 <++>

(<++>) :: (Monad m, MonadPlus p) => m (p a) -> m (p a) -> m (p a)

(<++>) = liftM2 mplus

-- Functor extension

single :: (Functor f, Monad m) => f a -> f (m a)

single = fmap return

flat :: (Functor f) => f [[a]] -> f [a]

flat = fmap concat

-- ----------------------------------------------

-- ParsecCombinator extension

-- ----------------------------------------------

followedWith :: GenParser tok st a -> GenParser tok st b -> GenParser tok st a

p `followedWith` q = try (p << lookAhead q)

begDoEnd :: (Monad f, Functor f) => f a -> f [a] -> f a -> f [a]

begDoEnd open p close = open <:> p <++> single close

enclosedBy :: (Monad f, Functor f) => f [a] -> f a -> f [a]

p `enclosedBy` q = begDoEnd q p q

checkWith :: (Show a) => GenParser tok st a -> (a -> Bool)

-> GenParser tok st a

p `checkWith` f = do x <- p

if f x then return x else

consumeNothing >> unexpected (show x)

separatedBy :: GenParser tok st a -> GenParser tok st b

-> GenParser tok st ([a], [b])

p `separatedBy` s = do r <- p

option ([r], [])

(do t <- s

(es, ts) <- separatedBy p s

return (r:es, t:ts))

-- ----------------------------------------------

-- casl words

-- ----------------------------------------------

scanLetterWord :: GenParser Char st String

scanLetterWord = caslLetter <:> many scanLPD <?> "letter word"

singleUnderline :: GenParser Char st Char

singleUnderline = char '_' `followedWith` scanLPD

scanUnderlineWord :: GenParser Char st String

scanUnderlineWord = singleUnderline <:> many1 scanLPD <?> "underline word"

scanAnyWords, casl_words :: GenParser Char st String

scanAnyWords = flat (scanLetterWord <:> many scanUnderlineWord) <?> "words"

casl_words = scanAnyWords

scanDot :: GenParser Char st Char

scanDot = char '.' `followedWith` caslLetter

scanDotWords :: GenParser Char st String

scanDotWords = scanDot <:> scanAnyWords <?> "dot-words"

-- ----------------------------------------------

-- casl escape chars for quoted chars and literal strings

-- ----------------------------------------------

-- see ParsecToken.number

value :: Int -> String -> Int

value base s = foldl (\x d -> base*x + (digitToInt d)) 0 s

simpleEscape :: GenParser Char st String

simpleEscape = single (oneOf "'\"\\ntrvbfa?")

decEscape :: GenParser Char st String

decEscape = count 3 digit `checkWith` \s -> value 10 s <= 255

hexEscape :: GenParser Char st String

hexEscape = char 'x' <:> count 2 hexDigit -- cannot be too big

octEscape :: GenParser Char st String

octEscape = char 'o' <:>

count 3 octDigit `checkWith` \s -> value 8 s <= 255

escapeChar :: GenParser Char st String

escapeChar = char '\\' <:>

(simpleEscape <|> decEscape <|> hexEscape <|> octEscape)

-- ----------------------------------------------

-- chars for quoted chars and literal strings

-- ----------------------------------------------

printable :: GenParser Char st String

printable = single (satisfy (\c -> (c /= '\'') && (c /= '"')

&& (c /= '\\') && (c > '\026')))

caslChar :: GenParser Char st String

caslChar = escapeChar <|> printable

scanQuotedChar :: GenParser Char st String

scanQuotedChar = (caslChar <|> (char '"' >> return "\\\""))

`enclosedBy` prime <?> "quoted char"

-- convert '"' to '\"' and "'" to "\'" (no support for ''')

scanString :: GenParser Char st String

scanString = flat (many (caslChar <|> (char '\'' >> return "\\\'")))

`enclosedBy` char '"' <?> "literal string"

isString :: Token -> Bool

isString t = head (tokStr t) == '\"'

parseString :: Parser a -> String -> a

parseString p s = case parse p "" s of

Left _ -> error "parseString"

Right x -> x

splitString :: Parser a -> String -> (a, String)

splitString p s =

let ph = do hd <- p;

tl <- getInput;

return (hd, tl)

in parseString ph s

-- ----------------------------------------------

-- digit, number, fraction, float

-- ----------------------------------------------

getNumber :: GenParser Char st String

getNumber = many1 digit

scanFloat :: GenParser Char st String

scanFloat = getNumber <++> (option ""

(char '.' <:> getNumber)

<++> option ""

(char 'E' <:> option "" (single (oneOf "+-"))

<++> getNumber))

scanDigit :: GenParser Char st String

scanDigit = single digit

isNumber :: Token -> Bool

isNumber t = let s = tokStr t in length s > 1 && isDigit (head s)

isFloating :: Token -> Bool

-- precondition: isNumber

isFloating t = any (\c -> c == '.' || c == 'E') (tokStr t)

isLitToken :: Token -> Bool

isLitToken t = isString t ||

let c = head (tokStr t) in c == '\'' || isDigit c

-- ----------------------------------------------

-- nested comment outs

-- ----------------------------------------------

notEndText :: Char -> GenParser Char st Char

notEndText c = try (char c << notFollowedBy (char '%'))

nestCommentOut :: GenParser Char st Char

nestCommentOut = try (string "%[") >>

many (noneOf "]%"

<|> notEndText ']'

<|> nestCommentOut

<|> char '%')

>> char ']' >> char '%'

-- ----------------------------------------------

-- skip whitespaces and nested comment out

-- ----------------------------------------------

whiteChars :: String

whiteChars = "\n\r\t\v\f \160" -- non breaking space

skip, whiteSpace :: GenParser Char st ()

skip = skipMany(oneOf (whiteChars)

<|> nestCommentOut <?> "") >> return ()

whiteSpace = skip

lexeme :: GenParser Char st a -> GenParser Char st a

lexeme p = p << skip

symbol :: String -> GenParser Char st String

symbol s = lexeme (string s)

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

skipSmart :: GenParser Char st ()

skipSmart = do p <- getPosition

try (do skip

q <- getPosition

if sourceLine q <= sourceLine p + 1 then return ()

else notFollowedBy (char '%') >> return ()

)

<|> return ()

-- ----------------------------------------------

-- keywords WORDS or NO-BRACKET-SIGNS

-- ----------------------------------------------

keyWord :: GenParser Char st a -> GenParser Char st a

keyWord p = try(p << notFollowedBy scanLPD)

keySign :: GenParser Char st a -> GenParser Char st a

keySign p = try(p << notFollowedBy (oneOf signChars))

reserved :: [String] -> GenParser Char st String -> GenParser Char st String

-- "try" to avoid reading keywords

reserved l p = try (p `checkWith` \r -> r `notElem` l)

-- ----------------------------------------------

-- lexical tokens with position

-- ----------------------------------------------

convToPos :: SourcePos -> SourcePos

convToPos = id

pToken :: GenParser Char st String -> GenParser Char st Token

pToken parser = bind (flip Token) getPosition (parser << skipSmart)

pluralKeyword :: String -> GenParser Char st Token

pluralKeyword s = pToken (keyWord (string s <++> option "" (string "s")))

-- check for keywords (depending on lexem class)

toKey :: String -> GenParser Char st String

toKey s = let p = string s in

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

else if last s `elem` signChars then keySign p

else keyWord p

asSeparator :: String -> GenParser Char st Token

asSeparator = pToken . string

commaT, semiT :: GenParser Char st Token

commaT = asSeparator ","

semiT = asSeparator ";"

oBraceT, cBraceT :: GenParser Char st Token

oBraceT = asSeparator "{"

cBraceT = asSeparator "}"

oBracketT, cBracketT, oParenT, cParenT :: GenParser Char st Token

oBracketT = asSeparator "["

cBracketT = asSeparator "]"

oParenT = asSeparator "("

cParenT = asSeparator ")"

braces :: GenParser Char st a -> GenParser Char st a

braces p = oBraceT >> p << cBraceT

commaSep1 :: GenParser Char st a -> GenParser Char st [a]

commaSep1 p = fmap fst $ separatedBy p commaT

placeS :: GenParser Char st String

placeS = string place

placeT :: GenParser Char st Token

placeT = pToken (try (placeS) <?> place)