Hi,
I'm seeing the following bug revived in 6.8.2 and 6.8.3:
http://hackage.haskell.org/trac/ghc/ticket/672
I use a default definition for class method, one that calls methods of
dependent (super?) classes. Of course I'm embarrassed it took me so long to
realize I didn't _need_ the class in the first place, I could just write a
plain polymorphic function that calls those methods. Regardless, looks like
a bug to me.
Two files are attached, Test.hs and Vec.hs. Search for "BUG IS HERE" in
Test.hs. There is a class and an instance declaration. Compile as-is to see
the correct result. Comment out the method definition in the instance
declaration to see the bug.
If someone confirms, I'll open a ticket.
Scott
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-- Vec : a library for fixed-length lists.
module Vec where
import Prelude hiding (map,zipWith,foldl,foldr,reverse,take,drop,head,tail,sum,length)
import qualified Prelude as P
import Foreign.Storable
import Foreign.Ptr
-- The vector type. (:.) for vectors is like (:) for lists, and () takes the
-- place of [].
data a :. b = (:.) !a !b
deriving (Eq,Ord,Read)
infixr :.
instance (Show a, Show v) => Show (a:.v) where
show (a:.v) = show a ++ ":. (" ++ show v ++ ")"
-- Some vectors. I heard somewhere that 7 was the magic number for tuples. So
-- be it for vectors as well.
type Vec2 a = a :. a :. ()
type Vec3 a = a :. (Vec2 a)
type Vec4 a = a :. (Vec3 a)
type Vec5 a = a :. (Vec4 a)
type Vec6 a = a :. (Vec5 a)
type Vec7 a = a :. (Vec6 a)
-- Some square matrices
type Mat22 a = Vec2 (Vec2 a)
type Mat23 a = Vec2 (Vec3 a)
type Mat33 a = Vec3 (Vec3 a)
type Mat34 a = Vec3 (Vec4 a)
type Mat44 a = Vec4 (Vec4 a)
-- Vec is the basic vector class, which is used to infer vector types from
-- their length and underlying component type. Some other functions, like
-- converting from lists, also fit in with the recursion here.
class Vec n a v | n a -> v, v -> n a where
mkVec :: n -> a -> v
-- make a uniform vector of a given length
vecFromList :: [a] -> v
-- turn a list into a vector of known length
getd :: Int -> v -> a
-- get a vector element, which one is determined at runtime
setd :: Int -> a -> v -> v
-- set a vector element, which one is determined at runtime
--Make a uniform vector. The length is inferred.
vec = mkVec undefined
instance Vec N1 a ( a :. () ) where
mkVec _ a = a :. ()
vecFromList (a:_) = a :. ()
vecFromList [] = error "vecFromList: list too short"
getd !i (a :. _)
| i == 0 = a
| otherwise = error ("getd: index out of bounds")
setd !i a _
| i == 0 = a :. ()
| otherwise = error ("setd: index out of bounds")
{-# INLINE setd #-}
{-# INLINE getd #-}
{-# INLINE mkVec #-}
{-# INLINE vecFromList #-}
instance Vec (Succ n) a (a':.v) => Vec (Succ (Succ n)) a (a:.a':.v) where
mkVec _ a = a :. (mkVec undefined a)
vecFromList (a:as) = a :. (vecFromList as)
vecFromList [] = error "vecFromList: list too short"
getd !i (a :. v)
| i == 0 = a
| otherwise = getd (i-1) v
setd !i a (x :. v)
| i == 0 = a :. v
| otherwise = x :. (setd (i-1) a v)
{-# INLINE setd #-}
{-# INLINE getd #-}
{-# INLINE mkVec #-}
{-# INLINE vecFromList #-}
--Type level naturals.
data N0
data Succ a
type N1 = Succ N0
type N2 = Succ N1
type N3 = Succ N2
type N4 = Succ N3
type N5 = Succ N4
type N6 = Succ N5
type N7 = Succ N6
type N8 = Succ N7
type N9 = Succ N8
type N10 = Succ N9
type N11 = Succ N10
type N12 = Succ N11
type N13 = Succ N12
type N14 = Succ N13
type N15 = Succ N14
type N16 = Succ N15
type N17 = Succ N16
type N18 = Succ N17
type N19 = Succ N18
n0 :: N0 ; n0 = undefined
n1 :: N1 ; n1 = undefined
n2 :: N2 ; n2 = undefined
n3 :: N3 ; n3 = undefined
n4 :: N4 ; n4 = undefined
n5 :: N5 ; n5 = undefined
n6 :: N6 ; n6 = undefined
n7 :: N7 ; n7 = undefined
n8 :: N8 ; n8 = undefined
n9 :: N9 ; n9 = undefined
n10 :: N10 ; n10 = undefined
n11 :: N11 ; n11 = undefined
n12 :: N12 ; n12 = undefined
n13 :: N13 ; n13 = undefined
n14 :: N14 ; n14 = undefined
n15 :: N15 ; n15 = undefined
n16 :: N16 ; n16 = undefined
n17 :: N17 ; n17 = undefined
n18 :: N18 ; n18 = undefined
n19 :: N19 ; n19 = undefined
class Nat n where nat :: n -> Int
instance Nat N0 where nat _ = 0
instance Nat a => Nat (Succ a) where nat _ = 1+(nat (undefined::a))
class Pred x y | x -> y, y -> x
instance Pred (Succ N0) N0
instance Pred (Succ n) p => Pred (Succ (Succ n)) (Succ p)
--Access: getting/setting vector elements, which one determined at compile
--time. Use the Nat types to access vector components. For instance, (get n0)
--gets the x component, (set n2 44) sets the z component to 44.
class Access n a v | v -> a where
get :: n -> v -> a
set :: n -> a -> v -> v
instance Access N0 a (a :. v) where
get _ (a :. _) = a
set _ a (_ :. v) = a :. v
{-# INLINE set #-}
{-# INLINE get #-}
instance Access n a v => Access (Succ n) a (a :. v) where
get _ (_ :. v) = get (undefined::n) v
set _ a' (a :. v) = a :. (set (undefined::n) a' v)
{-# INLINE set #-}
{-# INLINE get #-}
class Head v a | v -> a where head :: v -> a
instance Head (a :. as) a where
head (a :. _) = a
{-# INLINE head #-}
class Tail v v_ | v -> v_ where tail :: v -> v_
instance Tail (a :. as) as where
tail (_ :. as) = as
{-# INLINE tail #-}
-- Map, ZipWith and Fold. The function is applied strictly.
class Map a b u v | u -> a, v -> b, u b -> v a, v a -> u b 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 #-}
--strictly2 : strict binary function application
strictly2 f a b = (f $! a) $! b
{-# INLINE strictly2 #-}
class ZipWith a b c u v w | u->a, v->b, w->c, u c -> w, w a -> u where
zipWith :: (a -> b -> c) -> u -> v -> w
instance ZipWith a b c (a:.()) (b:.()) (c:.()) where
zipWith f (x:.()) (y:.()) = strictly2 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) = (strictly2 f x y):.(zipWith f u v)
{-# INLINE zipWith #-}
-- The fold function is like fold1. Whether it's left or right doesn't matter.
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:._) = strictly2 f z a
foldr f z (a:._) = strictly2 f a z
{-# INLINE fold #-}
{-# INLINE foldl #-}
{-# INLINE foldr #-}
instance Fold a (a:.u) => Fold a (a:.a:.u) where
fold f (a:.v) = strictly2 f a (fold f v)
foldl f z (a:.v) = strictly2 f (foldl f z v) a
foldr f z (a:.v) = strictly2 f a (foldr f z v)
{-# INLINE fold #-}
{-# INLINE foldl #-}
{-# INLINE foldr #-}
sum x = fold (+) x
product x = fold (*) x
maximum x = fold max x
minimum x = fold min x
{-# INLINE sum #-}
{-# INLINE product #-}
{-# INLINE maximum #-}
{-# INLINE minimum #-}
vecToList = foldr (:) []
{-# INLINE vecToList #-}
-- convert matrices to/from lists of lists.
matToLists = (P.map vecToList) . vecToList
matToList = concat . matToLists
matFromLists = vecFromList . (P.map vecFromList)
matFromList :: forall m n row mat elem. (Vec m row mat, Vec n elem row, Nat n) => [elem] -> mat
matFromList = matFromLists . groupsOf (nat(undefined::n))
where groupsOf n xs = let (a,b) = splitAt n xs in a:(groupsOf n b)
{-# INLINE matToLists #-}
{-# INLINE matToList #-}
{-# INLINE matFromLists #-}
{-# INLINE matFromList #-}
class Reverse v where
reverse :: v -> v
instance
(Reverse' (a:.()) v (a:.v))
=> Reverse (a:.v)
where
reverse (a:.v) = reverse' (a:.()) v
{-# INLINE reverse #-}
-- Reverse helper function : builds the reversed list as its first argument
class Reverse' p v v' | p v -> v' where
reverse' :: p -> v -> v'
instance Reverse' p (a:.()) (a:.p) where
reverse' p (a:.()) = a:.p
{-# INLINE reverse' #-}
instance Reverse' (a:.p) v v' => Reverse' p (a:.v) v' where
reverse' p (a:.v) = reverse' (a:.p) v
{-# INLINE reverse' #-}
class Append v1 v2 v3 | v1 v2 -> v3, v1 v3 -> v2 where
append :: v1 -> v2 -> v3
instance Append () v v where
append _ = id
{-# INLINE append #-}
instance Append (a:.()) v (a:.v) where
append (a:.()) v = a:.v
{-# INLINE append #-}
instance (Append (a':.v1) v2 v3) => Append (a:.a':.v1) v2 (a:.v3) where
append (a:.u) v = a:.(append u v)
{-# INLINE append #-}
-- Take and Drop : the amount to take or drop is known at compile time, as it
-- must be to infer the result type.
class Take n a v v' | n v -> v', n v' -> v, v -> a, v' -> a where
take :: n -> v -> v'
instance Take N0 a v () where
take _ _ = ()
{-# INLINE take #-}
instance Take n a v v' => Take (Succ n) a (a:.v) (a:.v') where
take _ (a:.v) = a:.(take (undefined::n) v)
{-# INLINE take #-}
class Drop n a v v' | n v -> v', n v' -> v, v -> a, v' -> a where
drop :: n -> v -> v'
instance Drop N0 a v v where
drop _ = id
{-# INLINE drop #-}
instance (Tail v' v'', Drop n a v v') => Drop (Succ n) a v v'' where
drop _ = tail . drop (undefined::n)
{-# INLINE drop #-}
--Num and Fractional instances. Everything is done component-wise. This is not
--at all consistent with mathematical convention. However I find it
--convenient. For instance, fromIntegral and realToFrac create uniform
--vectors from their arguments, so multiplying a vector by a scalar is just
--2 * v, and likewise for multiplying a matrix by a scalar. The literal 0 gives
--you either the null vector or a matrix of zeros, depending on the type.
instance
(Eq (a:.u)
,Show (a:.u)
,Num a
,Map a a (a:.u) (a:.u)
,ZipWith a a a (a:.u) (a:.u) (a:.u)
,Vec (Succ l) a (a:.u)
)
=> Num (a:.u)
where
(+) u v = zipWith (+) u v
(-) u v = zipWith (-) u v
(*) u v = zipWith (*) u v
abs u = map abs u
signum u = map signum u
fromInteger i = vec (fromInteger i)
{-# INLINE (+) #-}
{-# INLINE (-) #-}
{-# INLINE (*) #-}
{-# INLINE abs #-}
{-# INLINE signum #-}
{-# INLINE fromInteger #-}
instance
(Fractional a
,Ord (a:.u)
,ZipWith a a a (a:.u) (a:.u) (a:.u)
,Map a a (a:.u) (a:.u)
,Vec (Succ l) a (a:.u)
,Show (a:.u)
)
=> Fractional (a:.u)
where
(/) u v = zipWith (/) u v
recip u = map recip u
fromRational r = vec (fromRational r)
{-# INLINE (/) #-}
{-# INLINE recip #-}
{-# INLINE fromRational #-}
-- dot / inner / scalar product
dot u v = sum (u*v)
{-# INLINE dot #-}
-- vector norm, squared
normSq v = dot v v
{-# INLINE normSq #-}
-- vector norm
norm v = sqrt (dot v v)
{-# INLINE norm #-}
-- a unit vector in the direction of v
normalize v = map (/(norm v)) v
{-# INLINE normalize #-}
-- Matrix transpose wrapper class: infers type of one argument from the other,
-- because Transpose` can't do it, the fundeps there are not bijective
class Transpose a b | a -> b, b -> a where
transpose :: a -> b
instance Transpose () () where
transpose = id
instance
(Vec n s ra --ra is an n-vector of s'es (row of a)
,Vec m ra a --a is an m-vector of ra's
,Vec m s rb --rb is an m-vector of s'es (row of b)
,Vec n rb b --b is an n-vector of rb's
,Transpose' a b
)
=> Transpose a b
where
transpose = transpose'
{-# INLINE transpose #-}
class Transpose' a b | a->b
where transpose' :: a -> b
instance Transpose' () () where
transpose' = id
{-# INLINE transpose' #-}
instance
(Transpose' vs vs') => Transpose' ( () :. vs ) vs'
where
transpose' (():.vs) = transpose' vs
{-# INLINE transpose' #-}
instance Transpose' ((x:.()):.()) ((x:.()):.()) where
transpose' = id
instance
(Head xss_h xss_hh
,Map xss_h xss_hh (xss_h:.xss_t) xs'
,Tail xss_h xss_ht
,Map xss_h xss_ht (xss_h:.xss_t) xss_
,Transpose' (xs :. xss_) xss'
)
=> Transpose' ((x:.xs):.(xss_h:.xss_t)) ((x:.xs'):.xss')
where
transpose' ((x:.xs):.xss) =
(x :. (map head xss)) :. (transpose' (xs :. (map tail xss)))
{-# inline transpose' #-}
-- row vector * matrix
multvm v m = map (dot v) (transpose m)
{-# INLINE multvm #-}
-- matrix * column vector
multmv m v = map (dot v) m
{-# INLINE multmv #-}
-- matrix * matrix
multmm a b = map (\v -> map (dot v) (transpose b)) a
{-# INLINE multmm #-}
class SetDiagonal v m | m -> v where
setDiagonal :: v -> m -> m
--set the diagonal of an n-by-n matrix to a given n-vector
instance (Vec n a v, Vec n r m, SetDiagonal' N0 v m) => SetDiagonal v m where
setDiagonal v m = setDiagonal' (undefined::N0) v m
{-# INLINE setDiagonal #-}
class SetDiagonal' n v m where
setDiagonal' :: n -> v -> m -> m
instance SetDiagonal' n () m where
setDiagonal' _ _ m = m
{-# INLINE setDiagonal' #-}
instance
(SetDiagonal' (Succ n) v m
,Access n a r
)
=> SetDiagonal' n (a:.v) (r:.m)
where
setDiagonal' _ (a:.v) (r:.m) =
(set (undefined::n) a r) :. (setDiagonal' (undefined::Succ n) v m)
{-# INLINE setDiagonal' #-}
class GetDiagonal m v | m -> v, v -> m where
getDiagonal :: m -> v
--get the diagonal of an n-by-n matrix as a vector
instance (Vec n a v, Vec n v m, GetDiagonal' N0 () m v) => GetDiagonal m v where
getDiagonal m = getDiagonal' (undefined::N0) () m
{-# INLINE getDiagonal #-}
class GetDiagonal' n p m v where
getDiagonal' :: n -> p -> m -> v
instance
(Access n a r
,Append p (a:.()) (a:.p)
) => GetDiagonal' n p (r:.()) (a:.p)
where
getDiagonal' _ p (r:.()) = append p ((get (undefined::n) r) :. ())
{-# INLINE getDiagonal' #-}
instance
(Access n a r
,Append p (a:.()) p'
,GetDiagonal' (Succ n) p' m v
)
=> GetDiagonal' n p (r:.m) v
where
getDiagonal' _ p (r:.m) =
getDiagonal' (undefined::Succ n) (append p ( (get (undefined::n) r):.())) m
{-# INLINE getDiagonal' #-}
--scale : multiply the diagonal of matrix m by the vector s, component-wise. So
--(scale 5 m) multiplies the diagonal by 5, whereas (scale (vec(2,1,1,..)) m)
--only scales the x-dimension.
scale s m = setDiagonal (s * (getDiagonal m)) m
{-# INLINE scale #-}
--diagonal : construct a matrix with the vector v as the diagonal, and 0
--elsewhere.
diagonal :: (Vec n a v, Vec n v m, SetDiagonal v m, Num m) => v -> m
diagonal v = setDiagonal v 0
{-# INLINE diagonal #-}
--identity matrix
identity :: (Vec n a v, Vec n v m, Num v, Num m, SetDiagonal v m) => m
identity = diagonal 1
{-# INLINE identity #-}
-- cross / outter / vector product, for 3-vectors only
cross :: Num a => Vec3 a -> Vec3 a -> Vec3 a
cross (ux:.uy:.uz:.()) (vx:.vy:.vz:.()) =
(uy*vz-uz*vy):.(uz*vx-ux*vz):.(ux*vy-uy*vx):.()
{-# INLINE cross #-}
-- DropConsec: this is a helper function for computing determinants. Given an
-- n-vector v, drop each element from v and collect the remaning (n-1)-vectors
-- into an n-vector (ie an n-by-(n-1) matrix)
class DropConsec v vv | v -> vv where
dropConsec :: v -> vv
instance
(Vec n a v
,Pred n n_
,Vec n_ a v_
,Vec n v_ vv
,DropConsec' () v vv
) => DropConsec v vv
where
dropConsec v = dropConsec' () v :: vv
{-# INLINE dropConsec #-}
class DropConsec' p v vv where
dropConsec' :: p -> v -> vv
instance DropConsec' p (a:.()) (p:.()) where
dropConsec' p (a:.()) = (p:.())
{-# INLINE dropConsec' #-}
instance
(Append p (a:.v) x
,Append p (a:.()) y
,DropConsec' y (a:.v) z
)
=> DropConsec' p (a:.a:.v) (x:.z)
where
dropConsec' !p (a:.v) =
(append p v) :. (dropConsec' (append p (a:.())) v)
{-# INLINE dropConsec' #-}
--Alternating: vector of alternating positive/negative values. This is also a
--helper for computing determinants
class Alternating n a v | v -> n a where
alternating :: n -> a -> v
instance Alternating N1 a (a:.()) where
alternating _ !a = a:.()
{-# INLINE alternating #-}
instance (Num a, Alternating n a (a:.v)) => Alternating (Succ n) a (a:.a:.v) where
alternating _ !a = a:.(alternating (undefined::n) (negate a))
{-# INLINE alternating #-}
-- The Determinant of a square matrix
class Det a m | m -> a where
det :: m -> a
instance Num a => Det a ((a:.a:.()):.(a:.a:.()):.()) where
det ( (a:.b:.()) :. (c:.d:.()) :. () ) = a*d-b*c
{-# INLINE det #-}
instance
(Num a
,Num (a:.a:.a:.v)
,Fold a (a:.a:.a:.v)
,Alternating (Succ (Succ (Succ n))) a (a:.a:.a:.v)
,DropConsec (a:.a:.a:.v) vv
,Map (a:.a:.a:.v) vv ((a:.a:.a:.v):.(a:.a:.a:.v):.m) vmt
,Transpose vmt vm
,Map ((a:.a:.v):.(a:.a:.v):.m_) a vm (a:.a:.a:.v)
,Det a ((a:.a:.v):.(a:.a:.v):.m_)
,Vec (Succ (Succ (Succ n))) a (a:.a:.a:.v)
,Vec (Succ (Succ (Succ n))) (a:.a:.a:.v) ((a:.a:.a:.v):.(a:.a:.a:.v):.(a:.a:.a:.v):.m)
)
=>
Det a ((a:.a:.a:.v):.(a:.a:.a:.v):.(a:.a:.a:.v):.m)
where
det (mh:.mt) =
let m2 = map dropConsec mt :: vmt
in
sum ((alternating undefined 1) * mh *
(map det (transpose m2)))
{-# INLINE det #-}
--ReplConsec : this is a helper for solving a linear system. Given an n-vector
--v and a value r, replace each consecutive element from v with r, and collect
--the resulting n-vectors into an n-vector (ie an n-by-n matrix)
class ReplConsec a v vv | v -> vv where
replConsec :: a -> v -> vv
instance
(Vec n a v
,Vec n v vv
,ReplConsec' a () v vv
) => ReplConsec a v vv
where
replConsec a v = replConsec' a () v :: vv
{-# INLINE replConsec #-}
class ReplConsec' a p v vv where
replConsec' :: a -> p -> v -> vv
instance ReplConsec' a p () () where
replConsec' _ _ () = ()
{-# INLINE replConsec' #-}
instance
(Append p (a:.v) x
,Append p (a:.()) y
,ReplConsec' a y v z
)
=> ReplConsec' a p (a:.v) (x:.z)
where
replConsec' !r !p ((!a):.(!v)) =
(append p (r:.v)) :. (replConsec' r (append p (a :. ())) v)
{-# INLINE replConsec' #-}
-- solution of linear system by Cramer's rule
solve !m !b =
map (\m' -> (det m')/(det m)) (transpose (zipWith replConsec b m))
{-# INLINE solve #-}
-- matrix inversion
invert !m = transpose (map (\v -> solve m v) identity)
{-# INLINE invert #-}
-- some functions for homogoneous coordinates
class HomogCoords a v where
homVec :: v -> (a:.v)
--Interpret the vector as a direction / point at infinity
homPoint :: v -> (a:.v)
--Interpret the vector as a point
project :: (a:.v) -> v
--Project a vector in homogenous coordinates back into "normal" space.
--It is assumed the last vector component is non-zero, ie it's a point.
instance
(Fractional a
,Num a
,Num v
,Fractional v
,Ord a
,Vec n a v
,Vec (Succ n) a (a:.v)
,Append v (a:.()) (a:.v)
,Take n a (a:.v) v
,Access n a (a:.v)
)
=> HomogCoords a v
where
homVec v = append v ((0::a):.()) :: (a:.v)
homPoint v = append v ((1::a):.()) :: (a:.v)
project v = (take (undefined::n) v) / (mkVec (undefined::n) $ get (undefined::n) v)
{-# INLINE homVec #-}
{-# INLINE homPoint #-}
{-# INLINE project #-}
-- apply a translation to a projective transformation matrix
translate v m =
case reverse (transpose m) of
(h:.t) -> transpose (reverse (((homVec v) + h) :. t))
{-# INLINE translate #-}
column n = get n . transpose
row n = get n
-- Storable instances.
instance Storable a => Storable (a:.()) where
sizeOf _ = sizeOf (undefined::a)
alignment _ = alignment (undefined::a)
peek !p = peek (castPtr p) >>= \a -> return (a:.())
peekByteOff !p !o = peek (p`plusPtr`o)
peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::a)))
poke !p !(a:._) = poke (castPtr p) a
pokeByteOff !p !o !x = poke (p`plusPtr`o) x
pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::a))) x
{-# INLINE sizeOf #-}
{-# INLINE alignment #-}
{-# INLINE peek #-}
{-# INLINE peekByteOff #-}
{-# INLINE peekElemOff #-}
{-# INLINE poke #-}
{-# INLINE pokeByteOff #-}
{-# INLINE pokeElemOff #-}
instance (Vec (Succ n) a (a:.v), Storable a, Storable v) => Storable (a:.v)
where
sizeOf _ = sizeOf (undefined::a) + sizeOf (undefined::v)
alignment _ = alignment (undefined::a)
peek !p =
peek (castPtr p) >>= \a ->
peek (castPtr (p`plusPtr`sizeOf(undefined::a))) >>= \v ->
return (a:.v)
peekByteOff !p !o = peek (p`plusPtr`o)
peekElemOff !p !i = peek (p`plusPtr`(i*sizeOf(undefined::(a:.v))))
poke !p !(a:.v) =
poke (castPtr p) a >>
poke (castPtr (p`plusPtr`sizeOf(undefined::a))) v
pokeByteOff !p !o !x = poke (p`plusPtr`o) x
pokeElemOff !p !i !x = poke (p`plusPtr`(i*sizeOf(undefined::(a:.v)))) x
{-# INLINE sizeOf #-}
{-# INLINE alignment #-}
{-# INLINE peek #-}
{-# INLINE peekByteOff #-}
{-# INLINE peekElemOff #-}
{-# INLINE poke #-}
{-# INLINE pokeByteOff #-}
{-# INLINE pokeElemOff #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Test where
import Vec as V
data Vec3D = Vec3D {-#UNPACK#-} !Double
{-#UNPACK#-} !Double
{-#UNPACK#-} !Double
type Mat33D = Vec3 Vec3D
class PackedVec pv v | pv -> v where
packV :: v -> pv
unpackV :: pv -> v
instance PackedVec Vec3D (Vec3 Double) where
packV (x:.y:.z:.()) = Vec3D x y z
unpackV (Vec3D x y z) = x:.y:.z:.()
{-# INLINE packV #-}
{-# INLINE unpackV #-}
-- BUG IS HERE !!!
class (Map pv v pm m, Map v pv m pm, PackedVec pv v)
=> PackedMat pv v pm m | pv -> v, pm -> m
where
packM :: m -> pm
unpackM :: pm -> m
-- These default definitions are not inlined.
-- See instance declaration below.
packM = V.map packV
unpackM = V.map unpackV
{-# INLINE packM #-}
{-# INLINE unpackM #-}
-- BUG IS HERE !!!
instance PackedMat Vec3D (Vec3 Double) Mat33D (Mat33 Double)
-- Comment out these definitions to see the bug. Check core for
-- definition of multmv3d and notice call to unpackM, as well as many
-- unessecary constructors
where
packM = V.map packV
unpackM = V.map unpackV
{-# INLINE packM #-}
{-# INLINE unpackM #-}
-- Of course this suffices without the class:
{-
packM = V.map packV
unpackM = V.map unpackV
{-# INLINE packM #-}
{-# INLINE unpackM #-}
-}
addv3d :: Vec3D -> Vec3D -> Vec3D
addv3d a b = packV (unpackV a + unpackV b)
multmv3d :: Mat33D -> Vec3D -> Vec3D
multmv3d a b = packV $ unpackM a `multmv` unpackV b
_______________________________________________
Glasgow-haskell-users mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/glasgow-haskell-users
