diff --git a/.travis.yml b/.travis.yml index 1a29e716..ec2324aa 100644 --- a/.travis.yml +++ b/.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: diff --git a/CHANGELOG.md b/CHANGELOG.md index 317e1e7e..0ac63c43 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/README.md b/README.md index 86813104..e284040a 100644 --- a/README.md +++ b/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: diff --git a/dimensional.cabal b/dimensional.cabal index 5c5fc12d..65aa5aa2 100644 --- a/dimensional.cabal +++ b/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 diff --git a/src/Numeric/Units/Dimensional.hs b/src/Numeric/Units/Dimensional.hs index 438e6b76..b78545ff 100644 --- a/src/Numeric/Units/Dimensional.hs +++ b/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. -} diff --git a/src/Numeric/Units/Dimensional/Dimensions/TermLevel.hs b/src/Numeric/Units/Dimensional/Dimensions/TermLevel.hs index 6fc4653f..4eb1cf4b 100644 --- a/src/Numeric/Units/Dimensional/Dimensions/TermLevel.hs +++ b/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 diff --git a/src/Numeric/Units/Dimensional/Dynamic.hs b/src/Numeric/Units/Dimensional/Dynamic.hs index 55d65c2e..244bba5b 100644 --- a/src/Numeric/Units/Dimensional/Dynamic.hs +++ b/src/Numeric/Units/Dimensional/Dynamic.hs @@ -9,6 +9,7 @@ Defines types for manipulation of units and quantities without phantom types for their dimensions. -} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,6 +17,7 @@ Defines types for manipulation of units and quantities without phantom types for {-# 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) diff --git a/src/Numeric/Units/Dimensional/Internal.hs b/src/Numeric/Units/Dimensional/Internal.hs index 7dfa4b7a..97d0ba92 100644 --- a/src/Numeric/Units/Dimensional/Internal.hs +++ b/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 ++ ")"