------------------------------------------------------------------
-- |
-- Module      :  BackJSMW
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Haskell JSMW style back-end.
------------------------------------------------------------------

module BackJSMW where

import IdlScopedName
import IdlGlobal
import IdlUtil
import Data.SplitBounds
import Data.List
import Data.Char
import Data.Maybe
import Language.WebIDL.Syntax
import Language.WebIDL.PrettyPrint (prettyExpr)
import Language.Haskell.Exts
import qualified Data.Map as M

-- Toplevel function for the backend: convert a flattened map of the source IDL
-- specifications to the list of Haskell modules.

backJSMW :: ICGlobal -> M.Map String IDLDef -> String

backJSMW opts idlmap = concat $ map printmod $ hsmods opts idlmap where
  hsmods os im = map (onemodule os im) (modnames im) ++
                 concatMap (oneinterface os im) (itfnames im)
  modnames = M.keys . M.filter isModule
  itfnames = M.keys . M.filter isInterface
  printmod m = spbeg ++ prettyPrint m ++ spend where
    spend = "\n" ++ splitEnd ++ "\n"
    modn (Module _ mn _ _ _ _ _) = let ModuleName mm = mn in mm
    spbeg = "\n" ++ splitBegin ++ "/" ++ modn m ++ "\n"

-- Placeholdef for locations.

nullLoc = SrcLoc "" 0 0

-- Simple module import declaration (name only, augment further as needed).

impmod :: ModuleName -> ImportDecl

impmod m = ImportDecl {
        importLoc = nullLoc
       ,importModule = m
       ,importQualified = False
       ,importSrc = False
       ,importPkg = Nothing
       ,importAs = Nothing
       ,importSpecs = Nothing}

-- Import qualified (w/o 'as')

impmodq :: ModuleName -> ImportDecl

impmodq m = (impmod m) {importQualified = True}

-- All modules generated import this.

globimps :: [ImportDecl]

globimps = map (impmod . ModuleName) ["Language.JSMW", "BrownPLT.JavaScript"]

-- Produce Haskell code for a single module per an IDL module. This does not cover
-- interfaces as they are represented each by a separate module. So only constants
-- will be included in the modules formed.

onemodule :: ICGlobal -> M.Map String IDLDef -> String -> Module

onemodule os im mn = Module nullLoc (mkmodname os mn) []
                     Nothing (mkdefexp consts) globimps (mkdefdecl os consts) where 
  consts = M.elems $ M.filterWithKey (\k d -> isConst d && isof mn k) im

-- Produce Haskell code for a single interface. Each interface yields a pair of modules:
-- one to declare types and classes based on inheritance, and another to
-- declare attributes and operations.

oneinterface :: ICGlobal -> M.Map String IDLDef -> String -> [Module]

oneinterface os im mn = [modc, moda] where
  modc = Module nullLoc (clname os mn) []
         Nothing clexps (globimps ++ iimps) cldecls
  moda = Module nullLoc (mkmodname os mn) []
         Nothing (Just $ mcexps ++ expexps ++ ctorexps) (globimps ++ climps ++ expimps ++ ctorimps) 
                 (expdecls ++ ctordecls)
  climps = [impmod $ clname os mn]
  iimps = inhrimps os im mn
  (expexps, expimps, expdecls) = itfexp os im mn
  (ctorexps, ctorimps, ctordecls) = itfctors os im mn
  mcexps = [EModuleContents $ clname os mn]
  cname = Ident $ 'C' : (fstcap itfname)
  tname = Ident $ 'T' : (fstcap itfname)
  itfname = unscope $ bldsn mn
  clexps = Just [EVar $ UnQual cname
                ,EThingAll $ UnQual tname]
  cldecls = [idata, iclass] ++ insts
  idata = DataDecl nullLoc DataType [] tname [] [qcd] []
  qcd = QualConDecl nullLoc [] [] $ ConDecl tname []
  iclass = ClassDecl nullLoc (inhrctx os im mn) cname [UnkindedVar $ Ident "a"] [] []
  insts = idltpbl : map mkinst (Qual (clname os mn) cname : concatMap imp2class iimps)
  mkinst c = InstDecl nullLoc [] c [TyCon $ UnQual tname] []
  idltpbl = InstDecl nullLoc [] (UnQual $ Ident "IDLTypeable") [TyCon $ UnQual tname] [idltype]
  idltype = InsDecl $ FunBind [itmatch]
  itmatch = Match nullLoc (Ident "idlType") [PWildCard] Nothing itrhs (BDecls [])
  itrhs = UnGuardedRhs $ Lit $ String mn

-- Given an import declaration (caused by interface inheritance) produce a qualified
-- name of the class to derive an instance from.

imp2class :: ImportDecl -> [QName]

imp2class idcl =
  let mn@(ModuleName modn) = importModule idcl
      d2nl '.' = '\n'
      d2nl z = z
      mkrdn = reverse . lines . map d2nl
  in  case mkrdn modn of
        ("Class" : ('T':ts) : iname : _) -> [Qual mn $ Ident ('C': iname)]
        _ -> []

-- Given an interface name, build an import list based on inheritance. Each
-- inherited interface causes its corresponding class module to be imported.

inhrimps :: ICGlobal -> M.Map String IDLDef -> String -> [ImportDecl]

inhrimps os im mn = case M.lookup mn im of
  Just (IDLDefInterface _ _ inhr _) ->
    nub $ map (impmodq . clname os . prtsn) inhr ++ concatMap (inhrimps os im . prtsn) inhr
  _ -> []

-- Given an interface name, build context for its Haskell class.

inhrctx :: ICGlobal -> M.Map String IDLDef -> String -> [Asst]

inhrctx os im mn = case M.lookup mn im of
  Just (IDLDefInterface _ _ inhr _) ->
    map (\sn -> ClassA (Qual (clname os $ prtsn sn) (Ident ('C' : unscope sn))) [TyVar $ Ident "a"]) inhr
  _ -> []

-- Make a list of exports out of the list of IDL definitions.

mkdefexp :: [IDLDef] -> Maybe [ExportSpec]

mkdefexp [] = Nothing
mkdefexp ds = Just $ concatMap oneexp ds where
  oneexp (IDLDefConst (IDLConstDcl _ cn _)) = [EVar $ UnQual $ Ident $ 'c' : (unscope $ bldsn cn)]
  oneexp _ = []

-- If an interface contains [Constructor] or [NamedConstructor] extended attributes,
-- create special functions that being called force creation of interface objects. These
-- functions are named newCCCC where CCCC is constructor name as specified in the attribute
-- for NamedConstructor, or interface name (without T prefixed) for Constructor. If 
-- constructors are overloaded, _n will be appended to each duplicating function name
-- where n is a character representation of an integer number. The first constructor is never
-- appended such modifier to its name.

itfctors :: ICGlobal -> M.Map String IDLDef -> String -> ([ExportSpec], [ImportDecl], [Decl])

itfctors os im ni = case M.lookup ni im of
  Just (IDLDefInterface _ [] _ _) -> ([], [], [])
  Just (IDLDefInterface _ xa _ _) -> case uniqctor $ concatMap (uctor ni) xa of
    [] -> ([], [], [])
    cdets -> (exps, imps, decls) where
      npfx = ("new" ++)
      exps = map (EVar . UnQual . Ident . npfx . fst) cdets
      imps = []
      ops = map ct2op cdets
      ct2op (ctnm, ctprms) = IDLOpDcl [] [] (IDLParamScopedSpec $ bldsn ni) 
        (npfx ctnm) ctprms []
      decls = concatMap (mkexpdcl "" os . IDLExpOp . ct2op) cdets
  _ -> ([], [], [])

-- Uniqualize overloaded constructor names. Group the list by constructor name
-- (first element of the tuple) and zip with increasing number to make
-- unique (per interface) names.

uniqctor :: [(String, bs)] -> [(String, bs)]

uniqctor = concat . map zipn . groupBy eqp where
  eqp (s1, bs1) (s2, bs2) = s1 == s2
  zipn xs = zip (zipWith (++) (map fst xs) unql) (map snd xs)
  unql = "" : map (('_':) . show) [2 ..]

-- Filter an unify constructors. While named constructors with names same as interface
-- name are not allowed, unnamed constructors will be converted internally into
-- named constructors with interface name. Constructors without arguments are converted
-- per 4.2.3 and 4.2.4 into constructors with empty list of arguments.

uctor :: String -> IDLExtAttr -> [(String, [IDLParamDcl])]

uctor ni (IDLExtAttr _ "Constructor" Nothing) = [(unscope $ bldsn ni, [])]
uctor ni (IDLExtAttr _ "NamedConstructor" Nothing) = [] -- MUST take an identifier
uctor ni (IDLExtAttr _ "NamedConstructor" (Just (IDLDetailSN sn))) = [(prtsn sn, [])]
uctor ni (IDLExtAttr _ "Constructor" (Just (IDLDetailPD pns))) = [(unscope $ bldsn ni, pns)]
uctor ni (IDLExtAttr _ "NamedConstructor" (Just (IDLDetailID nc pns))) = [(nc, pns)]
uctor _ _ = []

-- Make lists of exports, imports, and declarations of an interface out of its body.

itfexp :: ICGlobal -> M.Map String IDLDef -> String -> ([ExportSpec], [ImportDecl], [Decl])

itfexp os im ni = case M.lookup ni im of
  Just (IDLDefInterface _ _ _ (Just (IDLInterfaceBody ixps))) -> (exps, imps, dcls) where
    ix (IDLExport _ _ x) = x
    (mkrname, mkrdecl, mkrimp) = mkmaker os ni
    (castname, castdecl, castimp) = mkcast os ni
    xxps = map ix ixps
    exps = map (EVar . UnQual . Ident) $ concatMap mkexpname xxps ++ mkrname ++ castname
    imps = nub $ concatMap (mkexpimp os) xxps ++ mkrimp ++ castimp
    dcls = concatMap (mkexpdcl ni os) xxps ++ mkrdecl ++ castdecl
  _ -> ([], [], [])

-- Create safe cast function. 
--  * asXXXX: to cast a polymorphic instance of CXXXX to a concrete type of TXXXX
--    as-casting functions are non-monadic, and have type signature TXXXX -> TXXX,
--    basically they are just `id'.

mkcast :: ICGlobal -> String -> ([String], [Decl], [ImportDecl])

mkcast os ni =
  let ifn = unscope $ bldsn ni
      asname = "as" ++ ifn
      asdecl = [assig, asimpl]
      assig = TypeSig nullLoc [Ident asname] astype
      astype = TyFun (ex tymres) (ex tymres)
      tymres = mktymres os (IDLParamScopedSpec $ bldsn ni) ""
      ex t = TyApp (TyVar $ Ident "Expression") t
      asimpl = FunBind [Match nullLoc (Ident asname) [] Nothing asrhs (BDecls [])]
      asrhs = UnGuardedRhs $ Var $ UnQual $ Ident "id"
  in  ([asname], asdecl, [])

-- Create declarations for a HTML element maker function.

mkmaker :: ICGlobal -> String -> ([String], [Decl], [ImportDecl])

mkmaker os ni =
  let ifn = unscope $ bldsn ni
      tag = M.lookup ifn (tagspec os)
      docm = "::dom::Document"
  in case tag of
       Nothing -> ([], [], [])
       Just t ->
         let docmod = mkmodname os docm
             crelt = (impmod docmod) {
               importSpecs = Just (False, [IVar $ Ident "createElement"])}
             crcls = (impmod $ clname os docm) {
               importSpecs = Just (False, [IVar $ Ident "CDocument"])}
             mkname = "mk" ++ (fstcap $ map toLower t)
             mkdecl = [mksig, mkimpl]
             mksig = TypeSig nullLoc [Ident mkname] mktype
             mktype = TyForall Nothing (mctx : dctx) $ TyFun 
                        (ex $ TyVar $ Ident $ doct ++ "_") (mnex tymres)
             mndn = 'm' : (show $ timestamp os)
             doct = 'd' : (show $ timestamp os)
             mctx = ClassA (UnQual $ Ident $ "Monad") [TyVar $ Ident mndn]
             mn t = TyApp (TyVar $ Ident mndn) t 
             ex t = TyApp (TyVar $ Ident "Expression") t
             mnex = mn . ex
             tymres = mktymres os (IDLParamScopedSpec $ bldsn ni) ""
             dctx = snd $ mktyres os (IDLParamScopedSpec $ bldsn docm) doct
             mkimpl = FunBind [Match nullLoc (Ident mkname) [] Nothing mkrhs (BDecls [])]
             tlit = Lit $ String t
             mkrhs = UnGuardedRhs $ App (Var $ Qual docmod $ Ident "createElement") $ Paren $
                                    App (App (Con $ UnQual $ Ident "StringLit") tlit) tlit
         in  ([mkname], mkdecl, [crelt, crcls])


-- Create import declarations out of an interface export. For an attribute, these are
-- derived from attribute types, for operations from parameter types and return types.
-- Only class-constrained types contribute into the import list.

mkexpimp :: ICGlobal -> IDLExp -> [ImportDecl]

mkexpimp os (IDLExpAttr (IDLAttrDcl _ _ ipts _ _ _)) = mktypeimp os ipts
mkexpimp os (IDLExpOp (IDLOpDcl _ _ ipts _ pdcls _)) = 
  mktypeimp os ipts ++ concatMap (mkprmimp os) pdcls
mkexpimp _ _ = []

-- Create import declarations out of operation parameters declaration.

mkprmimp :: ICGlobal -> IDLParamDcl -> [ImportDecl]

mkprmimp os (IDLParamDcl _ _ ipts _ _) = mktypeimp os ipts

-- Create declarations based on an interface export. Only constants, attributes, and
-- operations really count.

mkexpdcl :: String -> ICGlobal -> IDLExp -> [Decl]

mkexpdcl ni os (IDLExpConst cdcl) = mkdefdecl os [IDLDefConst cdcl]
mkexpdcl ni os (IDLExpAttr (IDLAttrDcl _ ro ipts an _ _)) = mkattrdcl ni os ro ipts an
mkexpdcl "" os (IDLExpOp (IDLOpDcl _ _ ipts on pdcls _)) = mkopdcl False "" os ipts pdcls on
mkexpdcl ni os (IDLExpOp (IDLOpDcl _ _ ipts on pdcls _)) = mkopdcl True ni os ipts pdcls on
mkexpdcl _ _ _ = []

-- Create declarations for an operation (first arg True) or a constructor (False).
-- Constructors do not have the last "this" argument, and their result is always
-- monomorphic.

mkopdcl :: Bool -> String -> ICGlobal -> IDLParamTypeSpec -> [IDLParamDcl] -> String -> [Decl]

mkopdcl isop ni os ipts pdcls on = [opsig, opimpl] where
  opn = fstlow $ unscope $ bldsn on
  opname = Ident $ opn
  opsig = TypeSig nullLoc [opname] optype
  optype = case isop of
    True -> TyForall Nothing (mctx : thisctx : rpctx) $ tfp typarm (mnex tyres)
    False -> TyForall Nothing [mctx] $ tfp typarm (mnex tyres)
  mndn = 'm' : (show $ timestamp os)
  resn = 'z' : (show $ timestamp os)
  mctx = ClassA (UnQual $ Ident $ "Monad") [TyVar $ Ident mndn]
  thisctx = itfctx os ni "this"
  tythis = TyVar $ Ident "this"
  (tyres, resctx) = case isop of
    True -> mktyres os ipts resn
    False -> (mktymres os ipts resn, [])
  mn t = TyApp (TyVar $ Ident mndn) t 
  ex t = TyApp (TyVar $ Ident "Expression") t
  mnex = mn . ex
  parmct = map (mkparmres os) pdcls
  rpctx = resctx ++ concatMap snd parmct
  tfp (t:ts) a = TyFun t (tfp ts a)
  tfp [] a = a
  typarm = map ex $ map fst parmct ++ if isop then [tythis] else []
  opimpl = FunBind [Match nullLoc opname (map (PVar . Ident . pnm) tpdcls) 
                          Nothing oprhs (BDecls [])]
  pnm (IDLParamDcl _ _ _ _ pn) = fstlow pn ++ "_"
  tpdcls = pdcls ++ if isop then [IDLParamDcl [] [IDLParamIn] IDLParamVoid Nothing "thisp"] else []
  oprhs = UnGuardedRhs $ case isop of
    True -> mkop opn tyres (map pnm pdcls)
    False -> mkctor opn tyres (map pnm pdcls)

-- Expression body for a constructor.

mkctor :: String -> Type -> [String] -> Exp

mkctor ('n':'e':'w':ctn) rt pnames = Do [let1, let2, ret] where
  let1 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "et") [] Nothing lrhs1 (BDecls [])]]
  lrhs1 = UnGuardedRhs $ ExpTypeSig nullLoc (Con $ UnQual $ Ident "undefined") rt
  let2 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "r") [] Nothing lrhs2 (BDecls [])]]
  lrhs2 = UnGuardedRhs $ App (App vrf et) (Paren $ App (App cid et) van)
  ret = Qualifier $ App vret (Paren vrt)
  [et, vret, vr] = map (Var . UnQual . Ident) ["et", "return", "r"]
  [vrf, cid, nex] = map (Con . UnQual . Ident) ["VarRef", "Id", "NewExpr"]
  cst = QVarOp $ UnQual $ Symbol "/\\"
  van = Lit $ String ctn
  vrt = App (App (App nex et) vr) $ List (map cstp pnames)
  cstp pn = InfixApp (Var $ UnQual $ Ident pn) cst et

mkctor ctn _ _ = error $ "Constructor does not start with new: " ++ ctn

-- Expression body for an operation.

mkop :: String -> Type -> [String] -> Exp

mkop opn rt pnames = Do [let1, let2, ret] where
  let1 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "et") [] Nothing lrhs1 (BDecls [])]]
  lrhs1 = UnGuardedRhs $ ExpTypeSig nullLoc (Con $ UnQual $ Ident "undefined") rt
  let2 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "r") [] Nothing lrhs2 (BDecls [])]]
  lrhs2 = UnGuardedRhs $ App (App (App dr et) $ Paren (InfixApp thp cst et)) 
                             (Paren $ App (App cid et) van)
  ret = Qualifier $ App vret (Paren vrt)
  [et, thp, vret, vr] = map (Var . UnQual . Ident) ["et", "thisp_", "return", "r"]
  [dr, cid, cex] = map (Con . UnQual . Ident) ["DotRef", "Id", "CallExpr"]
  cst = QVarOp $ UnQual $ Symbol "/\\"
  van = Lit $ String opn
  vrt = App (App (App cex et) vr) $ List (map cstp pnames)
  cstp pn = InfixApp (Var $ UnQual $ Ident pn) cst et

-- Operation parameter's type and context.

mkparmres :: ICGlobal -> IDLParamDcl -> (Type, [Asst])

mkparmres os (IDLParamDcl _ _ ipts _ pn) = mktyres os ipts pn

-- Create declarations for an attribute.

mkattrdcl :: String -> ICGlobal -> Bool -> IDLParamTypeSpec -> String -> [Decl]

mkattrdcl ni os ro ipts an = getdcl ++ (if ro then [] else setdcl) where
  getdcl = [gtsig, gtimpl, gtmsig, gtmimpl]
  atrn = unscope $ bldsn an
  gtname = Ident $ "get'" ++ atrn
  gtmname = Ident $ "getm'" ++ atrn
  gtsig = TypeSig nullLoc [gtname] gttype
  gttype = TyForall Nothing (mctx : thisctx : resctx) $ TyFun tythis (mnex tyres)
  gtmsig = TypeSig nullLoc [gtmname] gtmtype
  gtmtype = TyForall Nothing [mctx, thisctx] $ TyFun tythis (mnex tymres)
  mndn = 'm' : (show $ timestamp os)
  resn = 'z' : (show $ timestamp os)
  mctx = ClassA (UnQual $ Ident $ "Monad") [TyVar $ Ident mndn]
  thisctx = itfctx os ni "this"
  tythis = TyApp (TyVar $ Ident "Expression") (TyVar $ Ident "this")
  (tyres, resctx) = mktyres os ipts resn
  mn t = TyApp (TyVar $ Ident mndn) t 
  ex t = TyApp (TyVar $ Ident "Expression") t
  mnex = mn . ex
  tymres = mktymres os ipts resn
  setdcl = [stsig, stimpl]
  stname = Ident $ "set'" ++ atrn
  stsig = TypeSig nullLoc [stname] sttype
  sttype = TyForall Nothing (mctx : thisctx : resctx) $ 
    TyFun (ex tyres) (TyFun tythis (mn tythis))
  gtimpl = FunBind [Match nullLoc gtname [PVar $ Ident "thisp"] Nothing gtrhs (BDecls [])]
  gtrhs = UnGuardedRhs $ mkgetter atrn tyres
  gtmimpl = FunBind [Match nullLoc gtmname [] Nothing gtmrhs (BDecls [])]
  gtmrhs = UnGuardedRhs $ Var $ UnQual gtname
  stimpl = FunBind [Match nullLoc stname [] Nothing strhs (BDecls [])]
  strhs = UnGuardedRhs $ App (Var $ UnQual $ Ident "setjsProperty") (Lit $ String atrn)

-- Expression body for an attribute getter. It produces a JSMW-style monadic expression.

mkgetter :: String -> Type -> Exp

mkgetter an rt = Do [let1, let2, ret] where
  let1 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "et") [] Nothing lrhs1 (BDecls [])]]
  lrhs1 = UnGuardedRhs $ ExpTypeSig nullLoc (Con $ UnQual $ Ident "undefined") rt
  let2 = LetStmt $ BDecls [FunBind [Match nullLoc (Ident "r") [] Nothing lrhs2 (BDecls [])]]
  lrhs2 = UnGuardedRhs $ App (App (App dr et) $ Paren (InfixApp thp cst et)) 
                             (Paren $ App (App cid et) van)
  ret = Qualifier $ App vret vr
  [et, thp, vret, vr] = map (Var . UnQual . Ident) ["et", "thisp", "return", "r"]
  [dr, cid] = map (Con . UnQual . Ident) ["DotRef", "Id"]
  cst = QVarOp $ UnQual $ Symbol "/\\"
  van = Lit $ String an
  

-- Convert IDL type specification to an import declaration. Base types do not
-- cause anything to be imported. Interfaces cause their class modules to be imported.

mktypeimp :: ICGlobal -> IDLParamTypeSpec -> [ImportDecl]

mktypeimp os (IDLParamScopedSpec sn) | abssn sn = [impmodq $ clname os $ prtsn sn]
mktypeimp _ _ = []

-- Convert IDL type specification to Haskell monomorphic type. For interfaces,
-- corresponding data type rather than class constraint will be returned.

mktymres :: ICGlobal -> IDLParamTypeSpec -> String -> Type

mktymres os (IDLParamScopedSpec sn) tv | abssn sn = 
  TyCon (Qual (clname os $ prtsn sn) (Ident ('T' : unscope sn)))

mktymres os p tv = fst $ mktyres os p tv


-- Convert IDL type specification to Haskell type. If this is a base type,
-- a numeric or boolean or unit type is returned. Otherwise the given type
-- variable is returned because this is a class-constrained variable, and
-- proper type constraint will be returned.

mktyres :: ICGlobal -> IDLParamTypeSpec -> String -> (Type, [Asst])

mktyres _ (IDLParamBaseSpec bts) tv = (bt, []) where
  bt = case bts of
    IDLBaseTypeFloat _ -> TyVar $ Ident "Double"
    IDLBaseTypeInt _   -> TyVar $ Ident "Double"
    IDLBaseTypeChar    -> TyVar $ Ident "Char"
    IDLBaseTypeBool    -> TyVar $ Ident "Bool"
    IDLBaseTypeOctet   -> TyVar $ Ident "Char"
    IDLBaseTypeAny     -> TyVar $ Ident (tv ++ "_")

mktyres _ (IDLParamScopedSpec (IDLScopedName False ["@DOMString"])) _ = 
  (TyVar $ Ident "String", [])

mktyres _ (IDLParamScopedSpec (IDLScopedName False ["@Object"])) tv = 
  (TyVar $ Ident (tv ++ "_"), [])

mktyres os (IDLParamScopedSpec sn) tv = (TyVar $ Ident (tv ++ "_"), [ctx]) where
  ctx = itfctx os (prtsn sn) (tv ++ "_")

mktyres _ IDLParamVoid _ = (TyCon unit_con_name, [])

mktyres _ _ tv = (TyVar $ Ident (tv ++ "_"), [])

-- Create a type assertion from interface name.

itfctx :: ICGlobal -> String -> String -> Asst

itfctx os ni tv = 
  let sni = bldsn ni
  in  ClassA (Qual (clname os ni) (Ident ('C' : unscope sni))) [TyVar $ Ident tv]

-- Retrieve an exportable name from an interface export. Only constants, attributes, and
-- operations really count.

mkexpname :: IDLExp -> [String]

mkexpname (IDLExpConst (IDLConstDcl _ cn _)) = ['c' : unscope (bldsn cn)]
mkexpname (IDLExpOp (IDLOpDcl _ _ _ on _ _)) = [unscope $ bldsn on]
mkexpname (IDLExpAttr (IDLAttrDcl _ ro _ an _ _)) = sattr ++ gattr where
  atrn = unscope $ bldsn an
  gattr = ["get'" ++ atrn, "getm'" ++ atrn]
  sattr = if ro then [] else ["set'" ++ atrn]
mkexpname _ = []

-- Make a list of declarations out of the list of IDL definitions.

mkdefdecl :: ICGlobal -> [IDLDef] -> [Decl]

mkdefdecl os ds = concatMap (onedecl os) ds ++ concatMap (onetype os) ds where
  onedecl _ (IDLDefConst (IDLConstDcl _ cn ex)) = wbexpr hcn ex where
    hcn =  (Ident $ 'c' : (unscope $ bldsn cn))
  onedecl _ _ = []
  onetype _ _ = []

-- Print an IDL constant expression in terms of JSMW

iex2jsmw _ = "foo"

-- Test whether a name corresponds to a child of a definition. That is, X is a child of Y
-- if the removal of the last part of X is same as Y, and both names are absolute.  

isof pn cn =
  let IDLScopedName pabs pss = bldsn pn
      IDLScopedName cabs css = bldsn cn
      css' = case css of
        [] -> []
        ss -> reverse (tail $ reverse ss)
  in  pabs && cabs && css' == pss

-- Transform an IDL scoped name into a Haskell module name appending the current timestamp
-- and ".Class"

clname :: ICGlobal -> String -> ModuleName

clname os mn = let (ModuleName m) = mkmodname os mn
               in  ModuleName $ m ++ ".T" ++ show (timestamp os) ++ ".Class"

-- Transform an IDL scoped name into a Haskell name. The default namespace prefix (domns)
-- will be prepended to an absolute IDL scoped name.

mkmodname :: ICGlobal -> String -> ModuleName

mkmodname os isn = ModuleName $ domns os ++ ssn where
  IDLScopedName ab ss = bldsn isn
  ssn = case ab of
    False -> error $ "relative scoped name " ++ isn
    True -> if null ss then "" else '.' :  intercalate "." (map fstcap ss)

-- Uppercase the first character of a string.

fstcap :: String -> String

fstcap "" = ""
fstcap (c:cs) = toUpper c : cs

-- Lowercase the first character of a string.

fstlow :: String -> String

fstlow "" = ""
fstlow (c:cs) = toLower c : cs

-- Produce a WebBits-style declaration for a numeric expression represented as a string.
-- Correctness of the string is not verified at this moment.

wbexpr :: Name -> IDLConstExp -> [Decl]

wbexpr hcn exs | isnumber exs = [tdecl, xdecl] where
  idd = Ident "Double"
  dbl = Paren $ ExpTypeSig nullLoc (Con $ UnQual $ Ident "undefined") (TyVar idd)
  vrf = Con $ UnQual $ Ident "NumLit"
  idc = Con $ UnQual $ Ident "Id"
  tdecl = TypeSig nullLoc [hcn] $ TyApp (TyVar $ Ident "Expression") (TyVar idd)
  xdecl = FunBind [Match nullLoc hcn [] Nothing rhs binds]
  rhs = UnGuardedRhs $ App (App vrf dbl) (Var $ UnQual $ Ident $ prettyExpr exs)
  binds = BDecls []

wbexpr hcn exs | isbool exs = [tdecl, xdecl] where
  idd = Ident "Bool"
  dbl = Paren $ ExpTypeSig nullLoc (Con $ UnQual $ Ident "undefined") (TyVar idd)
  vrf = Con $ UnQual $ Ident "BoolLit"
  idc = Con $ UnQual $ Ident "Id"
  tdecl = TypeSig nullLoc [hcn] $ TyApp (TyVar $ Ident "Expression") (TyVar idd)
  xdecl = FunBind [Match nullLoc hcn [] Nothing rhs binds]
  rhs = UnGuardedRhs $ App (App vrf dbl) (Var $ UnQual $ Ident $ map toLower $ prettyExpr exs)
  binds = BDecls []

-- Distinguish between boolean and numeric expressions. Boolean literals and boolean
-- binary operations, and boolean negation are not numbers.

isnumber (IDLPrimLit (IDLIntLit _)) = True
isnumber (IDLPrimLit (IDLFloatLit _)) = True
isnumber _ = False

isbool (IDLPrimLit (IDLBoolLit _)) = True
isbool _ = False