AnnoParser.hs revision e9458b1a7a19a63aa4c179f9ab20f4d50681c168
{- |
Module : ./Common/AnnoParser.hs
Description : parsers for annotations and annoted items
Copyright : (c) Klaus Luettich, Christian Maeder and Uni Bremen 2002-2006
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Christian.Maeder@dfki.de
Stability : provisional
Portability : portable
Parsers for annotations and annoted items
Follows Chap. II:5 of the CASL Reference Manual.
uses Lexer, Keywords and Token rather than CaslLanguage
semantic annotations now end immediately after the keyword!
-}
module Common.AnnoParser
( annotationL
, annotations
, fromPos
, parseAnno
, parseAnnoId
, commentLine
, newlineOrEof
) where
import Text.ParserCombinators.Parsec.Pos as Pos
import Common.Parsec
import Common.Lexer
import Common.Token
import Common.Id as Id
import Common.IRI as IRI
import Common.Keywords
import Common.AS_Annotation
import Common.Utils (trimRight)
import qualified Data.Map as Map
import Data.List
comment :: GenParser Char st Annotation
comment = commentLine <|> commentGroup
parseAnnoId :: GenParser Char st Id
parseAnnoId = let keys = ([], []) in mixId keys keys
charOrEof :: Char -> GenParser Char st ()
charOrEof c = forget (char c) <|> eof
newlineOrEof :: GenParser Char st ()
newlineOrEof = lookAhead $ charOrEof '\n'
mkLineAnno :: String -> Annote_text
mkLineAnno s = let r = unwords $ words s in Line_anno $
[' ' | not (null r) && isPrefixOf " " s] ++ r
commentLine :: GenParser Char st Annotation
commentLine = do
p <- getPos
tryString percents
line <- manyTill anyChar newlineOrEof
q <- getPos
return $ Unparsed_anno Comment_start (mkLineAnno line) (Range [p, dec q])
dec :: Pos -> Pos
dec p = Id.incSourceColumn p (-1)
mylines :: String -> [String]
mylines s = let strip = unwords . words in
case lines s ++ ["" | isSuffixOf "\n" s] of
[] -> []
[x] -> let x0 = strip x in
[if null x0 then x0
else [' ' | head x == ' '] ++ x0 ++ [' ' | last x == ' ']]
(x : r) ->
let x0 = strip x
e = last r
e0 = strip e
needsBlank = not (null x0) && head x == ' '
addBlank y = [' ' | not (null y) && needsBlank] ++ y
in addBlank x0 : map (addBlank . strip) (init r)
++ [if null e then e
else if null e0 then [' ' | needsBlank]
else addBlank e0 ++ [' ' | last e == ' ']]
commentGroup :: GenParser Char st Annotation
commentGroup = do
p <- getPos
textLines <- plainBlock "%{" "}%"
q <- getPos
return $ Unparsed_anno Comment_start
(Group_anno $ mylines textLines) (Range [p, dec q])
annote :: GenParser Char st Annotation
annote = annoLabel <|> do
p <- getPos
i <- try annoIdent
anno <- annoteGroup p i <|> annoteLine p i
case parseAnno anno p of
Left err -> do
setPosition (errorPos err)
fail (tail (showErrorMessages "or" "unknown parse error"
"expecting" "unexpected" "end of input"
(errorMessages err)))
Right pa -> return pa
annoLabel :: GenParser Char st Annotation
annoLabel = do
p <- getPos
labelLines <- plainBlock "%(" ")%"
q <- getPos
return $ Label (mylines labelLines) $ Range [p, dec q]
annoIdent :: GenParser Char st Annote_word
annoIdent = fmap Annote_word $ string percentS >>
(scanAnyWords <|>
fail "wrong comment or annotation starting with a single %")
annoteGroup :: Pos -> Annote_word -> GenParser Char st Annotation
annoteGroup p s =
let aP = do
annoteLines <- plainBlock "(" ")%"
q <- getPos
return $ Unparsed_anno s (Group_anno $ mylines annoteLines)
$ Range [p, dec q]
in case s of
Annote_word w -> case lookup w $ swapTable semantic_anno_table of
Just sa -> return $ Semantic_anno sa
$ Range [p, Id.incSourceColumn p $ length (show sa) - 3]
Nothing -> aP
_ -> aP
annoteLine :: Pos -> Annote_word -> GenParser Char st Annotation
annoteLine p s = do
line <- manyTill anyChar newlineOrEof
q <- getPos
return $ Unparsed_anno s (mkLineAnno line) $ Range [p, dec q]
annotationL :: GenParser Char st Annotation
annotationL = comment <|> annote <?> "\"%\""
annotations :: GenParser Char st [Annotation]
annotations = many (annotationL << skip)
{- ---------------------------------------
parser for the contents of annotations
--------------------------------------- -}
commaIds :: GenParser Char st [Id]
commaIds = commaSep1 parseAnnoId
parseAnno :: Annotation -> Pos -> Either ParseError Annotation
parseAnno anno sp = case anno of
Unparsed_anno (Annote_word kw) txt qs -> let
nsp = Id.incSourceColumn sp (length kw + 1)
inp = annoArg txt
mkAssoc dir p = do
res <- p
return (Assoc_anno dir res qs)
in Map.findWithDefault (Right anno) kw $ Map.map ( \ p ->
parseInternal p nsp inp) $ Map.fromList
[ (left_assocS, mkAssoc ALeft commaIds)
, (right_assocS, mkAssoc ARight commaIds)
, (precS , precAnno qs)
, (displayS , displayAnno qs)
, (numberS , numberAnno qs)
, (stringS , stringAnno qs)
, (listS , listAnno qs)
, (floatingS, floatingAnno qs)
, (prefixS, prefixAnno qs)]
_ -> Right anno
fromPos :: Pos -> SourcePos
parseInternal :: GenParser Char () a -> Pos -> String -> Either ParseError a
parseInternal p sp = parse
(do
setPosition $ fromPos sp
spaces
res <- p
eof
return res) (Id.sourceName sp)
checkForPlaces :: [Token] -> GenParser Char st [Token]
checkForPlaces ts =
do let ps = filter isPlace ts
if null ps then nextListToks $ topMix3 ([], [])
-- topMix3 starts with square brackets
else if isSingle ps then return []
else unexpected "multiple places"
nextListToks :: GenParser Char st [Token] -> GenParser Char st [Token]
nextListToks f =
do ts <- f
cs <- checkForPlaces ts
return (ts ++ cs)
caslListBrackets :: GenParser Char st Id
caslListBrackets =
do l <- nextListToks $ afterPlace ([], [])
(c, p) <- option ([], nullRange) $ comps ([], [])
return $ Id l c p
precAnno, numberAnno, stringAnno, listAnno, floatingAnno
:: Range -> GenParser Char st Annotation
precAnno ps = do
leftIds <- braces commaIds
sign <- (tryString "<>" <|> string "<") << spaces
rightIds <- braces commaIds
return $ Prec_anno
(if sign == "<" then Lower else BothDirections)
leftIds
rightIds
ps
numberAnno ps = do
n <- parseAnnoId
return $ Number_anno n ps
listAnno ps = do
bs <- caslListBrackets
commaT
ni <- parseAnnoId
commaT
ci <- parseAnnoId
return $ List_anno bs ni ci ps
stringAnno ps = literal2idsAnno ps String_anno
floatingAnno ps = literal2idsAnno ps Float_anno
prefixAnno :: Range -> GenParser Char st Annotation
prefixAnno ps = do
prefixes <- many $ do
p <- (string colonS >> return "") <|>
(IRI.ncname << string colonS)
spaces
i <- angles iri
spaces
return (p, i)
return $ Prefix_anno prefixes ps
literal2idsAnno :: Range -> (Id -> Id -> Range -> Annotation)
-> GenParser Char st Annotation
literal2idsAnno ps con = do
i1 <- parseAnnoId
commaT
i2 <- parseAnnoId
return $ con i1 i2 ps
displayAnno :: Range -> GenParser Char st Annotation
displayAnno ps = do
ident <- parseAnnoId
tls <- many $ foldl1 (<|>) $ map dispSymb display_format_table
return (Display_anno ident tls ps)
dispSymb :: (Display_format, String)
-> GenParser Char st (Display_format, String)
dispSymb (dfSymb, symb) = do
tryString (percentS ++ symb) << spaces
str <- manyTill anyChar $ lookAhead $ charOrEof '%'
return (dfSymb, trimRight str)