packages feed

shapes-math (empty) → 0.1.0.0

raw patch · 12 files changed

+685/−0 lines, 12 filesdep +QuickCheckdep +basedep +criterionsetup-changed

Dependencies added: QuickCheck, base, criterion, ghc-prim, hspec, linear, shapes-math, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Kynan Rilee++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MagicHash #-}++module Main where++import GHC.Types (Double(D#))++import Criterion.Main++import qualified Shapes.Linear.Double as D+import qualified Shapes.Linear.Boxed as B+import qualified Linear.V2 as L+import qualified Linear.Matrix as L+import qualified Linear.Metric as L++main :: IO ()+main = defaultMain (benchLinear ++ benchShapesMath ++ benchShapesMathBoxed)++theLV2 :: L.V2 Double+theLV2 = L.V2 1 2++theLV2' :: L.V2 Double+theLV2' = L.V2 3 4++theLM2x2 :: L.V2 (L.V2 Double)+theLM2x2 = L.V2 (L.V2 1 2) (L.V2 3 4)++benchLinear :: [Benchmark]+benchLinear =+  [ bench "L.dot" $ whnf (uncurry L.dot) (theLV2, theLV2')+  , bench "L.!*!" $ whnf (uncurry (L.!*!)) (theLM2x2, theLM2x2)+  ]++theDV2 :: D.V2+theDV2 = D.V2 1.0## 2.0##++theDV2' :: D.V2+theDV2' = D.V2 3.0## 4.0##++theDM2x2 :: D.M2x2+theDM2x2 = D.fromListM2x2 [1, 2, 3, 4]++benchShapesMath :: [Benchmark]+benchShapesMath =+  [ bench "D.dotV2" $ whnf (\(x, y) -> D# (x `D.dotV2` y)) (theDV2, theDV2')+  , bench "D.mul2x2x2" $ whnf (uncurry D.mul2x2x2) (theDM2x2, theDM2x2)+  ]++theBV2 :: B.V2+theBV2 = B.V2 1 2++theBV2' :: B.V2+theBV2' = B.V2 3 4++benchShapesMathBoxed :: [Benchmark]+benchShapesMathBoxed =+  [ bench "B.dot" $ whnf (uncurry B.dot) (theBV2, theBV2') ]
+ shapes-math.cabal view
@@ -0,0 +1,77 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3783e0698dfe9e7fd03167ff3fbf20064da1222fdf3c250c045c4a126a8acc86++name:           shapes-math+version:        0.1.0.0+synopsis:       faster vector/matrix math using unboxed numbers and Template Haskell+description:    Please see the README on Github at <https://github.com/ublubu/shapes#readme>+category:       Math+homepage:       https://github.com/ublubu/shapes#readme+bug-reports:    https://github.com/ublubu/shapes/issues+author:         Kynan Rilee+maintainer:     kynan.rilee@gmail.com+copyright:      2018 Kynan Rilee+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: https://github.com/ublubu/shapes++library+  hs-source-dirs:+      src+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , ghc-prim+    , template-haskell+  exposed-modules:+      Shapes.Linear.Boxed+      Shapes.Linear.Class+      Shapes.Linear.Double+      Shapes.Linear.MatrixTemplate+      Shapes.Linear.Template+      Shapes.Linear.ValueInfos+  other-modules:+      Paths_shapes_math+  default-language: Haskell2010++executable math-bench+  main-is: Main.hs+  hs-source-dirs:+      bench+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , criterion+    , ghc-prim+    , linear+    , shapes-math+    , template-haskell+  other-modules:+      Paths_shapes_math+  default-language: Haskell2010++test-suite math-spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , ghc-prim+    , hspec+    , linear+    , shapes-math+    , template-haskell+  other-modules:+      Shapes.Linear.TemplateSpec+      Paths_shapes_math+  default-language: Haskell2010
+ src/Shapes/Linear/Boxed.hs view
@@ -0,0 +1,6 @@+module Shapes.Linear.Boxed where++data V2 = V2 Double Double deriving Show++dot :: V2 -> V2 -> Double+(V2 x0 y0) `dot` (V2 x1 y1) = (x0 * x1) + (y0 * y1)
+ src/Shapes/Linear/Class.hs view
@@ -0,0 +1,4 @@+module Shapes.Linear.Class where++-- TODO: use class to make matrix/vector/scalar multiplication fit together nicely?+-- NOTE: Can't make type family of kind #. (confirm?)
+ src/Shapes/Linear/Double.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}++module Shapes.Linear.Double where++import GHC.Prim+import GHC.Types (Double(..))++import Shapes.Linear.Template+import Shapes.Linear.MatrixTemplate+import Shapes.Linear.ValueInfos (doubleInfo)++$(makeVectorType doubleInfo 2)+$(makeMatrixType doubleInfo (2, 2))+$(defineMatrixMul doubleInfo (2, 2, 2))+$(makeVectorType doubleInfo 6)+$(makeVectorType doubleInfo 3)+$(defineJoinSplit doubleInfo (3, 3))++testV2 :: V2+testV2 = V2 0.0## 1.0##++testV2' :: V2+testV2' = liftV2 (+## 1.0##) testV2++testV2'' :: V2+testV2'' = lift2V2 (+##) testV2 testV2++testDot :: Double+testDot = D# (testV2 `dotV2` testV2')++testM2x2 :: M2x2+testM2x2 = M2x2 0.0## 1.0## 2.0## 3.0##++idM2x2 :: M2x2+idM2x2 = fromListM2x2 [1, 0, 0, 1]
+ src/Shapes/Linear/MatrixTemplate.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module Shapes.Linear.MatrixTemplate where++import Data.Monoid+import Language.Haskell.TH++import Shapes.Linear.Template++makeMatrixNL :: (Int, Int) -> (Name, Int)+makeMatrixNL (rows, cols) =+  (mkName $ "M" ++ show rows ++ "x" ++ show cols, rows * cols)++makeMatrixType :: ValueInfo -> (Int, Int) -> DecsQ+makeMatrixType vi@ValueInfo{..} dims = do+  let (matrixN, len) = makeMatrixNL dims+#if MIN_VERSION_template_haskell(2,11,0)+      constrArg = bangType (bang noSourceUnpackedness noSourceStrictness) (conT _valueN)+#else+      constrArg = strictType notStrict (conT _valueN)+#endif+      definers = [ defineLift+                 , defineLift2+                 , defineFromList+                 , defineToList+                 , deriveShow+                 , deriveArbitrary+                 ]+      definers' = [ defineMatrixMulVector+                  , defineVectorMulMatrix+                  , defineDiagMulMatrix+                  , defineMatrixMulDiag+                  , defineVectorOuterProduct+                  ]+  impls <- concat <$> mapM (\f -> f matrixN vi len) definers+  impls' <- concat <$> mapM (\f -> f vi dims) definers'+#if MIN_VERSION_template_haskell(2,12,0)+  matrixD <- dataD (cxt []) matrixN [] Nothing [normalC matrixN (replicate len constrArg)] []+#elif MIN_VERSION_template_haskell(2,11,0)+  matrixD <- dataD (cxt []) matrixN [] Nothing [normalC matrixN (replicate len constrArg)] (mapM conT [])+#else+  matrixD <- dataD (cxt []) matrixN [] [normalC matrixN (replicate len constrArg)] []+#endif+  return $ matrixD : impls ++ impls'++defineMatrixMul :: ValueInfo -> (Int, Int, Int) -> DecsQ+defineMatrixMul vi@ValueInfo{..} (left, inner, right) = do+  let (matN, len) = makeMatrixNL (left, inner)+      (matN', len') = makeMatrixNL (inner, right)+      (matN'', _) = makeMatrixNL (left, right)+  (matP, elemVars) <- conPE matN "a" len+  (matP', elemVars') <- conPE matN "b" len'+  let rows = chunks inner elemVars+      cols = stripes right elemVars'+      dotEs = do+        row <- rows+        col <- cols+        return $ dotE vi row col+      resultE = appsE (conE matN'' : dotEs)+      mulN = mkName $ "mul" ++ show left ++ "x" ++ show inner ++ "x" ++ show right+      mulC = simpleClause [matP, matP'] resultE+      mulT = arrowsT [matT, matT', matT'']+      matT = conT matN+      matT' = conT matN'+      matT'' = conT matN''+  inlSigDef mulN mulT [mulC]++defineMatrixMulVector :: ValueInfo -> (Int, Int) -> DecsQ+defineMatrixMulVector vi@ValueInfo{..} dims@(left, inner) = do+  let (matN, len) = makeMatrixNL dims+      vecN = makeVectorN inner+      vecN' = makeVectorN left+  (matP, elemVars) <- conPE matN "a" len+  (vecP, col) <- conPE vecN "b" inner+  let rows = chunks inner elemVars+      dotEs = do+        row <- rows+        return $ dotE vi row col+      resultE = appsE (conE vecN' : dotEs)+      mulN = mkName $ "mul" ++ show left ++ "x" ++ show inner ++ "c"+      mulC = simpleClause [matP, vecP] resultE+      mulT = arrowsT [matT, vecT, vecT']+      matT = conT matN+      vecT = conT vecN+      vecT' = conT vecN'+  inlSigDef mulN mulT [mulC]++defineVectorMulMatrix :: ValueInfo -> (Int, Int) -> DecsQ+defineVectorMulMatrix vi@ValueInfo{..} dims@(inner, right) = do+  let vecN = makeVectorN inner+      (matN, len) = makeMatrixNL dims+      vecN' = makeVectorN right+  (vecP, row) <- conPE vecN "a" inner+  (matP, elemVars) <- conPE matN "b" len+  let cols = stripes right elemVars+      dotEs = do+        col <- cols+        return $ dotE vi row col+      resultE = appsE (conE vecN' : dotEs)+      mulN = mkName $ "mulr" ++ show inner ++ "x" ++ show right+      mulC = simpleClause [vecP, matP] resultE+      mulT = arrowsT [vecT, matT, vecT']+      vecT = conT vecN+      matT = conT matN+      vecT' = conT vecN'+  inlSigDef mulN mulT [mulC]++defineDiagMulMatrix :: ValueInfo -> (Int, Int) -> DecsQ+defineDiagMulMatrix ValueInfo{..} dims@(inner, right) = do+  let vecN = makeVectorN inner+      (matN, len) = makeMatrixNL dims+  (vecP, diag) <- conPE vecN "a" inner+  (matP, elemVars) <- conPE matN "b" len+  let rows = chunks right elemVars+      rowE scalar = fmap (infixApp' (varE _valueMul) scalar)+      rowEs = zipWith rowE diag rows+      resultE = appsE (conE matN : concat rowEs)+      mulN = mkName $ "muld" ++ show inner ++ "x" ++ show right+      mulC = simpleClause [vecP, matP] resultE+      mulT = arrowsT [vecT, matT, matT]+      vecT = conT vecN+      matT = conT matN+  inlSigDef mulN mulT [mulC]++defineMatrixMulDiag :: ValueInfo -> (Int, Int) -> DecsQ+defineMatrixMulDiag ValueInfo{..} dims@(left, inner) = do+  let vecN = makeVectorN inner+      (matN, len) = makeMatrixNL dims+  (matP, elemVars) <- conPE matN "a" len+  (vecP, diag) <- conPE vecN "b" inner+  let cols = stripes inner elemVars+      colE scalar = fmap (infixApp' (varE _valueMul) scalar)+      colEs = zipWith colE diag cols+      resultE = appsE (conE matN : concat colEs)+      mulN = mkName $ "mul" ++ show left ++ "x" ++ show inner ++ "d"+      mulC = simpleClause [matP, vecP] resultE+      mulT = arrowsT [matT, vecT, matT]+      vecT = conT vecN+      matT = conT matN+  inlSigDef mulN mulT [mulC]++defineVectorOuterProduct :: ValueInfo -> (Int, Int) -> DecsQ+defineVectorOuterProduct ValueInfo{..} dims@(left, right) = do+  let vecN = makeVectorN left+      vecN' = makeVectorN right+      (matN, _) = makeMatrixNL dims+  (vecP, elemVars) <- conPE vecN "a" left+  (vecP', elemVars') <- conPE vecN' "b" right+  let elemEs = do+        x <- elemVars+        y <- elemVars'+        return $ infixApp' (varE _valueMul) x y+      resultE = appsE (conE matN : elemEs)+      mulN = mkName $ "mulT" ++ show left ++ "x" ++ show right+      mulC = simpleClause [vecP, vecP'] resultE+      mulT = arrowsT [vecT, vecT', matT]+      vecT = conT vecN+      vecT' = conT vecN'+      matT = conT matN+  inlSigDef mulN mulT [mulC]++chunks :: Int -> [a] -> [[a]]+chunks _ [] = []+chunks chunkSize xs =+  let (front, back) = splitAt chunkSize xs in front:chunks chunkSize back++stripes :: Int -> [a] -> [[a]]+stripes chunkSize = raggedZip . chunks chunkSize++unevenZip :: Monoid a => [a] -> [a] -> [a]+unevenZip [] [] = []+unevenZip [] (x:xs) = x : unevenZip [] xs+unevenZip (x:xs) [] = x : unevenZip xs []+unevenZip (x:xs) (y:ys) = (x <> y) : unevenZip xs ys++raggedZip :: [[a]] -> [[a]]+raggedZip = foldr (unevenZip . fmap pure) []
+ src/Shapes/Linear/Template.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module Shapes.Linear.Template where++import Test.QuickCheck.Arbitrary++import Control.Monad+import Language.Haskell.TH++-- TODO: Use a wrapper type to hold multiple sizes of vector?++data ValueInfo = ValueInfo { _valueN :: Name+                           , _valueWrap :: Name+                           , _valueBoxed :: Name+                           , _valueAdd :: Name+                           , _valueSub :: Name+                           , _valueMul :: Name+                           , _valueDiv :: Name+                           , _valueNeg :: Name+                           , _valueEq :: Name+                           , _valueNeq :: Name+                           , _valueLeq :: Name+                           , _valueGeq :: Name+                           , _valueGt :: Name+                           , _valueLt :: Name+                           }++makeInlineD :: Name -> DecQ+makeInlineD n = pragInlD n Inline FunLike AllPhases++makeVectorN :: Int -> Name+makeVectorN dim = mkName $ "V" ++ show dim++makeVectorType :: ValueInfo -> Int -> DecsQ+makeVectorType vi@ValueInfo{..} dim = do+#if MIN_VERSION_template_haskell(2,11,0)+  notStrict_ <- bang noSourceUnpackedness noSourceStrictness+#else+  notStrict_ <- notStrict+#endif+  let vectorN = makeVectorN dim+      constrArg = (notStrict_, ConT _valueN)+      definers = [ defineLift+                 , defineLift2+                 , defineDot+                 , defineFromList+                 , defineToList+                 , deriveShow+                 , deriveArbitrary+                 ]+  impls <- concat <$> mapM (\f -> f vectorN vi dim) definers+#if MIN_VERSION_template_haskell(2,11,0)+  let decs = DataD [] vectorN [] Nothing [NormalC vectorN (replicate dim constrArg)] [] : impls+#else+  let decs = DataD [] vectorN [] [NormalC vectorN (replicate dim constrArg)] [] : impls+#endif+  return decs++deriveShow :: Name -> ValueInfo -> Int -> DecsQ+deriveShow vectorN ValueInfo{..} dim = do+  (pat, vars) <- conPE vectorN "a" dim+  let f [] = [| "" |]+      f (v:vs) = [| " " ++ show $(appE (conE _valueWrap) v) ++ $(f vs) |]+      constructorShown = nameBase vectorN+      showClause = clause [pat] (normalB [| constructorShown ++ $(f vars) |]) []+  return <$> instanceD (cxt []) (appT (conT ''Show) (conT vectorN)) [funD 'show [showClause]]++dimE :: Int -> ExpQ+dimE = litE . integerL . fromIntegral++deriveArbitrary :: Name -> ValueInfo -> Int -> DecsQ+deriveArbitrary vectorN ValueInfo{..} dim = do+  let arbClause = clause [] (normalB $ infixApp (fromListE vectorN) (varE '(<$>)) arbList) []+      arbList = [| replicateM $(dimE dim) arbitrary |]+  return <$> instanceD (cxt []) (appT (conT ''Arbitrary) (conT vectorN)) [funD 'arbitrary [arbClause]]++defineLift :: Name -> ValueInfo -> Int -> DecsQ+defineLift vectorN ValueInfo{..} dim = do+  (funcP, funcV) <- newPE "f"+  (vecP, elemVars) <- conPE vectorN "a" dim+  let liftClause = clause [funcP, vecP] liftBody []+      f = appE funcV+      liftBody = normalB $ appsE (conE vectorN : fmap f elemVars)+      liftName = mkName $ "lift" ++ nameBase vectorN+      valueT = conT _valueN+      vectorT = conT vectorN+      liftType = arrowsT [arrowsT [valueT, valueT], vectorT, vectorT]+  inlSigDef liftName liftType [liftClause]++defineLift2 :: Name -> ValueInfo -> Int -> DecsQ+defineLift2 vectorN ValueInfo{..} dim = do+  (funcP, funcV) <- newPE "f"+  (vecP, elemVars) <- conPE vectorN "a" dim+  (vecP', elemVars') <- conPE vectorN "b" dim+  let pairVars = zip elemVars elemVars'+      liftClause = clause [funcP, vecP, vecP'] liftBody []+      f (x, y) = appsE [funcV, x, y]+      liftBody = normalB $ appsE (conE vectorN : fmap f pairVars)+      liftName = mkName $ "lift2" ++ nameBase vectorN+      valueT = conT _valueN+      vectorT = conT vectorN+      liftType = arrowsT [arrowsT [valueT, valueT, valueT], vectorT, vectorT, vectorT]+  inlSigDef liftName liftType [liftClause]++dotE :: ValueInfo -> [ExpQ] -> [ExpQ] -> ExpQ+dotE ValueInfo{..} row col = foldl1 (infixApp' $ varE _valueAdd) products+  where products = uncurry (infixApp' $ varE _valueMul) <$> zip row col++defineDot :: Name -> ValueInfo -> Int -> DecsQ+defineDot vectorN vi@ValueInfo{..} dim = do+  (vecP, elemVars) <- conPE vectorN "a" dim+  (vecP', elemVars') <- conPE vectorN "b" dim+  let dotClause = clause [vecP, vecP'] (normalB $ dotE vi elemVars elemVars') []+      dotName = mkName $ "dot" ++ nameBase vectorN+      valueT = conT _valueN+      vectorT = conT vectorN+      dotType = arrowsT [vectorT, vectorT, valueT]+  inlSigDef dotName dotType [dotClause]++defineJoinSplit :: ValueInfo -> (Int, Int) -> DecsQ+defineJoinSplit ValueInfo{..} (left, right) = do+  let vecN = makeVectorN left+      vecN' = makeVectorN right+      vecN'' = makeVectorN (left + right)+  (vecP, elemVs) <- conPE vecN "a" left+  (vecP', elemVs') <- conPE vecN' "b" right+  (vecP'', elemVs'') <- conPE vecN'' "c" (left + right)+  let joinE = appsE (conE vecN'' : elemVs ++ elemVs')+      joinC = simpleClause [vecP, vecP'] joinE+      joinN = mkName $ "join" ++ show left ++ "v" ++ show right+      joinT = arrowsT [vecT, vecT', vecT'']+      (leftVs, rightVs) = splitAt left elemVs''+      splitE = tupE [ appsE $ conE vecN : leftVs+                    , appsE $ conE vecN' : rightVs+                    ]+      splitC = simpleClause [vecP''] splitE+      splitN = mkName $ "split" ++ show left ++ "v" ++ show right+      splitT = arrowsT [vecT'', tupT [vecT, vecT']]+      vecT = conT vecN+      vecT' = conT vecN'+      vecT'' = conT vecN''+  joinI <- inlSigDef joinN joinT [joinC]+  splitI <- inlSigDef splitN splitT [splitC]+  return $ joinI ++ splitI++fromListN :: Name -> Name+fromListN = mkName . ("fromList" ++) . nameBase++fromListE :: Name -> ExpQ+fromListE = varE . fromListN++defineFromList :: Name -> ValueInfo -> Int -> DecsQ+defineFromList vectorN ValueInfo{..} dim = do+  (pats, vars) <- genPEWith "x" dim (conP _valueWrap . return . varP) varE+  let listPat = listP pats+      vecE = appsE (conE vectorN : vars)+      fromListClause0 = clause [listPat] (normalB vecE) []+      fromListClause1 = clause [wildP] (normalB [| error "wrong number of elements" |]) []+      vectorT = conT vectorN+      argT = appT listT (conT _valueBoxed)+      fromListType = arrowsT [argT, vectorT]+  inlSigDef (fromListN vectorN) fromListType [fromListClause0, fromListClause1]++defineToList :: Name -> ValueInfo -> Int -> DecsQ+defineToList vectorN ValueInfo{..} dim = do+  (vecP, elemVars) <- conPE vectorN "a" dim+  let boxedElemVars = fmap (appE $ conE _valueWrap) elemVars+      toListClause = clause [vecP] (normalB $ listE boxedElemVars) []+      toListName = mkName $ "toList" ++ nameBase vectorN+      vectorT = conT vectorN+      resultT = appT listT (conT _valueBoxed)+      toListType = arrowsT [vectorT, resultT]+  inlSigDef toListName toListType [toListClause]++infixApp' :: ExpQ -> ExpQ -> ExpQ -> ExpQ+infixApp' = flip infixApp++inlSigDef :: Name -> TypeQ -> [ClauseQ] -> DecsQ+inlSigDef funN funT funCs = do+  sigdef <- funSigDef funN funT funCs+  inl <- makeInlineD funN+  return $ sigdef ++ [inl]++funSigDef :: Name -> TypeQ -> [ClauseQ] -> DecsQ+funSigDef funN funT funCs = do+  funSig <- sigD funN funT+  funDef <- funD funN funCs+  return [funSig, funDef]++tupT :: [TypeQ] -> TypeQ+tupT ts = foldl appT (tupleT $ length ts) ts++arrowsT :: [TypeQ] -> TypeQ+arrowsT [] = error "can't have no type"+arrowsT [t] = t+arrowsT (t:ts) = appT (appT arrowT t) $ arrowsT ts++newPE :: String -> Q (PatQ, ExpQ)+newPE x = do+  x' <- newName x+  return (varP x', varE x')++conPE :: Name -> String -> Int -> Q (PatQ, [ExpQ])+conPE conN x dim = do+  (pats, vars) <- genPE x dim+  return (conP conN pats, vars)++genPEWith :: String -> Int -> (Name -> PatQ) -> (Name -> ExpQ) -> Q ([PatQ], [ExpQ])+genPEWith x n mkP mkE = do+  ids <- replicateM n (newName x)+  return (fmap mkP ids, fmap mkE ids)++genPE :: String -> Int -> Q ([PatQ], [ExpQ])+genPE x n = genPEWith x n varP varE++simpleClause :: [PatQ] -> ExpQ -> ClauseQ+simpleClause ps e = clause ps (normalB e) []
+ src/Shapes/Linear/ValueInfos.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}++module Shapes.Linear.ValueInfos where++import GHC.Prim+import GHC.Types (Double(..))++import Shapes.Linear.Template (ValueInfo(..))++doubleInfo :: ValueInfo+doubleInfo = ValueInfo { _valueN = ''Double#+                       , _valueWrap = 'D#+                       , _valueBoxed = ''Double+                       , _valueAdd = '(+##)+                       , _valueSub = '(-##)+                       , _valueMul = '(*##)+                       , _valueDiv = '(/##)+                       , _valueNeg = 'negateDouble#+                       , _valueEq = '(==##)+                       , _valueNeq = '(/=##)+                       , _valueLeq = '(<=##)+                       , _valueGeq = '(>=##)+                       , _valueGt = '(>##)+                       , _valueLt = '(<##)+                       }
+ test/Shapes/Linear/TemplateSpec.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MagicHash #-}++module Shapes.Linear.TemplateSpec where++import Test.Hspec+import Test.QuickCheck++import GHC.Types (Double(..))++import Shapes.Linear.Template (makeVectorType, defineJoinSplit)+import Shapes.Linear.MatrixTemplate (makeMatrixType, defineMatrixMul)+import Shapes.Linear.ValueInfos (doubleInfo)++import qualified Linear.Metric as L+import qualified Linear.V2 as L+import qualified Linear.Matrix as L++$(makeVectorType doubleInfo 2)+$(makeMatrixType doubleInfo (2, 2))+$(defineMatrixMul doubleInfo (2, 2, 2))+$(makeVectorType doubleInfo 4)+$(defineJoinSplit doubleInfo (2, 2))++spec :: Spec+spec = do+  it "toListV2 fromListV2 == id" $ property $+    \xy -> let xy' = pairToList xy in toListV2 (fromListV2 xy') == xy'+  it "dotV2 == L.dot" $ property $+    \(v1, v2) -> D# (v1 `dotV2` v2) == toLV2 v1 `L.dot` toLV2 v2+  it "show" $ show (V2 0.0## 1.0##) `shouldBe` "V2 0.0 1.0"+  it "2x2 * 2x2" $ property $+    \(m1, m2) -> toListM2x2 (m1 `mul2x2x2` m2) == toListLM22 (toLM22 m1 L.!*! toLM22 m2)+  it "split 4 into 2+2 and join back into 4" $ property $+    \v -> (toListV4 . uncurry join2v2 . split2v2 $ v) == toListV4 v++pairToList :: (a, a) -> [a]+pairToList (x, y) = [x, y]++toLV2 :: V2 -> L.V2 Double+toLV2 = (\[x, y] -> L.V2 x y) . toListV2++toLM22 :: M2x2 -> L.M22 Double+toLM22 = (\[a, b, c, d] -> L.V2 (L.V2 a b) (L.V2 c d)) . toListM2x2++toListLV2 :: L.V2 Double -> [Double]+toListLV2 (L.V2 x y) = [x, y]++toListLM22 :: L.M22 Double -> [Double]+toListLM22 (L.V2 (L.V2 a b) (L.V2 c d)) = [a, b, c, d]
+ test/Spec.hs view
@@ -0,0 +1,9 @@+module Main where++import Test.Hspec++import qualified Shapes.Linear.TemplateSpec++main :: IO ()+main = hspec $ do+  describe "TemplateSpec" Shapes.Linear.TemplateSpec.spec