HEAD-only Core Lint error with arith-encode-1.0.2 (Type of case alternatives not the same as the annotation on case)
Originally observed on a head.hackage CI run here.
The arith-encode-1.0.2 library on Hackage fails to build with -dcore-lint on GHC HEAD. Here is a standalone example (which unfortunately isn't terribly minimized).
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
module Data.ArithEncode.Util (function) where
import Control.Exception
import Data.Array.Base (unsafeAt)
import Data.Array.Unboxed hiding (accum)
import Data.Bits
import Data.List
import Data.Maybe
import GHC.Exts (Int(..), Int#, uncheckedIShiftRA#, isTrue#, int2Double#, sqrtDouble#, double2Int#, (<#), (*#), (-#))
import GHC.Integer.GMP.Internals (Integer(..), shiftLInteger, shiftRInteger, sizeofBigNat#)
import GHC.Integer.Logarithms (integerLog2#)
import Numeric.Natural (Natural)
import Prelude hiding (seq)
import qualified Data.Map as Map
nonEmptyOptionSeq :: Encoding ty
-> Encoding [Maybe ty]
nonEmptyOptionSeq enc =
let
fwdfunc Nothing = Just []
fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest))
revfunc' [] = Just Nothing
revfunc' (Just first : rest) = Just (Just (first, rest))
revfunc' _ = Nothing
revfunc = revfunc' . reverse
in
wrap revfunc fwdfunc (optional (pair enc (seq (optional enc))))
nonEmptyBoundedOptionSeq :: Integer
-> Encoding ty
-> Encoding [Maybe ty]
nonEmptyBoundedOptionSeq len enc =
let
fwdfunc Nothing = Just []
fwdfunc (Just (first, rest)) = Just (reverse (Just first : rest))
revfunc' [] = Just Nothing
revfunc' (Just first : rest) = Just (Just (first, rest))
revfunc' _ = Nothing
revfunc = revfunc' . reverse
in
wrap revfunc fwdfunc (optional (pair enc (boundedSeq (len - 1) (optional enc))))
function :: Ord keyty =>
Encoding keyty
-> Encoding valty
-> Encoding (Map.Map keyty valty)
function keyenc valenc =
let
seqToMap val =
let
convertEnt (_, Nothing) = Nothing
convertEnt (key', Just val') = Just (decode keyenc key', val')
contents = catMaybes (map convertEnt (zip (iterate (+ 1) 0) val))
in
Just (Map.fromList contents)
mapToSeq val
| all (inDomain keyenc) (Map.keys val) =
let
foldfun (count, accum) (idx, val') =
(idx + 1,
Just val' : replicate (fromInteger (idx - count)) Nothing ++ accum)
sorted = sortBy (\(a, _) (b, _) -> compare a b)
(map (\(key, val') -> (encode keyenc key, val'))
(Map.assocs val))
(_, out) = foldl foldfun (0, []) sorted
reversed = reverse out
in
Just reversed
| otherwise = Nothing
innerenc =
case size keyenc of
Just finitesize -> nonEmptyBoundedOptionSeq finitesize valenc
Nothing -> nonEmptyOptionSeq valenc
in
wrap mapToSeq seqToMap innerenc
-----
-- Data.ArithEncoding.Basic
-----
data Encoding ty =
Encoding {
encEncode :: ty -> Integer,
encDecode :: Integer -> ty,
encSize :: !(Maybe Integer),
encInDomain :: ty -> Bool
}
boundedSeq :: Integer
-> Encoding ty
-> Encoding [ty]
boundedSeq len enc@Encoding { encSize = sizeval, encInDomain = indomainfunc } =
let
(newencode, newdecode) = boundedSeqCore len enc
newsize = case len of
0 -> Just 1
_ -> fmap (geometricSum len) sizeval
newindomain vals = length vals <= fromInteger len && all indomainfunc vals
in
Encoding { encEncode = newencode, encDecode = newdecode,
encSize = newsize, encInDomain = newindomain }
boundedSeqCore :: Integer -> Encoding ty -> ([ty] -> Integer, Integer -> [ty])
boundedSeqCore len Encoding { encEncode = encodefunc, encDecode = decodefunc,
encSize = sizeval } =
case sizeval of
Nothing ->
let
newencode [] = 0
newencode vals =
let
thislen = toInteger (length vals)
contentnum = fromProdList (map encodefunc vals)
in
(contentnum * len) + thislen
newdecode 0 = []
newdecode num =
let
adjusted = num - 1
(remainingEntropy, lengthEntropy) = adjusted `quotRem` len
thislen = lengthEntropy + 1
in
map decodefunc (toProdList thislen remainingEntropy)
in
(newencode, newdecode)
Just 0 -> (\[] -> 0, \0 -> [])
Just 1 -> (genericLength, flip genericReplicate (decodefunc 0))
Just finitesize ->
let
newencode [] = 0
newencode vals =
let
thislen = toInteger (length vals)
base = geometricSum (thislen - 1) finitesize
newencode' accum [] = accum
newencode' accum (first : rest) =
newencode' ((accum * finitesize) + encodefunc first) rest
in
base + (newencode' 0 (reverse vals))
newdecode 0 = []
newdecode num =
let
lowlen = ilog finitesize ((num * (finitesize - 1)) + 1) - 1
thislen = lowlen + 1
contentnum = num - (geometricSum lowlen finitesize)
newdecode' accum 1 entropy = (decodefunc entropy : accum)
newdecode' _ 0 _ = []
newdecode' accum count entropy =
let
thisentropy = entropy `mod` finitesize
restentropy = entropy `quot` finitesize
this = decodefunc thisentropy
in
newdecode' (this : accum) (count - 1) restentropy
in
reverse (newdecode' [] thislen contentnum)
in
(newencode, newdecode)
decode :: Encoding ty
-> Integer
-> ty
decode encoding num
| num < 0 =
throw (IllegalArgument ("decode argument " ++ show num ++ " is negative"))
| maybe False (<= num) (size encoding) =
throw (IllegalArgument ("decode argument " ++ show num ++
" is out of bounds"))
| otherwise = (encDecode encoding) num
encode :: Encoding ty
-> ty
-> Integer
encode encoding = encEncode encoding
ilog :: Integer -> Integer -> Integer
ilog n = toInteger . integerLogBase' n
inDomain :: Encoding ty
-> ty
-> Bool
inDomain encoding = encInDomain encoding
isqrt :: Integer -> Integer
isqrt = integerSquareRoot
geometricSum :: Integer -> Integer -> Integer
geometricSum len 1 = len + 1
geometricSum len base = (1 - base ^ (len + 1)) `quot` (1 - base)
mkPairCore :: Encoding ty1 -> Encoding ty2 ->
((ty1, ty2) -> Integer, Integer -> (ty1, ty2), Maybe Integer)
mkPairCore Encoding { encEncode = encode1, encDecode = decode1,
encSize = sizeval1 }
Encoding { encEncode = encode2, encDecode = decode2,
encSize = sizeval2 } =
let
(convertidx, decodefunc) = case (sizeval1, sizeval2) of
(Just maxval, _) ->
let
convertidx' idx1 idx2 = (idx2 * maxval) + idx1
newdecode num = (decode1 (num `mod` maxval), decode2 (num `quot` maxval))
in
(convertidx', newdecode)
(_, Just maxval) ->
let
convertidx' idx1 idx2 = (idx1 * maxval) + idx2
newdecode num = (decode1 (num `quot` maxval), decode2 (num `mod` maxval))
in
(convertidx', newdecode)
(Nothing, Nothing) ->
let
convertidx' idx1 idx2 =
let
sumval = idx1 + idx2
base = (((sumval + 1) * sumval)) `quot` 2
in
base + idx2
newdecode num =
let
sumval = (isqrt ((8 * num) + 1) - 1) `quot` 2
base = (((sumval + 1) * sumval)) `quot` 2
num2 = num - base
num1 = sumval - num2
in
(decode1 num1, decode2 num2)
in
(convertidx', newdecode)
encodefunc (val1, val2) = convertidx (encode1 val1) (encode2 val2)
sizeval =
do
size1 <- sizeval1
size2 <- sizeval2
return (size1 * size2)
in
(encodefunc, decodefunc, sizeval)
optional :: Encoding ty -> Encoding (Maybe ty)
optional Encoding { encEncode = encodefunc, encDecode = decodefunc,
encSize = sizeval, encInDomain = indomainfunc } =
let
newsize = sizeval >>= return . (+ 1)
newindomain = maybe True indomainfunc
newencode Nothing = 0
newencode (Just val) = 1 + encodefunc val
newdecode 0 = Nothing
newdecode num = Just (decodefunc (num - 1))
in
Encoding { encEncode = newencode, encDecode = newdecode,
encSize = newsize, encInDomain = newindomain }
pair :: Encoding ty1 -> Encoding ty2 -> Encoding (ty1, ty2)
pair enc1@Encoding { encInDomain = indomain1 }
enc2@Encoding { encInDomain = indomain2 } =
let
(encodefunc, decodefunc, sizeval) = mkPairCore enc1 enc2
indomainfunc (val1, val2) = indomain1 val1 && indomain2 val2
in
Encoding { encEncode = encodefunc, encDecode = decodefunc,
encSize = sizeval, encInDomain = indomainfunc }
seq :: Encoding ty -> Encoding [ty]
seq enc@Encoding { encInDomain = indomainfunc } =
let
(newEncode, newDecode) = seqCore enc
newInDomain = all indomainfunc
in
Encoding { encEncode = newEncode, encDecode = newDecode,
encSize = Nothing, encInDomain = newInDomain }
seqCore :: Encoding ty -> ([ty] -> Integer, Integer -> [ty])
seqCore Encoding { encEncode = encodefunc, encDecode = decodefunc,
encSize = sizeval } =
case sizeval of
Just finitesize ->
let
newencodefunc =
let
foldfun accum = (((accum * finitesize) + 1) +) . encodefunc
in
foldl foldfun 0
newdecodefunc =
let
newdecodefunc' accum 0 = accum
newdecodefunc' accum num =
let
decoded = decodefunc ((num - 1) `mod` finitesize)
in
newdecodefunc' (decoded : accum) ((num - 1) `quot` finitesize)
in
newdecodefunc' []
in
(newencodefunc, newdecodefunc)
Nothing ->
let
newencodefunc [] = 0
newencodefunc (first : rest) =
let
insertUnary bin val =
let
encoded = encodefunc val
shifted = bin `shiftL` (fromInteger encoded)
in
shifted .|. ((2 ^ encoded) - 1)
foldfun accum val =
let
shifted = accum `shiftL` 1
in
insertUnary shifted val
initial = insertUnary 1 first
in
foldl foldfun initial rest
newdecodefunc 0 = []
newdecodefunc num =
let
leadingOnes :: Integer -> Integer
leadingOnes =
let
leadingOnes' count n
| testBit n 0 = leadingOnes' (count + 1) (n `shiftR` 1)
| otherwise = count
in
leadingOnes' 0
extractUnary bin =
let
unaryLen = leadingOnes bin
shifted = bin `shiftR` (fromInteger (unaryLen + 1))
decoded
| shifted /= 0 = decodefunc unaryLen
| otherwise = decodefunc (unaryLen - 1)
in
(decoded, shifted)
doDecode accum 0 = accum
doDecode accum bin =
let
(val, newbin) = extractUnary bin
in
doDecode (val : accum) newbin
in
doDecode [] num
in
(newencodefunc, newdecodefunc)
size :: Encoding ty
-> Maybe Integer
size = encSize
wrap :: (a -> Maybe b)
-> (b -> Maybe a)
-> Encoding b
-> Encoding a
wrap fwd rev enc@Encoding { encEncode = encodefunc, encDecode = decodefunc,
encInDomain = indomainfunc } =
let
safefwd val =
case fwd val of
Just val' -> val'
Nothing -> throw (IllegalArgument "No mapping into underlying domain")
saferev val =
case rev val of
Just val' -> val'
Nothing -> throw (IllegalArgument "No mapping into external domain")
in
enc { encEncode = encodefunc . safefwd,
encDecode = saferev . decodefunc,
encInDomain = maybe False indomainfunc . fwd }
toProdList :: Integer -> Integer -> [Integer]
toProdList =
let
productList' accum 1 entropy = reverse (entropy : accum)
productList' _ 0 _ = []
productList' accum count entropy =
let
sumval = (isqrt ((8 * entropy) + 1) - 1) `quot` 2
base = (((sumval + 1) * sumval)) `quot` 2
num2 = entropy - base
num1 = sumval - num2
in
productList' (num1 : accum) (count - 1) num2
in
productList' []
fromProdList :: [Integer] -> Integer
fromProdList [] = 0
fromProdList vals =
let
(first : rest) = reverse vals
fromProdList' accum [] = accum
fromProdList' accum (first' : rest') =
let
sumval = accum + first'
base = (((sumval + 1) * sumval)) `quot` 2
in
fromProdList' (base + accum) rest'
in
fromProdList' first rest
data IllegalArgument = IllegalArgument !String
instance Show IllegalArgument where
show (IllegalArgument "") = "Illegal argument"
show (IllegalArgument s) = "Illegal argument: " ++ s
instance Exception IllegalArgument
-----
-- Math.NumberTheory.Roots.Squares
-----
{-# SPECIALISE integerSquareRoot :: Int -> Int,
Word -> Word,
Integer -> Integer,
Natural -> Natural
#-}
integerSquareRoot :: Integral a => a -> a
integerSquareRoot n
| n < 0 = error "integerSquareRoot: negative argument"
| otherwise = integerSquareRoot' n
{-# RULES
"integerSquareRoot'/Int" integerSquareRoot' = isqrtInt'
"integerSquareRoot'/Word" integerSquareRoot' = isqrtWord
"integerSquareRoot'/Integer" integerSquareRoot' = isqrtInteger
#-}
{-# INLINE [1] integerSquareRoot' #-}
integerSquareRoot' :: Integral a => a -> a
integerSquareRoot' = isqrtA
isqrtInt' :: Int -> Int
isqrtInt' n
| n < r*r = r-1
| otherwise = r
where
!r = (truncate :: Double -> Int) . sqrt $ fromIntegral n
isqrtWord :: Word -> Word
isqrtWord n
| n < (r*r)
|| finiteBitSize (0 :: Word) == 64 && r == 4294967296
= r-1
| otherwise = r
where
!r = (fromIntegral :: Int -> Word) . (truncate :: Double -> Int) . sqrt $ fromIntegral n
{-# INLINE isqrtInteger #-}
isqrtInteger :: Integer -> Integer
isqrtInteger = fst . karatsubaSqrt
-----
-- Math.NumberTheory.Logarithms
-----
integerLogBase' :: Integer -> Integer -> Int
integerLogBase' b n
| n < b = 0
| ln-lb < lb = 1
| b < 33 = let bi = fromInteger b
ix = 2*bi-4
u = logArr `unsafeAt` ix
v = logArr `unsafeAt` (ix+1)
ex = fromInteger ((fromIntegral u * fromIntegral ln) `quot` fromIntegral v)
in case u of
1 -> ln `quot` v
_ -> ex + integerLogBase' b (n `quot` b ^ ex)
| otherwise = let bi = fromInteger (b `shiftR` (lb-4))
ix = 2*bi-2
u = fromIntegral $ logArr `unsafeAt` ix
v = fromIntegral $ logArr `unsafeAt` (ix+1)
w = v + u*fromIntegral (lb-4)
ex = fromInteger ((u * fromIntegral ln) `quot` w)
in ex + integerLogBase' b (n `quot` b ^ ex)
where
lb = integerLog2' b
ln = integerLog2' n
integerLog2' :: Integer -> Int
integerLog2' n = I# (integerLog2# n)
logArr :: UArray Int Int
logArr = listArray (0, 61)
[ 1 , 1,
190537 , 301994,
1 , 2,
1936274 , 4495889,
190537 , 492531,
91313 , 256348,
1 , 3,
190537 , 603988,
1936274 , 6432163,
1686227 , 5833387,
190537 , 683068,
5458 , 20197,
91313 , 347661,
416263 , 1626294,
1 , 4,
32631 , 133378,
190537 , 794525,
163451 , 694328,
1936274 , 8368437,
1454590 , 6389021,
1686227 , 7519614,
785355 , 3552602,
190537 , 873605,
968137 , 4495889,
5458 , 25655,
190537 , 905982,
91313 , 438974,
390321 , 1896172,
416263 , 2042557,
709397 , 3514492,
1 , 5
]
-----
-- Math.NumberTheory.Roots.Squares.Internal
-----
{-# SPECIALISE isqrtA :: Integer -> Integer #-}
isqrtA :: Integral a => a -> a
isqrtA 0 = 0
isqrtA n = heron n (fromInteger . appSqrt . fromIntegral $ n)
{-# SPECIALISE heron :: Integer -> Integer -> Integer #-}
heron :: Integral a => a -> a -> a
heron n a = go (step a)
where
step k = (k + n `quot` k) `quot` 2
go k
| m < k = go m
| otherwise = k
where
m = step k
appSqrt :: Integer -> Integer
appSqrt (S# i#) = S# (double2Int# (sqrtDouble# (int2Double# i#)))
appSqrt n@(Jp# bn#)
| isTrue# ((sizeofBigNat# bn#) <# thresh#) =
floor (sqrt $ fromInteger n :: Double)
| otherwise = case integerLog2# n of
l# -> case uncheckedIShiftRA# l# 1# -# 47# of
h# -> case shiftRInteger n (2# *# h#) of
m -> case floor (sqrt $ fromInteger m :: Double) of
r -> shiftLInteger r h#
where
thresh# :: Int#
thresh# = if finiteBitSize (0 :: Word) == 64 then 5# else 9#
appSqrt _ = error "integerSquareRoot': negative argument"
karatsubaSqrt :: Integer -> (Integer, Integer)
karatsubaSqrt 0 = (0, 0)
karatsubaSqrt n
| lgN < 2300 =
let s = isqrtA n in (s, n - s * s)
| otherwise =
if lgN .&. 2 /= 0 then
karatsubaStep k (karatsubaSplit k n)
else
let n' = n `unsafeShiftL` 2
(s, r) = karatsubaStep k (karatsubaSplit k n')
r' | s .&. 1 == 0 = r
| otherwise = r + double s - 1
in (s `unsafeShiftR` 1, r' `unsafeShiftR` 2)
where
k = lgN `unsafeShiftR` 2 + 1
lgN = I# (integerLog2# n)
karatsubaStep :: Int -> (Integer, Integer, Integer, Integer) -> (Integer, Integer)
karatsubaStep k (a3, a2, a1, a0)
| r >= 0 = (s, r)
| otherwise = (s - 1, r + double s - 1)
where
r = cat u a0 - q * q
s = s' `unsafeShiftL` k + q
(q, u) = cat r' a1 `quotRem` double s'
(s', r') = karatsubaSqrt (cat a3 a2)
cat x y = x `unsafeShiftL` k .|. y
{-# INLINE cat #-}
karatsubaSplit :: Int -> Integer -> (Integer, Integer, Integer, Integer)
karatsubaSplit k n0 = (a3, a2, a1, a0)
where
a3 = n3
n3 = n2 `unsafeShiftR` k
a2 = n2 .&. m
n2 = n1 `unsafeShiftR` k
a1 = n1 .&. m
n1 = n0 `unsafeShiftR` k
a0 = n0 .&. m
m = 1 `unsafeShiftL` k - 1
double :: Integer -> Integer
double x = x `unsafeShiftL` 1
{-# INLINE double #-}To reproduce the error, compile this file like so:
$ ghc-stage2 -fforce-recomp -dcore-lint -O Bug.hs
[1 of 1] Compiling Data.ArithEncode.Util ( Bug.hs, Bug.o )
*** Core Lint errors : in result of Simplifier ***
Bug.hs:65:14: warning:
Type of case alternatives not the same as the annotation on case:
Actual type: keyty_a4Ai -> Bool
Annotation on case: keyty_a4Ai -> All
Alt Rhs: ds_d55n
In the RHS of function :: forall keyty valty.
Ord keyty =>
Encoding keyty -> Encoding valty -> Encoding (Map keyty valty)
In the body of lambda with binder keyty_a4Ai :: *
In the body of lambda with binder valty_a4Aj :: *
In the body of lambda with binder $dOrd_a4Ak :: Ord keyty_a4Ai
In the body of lambda with binder keyenc_a21R :: Encoding
keyty_a4Ai
In the body of lambda with binder valenc_a21S :: Encoding
valty_a4Aj
In the body of lambda with binder val_a221 :: Map
keyty_a4Ai valty_a4Aj
In the body of letrec with binders f_s5Lp :: keyty_a4Ai -> Bool
In the body of lambda with binder k1_a5Lz :: keyty_a4Ai
In the body of lambda with binder ds_a5LA :: valty_a4Aj
In the body of lambda with binder xs_a5LB :: All
In a case alternative: (Encoding ds_d55k :: keyty_a4Ai -> Integer,
ds_d55l :: Integer -> keyty_a4Ai,
ds_d55m :: Maybe Integer,
ds_d55n :: keyty_a4Ai -> Bool)
Substitution: [TCvSubst
In scope: InScope {keyty_a4Ai valty_a4Aj}
Type env: [a4Ai :-> keyty_a4Ai, a4Aj :-> valty_a4Aj]
Co env: []]This does not occur with GHC 8.10.1.