{-# 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