content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  {- |
  Module      :  ./VSE/Parse.hs
  Description :  parsing VSE parts
  Copyright   :  (c) C. Maeder, DFKI Bremen 2008
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  Parser for VSE logic extension of CASL
  -}
  
  module VSE.Parse where
  
  import Common.AnnoState
  import Common.DocUtils
  import Common.Id
  import Common.Lexer
  import Common.Result
  import Common.Token
  import VSE.As
  import Text.ParserCombinators.Parsec
  import CASL.Formula
  import CASL.AS_Basic_CASL
  import Data.Char (toUpper, toLower)
  
  declWords :: [String]
  declWords = let
    ps = ["procedure", "function"]
    rs = ps ++ map (++ "s") ps
    in rs ++ map (map toUpper) rs
  
  reservedWords :: [String]
  reservedWords = let
    rs =
      [ "in", "out", "begin", "end", "abort", "skip", "return", "declare"
      , "if", "then", "else", "fi", "while", "do", "od"
      , "defprocs", "defprocsend", "restricted" ]
    in [ "<:", ":>"] ++ declWords ++ rs ++ map (map toUpper) rs
  
  keyword :: String -> AParser st Token
  keyword s = pToken $ try $ do
     annos
     str <- scanAnyWords
     lineAnnos
     if map toLower str == s then return s else unexpected str <?> map toUpper s
  
  vseVarDecl :: AParser st VarDecl
  vseVarDecl = do
    v <- varId reservedWords
    c <- colonT
    s <- sortId reservedWords
    option (VarDecl v s Nothing $ tokPos c) $ do
      a <- asKey ":="
      t <- term reservedWords
      return $ VarDecl v s (Just t) $ toRange c [] a
  
  fromVarDecl :: [VarDecl] -> Program -> ([VAR_DECL], Program)
  fromVarDecl vs p = case vs of
    [] -> ([], p)
    VarDecl v s mt r : n ->
        let (rs, q) = fromVarDecl n p
        in (Var_decl [v] s r : rs, case mt of
             Nothing -> q
             Just t -> Ranged (Seq (Ranged (Assign v t) r) q) r)
  
  program :: AParser st Program
  program = do
      t <- keyword "abort"
      return $ Ranged Abort $ tokPos t
    <|> do
      t <- keyword "skip"
      return $ Ranged Skip $ tokPos t
    <|> do
      r <- keyword "return"
      t <- term reservedWords
      return $ Ranged (Return t) $ tokPos r
    <|> do
      b <- keyword "begin"
      p <- programSeq
      e <- keyword "end"
      return $ Ranged (Block [] p) $ toRange b [] e
    <|> do
      d <- keyword "declare"
      (vs, ps) <- separatedBy vseVarDecl commaT
      s <- anSemi
      p <- programSeq
      let (cs, q) = fromVarDecl vs p
      return $ Ranged (Block cs q) $ toRange d ps s
    <|> do
      i <- keyword "if"
      c <- formula reservedWords
      p <- keyword "then"
      t <- programSeq
      do r <- keyword "fi"
         let s = toRange i [p] r
         return $ Ranged (If c t $ Ranged Skip s) s
       <|> do
         q <- keyword "else"
         e <- programSeq
         r <- keyword "fi"
         return $ Ranged (If c t e) $ toRange i [p, q] r
    <|> do
      w <- keyword "while"
      c <- formula reservedWords
      d <- keyword "do"
      p <- programSeq
      o <- keyword "od"
      return $ Ranged (While c p) $ toRange w [d] o
    <|> do
      (v, a) <- try $ do
           v <- varId reservedWords
           a <- asKey ":="
           return (v, a)
      t <- term reservedWords
      return $ Ranged (Assign v t) $ tokPos a
    <|> do
      t <- term reservedWords
      return . Ranged (Call $ Mixfix_formula t) . Range $ rangeSpan t
  
  programSeq :: AParser st Program
  programSeq = do
    p1 <- program
    option p1 $ do
      s <- semiT
      p2 <- programSeq
      return $ Ranged (Seq p1 p2) $ tokPos s
  
  procKind :: AParser st (ProcKind, Token)
  procKind = do
      k <- keyword "procedure"
      return (Proc, k)
    <|> do
      k <- keyword "function"
      return (Func, k)
  
  defproc :: AParser st Defproc
  defproc = do
    (pk, q) <- procKind
    i <- parseId reservedWords
    o <- oParenT
    (ts, ps) <- option ([], []) $
         varId reservedWords `separatedBy` commaT
    c <- cParenT
    p <- program
    return $ Defproc pk i ts p $ toRange q (o : ps) c
  
  boxOrDiamandProg :: AParser st (Token, BoxOrDiamond, Program, Token)
  boxOrDiamandProg = do
      o <- asKey "<:"
      p <- programSeq
      c <- asKey ":>"
      return (o, Diamond, p, c)
    <|> do
      o <- asKey "[:"
      p <- programSeq
      c <- asKey ":]"
      return (o, Box, p, c)
  
  dlformula :: AParser st Dlformula
  dlformula = do
      p <- keyword "defprocs"
      (ps, qs) <- separatedBy defproc semiT
      q <- keyword "defprocsend"
      return $ Ranged (Defprocs ps) $ toRange p qs q
    <|> do
     (o, b, p, c) <- boxOrDiamandProg
     f <- formula reservedWords
     return $ Ranged (Dlformula b p f) $ toRange o [] c
  
  param :: AParser st Procparam
  param = do
      k <- (keyword "in" >> return In) <|> (keyword "out" >> return Out)
      s <- sortId reservedWords
      return $ Procparam k s
  
  profile :: AParser st Profile
  profile = do
    (ps, _) <- option ([], []) $ separatedBy param commaT
    m <- optionMaybe $ asKey "->" >> sortId reservedWords
    return $ Profile ps m
  
  procdecl :: AParser st Sigentry
  procdecl = do
    i <- parseId reservedWords
    c <- colonT
    p <- profile
    return $ Procedure i p $ tokPos c
  
  procdecls :: AParser st Procdecls
  procdecls = do
    k <- keyword "procedures" <|> keyword "procedure"
    auxItemList (declWords ++ startKeyword) [k] procdecl Procdecls
  
  instance TermParser Dlformula where
    termParser = aToTermParser dlformula
  
  instance AParsable Procdecls where
    aparser = procdecls
  
  -- | just for testing
  testParse :: String -> String
  testParse str = case runParser (formula [] :: AParser () Sentence)
      (emptyAnnos ()) "" str of
    Left err -> showErr err
    Right ps -> showDoc ps ""
  