Unboxed arrays in Haskell

There is a great idea of Data.Ix implemented for nice and fast Data.Array.Unboxed and others. That allows to form arrays, matrices and other schemas (even triangles) of data access. To gain that flexibility we separate storage implementation (i.e. continous sequence of bytes) from indexing schema implementation.
But sometimes we need a way to access more complex objects and still have that magic Unboxed storage. I.e. instead of accessing single object we need two of them. Once again mighty of Haskell type system comes to save us. Just add another index axis and hide it in the same way how Ix do.

Isn't that funny?...

class SuperType a b c | a b -> c
class Coerce a b where
    coerce :: a -> b

instance (Coerce a c, Coerce b d) => Coerce (a, b) (c, d) where
    coerce (a, b) = (coerce a, coerce b)

coerceSuper :: (SuperType a b c, Coerce a c, Coerce b c) => (a, b) -> (c, c)
coerceSuper = coerce

instance (Integral a, Integral b) => SuperType a b Integer
    -- I'm too lazy to enumerate supertype for all pairs

instance Integral a => Coerce a Integer where coerce = toInteger

-- ANum
class (Integral a, Num a) => NumCoerce a
instance (Integral a, Num a) => NumCoerce a

data ANum = forall a . NumCoerce a => ANum a

instance Show ANum where showsPrec n (ANum a) = showsPrec n a

instance Eq ANum where
    (ANum a) == (ANum b) = (uncurry (==) . coerceSuper) (a,b)

instance Num ANum where
    (ANum a) + (ANum b) = (ANum . uncurry (+) . coerceSuper) (a,b)
    (ANum a) * (ANum b) = (ANum . uncurry (*) . coerceSuper) (a,b)
    (ANum a) - (ANum b) = (ANum . uncurry (-) . coerceSuper) (a,b)
    negate (ANum a) = ANum (negate a)
    abs (ANum a) = ANum (abs a)
    signum (ANum a) = ANum (signum a)
    fromInteger = ANum

One thing I really miss is nice way to create type-sets like NumCoerce a

By some reason Data.Decimal from Decimal-0.1.0 misses instance for Fractional instance Integral i => Fractional (DecimalRaw i) where (Decimal _ 0) / (Decimal _ ym) | ym /= 0 = Decimal 0 0 (Decimal p0 m0) / (Decimal 0 d) = divRem (Decimal p0 0) m0 where divRem z 0 = z -- out of decimalPlaces divRem (Decimal p m) r | p == maxBound = Decimal p (m + dm) where -- round for last digit dm | r'*2 >= d = dm0+1 | otherwise = dm0 (dm0, r') = r `divMod` d divRem (Decimal p m) r | r < d = divRem (Decimal (p+1) (m*10)) (r*10) divRem (Decimal p m) r = divRem (Decimal p (m+dm)) r' where (dm, r') = r `divMod` d -- divide decimalPlaces (Decimal xp xm) / (Decimal yp ym) | yp <= xp = Decimal (xp-yp) xm / Decimal 0 ym | otherwise = Decimal 0 (xm * (10^(yp-xp))) / Decimal 0 ym fromRational r = fromIntegral (numerator r) / fromIntegral (denominator r) class Scalable a where scale :: Integral b => Ratio b -> a -> a ratio :: Integral b => a -> a -> Ratio b instance Integral a => Scalable (DecimalRaw a) where r `scale` x = (x * n) / d where n = fromIntegral (numerator r) d = fromIntegral (denominator r) (Decimal xp xm) `ratio` (Decimal yp ym) = (fromIntegral xm * (10^yp)) % (fromIntegral ym * (10^xp))

List processors, request/response map

Once I tried to implement TigerHash in Haskell. Pure implementation was very slow no matter how did I tried to optimize it and I switched to foreign implementation in C. As most of hash function it need to store intermediate state between calls to update to process long streams. So interface in haskell consist of init/reset/update/finalize. But implementing only tigerHash function means that it will create and destroy context at each call. To avoid that I thought that I can make tigerHashList which will hold context while processing the list. That was pretty easy to use that tigerHashList when you have to just mapM_ print (tigerHashList $ map getContents files) or something like that. But when you will need to calculate something complicated which the way to use that function isn't so straight. For example:

out = tigerHashList (inp out)
inp ~(nextHash:ys) = nextFile : walk nextHash files ys

And there you have two choices: to make tigerHashMonad or to wrap that tigerHashList. As I did used "list processors" several times before:

newtype LPMonad a b c = LPMonad { unLPMonad :: [b] -> ([a] -> [a], c, [b]) }

runLPMonad :: LPMonad a b c -> ([a] -> [b]) -> c
runLPMonad m f = r where
    (inp, r, _) = unLPMonad m out
    out = f (inp [])

request :: a -> LPMonad a b b
request x = LPMonad (\ ~(y:ys) -> ((x:), y, ys) )

instance Monad (LPMonad a b) where
    return z = LPMonad (\ ys -> (id, z, ys))
    m >>= f = LPMonad next where
        next ys = (inp . inp', r', ys'') where
            (inp, r, ys') = unLPMonad m ys
            (inp', r', ys'') = unLPMonad (f r) ys'

data Action = Withdraw Int
            | Deposit Int
            | Receipt
            | Balance Int


account :: Int -> [Action] -> [Int]
account balance (Withdraw amount : xs) = balance' : account balance' xs where balance' = balance - amount
account balance (Deposit amount : xs) = balance' : account balance' xs where balance' = balance + amount
account balance (Receipt : xs) = balance : account balance xs
account balance (Balance amount : xs) = (amount - balance) : account balance xs


test1 = do
    request $ Deposit 200
    request $ Withdraw 50
    x <- request Receipt
    request $ Withdraw 50
    y <- request $ Balance 100
    return (x,y)

{-
tth = tree . splitBlocks 1024 where
    tree xs = runLPMonad (getHash 0 (length xs)) tigerHashList where
        getHash n 1 = request (xs !! n)
        getHash n m = do
            let l = m `div` 2
            a <- getHash n l
            b <- getHash (n+l) (m-l)
            request . runPut $ do
                putWord8 1
                put a
                put b
-}

main = do
    print (runLPMonad test1 (account 1))

P.S. simplified example from Curry's (MCC) Ports library.