------------------------------------------------------------------ -- | -- Module : IdlConvert -- Copyright : (c) Dmitry Golubovsky, 2009 -- License : BSD-style -- -- Maintainer : golubovsky@gmail.com -- Stability : experimental -- Portability : portable -- -- -- -- Conversion of Web IDL to intermediate format. ------------------------------------------------------------------ module IdlConvert where import Data.List import Data.Maybe import Data.Either import qualified Data.Map as M import Control.Monad.RWS import Text.ParserCombinators.Parsec.Pos import Language.WebIDL import Language.WebIDL.PrettyPrint import IdlGlobal import IdlUtil import IdlFQMonad import IdlScopedName import BackJSMW -- The toplevel conversion procedure. It is invoked within a slave process, -- and is passed a set of options (the lower portion of the ICGlobal structure. -- IDL source (possibly preprocessed) is read from standard input, and written -- to the standard output (the master process takes care of redirection). idlToHs :: ICGlobal -> IO () idlToHs opts = do edefs <- lexStdin >>= return . parseIDL case edefs of Left e -> error $ show e Right spec -> do let hask = convmain opts spec putStrLn hask -- The main conversion procedure. It takes a list of definitions and -- returns a string representing the conversion results. convmain :: ICGlobal -> IDLSpecification -> String convmain opts spec = backJSMW opts $ flatqual opts spec' where spec' = map fwDecls spec ++ map fwTypes spec ++ spec -- Add fake forward declarations for each interface defined. This makes sure -- that all interfaces loaded are known to the converter: per recent updates in -- WebIDL, order of source loading should not matter. fwDecls :: IDLDefinition -> IDLDefinition fwDecls (IDLDefinition sp jd idd) = IDLDefinition sp jd (fw idd) where fw (IDLDefInterface itfn xattr inhr (Just ib)) = IDLDefInterface itfn [] [] Nothing fw (IDLDefModule mn xattr defs) = IDLDefModule mn xattr defs' where defs' = map fwDecls (filter fwdefs defs) fwdefs (IDLDefinition _ _ (IDLDefInterface _ _ _ _)) = True fwdefs (IDLDefinition _ _ (IDLDefModule _ _ _)) = True fwdefs _ = False fw z = z -- Add fake forward declarations for each type defined. This makes sure -- that all typedefs are known to the converter: per recent updates in -- WebIDL, order of source loading should not matter. fwTypes :: IDLDefinition -> IDLDefinition fwTypes (IDLDefinition sp jd idd) = IDLDefinition sp jd (fw idd) where fw (IDLDefModule mn xattr defs) = IDLDefModule mn xattr defs' where defs' = map fwDecls (filter fwdefs defs) fwdefs (IDLDefinition _ _ (IDLDefType _)) = True fwdefs _ = False fw z = z -- Flatten the modules defined, and give them all qualified (absolute scoped) names. -- Once a module definition is found, its name string will be modified based on -- the possibly present Prefix attribute and/or enclosing module name. flatqual :: ICGlobal -> [IDLDefinition] -> M.Map String IDLDef flatqual opts defs = let (a, s, w) = runRWS fq opts FQST {root = [] ,srcpos = [] ,defdecl = M.empty} nopos = newPos "" 0 0 fq = mapM qndef defs in case lefts w of [] -> defdecl s es -> error $ unlines es -- Utility functions. -- Find details of an extended attribute from a list of ext attributes. -- Multiple occurrences of the same attribute result in a list of details. findattr :: String -> [IDLExtAttr] -> [Maybe IDLExtAttrDetails] findattr an al = let fltattr (IDLExtAttr _ n ds) | an == n = [ds] fltattr _ = [] in concat $ map fltattr al -- Operation on a single definition. At this step, all definitions and imports are -- given qualified names as described in the section 3.1. qndef :: IDLDefinition -> FQ IDLDefinition qndef dm@(IDLDefinition sp jd df) = do dm'@(IDLDefinition sp jd df') <- qndef' sp jd df let dn = defName df' case df of IDLDefType _ -> return dm' -- these have been checked within qnexp' IDLDefConst _ -> return dm' -------------------""------------------- _ -> checkdup dn dm' -- Check for a duplicated definition after it has been given a qualified name. -- The definition's name is checked against the map of existng definitions. -- If definitions with such name does not exist, it is added to the map. -- Duplicates are allowed in following cases: -- * module may open and close any number of times -- * forward dectaration of an interface will be replaced with a full declaration -- In any other situation duplication of a definition results in an error. checkdup :: String -> IDLDefinition -> FQ IDLDefinition checkdup dn dm'@(IDLDefinition sp jd df') = do dfd <- gets defdecl let redef = M.lookup dn dfd ismod = isModule df' isitf = isInterface df' prpr = take 101 (prettyPrint [dm']) ellps = if (length prpr) == 101 then "..." else "" errdf = errMsg $ "redefinition of\n" ++ take 100 prpr ++ ellps ++ "\n" case (dn, redef, ismod, isitf) of ("", _, _, _) -> return dm' -- definition has no recognizable name, skip it (_, Nothing, _, _) -> do -- definition did not occur before, add to the list let dfd' = M.insert dn df' dfd modify (\st -> st {defdecl = dfd'}) return dm' (_, Just rd, True, True) -> error $ "impossible happened: " ++ dn ++ " is a module and an interface at the same time" (_, Just rd, True, False) -> -- modules can be reopened if isModule rd then return dm' else errdf >> return dm' (_, Just rd, False, True) -> -- normal interf. declaration replaces fwd declaration if isFwdInterface rd then do let dfd' = M.update (const $ Just df') dn dfd modify (\st -> st {defdecl = dfd'}) return dm' else errdf >> return dm' -- otherwsie treat as redefinition unless typedef (_, Just rd, False, False) -> case isTypeDef rd of True -> if rd == df' then return dm' else errdf >> return dm' False -> errdf >> return dm' qndef' sp jd md@(IDLDefModule modn xattr defs) = do pushpos sp ns <- gets root >>= return . root2ns let qmodn = ns ++ "::" ++ modn dfd <- gets defdecl let tmod = IDLDefModule qmodn xattr [] pushdef md qdefs <- mapM qndef defs popdef poppos return $ IDLDefinition sp jd $ IDLDefModule qmodn xattr qdefs -- Before going over an interface's body, pretend that it was already forward-declared. -- Thus its exports may refer to it recursively. qndef' sp jd ii@(IDLDefInterface modi xattr inhr mbib) = do pushpos sp ns <- gets root >>= return . root2ns let qmodi = ns ++ "::" ++ modi dfd <- gets defdecl qinhr <- mapM rsvsne inhr >>= mapM rssntype let fwdef = IDLDefInterface qmodi xattr qinhr Nothing dfd' = M.insert qmodi fwdef dfd modify (\st -> st {defdecl = dfd'}) pushdef $ IDLDefInterface modi xattr qinhr mbib qxattr <- mapM qnxattr xattr qmbib <- case mbib of Nothing -> return Nothing Just (IDLInterfaceBody ib) -> mapM qnexp ib >>= return . Just . IDLInterfaceBody popdef poppos return $ IDLDefinition sp jd $ IDLDefInterface qmodi qxattr qinhr qmbib qndef' sp jd cc@(IDLDefConst ic) = do pushpos sp (IDLExpConst qic) <- qnexp' (IDLExpConst ic) poppos return $ IDLDefinition sp jd $ IDLDefConst qic qndef' sp jd td@(IDLDefType dt) = do pushpos sp (IDLExpType qdt) <- qnexp' (IDLExpType dt) poppos return $ IDLDefinition sp jd (IDLDefType qdt) qndef' sp jd ex@(IDLDefExcept ec) = do pushpos sp (IDLExpExcept qec) <- qnexp' (IDLExpExcept ec) poppos return $ IDLDefinition sp jd (IDLDefExcept qec) qndef' sp jd df = return $ IDLDefinition sp jd df -- Resolve scoped names in an extended attribute. qnxattr :: IDLExtAttr -> FQ IDLExtAttr qnxattr (IDLExtAttr js an (Just dtls)) = do qdtls <- qnxdtl dtls return $ IDLExtAttr js an (Just $ qdtls) qnxattr z = return z -- Resolve scoped names in extended attribute details. If resolution of a scoped -- name in an IDLDetailSN fails, use the original identifier. qnxdtl :: IDLExtAttrDetails -> FQ IDLExtAttrDetails qnxdtl (IDLDetailSN scn) = rsvsn scn >>= return . IDLDetailSN qnxdtl (IDLDetailPD pdcls) = mapM qpdcl pdcls >>= return . IDLDetailPD qnxdtl (IDLDetailID str pdcls) = mapM qpdcl pdcls >>= return . IDLDetailID str -- Resolve a scoped name which can be a typedef to follow. rssntype :: IDLScopedName -> FQ IDLScopedName rssntype sn = do ipts <- rstype sn [] case ipts of IDLParamScopedSpec nsn -> return nsn _ -> return sn -- Operation on a single export. Export declarations also are given qualified names -- based on the name of the enclosing module. qnexp :: IDLExport -> FQ IDLExport qnexp (IDLExport sp jd ex) = do pushpos sp qex <- qnexp' ex poppos return $ IDLExport sp jd qex qnexp' (IDLExpConst (IDLConstDcl t cn e)) = do ns <- gets root >>= return . root2ns qt <- qconsttype t qe <- qexpr e let qcn = ns ++ "::" ++ cn qconst = IDLConstDcl qt qcn qe checkdup qcn $ IDLDefinition (newPos "" 0 0) (JavaDoc "") $ IDLDefConst qconst return $ IDLExpConst qconst -- With typedefs, check for redefinition here, since multiple names may be -- introduced here. qnexp' (IDLExpType (IDLTypeDef ts ds)) = do ns <- gets root >>= return . root2ns qts <- qntypespec ts let sp = newPos "" 0 0 qpx = ns ++ "::" qdsf d = case d of IDLSimpleDecl s -> do let qtdn = qpx ++ s qtd = IDLSimpleDecl qtdn checkdup qtdn $ IDLDefinition sp (JavaDoc "") (IDLDefType $ IDLTypeDef qts [qtd]) return qtd IDLComplexDecl (IDLArrayDeclarator s cs) -> do let qtdn = qpx ++ s qtd = IDLComplexDecl $ IDLArrayDeclarator qtdn cs checkdup qtdn $ IDLDefinition sp (JavaDoc "") (IDLDefType $ IDLTypeDef qts [qtd]) return qtd qds <- mapM qdsf ds return $ IDLExpType $ IDLTypeDef qts qds qnexp' (IDLExpExcept (IDLExceptDcl en ems)) = do ns <- gets root >>= return . root2ns let qen = ns ++ "::" ++ en return $ IDLExpExcept $ IDLExceptDcl qen ems qnexp' (IDLExpAttr (IDLAttrDcl xattr ro aps ai xget xset)) = do qxget <- mapM rsvsne xget qxset <- mapM rsvsne xset qaps <- qnptypespec aps return $ IDLExpAttr $ IDLAttrDcl xattr ro qaps ai qxget qxset qnexp' (IDLExpOp (IDLOpDcl xattr mbow aps oi pds xrai)) = do qxrai <- mapM rsvsne xrai qaps <- qnptypespec aps qpds <- mapM qpdcl pds return $ IDLExpOp $ IDLOpDcl xattr mbow qaps oi qpds qxrai qnexp' z = return z -- Resolve scoped names in a typespec. qntypespec :: IDLTypeSpec -> FQ IDLTypeSpec qntypespec (IDLSimpleSpec (IDLSimpleScoped sn)) = do qsn <- rsvsne sn return $ IDLSimpleSpec $ IDLSimpleScoped qsn qntypespec z = return z -- Resolve scoped names in a parameter typespec. qnptypespec :: IDLParamTypeSpec -> FQ IDLParamTypeSpec qnptypespec (IDLParamScopedSpec sn) = do qsn <- rsvsne sn tdf <- rstype qsn [] return tdf qnptypespec z = return z -- Resolve (when possible) a typedef into a target type. rstype :: IDLScopedName -> [String] -> FQ IDLParamTypeSpec rstype sn seen = do let psn = prtsn sn dfd <- gets defdecl let lkup = M.lookup psn dfd case lkup of Nothing -> return $ IDLParamScopedSpec sn Just (IDLDefInterface isn _ _ _) -> return $ IDLParamScopedSpec $ bldsn isn Just (IDLDefType (IDLTypeDef (IDLSimpleSpec (IDLSimpleBase sb)) [IDLSimpleDecl _])) -> return $ IDLParamBaseSpec sb Just (IDLDefType (IDLTypeDef (IDLSimpleSpec (IDLSimpleTmpl tpl)) [IDLSimpleDecl _])) -> do case tpl of IDLTmplSequence (IDLSequenceType (IDLSimpleScoped sqsn) mbc) -> do qsqsn <- rsvsne sqsn sqtype <- rstype qsqsn (psn : seen) case sqtype of IDLParamScopedSpec rssn -> return $ IDLParamTmplSpec $ IDLTmplSequence $ IDLSequenceType (IDLSimpleScoped rssn) mbc IDLParamTmplSpec itpl -> return $ IDLParamTmplSpec $ IDLTmplSequence $ IDLSequenceType (IDLSimpleTmpl itpl) mbc _ -> return $ IDLParamTmplSpec $ IDLTmplSequence $ IDLSequenceType (IDLSimpleScoped qsqsn) mbc _ -> return $ IDLParamTmplSpec tpl Just (IDLDefType (IDLTypeDef (IDLSimpleSpec (IDLSimpleScoped tdsn)) [IDLSimpleDecl _])) -> do let ptdsn = prtsn tdsn case ptdsn `elem` seen of True -> do errMsg $ "circular type dependency for " ++ psn ++ " -> " ++ ptdsn return (IDLParamScopedSpec sn) False -> rstype tdsn (psn : seen) Just t -> do errMsg $ "type for " ++ prtsn sn ++ " cannot be resolved" return (IDLParamScopedSpec sn) -- Resolve scoped names in parameter declaration. qpdcl :: IDLParamDcl -> FQ IDLParamDcl qpdcl (IDLParamDcl xattr pattr pts mbel pi) = do qpts <- qnptypespec pts return $ IDLParamDcl xattr pattr qpts mbel pi -- Resolve scoped names in constant type. qconsttype :: IDLConstType -> FQ IDLConstType qconsttype (IDLConstTypeScoped sn) = rsvsne sn >>= return . IDLConstTypeScoped qconsttype z = return z -- Resolve scoped names in expressions. Follow named expresions and insert them into -- parent expressions down to primitive values. qexpr :: IDLConstExp -> FQ IDLConstExp qexpr (IDLBinExp bop e1 e2) = do qe1 <- qexpr e1 qe2 <- qexpr e2 return $ IDLBinExp bop qe1 qe2 qexpr (IDLUnaryExp uop e) = qexpr e >>= return . IDLUnaryExp uop qexpr (IDLParenExp e) = qexpr e >>= return . IDLParenExp qexpr (IDLPrimScoped sn) = do qsn <- rsvsne sn dfd <- gets defdecl let lkup = M.lookup (prtsn qsn) dfd case lkup of Nothing -> return $ IDLPrimScoped qsn Just (IDLDefConst (IDLConstDcl _ _ e)) -> case e of IDLPrimScoped sn' -> qexpr (IDLPrimScoped sn') IDLParenExp _ -> return e IDLPrimLit _ -> return e _ -> return $ IDLParenExp e Just _ -> do errMsg $ prtsn qsn ++ " is not a constant" return $ IDLPrimScoped qsn qexpr z = return z