{-# LINE 1 "src/Foreign/R/Context.hsc" #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE CApiFFI           #-}
-- |
-- Copyright: 2018 (C) Tweag I/O Limited.
--
-- inline-c context.
module Foreign.R.Context
  ( rCtx
  , SEXPREC
  , SEXP0
  , Logical(..)
  ) where

import Data.Complex
import qualified Data.Map as Map
import Foreign.C
import Foreign.Ptr
import Foreign.Storable
import Language.C.Types (TypeSpecifier(TypeName))
import Language.C.Inline.Context (Context(..))
import Internal.Error



data {-# CTYPE  "SEXPREC" #-} SEXPREC

type SEXP0 = Ptr SEXPREC

-- | R uses three-valued logic.
data {-# CTYPE "Logical" #-} Logical = FALSE
             | TRUE
             | NA
-- XXX no Enum instance because NA = INT_MIN, not representable as an Int on
-- 32-bit systems.
               deriving (Logical -> Logical -> Bool
(Logical -> Logical -> Bool)
-> (Logical -> Logical -> Bool) -> Eq Logical
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Logical -> Logical -> Bool
$c/= :: Logical -> Logical -> Bool
== :: Logical -> Logical -> Bool
$c== :: Logical -> Logical -> Bool
Eq, Eq Logical
Eq Logical =>
(Logical -> Logical -> Ordering)
-> (Logical -> Logical -> Bool)
-> (Logical -> Logical -> Bool)
-> (Logical -> Logical -> Bool)
-> (Logical -> Logical -> Bool)
-> (Logical -> Logical -> Logical)
-> (Logical -> Logical -> Logical)
-> Ord Logical
Logical -> Logical -> Bool
Logical -> Logical -> Ordering
Logical -> Logical -> Logical
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Logical -> Logical -> Logical
$cmin :: Logical -> Logical -> Logical
max :: Logical -> Logical -> Logical
$cmax :: Logical -> Logical -> Logical
>= :: Logical -> Logical -> Bool
$c>= :: Logical -> Logical -> Bool
> :: Logical -> Logical -> Bool
$c> :: Logical -> Logical -> Bool
<= :: Logical -> Logical -> Bool
$c<= :: Logical -> Logical -> Bool
< :: Logical -> Logical -> Bool
$c< :: Logical -> Logical -> Bool
compare :: Logical -> Logical -> Ordering
$ccompare :: Logical -> Logical -> Ordering
$cp1Ord :: Eq Logical
Ord, Int -> Logical -> ShowS
[Logical] -> ShowS
Logical -> String
(Int -> Logical -> ShowS)
-> (Logical -> String) -> ([Logical] -> ShowS) -> Show Logical
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Logical] -> ShowS
$cshowList :: [Logical] -> ShowS
show :: Logical -> String
$cshow :: Logical -> String
showsPrec :: Int -> Logical -> ShowS
$cshowsPrec :: Int -> Logical -> ShowS
Show)

instance Storable Logical where
  sizeOf :: Logical -> Int
sizeOf _       = CInt -> Int
forall a. Storable a => a -> Int
sizeOf (CInt
forall a. HasCallStack => a
undefined :: CInt)
  alignment :: Logical -> Int
alignment _    = CInt -> Int
forall a. Storable a => a -> Int
alignment (CInt
forall a. HasCallStack => a
undefined :: CInt)
  poke :: Ptr Logical -> Logical -> IO ()
poke ptr :: Ptr Logical
ptr FALSE = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Logical -> Ptr CInt
forall a b. Ptr a -> Ptr b
castPtr Ptr Logical
ptr) (0 :: CInt)
  poke ptr :: Ptr Logical
ptr TRUE  = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Logical -> Ptr CInt
forall a b. Ptr a -> Ptr b
castPtr Ptr Logical
ptr) (1 :: CInt)
  -- Currently NA_LOGICAL = INT_MIN.
  poke ptr :: Ptr Logical
ptr NA    = Ptr CInt -> CInt -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Logical -> Ptr CInt
forall a b. Ptr a -> Ptr b
castPtr Ptr Logical
ptr) (-2147483648 :: CInt)
{-# LINE 45 "src/Foreign/R/Context.hsc" #-}
  peek ptr = do
      x <- peek (castPtr ptr)
      case x :: CInt of
          0 -> return FALSE
          1 -> return TRUE
          -2147483648 -> return NA
{-# LINE 51 "src/Foreign/R/Context.hsc" #-}
          _ -> failure "Storable Logical peek" "Not a Logical."

rCtx :: Context
rCtx :: Context
rCtx = Context
forall a. Monoid a => a
mempty { ctxTypesTable :: TypesTable
ctxTypesTable = [(TypeSpecifier, TypeQ)] -> TypesTable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TypeSpecifier, TypeQ)]
tytabs }
  where
    tytabs :: [(TypeSpecifier, TypeQ)]
tytabs =
      [ (CIdentifier -> TypeSpecifier
TypeName "SEXP", [t| Ptr SEXPREC |])
      , (CIdentifier -> TypeSpecifier
TypeName "Rcomplex", [t| Complex Double |])
      ]