Commits

Thijs Alkemade committed e706872 Merge

Merged.

Comments (0)

Files changed (3)

 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 -- |Module defining values with dimensions and units, and mathematical operations on those.
 module UnitTyped (
 import Data.Monoid
 import Data.Foldable
 import Data.Traversable
+import qualified Data.Vector.Generic as VG
+import qualified Data.Vector.Generic.Mutable as VGM
+import qualified Data.Vector.Unboxed as VU
 
 import qualified Data.Map as M
 import Data.Typeable
 instance (MapNeg map2 map2', MapMerge map1 map2' sum, MapNull sum b) => MapEq map1 map2 b
 
 -- |A value tagged with its dimension a and unit b.
-data Value (a :: [(*, Number)]) (b :: [(*, Number)]) f = Value f
+newtype Value (a :: [(*, Number)]) (b :: [(*, Number)]) f = Value f
 -- |Used as fake argument for the 'Convertible' class.
 data ValueProxy (a :: [(*, Number)]) b
 -- |Used as fake argument for the 'Convertible'' class.
     toEnum = mkVal . fromInteger . toInteger
     fromEnum = fromInteger . round . val
 
+deriving instance (Eq f) => Eq (Value a b f)
+
 instance Functor (Value a b) where
     fmap f = mkVal . f . val
 
 instance Traversable (Value a b) where
     traverse f x = mkVal <$> (f $ val x)
 
+deriving instance VG.Vector VU.Vector f => VG.Vector VU.Vector (Value a b f) 
+deriving instance VGM.MVector VU.MVector f => VGM.MVector VU.MVector (Value a b f) 
+deriving instance VU.Unbox f => VU.Unbox (Value a b f) 
+
+    
+
 -- |A wrapped value with scalar value 1.
 one :: (Fractional f, Convertible' a b) => Value a b f
 one = mkVal 1

tests/TestUnbox.hs

+{-# LANGUAGE KindSignatures, DataKinds, MultiParamTypeClasses, FunctionalDependencies, ExistentialQuantification, TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Main where
+
+import UnitTyped
+import UnitTyped.SI
+import UnitTyped.SI.Derived
+import UnitTyped.SI.Derived.Length
+import UnitTyped.SI.Derived.Mass
+import UnitTyped.SI.Derived.Count
+import UnitTyped.SI.Derived.Time
+import UnitTyped.SI.Meta
+import UnitTyped.SI.Constants
+import UnitTyped.Bytes
+import UnitTyped.NoPrelude
+import UnitTyped.SI.Show
+
+import qualified Prelude
+import Control.Monad (foldM, unless)
+import Data.Ratio
+import qualified Data.Array.Repa as Repa
+import qualified Data.Array.Repa.Eval as Repa
+import qualified Data.Vector as V
+import qualified Data.Vector.Unboxed as VU
+import Prelude (zip, show, (++), IO, Bool(..), Integer, Double, return, error, putStrLn, fromIntegral)
+import System.Exit (exitFailure)
+
+x1 :: Value LengthDimension (U Meter) Rational
+x1 = 1 *| meter
+
+t1 = x1 == 72 *| centi meter + 280 *| mili meter
+
+
+type DoubleMeter = Value LengthDimension (U Meter) Double
+
+vx2 :: V.Vector (Value LengthDimension (U Meter) Rational)
+vx2 = V.generate 100 (\i -> fromIntegral i *| meter)
+
+vux2d :: VU.Vector DoubleMeter
+vux2d = VU.generate 100 (\i -> fromIntegral i *| meter)
+
+rux2d :: Repa.Array Repa.U Repa.DIM1 DoubleMeter
+rux2d = Repa.fromUnboxed (Repa.ix1 100) vux2d
+
+t2 = (Repa.foldAllS (|+|) (0*| meter) rux2d) Prelude.== 4950 *| meter
+
+deriving instance Repa.Elt f => Repa.Elt (Value a b f)
+
+runTest :: Bool -> (Bool, Integer) -> IO Bool
+runTest b (True, _) = return b
+runTest b (False, i) = do { putStrLn ("Test " ++ show i ++ " failed.")
+                                                  ; return False
+                                                  }
+
+main = do { b <- foldM runTest True (zip [t1, t2] [1..])
+                  ; unless b exitFailure
+                  }
   tag: 0.2
 
 library
-  build-depends:   base >= 4.6 && < 4.7, time, old-locale, containers
+  build-depends:   base >= 4.6 && < 4.7, vector >= 0.10, time, old-locale, containers
   extensions:      FlexibleInstances
                    UndecidableInstances
                    FunctionalDependencies
     type:          exitcode-stdio-1.0
     main-is:       tests/TestSI.hs
     build-depends: base >= 4.6 && < 4.7, unittyped
+
+Test-Suite test-unbox
+    type:          exitcode-stdio-1.0
+    main-is:       tests/TestUnbox.hs
+    build-depends: base >= 4.6 && < 4.7, unittyped, vector >= 0.10, repa >= 3.2.3