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