domconv-jsmw.hs

-- DOM interface converter: a tool to convert Haskell files produced by
-- H/Direct into properly structured DOM wrapper

module Main where

import Prelude hiding (putStrLn)
import System.Environment.UTF8
import System.Directory
import System.FilePath
import System.Exit
import System.IO (stdin, stderr, readFile, openFile, IOMode (..))
import System.IO.UTF8
import Control.Monad
import Data.Maybe
import Data.Either
import Data.List
import Data.Char
import Language.Haskell.Pretty
import Language.Preprocessor.Cpphs
import BrownPLT.JavaScript
import qualified Language.Haskell.Syntax as H
import qualified Data.Map as M
import qualified Data.Set as S
import qualified OmgParser
import LexM
import Literal
import qualified IDLSyn as I
import IDLUtils
import BasicTypes
import SplitBounds


main = do
  args <- getArgs
  let epopts = parseOptions args
  case epopts of
    Left s -> do
      hPutStrLn stderr $ "domconv: command line parse error " ++ s
      exitWith (ExitFailure 1)
    Right opts -> procopts opts

procopts opts = do
  let cppfiles = infiles opts
      (hsrc, inclfile) =
        case cppfiles of
          [] -> (hGetContents stdin, "<stdin>")
          ["-"] -> (hGetContents stdin, "<stdin>")
          (a:_) -> (openFile a ReadMode >>= hGetContents, a)
  let baseopt = [("boolean", "Bool")]
      optsb = opts {defines = ((defines opts) ++ baseopt)
                   ,boolopts = ((boolopts opts) {pragma = True}) }
  hsrc' <- hsrc
  let hsrcpr = runCpphs optsb inclfile hsrc'
  x <- runLexM [] inclfile hsrcpr OmgParser.parseIDL
  let showMod (I.Module i d) = do
        putStrLn $ "module" ++ show i
        mapM (putStrLn . show) d
        return ()
      showMod _ = return ()
  putStrLn "{--"
  mapM showMod x
  putStrLn "--}"
  let prntmap = mkParentMap x
  let valmsg = valParentMap prntmap
  when (length valmsg > 0) $ do
    mapM_ (hPutStrLn stderr) valmsg
    exitWith (ExitFailure 2)
  let modst = DOMState {
         pm = prntmap
        ,imp = []
        ,ns = "Data.DOM." -- this will be the default namespace unless a pragma namespace is used.
        ,procmod = []
        ,convlog = []
      }
      modst' = domLoop modst x
  mapM_ (hPutStrLn stderr) (convlog modst')
  let splitmod = splitModule (head $ procmod modst')
  mapM_ putSplit splitmod



-- Retrieve a module name as a string from Module

modName :: H.Module -> String

modName m = read $ drop 1 $ dropWhile (not . isSpace) (show m)

-- Get a module namespace (all elements of name separated with dots except
-- the last one)

modNS :: String -> String

modNS mn = concat $ intersperse "." mnpts where
  mnpts = case (reverse $ parts (== '.') mn) of
    [] -> []
    [_] -> []
    (p:ps) -> reverse ps

-- Write a module surrounded by split begin/end comments

putSplit :: H.HsModule -> IO ()

putSplit mod@(H.HsModule _ modid _ _ _) = do
  putStrLn $ "\n" ++ splitBegin ++ "/" ++ (modName modid) ++ "\n"
  putStrLn $ prettyPrint mod
  putStrLn $ "\n" ++ splitEnd ++ "\n"

-- Split a proto-module created by domLoop. All class, data, and instance definitions
-- remain in the "head" class. All methods are grouped by their `this' argument
-- context and placed into modules with the name of that context (first character removed).
-- All modules get the same imports that the "head" module has plus the "head" module itself.

splitModule :: H.HsModule -> [H.HsModule]

splitModule (H.HsModule _ modid mbexp imps decls) = headmod : submods where
  headns = modNS $ modName modid
  headmod = H.HsModule nullLoc modid headexp imps headdecls
  headdecls = datas ++ classes ++ instances
  headexp = Just $ map (mkEIdent . declname) (datas ++ classes)
  datas = filter datadecl decls
  datadecl (H.HsDataDecl _ _ _ _ _ _) = True
  datadecl (H.HsNewTypeDecl _ _ _ _ _ _) = True
  datadecl _ = False
  classes = filter classdecl decls
  classdecl (H.HsClassDecl _ _ _ _ _) = True
  classdecl _ = False
  instances = filter instdecl decls
  instdecl (H.HsInstDecl _ _ _ _ _) = True
  instdecl _ = False
  expname (H.HsEVar (H.UnQual (H.HsIdent s))) = s
  expname _ = ""
  declname (H.HsDataDecl _ _ (H.HsIdent s) _ _ _) = s
  declname (H.HsNewTypeDecl _ _ (H.HsIdent s) _ _ _) = s
  declname (H.HsClassDecl _ _ (H.HsIdent s) _ _) = s
  declname (H.HsTypeSig _ [H.HsIdent s] _) = s
  declname (H.HsFunBind [H.HsMatch _ (H.HsIdent s) _ _ _]) = s
  declname _ = ""
  mtsigs = filter methtsig (reverse decls)
  methtsig (H.HsTypeSig _ _ _) = True
  methtsig (H.HsFunBind _) = True
  methtsig _ = False
  corrn = drop 1 . dropWhile (/= '|')
  methcorrn (H.HsTypeSig x [H.HsIdent s] y) = H.HsTypeSig x [H.HsIdent (corrn s)] y
  methcorrn (H.HsFunBind [H.HsMatch x (H.HsIdent s) y z t]) =
    H.HsFunBind [H.HsMatch x (H.HsIdent (corrn s)) y z t]
  methcorrn z = z
  methassoc meth =
    let i = ns ++ takeWhile (/= '|') (declname meth)
        ns = case headns of
          "" -> ""
          mns -> mns ++ "."
    in (i, methcorrn meth)
  methmap = mkmethmap M.empty (map methassoc mtsigs)
  mkmethmap m [] = m
  mkmethmap m ((i, meth) : ims) = mkmethmap addmeth ims where
    addmeth = case M.lookup i m of
      Nothing -> M.insert i [meth] m
      (Just meths) -> M.insert i (meth : meths) m
  submods = M.elems $ M.mapWithKey mksubmod methmap
  mksubmod iid smdecls =
    H.HsModule nullLoc (H.Module iid) (Just subexp)
               (mkModImport modid : (imps ++ docimp)) smdecls where
      subexp = map mkEIdent $ nub $ filter (not . isSuffixOf "'") $ map declname smdecls
      docimp = case "createElement" `elem` (map declname smdecls) of
        True -> []
        _ -> [(mkModImport (H.Module docmod))
               {H.importSpecs = Just (False, [H.HsIVar $ H.HsIdent "createElement"])}] where
          docmod = concat $ intersperse "." $ reverse
                   ("Document" : tail (reverse $ parts (== '.') iid))


-- Loop through the list of toplevel parse results (modules, pragmas).
-- Pragmas modify state, modules don't.

domLoop :: DOMState -> [I.Defn] -> DOMState

domLoop st [] = st
domLoop st (def : defs) = case def of
  I.Pragma prgm -> domLoop (prgm2State st (dropWhile isSpace prgm)) defs
  I.Module id moddef ->
    let prmod = mod2mod st (I.Module id' moddef)
        modn = ns st ++ (renameMod $ concat $ intersperse "." $
                           reverse $ parts ( == '.') (getDef def))
        id' = I.Id modn
        imp' = modn : imp st
        modl = prmod : (procmod st) in
    domLoop st {procmod = modl, imp = imp'} defs
  z ->
    let logmsg = "Expected a Module or a Pragma; found " ++ (show z) in
    domLoop st {convlog = convlog st ++ [logmsg]} defs

-- Modify DOMState based on a pragma encountered

prgm2State :: DOMState -> String -> DOMState

prgm2State st ('n':'a':'m':'e':'s':'p':'a':'c':'e':nns) =
  let nnsst = read (dropWhile isSpace nns)
      dot = if length nnsst == 0 then "" else "." in
  st {ns = nnsst ++ dot}

prgm2State st upgm =
  let logmsg = "Unknown pragma " ++ upgm in
  st {convlog = convlog st ++ [logmsg]}

-- Validate a map of interface inheritance. Any "Left" parent identifier
-- causes a log message to be produced. It is also checked that an interface
-- does not have itself as a parent. Circular inheritance is not checked.

valParentMap :: M.Map String [Either String String] -> [String]

valParentMap pm = concat (M.elems m2) where
  m2 = M.mapWithKey lefts pm
  lefts intf parents = concat $ map (leftmsg intf) parents
  leftmsg intf (Right _) = []
  leftmsg intf (Left p) = ["Interface " ++ intf ++ " has " ++ p ++ " as a parent, but " ++
                           p ++ " is not defined anywhere"]

-- Prepare a complete map of interfaces inheritance. All ancestors
-- must be defined in the IDL module being processed plus in other
-- modules it includes.

mkParentMap :: [I.Defn] -> M.Map String [Either String String]

mkParentMap defns = m2 where
  allintfs = nub $ concat $ map getintfs defns
  getintfs (I.Module _ moddefs) = filter intfOnly moddefs
  getintfs _ = []
  m1 = M.fromList $ zip (map getDef allintfs) allintfs
  m2 = M.fromList (map getparents allintfs)
  getparents i@(I.Interface _ supers _) = (getDef i, concat $ map parent supers)
  parent pidf = case (pidf `M.member` m1) of
    True  -> (Right pidf) : snd (getparents (fromJust $ M.lookup pidf m1))
    False -> [Left pidf]


-- Fake source location

nullLoc = H.SrcLoc {H.srcFilename = "", H.srcLine = 0, H.srcColumn = 0}

-- A list of single-letter formal argument names (max. 26)

azList = map (: []) ['a' .. 'z']

azHIList = map H.HsIdent azList

-- Rename a module. First character of module name is uppercased. Each
-- underscore followed by a character causes that character uppercased.

renameMod :: String -> String

renameMod "" = ""
renameMod (m:odule) = toUpper m : renameMod' odule where
  renameMod' "" = ""
  renameMod' ('_':o:dule) = '.' : toUpper o : renameMod' dule
  renameMod' ('.':o:dule) = '.' : toUpper o : renameMod' dule
  renameMod' (o:dule) = o : renameMod' dule

-- Module converter mutable state (kind of)

data DOMState = DOMState {
   pm :: M.Map String [Either String String] -- inheritance map
  ,imp :: [String]                           -- import list
  ,ns :: String                              -- output module namespace (#pragma namespace)
  ,procmod :: [H.HsModule]                   -- modules already processed
  ,convlog :: [String]                       -- conversion messages
} deriving (Show)


-- Helpers to produce class and datatype identifiers out of DOM identifiers

classFor s = "C" ++ s
typeFor  s = "T" ++ s

-- Convert an IDL module definition into Haskell module syntax

mod2mod :: DOMState -> I.Defn -> H.HsModule

mod2mod st md@(I.Module _ moddefs) =
  H.HsModule nullLoc (H.Module modid') (Just []) imps decls where
    modlst = ["Control.Monad"
             ,"BrownPLT.JavaScript"
             ,"Data.DOM.WBTypes"]
    modid' = renameMod $ getDef md
    imps = map mkModImport (map H.Module (modlst ++ imp st))
    intfs = filter intfOnly moddefs
    eqop op1 op2 = getDef op1 == getDef op2
    decls = types ++ classes ++ instances ++ methods ++ attrs ++ makers
    makers  = concat $ map intf2maker intfs
    classes = concat $ map intf2class intfs
    methods = concat $ map intf2meth intfs
    types = concat $ map intf2type intfs
    attrs = concat $ map intf2attr intfs
    instances = concat $ map (intf2inst $ pm st) intfs

mod2mod _ z = error $ "Input of mod2mod should be a Module but is " ++ show z

-- Create a module import declaration

mkModImport :: H.Module -> H.HsImportDecl

mkModImport s = H.HsImportDecl {H.importLoc = nullLoc
                               ,H.importQualified = False
                               ,H.importModule = s
                               ,H.importAs = Nothing
                               ,H.importSpecs = Nothing}

-- For each interface, locate it in the inheritance map,
-- and produce instance declarations for the corresponding datatype.

intf2inst :: M.Map String [Either String String] -> I.Defn -> [H.HsDecl]

intf2inst pm intf@(I.Interface _ _ _) = self : parents where
  sid = getDef intf
  self = mkInstDecl sid sid
  parents = case M.lookup sid pm of
    Nothing -> []
    Just ess -> map (flip mkInstDecl sid) (map (either id id) ess)

intf2inst _ _ = []

-- For each interface found, define a newtype with the same name

intf2type :: I.Defn -> [H.HsDecl]


intf2type intf@(I.Interface _ _ _) =
  let typename = H.HsIdent (typeFor $ getDef intf) in
  [H.HsDataDecl nullLoc [] typename []
    [H.HsConDecl nullLoc typename []] []]

intf2type _ = []

-- Convert an Interface specification into a class specification

intf2class :: I.Defn -> [H.HsDecl]

intf2class intf@(I.Interface _ supers _) =
  [H.HsClassDecl nullLoc sups (H.HsIdent (classFor $ getDef intf)) (take 1 azHIList) []] where
    sups = map name2ctxt supers

intf2class _ = []

-- Convert a name to a type context assertion (assume single parameter class)

name2ctxt name = (mkUIdent $ classFor name, [H.HsTyVar $ head azHIList])

-- A helper function to produce an unqualified identifier

mkUIdent = H.UnQual . H.HsIdent

mkSymbol = H.UnQual . H.HsSymbol

-- A filter to select only operations (methods)

opsOnly :: I.Defn -> Bool
opsOnly (I.Operation _ _ _ _) = True
opsOnly _ = False

-- A filter to select only attributes

attrOnly :: I.Defn -> Bool
attrOnly (I.Attribute _ _ _) = True
attrOnly _ = False

-- A filter to select only interfaces (classes)

intfOnly :: I.Defn -> Bool
intfOnly (I.Interface _ _ cldefs) = True
intfOnly _ = False

-- A filter to select only constant definitions

constOnly :: I.Defn -> Bool
constOnly (I.Constant _ _ _ _) = True
constOnly _ = False

-- Collect all operations defined in an interface

collectOps :: I.Defn -> [I.Defn]

collectOps (I.Interface _ _ cldefs) =
  filter opsOnly cldefs

collectOps _ = []

-- Collect all constants defined in an interface

collectConst :: I.Defn -> [I.Defn]

collectConst (I.Interface _ _ cldefs) =
  filter constOnly cldefs

collectConst _ = []

-- Collect all attributes defined in an interface

collectAttrs :: I.Defn -> [I.Defn]

collectAttrs (I.Interface _ _ cldefs) =
  filter attrOnly cldefs

collectAttrs _ = []

-- Declare an instance (very simple case, no context, no methods only one class parameter)

mkInstDecl :: String -> String -> H.HsDecl

mkInstDecl clname typename =
  H.HsInstDecl nullLoc [] (mkUIdent $ classFor clname) [mkTIdent $ typeFor typename] []

-- For certain interfaces (ancestors of HTMLElement), special maker functions
-- are introduced to simplify creation of the formers.

intf2maker :: I.Defn -> [H.HsDecl]

intf2maker intf@(I.Interface (I.Id iid) _ _) =
  case (tagFor iid) of
    "" -> []
    tag -> [mktsig, mkimpl] where
      mkimpl =
        let defmaker = iid ++ "|mk" ++ renameMod tag
            flipv = mkVar "flip"
            crelv = mkVar "createElement"
            exprv = mkVar "StringLit"
            tags  = H.HsLit (H.HsString tag)
            tagv  = H.HsApp (H.HsApp exprv tags) tags
            rhs = H.HsUnGuardedRhs (H.HsApp crelv $ H.HsParen tagv)
            match = H.HsMatch nullLoc (H.HsIdent defmaker) [] rhs [] in
        H.HsFunBind [match]
      mktsig =
        let monadtv = mkTIdent "mn"
            exprtv = mkTIdent "Expression"
            defmaker = iid ++ "|mk" ++ renameMod tag
            parms = [H.HsIdent "a"]
            actx = (mkUIdent (classFor "HTMLDocument"),[mkTIdent "a"])
            monadctx = (mkUIdent "Monad",[monadtv])
            tpsig = mkTsig (map (H.HsTyApp exprtv . H.HsTyVar) parms)
                           (H.HsTyApp monadtv $ H.HsTyApp exprtv (mkTIdent (typeFor iid)))
            retts = H.HsQualType (monadctx : actx : []) tpsig in
        H.HsTypeSig nullLoc [H.HsIdent defmaker] retts

intf2maker _ = []

-- Tag values corresponding to certain HTML element interfaces

tagFor "HTMLButtonElement" = "button"
tagFor "HTMLDivElement" = "div"
tagFor "HTMLImageElement" = "img"
tagFor "HTMLAppletElement" = "applet"
tagFor "HTMLFontElement" = "font"
tagFor "HTMLFormElement" = "form"
tagFor "HTMLFrameElement" = "frame"
tagFor "HTMLInputElement" = "input"
tagFor "HTMLObjectElement" = "object"
tagFor "HTMLParagraphElement" = "p"
tagFor "HTMLParamElement" = "param"
tagFor "HTMLPreElement" = "pre"
tagFor "HTMLScriptElement" = "script"
tagFor "HTMLTableCellElement" = "td"
tagFor "HTMLTableColElement" = "col"
tagFor "HTMLTableElement" = "table"
tagFor "HTMLTableRowElement" = "tr"
tagFor "HTMLTextAreaElement" = "textarea"
tagFor "HTMLBRElement" = "br"
tagFor "HTMLHRElement" = "hr"
tagFor "HTMLLIElement" = "li"
tagFor "HTMLDListElement" = "dl"
tagFor "HTMLOListElement" = "ol"
tagFor "HTMLUListElement" = "ul"

tagFor _ = ""

-- Attributes are represented by methods with proper type signatures.
-- These methods are wrappers around type-neutral unsafe get/set property
-- functions.

intf2attr :: I.Defn -> [H.HsDecl]

intf2attr intf@(I.Interface (I.Id iid) _ cldefs) =
  concat $ map mkattr $ collectAttrs intf where
    mkattr (I.Attribute [] _ _) = []
    mkattr (I.Attribute [I.Id iat] False tat) = mksetter iid iat tat ++ mkgetter iid iat tat
    mkattr (I.Attribute [I.Id iat] True  tat) = mkgetter iid iat tat
    mkattr (I.Attribute (iatt:iats) b tat) =
      mkattr (I.Attribute [iatt] b tat) ++ mkattr (I.Attribute iats b tat)
    mksetter iid iat tat = [stsig iid iat tat, simpl iid iat]
    monadtv = mkTIdent "mn"
    exprtv = mkTIdent "Expression"
    monadctx = (mkUIdent "Monad",[monadtv])
    simpl iid iat =
      let defset = iid ++ "|set'" ++ iat
          unssetp = mkVar "setjsProperty"
          propnam = H.HsLit (H.HsString iat)
          rhs = H.HsUnGuardedRhs (H.HsApp unssetp propnam)
          match = H.HsMatch nullLoc (H.HsIdent defset) [] rhs [] in
      H.HsFunBind [match]
    stsig iid iat tat =
      let ityp = I.TyName iid Nothing
          defset = iid ++ "|set'" ++ iat
          parm = [I.Param (I.Id "val") tat [I.Mode In]]
          parms = (map (fst . tyParm) parm) ++ [H.HsIdent "zz"]
          contxt = (concat $ map (snd . tyParm) parm) ++ ctxRet ityp
          tpsig = mkTsig (map (H.HsTyApp exprtv . H.HsTyVar) parms)
                         (H.HsTyApp monadtv $ H.HsTyApp exprtv (tyRet ityp))
          retts = H.HsQualType (monadctx : contxt) tpsig in
      H.HsTypeSig nullLoc [H.HsIdent defset] retts
    mkgetter iid iat tat = [gtsig iid iat tat, gimpl iid iat tat, gtcnc iid iat tat, eqcnc iid iat]
    gimpl iid iat tat =
      let defget = iid ++ "|get'" ++ iat
          parm = H.HsPVar $ H.HsIdent "thisp"
          propnam = H.HsLit (H.HsString iat)
          undef = H.HsExpTypeSig nullLoc (mkVar "undefined") (H.HsQualType [] (tyRet tat))
          rhs = H.HsUnGuardedRhs $ mkGetter iat parm (tyRet tat)
          match = H.HsMatch nullLoc (H.HsIdent defget) [parm] rhs [] in
      H.HsFunBind [match]
    gtsig iid iat tat =
      let defget = iid ++ "|get'" ++ iat
          parms = [H.HsIdent "this"]
          thisctx = (mkUIdent (classFor iid),[mkTIdent "this"])
          tpsig = mkTsig (map (H.HsTyApp exprtv . H.HsTyVar) parms)
                         (H.HsTyApp monadtv $ H.HsTyApp exprtv (tyRet tat))
          retts = H.HsQualType (monadctx : thisctx : ctxRet tat) tpsig in
      H.HsTypeSig nullLoc [H.HsIdent defget] retts
    gtcnc iid iat tat =
      let defcnc = iid ++ "|getm'" ++ iat
          parms = [H.HsIdent "this"]
          thisctx = (mkUIdent (classFor iid),[mkTIdent "this"])
          tpsig = mkTsig (map (H.HsTyApp exprtv . H.HsTyVar) parms)
                         (H.HsTyApp monadtv $ H.HsTyApp exprtv (cnRet tat))
          retts = H.HsQualType [monadctx, thisctx] tpsig in
      H.HsTypeSig nullLoc [H.HsIdent defcnc] retts
    eqcnc iid iat =
      let defcnc = iid ++ "|getm'" ++ iat
          defget = "get'" ++ iat
          rhs = H.HsUnGuardedRhs (mkVar defget)
          match = H.HsMatch nullLoc (H.HsIdent defcnc) [] rhs [] in
      H.HsFunBind [match]



intf2attr _ = []

-- Create a Javascript body for a getter. Template for a getter is:
-- get'prop this = do
--   let et = undefined :: zz
--       r = DotRef et (this /\ et) (Id et "propname")
--   return r
-- where zz is a type variable or type name of the method return type.

mkGetter :: String -> H.HsPat -> H.HsType -> H.HsExp

mkGetter prop arg rett = H.HsDo [let1, let2, ret] where
  let1 = H.HsLetStmt [
           H.HsFunBind [
             H.HsMatch nullLoc
                       (H.HsIdent "et")
                       []
                       (H.HsUnGuardedRhs $ H.HsExpTypeSig nullLoc
                                                          (mkVar "undefined")
                                                          (H.HsQualType [] rett))
                       []
            ]
          ]
  let2 = H.HsLetStmt [
           H.HsFunBind [
             H.HsMatch nullLoc
                       (H.HsIdent "r")
                       []
                       (H.HsUnGuardedRhs $ H.HsApp (
                                             H.HsApp (
                                               H.HsApp (mkVar "DotRef")
                                                       (mkVar "et"))
                                               (H.HsParen $
                                                  H.HsInfixApp (mkVar "thisp")
                                                               (H.HsQVarOp $ mkSymbol "/\\")
                                                               (mkVar "et")))
                                             (H.HsParen $
                                                H.HsApp (
                                                  H.HsApp (mkVar "Id")
                                                          (mkVar "et"))
                                                  (H.HsLit $ H.HsString prop)))
                       []
             ]
           ]
  ret = H.HsQualifier $
          H.HsApp (mkVar "return") (mkVar "r")

-- Methods are lifted to top level. Declared argument types are converted
-- into type constraints unless they are of primitive types. First argument
-- always gets a type of the interface where the method is declared.
-- Only `In' parameters are supported at this time. The "this" argument
-- goes last to make monadic composition of actions easier.

intf2meth :: I.Defn -> [H.HsDecl]

intf2meth intf@(I.Interface _ _ cldefs) =
  (concat $ map mkmeth $ collectOps intf) ++
  (concat $ map mkconst $ collectConst intf) where
    getDefHs op = getDef op
    getDefJs op@(I.Operation _ _ _ mbctx) = case mbctx of
      Nothing -> getDef op
      Just [] -> getDef op
      Just (s:_) -> s
    mkconst cn@(I.Constant (I.Id cid) _ _ (I.Lit (IntegerLit (ILit base val)))) =
      let defcn = getDef intf ++ "|c" ++ cid
          match = H.HsMatch nullLoc (H.HsIdent defcn) [] crhs []
          crhs = H.HsUnGuardedRhs (H.HsLit (H.HsInt val))
      in  [H.HsFunBind [match]]
    mkmeth op = tsig op : timpl op
    tsig op@(I.Operation (I.FunId _ _ parm) optype _ _) =
      let monadtv = mkTIdent "mn"
          exprtv = mkTIdent "Expression"
          defop = getDef intf ++ "|" ++ getDefHs op
          parms =  (map (fst . tyParm) parm) ++ [H.HsIdent "this"]
          contxt = (concat $ map (snd . tyParm) parm) ++ ctxRet optype
          monadctx = (mkUIdent "Monad",[monadtv])
          thisctx = (mkUIdent (classFor $ getDef intf),[mkTIdent "this"])
          tpsig = mkTsig (map (H.HsTyApp exprtv . H.HsTyVar) parms)
                         (H.HsTyApp monadtv $ H.HsTyApp exprtv (tyRet optype))
          retts = H.HsQualType (monadctx : thisctx : contxt) tpsig in
      H.HsTypeSig nullLoc [H.HsIdent defop] retts
    timpl op@(I.Operation (I.FunId _ _ parm) optype _ _) =
      let defop = getDef intf ++ "|" ++ getDefHs op
          parms = map H.HsPVar (take (length parm) azHIList ++ [H.HsIdent "thisp"])
          rhs = H.HsUnGuardedRhs $ mkMethod (getDefJs op) parms (tyRet optype)
          match  = H.HsMatch nullLoc (H.HsIdent defop) parms rhs []
      in  [H.HsFunBind [match]]

intf2meth _ = []

-- Create a Javascript body for a method. Template for a method is:
-- method a1 ... an this = do
--   let et = undefined :: zz
--       r = DotRef et (this /\ et) (Id et "methodname")
--   return (CallExpr et r [a1 /\ et, ... an /\ et]
-- where zz is a type variable or type name of the method return type.

mkMethod :: String -> [H.HsPat] -> H.HsType -> H.HsExp

mkMethod meth args rett = H.HsDo [let1, let2, ret] where
  args' = (reverse . tail . reverse) args
  cast ts (H.HsPVar (H.HsIdent hn)) =
    H.HsInfixApp (mkVar hn) (H.HsQVarOp $ mkSymbol "/\\") (mkVar ts)
  let1 = H.HsLetStmt [
           H.HsFunBind [
             H.HsMatch nullLoc
                       (H.HsIdent "et")
                       []
                       (H.HsUnGuardedRhs $ H.HsExpTypeSig nullLoc
                                                          (mkVar "undefined")
                                                          (H.HsQualType [] rett))
                       []
            ]
          ]
  let2 = H.HsLetStmt [
           H.HsFunBind [
             H.HsMatch nullLoc
                       (H.HsIdent "r")
                       []
                       (H.HsUnGuardedRhs $ H.HsApp (
                                             H.HsApp (
                                               H.HsApp (mkVar "DotRef")
                                                       (mkVar "et"))
                                               (H.HsParen $
                                                  H.HsInfixApp (mkVar "thisp")
                                                               (H.HsQVarOp $ mkSymbol "/\\")
                                                               (mkVar "et")))
                                             (H.HsParen $
                                                H.HsApp (
                                                  H.HsApp (mkVar "Id")
                                                          (mkVar "et"))
                                                  (H.HsLit $ H.HsString meth)))
                       []
             ]
           ]
  ret = H.HsQualifier $
          H.HsApp (mkVar "return")
                  (H.HsParen $
                     H.HsApp (
                       H.HsApp (
                         H.HsApp (mkVar "CallExpr")
                                 (mkVar "et"))
                         (mkVar "r"))
                       (H.HsList $ map (cast "et") args'))

-- Build a variable name

mkVar = H.HsVar . mkUIdent

-- Build a method's type signature

mkTsig :: [H.HsType] -> H.HsType -> H.HsType

mkTsig [] a = a
mkTsig (p:ps) a = H.HsTyFun p (mkTsig ps a)

-- A helper function to produce a type identifier

mkTIdent = H.HsTyVar . H.HsIdent

-- A helper function to produce an export identifier.
-- Datas (Txxx) export all their members.

mkEIdent name@(n:_) | n `elem` ['T'] = (H.HsEThingAll . H.UnQual . H.HsIdent) name
                    | otherwise = (H.HsEVar . H.UnQual . H.HsIdent) name


-- Obtain a return type signature from a return type

tyRet :: I.Type -> H.HsType

tyRet (I.TyName c Nothing) = case (asIs c) of
  Nothing -> mkTIdent "zz"
  Just c' -> mkTIdent c'
tyRet (I.TyInteger _) = mkTIdent "Double"
tyRet (I.TyFloat _) = mkTIdent "Double"
tyRet (I.TyApply _ (I.TyInteger _)) = mkTIdent "Double"
tyRet  I.TyVoid  = H.HsTyTuple []
tyRet t = error $ "Return type " ++ (show t)

-- The same, for a concrete type

cnRet :: I.Type -> H.HsType

cnRet (I.TyName c Nothing) = case asIs c of
  Nothing -> mkTIdent ('T' : c)
  Just c' -> mkTIdent c'
cnRet z = tyRet z

-- Obtain a return type context (if any) from a return type

ctxRet :: I.Type -> [H.HsAsst]

ctxRet (I.TyName c Nothing) = case (asIs c) of
  Nothing -> [(mkUIdent $ classFor c, [mkTIdent "zz"])]
  Just c' -> []

ctxRet _ = []

-- Obtain a type signature from a parameter definition

tyParm :: I.Param -> (H.HsName, [H.HsAsst])

tyParm (I.Param (I.Id p) ptype [I.Mode In]) =
  let hsidp = H.HsIdent p in
  case ptype of
    I.TyName c Nothing -> case asIs c of
      Just cc ->  (H.HsIdent cc, [])
      Nothing -> (hsidp, [(mkUIdent $ classFor c, [mkTIdent p])])
    I.TyInteger _ -> (H.HsIdent "Double",[])
    I.TyFloat _ -> (H.HsIdent "Double",[])
    I.TyApply _ (I.TyInteger _) -> (H.HsIdent "Double",[])
    t -> error $ "Param type " ++ (show t)

tyParm (I.Param _ _ _) = error "Unsupported parameter attributes"

-- Some types pass through as is, other are class names

asIs :: String -> Maybe String

asIs "DOMString" = Just "String"
asIs "Bool"      = Just "Bool"
asIs "Int"       = Just "Double"
asIs _ = Nothing