{-# 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 ""
