Added package flags for optional instances

.travis.yml

@@ -20,6 +20,11 @@ env:
 - ARGS="--resolver lts-2 --stack-yaml stack.lts2.yaml"
 - ARGS="--resolver lts-3"
 - ARGS="--resolver lts-5"
+- ARGS="--resolver lts-5" FLAGS="--flag dimensional:aeson"
+- ARGS="--resolver lts-5" FLAGS="--flag dimensional:binary"
+- ARGS="--resolver lts-5" FLAGS="--flag dimensional:cereal"
+- ARGS="--resolver lts-5" FLAGS="--flag dimensional:vector-space"
+- ARGS="--resolver lts-5" FLAGS="--flag dimensional:aeson --flag dimensional:binary --flag dimensional:cereal --flag dimensional:vector-space"
 
 before_install:
 # Download and unpack the stack executable
@@ -34,7 +39,7 @@ before_install:
 # This line does all of the work: build the library,
 # executables, and test suites, and runs the test suites. --no-terminal works
 # around some quirks in Travis's terminal implementation.
-script: stack $ARGS --no-terminal test --haddock --bench
+script: stack $ARGS --no-terminal test $FLAGS --haddock --bench
 
 # Caching so the next build will be fast too.
 cache:

CHANGELOG.md

@@ -18,6 +18,9 @@ vNext
   `(Num a, Foldable f) => f (Dimensional v d a) -> Dimensionless a)` to
   `(Num a, Foldable f) => f b -> Dimensionless a`. This provides a weaker constraint on the type `a`
   and may result in ambiguous types in code that depends on the former less general type.
+* Added package flags `aeson`, `binary`, `cereal`, and `vector-space` enabling
+  optional dependencies on the packages of the same names to provide instances of widely
+  used classes from those packages.
 * Added `Data`, `Generic`, `Typeable` and `NFData` instances for many ancillary types.
 * Added `unQuantity` to the Coercion module to ease unwrapping without
   introducing ambiguous type variables.

README.md

@@ -63,6 +63,18 @@ main = do
          putStrLn $ "The journey requires " ++ show wholeSeconds ++ " seconds, rounded up to the nearest second."
 ```
 
+## Package Flags
+
+Package flags are available which enable us to provide instances for Quantity that are useful to interoperate with various popular packages without burdening all users with those
+dependencies or creating orphan instances.
+
+To install with `ToJSON` and `FromJSON` instances for `Quantity`, use:
+
+`cabal install dimensional -f aeson`
+
+Similarly the `binary`, `cereal`, and `vector-space` flags enable appropriate
+instances for use with the packages of the same names.
+
 ## Contributing
 
 For project information (issues, updates, wiki, examples) see:

dimensional.cabal

@@ -37,6 +37,26 @@ extra-source-files:  README.md,
                      examples/ReadmeExample.hs,
                      examples/GM.lhs
 
+flag aeson
+  description: Provide instances for use with the aeson package.
+  default:     False
+  manual:      True
+
+flag binary
+  description: Provide instances for use with the binary package.
+  default:     False
+  manual:      True
+
+flag cereal
+  description: Provide instances for use with the cereal package.
+  default:     False
+  manual:      True
+
+flag vector-space
+  description: Provide instances for use with the vector-space package.
+  default:     False
+  manual:      True
+
 source-repository head
   type:     git
   location: https://github.com/bjornbm/dimensional/
@@ -68,6 +88,22 @@ library
   other-modules:       Numeric.Units.Dimensional.Internal,
                        Numeric.Units.Dimensional.UnitNames.Internal
 
+  if flag(aeson)
+    build-depends:     aeson >= 0.9 && < 1
+    cpp-options:       -DUSE_AESON
+
+  if flag(binary)
+    build-depends:     binary >= 0.7 && < 1
+    cpp-options:       -DUSE_BINARY
+
+  if flag(cereal)
+    build-depends:     cereal >= 0.5 && <1
+    cpp-options:       -DUSE_CEREAL
+
+  if flag(vector-space)
+    build-depends:     vector-space >= 0.10 && < 1
+    cpp-options:       -DUSE_VECTOR_SPACE
+
 test-suite tests
   type:                exitcode-stdio-1.0
   main-is:             Test.hs

src/Numeric/Units/Dimensional.hs

@@ -647,7 +647,8 @@ tau = _2 * pi
 We intentionally decline to provide a 'Functor' instance for 'Dimensional' because its use breaks the
 abstraction of physical dimensions.
 
-If you feel your work requires this instance, it is provided as an orphan in "Numeric.Units.Dimensional.Functor".
+If you feel your work requires this instance, it is provided by enabling the `functor` package
+flag when installing the package.
 
 -}
 

src/Numeric/Units/Dimensional/Dimensions/TermLevel.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_HADDOCK not-home, show-extensions #-}
 
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -40,6 +41,18 @@ import GHC.Generics
 import Prelude (id, all, fst, snd, fmap, otherwise, divMod, ($), (+), (-), (.), (&&), Int, Show, Eq(..), Ord(..), Maybe(..))
 import qualified Prelude as P
 
+-- Optional imports when certain package flags are enabled
+#if USE_AESON
+import qualified Data.Aeson
+import qualified Data.Aeson.Types
+#endif
+#if USE_BINARY
+import qualified Data.Binary
+#endif
+#if USE_CEREAL
+import qualified Data.Serialize
+#endif
+
 -- $setup
 -- >>> import Prelude (negate)
 -- >>> import Control.Applicative
@@ -60,6 +73,23 @@ instance Monoid Dimension' where
   mempty = dOne
   mappend = (*)
 
+#if USE_AESON
+-- This instance only needs a body because an incorrect MINIMAL pragma in aeson-0.10 leads to
+-- a warning if you omit it.
+instance Data.Aeson.ToJSON Dimension' where
+  toJSON = Data.Aeson.genericToJSON Data.Aeson.Types.defaultOptions
+
+instance Data.Aeson.FromJSON Dimension'
+#endif
+
+#if USE_BINARY
+instance Data.Binary.Binary Dimension'
+#endif
+
+#if USE_CEREAL
+instance Data.Serialize.Serialize Dimension'
+#endif
+
 -- | Dimensional values, or those that are only possibly dimensional, inhabit this class,
 -- which allows access to a term-level representation of their dimension.
 class HasDynamicDimension a where

src/Numeric/Units/Dimensional/Dynamic.hs

@@ -9,13 +9,15 @@
 Defines types for manipulation of units and quantities without phantom types for their dimensions.
 -}
 
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Numeric.Units.Dimensional.Dynamic
@@ -53,6 +55,19 @@ import qualified Numeric.Units.Dimensional.UnitNames as N
 import Numeric.Units.Dimensional.Dimensions.TermLevel (HasDynamicDimension(..))
 import qualified Numeric.Units.Dimensional.Dimensions.TermLevel as D
 
+-- Optional imports when certain package flags are enabled
+#if USE_AESON
+import qualified Data.Aeson
+import qualified Data.Aeson.Types
+import qualified Data.Monoid
+#endif
+#if USE_BINARY
+import qualified Data.Binary
+#endif
+#if USE_CEREAL
+import qualified Data.Serialize
+#endif
+
 -- | The class of types that can be used to model 'Quantity's that are certain to have a value with
 -- some dimension.
 class Demoteable (q :: * -> *) where
@@ -120,6 +135,24 @@ instance Num a => Monoid (AnyQuantity a) where
   mempty = demoteQuantity (1 Dim.*~ one)
   mappend (AnyQuantity d1 a1) (AnyQuantity d2 a2) = AnyQuantity (d1 D.* d2) (a1 P.* a2)
 
+#if USE_AESON
+instance (Data.Aeson.ToJSON a) => Data.Aeson.ToJSON (AnyQuantity a) where
+  toJSON (AnyQuantity d a) = Data.Aeson.object ["dimension" Data.Aeson..= d, "value" Data.Aeson..= a]
+
+instance (Data.Aeson.FromJSON a) => Data.Aeson.FromJSON (AnyQuantity a) where
+  parseJSON (Data.Aeson.Object v) = AnyQuantity P.<$>
+                                    v Data.Aeson..: "dimension" P.<*>
+                                    v Data.Aeson..: "value"
+  parseJSON _ = Data.Monoid.mempty
+#endif
+
+#if USE_BINARY
+instance (Data.Binary.Binary a) => Data.Binary.Binary (AnyQuantity a)
+#endif
+
+#if USE_CEREAL
+instance (Data.Serialize.Serialize a) => Data.Serialize.Serialize (AnyQuantity a)
+#endif
 
 -- | Possibly a 'Quantity' whose 'Dimension' is only known dynamically.
 --
@@ -179,6 +212,23 @@ instance Num a => Monoid (DynQuantity a) where
   mempty = demoteQuantity (1 Dim.*~ one)
   mappend = (P.*)
 
+#if USE_AESON
+-- This instance only needs a body because an incorrect MINIMAL pragma in aeson-0.10 leads to
+-- a warning if you omit it.
+instance (Data.Aeson.ToJSON a) => Data.Aeson.ToJSON (DynQuantity a) where
+  toJSON = Data.Aeson.genericToJSON Data.Aeson.Types.defaultOptions
+
+instance (Data.Aeson.FromJSON a) => Data.Aeson.FromJSON (DynQuantity a)
+#endif
+
+#if USE_BINARY
+instance (Data.Binary.Binary a) => Data.Binary.Binary (DynQuantity a)
+#endif
+
+#if USE_CEREAL
+instance (Data.Serialize.Serialize a) => Data.Serialize.Serialize (DynQuantity a)
+#endif
+
 -- Lifts a function which is only valid on dimensionless quantities into a function on DynQuantitys.
 liftDimensionless :: (a -> a) -> DynQuantity a -> DynQuantity a
 liftDimensionless = liftDQ (matching D.dOne)

src/Numeric/Units/Dimensional/Internal.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE MultiParamTypeClasses #-} -- for Vector instances only
 {-# LANGUAGE RankNTypes #-}
@@ -46,9 +47,25 @@ import qualified Data.Vector.Unboxed.Base as U
 import Prelude
   ( Show, Eq(..), Ord, Bounded(..), Num, Fractional, Functor
   , String, Maybe(..)
-  , (.), ($), (++), (+), (/)
+  , (.), ($), (++)
   , show, otherwise, undefined, error, fmap
   )
+import qualified Prelude as P
+
+-- Optional imports when certain package flags are enabled
+#if USE_AESON
+import qualified Data.Aeson
+#endif
+#if USE_BINARY
+import qualified Data.Binary
+#endif
+#if USE_CEREAL
+import qualified Data.Serialize
+#endif
+#if USE_VECTOR_SPACE
+import qualified Data.AdditiveGroup
+import qualified Data.VectorSpace
+#endif
 
 -- | A unit of measurement.
 type Unit (m :: Metricality) = Dimensional ('DUnit m)
@@ -99,6 +116,37 @@ instance (Typeable m) => KnownVariant ('DUnit m) where
   injectValue _        _ = error "Shouldn't be reachable. Needed to name a quantity."
   dmap f (Unit n e x) = Unit n e (f x)
 
+instance Functor (Quantity DOne) where
+  fmap = dmap
+
+#if USE_AESON
+deriving instance (Data.Aeson.ToJSON a) => Data.Aeson.ToJSON (Quantity d a)
+
+deriving instance (Data.Aeson.FromJSON a) => Data.Aeson.FromJSON (Quantity d a)
+#endif
+
+#if USE_BINARY
+deriving instance (Data.Binary.Binary a) => Data.Binary.Binary (Quantity d a)
+#endif
+
+#if USE_CEREAL
+deriving instance (Data.Serialize.Serialize a) => Data.Serialize.Serialize (Quantity d a)
+#endif
+
+#if USE_VECTOR_SPACE
+instance (Num a) => Data.AdditiveGroup.AdditiveGroup (Quantity d a) where
+  zeroV = mempty
+  (^+^) = mappend
+  negateV = liftQ P.negate
+
+instance (Num a) => Data.VectorSpace.VectorSpace (Quantity d a) where
+  type Scalar (Quantity d a) = Quantity DOne a
+  (*^) = liftQ2 (P.*)
+
+instance (Num a) => Data.VectorSpace.InnerSpace (Quantity DOne a) where
+  (<.>) = liftQ2 (P.*)
+#endif
+
 -- GHC is somewhat unclear about why, but it won't derive this instance, so we give it explicitly.
 instance (Bounded a) => Bounded (Quantity d a) where
   minBound = Quantity minBound
@@ -115,19 +163,7 @@ we will define a monoid instance that adds.
 -- | 'Quantity's of a given 'Dimension' form a 'Monoid' under addition.
 instance (Num a) => Monoid (Quantity d a) where
   mempty = Quantity 0
-  mappend = liftQ2 (+)
-
-{-
-
-= Dimensionless =
-
-For dimensionless quantities pretty much any operation is applicable.
-We provide this freedom by making 'Dimensionless' an instance of
-'Functor'.
--}
-
-instance Functor (Quantity DOne) where
-  fmap = dmap
+  mappend = liftQ2 (P.+)
 
 instance (KnownDimension d) => HasDynamicDimension (Dimensional v d a) where
 
@@ -199,8 +235,8 @@ instance (KnownDimension d, Show a, Fractional a) => Show (Quantity d a) where
 
 -- | Shows the value of a 'Quantity' expressed in a specified 'Unit' of the same 'Dimension'.
 showIn :: (KnownDimension d, Show a, Fractional a) => Unit m d a -> Quantity d a -> String
-showIn (Unit n _ y) (Quantity x) | Name.weaken n == nOne = show (x / y)
-                                 | otherwise             = (show (x / y)) ++ " " ++ (show n)
+showIn (Unit n _ y) (Quantity x) | Name.weaken n == nOne = show (x P./ y)
+                                 | otherwise             = (show (x P./ y)) ++ " " ++ (show n)
 
 instance (KnownDimension d, Show a) => Show (Unit m d a) where
   show (Unit n e x) = "The unit " ++ show n ++ ", with value " ++ show e ++ " (or " ++ show x ++ ")"