inline-c 0.5.0.0 → 0.5.0.1
raw patch · 5 files changed
+236/−1 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- inline-c.cabal +5/−1
- test/Dummy.hs +7/−0
- test/Language/C/Inline/ContextSpec.hs +90/−0
- test/Language/C/Inline/ParseSpec.hs +88/−0
- test/Language/C/Types/ParseSpec.hs +46/−0
inline-c.cabal view
@@ -1,5 +1,5 @@ name: inline-c-version: 0.5.0.0+version: 0.5.0.1 synopsis: Write Haskell source files including C code inline. No FFI required. description: See <https://github.com/fpco/inline-c/blob/master/README.md>. license: MIT@@ -53,6 +53,10 @@ hs-source-dirs: test main-is: tests.hs c-sources: test/tests.c+ other-modules: Dummy+ , Language.C.Inline.ContextSpec+ , Language.C.Inline.ParseSpec+ , Language.C.Types.ParseSpec build-depends: base >=4 && <5 , ansi-wl-pprint , containers
+ test/Dummy.hs view
@@ -0,0 +1,7 @@+-- | This module exists because of TH staging restrictions.+module Dummy (dummyFun) where++import Foreign.C.Types++dummyFun :: CDouble -> IO CDouble+dummyFun x = return $ cos x
+ test/Language/C/Inline/ContextSpec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+module Language.C.Inline.ContextSpec (spec) where++import Control.Monad.Trans.Class (lift)+import qualified Test.Hspec as Hspec+import Text.Parser.Char+import Text.Parser.Combinators+import qualified Language.Haskell.TH as TH+import Foreign.C.Types+import Foreign.Ptr (Ptr, FunPtr)++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<*), (*>))+#endif++import qualified Language.C.Types as C+import Language.C.Inline.Context++spec :: Hspec.SpecWith ()+spec = do+ Hspec.it "converts simple type correctly (1)" $ do+ shouldBeType (cty "int") [t| CInt |]+ Hspec.it "converts simple type correctly (2)" $ do+ shouldBeType (cty "char") [t| CChar |]+ Hspec.it "converts void" $ do+ shouldBeType (cty "void") [t| () |]+ Hspec.it "converts single ptr type" $ do+ shouldBeType (cty "long*") [t| Ptr CLong |]+ Hspec.it "converts double ptr type" $ do+ shouldBeType (cty "unsigned long**") [t| Ptr (Ptr CULong) |]+ Hspec.it "converts arrays" $ do+ shouldBeType (cty "double[]") [t| CArray CDouble |]+ Hspec.it "converts named things" $ do+ shouldBeType (cty "unsigned int foo[]") [t| CArray CUInt |]+ Hspec.it "converts arrays of pointers" $ do+ shouldBeType+ (cty "unsigned short *foo[]") [t| CArray (Ptr CUShort) |]+ Hspec.it "ignores qualifiers" $ do+ shouldBeType (cty "const short*") [t| Ptr CShort |]+ Hspec.it "ignores storage information" $ do+ shouldBeType (cty "extern unsigned long") [t| CULong |]+ Hspec.it "converts sized arrays" $ do+ shouldBeType (cty "float[4]") [t| CArray CFloat |]+ Hspec.it "converts variably sized arrays" $ do+ shouldBeType (cty "float[*]") [t| CArray CFloat |]+ Hspec.it "converts function pointers" $ do+ shouldBeType+ (cty "int (*f)(unsigned char, float)")+ [t| FunPtr (CUChar -> CFloat -> IO CInt) |]+ Hspec.it "converts complicated function pointers (1)" $ do+ -- pointer to function returning pointer to function returning int+ shouldBeType+ (cty "int (*(*)())()") [t| FunPtr (IO (FunPtr (IO CInt))) |]+ Hspec.it "converts complicated function pointerst (2)" $ do+ -- foo is an array of pointer to pointer to function returning+ -- pointer to array of pointer to char+ shouldBeType+ (cty "char *(*(**foo [])())[]")+ [t| CArray (Ptr (FunPtr (IO (Ptr (CArray (Ptr CChar)))))) |]+ Hspec.it "converts complicated function pointers (3)" $ do+ -- foo is an array of pointer to pointer to function taking int+ -- returning pointer to array of pointer to char+ shouldBeType+ (cty "char *(*(**foo [])(int x))[]")+ [t| CArray (Ptr (FunPtr (CInt -> IO (Ptr (CArray (Ptr CChar)))))) |]+ where+ goodConvert cTy = do+ mbHsTy <- TH.runQ $ convertType IO (ctxTypesTable baseCtx) cTy+ case mbHsTy of+ Nothing -> error $ "Could not convert type (goodConvert)"+ Just hsTy -> return hsTy++ shouldBeType cTy hsTy = do+ x <- goodConvert cTy+ y <- TH.runQ hsTy+ x `Hspec.shouldBe` y++ assertParse p s =+ case C.runCParser (const False) "spec" s (lift spaces *> p <* lift eof) of+ Left err -> error $ "Parse error (assertParse): " ++ show err+ Right x -> x++ cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s
+ test/Language/C/Inline/ParseSpec.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.C.Inline.ParseSpec (spec) where++import Control.Monad.Trans.Class (lift)+import qualified Test.Hspec as Hspec+import Text.Parser.Char+import Text.Parser.Combinators+import Text.RawString.QQ (r)+import Control.Monad (void)+import Control.Exception (evaluate)+import Data.Monoid ((<>))+import Text.Regex.Posix ((=~))++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<*), (*>))+#endif++import qualified Language.C.Types as C+import Language.C.Inline.Internal+import Language.C.Inline.Context++spec :: Hspec.SpecWith ()+spec = do+ Hspec.describe "parsing" $ do+ Hspec.it "parses simple C expression" $ do+ (retType, params, cExp) <- goodParse [r|+ int { (int) ceil($(double x) + ((double) $(float y))) }+ |]+ retType `Hspec.shouldBe` (cty "int")+ params `shouldMatchParameters` [(cty "double", Plain "x"), (cty "float", Plain "y")]+ cExp `shouldMatchBody` " (int) ceil(x[a-z0-9_]+ \\+ ((double) y[a-z0-9_]+)) "+ Hspec.it "accepts anti quotes" $ do+ void $ goodParse [r| int { $(int x) } |]+ Hspec.it "rejects if bad braces (1)" $ do+ badParse [r| int x |]+ Hspec.it "rejects if bad braces (2)" $ do+ badParse [r| int { x |]+ Hspec.it "parses function pointers" $ do+ void $ goodParse [r| int(int (*add)(int, int)) { add(3, 4) } |]+ Hspec.it "parses returning function pointers" $ do+ (retType, params, cExp) <-+ goodParse [r| double (*)(double) { &cos } |]+ retType `Hspec.shouldBe` (cty "double (*)(double)")+ params `shouldMatchParameters` []+ cExp `shouldMatchBody` " &cos "+ where+ ctx = baseCtx <> funCtx++ assertParse p s =+ case C.runCParser (const False) "spec" s (lift spaces *> p <* lift eof) of+ Left err -> error $ "Parse error (assertParse): " ++ show err+ Right x -> x++ -- We use show + length to fully evaluate the result -- there+ -- might be exceptions hiding. TODO get rid of exceptions.+ strictParse :: String -> IO (C.Type, [(C.Identifier, C.Type, ParameterType)], String)+ strictParse s = do+ let ParseTypedC retType pars body =+ assertParse (parseTypedC (ctxAntiQuoters ctx)) s+ void $ evaluate $ length $ show (retType, pars, body)+ return (retType, pars, body)++ goodParse = strictParse+ badParse s = strictParse s `Hspec.shouldThrow` Hspec.anyException++ cty :: String -> C.Type+ cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s++ shouldMatchParameters+ :: [(C.Identifier, C.Type, ParameterType)] -> [(C.Type, ParameterType)] -> Hspec.Expectation+ shouldMatchParameters pars pars' =+ [(x, y) | (_, x, y) <- pars] `Hspec.shouldMatchList` pars'++ shouldMatchBody :: String -> String -> Hspec.Expectation+ shouldMatchBody x y = do+ let f ch' = case ch' of+ '(' -> "\\("+ ')' -> "\\)"+ ch -> [ch]+ (x =~ concatMap f y) `Hspec.shouldBe` True
+ test/Language/C/Types/ParseSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module Language.C.Types.ParseSpec (spec) where++import Control.Applicative+import Control.Monad.Trans.Class (lift)+import qualified Data.Set as Set+import qualified Test.Hspec as Hspec+import qualified Test.QuickCheck as QC+import Text.Parser.Char+import Text.Parser.Combinators+import qualified Text.PrettyPrint.ANSI.Leijen as PP++import Language.C.Types.Parse+import qualified Language.C.Types as Types++import Prelude -- Fix for 7.10 unused warnings.++spec :: Hspec.SpecWith ()+spec = do+ Hspec.it "parses everything which is pretty-printable (QuickCheck)" $ do+ QC.property $ \(ParameterDeclarationWithTypeNames typeNames ty) ->+ isGoodType ty QC.==>+ let ty' = assertParse (`Set.member` typeNames) parameter_declaration (prettyOneLine ty)+ in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty'++------------------------------------------------------------------------+-- Utils++assertParse :: IsTypeName -> (forall m. CParser m => m a) -> String -> a+assertParse isTypeName p s =+ case runCParser isTypeName "spec" s (lift spaces *> p <* lift eof) of+ Left err -> error $ "Parse error (assertParse): " ++ show err+ Right x -> x++prettyOneLine :: PP.Pretty a => a -> String+prettyOneLine x = PP.displayS (PP.renderCompact (PP.pretty x)) ""++isGoodType :: ParameterDeclaration -> Bool+isGoodType ty = case Types.untangleParameterDeclaration ty of+ Left _ -> False+ Right _ -> True