{- 
  Parser.hs: Parser for the Hamlet language 

  Copyright (c) 2009, ETH Zurich.
  All rights reserved.
  
  This file is distributed under the terms in the attached LICENSE file.
  If you do not find this file, copies can be found by writing to:
  ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group.
-}
  
module Parser where

import HamletAst

import Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec.Expr
import Text.ParserCombinators.Parsec.Pos
import Text.ParserCombinators.Parsec.Char as C
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language( javaStyle )
import Data.Char
import Numeric
import Data.List
import Data.Maybe
import Text.Printf

import System.Environment
import System.Exit
import System.Console.GetOpt
import System.IO
import System.FilePath.Posix


parseCaps filename = parseFromFile capsFile filename

lexer = P.makeTokenParser $! (javaStyle
                              { P.reservedNames = [ "is_always_copy"
                                                  , "is_never_copy"
                                                  , "from"
                                                  , "can_retype_multiple"
                                                  ]
                              , P.reservedOpNames = ["+"]
                              , P.identLetter = C.alphaNum <|> C.char '_'
                              })

whiteSpace = P.whiteSpace lexer 
reserved   = P.reserved lexer
identifier = P.identifier lexer
reservedOp = P.reservedOp lexer
integer    = P.integer lexer
stringLit  = P.stringLiteral lexer
comma      = P.comma lexer
commaSep   = P.commaSep lexer
commaSep1  = P.commaSep1 lexer
parens     = P.parens lexer
braces     = P.braces lexer
brackets   = P.brackets lexer
semiSep    = P.semiSep lexer
symbol     = P.symbol lexer

missingSep name = 
    symbol ";" <?> " ';' missing from end of " ++ name

capsFile = 
    do 
      whiteSpace
      defs <- many definesCst
      caps <- capDefFold []
      return $ Capabilities defs (nonAbsCaps caps) (absCaps caps)
    where
      capDefFold caps = do cap <- capabilitiesDef caps
                           capDefFold (cap:caps)
                        <|> (return $ reverse caps)
      nonAbsCaps = filter (\c -> not $ abstract c)
      absCaps = filter (\c -> abstract c)

-- parse global definition
definesCst =
    do
      reserved "define"
      name <- identifier
      val <- integer
      missingSep (name ++ " define")
      return $! Define name (fromInteger val)

parseAbstract = do
    (reserved "abstract" >> (return $ True))
    <|> (return False)

parseInherit caps = do
        (do reserved "inherit"
            from <- choice $ map (\s -> reserved s >> return s) capNames
            return $ Just $ findCap from)
        <|> (return Nothing)
    where
        capNames = map (\(CapName n) -> n) $ map name caps
        findCap name' = fromMaybe (error $ show name') $ find (\c -> name c == CapName name') caps

-- parse a single capability definition
capabilitiesDef caps =
    do 
      reserved "cap"
      name <- identifier
      geq <- generalEqualityP name
      from <- if isNothing geq then fromP caps else return Nothing
      fromSelf <- if isNothing geq then fromSelfP name else return False
      abstract <- parseAbstract
      inheritCap <- parseInherit caps
      (fields', rangeExpr', eqFields', multi', needsType') <- ((braces $ capabilityDef name inheritCap)
        <|> if isJust inheritCap then do
                let c = fromJust inheritCap
                return (fields c, rangeExpr c, eqFields c, multiRetype c, False)
            else unexpected ("Missing {} block"))
      missingSep ("cap " ++ name ++ " definition")
      let inheritName = maybe Nothing inherit inheritCap
      return $ Capability (CapName name) geq from fromSelf multi' fields' rangeExpr' eqFields' abstract needsType' inheritName

-- parse optional general equality (always/never copy)
generalEqualityP name = do
    (reserved "is_always_copy" >> (return $ Just True))
    <|> (reserved "is_never_copy" >> (return $ Just False))
    <|> (return Nothing)

-- parse optional "from <base cap name>"
fromP caps = withFromP <|> return Nothing
    where withFromP = do
            reserved "from"
            from <- choice $ map (\s -> reserved s >> return s) capNames
            return $ Just $ CapName from
          capNames = map (\(CapName n) -> n) $ map name caps

-- parse optional "from_self"
fromSelfP name = (reserved "from_self" >> (return True)) <|> (return False)

-- parse the body of a capability definition
capabilityDef name inheritCap = do

    -- check for "can_retype_multiple"
    multi <- (do reserved "can_retype_multiple"
                 missingSep ("can_retype_multiple in " ++ name)
                 return True)
             <|> (return $ maybe False multiRetype inheritCap)
    -- read sequence of field, address, size, and equality definitions
    annotatedFields <- many $ capFieldOrExpr name
    (fields, addresses, sizes, eqExprs) <- return $ unzipDefs annotatedFields

    -- lengths to check
    let numAddrs = length addresses
        numSizes = length sizes

    -- check that there are either 0 or 1 of both address and size definitions
    if numAddrs > 1
       then unexpected ("multiple address definitions for cap " ++ name)
       else return ()
    if numSizes > 1
       then unexpected ("multiple size definitions for cap " ++ name)
       else return ()
    if numAddrs < 1 && numSizes > 0
       then unexpected ("have size definition but no address definition for cap " ++ name)
       else return ()

    -- merge address and size expressions if present
    let rangeExpr' = if null addresses
                       then maybe Nothing rangeExpr inheritCap
                       else Just $
                         if null sizes
                            then (head addresses, ZeroSize)
                            else (head addresses, head sizes)
    return (fields, rangeExpr', eqExprs, multi, True)

  where
    -- un-maybe lists from capfields parsing
    unzipDefs annotatedFields = (fs, as, ss, es)
      where fs = maybe [] fields inheritCap ++ catMaybes afs
            as = eitherOr (catMaybes aas) fst
            ss = eitherOr (catMaybes ass) snd
            es = maybe [] eqFields inheritCap ++ catMaybes ess
            (afs, aas, ass, ess) = unzip4 annotatedFields
            eitherOr :: [a] -> ((AddressExpr, SizeExpr) -> a) -> [a]
            eitherOr a what = if null a then
                    map (what) $
                    maybeToList $
                    maybe Nothing (rangeExpr) inheritCap
                else a

capFieldOrExpr name = (reserved "address" >> (addrField <|> addrExpr))
                      <|>
                      (((reserved "size" >> (return False)) <|>
                        (reserved "size_bits" >> (return True)))
                       >>= (\isBits -> sizeField isBits <|> sizeExpr isBits))
                      <|>
                      (reserved "eq" >> eqField)
                      <|>
                      regField
    where
      addrField = do
        -- handle field marked as address
        field <- capTypeField
        return $
          let expr = AddressExpr $ NameExpr $ fieldName field
          in (Just field, Just expr, Nothing, Nothing)
      addrExpr = do
        -- handle address expression
        addrExpr <- braces addressExprP
        missingSep ("address definition for " ++ name)
        return (Nothing, Just addrExpr, Nothing, Nothing)
      sizeField isBits = do
        -- handle field marked as size or size_bits
        field <- capTypeField
        return $
          let mkSize = if isBits then SizeBitsExpr else SizeExpr
              expr = mkSize $ NameExpr $ fieldName field
          in (Just field, Nothing, Just expr, Nothing)
      eqField = do
        -- handle field marked as eq
        field <- capTypeField
        return (Just field, Nothing, Nothing, Just $ NameField $ fieldName field)
      sizeExpr isBits = do
        -- handle size expression
        expr <- braces (if isBits then sizeBitsExprP else sizeExprP)
        missingSep ("size definition for " ++ name)
        return (Nothing, Nothing, Just expr, Nothing)
      regField = do
        -- handle regular field
        field <- capTypeField
        return (Just field, Nothing, Nothing, Nothing)
      fieldName (CapField _ (NameField n)) = n

-- parse cap field (name, type, semicolon)
capTypeField = do
    typ <- stringLit <|> identifier
    name <- identifier
    missingSep ("field " ++ name)
    return $ CapField (read typ) (NameField name)

-- parse address expression
addressExprP = (reserved "mem_to_phys" >> parens exprP >>= (return . MemToPhysOp))
               <|> (reserved "get_address" >> parens exprP >>= (return . GetAddrOp))
               <|> (exprP >>= (return . AddressExpr))
-- parse size expression
sizeExprP = exprP >>= (return . SizeExpr)
-- parse size_bits expression
sizeBitsExprP = exprP >>= (return . SizeBitsExpr)
-- parse subexpression for the above
exprP = do
    left <- identifier
    (do reservedOp "+"
        right <- identifier
        return $ AddExpr left right
     <|> (return $ NameExpr left))
