Add specs for Language.R*

tweag · Jan 10, 2024 · e2d2d35 · e2d2d35
1 parent f7a6951
commit e2d2d35
Show file tree

Hide file tree

Showing 5 changed files with 95 additions and 67 deletions.
diff --git a/inline-r/inline-r.cabal b/inline-r/inline-r.cabal
@@ -59,18 +59,19 @@ library
     Foreign.R.Internal
     Foreign.R.Parse
     Foreign.R.Type
+    Foreign.R.Type.Singletons
 --    H.Prelude
 --    H.Prelude.Interactive
---    Language.R
+    Language.R
 --    Language.R.Debug
     Language.R.GC
     Language.R.Globals
     Language.R.HExp
     Language.R.Instance
---    Language.R.Internal
+    Language.R.Internal
     Language.R.Internal.FunWrappers
     Language.R.Internal.FunWrappers.TH
---    Language.R.Literal
+    Language.R.Literal
 --    Language.R.Matcher
 --    Language.R.QQ
   if !os(windows)

diff --git a/inline-r/src/Language/R.hs b/inline-r/src/Language/R.hs
@@ -36,12 +36,8 @@ import qualified Data.Vector.SEXP as Vector
 import Control.Monad.R.Class
 import Foreign.R
   ( SEXP
-  , SomeSEXP(..)
   , typeOf
-  , asTypeOf
   , cast
-  , unSomeSEXP
-  , unsafeCoerce
   )
 import qualified Foreign.R as R
 import qualified Foreign.R.Parse as R
@@ -73,7 +69,7 @@ import Prelude
 -- the dependency hierarchy.
 
 -- | Parse and then evaluate expression.
-parseEval :: ByteString -> IO (SomeSEXP V)
+parseEval :: ByteString -> IO (SEXP V)
 parseEval txt = useAsCString txt $ \ctxt ->
   R.withProtected (R.mkString ctxt) $ \rtxt ->
     alloca $ \status -> do
@@ -90,18 +86,20 @@ parseEval txt = useAsCString txt $ \ctxt ->
 --
 -- This function uses continuation because this is an easy way to make
 -- operations GC-safe.
-parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a
+{-@ parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a @-}
+parseFile :: FilePath -> (SEXP s -> IO a) -> IO a
 {-# DEPRECATED parseFile "Use [r| parse(file=\"path/to/file\") |] instead." #-}
 parseFile fl f = do
     withCString fl $ \cfl ->
       R.withProtected (R.mkString cfl) $ \rfl ->
         r1 (C8.pack "parse") rfl >>= \(R.SomeSEXP s) ->
-          return (R.unsafeCoerce s) `R.withProtected` f
+          return s `R.withProtected` f
 
+{-@ parseText :: String -> Bool -> IO (R.SEXP V 'R.Expr) @-}
 parseText
   :: String -- ^ Text to parse
   -> Bool   -- ^ Whether to annotate the AST with source locations.
-  -> IO (R.SEXP V 'R.Expr)
+  -> IO (R.SEXP V)
 {-# DEPRECATED parseText "Use [r| parse(text=...) |] instead." #-}
 parseText txt b = do
     s <- parseEval $ C8.pack $
@@ -112,22 +110,26 @@ parseText txt b = do
          | otherwise = "FALSE"
 
 -- | Internalize a symbol name.
-install :: MonadR m => String -> m (SEXP V 'R.Symbol)
+{-@ install :: String -> m (SEXP V 'R.Symbol) @-}
+install :: MonadR m => String -> m (SEXP V)
 install = io . installIO
 
 {-# DEPRECATED string, strings "Use mkSEXP instead" #-}
 
 -- | Create an R character string from a Haskell string.
-string :: String -> IO (SEXP V 'R.Char)
+{-@ string :: String -> IO (SEXP V 'R.Char) @-}
+string :: String -> IO (SEXP V)
 string str = withCString str R.mkChar
 
 -- | Create an R string vector from a Haskell string.
-strings :: String -> IO (SEXP V 'R.String)
+{-@ strings :: String -> IO (SEXP V 'R.String) @-}
+strings :: String -> IO (SEXP V)
 strings str = withCString str R.mkString
 
 -- | Evaluate a (sequence of) expression(s) in the given environment, returning the
 -- value of the last.
-evalEnv :: MonadR m => SEXP s a -> SEXP s 'R.Env -> m (SomeSEXP (Region m))
+{-@ evalEnv :: SEXP s a -> SEXP s 'R.Env -> m (SEXP (Region m)) @-}
+evalEnv :: MonadR m => SEXP s -> SEXP s -> m (SEXP (Region m))
 evalEnv (hexp -> Language.R.HExp.Expr _ v) rho = acquireSome =<< do
     io $ alloca $ \p -> do
       mapM_ (\(SomeSEXP s) -> void $ R.protect s) (Vector.toList v)
@@ -146,14 +148,15 @@ evalEnv x rho = acquireSome =<< do
       return v
 
 -- | Evaluate a (sequence of) expression(s) in the global environment.
-eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m))
+eval :: MonadR m => SEXP s -> m (SEXP (Region m))
 eval x = evalEnv x (R.release globalEnv)
 
 -- | Silent version of 'eval' function that discards it's result.
-eval_ :: MonadR m => SEXP s a -> m ()
+eval_ :: MonadR m => SEXP s -> m ()
 eval_ = void . eval
 
 -- | Throw an R error as an exception.
+{-@ throwR :: R.SEXP s 'R.Env -> m a @-}
 throwR :: MonadR m => R.SEXP s 'R.Env   -- ^ Environment in which to find error.
        -> m a
 throwR env = getErrorMessage env >>= io . throwIO . R.RError
@@ -173,7 +176,8 @@ throwRMessage :: MonadR m => String -> m a
 throwRMessage = io . throwIO . R.RError
 
 -- | Read last error message.
-getErrorMessage :: MonadR m => R.SEXP s 'R.Env -> m String
+{-@ getErrorMessage :: MonadR m => R.SEXP s 'R.Env -> m String @-}
+getErrorMessage :: MonadR m => R.SEXP s -> m String
 getErrorMessage e = io $ do
   R.withProtected (withCString "geterrmessage" ((R.install >=> R.lang1))) $ \f -> do
     R.withProtected (return (R.release e)) $ \env -> do

diff --git a/inline-r/src/Language/R/Internal.hs b/inline-r/src/Language/R/Internal.hs
@@ -19,17 +19,18 @@ inVoid = id
 {-# INLINE inVoid #-}
 
 -- | Call a pure unary R function of the given name in the global environment.
-r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V)
+r1 :: ByteString -> SEXP s -> IO (SEXP V)
 r1 fn a =
     useAsCString fn $ \cfn -> R.install cfn >>= \f ->
       R.withProtected (R.lang2 f (R.release a)) (unsafeRunRegion . inVoid . eval)
 
 -- | Call a pure binary R function. See 'r1' for additional comments.
-r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V)
+r2 :: ByteString -> SEXP s -> SEXP s -> IO (SEXP V)
 r2 fn a b =
     useAsCString fn $ \cfn -> R.install cfn >>= \f ->
       R.withProtected (R.lang3 f (R.release a) (R.release b)) (unsafeRunRegion . inVoid . eval)
 
 -- | Internalize a symbol name.
-installIO :: String -> IO (SEXP V 'R.Symbol)
+{-@ installIO :: String -> IO (TSEXP V Foreign.R.Type.Symbol) @-}
+installIO :: String -> IO (SEXP V)
 installIO str = withCString str R.install
diff --git a/inline-r/src/Language/R/Internal.hs-boot b/inline-r/src/Language/R/Internal.hs-boot
@@ -4,9 +4,8 @@ module Language.R.Internal where
 
 import Control.Memory.Region
 import Data.ByteString (ByteString)
-import Foreign.R (SEXP, SomeSEXP(..))
-import qualified Foreign.R.Type as R
+import Foreign.R (SEXP)
 
-r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V)
-r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V)
-installIO :: String -> IO (SEXP V 'R.Symbol)
+r1 :: ByteString -> SEXP s -> IO (SEXP V)
+r2 :: ByteString -> SEXP s -> SEXP s -> IO (SEXP V)
+installIO :: String -> IO (SEXP V)
diff --git a/inline-r/src/Language/R/Literal.hs b/inline-r/src/Language/R/Literal.hs
@@ -9,6 +9,7 @@
 {-# Language FlexibleInstances #-}
 {-# Language FunctionalDependencies #-}
 {-# Language GADTs #-}
+{-# Language KindSignatures #-}
 {-# Language LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -17,8 +18,11 @@
 {-# Language ViewPatterns #-}
 
 -- required to not warn about IsVector usage.
-{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -fno-warn-redundant-constraints -fplugin-opt=LiquidHaskell:--skip-module=False #-}
+{-@ LIQUID "--exact-data-cons" @-} -- needed to have LH accept specs in module HExp
+{-@ LIQUID "--prune-unsorted" @-}
 module Language.R.Literal
+  {-
   ( -- * Literals conversion
     Literal(..)
   , toPairList
@@ -33,16 +37,20 @@ module Language.R.Literal
   , mkProtectedSEXPVectorIO
     -- * Internal
   , funToSEXP
-  ) where
+  ) -} where
 
 import           Control.Memory.Region
 import           Control.Monad.R.Class
 import qualified Data.Vector.SEXP as SVector
 import qualified Data.Vector.SEXP.Mutable as SMVector
+import qualified Data.Vector.SEXP.Mutable as Mutable -- Needed to help LH name resolution
+import           Foreign.C  -- Needed to help LH name resolution
 import qualified Foreign.R as R
-import qualified Foreign.R.Internal as R (somesexp)
-import           Foreign.R.Type ( IsVector, SSEXPTYPE )
-import           Foreign.R ( SEXP, SomeSEXP(..) )
+import           Foreign.R.Type ( IsVector )
+import           Foreign.R.Type.Singletons (SSEXPTYPE)
+import           Foreign.R ( SEXP )
+import           GHC.ForeignPtr -- Needed to help LH name resolution
+import           GHC.ST -- Needed to help LH name resolution
 import           Internal.Error
 import           {-# SOURCE #-} Language.R.Internal (r1)
 import           Language.R.Globals (nilValue)
@@ -67,84 +75,98 @@ import qualified GHC.Foreign as GHC
 import GHC.IO.Encoding.UTF8
 import System.IO.Unsafe ( unsafePerformIO )
 
+{-@ measure Language.R.Literal.literalRType :: a -> R.SEXPTYPE @-}
+
 -- | Values that can be converted to 'SEXP'.
-class SingI ty => Literal a ty | a -> ty where
+class SingI ty => Literal a (ty :: R.SEXPTYPE) | a -> ty where
     -- | Internal function for converting a literal to a 'SEXP' value. You
     -- probably want to be using 'mkSEXP' instead.
-    mkSEXPIO :: a -> IO (SEXP V ty)
-    fromSEXP :: SEXP s ty -> a
+    {-@ mkSEXPIO :: x:a -> IO (TSEXP V (literalRType x)) @-}
+    mkSEXPIO :: a -> IO (SEXP V)
+    {-@ fromSEXP :: s:SEXP s -> {v:a | literalRType v == typeOf s} @-}
+    fromSEXP :: SEXP s -> a
+
+    {-@ literalRType :: x:a -> {v:R.SEXPTYPE | v == literalRType x } @-}
+    literalRType :: a -> R.SEXPTYPE
 
-    default mkSEXPIO :: (IsVector ty, Literal [a] ty) => a -> IO (SEXP V ty)
+{-
+    default mkSEXPIO :: (IsVector ty, Literal [a] ty) => a -> IO (SEXP V)
     mkSEXPIO x = mkSEXPIO [x]
 
-    default fromSEXP :: (IsVector ty, Literal [a] ty) => SEXP s ty -> a
+    default fromSEXP :: (IsVector ty, Literal [a] ty) => SEXP s -> a
     fromSEXP (fromSEXP -> [x]) = x
     fromSEXP _ = failure "fromSEXP" "Not a singleton vector."
+-}
 
 -- |  Create a SEXP value and protect it in current region
-mkSEXP :: (Literal a b, MonadR m) => a -> m (SEXP (Region m) b)
-mkSEXP x = acquire =<< io (mkSEXPIO x)
-
--- | Like 'fromSEXP', but with no static type satefy. Performs a dynamic
--- (i.e. at runtime) check instead.
-fromSomeSEXP :: forall s a form. (Literal a form) => R.SomeSEXP s -> a
-fromSomeSEXP = fromSEXP . R.cast (sing :: Sing form)
+{-@ assume mkSEXP :: x:a -> m (TSEXP (Region m) (literalRType x)) @-}
+mkSEXP :: (Literal a b, MonadR m) => a -> m (SEXP (Region m))
+mkSEXP x = io (mkSEXPIO x) >>= \a -> acquire a
 
 -- | Like 'fromSomeSEXP', but behaves like the @as.*@ family of functions
 -- in R, by performing a best effort conversion to the target form (e.g. rounds
 -- reals to integers, etc) for atomic types.
-dynSEXP :: forall a s ty. (Literal a ty) => SomeSEXP s -> a
-dynSEXP (SomeSEXP sx) =
-    fromSomeSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of
+dynSEXP :: forall a s ty. (Literal a ty) => SEXP s -> a
+dynSEXP sx =
+    fromSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of
       R.Char -> r1 "as.character" sx
       R.Int -> r1 "as.integer" sx
       R.Real -> r1 "as.double" sx
       R.Complex -> r1 "as.complex" sx
       R.Logical -> r1 "as.logical" sx
       R.Raw -> r1 "as.raw" sx
-      _ -> return $ SomeSEXP $ R.release sx
+      _ -> return $ R.release sx
 
 {-# NOINLINE mkSEXPVector #-}
-mkSEXPVector :: (Storable (SVector.ElemRep s a), IsVector a)
-             => SSEXPTYPE a
-             -> [IO (SVector.ElemRep s a)]
-             -> SEXP s a
+{-@ mkSEXPVector :: vt:VSEXPTYPE s a -> [IO a] -> TSEXP s (vstypeOf vt) @-}
+mkSEXPVector :: Storable a
+             => SVector.VSEXPTYPE s a
+             -> [IO a]
+             -> SEXP s
 mkSEXPVector ty allocators = unsafePerformIO $ mkSEXPVectorIO ty allocators
 
-mkSEXPVectorIO :: (Storable (SVector.ElemRep s a), IsVector a)
-               => SSEXPTYPE a
-               -> [IO (SVector.ElemRep s a)]
-               -> IO (SEXP s a)
+{-@ assume mkSEXPVectorIO :: vt:VSEXPTYPE s a -> [IO a] -> IO (TSEXP s (vstypeOf vt)) @-}
+{-@ ignore mkSEXPVectorIO @-}
+mkSEXPVectorIO :: Storable a
+               => SVector.VSEXPTYPE s a
+               -> [IO a]
+               -> IO (SEXP s)
 mkSEXPVectorIO ty allocators =
-    R.withProtected (R.allocVector ty $ length allocators) $ \vec -> do
+    R.withProtected (R.allocVector (SVector.vstypeOf ty) $ length allocators) $ \vec -> do
       let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
       zipWithM_ (\i -> (>>= pokeElemOff ptr i)) [0..] allocators
       return vec
 
 {-# NOINLINE mkProtectedSEXPVector #-}
-mkProtectedSEXPVector :: IsVector b
-                      => SSEXPTYPE b
-                      -> [SEXP s a]
-                      -> SEXP s b
+{-@
+mkProtectedSEXPVector :: vt:VSEXPTYPE s a -> [SEXP s] -> TSEXP s (vstypeOf vt)
+@-}
+mkProtectedSEXPVector :: SVector.VSEXPTYPE s a
+                      -> [SEXP s]
+                      -> SEXP s
 mkProtectedSEXPVector ty xs = unsafePerformIO $ mkProtectedSEXPVectorIO ty xs
 
-mkProtectedSEXPVectorIO :: IsVector b
-                        => SSEXPTYPE b
-                        -> [SEXP s a]
-                        -> IO (SEXP s b)
+{-@
+assume mkProtectedSEXPVectorIO :: vt:VSEXPTYPE s a -> [SEXP s] -> IO (TSEXP s (vstypeOf vt))
+ignore mkProtectedSEXPVectorIO
+@-}
+mkProtectedSEXPVectorIO :: SVector.VSEXPTYPE s a
+                        -> [SEXP s]
+                        -> IO (SEXP s)
 mkProtectedSEXPVectorIO ty xs = do
     mapM_ (void . R.protect) xs
-    z <- R.withProtected (R.allocVector ty $ length xs) $ \vec -> do
+    z <- R.withProtected (R.allocVector (SVector.vstypeOf ty) $ length xs) $ \vec -> do
            let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
            zipWithM_ (pokeElemOff ptr) [0..] xs
            return vec
     R.unprotect (length xs)
     return z
 
 instance Literal [R.Logical] 'R.Logical where
-    mkSEXPIO = mkSEXPVectorIO sing . map return
+    mkSEXPIO = mkSEXPVectorIO (fromSing sing) . map return
     fromSEXP (hexp -> Logical v) = SVector.toList v
 
+{-
 instance Literal [Int32] 'R.Int where
     mkSEXPIO = mkSEXPVectorIO sing . map return
     fromSEXP (hexp -> Int v) = SVector.toList v
@@ -256,7 +278,7 @@ instance (NFData a, Literal a la) => HFunWrap (R s a) (IO R.SEXP0) where
 
 instance (Literal a la, HFunWrap b wb)
          => HFunWrap (a -> b) (R.SEXP0 -> wb) where
-    hFunWrap f a = hFunWrap $ f $! fromSEXP (R.cast sing (R.somesexp a) :: SEXP s la)
+    hFunWrap f a = hFunWrap $ f $! fromSEXP (R.SEXP a :: SEXP s la)
 
 foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP
     :: FunPtr a -> IO (SEXP s 'R.ExtPtr)
@@ -265,3 +287,4 @@ funToSEXP :: HFunWrap a b => (b -> IO (FunPtr b)) -> a -> IO (SEXP s 'R.ExtPtr)
 funToSEXP w x = funPtrToSEXP =<< w (hFunWrap x)
 
 $(thWrapperLiterals 3 12)
+-}