------------------------------------------------------------------
-- |
-- Module      :  Language.JSMW.IdlGen
-- Copyright   :  (c) Dmitry Golubovsky, 2009
-- License     :  BSD-style
-- 
-- Maintainer  :  golubovsky@gmail.com
-- Stability   :  experimental
-- Portability :  portable
-- 
--
--
-- Integrate functions encoded in JSMW into a module and generate
-- WebIDL, JavaScript, and documentation.
------------------------------------------------------------------

module Language.JSMW.IdlGen (
-- * Data Structures
  Argument
 ,Attribute
 ,IFaceImpl (..)
-- * Helper types
 ,MRet
 ,This (..)
 ,Void
-- * Definitions of Arguments and Methods
 ,argument
 ,this
 ,method
 ,attribute
 ,ro
 ,rw
 ,withArg
 ,returning
 ,jdoctopic
 ,methTypeSig
 ,methCode
 ,defInterface
 ,withMethod
 ,withAttr
 ,withPrivate
 ,defIDLSpec
 ,mkObject
 ,mkConstr
-- * Access attributes from inside
 ,attrSet
 ,attrGet
-- * File output utilities
 ,writeFiles
)where

import Prelude hiding (writeFile)
import Data.List
import Data.Maybe
import Data.Tuple.All
import Data.Generics.Text
import Language.WebIDL.Syntax
import Language.WebIDL.PrettyPrint
import Language.JSMW.Monad
import Language.JSMW.Type
import BrownPLT.JavaScript.Syntax
import BrownPLT.JavaScript.PrettyPrint
import Text.ParserCombinators.Parsec.Pos
import System.IO.UTF8 (writeFile)
import System.FilePath

-- | Define an argument to a method. It is intended that within an interface,
-- arguments with the same name and type correspond to the same things.
-- For each argument, name (as used in IDL definitions), type (any value
-- whose type is an instance of 'IDLTypeable'), and annotation (arbitrary text)
-- must be provided.

data Argument t = Argument {
  argName :: String
 ,argType :: t
 ,argComment :: String}

-- | A datatype parameterized by a string that can be used to refer the interface
-- being implemented for within the implementation. Since an IDL file for the
-- interface being implemented may not exist at some moment, this datatype may be
-- used e. g. to define methods arguments corresponding to \"this\" variable,
-- that is, reference to the interface object itself.

data IFaceImpl = IFaceImpl String

instance IDLTypeable IFaceImpl where
  idlType (IFaceImpl s) = s

-- | A special phantom type to identify the \"this\" argument for methods that
-- need it. Also can be used with 'MRet' to indicate that the method returns
-- a reference to the interface being defined.

data This = This

instance JContainer This

instance IDLTypeable This where
  idlType _ = "@this"

-- | A helper type defining container type for all methods, that is '()'. This type
-- is to be used to define method's return type.

type MRet a = JSMW () () (Expression a)

-- | A helper type definition for methods that do not return a value (return 'unit').

type Void = ()

-- | Define an argument. Definition of one argument may be shared between
-- several methods provided that the argument serves same or similar purpose
-- in all methods that use its definition.

argument :: (IDLTypeable t) 
         => String                       -- ^ argument name
         -> t                            -- ^ argument type (use True or False for booleans)
         -> String                       -- ^ argument annotation
         -> Argument t                   -- ^ argument descriptor

argument n t c = Argument n t c

-- | Special definition for the \"this\" argument.

this :: Argument This

this = argument "this" This "internal self-reference"

-- | Start definition of a method. Method definitions are allowed in the "methods"
-- section of the interface definition.


method :: String                          -- ^ method name to show up in WebIDL generated
       -> a                               -- ^ method body. It is a function with any number
                                          --   of arguments, so it is not possible to tell
                                          --   the exact type here.
       -> String                          -- ^ annotation for this method
       -> (a, [(String, String, String)]) -- ^ the same function tupled with a list of
                                          --   triples: argument name, argument type as string
                                          --   (after 'idlType' has been applied), argument
                                          --   comment; the head of the list corresponds
                                          --   to the method itself (type string is always
                                          --   empty)

method n f s = (f, [(n, "", s)])

-- | Type alias for attributes

type Attribute t = (String, t, Bool, String)

-- | Define an attribute of the object.

attribute :: IDLTypeable t
          => String                       -- ^ attribute name
          -> t                            -- ^ attribute initial value and type: some value
                                          --   for simple types, and null for interface
                                          --   references
          -> Bool                         -- ^ True for readonly
          -> String                       -- ^ attribute annotation
          -> Attribute t                  -- ^ all values packed for further processing

attribute s t b a = (s, t, b, a)

-- | Encode a Boolean value for attribute read/write access

ro, rw :: Bool

ro = True
rw = False

-- | Specify an argument that method calls. This function is better applied inline.

withArg :: IDLTypeable t
        => (Expression t -> b, 
               [(String, String, String)]) -- ^ result of 'method' or previous application
                                           --   of 'withArg'
        -> Argument t                      -- ^ an argument to add to am method's definition
        -> (b, [(String, String, String)]) -- ^ function from the first argument applied
                                           --   to the argument specified, with argument
                                           --   names, types, and comments appended

(f, ntcs) `withArg` arg = 
  let vr = VarRef () (Id () $ argName arg)
  in  (f (vr /\ argType arg), ntcs ++ [(argName arg, idlType $ argType arg, argComment arg)])

-- | Annotate the return. This function only contributes to the Javadocs generated
-- for a method and does not change anything else.

returning :: (b, [(String, String, String)])  -- ^ arguments info
           -> String                          -- ^ annotation
           -> (b, [(String, String, String)]) -- ^ arguments info with return annotated

(f, ntcs) `returning` s = (f, ntcs ++ [("@return", "", s)])

-- | Create a Javadoc piece for a given topic (like \"@see\").

jdoctopic :: (b, [(String, String, String)]) -- ^ arguments info
          -> (String, String)                -- ^ topic, text
          -> (b, [(String, String, String)]) -- ^ arguments info with annotation added

(f, ntcs) `jdoctopic` (t, s) = (f, ntcs ++ [('@':t, "", s)])

-- | Extract a WebIDL type signature from a method.

methTypeSig :: (IDLTypeable t)
            => (JSMW () x (Expression t),    -- ^ method with all arguments applied
                 [(String, String, String)]) -- ^ result of 'withArg'
            -> (String, [String])            -- ^ WebIDL representations of return type,
                                             --   and argument types

methTypeSig (f, ntcs) = (
  idlType $ sel1 $ runJSMWWith nullContainer 0 f
 ,filter (not . null) $ map sel2 $ tail ntcs)

-- | Generate JavaScript function body (as an 'Expression') from a method.

methCode :: (IDLTypeable t)
         => (JSMW () x (Expression t),    -- ^ method with all arguments applied
              [(String, String, String)]) -- ^ result of 'withArg'
         -> Expression ()

methCode (f, ntcs) =
  let fblock = getBlock $ runJSMWWith nullContainer 0 f
      margs = map (Id ()) $ filter (\s -> s `notElem` ["@return", "this"]) $ map sel1 $ tail ntcs
  in  FuncExpr () margs (fblock /\ ())

-- | Start the interface definition by creating an empty WebIDL interface definitions
-- which will be populated later by subsequent additions. The [Constructor] extended
-- attribute for unnamed nullary constructor is always created.

defInterface :: IFaceImpl -> IDLDef

defInterface (IFaceImpl ifname) = IDLDefInterface ifname [ictor] [] (Just $ IDLInterfaceBody [])
  where ictor = IDLExtAttr (JavaDoc "") "Constructor" Nothing

-- | Add a method to an interface. Javascript code will be placed in a properly named
-- constant. Javadocs will be generated in simple form using a saved comment
-- with missing argument name as comment for the whole method, and each argument's annotation
-- to for \'@\' tags.

withMethod :: (IDLTypeable t)
         => IDLDef                        -- ^ empty or partially populated interface definition
         -> (JSMW () x (Expression t),    -- ^ method with all arguments applied
              [(String, String, String)]) -- ^ result of 'withArg'
         -> IDLDef                        -- ^ updated interface definition

withMethod (IDLDefInterface ifname ext sup ibody) (f, ntcs) =
  IDLDefInterface ifname ext sup ibody' where
    ibody' = case ibody of 
      Nothing -> Just $ IDLInterfaceBody [expmeth, jsmeth]
      Just ibody -> let IDLInterfaceBody exps = ibody 
                    in  Just $ IDLInterfaceBody (exps ++ [expmeth, jsmeth])
    expmeth = IDLExport (newPos "" 0 0) (mkjdoc ntcs) (mexp f ntcs)
    jsmeth = IDLExport (newPos "" 0 0) (JavaDoc "") (IDLExpConst jsmconst)
    jsmconst = IDLConstDcl (IDLConstTypeString $ IDLStringType Nothing)
                 (sel1 (head ntcs)) (IDLPrimLit $ IDLStringLit sermc)
    sermc = gshow $ (methCode (f, ntcs)) /\ True

-- | Add an attribute to the interface definition. Attribute initial value
-- will be coded similarly to a method body.

withAttr :: (IDLTypeable t)
         => IDLDef                        -- ^ empty or partially populated interface definition
         -> (String, t, Bool, String)     -- ^ attribute definition
         -> IDLDef                        -- ^ updated interface definition

withAttr (IDLDefInterface ifname ext sup ibody) (s, t, b, a) =
  IDLDefInterface ifname ext sup ibody' where
    ibody' = case ibody of
      Nothing -> Just $ IDLInterfaceBody [expattr, jsattr]
      Just ibody -> let IDLInterfaceBody exps = ibody 
                    in  Just $ IDLInterfaceBody (exps ++ [expattr, jsattr])
    expattr = IDLExport (newPos "" 0 0) (mkjdoc [("", "", a)]) (aexp s t b)
    jsattr = IDLExport (newPos "" 0 0) (JavaDoc "") (IDLExpConst attrconst)
    attrconst = IDLConstDcl (IDLConstTypeString $ IDLStringType Nothing) 
                  s (IDLPrimLit $ IDLStringLit sermc)
    sermc = gshow $ (defValue t) /\ True

-- | Add a private attribute to the interface definition. Basically same as
-- 'withAttr', but WebIDL export is not formed for such attribute, only
-- a field of the Javascript object is created.

withPrivate :: (IDLTypeable t)
         => IDLDef                        -- ^ empty or partially populated interface definition
         -> (String, t, Bool, String)     -- ^ attribute definition
         -> IDLDef                        -- ^ updated interface definition

withPrivate (IDLDefInterface ifname ext sup ibody) (s, t, b, a) =
  IDLDefInterface ifname ext sup ibody' where
    ibody' = case ibody of
      Nothing -> Just $ IDLInterfaceBody [jsattr]
      Just ibody -> let IDLInterfaceBody exps = ibody 
                    in  Just $ IDLInterfaceBody (exps ++ [jsattr])
    jsattr = IDLExport (newPos "" 0 0) (JavaDoc "") (IDLExpConst attrconst)
    attrconst = IDLConstDcl (IDLConstTypeString $ IDLStringType Nothing) 
                  s (IDLPrimLit $ IDLStringLit sermc)
    sermc = gshow $ (defValue t) /\ True

-- Produce JavaDoc out of a triple: method/argument/attribute name, type,
-- annotation.

mkjdoc ntcs = JavaDoc $ unlines $ jdstart ++ concatMap jdarg ntcs ++ jdend where
  jdstart = ["/**"]
  jdend = [" */"]
  jdbg = " * "
  jdarg (t@('@':_), "", anno) = map (jdbg ++) $ lines (t ++ " " ++ anno)
  jdarg (methn, "", methc) = map (jdbg ++) $ lines methc
  jdarg ("this", "@this", _) = []
  jdarg (argn, argt, argc) = map (jdbg ++) $ lines ("@param " ++ argn ++ " " ++ argc)

-- Produce a method declaration for an attribute.

aexp s t b = IDLExpAttr $ IDLAttrDcl [] b (str2type $ idlType t) s [] []

-- Produce an export declaration for a method.

mexp f ntcs = IDLExpOp $ IDLOpDcl [] [] mthtype mthname pdecls [] where
  (meth, args) = case ntcs of
    [] -> error "Empty method descriptor list"
    (m : a) -> (m, filter (\s -> sel2 s `notElem` ["", "@this"]) a)
  ts = methTypeSig (f, ntcs)
  mthname = sel1 meth
  mthtype = str2type (fst ts)
  pdecls = map pdecl args
  pdecl (argn, argt, _) = IDLParamDcl [] [IDLParamIn] (str2type argt) Nothing argn

-- Map a string representation of a type to an IDL type.

str2type "@this" = IDLParamScopedSpec $ bldsn "@this"
str2type s@(':':':':_) = IDLParamScopedSpec $ bldsn s
str2type "void" = IDLParamVoid
str2type "boolean" = IDLParamBaseSpec IDLBaseTypeBool
str2type "DOMString" = IDLParamStringSpec $ IDLStringType Nothing
str2type z = error $ "unknown mapping for type '" ++ z ++ "'"

-- | Build a WebIDL specification out of one or more definitions. If a definition
-- is an interface, and it contains constants wirh serialized method codes, 
-- they will be dropped.

defIDLSpec :: IDLDef -> IDLSpecification

defIDLSpec idf = map (IDLDefinition (newPos "" 0 0) (JavaDoc "")) [uncode idf] where
  this2itfn itfn 
            x@(IDLExport sp jd (IDLExpOp (IDLOpDcl xa mboa (IDLParamScopedSpec sn) opn pds exs))) =
    case prtsn sn of
      "@this" -> 
        let sn' = bldsn itfn
        in  IDLExport sp jd (IDLExpOp (IDLOpDcl xa mboa (IDLParamScopedSpec sn') opn pds exs))
      _ -> x
  this2itfn itfn
            x@(IDLExport sp jd (IDLExpAttr (IDLAttrDcl xa ow (IDLParamScopedSpec sn) atn sx rx))) =
    case prtsn sn of
      "@this" -> 
        let sn' = bldsn itfn
        in  IDLExport sp jd  (IDLExpAttr (IDLAttrDcl xa ow (IDLParamScopedSpec sn') atn sx rx))
      _ -> x
  this2itfn _ z = z
  uncode (IDLDefInterface itfn xa sn (Just (IDLInterfaceBody exps))) =
    IDLDefInterface itfn xa sn $ Just $ IDLInterfaceBody $ 
                                        map (this2itfn itfn) $ filter (null . jsmcode) exps
  uncode z = z

-- | Build a Javascript object literal out of an interface definition. Method codes are
-- expected to be stored in specially named string constants. String constants are not allowed
-- in WebIDL, so they serve only as temporary storage.

mkObject :: IDLDef -> Expression ()

mkObject (IDLDefInterface itfn xa sn (Just (IDLInterfaceBody exps))) =
  let serms = concatMap jsmcode exps
      props = map (PropString () . sel1) serms
      getexp a = case gread a of
        [] -> NullLit True
        (c, _) : _ -> c
      meths = map ((/\ ()) . getexp . sel2) serms
  in  ObjectLit () $ zip props meths 

mkObject _ = NullLit ()

-- | Build a complete definition of a constructor along with the object definition.
-- The constructor is always nullary (which corresponds to the default extended attribute
-- for the interface).

mkConstr :: IDLDef -> Statement ()

mkConstr itf@(IDLDefInterface itfn xa sn (Just (IDLInterfaceBody exps))) =
  let obj = mkObject itf
  in  FunctionStmt () (Id () itfn) [] $ BlockStmt () [ReturnStmt () $ Just obj]

-- | Get a value of an attribute into a temporary variable. Attributes should be referred
-- to via Haskell names they were defined with. Only the object self-reference may be
-- used for attribute access.

attrGet :: (IDLTypeable t)
        => Attribute t                           -- ^ attribute as defined elsewhere
        -> Expression This                       -- ^ object self-reference
        -> JSMW x y (Expression t)               -- ^ value retrieved

attrGet (s, t, b, a) expth = once =<< dotRef s expth

-- | Set a value of an attribute ensuring the code is compiled. Attributes should be referred
-- to via Haskell names they were defined with. Only the object self-reference may be
-- used for attribute access. Whether the atribute was defined as read-only or not,
-- object's own methods always can modify attributes' values.

attrSet :: (IDLTypeable t)
        => Attribute t                           -- ^ attribute as defined elsewhere
        -> Expression t                          -- ^ value to set the attribute to
        -> Expression This                       -- ^ object self-reference
        -> JSMW x y (Expression This)            -- ^ updated object for monadic chaining

attrSet (s, t, b, a) v expth = once =<< setjsProperty s v expth

-- | Given an interface definition, format and output IDL and Javascript
-- files in the directory specified. It is expected that interfaces
-- are defined at the top level (no enclosing modules).

writeFiles :: FilePath                           -- ^ directory where to save; empty string
                                                 --   is treated same as \".\" (dot): the
                                                 --   current directory
           -> IDLDef                             -- ^ interface definition completed: file
                                                 --   names are taken from its name
           -> IO ()                              -- ^ no value returned

writeFiles base itf@(IDLDefInterface itfn _ _ _) = do
  let base' = if null base then "." else base
      idlfile = base' </> itfn <.> "idl"
      jsfile = base' </> itfn <.> "js"
  writeFile idlfile $ prettyPrint $ defIDLSpec itf
  writeFile jsfile $ show $ stmt $ mkConstr itf

writeFiles _ _ = error "Not an IDL interface definition supplied"

-- Utility: detect a constant holding a serialized method code.

jsmcode :: IDLExport -> [(String, String)]

jsmcode (IDLExport sp jd (
  IDLExpConst (
    IDLConstDcl (IDLConstTypeString (IDLStringType Nothing)) cname (IDLPrimLit (IDLStringLit cval))
      )
    )
  ) = [(cname, cval)]

jsmcode z = []

-- Utility: build a scoped name from a string.

bldsn :: String -> IDLScopedName

bldsn (':':':':n) = IDLScopedName True (mksn n)
bldsn n = IDLScopedName False (mksn n)

mksn = filter (not . null) . lines . map c2nl where
  c2nl ':' = '\n'
  c2nl z = z

-- Utility: convert a scoped name into a string.

prtsn :: IDLScopedName -> String

prtsn (IDLScopedName _ []) = ""
prtsn (IDLScopedName True ss) = "::" ++ prtsn (IDLScopedName False ss)
prtsn (IDLScopedName False ss) = intercalate "::" ss