content: {-# LANGUAGE FlexibleContexts  #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TupleSections     #-}
  {-# LANGUAGE ViewPatterns      #-}
  
  -- | Compile FFI definitions.
  
  module Fay.Compiler.FFI
    (emitFayToJs
    ,emitJsToFay
    ,compileFFIExp
    ,jsToFayHash
    ,fayToJsHash
    ,typeArity
    ) where
  
  import           Fay.Compiler.Prelude
  
  import           Fay.Compiler.Misc
  import           Fay.Compiler.Print           (printJSString)
  import           Fay.Compiler.QName
  import           Fay.Exts.NoAnnotation        (unAnn)
  import qualified Fay.Exts.NoAnnotation        as N
  import qualified Fay.Exts.Scoped              as S
  import           Fay.Types
  
  import           Control.Monad.Except         (throwError)
  import           Control.Monad.Writer         (tell)
  import           Data.Generics.Schemes
  import           Language.ECMAScript3.Parser  as JS
  import           Language.ECMAScript3.Syntax
  import           Language.Haskell.Exts        (SrcSpanInfo, prettyPrint)
  import           Language.Haskell.Exts.Syntax
  
  -- | Compile an FFI expression (also used when compiling top level definitions).
  compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp
  compileFFIExp loc (fmap unAnn -> nameopt) formatstr sig' =
    -- substitute newtypes with their child types before calling
    -- real compileFFI
    compileFFI' . unAnn =<< rmNewtys sig'
    where
      rmNewtys :: S.Type -> Compile N.Type
      rmNewtys typ = case typ of
        TyForall _ b c t  -> TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t
        TyFun _ t1 t2     -> TyFun () <$> rmNewtys t1 <*> rmNewtys t2
        TyTuple _ b tl    -> TyTuple () b <$> mapM rmNewtys tl
        TyList _ t        -> TyList () <$> rmNewtys t
        TyApp _ t1 t2     -> TyApp () <$> rmNewtys t1 <*> rmNewtys t2
        t@TyVar{}         -> return $ unAnn t
        TyCon _ qname     -> maybe (TyCon () (unAnn qname)) snd <$> lookupNewtypeConst qname
        TyParen _ t       -> TyParen () <$> rmNewtys t
        TyInfix _ t1 q t2 -> flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2
        TyKind _ t k      -> flip (TyKind ()) (unAnn k) <$> rmNewtys t
        TyPromoted {}     -> return $ unAnn typ
        TyParArray _ t    -> TyParArray () <$> rmNewtys t
        TyEquals _ t1 t2  -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2
        TySplice {}       -> return $ unAnn typ
        TyBang _ bt unp t -> TyBang () (unAnn bt) (unAnn unp) <$> rmNewtys t
        TyWildCard {}     -> error "TyWildCard not supported"
        TyQuasiQuote {}   -> error "TyQuasiQuote not supported"
        TyUnboxedSum {}   -> error "TyUnboxedSum not supported"
  
      compileFFI' :: N.Type -> Compile JsExp
      compileFFI' sig = do
        let name = fromMaybe "<exp>" nameopt
        inner <- formatFFI loc formatstr (zip params funcFundamentalTypes)
        case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of
          Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err))
          Right exp  -> do
            config' <- config id
            when (configGClosure config') $ warnDotUses loc inner exp
            return (body inner)
        where
          body inner = foldr wrapParam (wrapReturn inner) params
          wrapParam pname inner = JsFun Nothing [pname] [] (Just inner)
          params = zipWith const uniqueNames [1..typeArity sig]
          wrapReturn :: String -> JsExp
          wrapReturn inner = thunk $
            case lastMay funcFundamentalTypes of
              -- Returns a “pure” value;
              Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)
              -- Base case:
              Nothing -> JsRawExp inner
          funcFundamentalTypes = functionTypeArgs sig
          returnType = last funcFundamentalTypes
  
  -- | Warn about uses of naked x.y which will not play nicely with Google Closure.
  warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()
  warnDotUses srcSpanInfo string expr =
    when anyrefs $
      warn $ printSrcSpanInfo srcSpanInfo ++ ":\nDot ref syntax used in FFI JS code: " ++ string
  
    where
      anyrefs = not (null (listify dotref expr)) ||
                    not (null (listify ldot expr))
  
      dotref :: Expression SourcePos -> Bool
      dotref x = case x of
        DotRef _ (VarRef _ (Id _ name)) _
           | name `elem` globalNames -> False
        DotRef{}                     -> True
        _                            -> False
  
      ldot :: LValue SourcePos -> Bool
      ldot x =
        case x of
          LDot _ (VarRef _ (Id _ name)) _
           | name `elem` globalNames -> False
          LDot{}                     -> True
          _                          -> False
  
      globalNames = ["Math","console","JSON"]
  
  -- | Make a Fay→JS encoder.
  emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()
  emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do
    qname <- qualify name
    let ctrName = printJSString $ unQual qname
    tell $ mempty { writerFayToJs = [(ctrName, translator)] }
  
    where
      translator =
        JsFun Nothing
              [JsNameVar "type", argTypes, transcodingObjForced]
              (obj : fieldStmts (map (getIndex name tyvars) fieldTypes))
              (Just $ JsName obj_)
  
      obj :: JsStmt
      obj = JsVar obj_ $
        JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))]
  
      fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt]
      fieldStmts [] = []
      fieldStmts ((i,fieldType):fts) =
        JsVar obj_v field :
          JsIf (JsNeq JsUndefined (JsName obj_v))
            [JsSetPropExtern obj_ decl (JsName obj_v)]
            [] :
          fieldStmts fts
        where
          obj_v = JsNameVar $ UnQual () (Ident () $ "obj_" ++ d)
          decl = JsNameVar $ UnQual () (Ident () d)
          (d, field) = declField i fieldType
  
      obj_ = JsNameVar "obj_"
  
      -- Declare/encode Fay→JS field
      declField :: Int -> (N.Name,N.Type) -> (String,JsExp)
      declField i (fname,typ) =
        (prettyPrint fname
        ,fayToJs (SerializeUserArg i)
                 (argType typ)
                 (JsGetProp (JsName transcodingObjForced)
                            (JsNameVar (UnQual () fname))))
  
  -- | A name used for transcoding.
  transcodingObj :: JsName
  transcodingObj = JsNameVar "obj"
  
  -- | The name used for the forced version of a transcoding variable.
  transcodingObjForced :: JsName
  transcodingObjForced = JsNameVar "_obj"
  
  -- | Get arg types of a function type.
  functionTypeArgs :: N.Type -> [FundamentalType]
  functionTypeArgs t = case t of
    TyForall _ _ _ i -> functionTypeArgs i
    TyFun _ a b      -> argType a : functionTypeArgs b
    TyParen _ st     -> functionTypeArgs st
    r                -> [argType r]
  
  -- | Convert a Haskell type to an internal FFI representation.
  argType :: N.Type -> FundamentalType
  argType t = case t of
    TyCon _ (UnQual _ (Ident _ "String"))                -> StringType
    TyCon _ (UnQual _ (Ident _ "Double"))                -> DoubleType
    TyCon _ (UnQual _ (Ident _ "Int"))                   -> IntType
    TyCon _ (UnQual _ (Ident _ "Bool"))                  -> BoolType
    TyApp _ (TyCon _ (UnQual _ (Ident _ "Ptr"))) _       -> PtrType
    TyApp _ (TyCon _ (UnQual _ (Ident _ "Automatic"))) _ -> Automatic
    TyApp _ (TyCon _ (UnQual _ (Ident _ "Defined"))) a   -> Defined (argType a)
    TyApp _ (TyCon _ (UnQual _ (Ident _ "Nullable"))) a  -> Nullable (argType a)
    TyApp _ (TyCon _ (UnQual _ (Ident _ "Fay"))) a       -> JsType (argType a)
    TyFun _ x xs                  -> FunctionType (argType x : functionTypeArgs xs)
    TyList _ x                    -> ListType (argType x)
    TyTuple _ _ xs                -> TupleType (map argType xs)
    TyParen _ st                  -> argType st
    TyApp _ op arg                -> userDefined (reverse (arg : expandApp op))
    _                     ->
      -- No semantic point to this, merely to avoid GHC's broken
      -- warning.
      case t of
        TyCon _ (UnQual _ user)   -> UserDefined user []
        _ -> UnknownType
  
  -- | Expand a type application.
  expandApp :: N.Type -> [N.Type]
  expandApp (TyParen _ t) = expandApp t
  expandApp (TyApp _ op arg) = arg : expandApp op
  expandApp x = [x]
  
  -- | Generate a user-defined type.
  userDefined :: [N.Type] -> FundamentalType
  userDefined (TyCon _ (UnQual _ name):typs) = UserDefined name (map argType typs)
  userDefined _ = UnknownType
  
  -- | Translate: JS → Fay.
  jsToFay :: SerializeContext -> FundamentalType -> JsExp -> JsExp
  jsToFay = translate "jsToFay"
  -- | Translate: Fay → JS.
  fayToJs :: SerializeContext -> FundamentalType -> JsExp -> JsExp
  fayToJs = translate "fayToJs"
  
  -- | Make a translator.
  translate :: String -> SerializeContext -> FundamentalType -> JsExp -> JsExp
  translate method context typ exp = case typ of
    -- Unserialized types
    PtrType     -> exp
    -- Flat types
    StringType -> flat "string"
    DoubleType -> flat "double"
    IntType    -> flat "int"
    BoolType   -> flat "bool"
    -- Collapse monad
    JsType x | method == "jsToFay" -> js x
    -- Otherwise recursive stuff needs the big guns
    _ -> recursive
  
    where flat specialize =
            JsApp (JsName (JsBuiltIn (Ident () (method ++ "_" ++ specialize))))
                  [exp]
          recursive =
            JsApp (JsName (JsBuiltIn (Ident () method)))
                  [typeRep context typ
                  ,exp]
          js ty' =
            JsNew (JsBuiltIn "Monad")
                  [translate method context ty' exp]
  
  -- | Get a JS-representation of a fundamental type for encoding/decoding.
  typeRep :: SerializeContext -> FundamentalType -> JsExp
  typeRep context typ = case typ of
    FunctionType xs     -> JsList [JsLit $ JsStr "function",JsList (map (typeRep context) xs)]
    JsType x            -> JsList [JsLit $ JsStr "action",JsList [typeRep context x]]
    ListType x          -> JsList [JsLit $ JsStr "list",JsList [typeRep context x]]
    TupleType xs        -> JsList [JsLit $ JsStr "tuple",JsList (map (typeRep context) xs)]
    UserDefined name xs -> JsList [JsLit $ JsStr "user"
                                  ,JsLit $ JsStr (unname name)
                                  ,JsList (zipWith (\t i -> typeRep (setArg i context) t) xs [0..])]
    Defined x           -> JsList [JsLit $ JsStr "defined",JsList [typeRep context x]]
    Nullable x          -> JsList [JsLit $ JsStr "nullable",JsList [typeRep context x]]
    _ -> nom
  
    where
      setArg i SerializeUserArg{}   = SerializeUserArg i
      setArg _ c = c
      ret = JsList . return . JsLit . JsStr
      nom = case typ of
        StringType -> ret "string"
        DoubleType -> ret "double"
        PtrType    -> ret "ptr"
        Automatic  -> ret "automatic"
        IntType    -> ret "int"
        BoolType   -> ret "bool"
        DateType   -> ret "date"
        _          ->
          case context of
            SerializeAnywhere -> ret "unknown"
            SerializeUserArg i ->
              let args = JsName argTypes
                  automatic = JsIndex 0 (JsName JsParametrizedType)
                  thisArg = JsIndex i args
              in JsTernaryIf (JsInfix "&&" args thisArg)
                             thisArg
                             (JsTernaryIf (JsEq automatic (JsLit "automatic"))
                                          (ret "automatic")
                                          (ret "unknown"))
  
  -- | Get the arity of a type.
  typeArity :: Type a -> Int
  typeArity t = case t of
    TyForall _ _ _ i -> typeArity i
    TyFun _ _ b      -> 1 + typeArity b
    TyParen _ st     -> typeArity st
    _              -> 0
  
  -- | Format the FFI  format string with the given arguments.
  formatFFI :: SrcSpanInfo                -- ^ Source Location.
            -> String                     -- ^ The format string.
            -> [(JsName,FundamentalType)] -- ^ Arguments.
            -> Compile String             -- ^ The JS code.
  formatFFI loc formatstr args = go formatstr where
    go ('%':'*':xs) = do
      these <- mapM inject (zipWith const [1..] args)
      rest <- go xs
      return (intercalate "," these ++ rest)
    go ('%':'%':xs) = do
      rest <- go xs
      return ('%' : rest)
    go ['%'] = throwError (FfiFormatIncompleteArg loc)
    go ('%':(span isDigit -> (op,xs))) =
      case readMay op of
       Nothing -> throwError (FfiFormatBadChars loc op)
       Just n -> do
         this <- inject n
         rest <- go xs
         return (this ++ rest)
    go (x:xs) = do rest <- go xs
                   return (x : rest)
    go [] = return []
  
    inject n =
      case listToMaybe (drop (n-1) args) of
        Nothing -> throwError (FfiFormatNoSuchArg loc n)
        Just (arg,typ) ->
          return (printJSString (fayToJs SerializeAnywhere typ (JsName arg)))
  
  -- | Generate n name-typ pairs from the given list.
  explodeFields :: [([a], t)] -> [(a, t)]
  explodeFields = concatMap $ \(names,typ) -> map (,typ) names
  
  -- | Generate Fay→JS encoding.
  fayToJsHash :: [(String, JsExp)] -> [JsStmt]
  fayToJsHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "fayToJsHash", JsObj cases]]
  
  -- | Generate JS→Fay decoding.
  jsToFayHash :: [(String, JsExp)] -> [JsStmt]
  jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]]
  
  -- | Make a JS→Fay decoder.
  emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],Type d)] -> Compile ()
  emitJsToFay (unAnn -> name) (map unAnn -> tyvars) (map (unAnn *** unAnn) . explodeFields -> fieldTypes) = do
    qname <- qualify name
    tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] })
  
    where
      translator qname =
        JsFun Nothing [JsNameVar "type", argTypes, transcodingObj] []
              (Just $ JsNew (JsConstructor qname)
                            (map (decodeField . getIndex name tyvars) fieldTypes))
      -- Decode JS→Fay field
      decodeField :: (Int,(N.Name,N.Type)) -> JsExp
      decodeField (i,(fname,typ)) =
        jsToFay (SerializeUserArg i)
                (argType typ)
                (JsGetPropExtern (JsName transcodingObj)
                                 (prettyPrint fname))
  
  -- | The argument types used in serialization of parametrized user-defined types.
  argTypes :: JsName
  argTypes = JsNameVar "argTypes"
  
  -- | Get the index of a name from the set of type variables bindings.
  getIndex :: Name a -> [TyVarBind b] -> (Name c,Type d) -> (Int,(N.Name,N.Type))
  getIndex (unAnn -> name) (map unAnn -> tyvars) (unAnn -> sname,unAnn -> ty) =
    case ty of
      TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of
        Nothing -> error $ "unknown type variable " ++ prettyPrint tyname ++
                           " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," ++
                           " vars were: " ++ unwords (map prettyPrint tyvars) ++ ", rest: " ++ show tyvars
        Just i -> (i,(sname,ty))
      _ -> (0,(sname,ty))
  
  -- | Extract the name from a possibly-kinded tyvar.
  tyvar :: N.TyVarBind -> N.Name
  tyvar (UnkindedVar _ v) = v
  tyvar (KindedVar _ v _) = v
  