never executed always true always false
    1 {-|
    2 Module: Flaw.Math
    3 Description: Math.
    4 License: MIT
    5 
    6 The math library is mostly generated by means of Template Haskell.
    7 Every data type is monomorphic, and uses unpacked scalar types.
    8 
    9 Derived math structures (vectors and matrices) are only available for
   10 scalar types having 'Vectorized' instance. Similarly quaternion types are
   11 only available for 'Quaternionized' scalar types.
   12 
   13 By default vectorized types are provided only for scalar types from
   14 'mathTypeNamesWithPrefix' list, and quaternion types only for types from
   15 'mathQuaternionTypeNamesWithPrefix' list. Vector's dimensions are from 1 to 4.
   16 Matrix dimensions are limited to ones from 'matDimensions' list.
   17 
   18 In general, math structures are defined as type families parametrized by scalar type.
   19 Convenient type synonyms and pattern synonyms are defined. As a result:
   20 
   21 * At type level you can use either 'Vec4' 'Float' (type family parametrized with scalar type)
   22 or 'Float4' (type synonym for the former).
   23 
   24 * At value level you can use either 'Float4' (constructor for type family instance)
   25 or 'Vec4' (bi-directional pattern synonym for the former) for both value construction and pattern matching.
   26 
   27 Scalar elements of vectors can be accessed with 'x_', 'y_', etc.
   28 Vector swizzling is available with 'xyz__', etc group of functions.
   29 
   30 There's no SIMD support yet.
   31 -}
   32 
   33 {-# LANGUAGE DeriveGeneric, MultiParamTypeClasses, PatternSynonyms, ScopedTypeVariables, TemplateHaskell, Trustworthy, TypeFamilies, ViewPatterns, UnboxedTuples #-}
   34 
   35 module Flaw.Math
   36   (
   37   -- * Classes
   38     Vec(..)
   39   , Dot(..)
   40   , Cross(..)
   41   , Norm(..)
   42   , Normalize(..)
   43   , Mat(..)
   44   , Mul(..)
   45   , MatInverse(..)
   46   -- * Data types
   47   -- ** Vectors and matrices
   48   , VecX(..), VecY(..), VecZ(..), VecW(..)
   49   , Vectorized(..)
   50   , VectorizedFunctor(..)
   51   , Vec1(..), Vec2(..), Vec3(..), Vec4(..)
   52   , Mat3x3(..), Mat3x4(..), Mat4x4(..)
   53   -- ** Quaternions
   54   , Quaternionized(..)
   55   , Quat(..)
   56   , Conjugate(..)
   57   -- * Pattern synonyms
   58   , pattern Vec1, pattern Vec2, pattern Vec3, pattern Vec4
   59   , pattern Mat3x3, pattern Mat3x4, pattern Mat4x4
   60   , pattern Quat
   61   -- * Vector swizzling
   62   , SwizzleVecX1(..), SwizzleVecX2(..), SwizzleVecX3(..), SwizzleVecX4(..)
   63   , SwizzleVecY1(..), SwizzleVecY2(..), SwizzleVecY3(..), SwizzleVecY4(..)
   64   , SwizzleVecZ1(..), SwizzleVecZ2(..), SwizzleVecZ3(..), SwizzleVecZ4(..)
   65   , SwizzleVecW1(..), SwizzleVecW2(..), SwizzleVecW3(..), SwizzleVecW4(..)
   66   -- * Type synonyms
   67   , Float1, Float2, Float3, Float4
   68   , Double1, Double2, Double3, Double4
   69   , Int32_1, Int32_2, Int32_3, Int32_4
   70   , Word32_1, Word32_2, Word32_3, Word32_4
   71   , Int1, Int2, Int3, Int4
   72   , Int8_1, Int8_2, Int8_3, Int8_4
   73   , Word8_1, Word8_2, Word8_3, Word8_4
   74   , Float3x3, Float3x4, Float4x4
   75   , Double3x3, Double3x4, Double4x4
   76   , Int32_3x3, Int32_3x4, Int32_4x4
   77   , Word32_3x3, Word32_3x4, Word32_4x4
   78   , Int3x3, Int3x4, Int4x4
   79   , Int8_3x3, Int8_3x4, Int8_4x4
   80   , Word8_3x3, Word8_3x4, Word8_4x4
   81   , FloatQ, DoubleQ
   82   -- * Base definitions
   83   , maxVecDimension
   84   , vecComponents
   85   ) where
   86 
   87 import Control.Monad
   88 import Data.Bits
   89 import Data.Char
   90 import Data.Default
   91 import Data.List
   92 import Data.Maybe
   93 import qualified Data.Serialize as S
   94 import Foreign.Ptr
   95 import Foreign.Storable
   96 import GHC.Generics(Generic)
   97 import Language.Haskell.TH
   98 
   99 import Flaw.Math.Internal
  100 
  101 -- | General vector class.
  102 class Vec (v :: *) where
  103   type VecElement v :: *
  104   -- | Get number of components in vector.
  105   vecLength :: v -> Int -- v is unused
  106   -- | Convert vector to list.
  107   vecToList :: v -> [VecElement v]
  108   -- | Create vector from scalar (put scalar into every component).
  109   vecFromScalar :: VecElement v -> v
  110 
  111 -- | Generate classes VecX..VecW with only method to access components.
  112 {- Example:
  113 class Vec v => VecX v where
  114   x_ :: v -> VecElement v
  115 -}
  116 forM vecComponents $ \c -> do
  117   let className = mkName $ "Vec" ++ [toUpper c]
  118   let methodName = mkName [c, '_']
  119   tvV <- newName "v"
  120   classD (return [AppT (ConT $ mkName "Vec") $ VarT tvV]) className [PlainTV tvV] []
  121     [ sigD methodName [t| $(varT tvV) -> VecElement $(varT tvV) |]
  122     ]
  123 
  124 -- | Generate class Vectorized.
  125 {-
  126 class Vectorized (a :: *) where
  127   data Vec{1234} a :: *
  128   vec{n=1234} :: a...{n} -> Vec{n} a
  129   unvec{n=1234} :: Vec{n} a -> (# a...{n} #)
  130   data Mat{1234}x{1234} a :: *
  131   mat{n=1234}x{m=1234} :: a...{n*m} -> Mat{n}x{m} a
  132   unmat{n=1234}x{m=1234} :: Mat{n}x{m} a -> (# a...{n*m} #)
  133 -}
  134 fmap return $ do
  135   tvA <- newName "a"
  136   vecDecs <- fmap concat $ forM [1..maxVecDimension] $ \dim -> do
  137     let dimStr = [intToDigit dim]
  138     let dataName = mkName $ "Vec" ++ dimStr
  139     let dataDec = dataFamilyD dataName [PlainTV tvA] (Just StarT)
  140     let packFuncDec = sigD (mkName $ "vec" ++ dimStr) $ foldr (\a b -> [t| $a -> $b |]) [t| $(conT dataName) $(varT tvA) |] $ replicate dim $ varT tvA
  141     let unpackFuncDec = sigD (mkName $ "unvec" ++ dimStr) [t| $(conT dataName) $(varT tvA) -> $(if dim == 1 then varT tvA else foldl appT (unboxedTupleT dim) $ replicate dim $ varT tvA) |]
  142     return [dataDec, packFuncDec, unpackFuncDec]
  143   matDecs <- fmap concat $ forM matDimensions $ \(dimN, dimM) -> do
  144     let dimStr = [intToDigit dimN, 'x', intToDigit dimM]
  145     let dataName = mkName $ "Mat" ++ dimStr
  146     let dataDec = dataFamilyD dataName [PlainTV tvA] (Just StarT)
  147     let packFuncDec = sigD (mkName $ "mat" ++ dimStr) $ foldr (\a b -> [t| $a -> $b |]) (appT (conT dataName) (varT tvA)) $ replicate (dimN * dimM) $ varT tvA
  148     let unpackFuncDec = sigD (mkName $ "unmat" ++ dimStr) [t| $(conT dataName) $(varT tvA) -> $(foldl appT (unboxedTupleT (dimN * dimM)) $ replicate (dimN * dimM) $ varT tvA) |]
  149     return [dataDec, packFuncDec, unpackFuncDec]
  150   classD (sequence [ [t| Ord $(varT tvA) |], [t| Show $(varT tvA) |] ]) (mkName "Vectorized") [KindedTV tvA StarT] [] $ vecDecs ++ matDecs
  151 
  152 -- | Special functor class over Vectorized elements.
  153 class VectorizedFunctor (f :: * -> *) where
  154   -- | Apply function to elements of functor.
  155   vecfmap :: (Vectorized a, Vectorized b) => (a -> b) -> f a -> f b
  156 
  157 -- Pattern synonyms for vectors and matrices, allowing to construct/deconstruct values using generalized names.
  158 -- vectors
  159 fmap concat . forM [1..maxVecDimension] $ \dim -> do
  160   let v = mkName $ "Vec" <> show dim
  161   a <- newName "a"
  162   comps <- mapM (newName . pure) $ take dim vecComponents
  163   sequence
  164     [ patSynSigD v (forallT [PlainTV a] (sequence [(conT ''Vectorized) `appT` (varT a)]) $ foldr (appT . (appT arrowT) . varT) ((conT v) `appT` (varT a)) (replicate dim a))
  165     , patSynD v (prefixPatSyn comps)
  166       (explBidir [clause (map varP comps) (normalB $ foldl appE (varE (mkName $ "vec" <> show dim)) $ map varE comps) []])
  167       (viewP (varE (mkName $ "unvec" <> show dim)) (if dim == 1 then varP (head comps) else unboxedTupP (map varP comps)))
  168     , pragCompleteD [v] Nothing
  169     ]
  170 -- matrices
  171 fmap concat . forM matDimensions $ \(dimN, dimM) -> do
  172   let dimStr = [intToDigit dimN, 'x', intToDigit dimM]
  173   let v = mkName $ "Mat" <> dimStr
  174   a <- newName "a"
  175   comps <- mapM newName [['m', intToDigit n, intToDigit m] | n <- [1..dimN], m <- [1..dimM]]
  176   sequence
  177     [ patSynSigD v (forallT [PlainTV a] (sequence [(conT ''Vectorized) `appT` (varT a)]) $ foldr (appT . (appT arrowT) . varT) ((conT v) `appT` (varT a)) (replicate (dimN * dimM) a))
  178     , patSynD v (prefixPatSyn comps)
  179       (explBidir [clause (map varP comps) (normalB $ foldl appE (varE (mkName $ "mat" <> dimStr)) $ map varE comps) []])
  180       (viewP (varE (mkName $ "unmat" <> dimStr)) (unboxedTupP (map varP comps)))
  181     , pragCompleteD [v] Nothing
  182     ]
  183 
  184 -- | Class for dot operation.
  185 class Vec v => Dot v where
  186   dot :: v -> v -> VecElement v
  187 
  188 -- | Class for cross operation.
  189 class Cross (v :: *) where
  190   cross :: v -> v -> v
  191 
  192 -- | Class for norm operation.
  193 class Vec v => Norm v where
  194   norm :: v -> VecElement v
  195   norm2 :: v -> VecElement v
  196 
  197 -- | Class for normalize operation.
  198 class Normalize (v :: *) where
  199   normalize :: v -> v
  200 
  201 -- | General matrix class.
  202 class Mat (m :: *) where
  203   type MatElement m :: *
  204   -- | Get matrix size.
  205   matSize :: m -> (Int, Int) -- m is unused
  206   -- | Create matrix from scalar (put scalar into every component).
  207   matFromScalar :: MatElement m -> m
  208 
  209 -- | Class for general multiplication.
  210 class Mul (a :: *) (b :: *) where
  211   type MulResult a b :: *
  212   mul :: a -> b -> MulResult a b
  213 
  214 -- | Class for matrix inversion.
  215 class MatInverse (a :: *) where
  216   matInverse :: a -> a
  217 
  218 -- | Generates classes SwizzleVec{X..W}{1..4}.
  219 {- Letter component should be presented in methods.
  220 Number is a dimension of result.
  221 class (VecX v, VecY v, VecZ v) => SwizzleVecZ2 v where
  222   type SwizzleVecZ2Result v :: *
  223   xz__ :: v -> SwizzleVecZ2Result v
  224   yz__ :: v -> SwizzleVecZ2Result v
  225   zx__ :: v -> SwizzleVecZ2Result v
  226   zy__ :: v -> SwizzleVecZ2Result v
  227   zz__ :: v -> SwizzleVecZ2Result v
  228 -}
  229 forM [(len, maxComp) | len <- [1..4], maxComp <- [1..4]] $ \(len, maxComp) -> do
  230   let
  231     components = take maxComp vecComponents
  232     nameSuffix = [toUpper $ last components, intToDigit len]
  233     className = mkName $ "SwizzleVec" ++ nameSuffix
  234     resultTypeName = mkName $ "SwizzleVecResult" ++ nameSuffix
  235   tvV <- newName "v"
  236   let
  237     variants = filter (swizzleVariantFilter components) $ genSwizzleVariants len
  238     genSig variant = sigD (mkName $ variant ++ "__") [t| $(varT tvV) -> $(conT resultTypeName) $(varT tvV) |]
  239   classD (sequence [ [t| $(conT $ mkName $ "Vec" ++ [toUpper c]) $(varT tvV) |] | c <- components])
  240     className [PlainTV tvV] [] $ openTypeFamilyD resultTypeName [PlainTV tvV] (KindSig StarT) Nothing : map genSig variants
  241 
  242 -- Things per math type.
  243 fmap concat $ mapM (uncurry mathTypeVectorizedDecls) mathTypeNamesWithPrefix
  244 
  245 -- Abstract instances for vector and matrix types.
  246 do
  247   tvE <- newName "e"
  248   let elemType = varT tvE
  249 
  250   -- vector declarations
  251   vecDecs <- fmap concat $ forM [1..maxVecDimension] $ \dim -> do
  252 
  253     let
  254       dimStr = [intToDigit dim]
  255       dataName = mkName $ "Vec" ++ dimStr
  256       conName = mkName $ "Vec" ++ dimStr -- using pattern synonym
  257       -- string with symbols of components, like "xyz"
  258       components = take dim vecComponents
  259 
  260     -- names for component-parameters
  261     componentParams <- forM components $ \c -> newName [c]
  262     as <- forM components $ \c -> newName ['a', c]
  263     bs <- forM components $ \c -> newName ['b', c]
  264     p <- newName "p"
  265 
  266     -- instance for Vec class
  267     vecInstance <- instanceD (sequence [ [t| Vectorized $elemType |] ]) [t| Vec ($(conT dataName) $elemType) |] =<< addInlines
  268       [ tySynInstD ''VecElement $ tySynEqn [ [t| $(conT dataName) $elemType |] ] elemType
  269       , funD 'vecLength [clause [wildP] (normalB $ litE $ integerL $ fromIntegral dim) []]
  270       , funD 'vecToList [clause [conP conName $ map varP componentParams] (normalB $ listE $ map varE componentParams) []]
  271       , funD 'vecFromScalar [clause [varP p] (normalB $ foldl appE (conE conName) $ replicate dim (varE p)) []]
  272       ]
  273 
  274     -- instances for VecX .. VecW classes
  275     vecComponentInstances <- forM components $ \component -> do
  276       let
  277         className = mkName $ "Vec" ++ [toUpper component]
  278         funName = mkName [component, '_']
  279       varName <- newName [component]
  280       instanceD (sequence [ [t| Vectorized $elemType |] ]) [t| $(conT className) ($(conT dataName) $elemType) |] =<< addInlines
  281         [ funD funName [clause [conP conName [if c == component then varP varName else wildP | c <- components]] (normalB (varE varName)) []]
  282         ]
  283 
  284     -- instance for VectorizedFunctor class
  285     vectorizedFunctorInstance <- instanceD (sequence []) [t| VectorizedFunctor $(conT dataName) |] =<< addInlines
  286       [ funD 'vecfmap [clause [varP p, conP conName $ map varP as] (normalB $ foldl appE (conE conName) $ map (appE (varE p) . varE) as) []]
  287       ]
  288 
  289     -- instance for Dot class
  290     dotInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Num $elemType |] ]) [t| Dot ($(conT dataName) $elemType) |] =<< addInlines
  291       [ funD 'dot
  292         [ clause
  293           [ conP conName $ map varP as
  294           , conP conName $ map varP bs
  295           ]
  296           (normalB $ foldl1 (\a b -> [| $a + $b |]) $ map (\(a, b) -> [| $(varE a) * $(varE b) |]) $ zip as bs) []
  297         ]
  298       ]
  299 
  300     -- instance for Norm class
  301     normInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Floating $elemType |] ]) [t| Norm ($(conT dataName) $elemType) |] =<< addInlines
  302       [ funD 'norm [clause [] (normalB $ [| sqrt . norm2 |]) []]
  303       , funD 'norm2 [clause [conP conName $ map varP as]
  304         (normalB $ foldl1 (\a b -> [| $a + $b |]) $ map ((\a -> [| $a * $a |]) . varE) as) []]
  305       ]
  306 
  307     -- instance for Normalize class
  308     normalizeInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Floating $elemType |] ]) [t| Normalize ($(conT dataName) $elemType) |] =<< addInlines
  309       [ funD 'normalize [clause [varP p] (normalB [| $(varE p) * vecFromScalar (1 / norm $(varE p)) |]) []]
  310       ]
  311 
  312     -- instance for SwizzleVec{maxComp}{dim} class
  313     swizzleVecInstances <- forM [(srcDim, maxComp) | srcDim <- [1..4], maxComp <- [1..srcDim]] $ \(srcDim, maxComp) -> do
  314       tvV <- newName "v"
  315       let
  316         swizzleComponents = take maxComp vecComponents
  317         nameSuffix = [toUpper $ last swizzleComponents, intToDigit dim]
  318         instanceName = mkName $ "SwizzleVec" ++ nameSuffix
  319         srcDataName = mkName $ "Vec" ++ [intToDigit srcDim]
  320         resultDecl = tySynInstD (mkName $ "SwizzleVecResult" ++ nameSuffix) $ tySynEqn [ [t| $(conT srcDataName) $elemType |] ] $ [t| $(conT dataName) $elemType |]
  321         variants = filter (swizzleVariantFilter swizzleComponents) $ genSwizzleVariants dim
  322         funDecl variant = let
  323           expr = foldl (\v c -> appE v [| $(varE (mkName [c, '_'])) $(varE tvV) |]) (conE conName) variant
  324           in funD (mkName $ variant ++ "__") [clause [varP tvV] (normalB expr) []]
  325       instanceD (sequence [ [t| Vectorized $elemType |] ]) [t| $(conT instanceName) ($(conT srcDataName) $elemType) |] =<< addInlines (resultDecl : map funDecl variants)
  326 
  327     let
  328       binaryOp opName = funD opName
  329         [ clause
  330           [ conP conName $ map varP as
  331           , conP conName $ map varP bs
  332           ]
  333           (normalB $ foldl appE (conE conName) $ map (\(a, b) -> [| $(varE opName) $(varE a) $(varE b) |]) $ zip as bs)
  334           []
  335         ]
  336       unaryOp opName = funD opName
  337         [ clause
  338           [ conP conName $ map varP as
  339           ]
  340           (normalB $ foldl appE (conE conName) $ map (\a -> [| $(varE opName) $(varE a) |]) as)
  341           []
  342         ]
  343       nullaryOp opName = funD opName
  344         [ clause []
  345           (normalB $ foldl appE (conE conName) $ map (\_ -> varE opName) as)
  346           []
  347         ]
  348 
  349     -- instance for Num class
  350     numInstance <- let
  351       fromIntegerDecl = do
  352         iParam <- newName "i"
  353         fiParam <- newName "fi"
  354         funD 'fromInteger [clause [varP iParam]
  355           (normalB $ foldl appE (conE conName) $ replicate dim $ varE fiParam)
  356           [valD (varP fiParam) (normalB [| fromInteger $(varE iParam) |]) []]]
  357 
  358       in instanceD (sequence [ [t| Vectorized $elemType |], [t| Num $elemType |] ]) [t| Num ($(conT dataName) $elemType) |] =<< addInlines
  359         [ binaryOp '(+)
  360         , binaryOp '(*)
  361         , binaryOp '(-)
  362         , unaryOp 'negate
  363         , unaryOp 'abs
  364         , unaryOp 'signum
  365         , fromIntegerDecl
  366         ]
  367 
  368     -- instance for Fractional class
  369     fractionalInstance <- let
  370       fromRationalDecl = do
  371         rParam <- newName "r"
  372         frParam <- newName "fr"
  373         funD 'fromRational [clause [varP rParam]
  374           (normalB $ foldl appE (conE conName) $ replicate dim $ varE frParam)
  375           [valD (varP frParam) (normalB [| fromRational $(varE rParam) |]) []]]
  376       in instanceD (sequence [ [t| Vectorized $elemType |], [t| Fractional $elemType |] ]) [t| Fractional ($(conT dataName) $elemType) |] =<< addInlines
  377         [ binaryOp '(/)
  378         , unaryOp 'recip
  379         , fromRationalDecl
  380         ]
  381 
  382     -- instance for Floating class
  383     floatingInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Floating $elemType |] ]) [t| Floating ($(conT dataName) $elemType) |] =<< addInlines (concat
  384       [ [nullaryOp 'pi]
  385       , map binaryOp
  386         [ '(**)
  387         , 'logBase
  388         ]
  389       , map unaryOp
  390         [ 'exp
  391         , 'sqrt
  392         , 'log
  393         , 'sin
  394         , 'tan
  395         , 'cos
  396         , 'asin
  397         , 'atan
  398         , 'acos
  399         , 'sinh
  400         , 'tanh
  401         , 'cosh
  402         , 'asinh
  403         , 'atanh
  404         , 'acosh
  405         ]
  406       ])
  407 
  408     -- instance for Storable class
  409     storableInstance <- let
  410       params = zip [0..(dim - 1)] as
  411       in instanceD (sequence [ [t| Vectorized $elemType |], [t| Storable $elemType |] ]) [t| Storable ($(conT dataName) $elemType) |] =<< addInlines
  412         [ funD 'sizeOf [clause [wildP] (normalB [| $(litE $ integerL $ fromIntegral dim) * sizeOf (undefined :: $elemType) |]) []]
  413         , funD 'alignment [clause [wildP] (normalB [| alignment (undefined :: $elemType) |]) []]
  414         , funD 'peek [clause [varP p] (normalB $ doE $ [bindS (varP a) [| peekElemOff (castPtr $(varE p)) $(litE $ integerL $ fromIntegral i) |] | (i, a) <- params] ++
  415           [noBindS [| return $(foldl appE (conE conName) $ map (varE . snd) params) |]]) []]
  416         , funD 'poke [clause [varP p, conP conName $ map (varP . snd) params]
  417           (normalB $ doE [noBindS [| pokeElemOff (castPtr $(varE p)) $(litE $ integerL $ fromIntegral i) $(varE a) |] | (i, a) <- params]) []]
  418         ]
  419 
  420     -- Eq instance
  421     eqInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Eq $elemType |] ]) [t| Eq ($(conT dataName) $elemType) |] =<< addInlines
  422       [ funD '(==) [clause [conP conName $ map varP as, conP conName $ map varP bs] (normalB $ foldl1 (\a b -> [| $a && $b |]) $ map (\(a, b) -> [| $(varE a) == $(varE b) |]) $ zip as bs) []]
  423       ]
  424 
  425     -- Ord instance
  426     ordInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Ord $elemType |] ]) [t| Ord ($(conT dataName) $elemType) |] =<< addInlines
  427       [ funD 'compare [clause [conP conName $ map varP as, conP conName $ map varP bs] (normalB $ foldr ($) [| EQ |] $ map (\(a, b) c ->
  428         [| case compare $(varE a) $(varE b) of
  429           EQ -> $c
  430           r -> r
  431           |]) $ zip as bs) []]
  432       ]
  433 
  434     -- Show instance
  435     {- Example:
  436     showsPrec p (Vec4 x y z w) q = if p >= 10 then '(' : s (')' : q) else s q where
  437       s h = "Vec4" ++ f x (f y (f z (f w h)))
  438       f t h = ' ' : (showsPrec 10 t h)
  439     -}
  440     showInstance <- do
  441       q <- newName "q"
  442       s <- newName "s"
  443       f <- newName "f"
  444       h <- newName "h"
  445       t <- newName "t"
  446       instanceD (sequence [ [t| Vectorized $elemType |], [t| Show $elemType |] ]) [t| Show ($(conT dataName) $elemType) |] =<< addInlines
  447         [ funD 'showsPrec [clause [varP p, conP conName $ map varP as, varP q] (normalB [| if $(varE p) >= 10 then '(' : $(varE s) (')' : $(varE q)) else $(varE s) $(varE q) |])
  448           [ funD s [clause [varP h] (normalB [| $(litE $ stringL $ "Vec" ++ dimStr) ++ $(foldr (appE . appE (varE f) . varE) (varE h) as) |]) []]
  449           , funD f [clause [varP t, varP h] (normalB [| ' ' : showsPrec 10 $(varE t) $(varE h) |]) []]
  450           ]]
  451         ]
  452 
  453     -- Serialize instance
  454     serializeInstance <-
  455       instanceD (sequence [ [t| Vectorized $elemType |], [t| S.Serialize $elemType |] ]) [t| S.Serialize ($(conT dataName) $elemType) |] =<< addInlines
  456         [ funD 'S.put [clause [conP conName $ map varP as] (normalB $ doE $ map (\a -> noBindS [| S.put $(varE a) |]) as) []]
  457         , funD 'S.get [clause [] (normalB $ doE $ map (\a -> bindS (varP a) [| S.get |]) as ++ [noBindS $ [| return $(foldl appE (conE conName) $ map varE as) |] ]) []]
  458         ]
  459 
  460     -- Default instance
  461     defaultInstance <-
  462       instanceD (sequence [ [t| Vectorized $elemType |], [t| Default $elemType |] ]) [t| Default ($(conT dataName) $elemType) |] =<< addInlines
  463         [ funD 'def [clause [] (normalB $ foldl appE (conE conName) $ replicate dim [| def |]) []]
  464         ]
  465 
  466     return $ vecInstance : vectorizedFunctorInstance : dotInstance : numInstance : normInstance : normalizeInstance : fractionalInstance : floatingInstance : storableInstance : eqInstance : ordInstance : showInstance : serializeInstance : defaultInstance :
  467       vecComponentInstances ++ swizzleVecInstances
  468 
  469   -- Cross instance
  470   crossInstance <- do
  471     names@[ax, ay, az, bx, by, bz] <- mapM newName ["ax", "ay", "az", "bx", "by", "bz"]
  472     let
  473       [axe, aye, aze, bxe, bye, bze] = map varE names
  474     instanceD (sequence [ [t| Vectorized $elemType |], [t| Num $elemType |] ]) [t| Cross (Vec3 $elemType) |] =<< addInlines
  475       [ funD 'cross [clause [conP 'Vec3 [varP ax, varP ay, varP az], conP 'Vec3 [varP bx, varP by, varP bz]] (normalB
  476         [| Vec3
  477           ($aye * $bze - $aze * $bye)
  478           ($aze * $bxe - $axe * $bze)
  479           ($axe * $bye - $aye * $bxe)
  480           |]) [] ]
  481       ]
  482 
  483   -- matrix declarations
  484   matDecs <- fmap concat $ forM matDimensions $ \(dimN, dimM) -> do
  485 
  486     let
  487       dimStr = [intToDigit dimN, 'x', intToDigit dimM]
  488       dataName = mkName $ "Mat" ++ dimStr
  489       conName = mkName $ "Mat" ++ dimStr -- using pattern synonym
  490 
  491     -- some params
  492     as <- mapM newName [['a', intToDigit i, intToDigit j] | i <- [1..dimN], j <- [1..dimM]]
  493     bs <- mapM newName [['b', intToDigit i, intToDigit j] | i <- [1..dimN], j <- [1..dimM]]
  494     p <- newName "p"
  495 
  496     -- Mat instance
  497     matInstance <- instanceD (sequence [ [t| Vectorized $elemType |] ]) [t| Mat ($(conT dataName) $elemType) |] =<< addInlines
  498       [ tySynInstD ''MatElement $ tySynEqn [ [t| $(conT dataName) $elemType |] ] elemType
  499       , funD 'matSize [clause [wildP] (normalB [| ($(litE $ integerL $ toInteger dimN), $(litE $ integerL $ toInteger dimM)) |]) []]
  500       , funD 'matFromScalar [clause [varP p] (normalB $ foldl appE (conE conName) $ replicate (dimN * dimM) (varE p)) []]
  501       ]
  502 
  503     -- Num instance
  504     numInstance <- let
  505       binaryOp opName = funD opName
  506         [ clause
  507           [ conP conName $ map varP as
  508           , conP conName $ map varP bs
  509           ]
  510           (normalB $ foldl appE (conE conName) $ map (\(a, b) -> infixApp (varE a) (varE opName) (varE b)) $ zip as bs)
  511           []
  512         ]
  513       unaryOp opName = funD opName
  514         [ clause
  515           [ conP conName $ map varP as
  516           ]
  517           (normalB $ foldl appE (conE conName) $ map (\a -> [| $(varE opName) $(varE a) |]) as)
  518           []
  519         ]
  520       fromIntegerDecl = do
  521         iParam <- newName "i"
  522         fiParam <- newName "fi"
  523         funD 'fromInteger [clause [varP iParam]
  524           (normalB $ foldl appE (conE conName) $ replicate (dimN * dimM) $ varE fiParam)
  525           [valD (varP fiParam) (normalB [| fromInteger $(varE iParam) |]) []]]
  526 
  527       in instanceD (sequence [ [t| Vectorized $elemType |], [t| Num $elemType |] ]) [t| Num ($(conT dataName) $elemType) |] =<< addInlines
  528         [ binaryOp '(+)
  529         , binaryOp '(*)
  530         , binaryOp '(-)
  531         , unaryOp 'negate
  532         , unaryOp 'abs
  533         , unaryOp 'signum
  534         , fromIntegerDecl
  535         ]
  536 
  537     -- Storable instance (column-major)
  538     storableInstance <- let
  539       params = zip [(i, j) | i <- [0..(dimN - 1)], j <- [0..(dimM - 1)]] as
  540       in instanceD (sequence [ [t| Vectorized $elemType |], [t| Storable $elemType |] ]) [t| Storable ($(conT dataName) $elemType) |] =<< addInlines
  541         [ funD 'sizeOf [clause [wildP] (normalB [| $(litE $ integerL $ fromIntegral (dimN * dimM)) * sizeOf (undefined :: $elemType) |]) []]
  542         , funD 'alignment [clause [wildP] (normalB [| alignment (undefined :: $elemType) |]) []]
  543         , funD 'peek [clause [varP p] (normalB $ doE $ [bindS (varP a) [| peekElemOff (castPtr $(varE p)) $(litE $ integerL $ fromIntegral (j * dimN + i)) |] | ((i, j), a) <- params] ++
  544           [noBindS [| return $(foldl appE (conE conName) $ map (varE . snd) params) |]]) []]
  545         , funD 'poke [clause [varP p, conP conName $ map (varP . snd) params]
  546           (normalB $ doE [noBindS [| pokeElemOff (castPtr $(varE p)) $(litE $ integerL $ fromIntegral (j * dimN + i)) $(varE a) |] | ((i, j), a) <- params]) []]
  547         ]
  548 
  549     -- Eq instance
  550     eqInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Eq $elemType |] ]) [t| Eq ($(conT dataName) $elemType) |] =<< addInlines
  551       [ funD '(==) [clause [conP conName $ map varP as, conP conName $ map varP bs] (normalB $ foldl1 (\a b -> [| $a && $b |]) $ map (\(a, b) -> [| $(varE a) == $(varE b) |]) $ zip as bs) []]
  552       ]
  553 
  554     -- Ord instance
  555     ordInstance <- instanceD (sequence [ [t| Vectorized $elemType |], [t| Ord $elemType |] ]) [t| Ord ($(conT dataName) $elemType) |] =<< addInlines
  556       [ funD 'compare [clause [conP conName $ map varP as, conP conName $ map varP bs] (normalB $ foldr ($) [| EQ |] $ map (\(a, b) c ->
  557         [| case compare $(varE a) $(varE b) of
  558           EQ -> $c
  559           r -> r
  560           |]) $ zip as bs) []]
  561       ]
  562 
  563     -- Show instance
  564     showInstance <- do
  565       q <- newName "q"
  566       s <- newName "s"
  567       f <- newName "f"
  568       h <- newName "h"
  569       t <- newName "t"
  570       instanceD (sequence [ [t| Vectorized $elemType |], [t| Show $elemType |] ]) [t| Show ($(conT dataName) $elemType) |] =<< addInlines
  571         [ funD 'showsPrec [clause [varP p, conP conName $ map varP as, varP q] (normalB [| if $(varE p) >= 10 then '(' : $(varE s) (')' : $(varE q)) else $(varE s) $(varE q) |])
  572           [ funD s [clause [varP h] (normalB [| $(litE $ stringL $ "Mat" ++ dimStr) ++ $(foldr (appE . appE (varE f) . varE) (varE h) as) |]) []]
  573           , funD f [clause [varP t, varP h] (normalB [| ' ' : showsPrec 10 $(varE t) $(varE h) |]) []]
  574           ]]
  575         ]
  576 
  577     -- Serialize instance
  578     serializeInstance <-
  579       instanceD (sequence [ [t| Vectorized $elemType |], [t| S.Serialize $elemType |] ]) [t| S.Serialize ($(conT dataName) $elemType) |] =<< addInlines
  580         [ funD 'S.put [clause [conP conName $ map varP as] (normalB $ doE $ map (\a -> noBindS [| S.put $(varE a) |]) as) []]
  581         , funD 'S.get [clause [] (normalB $ doE $ map (\a -> bindS (varP a) [| S.get |]) as ++ [noBindS $ [| return $(foldl appE (conE conName) $ map varE as) |] ]) []]
  582         ]
  583 
  584     return [matInstance, numInstance, storableInstance, eqInstance, ordInstance, showInstance, serializeInstance]
  585 
  586   -- Generate multiplications.
  587   mulInstances <- do
  588     let
  589       gen aName bName cName funDecl = instanceD (sequence [ [t| Vectorized $elemType |], [t| Num $elemType |] ]) [t| Mul ($(conT aName) $elemType) ($(conT bName) $elemType) |] =<< addInlines
  590         [ tySynInstD ''MulResult $ tySynEqn [ [t| $(conT aName) $elemType |], [t| $(conT bName) $elemType |] ] [t| $(conT cName) $elemType |]
  591         , funDecl
  592         ]
  593 
  594       genVecMatMul (n, m) = let
  595         aName = mkName $ "Vec" ++ [intToDigit n]
  596         aConName = aName -- using pattern synonym
  597         bName = mkName $ "Mat" ++ [intToDigit n, 'x', intToDigit m]
  598         bConName = bName -- using pattern synonym
  599         cName = mkName $ "Vec" ++ [intToDigit m]
  600         cConName = cName -- using pattern synonym
  601         aElemName i = mkName ['a', intToDigit i]
  602         bElemName i j = mkName ['b', intToDigit i, intToDigit j]
  603         cElemResult j = foldl1 (\a b -> [| $a + $b |]) [ [| $(varE $ aElemName i) * $(varE $ bElemName i j) |] | i <- [1..n]]
  604         aElems = map aElemName [1..n]
  605         bElems = [bElemName i j | i <- [1..n], j <- [1..m]]
  606         cElems = foldl appE (conE cConName) $ map cElemResult [1..m]
  607         aPat = conP aConName $ map varP aElems
  608         bPat = conP bConName $ map varP bElems
  609         in gen aName bName cName $ funD 'mul [clause [aPat, bPat] (normalB cElems) []]
  610       genMatVecMul (n, m) = let
  611         aName = mkName $ "Mat" ++ [intToDigit n, 'x', intToDigit m]
  612         aConName = aName -- using pattern synonym
  613         bName = mkName $ "Vec" ++ [intToDigit m]
  614         bConName = bName -- using pattern synonym
  615         cName = mkName $ "Vec" ++ [intToDigit n]
  616         cConName = cName -- using pattern synonym
  617         aElemName i j = mkName ['a', intToDigit i, intToDigit j]
  618         bElemName j = mkName ['b', intToDigit j]
  619         cElemResult i = foldl1 (\a b -> [| $a + $b |]) [ [| $(varE $ aElemName i j) * $(varE $ bElemName j) |] | j <- [1..m]]
  620         aElems = [aElemName i j | i <- [1..n], j <- [1..m]]
  621         bElems = map bElemName [1..m]
  622         cElems = foldl appE (conE cConName) $ map cElemResult [1..n]
  623         aPat = conP aConName $ map varP aElems
  624         bPat = conP bConName $ map varP bElems
  625         in gen aName bName cName $ funD 'mul [clause [aPat, bPat] (normalB cElems) []]
  626       genMatMatMul (n, m, k) = let
  627         aName = mkName $ "Mat" ++ [intToDigit n, 'x', intToDigit m]
  628         aConName = aName -- using pattern synonym
  629         bName = mkName $ "Mat" ++ [intToDigit m, 'x', intToDigit k]
  630         bConName = bName -- using pattern synonym
  631         cName = mkName $ "Mat" ++ [intToDigit n, 'x', intToDigit k]
  632         cConName = cName -- using pattern synonym
  633         aElemName i j = mkName ['a', intToDigit i, intToDigit j]
  634         bElemName i j = mkName ['b', intToDigit i, intToDigit j]
  635         cElemResult i j = foldl1 (\a b -> [| $a + $b |]) [ [| $(varE $ aElemName i t) * $(varE $ bElemName t j) |] | t <- [1..m]]
  636         aElems = [aElemName i j | i <- [1..n], j <- [1..m]]
  637         bElems = [bElemName i j | i <- [1..m], j <- [1..k]]
  638         cElems = foldl appE (conE cConName) [cElemResult i j | i <- [1..n], j <- [1..k]]
  639         aPat = conP aConName $ map varP aElems
  640         bPat = conP bConName $ map varP bElems
  641         in gen aName bName cName $ funD 'mul [clause [aPat, bPat] (normalB cElems) []]
  642 
  643     vecMatMuls <- mapM genVecMatMul $ do
  644       n <- [1..maxVecDimension]
  645       (m, k) <- matDimensions
  646       [(m, k) | n == m]
  647     matVecMuls <- mapM genMatVecMul $ do
  648       (n, m) <- matDimensions
  649       k <- [1..maxVecDimension]
  650       [(n, m) | m == k]
  651     matMatMuls <- mapM genMatMatMul $ do
  652       (n, m1) <- matDimensions
  653       (m2, k) <- matDimensions
  654       [(n, m1, k) | m1 == m2]
  655     
  656     return $ concat [vecMatMuls, matVecMuls, matMatMuls]
  657 
  658   -- matrix inversions
  659   matInverseInstances <- forM (map fst $ filter (uncurry (==)) matDimensions) $ \dim -> do
  660     mNames <- mapM newName ["m" ++ show i ++ "_" ++ show j | i <- [1..dim], j <- [1..dim]]
  661     let
  662       dataName = mkName $ "Mat" ++ show dim ++ "x" ++ show dim
  663       -- full mask
  664       dimMask = (1 `shiftL` dim) - 1
  665       -- name for value of minor
  666       detName imask jmask = case (maskBits imask, maskBits jmask) of
  667         ([i], [j]) -> mNames !! (i * dim + j)
  668         _ -> mkName $ "det" ++ show (imask :: Int) ++ "_" ++ show (jmask :: Int)
  669       -- get list of bits from mask
  670       maskBits mask = if mask == 0 then [] else let smask = (mask - 1) .&. mask in maskIndex (smask `xor` mask) : maskBits smask
  671       -- get index of one-bit mask
  672       maskIndex mask = fromJust $ elemIndex mask [1 `shiftL` a | a <- [0..(dim - 1)]]
  673       -- determinant expression
  674       detExp imask jmask = let
  675         (i : ribits) = maskBits imask
  676         jbits@(j : rjbits) = maskBits jmask
  677         subDets = detName (imask `xor` (1 `shiftL` i)) <$> map ((jmask `xor`) . (1 `shiftL`)) jbits
  678         alternateSign = zipWith ($) (cycle [id, \e -> [| negate $e |] ])
  679         subElems = alternateSign $ map (\jj -> varE $ mNames !! (i * dim + jj)) jbits
  680         subDetsElems = map (\(a, b) -> [| $(varE a) * $b |]) $ zip subDets subElems
  681         in if null ribits && null rjbits then varE $ mNames !! (i * dim + j) else foldl1 (\a b -> [| $a + $b |]) subDetsElems
  682       -- adjugate matrix expression
  683       adjExp = foldl appE (conE dataName)
  684         [ if even (i + j) then e else [| negate $e |]
  685         | i <- [0..(dim - 1)]
  686         , j <- [0..(dim - 1)]
  687         , let e = varE $ detName (dimMask `xor` (1 `shiftL` j)) (dimMask `xor` (1 `shiftL` i))
  688         ]
  689       -- inverse matrix expression
  690       invMatExp = [| $adjExp * matFromScalar (1 / $(varE $ detName dimMask dimMask)) |]
  691       -- decls for all determinants
  692       detDecls =
  693         [ valD (varP (detName imask jmask)) (normalB $ detExp imask jmask) []
  694         | imask <- [1..dimMask]
  695         , jmask <- [1..dimMask]
  696         , let l = length (maskBits imask)
  697         , l > 1 && ((1 `shiftL` max 0 (dim - l - 1)) - 1) .&. imask == 0 && l == length (maskBits jmask)
  698         ]
  699 
  700     instanceD (sequence [ [t| Vectorized $elemType |], [t| Fractional $elemType |] ]) [t| MatInverse ($(conT dataName) $elemType) |] =<< addInlines
  701       [ funD 'matInverse [clause [conP dataName $ map varP mNames] (normalB invMatExp) detDecls]
  702       ]
  703 
  704   return $ crossInstance : vecDecs ++ matDecs ++ mulInstances ++ matInverseInstances
  705 
  706 -- | Class of things which has quaternions.
  707 class (Vectorized a, Floating a) => Quaternionized a where
  708   data Quat a :: *
  709   quat :: Vec4 a -> Quat a
  710   unquat :: Quat a -> Vec4 a
  711 
  712 {-# COMPLETE Quat #-}
  713 pattern Quat :: Quaternionized a => Vec4 a -> Quat a
  714 pattern Quat v <- (unquat -> v) where Quat v = quat v
  715 
  716 -- | Conjugation.
  717 class Conjugate (q :: *) where
  718   conjugate :: q -> q
  719 
  720 -- Generate per-math type declarations for quaternions.
  721 fmap concat $ forM mathQuaternionTypeNamesWithPrefix $ \(mathTypeName, mathTypePrefix) -> do
  722 
  723   let elemType = conT mathTypeName
  724   let conName = mkName $ mathTypePrefix ++ "Q"
  725   v <- newName "v"
  726 
  727   -- Quaternionized instance
  728   quaternionizedInstance <- instanceD (sequence []) [t| Quaternionized $elemType |] =<< addInlines
  729     [ newtypeInstD (sequence []) ''Quat [elemType] Nothing (normalC conName [fmap (\t -> (Bang NoSourceUnpackedness NoSourceStrictness, t)) [t| Vec4 $elemType |]]) [derivClause Nothing [ [t| Generic |] ] ]
  730     , funD 'quat [clause [varP v] (normalB [| $(conE conName) $(varE v) |]) []]
  731     , funD 'unquat [clause [conP conName [varP v]] (normalB $ varE v) []]
  732     ]
  733 
  734   -- synonym
  735   synonym <- tySynD conName [] [t| Quat $elemType |]
  736 
  737   return [quaternionizedInstance, synonym]
  738 
  739 -- Abstract declarations for quaternions.
  740 do
  741   tvE <- newName "e"
  742   let elemType = varT tvE
  743   a <- newName "a"
  744   v <- newName "v"
  745   av <- newName "av"
  746   bv <- newName "bv"
  747   as <- forM vecComponents $ \c -> newName ['a', c]
  748   bs <- forM vecComponents $ \c -> newName ['b', c]
  749   let [ax, ay, az, aw] = map varE as
  750   let [bx, by, bz, bw] = map varE bs
  751 
  752   -- Vec instance
  753   vecInstance <- instanceD (sequence [ [t| Quaternionized $elemType |] ]) [t| Vec (Quat $elemType) |] =<< addInlines
  754     [ tySynInstD ''VecElement $ tySynEqn [ [t| Quat $elemType |] ] elemType
  755     , funD 'vecLength [clause [conP 'Quat [varP v]] (normalB [| vecLength $(varE v) |]) []]
  756     , funD 'vecToList [clause [conP 'Quat [varP v]] (normalB [| vecToList $(varE v) |]) []]
  757     , funD 'vecFromScalar [clause [varP a] (normalB [| Quat (vecFromScalar $(varE a)) |]) []]
  758     ]
  759 
  760   -- Norm instance
  761   normInstance <- instanceD (sequence [ [t| Quaternionized $elemType |] ]) [t| Norm (Quat $elemType) |] =<< addInlines
  762     [ funD 'norm [clause [conP 'Quat [varP v]] (normalB [| norm $(varE v) |]) []]
  763     , funD 'norm2 [clause [conP 'Quat [varP v]] (normalB [| norm2 $(varE v) |]) []]
  764     ]
  765 
  766   -- Normalize instance
  767   normalizeInstance <- instanceD (sequence [ [t| Quaternionized $elemType |] ]) [t| Normalize (Quat $elemType) |] =<< addInlines
  768     [ funD 'normalize [clause [conP 'Quat [varP v]] (normalB [| Quat (normalize $(varE v)) |]) []]
  769     ]
  770 
  771   -- Num instance
  772   numInstance <-
  773     instanceD (sequence [ [t| Quaternionized $elemType |] ]) [t| Num (Quat $elemType) |] =<< addInlines
  774       [ funD '(+) [clause [conP 'Quat [varP av], conP 'Quat [varP bv]] (normalB [| Quat ($(varE av) + $(varE bv)) |]) []]
  775       , funD '(-) [clause [conP 'Quat [varP av], conP 'Quat [varP bv]] (normalB [| Quat ($(varE av) - $(varE bv)) |]) []]
  776       , funD '(*) [clause
  777         [ conP 'Quat [conP 'Vec4 $ map varP as]
  778         , conP 'Quat [conP 'Vec4 $ map varP bs]
  779         ] (normalB [| Quat (Vec4
  780           ($aw * $bx + $ax * $bw + $ay * $bz - $az * $by)
  781           ($aw * $by - $ax * $bz + $ay * $bw + $az * $bx)
  782           ($aw * $bz + $ax * $by - $ay * $bx + $az * $bw)
  783           ($aw * $bw - $ax * $bx - $ay * $by - $az * $bz)
  784           )|]) []]
  785       , funD 'negate [clause [conP 'Quat [varP v]] (normalB [| Quat (negate $(varE v)) |]) []]
  786       , funD 'abs [clause [conP 'Quat [varP v]] (normalB [| Quat (abs $(varE v)) |]) []]
  787       , funD 'signum [clause [] (normalB [| undefined |]) []]
  788       , funD 'fromInteger [clause [] (normalB [| undefined |]) []]
  789       ]
  790 
  791   -- Conjugate instance
  792   conjugateInstance <- instanceD (sequence [ [t| Quaternionized $elemType |] ]) [t| Conjugate (Quat $elemType) |] =<< addInlines
  793     [ funD 'conjugate [clause [conP 'Quat [conP 'Vec4 $ map varP as]] (normalB [| Quat (Vec4 (- $ax) (- $ay) (- $az) $aw) |]) []]
  794     ]
  795 
  796   -- Storable instance
  797   storableInstance <-
  798     instanceD (sequence [ [t| Quaternionized $elemType |], [t| Storable $elemType |] ]) [t| Storable (Quat $elemType) |] =<< addInlines
  799       [ funD 'sizeOf [clause [wildP] (normalB [| sizeOf (undefined :: Vec4 $elemType) |]) []]
  800       , funD 'alignment [clause [wildP] (normalB [| alignment (undefined :: Vec4 $elemType) |]) []]
  801       , funD 'peek [clause [varP a] (normalB [| Quat <$> peek (castPtr $(varE a)) |]) []]
  802       , funD 'poke [clause [varP a, conP 'Quat [varP av]] (normalB [| poke (castPtr $(varE a)) $(varE av) |]) []]
  803       ]
  804 
  805   -- Eq instance
  806   eqInstance <- instanceD (sequence [ [t| Quaternionized $elemType |], [t| Eq $elemType |] ]) [t| Eq (Quat $elemType) |] =<< addInlines
  807     [ funD '(==) [clause [conP 'Quat [varP av], conP 'Quat [varP bv]] (normalB [| $(varE av) == $(varE bv) |]) []]
  808     ]
  809 
  810   -- Ord instance
  811   ordInstance <- instanceD (sequence [ [t| Quaternionized $elemType |], [t| Ord $elemType |] ]) [t| Ord (Quat $elemType) |] =<< addInlines
  812     [ funD 'compare [clause [conP 'Quat [varP av], conP 'Quat [varP bv]] (normalB [| compare $(varE av) $(varE bv) |]) []]
  813     ]
  814 
  815   -- Show instance
  816   {- Example:
  817   showsPrec p (Quat v) q = if p >= 10 then '(' : s (')' : q) else s q where
  818     s h = "Quat " ++ showsPrec 10 v h
  819   -}
  820   showInstance <- do
  821     p <- newName "p"
  822     q <- newName "q"
  823     s <- newName "s"
  824     h <- newName "h"
  825     instanceD (sequence [ [t| Quaternionized $elemType |], [t| Show $elemType |] ]) [t| Show (Quat $elemType) |] =<< addInlines
  826       [ funD 'showsPrec [clause [varP p, conP 'Quat [varP av], varP q] (normalB [| if $(varE p) >= 10 then '(' : $(varE s) (')' : $(varE q)) else $(varE s) $(varE q) |])
  827         [ funD s [clause [varP h] (normalB [| "Quat " ++ showsPrec 10 $(varE av) $(varE h) |]) []]
  828         ]]
  829       ]
  830 
  831   -- Serialize instance
  832   serializeInstance <-
  833     instanceD (sequence [ [t| Quaternionized $elemType |], [t| S.Serialize $elemType |] ]) [t| S.Serialize (Quat $elemType) |] =<< addInlines
  834       [ funD 'S.put [clause [conP 'Quat [varP av]] (normalB [| S.put $(varE av) |]) []]
  835       , funD 'S.get [clause [] (normalB [| Quat <$> S.get |]) []]
  836       ]
  837 
  838   return [vecInstance, normInstance, normalizeInstance, numInstance, conjugateInstance, storableInstance, eqInstance, ordInstance, showInstance, serializeInstance]