diff --git a/inline-c.cabal b/inline-c.cabal --- a/inline-c.cabal +++ b/inline-c.cabal @@ -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 . 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 diff --git a/test/Dummy.hs b/test/Dummy.hs new file mode 100644 --- /dev/null +++ b/test/Dummy.hs @@ -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 diff --git a/test/Language/C/Inline/ContextSpec.hs b/test/Language/C/Inline/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/C/Inline/ContextSpec.hs @@ -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 diff --git a/test/Language/C/Inline/ParseSpec.hs b/test/Language/C/Inline/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/C/Inline/ParseSpec.hs @@ -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 diff --git a/test/Language/C/Types/ParseSpec.hs b/test/Language/C/Types/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/C/Types/ParseSpec.hs @@ -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