mirror of
https://github.com/composewell/streamly.git
synced 2024-10-05 15:29:09 +03:00
Fix hlint issues for streamly-core
This commit is contained in:
parent
dd763fe9ec
commit
98018c8440
@ -1,4 +1,4 @@
|
||||
core/src/Streamly/Internal/Data/Stream/StreamK/Type.hs
|
||||
core/src/Streamly/Internal/Data/StreamK/Type.hs
|
||||
core/src/Streamly/Internal/Data/Pipe/Type.hs
|
||||
core/src/Streamly/Internal/Unicode/Stream.hs
|
||||
src/Streamly/Internal/Data/SmallArray/Type.hs
|
||||
@ -26,7 +26,6 @@ benchmark/NanoBenchmarks.hs
|
||||
benchmark/Streamly/Benchmark/Data/Array.hs
|
||||
benchmark/Streamly/Benchmark/Data/Parser.hs
|
||||
benchmark/Streamly/Benchmark/Data/ParserK.hs
|
||||
benchmark/Streamly/Benchmark/Data/Stream/StreamDK.hs
|
||||
benchmark/Streamly/Benchmark/Data/Stream/StreamK.hs
|
||||
benchmark/Streamly/Benchmark/Data/Unfold.hs
|
||||
benchmark/Streamly/Benchmark/FileSystem/Handle.hs
|
||||
|
@ -9,7 +9,6 @@
|
||||
# Warnings currently triggered by your code
|
||||
- suggest: {name: "Unused LANGUAGE pragma"}
|
||||
- suggest: {name: "Eta reduce"}
|
||||
- suggest: {name: "Reduce duplication"}
|
||||
|
||||
# Warnings currently ignored
|
||||
- ignore: {name: "Use list literal pattern"}
|
||||
@ -25,6 +24,8 @@
|
||||
- ignore: {name: "Redundant $!"}
|
||||
- ignore: {name: "Use fmap"}
|
||||
- ignore: {name: "Use ++"}
|
||||
- ignore: {name: "Replace case with maybe"} # case is more readable
|
||||
- ignore: {name: "Use mapMaybe"} # does not make any difference
|
||||
|
||||
# Warnings ignored in specific places
|
||||
- ignore: {name: "Use mapM", within: Stream.Transform}
|
||||
@ -38,9 +39,10 @@
|
||||
- arguments:
|
||||
[ --cpp-include=src
|
||||
, --cpp-include=src/Streamly/Internal/Data/Stream
|
||||
, --cpp-include=src/Streamly/Internal/Data/Array
|
||||
, --cpp-include=core/src/Streamly/Internal/Data/Array
|
||||
, --cpp-include=test
|
||||
, --cpp-define=CABAL_OS_LINUX
|
||||
, --cpp-define=linux_HOST_OS
|
||||
]
|
||||
|
||||
|
||||
|
@ -138,7 +138,7 @@ write = create
|
||||
|
||||
fromPureStream :: Stream Identity a -> Array a
|
||||
fromPureStream x =
|
||||
unsafePerformIO $ fmap (unsafeFreeze) (MArray.fromPureStream x)
|
||||
unsafePerformIO $ fmap unsafeFreeze (MArray.fromPureStream x)
|
||||
-- fromPureStream = runIdentity . D.fold (unsafeMakePure write)
|
||||
-- fromPureStream = fromList . runIdentity . D.toList
|
||||
|
||||
|
@ -897,7 +897,7 @@ fromPureStreamN n x =
|
||||
-- >>> fromPureStream = Array.fromList . runIdentity . Stream.toList
|
||||
--
|
||||
fromPureStream :: Unbox a => Stream Identity a -> Array a
|
||||
fromPureStream x = unsafePerformIO $ fmap (unsafeFreeze) (MA.fromPureStream x)
|
||||
fromPureStream x = unsafePerformIO $ fmap unsafeFreeze (MA.fromPureStream x)
|
||||
-- fromPureStream = runIdentity . D.fold (unsafeMakePure write)
|
||||
-- fromPureStream = fromList . runIdentity . D.toList
|
||||
|
||||
|
@ -19,6 +19,7 @@ where
|
||||
#if !MIN_VERSION_base(4,18,0)
|
||||
import Control.Applicative (liftA2)
|
||||
#endif
|
||||
import Data.Bifunctor (first)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- The Builder type
|
||||
@ -34,7 +35,7 @@ newtype Builder s m a =
|
||||
-- | Maps a function on the output of the fold (the type @b@).
|
||||
instance Functor m => Functor (Builder s m) where
|
||||
{-# INLINE fmap #-}
|
||||
fmap f (Builder step1) = Builder (fmap (\ (a, s) -> (f a, s)) . step1)
|
||||
fmap f (Builder step1) = Builder (fmap (first f) . step1)
|
||||
|
||||
{-# INLINE fromPure #-}
|
||||
fromPure :: Applicative m => b -> Builder s m b
|
||||
|
@ -1337,7 +1337,7 @@ notElem a = all (/= a)
|
||||
--
|
||||
{-# INLINE and #-}
|
||||
and :: Monad m => Fold m Bool Bool
|
||||
and = all (== True)
|
||||
and = all id
|
||||
|
||||
-- | Returns 'True' if any element is 'True', 'False' otherwise
|
||||
--
|
||||
@ -1347,7 +1347,7 @@ and = all (== True)
|
||||
--
|
||||
{-# INLINE or #-}
|
||||
or :: Monad m => Fold m Bool Bool
|
||||
or = any (== True)
|
||||
or = any id
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Grouping/Splitting
|
||||
@ -1641,9 +1641,9 @@ takeEndBySeq patArr (Fold fstep finitial fextract ffinal) =
|
||||
SplitOnSeqKRLoop s _ _ _ -> s
|
||||
in fex st
|
||||
|
||||
extract state = extractFunc fextract state
|
||||
extract = extractFunc fextract
|
||||
|
||||
final state = extractFunc ffinal state
|
||||
final = extractFunc ffinal
|
||||
|
||||
-- | Like 'takeEndBySeq' but discards the matched sequence.
|
||||
--
|
||||
@ -1802,9 +1802,9 @@ takeEndBySeq_ patArr (Fold fstep finitial fextract ffinal) =
|
||||
SplitOnSeqKR s idx rb _ -> consumeRing s idx rb (Ring.startOf rb)
|
||||
SplitOnSeqKRLoop s _ rb rh -> consumeRing s patLen rb rh
|
||||
|
||||
extract state = extractFunc fextract state
|
||||
extract = extractFunc fextract
|
||||
|
||||
final state = extractFunc ffinal state
|
||||
final = extractFunc ffinal
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Distributing
|
||||
|
@ -301,7 +301,7 @@ putIndexUnsafeWith n _arrContents# x =
|
||||
putIndexUnsafe :: forall m a. MonadIO m => Int -> MutArray a -> a -> m ()
|
||||
putIndexUnsafe i MutArray {..} x =
|
||||
assert (i >= 0 && i < arrLen)
|
||||
putIndexUnsafeWith (i + arrStart) arrContents# x
|
||||
(putIndexUnsafeWith (i + arrStart) arrContents# x)
|
||||
|
||||
invalidIndex :: String -> Int -> a
|
||||
invalidIndex label i =
|
||||
|
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
-- This is required as all the instances in this module are orphan instances.
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
@ -91,28 +89,25 @@ instance Serialize a => Serialize (Maybe a) where
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
Nothing -> (acc + 1)
|
||||
Just field0 -> (addSizeTo (acc + 1)) field0
|
||||
Nothing -> acc + 1
|
||||
Just field0 -> addSizeTo (acc + 1) field0
|
||||
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
(i0, tag) <- deserializeAt initialOffset arr endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> pure (i0, Nothing)
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, Just a0)
|
||||
_ -> error "Found invalid tag while peeking (Maybe a)"
|
||||
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
Nothing -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
pure i0
|
||||
Nothing -> serializeAt initialOffset arr (0 :: Word8)
|
||||
Just field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (1 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
|
||||
-- $(Serialize.deriveSerialize ''Either)
|
||||
instance (Serialize a, Serialize b) => Serialize (Either a b) where
|
||||
@ -120,16 +115,16 @@ instance (Serialize a, Serialize b) => Serialize (Either a b) where
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
Left field0 -> (addSizeTo (acc + 1)) field0
|
||||
Right field0 -> (addSizeTo (acc + 1)) field0
|
||||
Left field0 -> addSizeTo (acc + 1) field0
|
||||
Right field0 -> addSizeTo (acc + 1) field0
|
||||
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
(i0, tag) <- deserializeAt initialOffset arr endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
0 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, Left a0)
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, Right a0)
|
||||
_ -> error "Found invalid tag while peeking (Either a b)"
|
||||
|
||||
@ -137,21 +132,19 @@ instance (Serialize a, Serialize b) => Serialize (Either a b) where
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
Left field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (0 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
Right field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (1 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
|
||||
instance Serialize (Proxy a) where
|
||||
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc _ = (acc + 1)
|
||||
addSizeTo acc _ = acc + 1
|
||||
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset _ _ = pure ((initialOffset + 1), Proxy)
|
||||
deserializeAt initialOffset _ _ = pure (initialOffset + 1, Proxy)
|
||||
|
||||
{-# INLINE serializeAt #-}
|
||||
serializeAt initialOffset _ _ = pure (initialOffset + 1)
|
||||
@ -171,19 +164,19 @@ instance Serialize LiftedInteger where
|
||||
{-# INLINE addSizeTo #-}
|
||||
addSizeTo acc x =
|
||||
case x of
|
||||
LIS field0 -> (addSizeTo (acc + 1)) field0
|
||||
LIP field0 -> (addSizeTo (acc + 1)) field0
|
||||
LIN field0 -> (addSizeTo (acc + 1)) field0
|
||||
LIS field0 -> addSizeTo (acc + 1) field0
|
||||
LIP field0 -> addSizeTo (acc + 1) field0
|
||||
LIN field0 -> addSizeTo (acc + 1) field0
|
||||
|
||||
{-# INLINE deserializeAt #-}
|
||||
deserializeAt initialOffset arr endOffset = do
|
||||
(i0, tag) <- ((deserializeAt initialOffset) arr) endOffset
|
||||
(i0, tag) <- deserializeAt initialOffset arr endOffset
|
||||
case tag :: Word8 of
|
||||
0 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
0 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, LIS a0)
|
||||
1 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
1 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, LIP a0)
|
||||
2 -> do (i1, a0) <- ((deserializeAt i0) arr) endOffset
|
||||
2 -> do (i1, a0) <- deserializeAt i0 arr endOffset
|
||||
pure (i1, LIN a0)
|
||||
_ -> error "Found invalid tag while peeking (LiftedInteger)"
|
||||
|
||||
@ -191,17 +184,14 @@ instance Serialize LiftedInteger where
|
||||
serializeAt initialOffset arr val =
|
||||
case val of
|
||||
LIS field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (0 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (0 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
LIP field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (1 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (1 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
LIN field0 -> do
|
||||
i0 <- ((serializeAt initialOffset) arr) (2 :: Word8)
|
||||
i1 <- ((serializeAt i0) arr) field0
|
||||
pure i1
|
||||
i0 <- serializeAt initialOffset arr (2 :: Word8)
|
||||
serializeAt i0 arr field0
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 900
|
||||
|
||||
|
@ -172,8 +172,7 @@ mkSizeDec (SerializeConfig {..}) headTy cons = do
|
||||
cfgRecordSyntaxWithHeader
|
||||
(typeOfType headTy cons)
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
( foldMap
|
||||
(\x -> [PragmaD (InlineP 'addSizeTo x FunLike AllPhases)])
|
||||
cfgInlineSize
|
||||
++ [FunD 'addSizeTo [Clause [] (NormalB sizeOfMethod) []]]
|
||||
@ -240,7 +239,7 @@ mkDeserializeExpr False False headTy tyOfTy =
|
||||
, noBindS
|
||||
(caseE
|
||||
(sigE (varE _tag) (conT tagType))
|
||||
(map peekMatch (zip [0 ..] cons) ++ [peekErr]))
|
||||
(fmap peekMatch (zip [0 ..] cons) ++ [peekErr]))
|
||||
]
|
||||
where
|
||||
peekMatch (i, con) =
|
||||
@ -282,8 +281,7 @@ mkDeserializeDec (SerializeConfig {..}) headTy cons = do
|
||||
headTy
|
||||
(typeOfType headTy cons)
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
( foldMap
|
||||
(\x -> [PragmaD (InlineP 'deserializeAt x FunLike AllPhases)])
|
||||
cfgInlineDeserialize
|
||||
++
|
||||
@ -308,7 +306,7 @@ mkSerializeExprTag tagType tagVal =
|
||||
[|serializeAt
|
||||
$(varE _initialOffset)
|
||||
$(varE _arr)
|
||||
$((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
|
||||
$(sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType))|]
|
||||
|
||||
mkSerializeExpr :: Bool -> Bool -> TypeOfType -> Q Exp
|
||||
mkSerializeExpr True False tyOfTy =
|
||||
@ -365,7 +363,7 @@ mkSerializeExpr False False tyOfTy =
|
||||
tagType = getTagType lenCons
|
||||
caseE
|
||||
(varE _val)
|
||||
(map (\(tagVal, (SimpleDataCon cname fields)) ->
|
||||
(fmap (\(tagVal, SimpleDataCon cname fields) ->
|
||||
matchConstructor
|
||||
cname
|
||||
(length fields)
|
||||
@ -392,8 +390,7 @@ mkSerializeDec (SerializeConfig {..}) headTy cons = do
|
||||
cfgRecordSyntaxWithHeader
|
||||
(typeOfType headTy cons)
|
||||
pure
|
||||
( maybe
|
||||
[]
|
||||
( foldMap
|
||||
(\x -> [PragmaD (InlineP 'serializeAt x FunLike AllPhases)])
|
||||
cfgInlineSerialize
|
||||
++
|
||||
|
@ -249,7 +249,7 @@ makeA i = mkName $ "a" ++ show i
|
||||
|
||||
openConstructor :: Name -> Int -> Q Pat
|
||||
openConstructor cname numFields =
|
||||
conP cname (map varP (map mkFieldName [0 .. (numFields - 1)]))
|
||||
conP cname (map (varP. mkFieldName) [0 .. (numFields - 1)])
|
||||
|
||||
matchConstructor :: Name -> Int -> Q Exp -> Q Match
|
||||
matchConstructor cname numFields exp0 =
|
||||
@ -276,9 +276,9 @@ typeOfType :: Type -> [DataCon] -> TypeOfType
|
||||
typeOfType headTy [] =
|
||||
error
|
||||
("Attempting to get size with no constructors (" ++
|
||||
(pprint headTy) ++ ")")
|
||||
pprint headTy ++ ")")
|
||||
typeOfType _ [DataCon cname _ _ []] = UnitType cname
|
||||
typeOfType _ [con@(DataCon _ _ _ _)] = TheType $ simplifyDataCon con
|
||||
typeOfType _ [con@DataCon{}] = TheType $ simplifyDataCon con
|
||||
typeOfType _ cons = MultiType $ map simplifyDataCon cons
|
||||
|
||||
isUnitType :: [DataCon] -> Bool
|
||||
@ -286,7 +286,7 @@ isUnitType [DataCon _ _ _ []] = True
|
||||
isUnitType _ = False
|
||||
|
||||
isRecordSyntax :: SimpleDataCon -> Bool
|
||||
isRecordSyntax (SimpleDataCon _ fields) = and (isJust . fst <$> fields)
|
||||
isRecordSyntax (SimpleDataCon _ fields) = all (isJust . fst) fields
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Type casting
|
||||
@ -326,7 +326,7 @@ wListToString = fmap (chr . fromIntegral)
|
||||
shiftAdd :: Bits a => (b -> a) -> [b] -> a
|
||||
shiftAdd conv xs =
|
||||
foldl' (.|.) zeroBits $
|
||||
map (\(j, x) -> shiftL x (j * 8)) $ zip [0 ..] $ map conv xs
|
||||
fmap (\(j, x) -> shiftL x (j * 8)) $ zip [0 ..] $ map conv xs
|
||||
|
||||
-- Note: This only works in little endian machines
|
||||
-- TODO:
|
||||
@ -423,7 +423,7 @@ serializeW8List :: Name -> Name -> [Word8] -> Q Exp
|
||||
serializeW8List off arr w8List = do
|
||||
[|let $(varP (makeN 0)) = $(varE off)
|
||||
in $(doE (fmap makeBind [0 .. (lenW8List - 1)] ++
|
||||
[noBindS ([|pure $(varE (makeN lenW8List))|])]))|]
|
||||
[noBindS [|pure $(varE (makeN lenW8List))|]]))|]
|
||||
|
||||
where
|
||||
|
||||
|
@ -40,8 +40,8 @@ mkDeserializeExprOne peeker (SimpleDataCon cname fields) =
|
||||
[ varE (makeI numFields)
|
||||
, appsE
|
||||
(conE cname :
|
||||
(map (varE . makeA)
|
||||
[0 .. (numFields - 1)]))
|
||||
map (varE . makeA)
|
||||
[0 .. (numFields - 1)])
|
||||
]))
|
||||
]
|
||||
])
|
||||
@ -60,7 +60,7 @@ mkSerializeExprFields poker fields =
|
||||
_ ->
|
||||
doE
|
||||
(fmap makeBind [0 .. (numFields - 1)] ++
|
||||
[noBindS ([|pure $(varE (makeI numFields))|])])
|
||||
[noBindS [|pure $(varE (makeI numFields))|]])
|
||||
where
|
||||
numFields = length fields
|
||||
makeBind i =
|
||||
|
@ -105,7 +105,7 @@ instance forall a. Serialize a => Serialize (CompactList a) where
|
||||
|
||||
-- {-# INLINE addSizeTo #-}
|
||||
addSizeTo acc (CompactList xs) =
|
||||
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Word8))) xs
|
||||
foldl' addSizeTo (acc + Unbox.sizeOf (Proxy :: Proxy Word8)) xs
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE deserializeAt #-}
|
||||
@ -175,10 +175,10 @@ mkRecSizeOfExpr :: SimpleDataCon -> Q Exp
|
||||
mkRecSizeOfExpr con = do
|
||||
n_acc <- newName "acc"
|
||||
n_x <- newName "x"
|
||||
(lamE
|
||||
lamE
|
||||
[varP n_acc, varP n_x]
|
||||
[|$(litIntegral hlen) +
|
||||
$(caseE (varE n_x) [matchCons (varE n_acc) con])|])
|
||||
$(caseE (varE n_x) [matchCons (varE n_acc) con])|]
|
||||
|
||||
where
|
||||
|
||||
@ -194,7 +194,7 @@ mkRecSizeOfExpr con = do
|
||||
|
||||
headerValue :: SimpleDataCon -> [Word8]
|
||||
headerValue (SimpleDataCon _ fields) =
|
||||
int_w8 numFields : concat (fmap lengthPrependedFieldEncoding fields)
|
||||
int_w8 numFields : concatMap lengthPrependedFieldEncoding fields
|
||||
|
||||
where
|
||||
|
||||
@ -215,7 +215,7 @@ headerValue (SimpleDataCon _ fields) =
|
||||
else
|
||||
errorUnsupported
|
||||
"Length of any key should be <= 255."
|
||||
in (int_w8 (length fEnc)) : fEnc
|
||||
in int_w8 (length fEnc) : fEnc
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Peek
|
||||
@ -232,7 +232,7 @@ serializeWithSize off arr val = do
|
||||
pure off1
|
||||
|
||||
mkRecSerializeExpr :: Name -> SimpleDataCon -> Q Exp
|
||||
mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
|
||||
mkRecSerializeExpr initialOffset con@(SimpleDataCon cname fields) = do
|
||||
afterHLen <- newName "afterHLen"
|
||||
-- Encoding the header length is required.
|
||||
-- We first compare the header length encoded and the current header
|
||||
@ -264,7 +264,7 @@ mkRecSerializeExpr initialOffset (con@(SimpleDataCon cname fields)) = do
|
||||
{-# INLINE deserializeWithSize #-}
|
||||
deserializeWithSize ::
|
||||
Serialize a => Int -> MutByteArray -> Int -> IO (Int, a)
|
||||
deserializeWithSize off arr endOff = deserializeAt (off + 4) arr endOff
|
||||
deserializeWithSize off = deserializeAt (off + 4)
|
||||
|
||||
conUpdateFuncDec :: Name -> [Field] -> Q [Dec]
|
||||
conUpdateFuncDec funcName fields = do
|
||||
@ -274,7 +274,7 @@ conUpdateFuncDec funcName fields = do
|
||||
arr <- newName "arr"
|
||||
key <- newName "key"
|
||||
method <-
|
||||
(caseE
|
||||
caseE
|
||||
(varE key)
|
||||
(concat
|
||||
[ map (matchField arr endOff (prevAcc, curOff)) fnames
|
||||
@ -291,7 +291,7 @@ conUpdateFuncDec funcName fields = do
|
||||
, valOff + w32_int valLen)|])
|
||||
[]
|
||||
]
|
||||
]))
|
||||
])
|
||||
pure
|
||||
[ PragmaD (InlineP funcName NoInline FunLike AllPhases)
|
||||
, FunD
|
||||
|
@ -1,3 +1,4 @@
|
||||
{- HLINT ignore -}
|
||||
-- |
|
||||
-- Module : Streamly.Internal.Data.Serialize.Type
|
||||
-- Copyright : (c) 2023 Composewell Technologies
|
||||
@ -190,7 +191,7 @@ deserializeChecked off arr sz =
|
||||
let next = off + Unbox.sizeOf (Proxy :: Proxy a)
|
||||
in do
|
||||
-- Keep likely path in the straight branch.
|
||||
if (next <= sz)
|
||||
if next <= sz
|
||||
then Unbox.peekAt off arr >>= \val -> pure (next, val)
|
||||
else error
|
||||
$ "deserializeAt: accessing array at offset = "
|
||||
@ -241,7 +242,7 @@ instance forall a. Serialize a => Serialize [a] where
|
||||
|
||||
-- {-# INLINE addSizeTo #-}
|
||||
addSizeTo acc xs =
|
||||
foldl' addSizeTo (acc + (Unbox.sizeOf (Proxy :: Proxy Int))) xs
|
||||
foldl' addSizeTo (acc + Unbox.sizeOf (Proxy :: Proxy Int)) xs
|
||||
|
||||
-- Inlining this causes large compilation times for tests
|
||||
{-# INLINABLE deserializeAt #-}
|
||||
|
@ -282,7 +282,7 @@ parseBreakD (PRD.Parser pstep initial extract) stream@(Stream step state) = do
|
||||
src = Prelude.reverse src0
|
||||
return (Right b, Nesting.append (fromList src) (Stream step s))
|
||||
PR.Error err -> do
|
||||
let src = (Prelude.reverse $ getList buf) ++ x:xs
|
||||
let src = Prelude.reverse (getList buf) ++ x:xs
|
||||
return
|
||||
( Left (ParseError err)
|
||||
, Nesting.append (fromList src) (Stream step s)
|
||||
@ -315,7 +315,7 @@ parseBreakD (PRD.Parser pstep initial extract) stream@(Stream step state) = do
|
||||
src = Prelude.reverse src0
|
||||
return (Right b, fromList src)
|
||||
PR.Error err -> do
|
||||
let src = (Prelude.reverse $ getList buf) ++ x:xs
|
||||
let src = Prelude.reverse (getList buf) ++ x:xs
|
||||
return (Left (ParseError err), fromList src)
|
||||
|
||||
-- This is simplified goExtract
|
||||
@ -441,7 +441,7 @@ elem e (Stream step state) = go SPEC state
|
||||
|
||||
{-# INLINE_NORMAL notElem #-}
|
||||
notElem :: (Monad m, Eq a) => a -> Stream m a -> m Bool
|
||||
notElem e s = fmap not (elem e s)
|
||||
notElem e s = fmap not (e `elem` s)
|
||||
|
||||
{-# INLINE_NORMAL all #-}
|
||||
all :: Monad m => (a -> Bool) -> Stream m a -> m Bool
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{- HLINT ignore "Eta reduce" -}
|
||||
-- |
|
||||
-- Module : Streamly.Internal.Data.StreamK
|
||||
-- Copyright : (c) 2017 Composewell Technologies
|
||||
|
@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE NoMonoLocalBinds #-}
|
||||
{-# LANGUAGE UnboxedTuples #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{- HLINT ignore -}
|
||||
|
||||
-- |
|
||||
-- Module : Streamly.Internal.Data.Unbox
|
||||
|
@ -21,9 +21,10 @@ module Streamly.Internal.Data.Unbox.TH
|
||||
-- Imports
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Bifunctor (second)
|
||||
import Data.List (elemIndex)
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Word (Word16, Word32, Word64, Word8)
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
@ -62,7 +63,7 @@ elimTV _ptv ktv (KindedTV n k) = ktv n k
|
||||
-- | Extract the type variable name from a 'TyVarBndr', ignoring the
|
||||
-- kind signature if one exists.
|
||||
tvName :: TyVarBndr_ flag -> Name
|
||||
tvName = elimTV id (\n _ -> n)
|
||||
tvName = elimTV id const
|
||||
|
||||
-- | Get the 'Name' of a 'TyVarBndr'
|
||||
tyVarBndrName :: TyVarBndr_ flag -> Name
|
||||
@ -191,7 +192,7 @@ mkOffsetDecls tagSize fields =
|
||||
[|$(litE (IntegerL (fromIntegral tagSize))) +
|
||||
$(varE _initialOffset)|])
|
||||
[])
|
||||
(map mkOffsetExpr (zip [1 ..] fields)))
|
||||
(fmap mkOffsetExpr (zip [1 ..] fields)))
|
||||
|
||||
where
|
||||
|
||||
@ -271,7 +272,7 @@ mkPeekExpr headTy cons =
|
||||
, noBindS
|
||||
(caseE
|
||||
(sigE (varE _tag) (conT tagType))
|
||||
(map peekMatch (zip [0 ..] cons) ++ [peekErr]))
|
||||
(fmap peekMatch (zip [0 ..] cons) ++ [peekErr]))
|
||||
]
|
||||
|
||||
where
|
||||
@ -303,7 +304,7 @@ mkPokeExprTag tagType tagVal = pokeTag
|
||||
[|pokeAt
|
||||
$(varE _initialOffset)
|
||||
$(varE _arr)
|
||||
$((sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType)))|]
|
||||
$(sigE (litE (IntegerL (fromIntegral tagVal))) (conT tagType))|]
|
||||
|
||||
mkPokeExprFields :: Int -> [Field] -> Q Exp
|
||||
mkPokeExprFields tagSize fields = do
|
||||
@ -326,7 +327,7 @@ mkPokeExprFields tagSize fields = do
|
||||
mkPokeMatch :: Name -> Int -> Q Exp -> Q Match
|
||||
mkPokeMatch cname numFields exp0 =
|
||||
match
|
||||
(conP cname (map varP (map mkFieldName [0 .. (numFields - 1)])))
|
||||
(conP cname (map (varP . mkFieldName) [0 .. (numFields - 1)]))
|
||||
(normalB exp0)
|
||||
[]
|
||||
|
||||
@ -339,15 +340,15 @@ mkPokeExpr headTy cons =
|
||||
$(lift (pprint headTy)) ++ ")")|]
|
||||
-- XXX We don't gaurentee encoded equivalilty for Unbox. Does it still
|
||||
-- make sense to encode a default value for unit constructor?
|
||||
[(DataCon _ _ _ [])] -> [|pure ()|] -- mkPokeExprTag ''Word8 0
|
||||
[(DataCon cname _ _ fields)] ->
|
||||
[DataCon _ _ _ []] -> [|pure ()|] -- mkPokeExprTag ''Word8 0
|
||||
[DataCon cname _ _ fields] ->
|
||||
caseE
|
||||
(varE _val)
|
||||
[mkPokeMatch cname (length fields) (mkPokeExprFields 0 fields)]
|
||||
_ ->
|
||||
caseE
|
||||
(varE _val)
|
||||
(map (\(tagVal, (DataCon cname _ _ fields)) ->
|
||||
(fmap (\(tagVal, DataCon cname _ _ fields) ->
|
||||
mkPokeMatch
|
||||
cname
|
||||
(length fields)
|
||||
@ -466,7 +467,7 @@ deriveUnbox mDecs = do
|
||||
mapType f v = f v
|
||||
|
||||
modifyConVariables f con =
|
||||
con { dcFields = map (\(a, b) -> (a, mapType f b)) (dcFields con) }
|
||||
con { dcFields = map (second (mapType f)) (dcFields con) }
|
||||
|
||||
mkInst mo preds headTyWC methods =
|
||||
pure [InstanceD mo preds headTyWC methods]
|
||||
|
@ -519,7 +519,7 @@ replicateM = Unfold step inject
|
||||
|
||||
where
|
||||
|
||||
inject seed = pure seed
|
||||
inject = pure
|
||||
|
||||
{-# INLINE_LATE step #-}
|
||||
step (i, action) =
|
||||
|
@ -340,7 +340,7 @@ number = Parser (\s a -> return $ step s a) initial (return . extract)
|
||||
step SPInitial val =
|
||||
case val of
|
||||
'+' -> Continue 0 (SPSign 1)
|
||||
'-' -> Continue 0 $ (SPSign (-1))
|
||||
'-' -> Continue 0 (SPSign (-1))
|
||||
_ -> do
|
||||
let num = ord val - 48
|
||||
if num >= 0 && num <= 9
|
||||
@ -481,7 +481,7 @@ doubleParser = Parser (\s a -> return $ step s a) initial (return . extract)
|
||||
step DPInitial val =
|
||||
case val of
|
||||
'+' -> Continue 0 (DPSign 1)
|
||||
'-' -> Continue 0 $ (DPSign (-1))
|
||||
'-' -> Continue 0 (DPSign (-1))
|
||||
_ -> do
|
||||
let num = ord val - 48
|
||||
if num >= 0 && num <= 9
|
||||
|
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskellQuotes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
-- |
|
||||
-- Module : Streamly.Internal.Unicode.String
|
||||
|
Loading…
Reference in New Issue
Block a user