{-# LANGUAGE OverloadedStrings #-}
module IRTS.Cil.FFI
  ( parseDescriptor
  , parseForeignFunctionType
  , assemblyNameAndTypeFrom
  , foreignType
  , isIO
  , CILForeign(..)
  , ForeignFunctionType(..)
  ) where

import qualified Data.HashMap.Strict as HM
import           Data.Maybe
import           Data.Monoid ((<>))
import           Data.Text hiding (map, init, last)

import           IRTS.Lang (FDesc(..))
import           Idris.Core.TT (Name(..), sUN)

import           Language.Cil (PrimitiveType(..), MethodRef(..), CallConv(..), Version)
import           Language.Cil.Pretty (pr)

import           IRTS.Cil.Parsers (parseVersion)

type CILTy = PrimitiveType

data CILForeign
  = CILInstance       !String
  | CILInstanceCustom !String ![CILTy] !CILTy
  | CILInstanceField  !String
  | CILStatic         !CILTy !String
  | CILStaticField    !CILTy !String
  | CILCall           !MethodRef
  | CILConstructor
  | CILTypeOf         !CILTy
  | CILDelegate       !CILTy
  | CILExport         !String
  | CILDefault
  deriving Show

parseDescriptor :: FDesc -> CILForeign
parseDescriptor (FApp ffi [declType, FStr fn])
  | ffi == sUN "CILStatic"         = CILStatic (foreignType declType) fn
parseDescriptor (FApp ffi [declType, FStr fn])
  | ffi == sUN "CILStaticField"    = CILStaticField (foreignType declType) fn
parseDescriptor (FApp ffi [FStr fn])
  | ffi == sUN "CILInstance"       = CILInstance fn
parseDescriptor (FApp ffi [FStr fn, paramTys, retTy])
  | ffi == sUN "CILInstanceCustom" = CILInstanceCustom fn (foreignTypeList paramTys) (foreignType retTy)
parseDescriptor (FApp ffi [FStr fn])
  | ffi == sUN "CILInstanceField"  = CILInstanceField fn
parseDescriptor (FCon ffi)
  | ffi == sUN "CILConstructor"    = CILConstructor
parseDescriptor (FApp ffi [ty])
  | ffi == sUN "CILDelegate"       = CILDelegate (foreignType ty)
parseDescriptor (FApp ffi [ty])
  | ffi == sUN "CILTypeOf"         = CILTypeOf (foreignType ty)
parseDescriptor (FApp ffi [method])
  | ffi == sUN "CILCall"           = CILCall (foreignMethod method)
parseDescriptor e = error $ "invalid foreign descriptor: " <> show e

foreignMethod :: FDesc -> MethodRef
foreignMethod (FApp ctor [cc, declTy, FStr methodName, typeArgs, paramTys, retTy]) | ctor == sUN "CILGenMethod" =
    GenericMethodInstance (foreignCallConvention cc)
                          (foreignType declTy) methodName
                          (foreignTypeList typeArgs) (foreignTypeList paramTys) (foreignType retTy)
foreignMethod e = error $ "invalid foreign method descriptor: " <> show e

foreignCallConvention :: FDesc -> [CallConv]
foreignCallConvention (FCon n) | n == sUN "CCCStatic" = []
foreignCallConvention (FCon n) | n == sUN "CCCInstance" = [CcInstance]
foreignCallConvention e = error $ "invalid foreign calling convention: " <> show e

isIO :: FDesc -> Bool
isIO (FIO _) = True
isIO _       = False

foreignType :: FDesc -> PrimitiveType
foreignType (FStr exportedDataType) = ValueType "" exportedDataType
foreignType (FCon t)                = foreignTypeByName t
foreignType (FIO t)                 = foreignType t

foreignType (FApp cilTy [_, ty])
  | cilTy == sUN "CIL_Array" = foreignType ty

foreignType (FApp cilTy [ty, _])
  | cilTy == sUN "TypedArray" = foreignType ty

foreignType (FApp cilTy [ty])
  | cilTy == sUN "CIL_CILT" = foreignType ty

foreignType (FApp cilTy [ty])
  | cilTy == sUN "CIL" = foreignType ty

foreignType (FApp cilTy [_, ty, _])
  | cilTy == sUN "CIL_FnT" = foreignType ty

foreignType (FApp cilTy [_, ty])
  | cilTy == sUN "CIL_Ref" = ByRef $ foreignType ty

foreignType (FApp cilTy [_, ty])
  | cilTy == sUN "CIL_MaybeT" = foreignType ty

foreignType (FApp cilTy [_, ty])
  | cilTy == sUN "CIL_EnumT" = foreignType ty

foreignType (FApp cilTy [ty])
  | cilTy == sUN "CILTyArr" = Array $ foreignType ty

foreignType (FApp cilTy [FStr assembly, FStr typeName])
  | cilTy == sUN "CILTyRef" =
    case (assembly, typeName) of
      ("", "object") -> Object
      ("", "string") -> String
      ("", "void")   -> Void
      _              -> ReferenceType assembly typeName

foreignType (FApp cilTy [FStr assembly, FStr typeName])
  | cilTy == sUN "CILTyVal" =
    case (assembly, typeName) of
      ("", "float32") -> Float32
      ("", "float64") -> Double64
      ("", "bool")    -> Bool
      ("", "int")     -> Int32
      ("", "char")    -> Char
      _               -> ValueType assembly typeName

foreignType (FApp cilTy [_, FCon (UN cilIntTy)])
  | cilTy == sUN "CIL_IntT" =
    let intName = unpack cilIntTy
    in case intName of
         "CIL_IntChar"   -> Char
         "CIL_IntNative" -> Int32
         _               -> error $ "Unsupported foreign int type `" <> intName <> "'"

foreignType (FApp cilTy [def, typeArgs])
  | cilTy == sUN "CILTyGen" = GenericReferenceTypeInstance assembly typeName cilTyArgs
  where (ReferenceType assembly typeName) = foreignType def
        cilTyArgs = foreignTypeList typeArgs

foreignType (FApp cilTy [FStr paramIndex])
  | cilTy == sUN "CILTyGenParam" = GenericType (read paramIndex)

foreignType (FApp cilTy [FStr paramIndex])
  | cilTy == sUN "CILTyGenMethodParam" = GenericMethodTypeParameter (read paramIndex)

foreignType d = error $ "invalid type descriptor: " <> show d

foreignTypeList :: FDesc -> [CILTy]
foreignTypeList = (foreignType <$>) . foreignList

foreignList :: FDesc -> [FDesc]
foreignList (FApp tag [_, x, xs])
  | tag == sUN "::"  = x : foreignList xs
foreignList (FApp tag [_])
  | tag == sUN "Nil" = []
foreignList d        = error $ "invalid foreign list: " <> show d

assemblyNameAndTypeFrom :: PrimitiveType -> (String, String)
assemblyNameAndTypeFrom (ReferenceType assemblyName typeName) = (assemblyName, typeName)
assemblyNameAndTypeFrom (ValueType     assemblyName typeName) = (assemblyName, typeName)
assemblyNameAndTypeFrom gti@GenericReferenceTypeInstance{}    = ("", pr gti "")
assemblyNameAndTypeFrom String = ("", "string")
assemblyNameAndTypeFrom Object = ("", "object")
assemblyNameAndTypeFrom Int32  = ("", "int32")
assemblyNameAndTypeFrom Double64 = ("", "float64")
assemblyNameAndTypeFrom t = error $ "unsupported assembly name for: " <> show t

foreignTypeByName :: Name -> PrimitiveType
foreignTypeByName (UN typeName) =
  fromMaybe
    (unsupportedForeignType $ unpack typeName)
    (HM.lookup typeName foreignTypes)
foreignTypeByName n = unsupportedForeignType $ show n

unsupportedForeignType :: String -> a
unsupportedForeignType = error . ("Unsupported foreign type: " <>)

foreignTypes :: HM.HashMap Text PrimitiveType
foreignTypes = HM.fromList
  [ ("CIL_Str",   String)
  , ("CIL_Ptr",   Object)
  , ("CIL_Float", Double64)
  , ("CIL_Bool",  Bool)
  , ("CIL_Unit",  Void)
  ]

data ForeignFunctionType = ForeignFunctionType
  { parameterTypes :: ![PrimitiveType]
  , returnType     :: !PrimitiveType
  , returnTypeIO   :: !Bool
  } deriving (Eq, Ord, Show)

data CILFn
  = CILFnIO !PrimitiveType
  | CILFn   !PrimitiveType

unCILFn :: CILFn -> PrimitiveType
unCILFn (CILFnIO t) = t
unCILFn (CILFn t)   = t

parseForeignFunctionType :: FDesc -> ForeignFunctionType
parseForeignFunctionType (FApp n [_, _, fnT]) | n == sUN "CIL_FnT" =
  let ft = functionType fnT
      retType = last ft
      io = case retType of { CILFnIO _ -> True; _ -> False }
  in ForeignFunctionType (unCILFn <$> init ft) (unCILFn retType) io
parseForeignFunctionType d = functionTypeError d

functionType :: FDesc -> [CILFn]
functionType (FApp n [_, _, pT, fnT]) | n == sUN "CIL_Fn"     = CILFn (foreignType pT) : functionType fnT
functionType (FApp n [_, _, ret])     | n == sUN "CIL_FnIO"   = [CILFnIO (foreignType ret)]
functionType (FApp n [_, ret])        | n == sUN "CIL_FnBase" = [CILFn (foreignType ret)]
functionType d = functionTypeError d

functionTypeError :: FDesc -> a
functionTypeError d = error $ "foreign function signature: " <> show d
