Aelve Codesearch

grep over package repositories
Please provide a string to search for.
3+ characters are required.
Index updated about an hour ago

total matches: more than 1000

Cabal-3.0.0.0
25 matches
tests/HackageTests.hs
import Data.Foldable                               (for_, traverse_)
import Data.IORef                                  (modifyIORef', newIORef, readIORef)
import Data.List                                   (isPrefixOf, isSuffixOf)
import Data.Maybe                                  (mapMaybe)
import Data.Monoid                                 (Sum (..))
import Distribution.PackageDescription.Check       (PackageCheck (..), checkPackage)
import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)
import Distribution.PackageDescription.Quirks      (patchQuirks)
import Distribution.Simple.Utils                   (fromUTF8BS, toUTF8BS)

            
tests/HackageTests.hs

instance Monoid CheckResult where
    mempty = CheckResult 0 0 0 0 0 0
    mappend = (<>)

toCheckResult :: PackageCheck -> CheckResult
toCheckResult PackageBuildImpossible {}    = CheckResult 0 1 0 0 0 0
toCheckResult PackageBuildWarning {}       = CheckResult 0 0 1 0 0 0
toCheckResult PackageDistSuspicious {}     = CheckResult 0 0 0 1 0 0

            
tests/HackageTests.hs
        putStrLn $ show d ++ " build dist suspicious warning"
        putStrLn $ show e ++ " build dist inexcusable"

    prefixP = fmap mkPredicate $ many $ O.strArgument $ mconcat
        [ O.metavar "PREFIX"
        , O.help "Check only files starting with a prefix"
        ]

    testFieldsP = O.switch $ mconcat

            
tests/HackageTests.hs

-- TODO: Use 'Cabal' for this?
reposFromConfig :: [Parsec.Field ann] -> [String]
reposFromConfig fields = takeWhile (/= ':') <$> mapMaybe f fields
  where
    f (Parsec.Field (Parsec.Name _ name) fieldLines)
        | B8.unpack name == "remote-repo" =
            Just $ fieldLinesToString fieldLines
    f (Parsec.Section (Parsec.Name _ name)

            
tests/HackageTests.hs

-- | Looks up the given key in the cabal configuration file
lookupInConfig :: String -> [Parsec.Field ann] -> [String]
lookupInConfig key = mapMaybe f
  where
    f (Parsec.Field (Parsec.Name _ name) fieldLines)
        | B8.unpack name == key =
            Just $ fieldLinesToString fieldLines
    f _ = Nothing

            
tests/HackageTests.hs
    -- strict foldM
    g :: m -> [a] -> IO m
    g !acc []     = return acc
    g !acc (x:xs) = f x >>= \ m -> g (mappend acc m) xs

-- | This 'parallelInterleaved' from @parallel-io@ but like (effectful) 'foldMap', not 'sequence'
foldIO' :: (Monoid m, NFData m) => (a -> IO m) -> [a] -> IO m
foldIO' f ys = do
    cap <- getNumCapabilities

            
tests/HackageTests.hs
    withPool cap' $ \pool -> mask $ \restore -> do
        for_ ys $ \y -> submitToPool pool $ reflectExceptionsTo tid $ do
            m <- restore (f y)
            modifyIORef' ref (force . mappend m)

        readIORef ref
  where
    reflectExceptionsTo :: ThreadId -> IO () -> IO ()
    reflectExceptionsTo tid act = catchNonThreadKilled act (throwTo tid)

            
tests/ParserTests.hs
            "UNXPECTED SUCCESS\n" ++
            showGenericPackageDescription gpd
        Left (v, errs) ->
            unlines $ ("VERSION: " ++ show v) : map (showPError fp) errs
  where
    input = "tests" </> "ParserTests" </> "errors" </> fp
    correct = replaceExtension input "errors"

-------------------------------------------------------------------------------

            
tests/ParserTests.hs

    return $ toUTF8BS $ case x of
        Right gpd ->
            unlines (map (showPWarning fp) warns)
            ++ showGenericPackageDescription gpd
        Left (_, errs) ->
            unlines $ "ERROR" : map (showPError fp) errs
  where
    input = "tests" </> "ParserTests" </> "regressions" </> fp
    correct = replaceExtension input "format"

#ifdef MIN_VERSION_tree_diff

            
tests/ParserTests.hs
    let (_, x) = runParseResult res
    case x of
        Right gpd      -> pure (toExpr gpd)
        Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPError fp) errs
  where
    input = "tests" </> "ParserTests" </> "regressions" </> fp
    exprFile = replaceExtension input "expr"
#endif


            
tests/ParserTests.hs
        case x' of
            Right gpd      -> pure gpd
            Left (_, errs) -> do
                void $ assertFailure $ unlines (map (showPError fp) errs)
                fail "failure"
    input = "tests" </> "ParserTests" </> "regressions" </> fp

-------------------------------------------------------------------------------
-- InstalledPackageInfo regressions

            
tests/ParserTests.hs
    cmp x y = return $ Just $ unlines $
        concatMap f (getGroupedDiff (BS8.lines x) (BS8.lines y))
      where
        f (First xs)  = map (cons3 '-' . fromUTF8BS) xs
        f (Second ys) = map (cons3 '+' . fromUTF8BS) ys
        -- we print unchanged lines too. It shouldn't be a problem while we have
        -- reasonably small examples
        f (Both xs _) = map (cons3 ' ' . fromUTF8BS) xs
        -- we add three characters, so the changed lines are easier to spot
        cons3 c cs = c : c : c : ' ' : cs

            
tests/UnitTests/Distribution/SPDX.hs
-------------------------------------------------------------------------------

shouldAccept :: [License]
shouldAccept = map License
    [ simpleLicenseExpression GPL_2_0_only
    , simpleLicenseExpression GPL_2_0_or_later
    , simpleLicenseExpression BSD_2_Clause
    , simpleLicenseExpression BSD_3_Clause
    , simpleLicenseExpression MIT

            
tests/UnitTests/Distribution/SPDX.hs
    ]

shouldReject :: [License]
shouldReject = map License
    [ simpleLicenseExpression BSD_4_Clause
    , simpleLicenseExpression BSD_4_Clause `EAnd` simpleLicenseExpression MIT
    ]

-- | A sketch of what Hackage could accept

            
tests/UnitTests/Distribution/SPDX.hs

shouldAcceptProp :: Property
shouldAcceptProp = conjoin $
    map (\l -> counterexample (prettyShow l) (isAcceptableLicense l)) shouldAccept

shouldRejectProp :: Property
shouldRejectProp = conjoin $
    map (\l -> counterexample (prettyShow l) (not $ isAcceptableLicense l)) shouldReject

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------


            
tests/UnitTests/Distribution/SPDX.hs
                arbA = arb m
                arbB = arb (n - m)

    shrink (EAnd a b) = a : b : map (uncurry EAnd) (shrink (a, b))
    shrink (EOr a b)  = a : b : map (uncurry EOr) (shrink (a, b))
    shrink _          = []


            
tests/UnitTests/Distribution/Utils/NubList.hs

prop_Identity :: [Int] -> Bool
prop_Identity xs =
    mempty `mappend` toNubList xs == toNubList xs `mappend` mempty

prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool
prop_Associativity xs ys zs =
    (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs
            == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs)

            
tests/UnitTests/Distribution/Version.hs
        unionVersionRanges (EarlierVersion v) (ThisVersion v)

  shrink AnyVersion                   = []
  shrink (ThisVersion v)              = map ThisVersion (shrink v)
  shrink (LaterVersion v)             = map LaterVersion (shrink v)
  shrink (EarlierVersion v)           = map EarlierVersion (shrink v)
  shrink (OrLaterVersion v)           = LaterVersion v : map OrLaterVersion (shrink v)
  shrink (OrEarlierVersion v)         = EarlierVersion v : map OrEarlierVersion (shrink v)
  shrink (WildcardVersion v)          = map WildcardVersion ( shrink v)
  shrink (MajorBoundVersion v)        = map MajorBoundVersion (shrink v)
  shrink (VersionRangeParens vr)      = vr : map VersionRangeParens (shrink vr)
  shrink (UnionVersionRanges a b)     = a : b : map (uncurry UnionVersionRanges) (shrink (a, b))
  shrink (IntersectVersionRanges a b) = a : b : map (uncurry IntersectVersionRanges) (shrink (a, b))

---------------------
-- Version properties
--


            
tests/UnitTests/Distribution/Version.hs
prop_VersionId lst0 =
    (versionNumbers . mkVersion) lst == lst
  where
    lst = map getNonNegative lst0

prop_VersionId2 :: VersionArb -> Bool
prop_VersionId2 (VersionArb lst) =
    (versionNumbers . mkVersion) lst == lst


            
tests/UnitTests/Distribution/Version.hs
--

instance Arbitrary VersionIntervals where
  arbitrary = fmap mkVersionIntervals' arbitrary
    where
      mkVersionIntervals' :: [(Version, Bound)] -> VersionIntervals
      mkVersionIntervals' = mkVersionIntervals . go version0
        where
          go :: Version -> [(Version, Bound)] -> [VersionInterval]

            
tests/UnitTests/Distribution/Version.hs

prop_parse_disp :: VersionRange -> Property
prop_parse_disp vr = counterexample (show (prettyShow vr')) $
    fmap s (simpleParsec (prettyShow vr')) === Just vr'
  where
    -- we have to strip parens, because arbitrary 'VersionRange' may have
    -- too little parens constructors.
    s = stripParensVersionRange
    vr' = s vr

            
tests/UnitTests/Distribution/Version.hs

prop_parse_disp1 :: VersionRange -> Bool
prop_parse_disp1 vr =
    fmap stripParens (simpleParsec (prettyShow vr)) == Just (normaliseVersionRange vr)
  where
    stripParens :: VersionRange -> VersionRange
    stripParens (VersionRangeParens v) = stripParens v
    stripParens (UnionVersionRanges v1 v2) =
      UnionVersionRanges (stripParens v1) (stripParens v2)

            
tests/UnitTests/Distribution/Version.hs

prop_parse_disp2 :: VersionRange -> Property
prop_parse_disp2 vr =
  let b = fmap (prettyShow :: VersionRange -> String) (simpleParsec (prettyShow vr))
      a = Just (prettyShow vr)
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a

            
tests/UnitTests/Distribution/Version.hs
prop_parse_disp3 :: VersionRange -> Property
prop_parse_disp3 vr =
  let a = Just (prettyShow vr)
      b = fmap displayRaw (simpleParsec (prettyShow vr))
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a


            
tests/UnitTests/Distribution/Version.hs

    dispWild v =
           Disp.hcat (Disp.punctuate (Disp.char '.')
                                     (map Disp.int (versionNumbers v)))
        <<>> Disp.text ".*"

            
JuicyPixels-scale-dct-0.1.2
4 matches
src/Codec/Picture/ScaleDCT.hs
       (Image (..), PixelRGBA8 (..), Traversal, generateImage, imagePixels)
import Control.Applicative (Const (..))
import Data.Array.CArray
       (CArray, amap, array, bounds, elems, listArray, size, (!))
import Data.Coerce         (Coercible, coerce)
import Data.Ix             (inRange, range)
import Data.Monoid         (Endo (..))
import Data.Word           (Word8)
import Math.FFT            (dct1N, dct2N, dct3N)

            
src/Codec/Picture/ScaleDCT.hs
    b = channelB img
    a = channelA img

    transform ch = amap (k*) ch'
      where
        ch' = dct3N [1, 0] . cutImpl . dct2N [0, 1] $ ch
        k = imgNorm ch / imgNorm ch'

    r' = transform r

            
src/Codec/Picture/ScaleDCT.hs
    a' = transform a

imgNorm :: Array2D -> Double
imgNorm ch = sqrt . (/n) . sum . fmap sq . elems $ ch
  where
    sq x = x * x
    n = fromIntegral $ size ch

cut :: (Int, Int) -> Array2D -> Array2D

            
src/Codec/Picture/ScaleDCT.hs
extractChannel :: (PixelRGBA8 -> Word8) -> Image PixelRGBA8 -> Array2D
extractChannel f img@(Image w h _)
    = listArray ((0, 0), (h - 1, w - 1))
    . map (fromInteger . toInteger . f)
    . toListOf imagePixels
    $ img

channelR, channelG, channelB, channelA :: Image PixelRGBA8 -> Array2D
channelR = extractChannel pixelR

            
LambdaHack-0.8.3.0
1 matches
Game/LambdaHack/Common/Prelude.hs

infixl 4 <$$>
(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
h <$$> m = fmap h <$> m

partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])
{-# INLINE partitionM #-}
partitionM p = foldr (\a ->
  liftA2 (\b -> (if b then first else second) (a :)) (p a)) (pure ([], []))