Skip to content

Commit 75cc29b

Browse files
facundominguezfacundominguez
committed
Add specs for Language.R*
1 parent f45f5d9 commit 75cc29b

File tree

7 files changed

+265
-178
lines changed

7 files changed

+265
-178
lines changed

‎inline-r/inline-r.cabal‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -59,18 +59,19 @@ library
5959
Foreign.R.Internal
6060
Foreign.R.Parse
6161
Foreign.R.Type
62+
Foreign.R.Type.Singletons
6263
-- H.Prelude
6364
-- H.Prelude.Interactive
64-
-- Language.R
65+
Language.R
6566
-- Language.R.Debug
6667
Language.R.GC
6768
Language.R.Globals
6869
Language.R.HExp
6970
Language.R.Instance
70-
-- Language.R.Internal
71+
Language.R.Internal
7172
Language.R.Internal.FunWrappers
7273
Language.R.Internal.FunWrappers.TH
73-
-- Language.R.Literal
74+
Language.R.Literal
7475
-- Language.R.Matcher
7576
-- Language.R.QQ
7677
if !os(windows)

‎inline-r/src/Language/R.hs‎

Lines changed: 31 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -36,12 +36,7 @@ import qualified Data.Vector.SEXP as Vector
3636
import Control.Monad.R.Class
3737
import Foreign.R
3838
( SEXP
39-
, SomeSEXP(..)
4039
, typeOf
41-
, asTypeOf
42-
, cast
43-
, unSomeSEXP
44-
, unsafeCoerce
4540
)
4641
import qualified Foreign.R as R
4742
import qualified Foreign.R.Parse as R
@@ -73,88 +68,96 @@ import Prelude
7368
-- the dependency hierarchy.
7469

7570
-- | Parse and then evaluate expression.
76-
parseEval :: ByteString -> IO (SomeSEXP V)
71+
parseEval :: ByteString -> IO (SEXP V)
7772
parseEval txt = useAsCString txt $ \ctxt ->
7873
R.withProtected (R.mkString ctxt) $ \rtxt ->
7974
alloca $ \status -> do
8075
R.withProtected (R.parseVector rtxt 1 status (R.release nilValue)) $ \exprs -> do
8176
rc <- fromIntegral <$> peek status
8277
unless (R.PARSE_OK == toEnum rc) $
8378
runRegion $ throwRMessage $ "Parse error in: " ++ C8.unpack txt
84-
SomeSEXP expr <- peek $ castPtr $ R.unsafeSEXPToVectorPtr exprs
79+
expr <- peek $ castPtr $ R.unsafeSEXPToVectorPtr exprs
8580
runRegion $ do
86-
SomeSEXP val <- eval expr
87-
return $ SomeSEXP (R.release val)
81+
val <- eval expr
82+
return (R.release val)
8883

8984
-- | Parse file and perform some actions on parsed file.
9085
--
9186
-- This function uses continuation because this is an easy way to make
9287
-- operations GC-safe.
93-
parseFile :: FilePath -> (SEXP s 'R.Expr -> IO a) -> IO a
88+
{-@ parseFile :: FilePath -> (SEXP s Foreign.R.Type.Expr -> IO a) -> IO a @-}
89+
parseFile :: FilePath -> (SEXP s -> IO a) -> IO a
9490
{-# DEPRECATED parseFile "Use [r| parse(file=\"path/to/file\") |] instead." #-}
9591
parseFile fl f = do
9692
withCString fl $ \cfl ->
9793
R.withProtected (R.mkString cfl) $ \rfl ->
98-
r1 (C8.pack "parse") rfl >>= \(R.SomeSEXP s) ->
99-
return (R.unsafeCoerce s) `R.withProtected` f
94+
r1 (C8.pack "parse") rfl >>= \s ->
95+
return s `R.withProtected` f
10096

97+
{-@ parseText :: String -> Bool -> IO (R.SEXP V Foreign.R.Type.Expr) @-}
10198
parseText
10299
:: String -- ^ Text to parse
103100
-> Bool -- ^ Whether to annotate the AST with source locations.
104-
-> IO (R.SEXP V 'R.Expr)
101+
-> IO (R.SEXP V)
105102
{-# DEPRECATED parseText "Use [r| parse(text=...) |] instead." #-}
106103
parseText txt b = do
107104
s <- parseEval $ C8.pack $
108105
"parse(text=" ++ show txt ++ ", keep.source=" ++ keep ++ ")"
109-
return $ (sing :: R.SSEXPTYPE 'R.Expr) `R.cast` s
106+
return $ R.Expr `R.checkSEXPTYPE` s
110107
where
111108
keep | b = "TRUE"
112109
| otherwise = "FALSE"
113110

114111
-- | Internalize a symbol name.
115-
install :: MonadR m => String -> m (SEXP V 'R.Symbol)
112+
{-@ install :: String -> m (SEXP V Foreign.R.Type.Symbol) @-}
113+
install :: MonadR m => String -> m (SEXP V)
116114
install = io . installIO
117115

118116
{-# DEPRECATED string, strings "Use mkSEXP instead" #-}
119117

120118
-- | Create an R character string from a Haskell string.
121-
string :: String -> IO (SEXP V 'R.Char)
119+
{-@ string :: String -> IO (SEXP V Foreign.R.Type.Char) @-}
120+
string :: String -> IO (SEXP V)
122121
string str = withCString str R.mkChar
123122

124123
-- | Create an R string vector from a Haskell string.
125-
strings :: String -> IO (SEXP V 'R.String)
124+
{-@ strings :: String -> IO (SEXP V Foreign.R.Type.String) @-}
125+
strings :: String -> IO (SEXP V)
126126
strings str = withCString str R.mkString
127127

128128
-- | Evaluate a (sequence of) expression(s) in the given environment, returning the
129129
-- value of the last.
130-
evalEnv :: MonadR m => SEXP s a -> SEXP s 'R.Env -> m (SomeSEXP (Region m))
131-
evalEnv (hexp -> Language.R.HExp.Expr _ v) rho = acquireSome =<< do
130+
{-@ assume evalEnv :: SEXP s a -> TSEXP s Foreign.R.Type.Env -> m (SEXP (Region m)) @-}
131+
{-@ ignore evalEnv @-}
132+
evalEnv :: MonadR m => SEXP s -> SEXP s -> m (SEXP (Region m))
133+
evalEnv (hexp -> Language.R.HExp.Expr _ v) rho = acquire =<< do
132134
io $ alloca $ \p -> do
133-
mapM_ (\(SomeSEXP s) -> void $ R.protect s) (Vector.toList v)
134-
x <- Prelude.last <$> forM (Vector.toList v) (\(SomeSEXP s) -> do
135+
mapM_ (\s -> void $ R.protect s) (Vector.toList v)
136+
x <- Prelude.last <$> forM (Vector.toList v) (\s -> do
135137
z <- R.tryEvalSilent s (R.release rho) p
136138
e <- peek p
137139
when (e /= 0) $ runRegion $ throwR rho
138140
return z)
139141
R.unprotect (Vector.length v)
140142
return x
141-
evalEnv x rho = acquireSome =<< do
143+
evalEnv x rho = acquire =<< do
142144
io $ alloca $ \p -> R.withProtected (return (R.release x)) $ \_ -> do
143145
v <- R.tryEvalSilent x rho p
144146
e <- peek p
145147
when (e /= 0) $ runRegion $ throwR rho
146148
return v
147149

148150
-- | Evaluate a (sequence of) expression(s) in the global environment.
149-
eval :: MonadR m => SEXP s a -> m (SomeSEXP (Region m))
151+
eval :: MonadR m => SEXP s -> m (SEXP (Region m))
150152
eval x = evalEnv x (R.release globalEnv)
151153

152154
-- | Silent version of 'eval' function that discards it's result.
153-
eval_ :: MonadR m => SEXP s a -> m ()
155+
eval_ :: MonadR m => SEXP s -> m ()
154156
eval_ = void . eval
155157

156158
-- | Throw an R error as an exception.
157-
throwR :: MonadR m => R.SEXP s 'R.Env -- ^ Environment in which to find error.
159+
{-@ throwR :: TSEXP s Foreign.R.Type.Env -> m a @-}
160+
throwR :: MonadR m => R.SEXP s -- ^ Environment in which to find error.
158161
-> m a
159162
throwR env = getErrorMessage env >>= io . throwIO . R.RError
160163

@@ -173,12 +176,13 @@ throwRMessage :: MonadR m => String -> m a
173176
throwRMessage = io . throwIO . R.RError
174177

175178
-- | Read last error message.
176-
getErrorMessage :: MonadR m => R.SEXP s 'R.Env -> m String
179+
{-@ getErrorMessage :: TSEXP s Foreign.R.Type.Env -> m String @-}
180+
getErrorMessage :: MonadR m => R.SEXP s -> m String
177181
getErrorMessage e = io $ do
178182
R.withProtected (withCString "geterrmessage" ((R.install >=> R.lang1))) $ \f -> do
179183
R.withProtected (return (R.release e)) $ \env -> do
180184
peekCString
181185
=<< R.char
182186
=<< peek
183-
=<< R.string . R.cast (sing :: R.SSEXPTYPE 'R.String)
187+
=<< R.string . checkSEXPTYPE R.SString
184188
=<< R.eval f env

‎inline-r/src/Language/R/HExp.hs‎

Lines changed: 17 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -198,14 +198,14 @@ htypeOf = \case
198198
Lang{} -> R.Lang
199199
Special{} -> R.Special
200200
Builtin{} -> R.Builtin
201-
Char{} -> R.Char
202-
Int{} -> R.Int
201+
Char{} -> R.SChar
202+
Int{} -> R.SInt
203203
Logical{} -> R.Logical
204204
Real{} -> R.Real
205-
Complex{} -> R.Complex
206-
String{} -> R.String
205+
Complex{} -> R.SComplex
206+
String{} -> R.SString
207207
DotDotDot{} -> R.List
208-
Vector{} -> R.Vector
208+
Vector{} -> R.SVector
209209
Expr{} -> R.Expr
210210
Bytecode{} -> R.Bytecode
211211
ExtPtr{} -> R.ExtPtr
@@ -216,7 +216,7 @@ htypeOf = \case
216216
{-@
217217
data HExp :: * -> * where
218218
Nil :: HExp s
219-
Symbol :: {e1:SEXP s| typeOf e1 == R.Char || typeOf e1 == R.Nil}
219+
Symbol :: {e1:SEXP s| typeOf e1 == R.SChar || typeOf e1 == R.Nil}
220220
-> SEXP s
221221
-> SEXP s
222222
-> HExp s
@@ -226,7 +226,7 @@ data HExp :: * -> * where
226226
-> HExp s
227227
Env :: {e1:SEXP s | typeOf e1 == R.List || typeOf e1 == R.Nil}
228228
-> {e2:SEXP s | typeOf e2 == R.Env || typeOf e2 == R.Nil}
229-
-> {e3:SEXP s | typeOf e3 == R.Vector || typeOf e3 == R.Nil}
229+
-> {e3:SEXP s | typeOf e3 == R.SVector || typeOf e3 == R.Nil}
230230
-> HExp s
231231
Closure :: {e1:SEXP s | typeOf e1 == R.List || typeOf e1 == R.Nil}
232232
-> SEXP s
@@ -241,22 +241,22 @@ data HExp :: * -> * where
241241
-> HExp s
242242
Special :: HExp s
243243
Builtin :: HExp s
244-
Char :: TVector Word8 R.Char
244+
Char :: TVector Word8 R.SChar
245245
-> HExp s
246246
Logical :: TVector Foreign.R.Context.Logical R.Logical
247247
-> HExp s
248-
Int :: TVector Int32 R.Int
248+
Int :: TVector Int32 R.SInt
249249
-> HExp s
250250
Real :: TVector Double R.Real
251251
-> HExp s
252-
Complex :: TVector (Complex Double) R.Complex
252+
Complex :: TVector (Complex Double) R.SComplex
253253
-> HExp s
254-
String :: TVector (TSEXP V R.Char) R.String
254+
String :: TVector (TSEXP V R.SChar) R.SString
255255
-> HExp s
256256
DotDotDot :: {e1:SEXP s | typeOf e1 == R.List || typeOf e1 == R.Nil}
257257
-> HExp s
258258
Vector :: Int32
259-
-> TVector (SEXP V) R.Vector
259+
-> TVector (SEXP V) R.SVector
260260
-> HExp s
261261
Expr :: Int32
262262
-> TVector (SEXP V) R.Expr
@@ -382,14 +382,14 @@ peekHExp s =
382382
<*> R.cdr s
383383
R.Special -> return Special
384384
R.Builtin -> return Builtin
385-
R.Char -> return $ Char (Vector.unsafeFromSEXP s)
385+
R.SChar -> return $ Char (Vector.unsafeFromSEXP s)
386386
R.Logical -> return $ Logical (Vector.unsafeFromSEXP s)
387-
R.Int -> return $ Int (Vector.unsafeFromSEXP s)
387+
R.SInt -> return $ Int (Vector.unsafeFromSEXP s)
388388
R.Real -> return $ Real (Vector.unsafeFromSEXP s)
389-
R.Complex -> return $ Complex (Vector.unsafeFromSEXP s)
390-
R.String -> return $ String (Vector.unsafeFromSEXP s)
389+
R.SComplex -> return $ Complex (Vector.unsafeFromSEXP s)
390+
R.SString -> return $ String (Vector.unsafeFromSEXP s)
391391
R.DotDotDot -> unimplemented $ "peekHExp: " ++ show (R.typeOf s)
392-
R.Vector ->
392+
R.SVector ->
393393
Vector <$> (fromIntegral <$> R.trueLength s)
394394
<*> pure (Vector.unsafeFromSEXP s)
395395
R.Expr ->

‎inline-r/src/Language/R/Internal.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,17 +19,18 @@ inVoid = id
1919
{-# INLINE inVoid #-}
2020

2121
-- | Call a pure unary R function of the given name in the global environment.
22-
r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V)
22+
r1 :: ByteString -> SEXP s -> IO (SEXP V)
2323
r1 fn a =
2424
useAsCString fn $ \cfn -> R.install cfn >>= \f ->
2525
R.withProtected (R.lang2 f (R.release a)) (unsafeRunRegion . inVoid . eval)
2626

2727
-- | Call a pure binary R function. See 'r1' for additional comments.
28-
r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V)
28+
r2 :: ByteString -> SEXP s -> SEXP s -> IO (SEXP V)
2929
r2 fn a b =
3030
useAsCString fn $ \cfn -> R.install cfn >>= \f ->
3131
R.withProtected (R.lang3 f (R.release a) (R.release b)) (unsafeRunRegion . inVoid . eval)
3232

3333
-- | Internalize a symbol name.
34-
installIO :: String -> IO (SEXP V 'R.Symbol)
34+
{-@ installIO :: String -> IO (TSEXP V Foreign.R.Type.Symbol) @-}
35+
installIO :: String -> IO (SEXP V)
3536
installIO str = withCString str R.install

‎inline-r/src/Language/R/Internal.hs-boot‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,8 @@ module Language.R.Internal where
44

55
import Control.Memory.Region
66
import Data.ByteString (ByteString)
7-
import Foreign.R (SEXP, SomeSEXP(..))
8-
import qualified Foreign.R.Type as R
7+
import Foreign.R (SEXP)
98

10-
r1 :: ByteString -> SEXP s a -> IO (SomeSEXP V)
11-
r2 :: ByteString -> SEXP s a -> SEXP s b -> IO (SomeSEXP V)
12-
installIO :: String -> IO (SEXP V 'R.Symbol)
9+
r1 :: ByteString -> SEXP s -> IO (SEXP V)
10+
r2 :: ByteString -> SEXP s -> SEXP s -> IO (SEXP V)
11+
installIO :: String -> IO (SEXP V)

‎inline-r/src/Language/R/Internal/FunWrappers/TH.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -74,7 +74,6 @@ thWrapperLiteral :: Int -> Q Dec
7474
thWrapperLiteral n = do
7575
let s = varT =<< newName "s"
7676
names1 <- replicateM (n + 1) $ newName "a"
77-
names2 <- replicateM (n + 1) $ newName "i"
7877
let mkTy [] = impossible "thWrapperLiteral"
7978
mkTy [x] = [t| $nR $s $x |]
8079
mkTy (x:xs) = [t| $x -> $(mkTy xs) |]
@@ -84,22 +83,24 @@ thWrapperLiteral n = do
8483
#else
8584
[classP (mkName "NFData") [varT (last names1)]] ++
8685
#endif
87-
zipWith f (map varT names1) (map varT names2)
86+
map (f . varT) names1
8887
where
8988
#if MIN_VERSION_template_haskell(2,10,0)
90-
f tv1 tv2 = foldl AppT (ConT (mkName "Literal")) <$> sequence [tv1, tv2]
89+
f tv1 = foldl AppT (ConT (mkName "Literal")) <$> sequence [tv1]
9190
#else
92-
f tv1 tv2 = classP (mkName "Literal") [tv1, tv2]
91+
f tv1 = classP (mkName "Literal") [tv1]
9392
#endif
9493
-- XXX: Ideally would import these names from their defining module, but
9594
-- see GHC bug #1012. Using 'mkName' is a workaround.
9695
nR = conT $ mkName "R"
9796
nwrapn = varE $ mkName $ "wrap" ++ show n
9897
nfunToSEXP = varE $ mkName "Language.R.Literal.funToSEXP"
9998
nLiteral = conT $ mkName "Literal"
100-
instanceD ctx [t| $nLiteral $(mkTy $ map varT names1) 'R.ExtPtr |]
99+
instanceD ctx [t| $nLiteral $(mkTy $ map varT names1) |]
101100
[ funD (mkName "mkSEXPIO")
102101
[ clause [] (normalB [| $nfunToSEXP $nwrapn |]) [] ]
103102
, funD (mkName "fromSEXP")
104103
[ clause [] (normalB [| unimplemented "thWrapperLiteral fromSEXP" |]) [] ]
104+
, funD (mkName "dynSEXP")
105+
[ clause [] (normalB [| unimplemented "thWrapperLiteral dynSEXP" |]) [] ]
105106
]

0 commit comments

Comments
 (0)