Ticket #2396: ClassMethodInline.hs

-- BUG : default class methods are not inlined
-- compile with -O2
-- see class PackedMat for more details


{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}

module Test where

import Prelude hiding (map,zipWith,foldr,foldl)

data (:.) a b = !a :. !b
infixr :.
type Vec3 a = a:.a:.a:.()
type Mat33 a = Vec3 (Vec3 a)
type Mat33D = Vec3 Vec3D 
data Vec3D = Vec3D {-#UNPACK#-} !Double 
                   {-#UNPACK#-} !Double 
                   {-#UNPACK#-} !Double

-- This is the class in question
class (Map pv v pm m, Map v pv m pm, PackedVec pv v) 
    => PackedMat pv v pm m | pv -> v, pm -> m
  where
    packMat   :: m -> pm
    unpackMat :: pm -> m
    -- These default definitions are not inlined.
    -- See instance declaration below.
    packMat = map pack
    unpackMat = map unpack
    {-# INLINE packMat #-}
    {-# INLINE unpackMat #-}

-- BUG IS HERE !!!
instance PackedMat Vec3D (Vec3 Double) Mat33D (Mat33 Double)
-- Uncomment these method definitions to see the desired behavior.
-- As it stands, core for definition of multmv3d will call
-- unpackMat and use many unessecary constructors
--  where
--    packMat = map pack 
--    unpackMat = map unpack
--    {-# INLINE packMat #-}
--    {-# INLINE unpackMat #-}


-- Of course this suffices without the class:
{-
packM = V.map packV 
unpackM = V.map unpackV
{-# INLINE packM #-}
{-# INLINE unpackM #-}
-}

class PackedVec pv v | pv -> v where
  pack   :: v -> pv
  unpack :: pv -> v

instance PackedVec Vec3D (Vec3 Double) where
  pack (x:.y:.z:.()) = Vec3D x y z
  unpack (Vec3D x y z) = x:.y:.z:.()
  {-# INLINE pack #-}
  {-# INLINE unpack #-}


multmv3d :: Mat33D -> Vec3D -> Vec3D
multmv3d a b = pack $ unpackMat a `multmv` unpack b

multmv :: (Num a, ZipWith a a a v v v, Fold a v, Map v a m v') 
          => m -> v -> v'

multmv m v = map (fold (+) . zipWith (*) v) m
{-# INLINE multmv #-}

class Map a b u v | u -> a, v -> b, b u -> v, a v -> u where
  map :: (a -> b) -> u -> v

instance Map a b (a :. ()) (b :. ()) where
  map f (x :. ()) = (f x) :. ()
  {-# INLINE map #-}

instance Map a b (a':.u) (b':.v) => Map a b (a:.a':.u) (b:.b':.v) where
  map f (x:.v) = (f x):.(map f v)
  {-# INLINE map #-}


class Fold a v | v -> a where
  fold  :: (a -> a -> a) -> v -> a
  foldl :: (b -> a -> b) -> b -> v -> b
  foldr :: (a -> b -> b) -> b -> v -> b

instance Fold a (a:.()) where
  fold  f   (a:._) = a 
  foldl f z (a:._) = (f $! z) $! a
  foldr f z (a:._) = (f $! a) $! z
  {-# INLINE fold #-}
  {-# INLINE foldl #-}
  {-# INLINE foldr #-}

instance Fold a (a':.u) => Fold a (a:.a':.u) where
  fold  f   (a:.v) = (f $! a) $! (fold f v)
  foldl f z (a:.v) = (f $! (foldl f z v)) $! a
  foldr f z (a:.v) = (f $! a) $! (foldr f z v)
  {-# INLINE fold #-}
  {-# INLINE foldl #-}
  {-# INLINE foldr #-}


class ZipWith a b c u v w | u->a, v->b, w->c, u v c -> w where
  zipWith :: (a -> b -> c) -> u -> v -> w

instance ZipWith a b c (a:.()) (b:.()) (c:.()) where
  zipWith f (x:._) (y:._) = f x y :.()
  {-# INLINE zipWith #-}

instance ZipWith a b c (a:.()) (b:.b:.bs) (c:.()) where
  zipWith f (x:._) (y:._) = f x y :.()
  {-# INLINE zipWith #-}

instance ZipWith a b c (a:.a:.as) (b:.()) (c:.()) where
  zipWith f (x:._) (y:._) = f x y :.()
  {-# INLINE zipWith #-}

instance 
  ZipWith a b c (a':.u) (b':.v) (c':.w) 
  => ZipWith a b c (a:.a':.u) (b:.b':.v) (c:.c':.w) 
    where
      zipWith f (x:.u) (y:.v) = f x y :. zipWith f u v
      {-# INLINE zipWith #-}