Unboxed polymorphic types

Unboxed.hs

{-# LANGUAGE UnboxedTuples, MagicHash, TypeFamilies, DataKinds, PolyKinds, TypeOperators, DefaultSignatures  #-}
{-# LANGUAGE KindSignatures, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

module Data.Unboxed where

import GHC.Exts
import GHC.Generics


class Unbox (a :: *) where
    type Unboxed a :: #
    unbox :: a -> Unboxed a
    box   :: Unboxed a -> a

instance Unbox Int where
    type Unboxed Int = Int#
    unbox (I# x) = x
    box = I#

instance Unbox Word where
    type Unboxed Word = Word#
    unbox (W# x) = x
    box = W#

instance Unbox Float where
    type Unboxed Float = Float#
    unbox (F# x) = x
    box = F#

instance Unbox Double where
    type Unboxed Double = Double#
    unbox (D# x) = x
    box = D#

instance Unbox Char where
    type Unboxed Char = Char#
    unbox (C# x) = x
    box = C#

instance (Generic a, GUnbox (Rep a)) => Unbox a where
    type Unboxed a = GUnboxed (Rep a)

    default unbox :: (Generic a, GUnbox (Rep a)) => a -> GUnboxed (Rep a)
    unbox x = gunbox (from x)

    default box :: (Generic a, GUnbox (Rep a)) => GUnboxed (Rep a) -> a
    box x = to (gbox x)


class GUnbox f where
    type GUnboxed f :: #
    gunbox :: f p -> GUnboxed f
    gbox :: GUnboxed f -> f p

instance (Unbox c) => GUnbox (K1 i c) where
    type GUnboxed (K1 i c) = Unboxed c
    gunbox (K1 x) = unbox x
    gbox x = K1 (box x)

instance (GUnbox f) => GUnbox (M1 i t f) where
    type GUnboxed (M1 i t f) = GUnboxed f
    gunbox (M1 x) = gunbox x
    gbox x = M1 (gbox x)

instance (GUnbox f, GUnbox g) => GUnbox (f :*: g) where
    type GUnbox (f :*: g) = (# GUnboxed f, GUnboxed g #)
    gunbox (x :*: y) = (# gunbox x, gunbox y #)
    gbox (# x, y #) = gbox x :*: gbox y


data Point a = Point a a
    deriving (Generic, Unbox)

type Point# a = Unboxed (Point a)


distance :: (Unbox a, Fractional a) => Point# a -> Point# a -> a
distance p0 p1 =
    let Point x0 y0 = box p0
        Point x1 y1 = box p1
        dx = x1 - x0
        dy = y1 - y0
    in sqrt (dx * dx + dy * dy)
{-# SPECIALIZE distance :: Point Float -> Point Float -> Float #-}
{-# SPECIALIZE distance :: Point Double -> Point Double -> Double #-}