unboxed.hs

{-# LANGUAGE UnboxedTuples  #-}
{-# LANGUAGE RankNTypes     #-}
{-# LANGUAGE BangPatterns   #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds      #-}
{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE TypeOperators  #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Main where

import Prelude hiding (foldl, (.), id, flip)
import qualified Prelude
import GHC.Exts
import Data.Kind

type Lev (a :: TYPE r) = Void# -> a
unlift :: Lev (a :: TYPE r) -> a
unlift k = k void#

class Call (r :: RuntimeRep) where
  callF :: forall r' (a :: TYPE r) (b :: TYPE r'). (Lev a -> Lev b) -> a -> b
  mapF  :: forall r' (a :: TYPE r) (b :: TYPE r'). (a -> b) -> Lev a -> Lev b

instance Call LiftedRep where
  callF f x = f (\_ -> x) void#
  mapF f k _ = f (k void#)

instance Call IntRep where
  callF f x = f (\_ -> x) void#
  mapF f k _ = f (k void#)

id :: forall r (a :: TYPE r). Call r => a -> a
id = callF Prelude.id

(.) :: forall ra rb rc (b :: TYPE rb) (c :: TYPE rc) (a :: TYPE ra). (Call ra, Call rb) => (b -> c) -> (a -> b) -> (a -> c)
(.) f g = callF (mapF f Prelude.. mapF g)

fold :: forall r a (b :: TYPE r). Call r => (a -> b -> b) -> [a] -> b -> b
fold f [] = id
fold f (x:xs) = (fold f xs) . (f x)

flip :: forall ra rb rc (b :: TYPE rb) (c :: TYPE rc) (a :: TYPE ra). (Call ra, Call rb) => (a -> b -> c) -> b -> a -> c
flip f = callF (\lb _ -> callF (\la -> mapF (\k -> unlift $ mapF k lb) $ mapF f la))

foldl :: forall r a (b :: TYPE r). Call r => (b -> a -> b) -> b -> [a] -> b
foldl f = flip (fold (flip f))

usum :: [Int] -> Int
usum xs = I# (foldl (\acc (I# x) -> acc +# x) 0# xs)
{-# NOINLINE usum #-}

bsum :: [Int] -> Int
bsum xs = foldl (+) 0 xs
{-# NOINLINE bsum #-}

main = print $ usum [1..1000000]