diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..08f723a --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,60 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules +- ignore: {name: Use camelCase} + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.travis.yml b/.travis.yml index 4a30c26..d2bb3fd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -13,11 +13,8 @@ addons: - libcairo2-dev env: -- ARGS="--flag inline-c:gsl-example" -- ARGS="--stack-yaml stack-lts-12.14.yaml --flag inline-c:gsl-example" -# gtk2hs-buildtools is not present in nightly a bit of a pain to install, -# skip it for now -- ARGS="--stack-yaml stack-nightly-2018-10-24.yaml" +- STACK="stack --no-terminal --install-ghc" + STACK_TEST="$STACK test --haddock" before_install: # Download and unpack the stack executable @@ -28,7 +25,21 @@ before_install: # This line does all of the work: installs GHC if necessary, build the library, # executables, and test suites, and runs the test suites. --no-terminal works # around some quirks in Travis's terminal implementation. -script: stack --no-terminal --install-ghc test --haddock $ARGS +matrix: + include: + - name: test +gsl + script: $STACK_TEST --flag inline-c:gsl-example + - name: test +gsl lts-12.14 + script: + $STACK_TEST + --stack-yaml stack-lts-12.14.yaml --flag inline-c:gsl-example + - name: test nightly + # gtk2hs-buildtools is not present in nightly a bit of a pain to install, + # skip it for now + script: $STACK_TEST --stack-yaml stack-nightly-2018-10-24.yaml + - name: HLint + # 2.1.11 inroduced {- HLINT -} pragmas, use it until lts-12.22 + script: $STACK build hlint-2.1.11 --exec 'hlint .' # Caching so the next build will be fast too. cache: diff --git a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs index 1217b04..004ccbb 100644 --- a/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs +++ b/inline-c-cpp/src/Language/C/Inline/Cpp/Exceptions.hs @@ -70,7 +70,7 @@ handleForeignCatch cont = -- them in an 'Either' throwBlock :: QuasiQuoter throwBlock = QuasiQuoter - { quoteExp = \blockStr -> do + { quoteExp = \blockStr -> [e| either throwIO return =<< $(tryBlockQuoteExp blockStr) |] , quotePat = unsupported , quoteType = unsupported @@ -87,7 +87,7 @@ catchBlock = QuasiQuoter , quoteDec = unsupported } where unsupported _ = fail "Unsupported quasiquotation." - + tryBlockQuoteExp :: String -> Q Exp tryBlockQuoteExp blockStr = do @@ -147,7 +147,7 @@ tryBlockQuoteExp blockStr = do , "}" ] [e| handleForeignCatch $ \ $(varP typePtrVarName) $(varP msgPtrVarName) -> $(quoteExp C.block inlineCStr) |] - + -- | Similar to `C.block`, but C++ exceptions will be caught and the result is (Either CppException value). The return type must be void or constructible with @{}@. -- Using this will automatically include @exception@, @cstring@ and @cstdlib@. tryBlock :: QuasiQuoter diff --git a/inline-c-cpp/test/tests.hs b/inline-c-cpp/test/tests.hs index b84bbd1..65c326b 100644 --- a/inline-c-cpp/test/tests.hs +++ b/inline-c-cpp/test/tests.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} import Control.Exception.Safe -import Control.Monad import qualified Language.C.Inline.Cpp as C import qualified Language.C.Inline.Cpp.Exceptions as C import qualified Test.Hspec as Hspec @@ -129,3 +128,5 @@ main = Hspec.hspec $ do |] result `Hspec.shouldBe` Right 0xDEADBEEF + +{- HLINT ignore main "Redundant do" -} diff --git a/inline-c/examples/gsl-ode.hs b/inline-c/examples/gsl-ode.hs index b1d5007..4d03c63 100644 --- a/inline-c/examples/gsl-ode.hs +++ b/inline-c/examples/gsl-ode.hs @@ -104,7 +104,7 @@ lorenz -> Double -- ^ End point -> Either String (V.Vector Double) -lorenz x0 f0 xend = solveOde fun x0 f0 xend +lorenz = solveOde fun where sigma = 10.0; _R = 28.0; diff --git a/inline-c/src/Language/C/Inline.hs b/inline-c/src/Language/C/Inline.hs index d6810f5..1fbe98f 100644 --- a/inline-c/src/Language/C/Inline.hs +++ b/inline-c/src/Language/C/Inline.hs @@ -1,10 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -315,7 +312,7 @@ verbatim s = do -- | Like 'alloca', but also peeks the contents of the 'Ptr' and returns -- them once the provided action has finished. withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b) -withPtr f = do +withPtr f = alloca $ \ptr -> do x <- f ptr y <- peek ptr diff --git a/inline-c/src/Language/C/Inline/Context.hs b/inline-c/src/Language/C/Inline/Context.hs index 108b11d..285b676 100644 --- a/inline-c/src/Language/C/Inline/Context.hs +++ b/inline-c/src/Language/C/Inline/Context.hs @@ -42,6 +42,9 @@ module Language.C.Inline.Context , bsCtx ) where +{- HLINT ignore "Use fewer imports" -} +{- HLINT ignore "Reduce duplication" -} + import Control.Applicative ((<|>)) import Control.Monad (mzero) import Control.Monad.Trans.Class (lift) @@ -174,7 +177,9 @@ instance Monoid Context where , ctxForeignSrcLang = Nothing } -#if !MIN_VERSION_base(4,11,0) +#if MIN_VERSION_base(4,9,0) + mappend = (<>) +#else mappend ctx2 ctx1 = Context { ctxTypesTable = ctxTypesTable ctx1 <> ctxTypesTable ctx2 , ctxAntiQuoters = ctxAntiQuoters ctx1 <> ctxAntiQuoters ctx2 @@ -278,7 +283,7 @@ convertType purity cTypes = runMaybeT . go C.Array _mbSize cTy' -> do hsTy <- go cTy' lift [t| CArray $(return hsTy) |] - C.Proto _retType _pars -> do + C.Proto _retType _pars -> -- We cannot convert standalone prototypes mzero @@ -453,7 +458,7 @@ vecLenAntiQuoter = AntiQuoter hId <- C.parseIdentifier let cId = mangleHaskellIdentifier hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) - , aqMarshaller = \_purity _cTypes cTy cId -> do + , aqMarshaller = \_purity _cTypes cTy cId -> case cTy of C.TypeSpecifier _ (C.Long C.Signed) -> do hsExp <- getHsVariable "vecCtx" cId @@ -461,7 +466,7 @@ vecLenAntiQuoter = AntiQuoter hsTy <- [t| CLong |] hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') - _ -> do + _ -> fail "impossible: got type different from `long' (vecCtx)" } @@ -488,7 +493,7 @@ bsPtrAntiQuoter = AntiQuoter hId <- C.parseIdentifier let cId = mangleHaskellIdentifier hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) - , aqMarshaller = \_purity _cTypes cTy cId -> do + , aqMarshaller = \_purity _cTypes cTy cId -> case cTy of C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do hsTy <- [t| Ptr CChar |] @@ -505,7 +510,7 @@ bsLenAntiQuoter = AntiQuoter hId <- C.parseIdentifier let cId = mangleHaskellIdentifier hId return (cId, C.TypeSpecifier mempty (C.Long C.Signed), hId) - , aqMarshaller = \_purity _cTypes cTy cId -> do + , aqMarshaller = \_purity _cTypes cTy cId -> case cTy of C.TypeSpecifier _ (C.Long C.Signed) -> do hsExp <- getHsVariable "bsCtx" cId @@ -513,7 +518,7 @@ bsLenAntiQuoter = AntiQuoter hsTy <- [t| CLong |] hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') - _ -> do + _ -> fail "impossible: got type different from `long' (bsCtx)" } @@ -523,7 +528,7 @@ bsCStrAntiQuoter = AntiQuoter hId <- C.parseIdentifier let cId = mangleHaskellIdentifier hId return (cId, C.Ptr [] (C.TypeSpecifier mempty (C.Char Nothing)), hId) - , aqMarshaller = \_purity _cTypes cTy cId -> do + , aqMarshaller = \_purity _cTypes cTy cId -> case cTy of C.Ptr _ (C.TypeSpecifier _ (C.Char Nothing)) -> do hsTy <- [t| Ptr CChar |] @@ -553,7 +558,7 @@ cDeclAqParser = do deHaskellifyCType :: C.CParser HaskellIdentifier m => C.Type HaskellIdentifier -> m (C.Type C.CIdentifier) -deHaskellifyCType = traverse $ \hId -> do +deHaskellifyCType = traverse $ \hId -> case C.cIdentifierFromString (unHaskellIdentifier hId) of Left err -> fail $ "Illegal Haskell identifier " ++ unHaskellIdentifier hId ++ " in C type:\n" ++ err diff --git a/inline-c/src/Language/C/Inline/HaskellIdentifier.hs b/inline-c/src/Language/C/Inline/HaskellIdentifier.hs index 57b48c9..d5afa65 100644 --- a/inline-c/src/Language/C/Inline/HaskellIdentifier.hs +++ b/inline-c/src/Language/C/Inline/HaskellIdentifier.hs @@ -16,12 +16,14 @@ module Language.C.Inline.HaskellIdentifier , haskellReservedWords ) where +{- HLINT ignore "Use fewer imports" -} + import Control.Applicative ((<|>)) import Control.Monad (when, msum, void) import Data.Char (ord) import qualified Data.HashSet as HashSet import Data.Hashable (Hashable) -import Data.List (intercalate, partition, intersperse) +import Data.List (intercalate, partition) import Data.Monoid ((<>)) import Data.String (IsString(..)) import Data.Typeable (Typeable) @@ -94,9 +96,8 @@ haskellReservedWords = C.cReservedWords <> HashSet.fromList -- | See -- . parseHaskellIdentifier :: forall i m. C.CParser i m => m HaskellIdentifier -parseHaskellIdentifier = do - segments <- go - return $ HaskellIdentifier $ intercalate "." segments +parseHaskellIdentifier = + HaskellIdentifier . intercalate "." <$> go where small = lower <|> char '_' large = upper @@ -135,7 +136,7 @@ mangleHaskellIdentifier (HaskellIdentifier hs) = where (valid, invalid) = partition (`elem` C.cIdentLetter) hs - mangled = concat $ intersperse "_" $ map (`showHex` "") $ map ord invalid + mangled = intercalate "_" $ map ((`showHex` "") . ord) invalid -- Utils ------------------------------------------------------------------------ @@ -146,4 +147,3 @@ identNoLex s = fmap fromString $ try $ do ((:) <$> _styleStart s <*> many (_styleLetter s) _styleName s) when (HashSet.member name (_styleReserved s)) $ unexpected $ "reserved " ++ _styleName s ++ " " ++ show name return name - diff --git a/inline-c/src/Language/C/Inline/Internal.hs b/inline-c/src/Language/C/Inline/Internal.hs index 8a301ca..55dd4a1 100644 --- a/inline-c/src/Language/C/Inline/Internal.hs +++ b/inline-c/src/Language/C/Inline/Internal.hs @@ -199,7 +199,7 @@ setContext ctx = do void $ initialiseModuleState $ Just ctx bumpGeneratedNames :: TH.Q Int -bumpGeneratedNames = do +bumpGeneratedNames = modifyModuleState $ \ms -> let c' = msGeneratedNames ms in (ms{msGeneratedNames = c' + 1}, c') @@ -406,10 +406,10 @@ runParserInQ s ctx p = do let parsecLoc = Parsec.newPos (TH.loc_filename loc) line col let p' = lift (Parsec.setPosition parsecLoc) *> p <* lift Parser.eof case C.runCParser ctx (TH.loc_filename loc) s p' of - Left err -> do + Left err -> -- TODO consider prefixing with "error while parsing C" or similar fail $ show err - Right res -> do + Right res -> return res data SomeEq = forall a. (Typeable a, Eq a) => SomeEq a @@ -423,9 +423,9 @@ instance Show SomeEq where show _ = "<>" toSomeEq :: (Eq a, Typeable a) => a -> SomeEq -toSomeEq x = SomeEq x +toSomeEq = SomeEq -fromSomeEq :: (Eq a, Typeable a) => SomeEq -> Maybe a +fromSomeEq :: Typeable a => SomeEq -> Maybe a fromSomeEq (SomeEq x) = cast x data ParameterType @@ -481,7 +481,6 @@ parseTypedC antiQs = do return (decls1 ++ decls2, s1 ++ s2) ] return (decls, s ++ s') - where parseAntiQuote :: StateT Int m ([(C.CIdentifier, C.Type C.CIdentifier, ParameterType)], String) @@ -523,7 +522,7 @@ parseTypedC antiQs = do -- The @m@ is polymorphic because we use this both for the plain -- parser and the StateT parser we use above. We only need 'fail'. purgeHaskellIdentifiers - :: forall n. (Applicative n, Monad n) + :: forall n. Monad n => C.Type HaskellIdentifier -> n (C.Type C.CIdentifier) purgeHaskellIdentifiers cTy = for cTy $ \hsIdent -> do let hsIdentS = unHaskellIdentifier hsIdent @@ -557,14 +556,14 @@ genericQuote purity build = quoteCode $ \s -> do (haskellCParserContext (typeNamesFromTypesTable (ctxTypesTable ctx))) (parseTypedC (ctxAntiQuoters ctx)) hsType <- cToHs ctx cType - hsParams <- forM cParams $ \(_cId, cTy, parTy) -> do + hsParams <- forM cParams $ \(_cId, cTy, parTy) -> case parTy of Plain s' -> do hsTy <- cToHs ctx cTy let hsName = TH.mkName (unHaskellIdentifier s') hsExp <- [| \cont -> cont ($(TH.varE hsName) :: $(return hsTy)) |] return (hsTy, hsExp) - AntiQuote antiId dyn -> do + AntiQuote antiId dyn -> case Map.lookup antiId (ctxAntiQuoters ctx) of Nothing -> fail $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++ @@ -599,13 +598,9 @@ genericQuote purity build = quoteCode $ \s -> do |] convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ - convertCFunSig retType params0 = do - go params0 - where - go [] = - [t| IO $(return retType) |] - go (paramType : params) = do - [t| $(return paramType) -> $(go params) |] + convertCFunSig retType = go where + go [] = [t| IO $(return retType) |] + go (paramType : params) = [t| $(return paramType) -> $(go params) |] splitTypedC :: String -> (String, String) -- ^ Returns the type and the body separately @@ -640,13 +635,9 @@ funPtrQuote callSafety = quoteCode $ \code -> do Just hsTy -> return hsTy convertCFunSig :: TH.Type -> [TH.Type] -> TH.TypeQ - convertCFunSig retType params0 = do - go params0 - where - go [] = - [t| IO $(return retType) |] - go (paramType : params) = do - [t| $(return paramType) -> $(go params) |] + convertCFunSig retType = go where + go [] = [t| IO $(return retType) |] + go (paramType : params) = [t| $(return paramType) -> $(go params) |] parse :: C.CParser C.CIdentifier m => m FunPtrDecl parse = do @@ -669,7 +660,7 @@ funPtrQuote callSafety = quoteCode $ \code -> do , funPtrBody = body , funPtrName = fmap C.unCIdentifier mbName } - _ -> fail $ "Expecting function declaration" + _ -> fail "Expecting function declaration" parseBody :: C.CParser C.CIdentifier m => m String parseBody = do diff --git a/inline-c/src/Language/C/Types.hs b/inline-c/src/Language/C/Types.hs index a5c4d39..c21cddd 100644 --- a/inline-c/src/Language/C/Types.hs +++ b/inline-c/src/Language/C/Types.hs @@ -3,10 +3,10 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -60,6 +60,8 @@ module Language.C.Types , describeType ) where +{- HLINT ignore "Use fewer imports" -} + import Control.Arrow (second) import Control.Monad (when, unless, forM_) import Control.Monad.State (execState, modify) @@ -117,7 +119,9 @@ instance Semigroup Specifiers where instance Monoid Specifiers where mempty = Specifiers [] [] [] -#if !MIN_VERSION_base(4,11,0) +#if MIN_VERSION_base(4,9,0) + mappend = (<>) +#else mappend (Specifiers x1 y1 z1) (Specifiers x2 y2 z2) = Specifiers (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) #endif @@ -136,7 +140,7 @@ data Sign data ParameterDeclaration i = ParameterDeclaration { parameterDeclarationId :: Maybe i - , parameterDeclarationType :: (Type i) + , parameterDeclarationType :: Type i } deriving (Typeable, Show, Eq, Functor, Foldable, Traversable) ------------------------------------------------------------------------ @@ -167,15 +171,15 @@ untangleParameterDeclaration P.ParameterDeclaration{..} = do untangleDeclarationSpecifiers :: [P.DeclarationSpecifier] -> Either UntangleErr (Specifiers, TypeSpecifier) untangleDeclarationSpecifiers declSpecs = do - let (pStorage, pTySpecs, pTyQuals, pFunSpecs) = flip execState ([], [], [], []) $ do - forM_ (reverse declSpecs) $ \declSpec -> case declSpec of + let (pStorage, pTySpecs, pTyQuals, pFunSpecs) = flip execState ([], [], [], []) $ + forM_ (reverse declSpecs) $ \case P.StorageClassSpecifier x -> modify $ \(a, b, c, d) -> (x:a, b, c, d) P.TypeSpecifier x -> modify $ \(a, b, c, d) -> (a, x:b, c, d) P.TypeQualifier x -> modify $ \(a, b, c, d) -> (a, b, x:c, d) P.FunctionSpecifier x -> modify $ \(a, b, c, d) -> (a, b, c, x:d) -- Split data type and specifiers let (dataTypes, specs) = - partition (\x -> not (x `elem` [P.SIGNED, P.UNSIGNED, P.LONG, P.SHORT])) pTySpecs + partition (`notElem` [P.SIGNED, P.UNSIGNED, P.LONG, P.SHORT]) pTySpecs let illegalSpecifiers s = failConversion $ IllegalSpecifiers s specs -- Find out sign, if present mbSign0 <- case filter (== P.SIGNED) specs of @@ -219,26 +223,26 @@ untangleDeclarationSpecifiers declSpecs = do P.CHAR -> do checkNoLength return $ Char mbSign - P.INT | longs == 0 && shorts == 0 -> do + P.INT | longs == 0 && shorts == 0 -> return $ Int sign - P.INT | longs == 1 -> do + P.INT | longs == 1 -> return $ Long sign - P.INT | longs == 2 -> do + P.INT | longs == 2 -> return $ LLong sign - P.INT | shorts == 1 -> do + P.INT | shorts == 1 -> return $ Short sign - P.INT -> do + P.INT -> illegalSpecifiers "too many long/short" P.FLOAT -> do checkNoLength return Float - P.DOUBLE -> do + P.DOUBLE -> if longs == 1 then return LDouble else do checkNoLength return Double - _ -> do + _ -> error $ "untangleDeclarationSpecifiers impossible: " ++ show dataType return (Specifiers pStorage pTyQuals pFunSpecs, tySpec) diff --git a/inline-c/src/Language/C/Types/Parse.hs b/inline-c/src/Language/C/Types/Parse.hs index dfc2f95..db03ed3 100644 --- a/inline-c/src/Language/C/Types/Parse.hs +++ b/inline-c/src/Language/C/Types/Parse.hs @@ -186,7 +186,7 @@ runCParser -- ^ Source name. -> s -- ^ String to parse. - -> (ReaderT (CParserContext i) (Parsec.Parsec s ()) a) + -> ReaderT (CParserContext i) (Parsec.Parsec s ()) a -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> Either Parsec.ParseError a @@ -198,7 +198,7 @@ quickCParser :: CParserContext i -> String -- ^ String to parse. - -> (ReaderT (CParserContext i) (Parsec.Parsec String ()) a) + -> ReaderT (CParserContext i) (Parsec.Parsec String ()) a -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> a @@ -211,7 +211,7 @@ quickCParser typeNames s p = case runCParser typeNames "quickCParser" s p of quickCParser_ :: String -- ^ String to parse. - -> (ReaderT (CParserContext CIdentifier) (Parsec.Parsec String ()) a) + -> ReaderT (CParserContext CIdentifier) (Parsec.Parsec String ()) a -- ^ Parser. Anything with type @forall m. CParser i m => m a@ is a -- valid argument. -> a @@ -231,11 +231,13 @@ cReservedWords = HashSet.fromList cIdentStart :: [Char] cIdentStart = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] +{- HLINT ignore cIdentStart "Use String" -} cIdentLetter :: [Char] cIdentLetter = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9'] +{- HLINT ignore cIdentLetter "Use String" -} -cIdentStyle :: (TokenParsing m, Monad m) => IdentifierStyle m +cIdentStyle :: TokenParsing m => IdentifierStyle m cIdentStyle = IdentifierStyle { _styleName = "C identifier" , _styleStart = oneOf cIdentStart @@ -376,7 +378,7 @@ function_specifier = msum data Declarator i = Declarator { declaratorPointers :: [Pointer] - , declaratorDirect :: (DirectDeclarator i) + , declaratorDirect :: DirectDeclarator i } deriving (Typeable, Eq, Show, Functor, Foldable, Traversable) declarator :: CParser i m => m (Declarator i) @@ -424,7 +426,7 @@ direct_declarator = do aops <- many array_or_proto return $ foldl ArrayOrProto ddecltor aops -data Pointer +newtype Pointer = Pointer [TypeQualifier] deriving (Typeable, Eq, Show) @@ -539,8 +541,7 @@ instance Pretty i => Pretty (Declarator i) where _:_ -> prettyPointers ptrs <+> pretty ddecltor prettyPointers :: [Pointer] -> Doc -prettyPointers [] = "" -prettyPointers (x : xs) = pretty x <> prettyPointers xs +prettyPointers = foldr ((<>) . pretty) "" instance Pretty Pointer where pretty (Pointer tyQual) = "*" <> hsep (map pretty tyQual) diff --git a/inline-c/test/Language/C/Inline/ContextSpec.hs b/inline-c/test/Language/C/Inline/ContextSpec.hs index 9c7ec2b..95fc922 100644 --- a/inline-c/test/Language/C/Inline/ContextSpec.hs +++ b/inline-c/test/Language/C/Inline/ContextSpec.hs @@ -81,7 +81,7 @@ spec = do goodConvert cTy = do mbHsTy <- TH.runQ $ convertType IO baseTypes cTy case mbHsTy of - Nothing -> error $ "Could not convert type (goodConvert)" + Nothing -> error "Could not convert type (goodConvert)" Just hsTy -> return hsTy shouldBeType cTy hsTy = do @@ -97,3 +97,5 @@ spec = do cty s = C.parameterDeclarationType $ assertParse C.parseParameterDeclaration s baseTypes = ctxTypesTable baseCtx + +{- HLINT ignore spec "Redundant do" -} diff --git a/inline-c/test/Language/C/Inline/ParseSpec.hs b/inline-c/test/Language/C/Inline/ParseSpec.hs index 92c943a..de08bf5 100644 --- a/inline-c/test/Language/C/Inline/ParseSpec.hs +++ b/inline-c/test/Language/C/Inline/ParseSpec.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module Language.C.Inline.ParseSpec (spec) where @@ -36,7 +35,7 @@ spec = do (retType, params, cExp) <- goodParse [r| int { (int) ceil($(double x) + ((double) $(float y))) } |] - retType `Hspec.shouldBe` (cty "int") + 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 @@ -50,22 +49,22 @@ spec = do Hspec.it "parses returning function pointers" $ do (retType, params, cExp) <- goodParse [r| double (*)(double) { &cos } |] - retType `Hspec.shouldBe` (cty "double (*)(double)") + retType `Hspec.shouldBe` cty "double (*)(double)" params `shouldMatchParameters` [] cExp `shouldMatchBody` " &cos " Hspec.it "parses Haskell identifier (1)" $ do (retType, params, cExp) <- goodParse [r| double { $(double x') } |] - retType `Hspec.shouldBe` (cty "double") + retType `Hspec.shouldBe` cty "double" params `shouldMatchParameters` [(cty "double", Plain "x'")] cExp `shouldMatchBody` " x[a-z0-9_]+ " Hspec.it "parses Haskell identifier (2)" $ do (retType, params, cExp) <- goodParse [r| double { $(double ä') } |] - retType `Hspec.shouldBe` (cty "double") + retType `Hspec.shouldBe` cty "double" params `shouldMatchParameters` [(cty "double", Plain "ä'")] cExp `shouldMatchBody` " [a-z0-9_]+ " Hspec.it "parses Haskell identifier (3)" $ do (retType, params, cExp) <- goodParse [r| int { $(int Foo.bar) } |] - retType `Hspec.shouldBe` (cty "int") + retType `Hspec.shouldBe` cty "int" params `shouldMatchParameters` [(cty "int", Plain "Foo.bar")] cExp `shouldMatchBody` " Foobar[a-z0-9_]+ " Hspec.it "does not parse Haskell identifier in bad position" $ do @@ -110,3 +109,5 @@ spec = do ')' -> "\\)" ch -> [ch] (x =~ concatMap f y) `Hspec.shouldBe` True + +{- HLINT ignore spec "Redundant do" -} diff --git a/inline-c/test/Language/C/Types/ParseSpec.hs b/inline-c/test/Language/C/Types/ParseSpec.hs index 4426118..8d8cb5f 100644 --- a/inline-c/test/Language/C/Types/ParseSpec.hs +++ b/inline-c/test/Language/C/Types/ParseSpec.hs @@ -51,6 +51,7 @@ spec = do return $ isGoodType ty QC.==> let ty' = assertParse (haskellCParserContext typeNames) parameter_declaration (prettyOneLine ty) in Types.untangleParameterDeclaration ty == Types.untangleParameterDeclaration ty' +{- HLINT ignore spec "Redundant do" -} ------------------------------------------------------------------------ -- Utils @@ -92,7 +93,7 @@ halveSize m = QC.sized $ \n -> QC.resize (n `div` 2) m instance QC.Arbitrary CIdentifier where arbitrary = do - s <- ((:) <$> QC.elements cIdentStart <*> QC.listOf (QC.elements cIdentLetter)) + s <- (:) <$> QC.elements cIdentStart <*> QC.listOf (QC.elements cIdentLetter) if HashSet.member s cReservedWords then QC.arbitrary else return $ fromString s @@ -101,7 +102,7 @@ instance QC.Arbitrary CIdentifier where -- arbitrary allowed type names. data ParameterDeclarationWithTypeNames i = ParameterDeclarationWithTypeNames { _pdwtnTypeNames :: HashSet.HashSet CIdentifier - , _pdwtnParameterDeclaration :: (ParameterDeclaration i) + , _pdwtnParameterDeclaration :: ParameterDeclaration i } deriving (Typeable, Eq, Show) data ArbitraryContext i = ArbitraryContext @@ -120,8 +121,8 @@ arbitraryParameterDeclarationWithTypeNames identToString = do return $ ParameterDeclarationWithTypeNames names decl arbitraryDeclarationSpecifierFrom - :: (QC.Arbitrary i, Hashable i) => ArbitraryContext i -> QC.Gen DeclarationSpecifier -arbitraryDeclarationSpecifierFrom typeNames = QC.oneof $ + :: ArbitraryContext i -> QC.Gen DeclarationSpecifier +arbitraryDeclarationSpecifierFrom typeNames = QC.oneof [ StorageClassSpecifier <$> QC.arbitrary , TypeQualifier <$> QC.arbitrary , FunctionSpecifier <$> QC.arbitrary @@ -137,7 +138,7 @@ instance QC.Arbitrary StorageClassSpecifier where , return REGISTER ] -arbitraryTypeSpecifierFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen TypeSpecifier +arbitraryTypeSpecifierFrom :: ArbitraryContext i -> QC.Gen TypeSpecifier arbitraryTypeSpecifierFrom ctx = QC.oneof $ [ return VOID , return CHAR @@ -170,8 +171,7 @@ arbitraryDeclaratorFrom arbitraryDeclaratorFrom typeNames = halveSize $ Declarator <$> QC.arbitrary <*> arbitraryDirectDeclaratorFrom typeNames -arbitraryCIdentifierFrom - :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen CIdentifier +arbitraryCIdentifierFrom :: ArbitraryContext i -> QC.Gen CIdentifier arbitraryCIdentifierFrom ctx = arbitraryIdentifierFrom ctx{acIdentToString = unCIdentifier} @@ -185,7 +185,7 @@ arbitraryIdentifierFrom ctx = do arbitraryDirectDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectDeclarator i) -arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $ +arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized [ Anyhow $ DeclaratorRoot <$> arbitraryIdentifierFrom typeNames , IfPositive $ DeclaratorParens <$> arbitraryDeclaratorFrom typeNames , IfPositive $ ArrayOrProto @@ -195,7 +195,7 @@ arbitraryDirectDeclaratorFrom typeNames = halveSize $ oneOfSized $ arbitraryArrayOrProtoFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (ArrayOrProto i) -arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized $ +arbitraryArrayOrProtoFrom typeNames = halveSize $ oneOfSized [ Anyhow $ Array <$> arbitraryArrayTypeFrom typeNames , IfPositive $ Proto <$> QC.listOf (arbitraryParameterDeclarationFrom typeNames) ] @@ -235,7 +235,7 @@ arbitraryAbstractDeclaratorFrom typeNames = halveSize $ do arbitraryDirectAbstractDeclaratorFrom :: (Hashable i, QC.Arbitrary i) => ArbitraryContext i -> QC.Gen (DirectAbstractDeclarator i) -arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized $ +arbitraryDirectAbstractDeclaratorFrom typeNames = halveSize $ oneOfSized [ Anyhow $ ArrayOrProtoHere <$> arbitraryArrayOrProtoFrom typeNames , IfPositive $ AbstractDeclaratorParens <$> arbitraryAbstractDeclaratorFrom typeNames , IfPositive $ ArrayOrProtoThere @@ -254,10 +254,10 @@ instance QC.Arbitrary HaskellIdentifier where arbitraryModId = arbitraryConId arbitraryConId = - ((:) <$> QC.elements large <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) + (:) <$> QC.elements large <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\''])) arbitraryVarId = - ((:) <$> QC.elements small <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\'']))) + (:) <$> QC.elements small <*> QC.listOf (QC.elements (small ++ large ++ digit' ++ ['\''])) -- We currently do not generate unicode identifiers. large = ['A'..'Z'] diff --git a/inline-c/test/tests.hs b/inline-c/test/tests.hs index 697e413..a799b0f 100644 --- a/inline-c/test/tests.hs +++ b/inline-c/test/tests.hs @@ -205,10 +205,10 @@ main = Hspec.hspec $ do bits `Hspec.shouldBe` 16 Hspec.it "Haskell identifiers" $ do let x' = 3 - void $ [C.exp| int { $(int x') } |] + void [C.exp| int { $(int x') } |] let ä = 3 - void $ [C.exp| int { $(int ä) } |] - void $ [C.exp| int { $(int Prelude.maxBound) } |] + void [C.exp| int { $(int ä) } |] + void [C.exp| int { $(int Prelude.maxBound) } |] Hspec.it "Function pointers" $ do alloca $ \x_ptr -> do poke x_ptr 7 @@ -216,3 +216,5 @@ main = Hspec.hspec $ do [C.exp| void { $(void (*fp)(int *))($(int *x_ptr)) } |] x <- peek x_ptr x `Hspec.shouldBe` 42 + +{- HLINT ignore main "Redundant do" -}