{- |
Module      :  $Header$
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
import Text.ParserCombinators.Parsec.Error
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
fromPos p = Pos.newPos (Id.sourceName p) (Id.sourceLine p) (Id.sourceColumn p)

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 <- char '<' >> iri << char '>'
        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)
