mixed-types-num 0.4.1 → 0.5.0.0

raw patch · 25 files changed

+1033/−2234 lines, 25 filesdep +collect-errorsdep ~base

Dependencies added: collect-errors

Dependency ranges changed: base

Files

• README.md +20/−0
• changelog.md +4/−0
• mixed-types-num.cabal +83/−105
• src/Control/CollectErrors.hs +0/−452
• src/Data/Convertible/Base.hs +1/−0
• src/Data/Convertible/Instances/Num.hs +1/−0
• src/MixedTypesNumPrelude.hs +25/−45
• src/Numeric/CollectErrors.hs +0/−155
• src/Numeric/MixedTypes/AddSub.hs +26/−101
• src/Numeric/MixedTypes/Bool.hs +28/−144
• src/Numeric/MixedTypes/Complex.hs +4/−11
• src/Numeric/MixedTypes/Div.hs +208/−0
• src/Numeric/MixedTypes/Elementary.hs +49/−222
• src/Numeric/MixedTypes/Eq.hs +29/−69
• src/Numeric/MixedTypes/Field.hs +19/−295
• src/Numeric/MixedTypes/Kleenean.hs +87/−0
• src/Numeric/MixedTypes/Literals.hs +10/−4
• src/Numeric/MixedTypes/MinMaxAbs.hs +24/−112
• src/Numeric/MixedTypes/Ord.hs +29/−70
• src/Numeric/MixedTypes/Power.hs +232/−0
• src/Numeric/MixedTypes/Reduce.hs +44/−0
• src/Numeric/MixedTypes/Ring.hs +23/−336
• src/Numeric/MixedTypes/Round.hs +82/−108
• src/Utils/Test/EnforceRange.hs +3/−3
• test/Numeric/MixedTypes/RoundSpec.hs +2/−2

@@ -0,0 +1,20 @@+# mixed-types-num++This package provides a version of Prelude where+unary and binary operations such as `not`, `+`, `==`+have their result type derived from the parameter type(s)+and thus supports mixed-type arithmetic and comparisons.++Partial operations such as division, sqrt and power+do not throw exceptions even when errors such as division by zero+occur.  Instead, these errors are propagated bottom-up in+a bespoke error-accumulating functor from package collect-errors.++This library (as well as collect-errors) arose while developing the+[AERN2](https://github.com/michalkonecny/aern2) library for interval and exact real computation.+Certain aspects are specifically tailored for interval or exact real arithmetics,+including three-valued numerical comparisons and distinguishing potential and certain errors.++See module [MixedTypesNumPrelude](https://hackage.haskell.org/package/mixed-types-num/docs/MixedTypesNumPrelude.html) for further documentation.++[Hackage page including Haddock](https://hackage.haskell.org/package/mixed-types-num)

@@ -1,5 +1,9 @@ # mixed-types-num change log +* v 0.5.0 2021-04-13+  * use package collect-errors with a much simpler CN wrapper+  * replace Maybe Bool by Kleenean (a new type)+  * remove very long type constraints in specifications using PartialTypeSignatures * v 0.4.1 2021-01-21   * add hasErrorCE and hasErrorCN for testing if CE/CN values contain errors * v 0.4.0.2 2020-08-02

@@ -1,120 +1,98 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 49afc3a2c4bc0e8c25dc926023d6d0ae68fbdfc1880e1e70d30403256ddb1f11+ name:           mixed-types-num-version:        0.4.1-cabal-version:  >= 1.10-build-type:     Simple-homepage:       https://github.com/michalkonecny/mixed-types-num+version:        0.5.0.0+synopsis:       Alternative Prelude with numeric and logic expressions typed bottom-up+description:    Please see the README on GitHub at <https://github.com/michalkonecny/mixed-types-num#readme>+category:       Math+homepage:       https://github.com/michalkonecny/mixed-types-num#readme+bug-reports:    https://github.com/michalkonecny/mixed-types-num/issues author:         Michal Konecny-maintainer:     Michal Konecny <mikkonecny@gmail.com>-copyright:      (c) 2015-2021 Michal Konecny+maintainer:     mikkonecny@gmail.com+copyright:      2015-2021 Michal Konecny license:        BSD3 license-file:   LICENSE-extra-source-files:  changelog.md-stability:      experimental-category:       Math-synopsis:       Alternative Prelude with numeric and logic expressions typed bottom-up-Description:-    This package provides a version of Prelude where-    unary and binary operations such as @not@, @+@, @==@-    have their result type derived from the parameter type(s)-    and thus supports mixed-type arithmetic and comparisons.-    .-    Partial operations such as division, sqrt and power-    do not throw exceptions even when errors such as division by zero-    occur.  Instead, these errors are propagated bottom-up in-    a bespoke error-accumulating functor.-    .-    This library is a by-product of developing the-    <https://github.com/michalkonecny/aern2 AERN2> library for interval and exact real computation.-    Certain aspects are specifically tailored for interval or exact real arithmetics,-    including three-valued numerical comparisons-    and distinguishing potential and certain errors.-    .-    See module "MixedTypesNumPrelude" for further documentation.-    .-    /Ghci 8.0.* fails when loading this package/ due to ghc bug <https://ghc.haskell.org/trac/ghc/ticket/13385#ticket 13385>.-    This bug does not affect ghci 7.10.3 and ghci 8.2.* and above.+build-type:     Simple+extra-source-files:+    README.md+    changelog.md  source-repository head-  type:     git-  location: https://github.com/mikkonecny/mixed-types-num+  type: git+  location: https://github.com/michalkonecny/mixed-types-num  library-  hs-source-dirs:  src-  ghc-options:     -Wall -fno-warn-orphans-  default-language: Haskell2010-  default-extensions:-    RebindableSyntax,-    PostfixOperators,-    ScopedTypeVariables,-    TypeFamilies,-    TypeOperators,-    ConstraintKinds,-    DefaultSignatures,-    MultiParamTypeClasses,-    FlexibleContexts,-    FlexibleInstances,-    UndecidableInstances-  other-extensions:-    TemplateHaskell+  exposed-modules:+      Data.Convertible.Base+      Data.Convertible.Instances.Num+      Data.Convertible.Utils+      MixedTypesNumPrelude+      Numeric.MixedTypes.AddSub+      Numeric.MixedTypes.Bool+      Numeric.MixedTypes.Complex+      Numeric.MixedTypes.Div+      Numeric.MixedTypes.Elementary+      Numeric.MixedTypes.Eq+      Numeric.MixedTypes.Field+      Numeric.MixedTypes.Kleenean+      Numeric.MixedTypes.Literals+      Numeric.MixedTypes.MinMaxAbs+      Numeric.MixedTypes.Ord+      Numeric.MixedTypes.Power+      Numeric.MixedTypes.PreludeHiding+      Numeric.MixedTypes.Reduce+      Numeric.MixedTypes.Ring+      Numeric.MixedTypes.Round+      Utils.Test.EnforceRange+      Utils.TH.DeclForTypes+  other-modules:+      Paths_mixed_types_num+  hs-source-dirs:+      src+  default-extensions: RebindableSyntax PostfixOperators ScopedTypeVariables TypeFamilies TypeOperators ConstraintKinds DefaultSignatures MultiParamTypeClasses FlexibleContexts FlexibleInstances UndecidableInstances+  other-extensions: TemplateHaskell+  ghc-options: -Wall   build-depends:-    base >= 4.8 && < 5-    -- , convertible >= 1.1.1.0-    , template-haskell+      QuickCheck >=2.7+    , base >=4.7 && <5+    , collect-errors ==0.1.*+    , hspec >=2.1+    , hspec-smallcheck >=0.3     , mtl-    , hspec >= 2.1-    , hspec-smallcheck >= 0.3-    , smallcheck >= 1.1-    , QuickCheck >= 2.7-  exposed-modules:-    Utils.TH.DeclForTypes-    Utils.Test.EnforceRange-    Data.Convertible.Base-    Data.Convertible.Utils-    Data.Convertible.Instances.Num-    Control.CollectErrors-    Numeric.CollectErrors-    Numeric.MixedTypes.PreludeHiding-    Numeric.MixedTypes.Literals-    Numeric.MixedTypes.Bool-    Numeric.MixedTypes.Eq-    Numeric.MixedTypes.Ord-    Numeric.MixedTypes.MinMaxAbs-    Numeric.MixedTypes.AddSub-    Numeric.MixedTypes.Round-    Numeric.MixedTypes.Ring-    Numeric.MixedTypes.Field-    Numeric.MixedTypes.Elementary-    Numeric.MixedTypes.Complex-    MixedTypesNumPrelude---test-suite spec-  type:-      exitcode-stdio-1.0-  ghc-options:-      -Wall+    , smallcheck >=1.1+    , template-haskell   default-language: Haskell2010-  default-extensions:-    RebindableSyntax,-    PostfixOperators,-    ScopedTypeVariables,-    FlexibleContexts++test-suite mixed-types-num-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Numeric.MixedTypes.AddSubSpec+      Numeric.MixedTypes.BoolSpec+      Numeric.MixedTypes.EqOrdSpec+      Numeric.MixedTypes.FieldSpec+      Numeric.MixedTypes.LiteralsSpec+      Numeric.MixedTypes.MinMaxAbsSpec+      Numeric.MixedTypes.RingSpec+      Numeric.MixedTypes.RoundSpec+      Paths_mixed_types_num   hs-source-dirs:       test-  main-is:-    Spec.hs-  other-modules:-    Numeric.MixedTypes.AddSubSpec-    Numeric.MixedTypes.BoolSpec-    Numeric.MixedTypes.EqOrdSpec-    Numeric.MixedTypes.FieldSpec-    Numeric.MixedTypes.LiteralsSpec-    Numeric.MixedTypes.MinMaxAbsSpec-    Numeric.MixedTypes.RingSpec-    Numeric.MixedTypes.RoundSpec+  default-extensions: RebindableSyntax PostfixOperators ScopedTypeVariables TypeFamilies TypeOperators ConstraintKinds DefaultSignatures MultiParamTypeClasses FlexibleContexts FlexibleInstances UndecidableInstances+  other-extensions: TemplateHaskell+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall   build-depends:-    base >= 4.8 && < 5+      QuickCheck >=2.7+    , base >=4.7 && <5+    , collect-errors ==0.1.*+    , hspec >=2.1+    , hspec-smallcheck >=0.3     , mixed-types-num-    , hspec >= 2.1-    , hspec-smallcheck >= 0.3-    , QuickCheck >= 2.7+    , smallcheck >=1.1+  default-language: Haskell2010

@@ -1,452 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Control.CollectErrors-(--- * Monad for collecting errors in expressions-  CollectErrors(..), SuitableForCE-, CanTestErrorsCertain(..), hasCertainErrorCE-, CanTestErrorsPresent(..), hasErrorCE-, noValueCE, prependErrorsCE-, filterValuesWithoutErrorCE, getValueIfNoErrorCE-, ce2ConvertResult--- * Tools for avoiding @CollectErrors(CollectErrors t)@ and putting CE inside containers-, CanEnsureCE(..)-, getValueOrThrowErrorsNCE-, lift1CE, lift2CE, lift2TCE, lift2TLCE, lift3CE--- ** Tools for pulling errors out of structures-, CanExtractCE(..)-)-where--import Prelude-  (Functor(..), Applicative(..), Monad(..), (<$>), ($), (.)-  , error, const, flip, not, fst, snd, foldMap, (++)-  , Int, Integer, Rational, Double, Bool, Char-  , Maybe(..), Either(..)-  , Show(..), Eq(..)-  , Traversable(..))-import Text.Printf--import Control.Monad (join)--import Data.Monoid-import Data.Maybe (fromJust)---- import Data.Convertible-import Data.Convertible.Base-import Data.Typeable---- import Language.Haskell.TH--import Test.QuickCheck--{-|-  A wrapper around values which can accommodate a list of-  (potential) errors that have (maybe) occurred during the computation-  of a value.  A value may be missing, leaving only the error(s).--  Such error collection allows one to write expressions with partial-  functions (ie functions that fail for some inputs) instead of-  branching after each application of such function.-  Dealing with the errors can be moved outside the expression.-  If the error data contain enough information, their list can be used-  to trace the source of the errors.--}-data CollectErrors es v =-  CollectErrors-    { getMaybeValueCE :: Maybe v-    , getErrorsCE :: es }--class CanTestErrorsCertain es where-  hasCertainError :: es -> Bool--hasCertainErrorCE :: (CanTestErrorsCertain es) => (CollectErrors es v) -> Bool-hasCertainErrorCE (CollectErrors _ es) = hasCertainError es--class CanTestErrorsPresent es where-  hasError :: es -> Bool--hasErrorCE :: (CanTestErrorsPresent es) => (CollectErrors es v) -> Bool-hasErrorCE (CollectErrors _ es) = hasError es--type SuitableForCE es = (Monoid es, Eq es, Show es, CanTestErrorsCertain es)--instance (Show v, SuitableForCE es) => (Show (CollectErrors es v)) where-  show (CollectErrors mv es) =-    case mv of-      Just v | es == mempty -> show v-      Just v -> printf "%s{%s}" (show v) (show es)-      Nothing -> printf "{%s}" (show es)--noValueCE :: es -> CollectErrors es v-noValueCE es = CollectErrors Nothing es--prependErrorsCE :: (Monoid es) => es -> CollectErrors es v -> CollectErrors es v-prependErrorsCE es1 (CollectErrors mv es2) = CollectErrors mv (es1 <> es2)--ce2ConvertResult ::-  (Typeable t, Show t, SuitableForCE es)-  =>-  CollectErrors es t -> Either ConvertError t-ce2ConvertResult (CollectErrors mv es) =-  case mv of-    Just v | es == mempty -> Right v-    _ -> convError (show es) mv--{-| A safe way to get a value out of the CollectErrors wrapper. -}-getValueIfNoErrorCE ::-  (SuitableForCE es)-  =>-  CollectErrors es v -> (v -> t) -> (es -> t) -> t-getValueIfNoErrorCE (CollectErrors mv es) withValue withErrors =-  case mv of-    Just v | es == mempty -> withValue v-    _ -> withErrors es--filterValuesWithoutErrorCE ::-  (SuitableForCE es)-  =>-  [CollectErrors es v] -> [v]-filterValuesWithoutErrorCE [] = []-filterValuesWithoutErrorCE (vCE : rest) =-  getValueIfNoErrorCE vCE (: restDone) (const restDone)-  where-  restDone = filterValuesWithoutErrorCE rest---- functor instances:--instance Functor (CollectErrors es) where-  fmap f (CollectErrors mv es) =-    CollectErrors (fmap f mv) es--instance (Monoid es) => Applicative (CollectErrors es) where-  pure v = CollectErrors (Just v) mempty-  (CollectErrors (Just a) ae) <*> (CollectErrors (Just b) be) =-    CollectErrors (Just (a b)) (ae <> be)-  (CollectErrors _ ae) <*> (CollectErrors _ be) =-    CollectErrors Nothing (ae <> be)--instance (Monoid es) => Monad (CollectErrors es) where-  ae >>= f =-    case ae of-      CollectErrors (Just a) es1 ->-        let (CollectErrors mv es2) = f a in-          CollectErrors mv (es1 <> es2)-      CollectErrors _ es ->-        CollectErrors Nothing es--instance (Arbitrary t, Monoid es) => Arbitrary (CollectErrors es t) where-  arbitrary = (\v -> CollectErrors (Just v) mempty) <$> arbitrary--{-|-  A mechanism for adding and removing CollectErrors-  to a type in a manner that depends on-  the shape of the type, especially whether-  it already has CollectErrors.--}-class-  (Monoid es-  , EnsureCE es (EnsureCE es a) ~ EnsureCE es a-  , EnsureCE es (EnsureNoCE es a) ~ EnsureCE es a-  , EnsureNoCE es (EnsureCE es a) ~ EnsureNoCE es a-  , EnsureNoCE es (EnsureNoCE es a) ~ EnsureNoCE es a)-  =>-  CanEnsureCE es a where-  {-|-    Add CollectErrors to a type except when the type already-    has CollectErrors in it.-  -}-  type EnsureCE es a-  type EnsureCE es a = CollectErrors es a -- default-  type EnsureNoCE es a-  type EnsureNoCE es a = a -- default--  {-|-    Translate a value of a type @a@-    to a value of a type @EnsureCE es a@.-  -}-  ensureCE ::-    Maybe es {-^ sample only -} ->-    a -> EnsureCE es a--  default ensureCE ::-    (EnsureCE es a ~ CollectErrors es a)-    =>-    Maybe es {-^ sample only -} ->-    a -> EnsureCE es a-  ensureCE _ = pure--  deEnsureCE ::-    Maybe es {-^ sample only -} ->-    EnsureCE es a -> Either es a--  default deEnsureCE ::-    (EnsureCE es a ~ CollectErrors es a, Eq es) =>-    Maybe es {-^ sample only -} ->-    EnsureCE es a -> Either es a-  deEnsureCE _ (CollectErrors mv es) =-    case mv of-      Just v | es == mempty -> Right v-      _ -> Left es--  ensureNoCE ::-    Maybe es {-^ sample only -} ->-    a -> (Maybe (EnsureNoCE es a), es)--  default ensureNoCE ::-    (EnsureNoCE es a ~ a, Eq es, Monoid es) =>-    Maybe es {-^ sample only -} ->-    a -> (Maybe (EnsureNoCE es a), es)-  ensureNoCE _ a = (Just a, mempty)--  {-|  Make CollectErrors record with no value, only errors. -}-  noValueECE ::-    Maybe a {-^ sample only -} ->-    es -> EnsureCE es a--  default noValueECE ::-    (EnsureCE es a ~ CollectErrors es a)-    =>-    Maybe a ->-    es -> EnsureCE es a-  noValueECE _ = noValueCE--  prependErrorsECE ::-    Maybe a ->-    es -> EnsureCE es a -> EnsureCE es a-  default prependErrorsECE ::-    (EnsureCE es a ~ CollectErrors es a)-    =>-    Maybe a ->-    es -> EnsureCE es a -> EnsureCE es a-  prependErrorsECE _ = prependErrorsCE---- instance for CollectErrors a:--instance-  (SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (CollectErrors es a)-  where-  type EnsureCE es (CollectErrors es a) = EnsureCE es a-  type EnsureNoCE es (CollectErrors es a) = EnsureNoCE es a--  ensureCE sample_es (CollectErrors mv es) =-    case mv of-      Just v -> prependErrorsECE (Just v) es $ ensureCE sample_es v-      _ -> noValueECE mv es-  deEnsureCE sample_es vCE =-    case deEnsureCE sample_es vCE of-      Right v -> Right $ CollectErrors (Just v) mempty-      Left es -> Left es-  ensureNoCE sample_es (CollectErrors mv es) =-    case fmap (ensureNoCE sample_es) mv of-      Just (Just v, es2) -> (Just v, es2 <> es)-      Just (_, es2) -> (Nothing, es2 <> es)-      _ -> (Nothing, mempty)--  noValueECE sample_vCE es =-    noValueECE (join $ fmap getMaybeValueCE sample_vCE) es-  prependErrorsECE sample_vCE =-    prependErrorsECE (join $ fmap getMaybeValueCE sample_vCE)---- instances for ground types, using the default implementations:--instance (SuitableForCE es) => CanEnsureCE es Int-instance (SuitableForCE es) => CanEnsureCE es Integer-instance (SuitableForCE es) => CanEnsureCE es Rational-instance (SuitableForCE es) => CanEnsureCE es Double-instance (SuitableForCE es) => CanEnsureCE es Bool-instance (SuitableForCE es) => CanEnsureCE es Char-instance (SuitableForCE es) => CanEnsureCE es ()---- instance for Maybe a:--instance-  (SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (Maybe a)-  where-  type EnsureCE es (Maybe a) = Maybe (EnsureCE es a)-  type EnsureNoCE es (Maybe a) = Maybe (EnsureNoCE es a)--  ensureCE sample_es = fmap (ensureCE sample_es)-  deEnsureCE sample_es (Just vCE) = fmap Just (deEnsureCE sample_es vCE)-  deEnsureCE _sample_es Nothing = Right Nothing-  ensureNoCE sample_es (Just vCE) =-    case ensureNoCE sample_es vCE of-      (Just v, es) -> (Just (Just v), es)-      (_, es) -> (Nothing, es)-  ensureNoCE _sample_es Nothing = (Nothing, mempty)--  noValueECE sample_vCE es = Just (noValueECE (fromJust sample_vCE) es)--  prependErrorsECE sample_vCE es (Just vCE) =-    Just $ prependErrorsECE (fromJust sample_vCE) es vCE-  prependErrorsECE _sample_vCE _es Nothing = Nothing--instance-  (SuitableForCE es, CanEnsureCE es a)-  =>-  CanEnsureCE es (b -> a)-  where-  type EnsureCE es (b -> a) = b -> (EnsureCE es a)-  type EnsureNoCE es (b -> a) = b ->  (EnsureNoCE es a)--  ensureCE sample_es = ((ensureCE sample_es) .)-  deEnsureCE sample_es f =-    Right $ \ a ->-      case deEnsureCE sample_es (f a) of-        Right v -> v-        Left es -> error $ "deEnsureCE for function: " ++ show es-  ensureNoCE sample_es f = (Just f', mempty)-    where-    f' a =-      case ensureNoCE sample_es (f a) of-        (Just v, _) -> v-        (_, es) -> error $ "ensureNoCE for function: " ++ show es--  noValueECE (_fvCE :: Maybe (b -> a)) es =-    const (noValueECE (Nothing :: Maybe a) es)--  prependErrorsECE (_fvCE :: Maybe (b -> a)) es =-    ((prependErrorsECE (Nothing :: Maybe a) es) .)---- instance (Monoid es) => CanEnsureCE es [a] where--- instance (Monoid es) => CanEnsureCE es (Either e a) where--{-| An unsafe way to get a value out of an CollectErrors wrapper. -}-getValueOrThrowErrorsNCE ::-  (SuitableForCE es, CanEnsureCE es v, Show v)-  =>-  Maybe es {-^ sample only -} ->-  v -> (EnsureNoCE es v)-getValueOrThrowErrorsNCE sample_es v =-  case ensureNoCE sample_es v of-    (Just vNCE, es) | not (hasCertainError es) -> vNCE-    _ -> error (show v)--{-|-  Add error collection support to an unary function whose-  result may already have collected errors.--}-lift1CE ::-  (SuitableForCE es-  , CanEnsureCE es a, CanEnsureCE es c)-  =>-  (a -> c) ->-  (CollectErrors es a) -> (EnsureCE es c)-lift1CE fn aCE =-  case ma of-    Just a ->-      prependErrorsECE sample_c a_es $ ensureCE sample_es $ fn a-    _ ->-      noValueECE sample_c a_es-  where-  CollectErrors ma a_es = aCE-  sample_es = Just a_es-  sample_c = fn <$> ma--{-|-  Add error collection support to a binary function whose-  result may already have collected errors.--}-lift2CE ::-  (SuitableForCE es-  , CanEnsureCE es a, CanEnsureCE es b, CanEnsureCE es c)-  =>-  (a -> b -> c) ->-  (CollectErrors es a) -> (CollectErrors es b) -> (EnsureCE es c)-lift2CE fn aCE bCE =-  case (ma, mb) of-    (Just a, Just b) ->-      prependErrorsECE sample_c ab_es $ ensureCE sample_es $ fn a b-    _ ->-      noValueECE sample_c ab_es-  where-  CollectErrors ma a_es = aCE-  CollectErrors mb b_es = bCE-  ab_es = a_es <> b_es-  sample_es = Just a_es-  sample_c = fn <$> ma <*> mb--{-|-  Add error collection support to a binary function whose-  result may already have collected errors.-  A version where the second operand is not lifted, only the first one.--}-lift2TCE ::-  (SuitableForCE es-  , CanEnsureCE es a, CanEnsureCE es c)-  =>-  (a -> b -> c) ->-  (CollectErrors es a) -> b -> (EnsureCE es c)-lift2TCE fn aCE b =-  case ma of-    (Just a) ->-      prependErrorsECE sample_c a_es $ ensureCE sample_es $ fn a b-    _ ->-      noValueECE sample_c a_es-  where-  CollectErrors ma a_es = aCE-  sample_es = Just a_es-  sample_c = fn <$> ma <*> (Just b)--{-|-  Add error collection support to a binary function whose-  result may already have collected errors.-  A version where the first operand is not lifted, only the second one.--}-lift2TLCE ::-  (SuitableForCE es-  , CanEnsureCE es b, CanEnsureCE es c)-  =>-  (a -> b -> c) ->-  a -> (CollectErrors es b) -> (EnsureCE es c)-lift2TLCE f = flip $ lift2TCE (flip f)--{-|-  Add error collection support to a binary function whose-  result may already have collected errors.--}-lift3CE ::-  (SuitableForCE es-  , CanEnsureCE es a, CanEnsureCE es b, CanEnsureCE es c, CanEnsureCE es d)-  =>-  (a -> b -> c -> d) ->-  (CollectErrors es a) -> (CollectErrors es b) -> (CollectErrors es c) -> (EnsureCE es d)-lift3CE fn aCE bCE cCE =-  case (ma, mb, mc) of-    (Just a, Just b, Just c) ->-      prependErrorsECE sample_d abc_es $ ensureCE sample_es $ fn a b c-    _ ->-      noValueECE sample_d abc_es-  where-  CollectErrors ma a_es = aCE-  CollectErrors mb b_es = bCE-  CollectErrors mc c_es = cCE-  abc_es = a_es <> b_es <> c_es-  sample_es = Just a_es-  sample_d = fn <$> ma <*> mb <*> mc---{-|-  Ability to lift collected (potential) errors from inside some structure/collection.--  This is useful mostly for structures that use the default implementation of-  'CanEnsureCE es'.--}-class (SuitableForCE es) => CanExtractCE es f where-  extractCE ::-    (CanEnsureCE es c) =>-    Maybe es ->-    f c -> CollectErrors es (f (EnsureNoCE es c))-  default extractCE ::-    (CanEnsureCE es c, Traversable f) =>-    Maybe es ->-    f c -> CollectErrors es (f (EnsureNoCE es c))-  extractCE sample_es fc =-    case mapM fst fcNoCE of-      Just fec -> pure fec-      _ -> noValueCE $ foldMap snd fcNoCE-    where-    fcNoCE = fmap (ensureNoCE sample_es) fc

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-deprecations #-} {-  Borrowed from package convertible-1.1.1.0.   

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} {-  Borrowed from package convertible-1.1.1.0.   

@@ -43,16 +43,20 @@   -- * Modules with Prelude alternatives   module Numeric.MixedTypes.Literals,   module Numeric.MixedTypes.Bool,+  module Numeric.MixedTypes.Kleenean,   module Numeric.MixedTypes.Eq,   module Numeric.MixedTypes.Ord,   module Numeric.MixedTypes.MinMaxAbs,   module Numeric.MixedTypes.AddSub,   module Numeric.MixedTypes.Round,+  module Numeric.MixedTypes.Reduce,   module Numeric.MixedTypes.Ring,+  module Numeric.MixedTypes.Div,+  module Numeric.MixedTypes.Power,   module Numeric.MixedTypes.Field,   module Numeric.MixedTypes.Elementary,   module Numeric.MixedTypes.Complex,-  module Numeric.CollectErrors,+  -- module Numeric.CollectErrors,   module Utils.TH.DeclForTypes,   module Utils.Test.EnforceRange,   -- * Re-export for convenient Rational literals@@ -65,16 +69,19 @@ import Data.Convertible.Base import Utils.TH.DeclForTypes import Utils.Test.EnforceRange-import Numeric.CollectErrors import Numeric.MixedTypes.PreludeHiding import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool+import Numeric.MixedTypes.Kleenean import Numeric.MixedTypes.Eq import Numeric.MixedTypes.Ord import Numeric.MixedTypes.MinMaxAbs import Numeric.MixedTypes.AddSub import Numeric.MixedTypes.Round+import Numeric.MixedTypes.Reduce import Numeric.MixedTypes.Ring+import Numeric.MixedTypes.Div+import Numeric.MixedTypes.Power import Numeric.MixedTypes.Field import Numeric.MixedTypes.Elementary import Numeric.MixedTypes.Complex@@ -108,71 +115,44 @@ === Dividing integers, dealing with potential error  >...> :t let n = 1 in n/(n+1)->... :: CollectErrors [(ErrorCertaintyLevel, NumError)] Rational+>... :: Rational -A shorter synonym of this type is @CN Rational@.-We use the shorter form below for better readability of this documentation-although ghci usually prints the longer version:+To avoid runtime exceptions, it is recommended to use the CN error-collecting wrapper from package collect-errors: ->...> :t let n = 1 in n/(n+1)+>...> :t let n = cn 1 in n/(n+1) >... :: CN Rational -The @CN@ wrapper here indicates that integer division can fail for some values:+@CN@ is a synonym for @CollectErrors [(ErrorCertaintyLevel, NumError)] Rational@ as defined in module "Numeric.CollectErrors".+The @CN@ wrapper indicates that integer division can fail for some values: ->...> 1/0->{[(ERROR,division by 0)]}+>...> let n = cn 1 in n/(n-1)+>{[(division by 0,ERROR)]} -Note that when evaluating @1/0@, it evaluates to the error value printed above.-This is not an exception, but a special value.+Note that the error printed above is not an exception, but a special value.  All arithmetic operations have been extended to CN types so that it is possible to have expressions that operate exclusively on CN types:  >...> f (n :: CN Integer) = 1/(1/(n-1) + 1/n) :: CN Rational >...> f (cn 0)->{[(ERROR,division by 0)]}+>{[(division by 0,POTENTIAL ERROR),(division by 0,ERROR)]} >...> f (cn 1)->{[(ERROR,division by 0)]}+>{[(division by 0,POTENTIAL ERROR),(division by 0,ERROR)]} >...> f (cn 2) >2 % 3 -The function hasErrorCN can be used to check whether any error occurred:+The function @hasError@ can be used to check whether any error occurred: ->...> hasErrorCN (1/0)+>...> hasError (cn 1/0) >True ->...> hasErrorCN (1/1)+>...> hasError (cn 1/1) >False -When one is certain the division is well defined, one can remove @CN@ as follows:-->...> :t (1/!2)->... :: Rational--Note that if one gets it wrong, it can lead to an exception:-->...> :t (1/!0)->*** Exception: Ratio has zero denominator--More generally, one can remove @CN@ as follows:-->...> :t (~!) (1/2)->... :: Rational--The operator @(/!)@ stands for division which throws an exception is the-denominator is 0.  It "propagates" any potential errors-from the sub-expressions.  For example:-->...> :t 1/!(1 - 1/n)->... :: CN Rational--The above expression will throw an error exception when evaluated with @n=1@-but when @n=0@, it will not throw an excetion but return an error value.--The @(~!)@ operator removes CN from any type, throwing an exception if some errors have certainly occurred:+To extract a value from the CN wrapper, one can use function @withErrorOrValue@: ->...> :t (~!) (1/(1 - 1/n))->... :: Rational+>...> withErrorOrValue (const 0.0) id (cn 1/2)+>1 % 2  The following examples require also package <https://github.com/michalkonecny/aern2 aern2-real>. To get access to this via stack, you can start ghci eg as follows:

@@ -1,155 +0,0 @@-{-|-    Module      :  Numeric.CollectErrors-    Description :  A type of numeric errors to be collected-    Copyright   :  (c) Michal Konecny-    License     :  BSD3--    Maintainer  :  mikkonecny@gmail.com-    Stability   :  experimental-    Portability :  portable--    A type of numeric errors to be collected.--}-module Numeric.CollectErrors-(-  -- * Type of numeric errors-  ErrorCertaintyLevel(..), NumError(..), NumErrors, sample_NumErrors-  -- * Specialisation to numeric errors-, CN-, hasCertainError, hasCertainErrorCN-, hasError, hasErrorCN-, noValueCN-, noValueNumErrorCertainCN, noValueNumErrorPotentialCN-, getMaybeValueCN, getErrorsCN, prependErrorsCN-, CanEnsureCN, EnsureCN, EnsureNoCN-, ensureCN, deEnsureCN, ensureNoCN-, noValueECN, prependErrorsECN-, noValueNumErrorCertainECN, noValueNumErrorPotentialECN-, CanExtractCN, extractCN-  -- ** More compact synonyms-, cn, deCN, (~!)-)-where--import Prelude-  (Show(..), Eq(..), Bool, String, Maybe(..), Either(..), (++), (.), or, map, fst, ($), null, not)--import Control.CollectErrors--data NumError =-    DivByZero | OutOfRange String | NumError String-    deriving (Eq)--instance Show NumError where-  show DivByZero = "division by 0"-  show (OutOfRange s) = "out of range: " ++ s-  show (NumError s) = "numeric error: " ++ s--data ErrorCertaintyLevel =-  ErrorCertain | ErrorPotential-  deriving (Eq)--instance Show ErrorCertaintyLevel where-  show ErrorCertain = "ERROR"-  show ErrorPotential = "POTENTIAL ERROR"--type NumErrors = [(ErrorCertaintyLevel, NumError)]--instance CanTestErrorsCertain NumErrors where-  hasCertainError es =-    or $ map ((== ErrorCertain) . fst) es--hasCertainErrorCN :: CN v -> Bool-hasCertainErrorCN = hasCertainErrorCE--instance CanTestErrorsPresent NumErrors where-  hasError = not . null--hasErrorCN :: CN v -> Bool-hasErrorCN = hasErrorCE--sample_NumErrors :: Maybe [(ErrorCertaintyLevel, NumError)]-sample_NumErrors = Nothing--type CN = CollectErrors NumErrors-type CanEnsureCN = CanEnsureCE NumErrors-type EnsureCN a = EnsureCE NumErrors a-type EnsureNoCN a = EnsureNoCE NumErrors a--type CanExtractCN f = CanExtractCE NumErrors f-extractCN ::-  (CanEnsureCN c, CanExtractCN f) =>-  f c -> CN (f (EnsureNoCN c))-extractCN = extractCE sample_NumErrors--{-|-  Translate a value of a type @a@-  to a value of a type @CollectNumErrors a@ except when @a@-  already is a @CollectNumErrors@ type, in which case the value is left as is.--}-ensureCN :: (CanEnsureCN v) => v -> EnsureCN v-ensureCN = ensureCE sample_NumErrors--{-|-  Translate a value of a type @EnsureCN es a@ to @a@,-  throwing an exception if there was an error.-  If @a@ is a @CollectNumErrors@ type, then this is just an identity.--}-deEnsureCN :: (CanEnsureCN v) => EnsureCN v -> Either NumErrors v-deEnsureCN = deEnsureCE sample_NumErrors--{-|-  Translate a value of a type @a@-  to a value of a type @CollectNumErrors a@ except when @a@-  already is a @CollectNumErrors@ type, in which case the value is left as is.--}-ensureNoCN :: (CanEnsureCN v) => v -> (Maybe (EnsureNoCN v), NumErrors)-ensureNoCN = ensureNoCE sample_NumErrors--noValueECN :: (CanEnsureCN v) => Maybe v -> NumErrors -> EnsureCN v-noValueECN = noValueECE--prependErrorsECN :: (CanEnsureCN v) => Maybe v -> NumErrors -> EnsureCN v -> EnsureCN v-prependErrorsECN = prependErrorsECE--{-| Construct an empty wrapper indicating that given error has certainly occurred. -}-noValueNumErrorCertainECN :: (CanEnsureCN v) => Maybe v -> NumError -> EnsureCN v-noValueNumErrorCertainECN sample_v e = noValueECE sample_v [(ErrorCertain, e)]--{-| Construct an empty wrapper indicating that given error may have occurred. -}-noValueNumErrorPotentialECN :: (CanEnsureCN v) => Maybe v -> NumError -> EnsureCN v-noValueNumErrorPotentialECN sample_v e = noValueECE sample_v [(ErrorPotential, e)]--getErrorsCN :: CN v -> NumErrors-getErrorsCN = getErrorsCE--getMaybeValueCN :: CN v -> Maybe v-getMaybeValueCN = getMaybeValueCE--noValueCN :: NumErrors -> CN v-noValueCN = noValueCE--{-| Construct an empty wrapper indicating that given error has certainly occurred. -}-noValueNumErrorCertainCN :: NumError -> CN v-noValueNumErrorCertainCN e = noValueCN [(ErrorCertain, e)]--{-| Construct an empty wrapper indicating that given error may have occurred. -}-noValueNumErrorPotentialCN :: NumError -> CN v-noValueNumErrorPotentialCN e = noValueCN [(ErrorPotential, e)]--prependErrorsCN :: NumErrors -> CN v -> CN v-prependErrorsCN = prependErrorsCE---- more compact synonyms:--{-| Wrap a value in the 'CollectNumErrors' wrapper. -}-cn :: (CanEnsureCN v) => v -> EnsureCN v-cn = ensureCN--{-| An unsafe way to get a value out of the CollectNumErrors wrapper. -}-deCN :: (CanEnsureCN v) => EnsureCN v -> Either NumErrors v-deCN = deEnsureCN--{-| An unsafe way to get a value out of the CollectNumErrors wrapper. -}-(~!) :: (CanEnsureCN v, Show v) => v -> EnsureNoCN v-(~!) = getValueOrThrowErrorsNCE sample_NumErrors

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.AddSub@@ -37,8 +39,8 @@ import Test.Hspec import Test.QuickCheck --- import Numeric.CollectErrors-import Control.CollectErrors+import Control.CollectErrors ( CollectErrors, CanBeErrors )+import qualified Control.CollectErrors as CE  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -83,30 +85,7 @@   HSpec properties that each implementation of CanAdd should satisfy.  -} specCanAdd ::-  (Show t1, Show t2, Show t3, Show (AddType t1 t1),-   Show (AddType t1 t2), Show (AddType t2 t1),-   Show (AddType t1 (AddType t2 t3)),-   Show (AddType (AddType t1 t2) t3), Arbitrary t1, Arbitrary t2,-   Arbitrary t3, ConvertibleExactly Integer t1,-   CanTestCertainly-     (EqCompareType (AddType t1 t1) t1),-   CanTestCertainly-     (EqCompareType (AddType t1 t2) (AddType t2 t1)),-   CanTestCertainly-     (EqCompareType-        (AddType t1 (AddType t2 t3)) (AddType (AddType t1 t2) t3)),-   CanTestCertainly-     (OrderCompareType (AddType t1 t2) t2),-   HasEqAsymmetric (AddType t1 t1) t1,-   HasEqAsymmetric (AddType t1 t2) (AddType t2 t1),-   HasEqAsymmetric-     (AddType t1 (AddType t2 t3)) (AddType (AddType t1 t2) t3),-   HasOrderAsymmetric (AddType t1 t2) t2, CanTestPosNeg t1,-   CanAddAsymmetric t1 t1, CanAddAsymmetric t1 t2,-   CanAddAsymmetric t1 (AddType t2 t3), CanAddAsymmetric t2 t1,-   CanAddAsymmetric t2 t3, CanAddAsymmetric (AddType t1 t2) t3)-  =>-  T t1 -> T t2 -> T t3 -> Spec+  _ => T t1 -> T t2 -> T t3 -> Spec specCanAdd (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "CanAdd %s %s, CanAdd %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "absorbs 0" $ do@@ -135,24 +114,7 @@   HSpec properties that each implementation of CanAdd should satisfy.  -} specCanAddNotMixed ::-  (Show t, Show (AddType t t), Show (AddType t (AddType t t)),-   Show (AddType (AddType t t) t), Arbitrary t,-   ConvertibleExactly Integer t,-   CanTestCertainly (EqCompareType (AddType t t) t),-   CanTestCertainly (EqCompareType (AddType t t) (AddType t t)),-   CanTestCertainly-     (EqCompareType-        (AddType t (AddType t t)) (AddType (AddType t t) t)),-   CanTestCertainly (OrderCompareType (AddType t t) t),-   HasEqAsymmetric (AddType t t) t,-   HasEqAsymmetric (AddType t t) (AddType t t),-   HasEqAsymmetric-     (AddType t (AddType t t)) (AddType (AddType t t) t),-   HasOrderAsymmetric (AddType t t) t, CanTestPosNeg t,-   CanAddAsymmetric t t, CanAddAsymmetric t (AddType t t),-   CanAddAsymmetric (AddType t t) t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanAddNotMixed (t :: T t) = specCanAdd t t t  {-|@@ -235,16 +197,13 @@   add _ _ = Nothing  instance-  (CanAddAsymmetric a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (AddType a b)-  , SuitableForCE es)+  (CanAddAsymmetric a b, CanBeErrors es)   =>   CanAddAsymmetric (CollectErrors es a) (CollectErrors es  b)   where   type AddType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (AddType a b)-  add = lift2CE add+    CollectErrors es (AddType a b)+  add = CE.lift2 add  -- TH for ground type instances at is the end of the file due to a bug in TH @@ -277,17 +236,7 @@   HSpec properties that each implementation of CanSub should satisfy.  -} specCanSub ::-  (Show t1, Show t2, Show (SubType t1 t1), Show (SubType t1 t2),-   Show (AddType t1 (NegType t2)), Arbitrary t1, Arbitrary t2,-   ConvertibleExactly Integer t1,-   CanTestCertainly (EqCompareType (SubType t1 t1) t1),-   CanTestCertainly-     (EqCompareType (SubType t1 t2) (AddType t1 (NegType t2))),-   CanNeg t2, HasEqAsymmetric (SubType t1 t1) t1,-   HasEqAsymmetric (SubType t1 t2) (AddType t1 (NegType t2)),-   CanSub t1 t1, CanSub t1 t2, CanAddAsymmetric t1 (NegType t2))-  =>-  T t1 -> T t2 -> Spec+  _ => T t1 -> T t2 -> Spec specCanSub (T typeName1 :: T t1) (T typeName2 :: T t2) =   describe (printf "CanSub %s %s" typeName1 typeName2) $ do     it "x-0 = x" $ do@@ -306,16 +255,7 @@   HSpec properties that each implementation of CanSub should satisfy.  -} specCanSubNotMixed ::-  (Show t, Show (SubType t t), Show (AddType t (NegType t)),-   Arbitrary t, ConvertibleExactly Integer t,-   CanTestCertainly (EqCompareType (SubType t t) t),-   CanTestCertainly-     (EqCompareType (SubType t t) (AddType t (NegType t))),-   CanNeg t, HasEqAsymmetric (SubType t t) t,-   HasEqAsymmetric (SubType t t) (AddType t (NegType t)), CanSub t t,-   CanAddAsymmetric t (NegType t))-  =>-  T t -> Spec+  _ => T t -> Spec specCanSubNotMixed (t :: T t) = specCanSub t t  instance CanSub Int Int where@@ -380,66 +320,51 @@   instance-  (CanSub a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (SubType a b)-  , SuitableForCE es)+  (CanSub a b, CanBeErrors es)   =>   CanSub (CollectErrors es a) (CollectErrors es  b)   where   type SubType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (SubType a b)-  sub = lift2CE sub+    CollectErrors es (SubType a b)+  sub = CE.lift2 sub  $(declForTypes   [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]   (\ t -> [d|      instance-      (CanSub $t b-      , CanEnsureCE es b-      , CanEnsureCE es (SubType $t b)-      , SuitableForCE es)+      (CanSub $t b, CanBeErrors es)       =>       CanSub $t (CollectErrors es  b)       where       type SubType $t (CollectErrors es  b) =-        EnsureCE es (SubType $t b)-      sub = lift2TLCE sub+        CollectErrors es (SubType $t b)+      sub = CE.liftT1 sub      instance-      (CanSub a $t-      , CanEnsureCE es a-      , CanEnsureCE es (SubType a $t)-      , SuitableForCE es)+      (CanSub a $t, CanBeErrors es)       =>       CanSub (CollectErrors es a) $t       where       type SubType (CollectErrors es  a) $t =-        EnsureCE es (SubType a $t)-      sub = lift2TCE sub+        CollectErrors es (SubType a $t)+      sub = CE.lift1T sub      instance-      (CanAddAsymmetric $t b-      , CanEnsureCE es b-      , CanEnsureCE es (AddType $t b)-      , SuitableForCE es)+      (CanAddAsymmetric $t b, CanBeErrors es)       =>       CanAddAsymmetric $t (CollectErrors es  b)       where       type AddType $t (CollectErrors es  b) =-        EnsureCE es (AddType $t b)-      add = lift2TLCE add+        CollectErrors es (AddType $t b)+      add = CE.liftT1 add      instance-      (CanAddAsymmetric a $t-      , CanEnsureCE es a-      , CanEnsureCE es (AddType a $t)-      , SuitableForCE es)+      (CanAddAsymmetric a $t, CanBeErrors es)       =>       CanAddAsymmetric (CollectErrors es a) $t       where       type AddType (CollectErrors es  a) $t =-        EnsureCE es (AddType a $t)-      add = lift2TCE add+        CollectErrors es (AddType a $t)+      add = CE.lift1T add   |]))

@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-orphans #-} {-|     Module      :  Numeric.MixedType.Bool     Description :  Bottom-up typed Boolean operations@@ -9,7 +12,6 @@     Portability :  portable  -}- module Numeric.MixedTypes.Bool (   IsBool, specIsBool@@ -35,8 +37,8 @@  import qualified Data.List as List --- import Numeric.CollectErrors-import Control.CollectErrors+import Control.CollectErrors ( CollectErrors, CanBeErrors )+import qualified Control.CollectErrors as CE  import Numeric.MixedTypes.Literals @@ -109,23 +111,11 @@   isCertainlyTrue = id   isCertainlyFalse = not -instance (ConvertibleExactly Bool t) => ConvertibleExactly Bool (Maybe t) where-  safeConvertExactly b =-    case (safeConvertExactly b) of-      Left _ -> Right Nothing-      Right r -> Right (Just r)--instance (CanTestCertainly t) => CanTestCertainly (Maybe t) where-  isCertainlyTrue (Just b) = isCertainlyTrue b-  isCertainlyTrue _ = False-  isCertainlyFalse (Just b) = isCertainlyFalse b-  isCertainlyFalse _ = False--instance (CanTestCertainly t, SuitableForCE es) => CanTestCertainly (CollectErrors es t) where+instance (CanTestCertainly t, CanBeErrors es) => CanTestCertainly (CollectErrors es t) where   isCertainlyTrue vCE =-    getValueIfNoErrorCE vCE isCertainlyTrue (const False)+    CE.withErrorOrValue (const False) isCertainlyTrue vCE   isCertainlyFalse vCE =-    getValueIfNoErrorCE vCE isCertainlyFalse (const False)+    CE.withErrorOrValue (const False) isCertainlyFalse vCE   {---- Negation ----}@@ -157,12 +147,7 @@   HSpec properties that each Boolean implementation of CanNeg should satisfy.  -} specCanNegBool ::-  (Show t, Show (NegType (NegType t)), SCS.Serial IO t,-   CanTestCertainly t, CanTestCertainly (NegType t),-   CanTestCertainly (NegType (NegType t)), CanNeg t,-   CanNeg (NegType t))-  =>-  T t -> Spec+  _ => T t -> Spec specCanNegBool (T typeName :: T t) =   describe (printf "CanNeg %s" typeName) $ do     it "ignores double negation" $ do@@ -177,19 +162,12 @@  instance CanNeg Bool where negate = P.not -instance CanNeg t => CanNeg (Maybe t) where-  type NegType (Maybe t) = Maybe (NegType t)-  negate = fmap negate--_testNeg1 :: Maybe Bool-_testNeg1 = not (Just True)- instance-  (CanNeg t, SuitableForCE es, CanEnsureCE es t, CanEnsureCE es (NegType t))+  (CanNeg t, CanBeErrors es)   =>   CanNeg (CollectErrors es t) where-  type NegType (CollectErrors es t) = EnsureCE es (NegType t)-  negate = lift1CE negate+  type NegType (CollectErrors es t) = CollectErrors es (NegType t)+  negate = fmap negate  {---- And/Or ----} @@ -232,31 +210,7 @@ {-|   HSpec properties that each implementation of CanAndOr should satisfy.  -}-specCanAndOr ::-  (Show t1, Show t2, Show t3, Show (AndOrType t1 t1),-   Show (AndOrType t1 t2), Show (AndOrType t2 t1),-   Show (AndOrType t1 (AndOrType t2 t3)),-   Show (AndOrType (AndOrType t1 t2) t3),-   Show (AndOrType (AndOrType t1 t2) (AndOrType t1 t3)),-   Show (NegType (AndOrType t1 t2)),-   Show (AndOrType (NegType t1) (NegType t2)), SCS.Serial IO t1,-   SCS.Serial IO t2, SCS.Serial IO t3, CanTestCertainly t1,-   CanTestCertainly (AndOrType t1 t1),-   CanTestCertainly (AndOrType t1 t2),-   CanTestCertainly (AndOrType t2 t1),-   CanTestCertainly (AndOrType t1 (AndOrType t2 t3)),-   CanTestCertainly (AndOrType (AndOrType t1 t2) t3),-   CanTestCertainly (AndOrType (AndOrType t1 t2) (AndOrType t1 t3)),-   CanTestCertainly (NegType (AndOrType t1 t2)),-   CanTestCertainly (AndOrType (NegType t1) (NegType t2)), CanNeg t1,-   CanNeg t2, CanNeg (AndOrType t1 t2), CanAndOrAsymmetric t1 t1,-   CanAndOrAsymmetric t1 t2, CanAndOrAsymmetric t1 t3,-   CanAndOrAsymmetric t1 (AndOrType t2 t3), CanAndOrAsymmetric t2 t1,-   CanAndOrAsymmetric t2 t3, CanAndOrAsymmetric (AndOrType t1 t2) t3,-   CanAndOrAsymmetric (AndOrType t1 t2) (AndOrType t1 t3),-   CanAndOrAsymmetric (NegType t1) (NegType t2))-  =>-  T t1 -> T t2 -> T t3 -> Spec+specCanAndOr :: _ => T t1 -> T t2 -> T t3 -> Spec specCanAndOr (T typeName1 ::T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "CanAndOr %s %s, CanAndOr %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "has idempotent ||" $ do@@ -287,26 +241,7 @@ {-|   HSpec properties that each implementation of CanAndOr should satisfy.  -}-specCanAndOrNotMixed ::-  (Show t, Show (AndOrType t t),-   Show (AndOrType t (AndOrType t t)),-   Show (AndOrType (AndOrType t t) t),-   Show (AndOrType (AndOrType t t) (AndOrType t t)),-   Show (NegType (AndOrType t t)),-   Show (AndOrType (NegType t) (NegType t)), SCS.Serial IO t,-   CanTestCertainly t, CanTestCertainly (AndOrType t t),-   CanTestCertainly (AndOrType t (AndOrType t t)),-   CanTestCertainly (AndOrType (AndOrType t t) t),-   CanTestCertainly (AndOrType (AndOrType t t) (AndOrType t t)),-   CanTestCertainly (NegType (AndOrType t t)),-   CanTestCertainly (AndOrType (NegType t) (NegType t)), CanNeg t,-   CanNeg (AndOrType t t), CanAndOrAsymmetric t t,-   CanAndOrAsymmetric t (AndOrType t t),-   CanAndOrAsymmetric (AndOrType t t) t,-   CanAndOrAsymmetric (AndOrType t t) (AndOrType t t),-   CanAndOrAsymmetric (NegType t) (NegType t))-  =>-  T t -> Spec+specCanAndOrNotMixed :: _ => T t -> Spec specCanAndOrNotMixed t = specCanAndOr t t t  instance CanAndOrAsymmetric Bool Bool where@@ -314,90 +249,39 @@   and2 = (P.&&)   or2 = (P.||) -instance (CanAndOrAsymmetric t1 t2, CanTestCertainly t1, CanTestCertainly t2, CanTestCertainly (AndOrType t1 t2)) =>-  CanAndOrAsymmetric (Maybe t1) (Maybe t2)-  where-  type AndOrType (Maybe t1) (Maybe t2) = Maybe (AndOrType t1 t2)-  and2 (Just b1) _ | isCertainlyFalse b1 = Just (convertExactly False)-  and2 _ (Just b2) | isCertainlyFalse b2 = Just (convertExactly False)-  and2 (Just b1) (Just b2) = Just (b1 && b2)-  and2 _ _ = Nothing-  or2 (Just b1) _ | isCertainlyTrue b1 = Just (convertExactly True)-  or2 _ (Just b2) | isCertainlyTrue b2 = Just (convertExactly True)-  or2 (Just b1) (Just b2) = Just (b1 || b2)-  or2 _ _ = Nothing--instance (CanAndOrAsymmetric Bool t2, CanTestCertainly t2, CanTestCertainly (AndOrType Bool t2)) =>-  CanAndOrAsymmetric Bool (Maybe t2)-  where-  type AndOrType Bool (Maybe t2) = Maybe (AndOrType Bool t2)-  and2 False _ = Just (convertExactly False)-  and2 _ (Just b2) | isCertainlyFalse b2 = Just (convertExactly False)-  and2 b1 (Just b2) = Just (b1 && b2)-  and2 _ _ = Nothing-  or2 True _ = Just (convertExactly True)-  or2 _ (Just b2) | isCertainlyTrue b2 = Just (convertExactly True)-  or2 b1 (Just b2) = Just (b1 || b2)-  or2 _ _ = Nothing--instance (CanAndOrAsymmetric t1 Bool, CanTestCertainly t1, CanTestCertainly (AndOrType t1 Bool)) =>-  CanAndOrAsymmetric (Maybe t1) Bool-  where-  type AndOrType (Maybe t1) Bool = Maybe (AndOrType t1 Bool)-  and2 _ False = Just (convertExactly False)-  and2 (Just b1) _ | isCertainlyFalse b1 = Just (convertExactly False)-  and2 (Just b1) b2 = Just (b1 && b2)-  and2 _ _ = Nothing-  or2 _ True = Just (convertExactly True)-  or2 (Just b1) _ | isCertainlyTrue b1 = Just (convertExactly True)-  or2 (Just b1) b2 = Just (b1 || b2)-  or2 _ _ = Nothing--_testAndOr1 :: Maybe Bool-_testAndOr1 = (Just True) && False--_testAndOr2 :: Maybe (Maybe Bool)-_testAndOr2 = (Just (Just True)) || False--_testAndOr3 :: Maybe Bool-_testAndOr3 = and [Just True, Nothing, Just False]- instance-  (CanAndOrAsymmetric t1 t2, SuitableForCE es-  , CanEnsureCE es t1, CanEnsureCE es t2, CanEnsureCE es (AndOrType t1 t2))+  (CanAndOrAsymmetric t1 t2, CanBeErrors es)   =>   CanAndOrAsymmetric (CollectErrors es t1) (CollectErrors es t2)   where-  type AndOrType (CollectErrors es t1) (CollectErrors es t2) = EnsureCE es (AndOrType t1 t2)-  and2 = lift2CE and2-  or2 = lift2CE or2+  type AndOrType (CollectErrors es t1) (CollectErrors es t2) = CollectErrors es (AndOrType t1 t2)+  and2 = CE.lift2 and2+  or2 = CE.lift2 or2  instance-  (CanAndOrAsymmetric t1 Bool, SuitableForCE es-  , CanEnsureCE es t1, CanEnsureCE es (AndOrType t1 Bool))+  (CanAndOrAsymmetric t1 Bool, CanBeErrors es)   =>   CanAndOrAsymmetric (CollectErrors es t1) Bool   where-  type AndOrType (CollectErrors es t1) Bool = EnsureCE es (AndOrType t1 Bool)-  and2 = lift2TCE and2-  or2 = lift2TCE or2+  type AndOrType (CollectErrors es t1) Bool = CollectErrors es (AndOrType t1 Bool)+  and2 = CE.lift1T and2+  or2 = CE.lift1T or2  instance-  (CanAndOrAsymmetric Bool t2, SuitableForCE es-  , CanEnsureCE es t2, CanEnsureCE es (AndOrType Bool t2))+  (CanAndOrAsymmetric Bool t2, CanBeErrors es)   =>   CanAndOrAsymmetric Bool (CollectErrors es t2)   where-  type AndOrType Bool (CollectErrors es t2) = EnsureCE es (AndOrType Bool t2)-  and2 = lift2TLCE and2-  or2 = lift2TLCE or2+  type AndOrType Bool (CollectErrors es t2) = CollectErrors es (AndOrType Bool t2)+  and2 = CE.liftT1 and2+  or2 = CE.liftT1 or2  {-|   A type constraint synonym that stipulates that the type behaves very   much like Bool, except it does not necessarily satisfy the law of excluded middle,-  which means that the type can contain a "do-not-know" value.+  which means that the type can contain a "do-not-know" value or an error. -  Examples: @Bool@, @Maybe Bool@, @Maybe (Maybe Bool)@, @CollectErrors Bool@+  Examples: @Bool@, @Kleenean@, @CollectErrors Bool@ -} type IsBool t =   (HasBools t, CanNegSameType t, CanAndOrSameType t)

@@ -12,6 +12,7 @@     Instances for "Data.Complex". -} +{-# OPTIONS_GHC -Wno-orphans #-} module Numeric.MixedTypes.Complex (   tComplex@@ -32,7 +33,9 @@ import Numeric.MixedTypes.MinMaxAbs import Numeric.MixedTypes.AddSub import Numeric.MixedTypes.Ring-import Numeric.MixedTypes.Field+import Numeric.MixedTypes.Div+-- import Numeric.MixedTypes.Power+-- import Numeric.MixedTypes.Field import Numeric.MixedTypes.Elementary  tComplex :: T t -> T (Complex t)@@ -116,10 +119,6 @@   divide (a1 :+ i1) (a2 :+ i2) =     let d = a2*a2 + i2*i2 in     ((a1*a2 + i1*i2)/d) :+ ((i1*a2-a1*i2)/d)-  type DivTypeNoCN (Complex a) (Complex b) = Complex (DivTypeNoCN (MulType a b) (MulType b b))-  divideNoCN (a1 :+ i1) (a2 :+ i2) =-    let d = a2*a2 + i2*i2 in-    ((a1*a2 + i1*i2)/!d) :+ ((i1*a2-a1*i2)/!d)  instance   (CanMulAsymmetric t t@@ -194,16 +193,10 @@       divide n (a2 :+ i2) =         let d = a2*a2 + i2*i2 in         ((n*a2)/d) :+ (((-n)*i2)/d)-      type DivTypeNoCN $t (Complex b) = Complex (DivTypeNoCN (MulType $t b) (MulType b b))-      divideNoCN n (a2 :+ i2) =-        let d = a2*a2 + i2*i2 in-        ((n*a2)/!d) :+ (((-n)*i2)/!d)      instance       (CanDiv a $t) => CanDiv (Complex a) $t       where       type DivType (Complex a) $t = Complex (DivType a $t)       divide (a1 :+ i1) n = (a1/n) :+ (i1/n)-      type DivTypeNoCN (Complex a) $t = Complex (DivTypeNoCN a $t)-      divideNoCN (a1 :+ i1) n = (a1/!n) :+ (i1/!n)   |]))

@@ -0,0 +1,208 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-|+    Module      :  Numeric.MixedType.Div+    Description :  Bottom-up typed division+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++-}++module Numeric.MixedTypes.Div+(+  -- * Division+    CanDiv(..), CanDivBy, CanDivSameType+  , CanRecip, CanRecipSameType+  , (/), recip+  -- ** Tests+  , specCanDiv, specCanDivNotMixed+)+where++import Utils.TH.DeclForTypes++import Numeric.MixedTypes.PreludeHiding+import qualified Prelude as P+import Text.Printf++-- import qualified Data.List as List++import Test.Hspec+import Test.QuickCheck++import Numeric.CollectErrors ( CN, cn )+import qualified Numeric.CollectErrors as CN++import Numeric.MixedTypes.Literals+import Numeric.MixedTypes.Bool+import Numeric.MixedTypes.Eq+-- import Numeric.MixedTypes.Ord+-- import Numeric.MixedTypes.MinMaxAbs+-- import Numeric.MixedTypes.AddSub+import Numeric.MixedTypes.Ring++{---- Division -----}++{-|+  A replacement for Prelude's binary `P./`.  If @t1 = t2@ and @Fractional t1@,+  then one can use the default implementation to mirror Prelude's @/@.+-}+class CanDiv t1 t2 where+  type DivType t1 t2+  type DivType t1 t2 = t1+  divide :: t1 -> t2 -> DivType t1 t2++divideCN ::+  (CanTestZero t2)+  =>+  (t1 -> t2 -> t3) ->+  CN t1 -> CN t2 -> CN t3+divideCN unsafeDivide a b+  | isCertainlyZero b = CN.noValueNumErrorCertain e+  | isCertainlyNonZero b = r+  | otherwise = CN.noValueNumErrorPotential e+  where+  r = CN.lift2 unsafeDivide a b+  e :: CN.NumError+  e = CN.DivByZero++infixl 7  /++(/) :: (CanDiv t1 t2) => t1 -> t2 -> DivType t1 t2+(/) = divide++type CanRecip t =+  (CanDiv Integer t)++type CanRecipSameType t =+  (CanDiv Integer t, DivType Integer t ~ t)++recip :: (CanRecip t) => t -> DivType Integer t+recip = divide 1++type CanDivBy t1 t2 =+  (CanDiv t1 t2, DivType t1 t2 ~ t1)+type CanDivSameType t =+  CanDivBy t t++{-|+  HSpec properties that each implementation of CanDiv should satisfy.+ -}+specCanDiv ::+  _ => T t1 -> T t2 -> Spec+specCanDiv (T typeName1 :: T t1) (T typeName2 :: T t2) =+  describe (printf "CanDiv %s %s" typeName1 typeName2) $ do+    it "recip(recip x) = x" $ do+      property $ \ (x :: t1) ->+        (isCertainlyNonZero x && isCertainlyNonZero (recip x)) ==>+          recip (recip x) ?==?$ x+    it "x/1 = x" $ do+      property $ \ (x :: t1) -> let one = (convertExactly 1 :: t2) in (x / one) ?==?$ x+    it "x/x = 1" $ do+      property $ \ (x :: t1) ->+        (isCertainlyNonZero x) ==>+          let one = (convertExactly 1 :: t1) in (x / x) ?==?$ one+    it "x/y = x*(1/y)" $ do+      property $ \ (x :: t1) (y :: t2) ->+        (isCertainlyNonZero y) ==>+          let one = (convertExactly 1 :: t1) in (x / y) ?==?$ x * (one/y)+  where+  infix 4 ?==?$+  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property+  (?==?$) = printArgsIfFails2 "?==?" (?==?)++{-|+  HSpec properties that each implementation of CanDiv should satisfy.+ -}+specCanDivNotMixed ::+  _ => T t -> Spec+specCanDivNotMixed (t :: T t) = specCanDiv t t++instance CanDiv Int Int where+  type DivType Int Int = Rational+  divide a b = (P./) (rational a) (rational b)++instance CanDiv Integer Integer where+  type DivType Integer Integer = Rational+  divide a b = (P./) (rational a) (rational b)+instance CanDiv Rational Rational where+  type DivType Rational Rational = Rational+  divide = (P./)++instance CanDiv Int Integer where+  type DivType Int Integer = Rational+  divide a b = (P./) (rational a) (rational b)+instance CanDiv Integer Int where+  type DivType Integer Int = Rational+  divide a b = (P./) (rational a) (rational b)++instance CanDiv Int Rational where+  type DivType Int Rational = Rational+  divide = convertFirst divide+instance CanDiv Rational Int where+  divide = convertSecond divide++instance CanDiv Integer Rational where+  type DivType Integer Rational = Rational+  divide = convertFirst divide+instance CanDiv Rational Integer where+  divide = convertSecond divide++instance CanDiv Double Double where+  divide = (P./)++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |]]+  (\ t -> [d|++    instance CanDiv $t Double where+      type DivType $t Double = Double+      divide n d = divide (double n) d+    instance CanDiv Double $t where+      type DivType Double $t = Double+      divide d n = divide d (double n)+  |]))++instance (CanDiv a b) => CanDiv [a] [b] where+  type DivType [a] [b] = [DivType a b]+  divide (x:xs) (y:ys) = (divide x y) : (divide xs ys)+  divide _ _ = []++instance (CanDiv a b) => CanDiv (Maybe a) (Maybe b) where+  type DivType (Maybe a) (Maybe b) = Maybe (DivType a b)+  divide (Just x) (Just y) = Just (divide x y)+  divide _ _ = Nothing++instance+  (CanDiv a b, CanTestZero b)+  =>+  CanDiv (CN a) (CN  b)+  where+  type DivType (CN a) (CN b) = CN (DivType a b)+  divide  = divideCN divide++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]+  (\ t -> [d|++    instance+      (CanDiv $t b, CanTestZero b)+      =>+      CanDiv $t (CN  b)+      where+      type DivType $t (CN b) = CN (DivType $t b)+      divide a b = divideCN divide (cn a) b++    instance+      (CanDiv a $t)+      =>+      CanDiv (CN a) $t+      where+      type DivType (CN a) $t = CN (DivType a $t)+      divide a b = divideCN divide a (cn b)+  |]))

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-|     Module      :  Numeric.MixedType.Elementary     Description :  Bottom-up typed pi, sqrt, cos, etc@@ -9,15 +11,14 @@     Portability :  portable  -}- module Numeric.MixedTypes.Elementary (   -- * Square root-  CanSqrt(..), CanSqrtSameType, CanSqrtCNSameType, specCanSqrtReal+  CanSqrt(..), CanSqrtSameType, specCanSqrtReal   -- * Exp   , CanExp(..), CanExpSameType, specCanExpReal   -- * Log-  , CanLog(..), CanLogSameType, CanLogCNSameType, specCanLogReal+  , CanLog(..), CanLogSameType, specCanLogReal   , powUsingExpLog   -- * Sine and cosine   , CanSinCos(..), CanSinCosSameType, specCanSinCosReal@@ -34,17 +35,18 @@ import Test.Hspec import Test.QuickCheck -import Numeric.CollectErrors-import Control.CollectErrors+import Numeric.CollectErrors ( CN )+import qualified Numeric.CollectErrors as CN  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool import Numeric.MixedTypes.Eq import Numeric.MixedTypes.Ord--- import Numeric.MixedTypes.MinMaxAbs+import Numeric.MixedTypes.MinMaxAbs import Numeric.MixedTypes.AddSub import Numeric.MixedTypes.Ring import Numeric.MixedTypes.Field+import Numeric.MixedTypes.Power -- import Numeric.MixedTypes.Round  import Utils.Test.EnforceRange @@ -63,21 +65,12 @@   sqrt = P.sqrt  type CanSqrtSameType t = (CanSqrt t, SqrtType t ~ t)-type CanSqrtCNSameType t = (CanSqrt t, SqrtType t ~ EnsureCN t)  {-|   HSpec properties that each implementation of CanSqrt should satisfy.  -} specCanSqrtReal ::-  (Show t, Show (SqrtType t), Show (PowType (SqrtType t) Integer),-    Arbitrary t,-    CanTestCertainly (OrderCompareType (SqrtType t) Integer),-    CanTestCertainly (EqCompareType (PowType (SqrtType t) Integer) t),-    HasEqAsymmetric (PowType (SqrtType t) Integer) t,-    HasOrderAsymmetric (SqrtType t) Integer, CanTestPosNeg t,-    CanPow (SqrtType t) Integer, CanSqrt t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanSqrtReal (T typeName :: T t) =   describe (printf "CanSqrt %s" typeName) $ do     it "sqrt(x) >= 0" $ do@@ -104,15 +97,18 @@ instance CanSqrt Double -- not exact, will not pass the tests  instance-  (CanSqrt a-  , CanEnsureCE es a-  , CanEnsureCE es (SqrtType a)-  , SuitableForCE es)+  (CanSqrt a, CanTestPosNeg a, CanMinMaxThis a Integer)   =>-  CanSqrt (CollectErrors es a)+  CanSqrt (CN a)   where-  type SqrtType (CollectErrors es a) = EnsureCE es (SqrtType a)-  sqrt = lift1CE sqrt+  type SqrtType (CN a) = CN (SqrtType a)+  sqrt x +    | isCertainlyNonNegative x = CN.lift sqrt x+    | isCertainlyNegative x = CN.noValueNumErrorCertain err+    | otherwise = CN.prependErrorPotential err $ CN.lift sqrt $ max x 0+    where+    err :: CN.NumError+    err = CN.OutOfDomain "negative sqrt argument"   {----  exp -----}@@ -134,33 +130,7 @@   HSpec properties that each implementation of CanExp should satisfy.  -} specCanExpReal ::-  (Show t, Show (ExpType t), Show (DivType Integer (ExpType t)),-   Show (ExpType (AddType t t)),-   Show (MulType (ExpType t) (ExpType t)),-   Show (EnsureCN (ExpType t)), Arbitrary t,-   CanEnsureCN (ExpType t),-   CanTestCertainly (OrderCompareType Integer t),-   CanTestCertainly (OrderCompareType t Integer),-   CanTestCertainly (OrderCompareType (ExpType t) Integer),-   CanTestCertainly-     (EqCompareType-        (EnsureCN (ExpType t)) (DivType Integer (ExpType t))),-   CanTestCertainly-     (EqCompareType-        (ExpType (AddType t t)) (MulType (ExpType t) (ExpType t))),-   CanNeg t,-   HasEqAsymmetric-     (ExpType (AddType t t)) (MulType (ExpType t) (ExpType t)),-   HasEqAsymmetric-     (EnsureCN (ExpType t)) (DivType Integer (ExpType t)),-   HasOrderAsymmetric t Integer,-   HasOrderAsymmetric (ExpType t) Integer,-   HasOrderAsymmetric Integer t, CanAddAsymmetric t t,-   CanMulAsymmetric (ExpType t) (ExpType t),-   CanDiv Integer (ExpType t), CanExp t, CanExp (AddType t t),-   NegType t ~ t, -   CanEnforceRange t Integer) =>-   T t -> Spec+  _ => T t -> Spec specCanExpReal (T typeName :: T t) =   describe (printf "CanExp %s" typeName) $ do     it "exp(x) >= 0" $ do@@ -172,7 +142,7 @@         let x = enforceRange (Just (-100000), Just 100000) x_ in         let ex = exp x in           (ex !>! 0) ==>-            (ensureCN $ exp (-x)) ?==?$ 1/ex+            (exp (-x)) ?==?$ 1/ex     it "exp(x+y) = exp(x)*exp(y)" $ do       property $ \ (x_ :: t)  (y_ :: t) ->         let x = enforceRange (Just (-100000), Just 100000) x_ in@@ -194,15 +164,10 @@ instance CanExp Double -- not exact, will not pass the tests  instance-  (CanExp a-  , CanEnsureCE es a-  , CanEnsureCE es (ExpType a)-  , SuitableForCE es)-  =>-  CanExp (CollectErrors es a)+  (CanExp a) => CanExp (CN a)   where-  type ExpType (CollectErrors es a) = EnsureCE es (ExpType a)-  exp = lift1CE exp+  type ExpType (CN a) = CN (ExpType a)+  exp = CN.lift exp  {----  log -----} @@ -218,42 +183,12 @@   log = P.log  type CanLogSameType t = (CanLog t, LogType t ~ t)-type CanLogCNSameType t = (CanLog t, LogType t ~ EnsureCN t)  {-|   HSpec properties that each implementation of CanLog should satisfy.  -} specCanLogReal ::-  (Show t, Show (LogType t), Show (LogType (DivType Integer t)),-   Show (LogType (MulType t t)),-   Show (AddType (LogType t) (LogType t)), Show (LogType (ExpType t)),-   Arbitrary t, CanTestCertainly (OrderCompareType t Integer),-   CanTestCertainly (OrderCompareType (DivType Integer t) Integer),-   CanTestCertainly-     (EqCompareType (LogType (DivType Integer t)) (LogType t)),-   CanTestCertainly (OrderCompareType (MulType t t) Integer),-   CanTestCertainly (OrderCompareType (ExpType t) Integer),-   CanTestCertainly-     (EqCompareType-        (LogType (MulType t t)) (AddType (LogType t) (LogType t))),-   CanTestCertainly (OrderCompareType Integer t),-   CanTestCertainly (EqCompareType (LogType (ExpType t)) t),-   CanNeg (LogType t),-   HasEqAsymmetric (LogType (DivType Integer t)) (LogType t),-   HasEqAsymmetric-     (LogType (MulType t t)) (AddType (LogType t) (LogType t)),-   HasEqAsymmetric (LogType (ExpType t)) t,-   HasOrderAsymmetric t Integer,-   HasOrderAsymmetric (DivType Integer t) Integer,-   HasOrderAsymmetric (MulType t t) Integer,-   HasOrderAsymmetric (ExpType t) Integer,-   HasOrderAsymmetric Integer t,-   CanAddAsymmetric (LogType t) (LogType t), CanMulAsymmetric t t,-   CanDiv Integer t, CanExp t, CanLog t, CanLog (DivType Integer t),-   CanLog (MulType t t), CanLog (ExpType t),-   LogType t ~ NegType (LogType t),-   CanEnforceRange t Integer) =>-  T t -> Spec+  _ => T t -> Spec specCanLogReal (T typeName :: T t) =   describe (printf "CanLog %s" typeName) $ do     it "log(1/x) == -(log x)" $ do@@ -286,65 +221,36 @@ instance CanLog Double -- not exact, will not pass the tests  instance-  (CanLog a-  , CanEnsureCE es a-  , CanEnsureCE es (LogType a)-  , SuitableForCE es)+  (CanLog a, CanTestPosNeg a)   =>-  CanLog (CollectErrors es a)+  CanLog (CN a)   where-  type LogType (CollectErrors es a) = EnsureCE es (LogType a)-  log = lift1CE log+  type LogType (CN a) = CN (LogType a)+  log x +    | isCertainlyPositive x = logx+    | isCertainlyNonPositive x = CN.noValueNumErrorCertain err+    | otherwise = CN.noValueNumErrorPotential err+    where+    logx = CN.lift log x+    err :: CN.NumError+    err = CN.OutOfDomain "log argument not positive" -instance CanPow Double Double where-  powNoCN = (P.**)-  type PowType Double Double = Double-  pow = (P.**)-instance CanPow Double Rational where-  powNoCN b e = b ^! (double e)-  type PowType Double Rational = Double-  pow b e = b ^ (double e)-instance CanPow Rational Double where-  type PowTypeNoCN Rational Double = Double-  powNoCN b e = (double b) ^! e-  type PowType Rational Double = Double-  pow b e = (double b) ^ e-instance CanPow Integer Double where-  type PowTypeNoCN Integer Double = Double-  powNoCN b e = (double b) ^! e-  type PowType Integer Double = Double-  pow b e = (double b) ^ e-instance CanPow Int Double where-  type PowTypeNoCN Int Double = Double-  powNoCN b e = (double b) ^! e-  type PowType Int Double = Double-  pow b e = (double b) ^ e  powUsingExpLog ::-  (CanTestPosNeg t,-   CanEnsureCN t,-   CanEnsureCN (EnsureCN t),-   EnsureCN t ~ EnsureCN (EnsureCN t),-   CanLogCNSameType t,+  (CanLogSameType t,+   CanExpSameType t,    CanMulSameType t,-   CanMulSameType (EnsureCN t),-   CanExpSameType (EnsureCN t),    CanTestInteger t,    CanTestZero t,-   CanRecipCNSameType t)+   CanRecipSameType t)   =>-  t -> t -> t -> t -> EnsureCN t-powUsingExpLog zero one b e =+  t -> t -> t -> t+powUsingExpLog one b e =   case certainlyIntegerGetIt e of     Just n ->       powUsingMulRecip one b n-    Nothing-      | isCertainlyZero b && isCertainlyPositive e -> cn zero-      | isCertainlyNonNegative b -> exp ((log b) * (ensureCN e))-      | isCertainlyNegative b && certainlyNotInteger e -> noValueNumErrorCertainECN (Just b) err-      | otherwise -> noValueNumErrorPotentialECN (Just b) err-  where-  err = NumError "powUsingExpLog: illegal power a^b with negative a and non-integer b"+    Nothing ->+      exp ((log b) * (e))  {----  sine and cosine -----} @@ -371,81 +277,7 @@   http://math.stackexchange.com/questions/1303044/axiomatic-definition-of-sin-and-cos  -} specCanSinCosReal ::- (Show t, Show (SinCosType t),-  Show-    (AddType-       (PowType (SinCosType t) Integer) (PowType (SinCosType t) Integer)),-  Show (SinCosType (SubType t t)),-  Show-    (SubType-       (MulType (SinCosType t) (SinCosType t))-       (MulType (SinCosType t) (SinCosType t))),-  Show-    (AddType-       (MulType (SinCosType t) (SinCosType t))-       (MulType (SinCosType t) (SinCosType t))),-  Show (DivType (SinCosType t) (SinCosType t)),-  Show (EnsureCN t), Arbitrary t, CanEnsureCN t,-  CanTestCertainly (OrderCompareType Integer (SinCosType t)),-  CanTestCertainly (OrderCompareType (SinCosType t) Integer),-  CanTestCertainly-    (EqCompareType-       (AddType-          (PowType (SinCosType t) Integer)-          (PowType (SinCosType t) Integer))-       Integer),-  CanTestCertainly-    (EqCompareType-       (SinCosType (SubType t t))-       (SubType-          (MulType (SinCosType t) (SinCosType t))-          (MulType (SinCosType t) (SinCosType t)))),-  CanTestCertainly-    (EqCompareType-       (SinCosType (SubType t t))-       (AddType-          (MulType (SinCosType t) (SinCosType t))-          (MulType (SinCosType t) (SinCosType t)))),-  CanTestCertainly (OrderCompareType t Integer),-  CanTestCertainly (OrderCompareType t Rational),-  CanTestCertainly (OrderCompareType (SinCosType t) t),-  CanTestCertainly-    (OrderCompareType-       (EnsureCN t) (DivType (SinCosType t) (SinCosType t))),-  HasEqAsymmetric-    (AddType-       (PowType (SinCosType t) Integer) (PowType (SinCosType t) Integer))-    Integer,-  HasEqAsymmetric-    (SinCosType (SubType t t))-    (SubType-       (MulType (SinCosType t) (SinCosType t))-       (MulType (SinCosType t) (SinCosType t))),-  HasEqAsymmetric-    (SinCosType (SubType t t))-    (AddType-       (MulType (SinCosType t) (SinCosType t))-       (MulType (SinCosType t) (SinCosType t))),-  HasOrderAsymmetric t Integer, HasOrderAsymmetric t Rational,-  HasOrderAsymmetric (SinCosType t) t,-  HasOrderAsymmetric (SinCosType t) Integer,-  HasOrderAsymmetric-    (EnsureCN t) (DivType (SinCosType t) (SinCosType t)),-  HasOrderAsymmetric Integer (SinCosType t), CanSub t t,-  CanSub-    (MulType (SinCosType t) (SinCosType t))-    (MulType (SinCosType t) (SinCosType t)),-  CanAddAsymmetric-    (PowType (SinCosType t) Integer) (PowType (SinCosType t) Integer),-  CanAddAsymmetric-    (MulType (SinCosType t) (SinCosType t))-    (MulType (SinCosType t) (SinCosType t)),-  CanPow (SinCosType t) Integer,-  CanMulAsymmetric (SinCosType t) (SinCosType t),-  CanDiv (SinCosType t) (SinCosType t), CanSinCos t,-  CanSinCos (SubType t t))-  =>-  T t -> Spec+  _ => T t -> Spec specCanSinCosReal (T typeName :: T t) =   describe (printf "CanSinCos %s" typeName) $ do     it "-1 <= sin(x) <= 1" $ do@@ -466,7 +298,7 @@     it "sin(x) < x < tan(x) for x in [0,pi/2]" $ do       property $ \ (x :: t) ->         x !>=! 0 && x !<=! 1.57 && (cos x) !>! 0 ==>-          (sin x) ?<=?$ x .&&. (ensureCN x) ?<=?$ (sin x)/(cos x)+          (sin x) ?<=?$ x .&&. (x) ?<=?$ (sin x)/(cos x)   where   infix 4 ?==?$   (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property@@ -483,16 +315,11 @@ instance CanSinCos Double -- not exact, will not pass the tests  instance-  (CanSinCos a-  , CanEnsureCE es a-  , CanEnsureCE es (SinCosType a)-  , SuitableForCE es)-  =>-  CanSinCos (CollectErrors es a)+  (CanSinCos a) => CanSinCos (CN a)   where-  type SinCosType (CollectErrors es a) = EnsureCE es (SinCosType a)-  sin = lift1CE sin-  cos = lift1CE cos+  type SinCosType (CN a) = CN (SinCosType a)+  sin = CN.lift sin+  cos = CN.lift cos  {-|   Approximate pi, synonym for Prelude's `P.pi`.

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.Eq@@ -15,7 +17,6 @@   -- * Equality checks   HasEq,  HasEqAsymmetric(..), (==), (/=)   , HasEqCertainly, HasEqCertainlyAsymmetric-  , HasEqCertainlyCE, HasEqCertainlyCN   , notCertainlyDifferentFrom, certainlyEqualTo, certainlyNotEqualTo   , (?==?), (!==!), (!/=!)   -- ** Tests@@ -40,8 +41,8 @@ import Test.Hspec import Test.QuickCheck as QC -import Numeric.CollectErrors-import Control.CollectErrors+import Control.CollectErrors ( CollectErrors, CanBeErrors )+import qualified Control.CollectErrors as CE  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -62,19 +63,6 @@ type HasEqCertainly t1 t2 =   (HasEq t1 t2, CanTestCertainly (EqCompareType t1 t2)) -type HasEqCertainlyCE es t1 t2 =-  (HasEqCertainly t1 t2,-   HasEqCertainly (EnsureCE es t1) (EnsureCE es t2))-  --  HasEqCertainly (WithoutCE es t1) (WithoutCE es t2),-  --  CanTestCertainly (WithoutCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  IsBool (WithoutCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  CanEnsureCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2)),-  --  CanEnsureCE es (WithoutCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  WithoutCE es (WithoutCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2)))-  --    ~ (WithoutCE es (EqCompareType (WithoutCE es t1) (WithoutCE es t2))))--type HasEqCertainlyCN t1 t2 = HasEqCertainlyCE NumErrors t1 t2- class (IsBool (EqCompareType a b)) => HasEqAsymmetric a b where     type EqCompareType a b     type EqCompareType a b = Bool -- default@@ -113,19 +101,8 @@ {-|   HSpec properties that each implementation of HasEq should satisfy.  -}-specHasEq ::- (Show t1, Show t2, Show t3, Arbitrary t1, Arbitrary t2,-  Arbitrary t3, CanTestCertainly (EqCompareType t1 t1),-  CanTestCertainly (EqCompareType t1 t2),-  CanTestCertainly (EqCompareType t2 t1),-  CanTestCertainly (EqCompareType t2 t3),-  CanTestCertainly-    (AndOrType (EqCompareType t1 t2) (EqCompareType t2 t3)),-  CanAndOrAsymmetric (EqCompareType t1 t2) (EqCompareType t2 t3),-  HasEqAsymmetric t1 t1, HasEqAsymmetric t1 t2,-  HasEqAsymmetric t2 t1, HasEqAsymmetric t2 t3)-  =>-  T t1 -> T t2 -> T t3 -> Spec+specHasEq :: +  _ => T t1 -> T t2 -> T t3 -> Spec specHasEq (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "HasEq %s %s, HasEq %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "has reflexive ==" $ do@@ -143,12 +120,7 @@   HSpec properties that each implementation of HasEq should satisfy.  -} specHasEqNotMixed ::-  (Show t, Arbitrary t, CanTestCertainly (EqCompareType t t),-   CanTestCertainly-     (AndOrType (EqCompareType t t) (EqCompareType t t)),-   HasEqAsymmetric t t)-  =>-  T t -> Spec+  _ => T t -> Spec specHasEqNotMixed (t :: T t) = specHasEq t t t  {-|@@ -249,47 +221,35 @@   equalTo _ _ = convertExactly False  instance-  (HasEqAsymmetric a b-  , CanEnsureCE es (EqCompareType a b)-  , CanEnsureCE es a, CanEnsureCE es b-  , IsBool (EnsureCE es (EqCompareType a b))-  , SuitableForCE es)+  (HasEqAsymmetric a b, CanBeErrors es)   =>   HasEqAsymmetric (CollectErrors es a) (CollectErrors es  b)   where   type EqCompareType (CollectErrors es  a) (CollectErrors es  b) =-    EnsureCE es (EqCompareType a b)-  equalTo = lift2CE equalTo+    CollectErrors es (EqCompareType a b)+  equalTo = CE.lift2 equalTo  $(declForTypes   [[t| Bool |], [t| Maybe Bool |], [t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]   (\ t -> [d|      instance-      (HasEqAsymmetric $t b-      , CanEnsureCE es b-      , CanEnsureCE es (EqCompareType $t b)-      , IsBool (EnsureCE es (EqCompareType $t b))-      , SuitableForCE es)+      (HasEqAsymmetric $t b, CanBeErrors es)       =>       HasEqAsymmetric $t (CollectErrors es  b)       where       type EqCompareType $t (CollectErrors es  b) =-        EnsureCE es (EqCompareType $t b)-      equalTo = lift2TLCE equalTo+        CollectErrors es (EqCompareType $t b)+      equalTo = CE.liftT1 equalTo      instance-      (HasEqAsymmetric a $t-      , CanEnsureCE es a-      , CanEnsureCE es (EqCompareType a $t)-      , IsBool (EnsureCE es (EqCompareType a $t))-      , SuitableForCE es)+      (HasEqAsymmetric a $t, CanBeErrors es)       =>       HasEqAsymmetric (CollectErrors es a) $t       where       type EqCompareType (CollectErrors es  a) $t =-        EnsureCE es (EqCompareType a $t)-      equalTo = lift2TCE equalTo+        CollectErrors es (EqCompareType a $t)+      equalTo = CE.lift1T equalTo    |])) @@ -326,12 +286,12 @@   isInfinite = const False   isFinite = const True -instance (CanTestNaN t, SuitableForCE es) => (CanTestNaN (CollectErrors es t)) where-  isNaN ce = getValueIfNoErrorCE ce isNaN (const False)+instance (CanTestNaN t, CanBeErrors es) => (CanTestNaN (CollectErrors es t)) where+  isNaN = CE.withErrorOrValue (const False) isNaN -instance (CanTestFinite t, SuitableForCE es) => (CanTestFinite (CollectErrors es t)) where-  isInfinite ce = getValueIfNoErrorCE ce isInfinite (const False)-  isFinite ce = getValueIfNoErrorCE ce isFinite (const False)+instance (CanTestFinite t, CanBeErrors es) => (CanTestFinite (CollectErrors es t)) where+  isInfinite = CE.withErrorOrValue (const False) isInfinite+  isFinite = CE.withErrorOrValue (const False) isFinite  {---- Checking whether it is an integer -----} @@ -369,9 +329,9 @@       dF = P.floor d       dC = P.ceiling d -instance (CanTestInteger t, SuitableForCE es) => (CanTestInteger (CollectErrors es t)) where-  certainlyNotInteger ce = getValueIfNoErrorCE ce certainlyNotInteger (const False)-  certainlyIntegerGetIt ce = getValueIfNoErrorCE ce certainlyIntegerGetIt (const Nothing)+instance (CanTestInteger t, CanBeErrors es) => (CanTestInteger (CollectErrors es t)) where+  certainlyNotInteger = CE.withErrorOrValue (const False) certainlyNotInteger+  certainlyIntegerGetIt = CE.withErrorOrValue (const Nothing) certainlyIntegerGetIt  {---- Checking whether it is zero -----} @@ -406,9 +366,9 @@ instance CanTestZero Rational instance CanTestZero Double -instance (CanTestZero t, SuitableForCE es) => (CanTestZero (CollectErrors es t)) where-  isCertainlyZero ce = getValueIfNoErrorCE ce isCertainlyZero (const False)-  isCertainlyNonZero ce = getValueIfNoErrorCE ce isCertainlyNonZero (const False)+instance (CanTestZero t, CanBeErrors es) => (CanTestZero (CollectErrors es t)) where+  isCertainlyZero = CE.withErrorOrValue (const False) isCertainlyZero+  isCertainlyNonZero = CE.withErrorOrValue (const False) isCertainlyNonZero   class CanPickNonZero t where@@ -457,9 +417,9 @@ instance CanPickNonZero Integer instance CanPickNonZero Rational -instance (CanPickNonZero a, SuitableForCE es) => (CanPickNonZero (CollectErrors es a)) where+instance (CanPickNonZero a, CanBeErrors es) => (CanPickNonZero (CollectErrors es a)) where   pickNonZero =     fmap (\(v,s) -> (pure v,s))     . pickNonZero-    . filterValuesWithoutErrorCE+    . CE.filterValuesWithoutError     . (map (\(vCN,s) -> fmap (\v -> (v,s)) vCN))

@@ -14,50 +14,40 @@ module Numeric.MixedTypes.Field (   -- * Field-  CanAddSubMulDivCNBy, Field, OrderedField, OrderedCertainlyField+  CanAddSubMulDivBy, Field, OrderedField, OrderedCertainlyField   -- * Division-  , CanDiv(..), CanDivBy, CanDivCNBy, CanDivSameType, CanDivCNSameType-  , CanRecip, CanRecipSameType, CanRecipCNSameType-  , (/), (/!), recip-  , powUsingMulRecip-  -- ** Tests-  , specCanDiv, specCanDivNotMixed+  , module Numeric.MixedTypes.Div ) where -import Utils.TH.DeclForTypes- import Numeric.MixedTypes.PreludeHiding-import qualified Prelude as P-import Text.Printf---- import qualified Data.List as List--import Test.Hspec-import Test.QuickCheck+-- import qualified Prelude as P -import Numeric.CollectErrors-import Control.CollectErrors+import Numeric.CollectErrors ( CN )+-- import qualified Numeric.CollectErrors as CN -import Numeric.MixedTypes.Literals-import Numeric.MixedTypes.Bool-import Numeric.MixedTypes.Eq+-- import Numeric.MixedTypes.Literals+-- import Numeric.MixedTypes.Bool+-- import Numeric.MixedTypes.Eq import Numeric.MixedTypes.Ord -- import Numeric.MixedTypes.MinMaxAbs -- import Numeric.MixedTypes.AddSub import Numeric.MixedTypes.Ring+import Numeric.MixedTypes.Div+import Numeric.MixedTypes.Power  {----- Field -----} -type CanAddSubMulDivCNBy t s =-  (CanAddSubMulBy t s, CanAddSubMulBy (EnsureCN t) s, CanDivCNBy t s)+type CanAddSubMulDivBy t s =+  (CanAddSubMulBy t s, CanAddSubMulBy t s, CanDivBy t s)  class   (Ring t,-   CanDivCNSameType t, CanRecipCNSameType t,-   CanAddSubMulDivCNBy t Rational,-   CanAddSubMulDivCNBy t Integer,-   CanAddSubMulDivCNBy t Int+   CanPowBy t Integer, CanPowBy t Int,+   CanDivSameType t, CanRecipSameType t,+   CanAddSubMulDivBy t Rational,+   CanAddSubMulDivBy t Integer,+   CanAddSubMulDivBy t Int   )   =>   Field t@@ -66,281 +56,15 @@ instance Field (CN Rational)  class-  (Field t, OrderedRing t, HasOrder t Rational, HasOrder (EnsureCN t) Rational)+  (Field t, OrderedRing t, HasOrder t Rational, HasOrder t Rational)   => OrderedField t  instance OrderedField Rational instance OrderedField (CN Rational)  class-  (Field t, OrderedCertainlyRing t, HasOrderCertainly t Rational, HasOrderCertainly (EnsureCN t) Rational)+  (Field t, OrderedCertainlyRing t, HasOrderCertainly t Rational, HasOrderCertainly t Rational)   => OrderedCertainlyField t  instance OrderedCertainlyField Rational instance OrderedCertainlyField (CN Rational)--{---- Division -----}--{-|-  A replacement for Prelude's binary `P./`.  If @t1 = t2@ and @Fractional t1@,-  then one can use the default implementation to mirror Prelude's @/@.--}-class CanDiv t1 t2 where-  type DivTypeNoCN t1 t2-  divideNoCN :: t1 -> t2 -> DivTypeNoCN t1 t2-  type DivType t1 t2-  type DivType t1 t2 = EnsureCN (DivTypeNoCN t1 t2)-  divide :: t1 -> t2 -> DivType t1 t2-  default divide ::-    (CanTestZero t2, CanEnsureCN (DivTypeNoCN t1 t2)-    , DivType t1 t2 ~ EnsureCN (DivTypeNoCN t1 t2))-    =>-    t1 -> t2 -> DivType t1 t2-  divide = divideCN divideNoCN--divideCN ::-  (CanTestZero t2, CanEnsureCN t3)-  =>-  (t1 -> t2 -> t3) ->-  t1 -> t2 -> EnsureCN t3-divideCN unsafeDivide a b-  | isCertainlyZero b = noValueNumErrorCertainECN sample_v DivByZero-  | isCertainlyNonZero b = ensureCN $ a `unsafeDivide` b-  | otherwise = noValueNumErrorPotentialECN sample_v DivByZero-  where-  sample_v = Just $ unsafeDivide a b--infixl 7  /,/!--(/) :: (CanDiv t1 t2) => t1 -> t2 -> DivType t1 t2-(/) = divide--(/!) :: (CanDiv t1 t2) => t1 -> t2 -> DivTypeNoCN t1 t2-(/!) = divideNoCN--type CanRecip t =-  (CanDiv Integer t)--type CanRecipSameType t =-  (CanDiv Integer t, DivType Integer t ~ t, DivTypeNoCN Integer t ~ t)--type CanRecipCNSameType t =-  (CanDiv Integer t, DivType Integer t ~ EnsureCN t, DivTypeNoCN Integer t ~ t-  ,CanEnsureCN t-  ,CanDiv Integer (EnsureCN t), DivType Integer (EnsureCN t) ~ EnsureCN t, DivTypeNoCN Integer (EnsureCN t) ~ (EnsureCN t))--recip :: (CanRecip t) => t -> DivType Integer t-recip = divide 1--type CanDivBy t1 t2 =-  (CanDiv t1 t2, DivType t1 t2 ~ t1, DivTypeNoCN t1 t2 ~ t1)-type CanDivSameType t =-  CanDivBy t t--type CanDivCNBy t1 t2 =-  (CanDiv t1 t2, DivType t1 t2 ~ EnsureCN t1, DivTypeNoCN t1 t2 ~ t1-  , CanEnsureCN t1-  , CanDiv (EnsureCN t1) t2, DivType (EnsureCN t1) t2 ~ EnsureCN t1, DivTypeNoCN (EnsureCN t1) t2 ~ (EnsureCN t1))-type CanDivCNSameType t =-  (CanDivCNBy t t-  , CanDiv (EnsureCN t) (EnsureCN t), DivType (EnsureCN t) (EnsureCN t) ~ EnsureCN t, DivTypeNoCN (EnsureCN t) (EnsureCN t) ~ (EnsureCN t))--{-|-  HSpec properties that each implementation of CanDiv should satisfy.- -}-specCanDiv ::-  (Show t1, Show t2, Show (DivType Integer (DivType Integer t1)),-   Show (DivType t1 t2), Show (DivType t1 t1),-   Show (MulType t1 (DivType t1 t2)), Arbitrary t1, Arbitrary t2,-   ConvertibleExactly Integer t1, ConvertibleExactly Integer t2,-   CanTestCertainly-     (EqCompareType (DivType Integer (DivType Integer t1)) t1),-   CanTestCertainly (EqCompareType (DivType t1 t2) t1),-   CanTestCertainly (EqCompareType (DivType t1 t1) t1),-   CanTestCertainly-     (EqCompareType (DivType t1 t2) (MulType t1 (DivType t1 t2))),-   HasEqAsymmetric (DivType Integer (DivType Integer t1)) t1,-   HasEqAsymmetric (DivType t1 t2) t1,-   HasEqAsymmetric (DivType t1 t2) (MulType t1 (DivType t1 t2)),-   HasEqAsymmetric (DivType t1 t1) t1, CanTestZero t1, CanTestZero t2,-   CanTestZero (DivType Integer t1),-   CanMulAsymmetric t1 (DivType t1 t2), CanDiv t1 t1, CanDiv t1 t2,-   CanDiv Integer t1, CanDiv Integer (DivType Integer t1))-  =>-  T t1 -> T t2 -> Spec-specCanDiv (T typeName1 :: T t1) (T typeName2 :: T t2) =-  describe (printf "CanDiv %s %s" typeName1 typeName2) $ do-    it "recip(recip x) = x" $ do-      property $ \ (x :: t1) ->-        (isCertainlyNonZero x && isCertainlyNonZero (recip x)) ==>-          recip (recip x) ?==?$ x-    it "x/1 = x" $ do-      property $ \ (x :: t1) -> let one = (convertExactly 1 :: t2) in (x / one) ?==?$ x-    it "x/x = 1" $ do-      property $ \ (x :: t1) ->-        (isCertainlyNonZero x) ==>-          let one = (convertExactly 1 :: t1) in (x / x) ?==?$ one-    it "x/y = x*(1/y)" $ do-      property $ \ (x :: t1) (y :: t2) ->-        (isCertainlyNonZero y) ==>-          let one = (convertExactly 1 :: t1) in (x / y) ?==?$ x * (one/y)-  where-  infix 4 ?==?$-  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property-  (?==?$) = printArgsIfFails2 "?==?" (?==?)--{-|-  HSpec properties that each implementation of CanDiv should satisfy.- -}-specCanDivNotMixed ::-  (Show t, Show (DivType Integer (DivType Integer t)),-   Show (DivType t t), Show (MulType t (DivType t t)), Arbitrary t,-   ConvertibleExactly Integer t,-   CanTestCertainly-     (EqCompareType (DivType Integer (DivType Integer t)) t),-   CanTestCertainly (EqCompareType (DivType t t) t),-   CanTestCertainly-     (EqCompareType (DivType t t) (MulType t (DivType t t))),-   HasEqAsymmetric (DivType Integer (DivType Integer t)) t,-   HasEqAsymmetric (DivType t t) t,-   HasEqAsymmetric (DivType t t) (MulType t (DivType t t)),-   CanTestZero t, CanTestZero (DivType Integer t),-   CanMulAsymmetric t (DivType t t), CanDiv t t, CanDiv Integer t,-   CanDiv Integer (DivType Integer t))-  =>-  T t -> Spec-specCanDivNotMixed (t :: T t) = specCanDiv t t--instance CanDiv Int Int where-  type DivTypeNoCN Int Int = Rational-  divideNoCN a b = (P./) (rational a) (rational b)--instance CanDiv Integer Integer where-  type DivTypeNoCN Integer Integer = Rational-  divideNoCN a b = (P./) (rational a) (rational b)-instance CanDiv Rational Rational where-  type DivTypeNoCN Rational Rational = Rational-  divideNoCN = (P./)--instance CanDiv Int Integer where-  type DivTypeNoCN Int Integer = Rational-  divideNoCN a b = (P./) (rational a) (rational b)-instance CanDiv Integer Int where-  type DivTypeNoCN Integer Int = Rational-  divideNoCN a b = (P./) (rational a) (rational b)--instance CanDiv Int Rational where-  type DivTypeNoCN Int Rational = Rational-  divideNoCN = convertFirst divideNoCN-instance CanDiv Rational Int where-  type DivTypeNoCN Rational Int = Rational-  divideNoCN = convertSecond divideNoCN--instance CanDiv Integer Rational where-  type DivTypeNoCN Integer Rational = Rational-  divideNoCN = convertFirst divideNoCN-instance CanDiv Rational Integer where-  type DivTypeNoCN Rational Integer = Rational-  divideNoCN = convertSecond divideNoCN--instance CanDiv Double Double where-  type DivTypeNoCN Double Double = Double-  divideNoCN = (P./)-  type DivType Double Double = Double-  divide = (P./)--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |]]-  (\ t -> [d|--    instance CanDiv $t Double where-      type DivType $t Double = Double-      divide n d = divide (double n) d-      type DivTypeNoCN $t Double = Double-      divideNoCN n d = divide (double n) d-    instance CanDiv Double $t where-      type DivType Double $t = Double-      divide d n = divide d (double n)-      type DivTypeNoCN Double $t = Double-      divideNoCN d n = divide d (double n)-  |]))--instance (CanDiv a b) => CanDiv [a] [b] where-  type DivTypeNoCN [a] [b] = [DivTypeNoCN a b]-  divideNoCN (x:xs) (y:ys) = (divideNoCN x y) : (divideNoCN xs ys)-  divideNoCN _ _ = []-  type DivType [a] [b] = [DivType a b]-  divide (x:xs) (y:ys) = (divide x y) : (divide xs ys)-  divide _ _ = []--instance (CanDiv a b) => CanDiv (Maybe a) (Maybe b) where-  type DivType (Maybe a) (Maybe b) = Maybe (DivType a b)-  divide (Just x) (Just y) = Just (divide x y)-  divide _ _ = Nothing-  type DivTypeNoCN (Maybe a) (Maybe b) = Maybe (DivTypeNoCN a b)-  divideNoCN (Just x) (Just y) = Just (divideNoCN x y)-  divideNoCN _ _ = Nothing--instance-  (CanDiv a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (DivType a b)-  , CanEnsureCE es (DivTypeNoCN a b)-  , SuitableForCE es)-  =>-  CanDiv (CollectErrors es a) (CollectErrors es  b)-  where-  type DivType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (DivType a b)-  divide = lift2CE divide-  type DivTypeNoCN (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (DivTypeNoCN a b)-  divideNoCN = lift2CE divideNoCN--powUsingMulRecip ::-  (CanBeInteger e,-   CanRecipCNSameType t, CanMulSameType t, CanEnsureCN t)-   =>-   t -> t -> e -> EnsureCN t-powUsingMulRecip one x nPre-  | n < 0 = recip $ powUsingMul one x (negate n)-  | otherwise = ensureCN $ powUsingMul one x n-  where-  n = integer nPre--$(declForTypes-  [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]-  (\ t -> [d|--    instance-      (CanDiv $t b-      , CanEnsureCE es b-      , CanEnsureCE es (DivType $t b)-      , CanEnsureCE es (DivTypeNoCN $t b)-      , SuitableForCE es)-      =>-      CanDiv $t (CollectErrors es  b)-      where-      type DivType $t (CollectErrors es  b) =-        EnsureCE es (DivType $t b)-      divide = lift2TLCE divide-      type DivTypeNoCN $t (CollectErrors es  b) =-        EnsureCE es (DivTypeNoCN $t b)-      divideNoCN = lift2TLCE divideNoCN--    instance-      (CanDiv a $t-      , CanEnsureCE es a-      , CanEnsureCE es (DivType a $t)-      , CanEnsureCE es (DivTypeNoCN a $t)-      , SuitableForCE es)-      =>-      CanDiv (CollectErrors es a) $t-      where-      type DivType (CollectErrors es  a) $t =-        EnsureCE es (DivType a $t)-      divide = lift2TCE divide-      type DivTypeNoCN (CollectErrors es  a) $t =-        EnsureCE es (DivTypeNoCN a $t)-      divideNoCN = lift2TCE divideNoCN-  |]))

@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-|+    Module      :  Numeric.MixedType.Kleenean+    Description :  Three-valued logic+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++-}+module Numeric.MixedTypes.Kleenean+(+    Kleenean(..), kleenean+)+where++import Numeric.MixedTypes.PreludeHiding+import qualified Prelude as P++import Numeric.MixedTypes.Literals+    ( ConvertibleExactly(..), convertExactly )+import Numeric.MixedTypes.Bool+    ( (&&),+      not,+      CanAndOrAsymmetric(..),+      CanNeg(negate),+      CanTestCertainly(..),+      and )++data Kleenean = CertainTrue | CertainFalse | TrueOrFalse+  deriving (P.Eq, Show)++type CanBeKleenean t = ConvertibleExactly t Kleenean+kleenean :: (CanBeKleenean t) => t -> Kleenean+kleenean = convertExactly++instance ConvertibleExactly Kleenean Kleenean where+  safeConvertExactly = Right++instance ConvertibleExactly Bool Kleenean where+  safeConvertExactly True = Right CertainTrue+  safeConvertExactly False = Right CertainFalse++instance CanTestCertainly Kleenean where+  isCertainlyTrue = (P.== CertainTrue)+  isCertainlyFalse = (P.== CertainFalse)++instance CanNeg Kleenean where+  negate CertainTrue = CertainFalse+  negate CertainFalse = CertainTrue+  negate TrueOrFalse = TrueOrFalse++_testNeg1 :: Kleenean+_testNeg1 = not CertainTrue++instance CanAndOrAsymmetric Kleenean Kleenean+  where+  type AndOrType Kleenean Kleenean = Kleenean+  and2 CertainTrue CertainTrue = CertainTrue+  and2 CertainFalse _ = CertainFalse+  and2 _ CertainFalse = CertainFalse+  and2 _ _ = TrueOrFalse+  or2 CertainFalse CertainFalse = CertainFalse+  or2 CertainTrue _ = CertainTrue+  or2 _ CertainTrue = CertainTrue+  or2 _ _ = TrueOrFalse++instance CanAndOrAsymmetric Bool Kleenean+  where+  type AndOrType Bool Kleenean = Kleenean+  and2 b = and2 (kleenean b)+  or2 b = or2 (kleenean b)++instance CanAndOrAsymmetric Kleenean Bool+  where+  type AndOrType Kleenean Bool = Kleenean+  and2 k b = and2 k (kleenean b)+  or2 k b = or2 k (kleenean b)++_testAndOr1 :: Kleenean+_testAndOr1 = TrueOrFalse && False++_testAndOr2 :: Kleenean+_testAndOr2 = and [CertainTrue, TrueOrFalse, CertainFalse]+

@@ -49,7 +49,7 @@   -- * Prelude List operations versions without Int   , (!!), length, replicate, take, drop, splitAt   -- * Testing support functions-  , T(..), tInt, tInteger, tRational, tDouble+  , T(..), tInt, tInteger, tCNInteger, tRational, tCNRational, tDouble   , tBool, tMaybe, tMaybeBool, tMaybeMaybeBool   , specCanBeInteger   , printArgsIfFails2@@ -75,7 +75,7 @@ import Test.QuickCheck -- import Control.Exception (evaluate) --- import Numeric.CollectErrors+import Numeric.CollectErrors (CN) import Control.CollectErrors  {-| Replacement for 'Prelude.fromInteger' using the RebindableSyntax extension.@@ -251,9 +251,15 @@ tInteger :: T Integer tInteger = T "Integer" +tCNInteger :: T (CN Integer)+tCNInteger = T "(CN Integer)"+ tRational :: T Rational tRational = T "Rational" +tCNRational :: T (CN Rational)+tCNRational = T "(CN Rational)"+ tDouble :: T Double tDouble = T "Double" @@ -296,7 +302,7 @@ convertSecond = convertSecondUsing (\ _ b -> convertExactly b)  -- instance---   (ConvertibleExactly t1 t2, SuitableForCE es)+--   (ConvertibleExactly t1 t2, CanBeErrors es) --   => --   ConvertibleExactly t1 (CollectErrors es t2) --   where@@ -308,5 +314,5 @@   (\ t -> [d|      instance (ConvertibleExactly $t t, Monoid es) => ConvertibleExactly $t (CollectErrors es t) where-      safeConvertExactly = fmap (\v -> CollectErrors (Just v) mempty) . safeConvertExactly+      safeConvertExactly = fmap pure . safeConvertExactly   |]))

@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.MinMaxAbs@@ -36,8 +39,8 @@ import Test.Hspec import Test.QuickCheck --- import Numeric.CollectErrors-import Control.CollectErrors+import Control.CollectErrors ( CollectErrors, CanBeErrors )+import qualified Control.CollectErrors as CE  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -81,38 +84,7 @@   HSpec properties that each implementation of CanMinMax should satisfy.  -} specCanMinMax ::- (Show t1, Show t2, Show t3, Show (MinMaxType t1 t2),-  Show (MinMaxType t1 t1), Show (MinMaxType t2 t1),-  Show (MinMaxType t1 (MinMaxType t2 t3)),-  Show (MinMaxType (MinMaxType t1 t2) t3), Arbitrary t1,-  Arbitrary t2, Arbitrary t3, CanTestCertainly (EqCompareType t1 t1),-  CanTestCertainly (EqCompareType t2 t2),-  CanTestCertainly (OrderCompareType (MinMaxType t1 t2) t2),-  CanTestCertainly (OrderCompareType (MinMaxType t1 t2) t1),-  CanTestCertainly (EqCompareType (MinMaxType t1 t1) t1),-  CanTestCertainly-    (EqCompareType (MinMaxType t1 t2) (MinMaxType t2 t1)),-  CanTestCertainly (EqCompareType t3 t3),-  CanTestCertainly-    (EqCompareType-       (MinMaxType t1 (MinMaxType t2 t3))-       (MinMaxType (MinMaxType t1 t2) t3)),-  CanTestFinite t1, CanTestFinite t2, CanTestFinite t3,-  HasEqAsymmetric t1 t1, HasEqAsymmetric t2 t2,-  HasEqAsymmetric t3 t3,-  HasEqAsymmetric (MinMaxType t1 t2) (MinMaxType t2 t1),-  HasEqAsymmetric (MinMaxType t1 t1) t1,-  HasEqAsymmetric-    (MinMaxType t1 (MinMaxType t2 t3))-    (MinMaxType (MinMaxType t1 t2) t3),-  HasOrderAsymmetric (MinMaxType t1 t2) t1,-  HasOrderAsymmetric (MinMaxType t1 t2) t2,-  CanMinMaxAsymmetric t1 t1, CanMinMaxAsymmetric t1 t2,-  CanMinMaxAsymmetric t1 (MinMaxType t2 t3),-  CanMinMaxAsymmetric t2 t1, CanMinMaxAsymmetric t2 t3,-  CanMinMaxAsymmetric (MinMaxType t1 t2) t3)-  =>-  T t1 -> T t2 -> T t3 -> Spec+  _ => T t1 -> T t2 -> T t3 -> Spec specCanMinMax (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "CanMinMax %s %s, CanMinMax %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "`min` is not larger than its arguments" $ do@@ -167,30 +139,7 @@   HSpec properties that each implementation of CanMinMax should satisfy.  -} specCanMinMaxNotMixed ::- (Show t, Show (MinMaxType t t),-  Show (MinMaxType t (MinMaxType t t)),-  Show (MinMaxType (MinMaxType t t) t), Arbitrary t,-  CanTestCertainly (EqCompareType t t),-  CanTestCertainly (OrderCompareType (MinMaxType t t) t),-  CanTestCertainly (EqCompareType (MinMaxType t t) t),-  CanTestCertainly-    (EqCompareType (MinMaxType t t) (MinMaxType t t)),-  CanTestCertainly-    (EqCompareType-       (MinMaxType t (MinMaxType t t))-       (MinMaxType (MinMaxType t t) t)),-  CanTestFinite t,-  HasEqAsymmetric t t, HasEqAsymmetric (MinMaxType t t) t,-  HasEqAsymmetric (MinMaxType t t) (MinMaxType t t),-  HasEqAsymmetric-    (MinMaxType t (MinMaxType t t))-    (MinMaxType (MinMaxType t t) t),-  HasOrderAsymmetric (MinMaxType t t) t,-  CanMinMaxAsymmetric t t,-  CanMinMaxAsymmetric t (MinMaxType t t),-  CanMinMaxAsymmetric (MinMaxType t t) t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanMinMaxNotMixed t = specCanMinMax t t t  instance CanMinMaxAsymmetric Int Int@@ -240,72 +189,49 @@   max _ _ = Nothing  instance-  (CanMinMaxAsymmetric a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (MinMaxType a b)-  , SuitableForCE es)+  (CanMinMaxAsymmetric a b, CanBeErrors es)   =>   CanMinMaxAsymmetric (CollectErrors es a) (CollectErrors es  b)   where   type MinMaxType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (MinMaxType a b)-  min = lift2CE min-  max = lift2CE max+    CollectErrors es (MinMaxType a b)+  min = CE.lift2 min+  max = CE.lift2 max  $(declForTypes   [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]   (\ t -> [d|      instance-      (CanMinMaxAsymmetric $t b-      , CanEnsureCE es b-      , CanEnsureCE es (MinMaxType $t b)-      , SuitableForCE es)+      (CanMinMaxAsymmetric $t b, CanBeErrors es)       =>       CanMinMaxAsymmetric $t (CollectErrors es  b)       where       type MinMaxType $t (CollectErrors es  b) =-        EnsureCE es (MinMaxType $t b)-      min = lift2TLCE min-      max = lift2TLCE max+        CollectErrors es (MinMaxType $t b)+      min = CE.liftT1 min+      max = CE.liftT1 max      instance-      (CanMinMaxAsymmetric a $t-      , CanEnsureCE es a-      , CanEnsureCE es (MinMaxType a $t)-      , SuitableForCE es)+      (CanMinMaxAsymmetric a $t, CanBeErrors es)       =>       CanMinMaxAsymmetric (CollectErrors es a) $t       where       type MinMaxType (CollectErrors es  a) $t =-        EnsureCE es (MinMaxType a $t)-      min = lift2TCE min-      max = lift2TCE max+        CollectErrors es (MinMaxType a $t)+      min = CE.lift1T min+      max = CE.lift1T max    |]))  -{-| Compound type constraint useful for test definition. -}-type CanNegX t =-  (CanNeg t, Show t, Arbitrary t, Show (NegType t))- {----  numeric negation tests and instances -----}  {-|   HSpec properties that each numeric implementation of CanNeg should satisfy.  -} specCanNegNum ::-  (CanNegX t, CanNegX (NegType t),-   HasEqCertainly t (NegType (NegType t)),-   ConvertibleExactly Integer t,-   HasEqCertainly t t,-   HasEqCertainly t (NegType t),-   CanTestFinite t,-   CanTestPosNeg t,-   CanTestPosNeg (NegType t)-  )-  =>-  T t -> Spec+  _ => T t -> Spec specCanNegNum (T typeName :: T t) =   describe (printf "CanNeg %s" typeName) $ do     it "ignores double negation" $ do@@ -352,32 +278,18 @@ instance CanAbs Double  instance-  (CanAbs a-  , CanEnsureCE es a-  , CanEnsureCE es (AbsType a)-  , SuitableForCE es)+  (CanAbs a, CanBeErrors es)   =>   CanAbs (CollectErrors es a)   where-  type AbsType (CollectErrors es a) = EnsureCE es (AbsType a)-  abs = lift1CE abs--type CanAbsX t =-  (CanAbs t,-   CanNegSameType t,-   CanTestPosNeg t,-   CanTestPosNeg (AbsType t),-   HasEqCertainly t t,-   HasEqCertainly t (AbsType t),-   Show t, Arbitrary t, Show (AbsType t))+  type AbsType (CollectErrors es a) = CollectErrors es (AbsType a)+  abs = CE.lift abs  {-|   HSpec properties that each implementation of CanAbs should satisfy.  -} specCanAbs ::-  (CanAbsX t, CanAbsX (AbsType t), CanTestFinite t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanAbs (T typeName :: T t) =   describe (printf "CanAbs %s" typeName) $ do     it "is idempotent" $ do

@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.Ord@@ -16,7 +18,6 @@   -- * Comparisons in numeric order   HasOrder, HasOrderAsymmetric(..), (>), (<), (<=), (>=)   , HasOrderCertainlyAsymmetric, HasOrderCertainly-  , HasOrderCertainlyCE, HasOrderCertainlyCN   , (?<=?), (?<?), (?>=?), (?>?)   , (!<=!), (!<!), (!>=!), (!>!)   -- ** Tests@@ -35,8 +36,8 @@ import Test.Hspec import qualified Test.QuickCheck as QC -import Numeric.CollectErrors-import Control.CollectErrors+import Control.CollectErrors ( CollectErrors, CanBeErrors )+import qualified Control.CollectErrors as CE  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -55,19 +56,6 @@ type HasOrderCertainly t1 t2 =   (HasOrder t1 t2, CanTestCertainly (OrderCompareType t1 t2)) -type HasOrderCertainlyCE es t1 t2 =-  (HasOrderCertainly t1 t2,-   HasOrderCertainly (EnsureCE es t1) (EnsureCE es t2))-  --  ,-  --  CanTestCertainly (WithoutCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  IsBool (WithoutCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  CanEnsureCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2)),-  --  CanEnsureCE es (WithoutCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2))),-  --  WithoutCE es (WithoutCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2)))-  --    ~ (WithoutCE es (OrderCompareType (WithoutCE es t1) (WithoutCE es t2))))--type HasOrderCertainlyCN t1 t2 = HasOrderCertainlyCE NumErrors t1 t2- type HasOrderCertainlyAsymmetric t1 t2 =   (HasOrderAsymmetric t1 t2, CanTestCertainly (OrderCompareType t1 t2)) @@ -131,19 +119,7 @@   HSpec properties that each implementation of 'HasOrder' should satisfy.  -} specHasOrder ::-  (Show t1, Show t2, Show t3, QC.Arbitrary t1, QC.Arbitrary t2,-   QC.Arbitrary t3, CanTestCertainly (OrderCompareType t1 t1),-   CanTestCertainly (OrderCompareType t1 t2),-   CanTestCertainly (OrderCompareType t2 t1),-   CanTestCertainly (OrderCompareType t2 t3),-   CanTestCertainly-     (AndOrType (OrderCompareType t1 t2) (OrderCompareType t2 t3)),-   CanAndOrAsymmetric-     (OrderCompareType t1 t2) (OrderCompareType t2 t3),-   HasOrderAsymmetric t1 t1, HasOrderAsymmetric t1 t2,-   HasOrderAsymmetric t2 t1, HasOrderAsymmetric t2 t3)-  =>-  T t1 -> T t2 -> T t3 -> Spec+  _ => T t1 -> T t2 -> T t3 -> Spec specHasOrder (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "HasOrd %s %s, HasOrd %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "has reflexive >=" $ do@@ -169,12 +145,7 @@   HSpec properties that each implementation of 'HasOrder' should satisfy.  -} specHasOrderNotMixed ::-  (Show t, QC.Arbitrary t, CanTestCertainly (OrderCompareType t t),-   CanTestCertainly-     (AndOrType (OrderCompareType t t) (OrderCompareType t t)),-   HasOrderAsymmetric t t)-  =>-  T t -> Spec+  _ => T t -> Spec specHasOrderNotMixed (t :: T t) = specHasOrder t t t  instance HasOrderAsymmetric () () where@@ -222,56 +193,44 @@   leq d n = leq d (integer n)  instance-  (HasOrderAsymmetric a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (OrderCompareType a b)-  , IsBool (EnsureCE es (OrderCompareType a b))-  , SuitableForCE es)+  (HasOrderAsymmetric a b, CanBeErrors es)   =>   HasOrderAsymmetric (CollectErrors es a) (CollectErrors es b)   where   type OrderCompareType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (OrderCompareType a b)-  lessThan = lift2CE lessThan-  leq = lift2CE leq-  greaterThan = lift2CE greaterThan-  geq = lift2CE geq+    CollectErrors es (OrderCompareType a b)+  lessThan = CE.lift2 lessThan+  leq = CE.lift2 leq+  greaterThan = CE.lift2 greaterThan+  geq = CE.lift2 geq  $(declForTypes   [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]   (\ t -> [d|      instance-      (HasOrderAsymmetric $t b-      , CanEnsureCE es b-      , CanEnsureCE es (OrderCompareType $t b)-      , IsBool (EnsureCE es (OrderCompareType $t b))-      , SuitableForCE es)+      (HasOrderAsymmetric $t b, CanBeErrors es)       =>       HasOrderAsymmetric $t (CollectErrors es  b)       where       type OrderCompareType $t (CollectErrors es  b) =-        EnsureCE es (OrderCompareType $t b)-      lessThan = lift2TLCE lessThan-      leq = lift2TLCE leq-      greaterThan = lift2TLCE greaterThan-      geq = lift2TLCE geq+        CollectErrors es (OrderCompareType $t b)+      lessThan = CE.liftT1 lessThan+      leq = CE.liftT1 leq+      greaterThan = CE.liftT1 greaterThan+      geq = CE.liftT1 geq      instance-      (HasOrderAsymmetric a $t-      , CanEnsureCE es a-      , CanEnsureCE es (OrderCompareType a $t)-      , IsBool (EnsureCE es (OrderCompareType a $t))-      , SuitableForCE es)+      (HasOrderAsymmetric a $t, CanBeErrors es)       =>       HasOrderAsymmetric (CollectErrors es a) $t       where       type OrderCompareType (CollectErrors es  a) $t =-        EnsureCE es (OrderCompareType a $t)-      lessThan = lift2TCE lessThan-      leq = lift2TCE leq-      greaterThan = lift2TCE greaterThan-      geq = lift2TCE geq+        CollectErrors es (OrderCompareType a $t)+      lessThan = CE.lift1T lessThan+      leq = CE.lift1T leq+      greaterThan = CE.lift1T greaterThan+      geq = CE.lift1T geq    |])) @@ -294,8 +253,8 @@ instance CanTestPosNeg Rational instance CanTestPosNeg Double -instance (CanTestPosNeg t, SuitableForCE es) => (CanTestPosNeg (CollectErrors es t)) where-  isCertainlyPositive ce = getValueIfNoErrorCE ce isCertainlyPositive (const False)-  isCertainlyNonNegative ce = getValueIfNoErrorCE ce isCertainlyNonNegative (const False)-  isCertainlyNegative ce = getValueIfNoErrorCE ce isCertainlyNegative (const False)-  isCertainlyNonPositive ce = getValueIfNoErrorCE ce isCertainlyNonPositive (const False)+instance (CanTestPosNeg t, CanBeErrors es) => (CanTestPosNeg (CollectErrors es t)) where+  isCertainlyPositive = CE.withErrorOrValue (const False) isCertainlyPositive+  isCertainlyNonNegative = CE.withErrorOrValue (const False) isCertainlyNonNegative+  isCertainlyNegative = CE.withErrorOrValue (const False) isCertainlyNegative+  isCertainlyNonPositive = CE.withErrorOrValue (const False) isCertainlyNonPositive

@@ -0,0 +1,232 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-|+    Module      :  Numeric.MixedType.Power+    Description :  Bottom-up typed exponentiation+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++-}++module Numeric.MixedTypes.Power+(+  -- * Exponentiation+   CanPow(..), CanPowBy+  , (^)+  , powUsingMul, integerPowCN+  , powUsingMulRecip+  -- ** Tests+  , specCanPow+)+where++import Utils.TH.DeclForTypes++import Numeric.MixedTypes.PreludeHiding+import qualified Prelude as P+import Text.Printf++import Test.Hspec+import Test.QuickCheck++import Numeric.CollectErrors ( CN, cn )+import qualified Numeric.CollectErrors as CN++import Numeric.MixedTypes.Literals+import Numeric.MixedTypes.Bool+import Numeric.MixedTypes.Eq+import Numeric.MixedTypes.Ord+-- import Numeric.MixedTypes.MinMaxAbs+import Numeric.MixedTypes.AddSub+import Numeric.MixedTypes.Ring+import Numeric.MixedTypes.Div++++{---- Exponentiation -----}++infixl 8  ^++(^) :: (CanPow t1 t2) => t1 -> t2 -> PowType t1 t2+(^) = pow+++{-|+  A replacement for Prelude's binary `P.^` and `P.^^`.+-}+class CanPow b e where+  type PowType b e+  type PowType b e = b -- default+  pow :: b -> e -> PowType b e++integerPowCN ::+  (HasOrderCertainly b Integer, HasOrderCertainly e Integer,+   HasEqCertainly b Integer, HasEqCertainly e Integer)+  =>+  (b -> e -> r) -> CN b -> CN e -> CN r+integerPowCN unsafeIntegerPow b n+  | n !<! 0 =+    CN.noValueNumErrorCertain $ CN.OutOfDomain "illegal integer pow: negative exponent"+  | n !==! 0 && b !==! 0 =+    CN.noValueNumErrorCertain $ CN.OutOfDomain "illegal integer pow: 0^0"+  | n ?<? 0 =+    CN.noValueNumErrorCertain $ CN.OutOfDomain "illegal integer pow: negative exponent"+  | n ?==? 0 && b ?==? 0 =+    CN.noValueNumErrorPotential $ CN.OutOfDomain "illegal integer pow: 0^0"+  | otherwise =+    CN.lift2 unsafeIntegerPow b n++powCN ::+  (HasOrderCertainly b Integer, HasOrderCertainly e Integer,+   HasEqCertainly b Integer, CanTestInteger e)+  =>+  (b -> e -> r) -> CN b -> CN e -> CN r+powCN unsafePow b e+  | b !==! 0 && e !<=! 0 =+    CN.noValueNumErrorCertain $ CN.OutOfDomain "illegal pow: 0^e with e <= 0"+  | b !<! 0 && certainlyNotInteger e =+    CN.noValueNumErrorCertain $ CN.OutOfDomain "illegal pow: b^e with b < 0 and e non-integer"+  | b ?==? 0 && e ?<=? 0 =+    CN.noValueNumErrorPotential $ CN.OutOfDomain "illegal pow: 0^e with e <= 0"+  | b ?<? 0 && not (certainlyInteger e) =+    CN.noValueNumErrorPotential $ CN.OutOfDomain "illegal pow: b^e with b < 0 and e non-integer"+  | otherwise =+    CN.lift2 unsafePow b e++powUsingMul ::+  (CanBeInteger e,+   CanMulSameType t)+   =>+   t -> t -> e -> t+powUsingMul one x nPre+  | n < 0 = error $ "powUsingMul is not defined for negative exponent " ++ show n+  | n == 0 = one+  | otherwise = aux n+  where+    n = integer nPre+    aux m+      | m == 1 = x+      | even m =+        let s = aux (m `P.div` 2) in s * s+      | otherwise =+        let s = aux ((m-1) `P.div` 2) in x * s * s++powUsingMulRecip ::+  (CanBeInteger e, CanMulSameType b, CanRecipSameType b)+   =>+   b -> b -> e -> b+powUsingMulRecip one x e+  | eI < 0 = recip $ powUsingMul one x (negate eI)+  | otherwise = powUsingMul one x eI+  where+  eI = integer e++type CanPowBy t1 t2 =+  (CanPow t1 t2, PowType t1 t2 ~ t1)++{-|+  HSpec properties that each implementation of CanPow should satisfy.+ -}+specCanPow ::+  _ => T t1 -> T t2 -> Spec+specCanPow (T typeName1 :: T t1) (T typeName2 :: T t2) =+  describe (printf "CanPow %s %s" typeName1 typeName2) $ do+    it "x^0 = 1" $ do+      property $ \ (x :: t1) ->+        let one = (convertExactly 1 :: t1) in+        let z = (convertExactly 0 :: t2) in+        (x ^ z) ?==?$ one+    it "x^1 = x" $ do+      property $ \ (x :: t1) ->+        let one = (convertExactly 1 :: t2) in+        (x ^ one) ?==?$ x+    it "x^(y+1) = x*x^y" $ do+      property $ \ (x :: t1) (y :: t2) ->+        (isCertainlyNonNegative y) ==>+          x * (x ^ y) ?==?$ (x ^ (y + 1))+  where+  infix 4 ?==?$+  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property+  (?==?$) = printArgsIfFails2 "?==?" (?==?)++instance CanPow Integer Integer where  +  type PowType Integer Integer = Rational+  pow b = (P.^^) (rational b)+instance CanPow Integer Int where+  type PowType Integer Int = Rational+  pow b = (P.^^) (rational b)+instance CanPow Int Integer where+  type PowType Int Integer = Rational+  pow b = (P.^^) (rational b)+instance CanPow Int Int where+  type PowType Int Int = Rational+  pow b = (P.^^) (rational b)+instance CanPow Rational Int where+  pow = (P.^^)+instance CanPow Rational Integer where+  pow = (P.^^)+instance CanPow Double Int where+  pow = (P.^^)+instance CanPow Double Integer where+  pow = (P.^^)+instance CanPow Double Double where+  type PowType Double Double = Double+  pow = (P.**)+instance CanPow Double Rational where+  type PowType Double Rational = Double+  pow b e = b ^ (double e)+instance CanPow Rational Double where+  type PowType Rational Double = Double+  pow b e = (double b) ^ e+instance CanPow Integer Double where+  type PowType Integer Double = Double+  pow b e = (double b) ^ e+instance CanPow Int Double where+  type PowType Int Double = Double+  pow b e = (double b) ^ e++-- instance (CanPow a b) => CanPow [a] [b] where+--   type PowType [a] [b] = [PowType a b]+--   pow (x:xs) (y:ys) = (pow x y) : (pow xs ys)+--   pow _ _ = []++instance (CanPow a b) => CanPow (Maybe a) (Maybe b) where+  type PowType (Maybe a) (Maybe b) = Maybe (PowType a b)+  pow (Just x) (Just y) = Just (pow x y)+  pow _ _ = Nothing++instance+  (CanPow b e, HasOrderCertainly b Integer, HasOrderCertainly e Integer,+   HasEqCertainly b Integer, CanTestInteger e)+  =>+  CanPow (CN b) (CN e)+  where+  type PowType (CN b) (CN e) = CN (PowType b e)+  pow = powCN pow++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]+  (\ t -> [d|++    instance+      (CanPow $t e, HasOrderCertainly e Integer, CanTestInteger e)+      =>+      CanPow $t (CN e)+      where+      type PowType $t (CN e) = CN (PowType $t e)+      pow b e = powCN pow (cn b) e++    instance+      (CanPow b $t, HasOrderCertainly b Integer, HasEqCertainly b Integer)+      =>+      CanPow (CN b) $t+      where+      type PowType (CN b) $t = CN (PowType b $t)+      pow b e = powCN pow b (cn e)++  |]))

@@ -0,0 +1,44 @@+{-|+    Module      :  Numeric.MixedType.Reduce+    Description :  Throw error when too inaccurate+    Copyright   :  (c) Michal Konecny+    License     :  BSD3++    Maintainer  :  mikkonecny@gmail.com+    Stability   :  experimental+    Portability :  portable++    Mechanism to throw an error when a value gets too inaccurate.+-}+module Numeric.MixedTypes.Reduce+(+    CanGiveUpIfVeryInaccurate(giveUpIfVeryInaccurate)+    , numErrorVeryInaccurate+)+where++import Numeric.MixedTypes.PreludeHiding+-- import qualified Prelude as P++import Numeric.CollectErrors ( CN, NumError (NumError) )++class CanGiveUpIfVeryInaccurate t where+  {-| If the value contains so little information that it is seen as useless,+      drop the value and add an error indicating what happened.+    -}+  giveUpIfVeryInaccurate :: CN t -> CN t+  giveUpIfVeryInaccurate = id  -- by default, never give up!++numErrorVeryInaccurate :: String -> String -> NumError+numErrorVeryInaccurate context detail =+  case (context, detail) of+     ("", "") -> NumError $ msg <> "."+     ("", _) -> NumError $ msg <> ": " ++ detail+     (_, "") -> NumError $ context <> ": " <> msg <> "."+     _ -> NumError $ context <> ": " <> msg <> ": " ++ detail+  where+  msg = "Very inaccurate, too little information"++instance CanGiveUpIfVeryInaccurate Int+instance CanGiveUpIfVeryInaccurate Integer+instance CanGiveUpIfVeryInaccurate Rational

@@ -1,7 +1,9 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.Ring-    Description :  Bottom-up typed multiplication and exponent+    Description :  Bottom-up typed multiplication with ring laws     Copyright   :  (c) Michal Konecny     License     :  BSD3 @@ -20,12 +22,6 @@   , (*), product   -- ** Tests   , specCanMul, specCanMulNotMixed, specCanMulSameType-  -- * Exponentiation-  , CanPow(..), CanPowBy, CanPowCNBy-  , (^), (^!)-  , powUsingMul, integerPowCN-  -- ** Tests-  , specCanPow ) where @@ -40,8 +36,8 @@ import Test.Hspec import Test.QuickCheck -import Numeric.CollectErrors-import Control.CollectErrors+import qualified Numeric.CollectErrors as CN+import Numeric.CollectErrors ( CN )  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -49,26 +45,19 @@ import Numeric.MixedTypes.Ord -- import Numeric.MixedTypes.MinMaxAbs import Numeric.MixedTypes.AddSub+import Numeric.MixedTypes.Reduce  {----- Ring -----}  type CanAddSubMulBy t s =   (CanAddThis t s, CanSubThis t s, CanSub s t, SubType s t ~ t, CanMulBy t s) -type RingPre t =+class   (CanNegSameType t, CanAddSameType t, CanSubSameType t, CanMulSameType t,-   CanPowCNBy t Integer, CanPowCNBy t Int,    HasEq t t,    HasEq t Integer, CanAddSubMulBy t Integer,    HasEq t Int, CanAddSubMulBy t Int,-   HasIntegers t)--class-  (RingPre t,-   CanEnsureCN t,-   RingPre (EnsureCN t))-  =>-  Ring t+   HasIntegers t) => Ring t  instance Ring Integer instance Ring (CN Integer)@@ -78,15 +67,9 @@ class   (Ring t   , HasEq t t-  , HasEq (EnsureCN t) t-  , HasEq t (EnsureCN t)   , HasEq t Int, HasEq t Integer-  , HasEq (EnsureCN t) Int, HasEq (EnsureCN t) Integer   , HasOrder t t-  , HasOrder (EnsureCN t) t-  , HasOrder t (EnsureCN t)-  , HasOrder t Int, HasOrder t Integer-  , HasOrder (EnsureCN t) Int, HasOrder (EnsureCN t) Integer)+  , HasOrder t Int, HasOrder t Integer)   => OrderedRing t  instance OrderedRing Integer@@ -97,15 +80,9 @@ class   (Ring t   , HasEqCertainly t t-  , HasEqCertainly (EnsureCN t) t-  , HasEqCertainly t (EnsureCN t)   , HasEqCertainly t Int, HasEq t Integer-  , HasEqCertainly (EnsureCN t) Int, HasEq (EnsureCN t) Integer   , HasOrderCertainly t t-  , HasOrderCertainly (EnsureCN t) t-  , HasOrderCertainly t (EnsureCN t)   , HasOrderCertainly t Int, HasOrderCertainly t Integer-  , HasOrderCertainly (EnsureCN t) Int, HasOrderCertainly (EnsureCN t) Integer   , CanTestPosNeg t)   => OrderedCertainlyRing t @@ -131,7 +108,6 @@   default mul :: (MulType t1 t2 ~ t1, t1~t2, P.Num t1) => t1 -> t2 -> MulType t1 t2   mul = (P.*) -infixl 8  ^, ^! infixl 7  *  (*) :: (CanMulAsymmetric t1 t2) => t1 -> t2 -> MulType t1 t2@@ -149,36 +125,7 @@   HSpec properties that each implementation of CanMul should satisfy.  -} specCanMul ::-  (Show t1, Show t2, Show t3, Show (MulType t1 t2),-   Show (MulType t2 t1), Show (MulType t1 (MulType t2 t3)),-   Show (MulType (MulType t1 t2) t3),-   Show (MulType t1 (AddType t2 t3)),-   Show (AddType (MulType t1 t2) (MulType t1 t3)), Arbitrary t1,-   Arbitrary t2, Arbitrary t3, ConvertibleExactly Integer t2,-   CanTestCertainly (EqCompareType (MulType t1 t2) t1),-   CanTestCertainly (EqCompareType (MulType t1 t2) (MulType t2 t1)),-   CanTestCertainly-     (EqCompareType-        (MulType t1 (MulType t2 t3)) (MulType (MulType t1 t2) t3)),-   CanTestCertainly-     (EqCompareType-        (MulType t1 (AddType t2 t3))-        (AddType (MulType t1 t2) (MulType t1 t3))),-   HasEqAsymmetric (MulType t1 t2) t1,-   HasEqAsymmetric (MulType t1 t2) (MulType t2 t1),-   HasEqAsymmetric-     (MulType t1 (MulType t2 t3)) (MulType (MulType t1 t2) t3),-   HasEqAsymmetric-     (MulType t1 (AddType t2 t3))-     (AddType (MulType t1 t2) (MulType t1 t3)),-   CanAddAsymmetric t2 t3,-   CanAddAsymmetric (MulType t1 t2) (MulType t1 t3),-   CanMulAsymmetric t1 t2, CanMulAsymmetric t1 t3,-   CanMulAsymmetric t1 (MulType t2 t3),-   CanMulAsymmetric t1 (AddType t2 t3), CanMulAsymmetric t2 t1,-   CanMulAsymmetric t2 t3, CanMulAsymmetric (MulType t1 t2) t3)-  =>-  T t1 -> T t2 -> T t3 -> Spec+  _ => T t1 -> T t2 -> T t3 -> Spec specCanMul (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =   describe (printf "CanMul %s %s, CanMul %s %s" typeName1 typeName2 typeName2 typeName3) $ do     it "absorbs 1" $ do@@ -200,30 +147,7 @@   HSpec properties that each implementation of CanMul should satisfy.  -} specCanMulNotMixed ::-  (Show t, Show (MulType t t), Show (MulType t (MulType t t)),-   Show (MulType (MulType t t) t), Show (MulType t (AddType t t)),-   Show (AddType (MulType t t) (MulType t t)), Arbitrary t,-   ConvertibleExactly Integer t,-   CanTestCertainly (EqCompareType (MulType t t) t),-   CanTestCertainly (EqCompareType (MulType t t) (MulType t t)),-   CanTestCertainly-     (EqCompareType-        (MulType t (MulType t t)) (MulType (MulType t t) t)),-   CanTestCertainly-     (EqCompareType-        (MulType t (AddType t t)) (AddType (MulType t t) (MulType t t))),-   HasEqAsymmetric (MulType t t) t,-   HasEqAsymmetric (MulType t t) (MulType t t),-   HasEqAsymmetric-     (MulType t (MulType t t)) (MulType (MulType t t) t),-   HasEqAsymmetric-     (MulType t (AddType t t)) (AddType (MulType t t) (MulType t t)),-   CanAddAsymmetric t t, CanAddAsymmetric (MulType t t) (MulType t t),-   CanMulAsymmetric t t, CanMulAsymmetric t (MulType t t),-   CanMulAsymmetric t (AddType t t),-   CanMulAsymmetric (MulType t t) t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanMulNotMixed (t :: T t) = specCanMul t t t  {-|@@ -307,267 +231,30 @@   mul _ _ = Nothing  instance-  (CanMulAsymmetric a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (MulType a b)-  , SuitableForCE es)-  =>-  CanMulAsymmetric (CollectErrors es a) (CollectErrors es  b)-  where-  type MulType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (MulType a b)-  mul = lift2CE mul--{---- Exponentiation -----}--(^) :: (CanPow t1 t2) => t1 -> t2 -> PowType t1 t2-(^) = pow--{-| Like `^` but throwing an exception if the power is undefined. -}-(^!) :: (CanPow t1 t2) =>-  t1 -> t2 -> PowTypeNoCN t1 t2-(^!) = powNoCN---{-|-  A replacement for Prelude's binary `P.^` and `P.^^`.  If @Num t1@ and @Integral t2@,-  then one can use the default implementation to mirror Prelude's @^@.--}-class CanPow b e where-  type PowTypeNoCN b e-  type PowTypeNoCN b e = b -- default-  powNoCN :: b -> e -> PowTypeNoCN b e-  type PowType b e-  type PowType b e = EnsureCN (PowTypeNoCN b e) -- default-  pow :: b -> e -> PowType b e-  default pow ::-    (HasOrderCertainly b Integer, HasOrderCertainly e Integer,-     HasEqCertainly b Integer, CanTestInteger e,-     CanEnsureCN (PowTypeNoCN b e), PowType b e~EnsureCN (PowTypeNoCN b e))-    =>-    b -> e -> PowType b e-  pow = powCN powNoCN--integerPowCN ::-  (HasOrderCertainly b Integer, HasOrderCertainly e Integer,-   HasEqCertainly b Integer, HasEqCertainly e Integer,-   CanEnsureCN r)-  =>-  (b -> e -> r) -> b -> e -> EnsureCN r-integerPowCN unsafeIntegerPow b n-  | n !<! 0 =-    noValueNumErrorCertainECN sample_v $ OutOfRange "illegal integer pow: negative exponent"-  | n !==! 0 && b !==! 0 =-    noValueNumErrorCertainECN sample_v $ OutOfRange "illegal integer pow: 0^0"-  | n ?<? 0 =-    noValueNumErrorPotentialECN sample_v $ OutOfRange "illegal integer pow: negative exponent"-  | n ?==? 0 && b ?==? 0 =-    noValueNumErrorPotentialECN sample_v $ OutOfRange "illegal integer pow: 0^0"-  | otherwise =-    ensureCN $ unsafeIntegerPow b n-  where-  sample_v = Just (unsafeIntegerPow b n)--powCN ::-  (HasOrderCertainly b Integer, HasOrderCertainly e Integer,-   HasEqCertainly b Integer, CanTestInteger e,-   CanEnsureCN r)-  =>-  (b -> e -> r) -> b -> e -> EnsureCN r-powCN unsafePow b e-  | b !==! 0 && e !<=! 0 =-    noValueNumErrorCertainECN sample_v $ OutOfRange "illegal pow: 0^e with e <= 0"-  | b !<! 0 && certainlyNotInteger e =-    noValueNumErrorCertainECN sample_v $ OutOfRange "illegal pow: b^e with b < 0 and e non-integer"-  | b ?==? 0 && e ?<=? 0 =-    noValueNumErrorPotentialECN sample_v $ OutOfRange "illegal pow: 0^e with e <= 0"-  | b ?<? 0 && not (certainlyInteger e) =-    noValueNumErrorPotentialECN sample_v $ OutOfRange "illegal pow: b^e with b < 0 and e non-integer"-  | otherwise =-    ensureCN $ unsafePow b e-  where-  sample_v = Just (unsafePow b e)--powUsingMul ::-  (CanBeInteger e,-   CanMulSameType t)-   =>-   t -> t -> e -> t-powUsingMul one x nPre-  | n < 0 = error $ "powUsingMul is not defined for negative exponent " ++ show n-  | n == 0 = one-  | otherwise = aux n-  where-    n = integer nPre-    aux m-      | m == 1 = x-      | even m =-        let s = aux (m `P.div` 2) in s * s-      | otherwise =-        let s = aux ((m-1) `P.div` 2) in x * s * s--type CanPowBy t1 t2 =-  (CanPow t1 t2, PowType t1 t2 ~ t1, PowTypeNoCN t1 t2 ~ t1)--type CanPowCNBy t1 t2 =-  (CanPow t1 t2, PowType t1 t2 ~ EnsureCN t1, PowTypeNoCN t1 t2 ~ t1-  , CanEnsureCN t1-  , CanPow (EnsureCN t1) t2, PowType (EnsureCN t1) t2 ~ EnsureCN t1-  , PowTypeNoCN (EnsureCN t1) t2 ~ (EnsureCN t1))--{-|-  HSpec properties that each implementation of CanPow should satisfy.- -}-specCanPow ::-  (Show t1, Show t2, Show (PowType t1 t2),-   Show (MulType t1 (PowType t1 t2)),-   Show (PowType t1 (AddType t2 Integer)), Arbitrary t1, Arbitrary t2,-   ConvertibleExactly Integer t1, ConvertibleExactly Integer t2,-   CanTestCertainly (EqCompareType (PowType t1 t2) t1),-   CanTestCertainly-     (EqCompareType-        (MulType t1 (PowType t1 t2)) (PowType t1 (AddType t2 Integer))),-   HasEqAsymmetric (PowType t1 t2) t1,-   HasEqAsymmetric-     (MulType t1 (PowType t1 t2)) (PowType t1 (AddType t2 Integer)),-   CanTestPosNeg t2, CanAddAsymmetric t2 Integer, CanPow t1 t2,-   CanPow t1 (AddType t2 Integer),-   CanMulAsymmetric t1 (PowType t1 t2))-  =>-  T t1 -> T t2 -> Spec-specCanPow (T typeName1 :: T t1) (T typeName2 :: T t2) =-  describe (printf "CanPow %s %s" typeName1 typeName2) $ do-    it "x^0 = 1" $ do-      property $ \ (x :: t1) ->-        let one = (convertExactly 1 :: t1) in-        let z = (convertExactly 0 :: t2) in-        (x ^ z) ?==?$ one-    it "x^1 = x" $ do-      property $ \ (x :: t1) ->-        let one = (convertExactly 1 :: t2) in-        (x ^ one) ?==?$ x-    it "x^(y+1) = x*x^y" $ do-      property $ \ (x :: t1) (y :: t2) ->-        (isCertainlyNonNegative y) ==>-          x * (x ^ y) ?==?$ (x ^ (y + 1))-  where-  infix 4 ?==?$-  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property-  (?==?$) = printArgsIfFails2 "?==?" (?==?)--instance CanPow Integer Integer where-  powNoCN = (P.^)-  pow = integerPowCN (P.^)-instance CanPow Integer Int where-  powNoCN = (P.^)-  pow = integerPowCN (P.^)-instance CanPow Int Integer where-  type PowTypeNoCN Int Integer = Integer-  powNoCN x n = powNoCN (integer x) n-  pow x n = pow (integer x) n-instance CanPow Int Int where-  type PowTypeNoCN Int Int = Integer-  powNoCN x n = powNoCN (integer x) n-  pow x n = pow (integer x) n-instance CanPow Rational Int where-  powNoCN = (P.^^)-instance CanPow Rational Integer where-  powNoCN = (P.^^)-instance CanPow Double Int where-  powNoCN = (P.^^)-  type PowType Double Int = Double-  pow = (P.^^)-instance CanPow Double Integer where-  powNoCN = (P.^^)-  type PowType Double Integer = Double-  pow = (P.^^)---- instance (CanPow a b) => CanPow [a] [b] where---   type PowType [a] [b] = [PowType a b]---   pow (x:xs) (y:ys) = (pow x y) : (pow xs ys)---   pow _ _ = []--instance (CanPow a b) => CanPow (Maybe a) (Maybe b) where-  type PowTypeNoCN (Maybe a) (Maybe b) = Maybe (PowTypeNoCN a b)-  powNoCN (Just x) (Just y) = Just (powNoCN x y)-  powNoCN _ _ = Nothing-  type PowType (Maybe a) (Maybe b) = Maybe (PowType a b)-  pow (Just x) (Just y) = Just (pow x y)-  pow _ _ = Nothing--instance-  (CanPow a b-  , CanEnsureCE es a, CanEnsureCE es b-  , CanEnsureCE es (PowTypeNoCN a b)-  , CanEnsureCE es (PowType a b)-  , SuitableForCE es)+  (CanMulAsymmetric a b, CanGiveUpIfVeryInaccurate (MulType a b))   =>-  CanPow (CollectErrors es a) (CollectErrors es  b)+  CanMulAsymmetric (CN a) (CN b)   where-  type PowTypeNoCN (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (PowTypeNoCN a b)-  powNoCN = lift2CE powNoCN-  type PowType (CollectErrors es a) (CollectErrors es b) =-    EnsureCE es (PowType a b)-  pow = lift2CE pow+  type MulType (CN a) (CN b) = CN (MulType a b)+  mul a b = giveUpIfVeryInaccurate $ CN.lift2 mul a b  $(declForTypes   [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]   (\ t -> [d|      instance-      (CanPow $t b-      , CanEnsureCE es b-      , CanEnsureCE es (PowType $t b)-      , CanEnsureCE es (PowTypeNoCN $t b)-      , SuitableForCE es)-      =>-      CanPow $t (CollectErrors es  b)-      where-      type PowTypeNoCN $t (CollectErrors es  b) =-        EnsureCE es (PowTypeNoCN $t b)-      powNoCN = lift2TLCE powNoCN-      type PowType $t (CollectErrors es  b) =-        EnsureCE es (PowType $t b)-      pow = lift2TLCE pow--    instance-      (CanPow a $t-      , CanEnsureCE es a-      , CanEnsureCE es (PowType a $t)-      , CanEnsureCE es (PowTypeNoCN a $t)-      , SuitableForCE es)-      =>-      CanPow (CollectErrors es a) $t-      where-      type PowTypeNoCN (CollectErrors es  a) $t =-        EnsureCE es (PowTypeNoCN a $t)-      powNoCN = lift2TCE powNoCN-      type PowType (CollectErrors es  a) $t =-        EnsureCE es (PowType a $t)-      pow = lift2TCE pow--    instance-      (CanMulAsymmetric $t b-      , CanEnsureCE es b-      , CanEnsureCE es (MulType $t b)-      , SuitableForCE es)+      (CanMulAsymmetric $t b, CanGiveUpIfVeryInaccurate (MulType $t b))       =>-      CanMulAsymmetric $t (CollectErrors es  b)+      CanMulAsymmetric $t (CN b)       where-      type MulType $t (CollectErrors es  b) =-        EnsureCE es (MulType $t b)-      mul = lift2TLCE mul+      type MulType $t (CN b) = CN (MulType $t b)+      mul a b = giveUpIfVeryInaccurate $ CN.liftT1 mul a b      instance-      (CanMulAsymmetric a $t-      , CanEnsureCE es a-      , CanEnsureCE es (MulType a $t)-      , SuitableForCE es)+      (CanMulAsymmetric a $t, CanGiveUpIfVeryInaccurate (MulType a $t))       =>-      CanMulAsymmetric (CollectErrors es a) $t+      CanMulAsymmetric (CN a) $t       where-      type MulType (CollectErrors es  a) $t =-        EnsureCE es (MulType a $t)-      mul = lift2TCE mul+      type MulType (CN a) $t = CN (MulType a $t)+      mul a b = giveUpIfVeryInaccurate $ CN.lift1T mul a b   |]))

@@ -1,3 +1,6 @@+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TemplateHaskell #-} {-|     Module      :  Numeric.MixedType.Round     Description :  Bottom-up typed round, floor, etc.@@ -13,7 +16,9 @@ module Numeric.MixedTypes.Round (   -- * Rounded division + modulus-  CanDivIMod(..), CanDivIModIntegerSameType, modNoCN, divINoCN, divIModNoCN+  CanDivIMod(..)+  , CanDivIModIntegerSameType+  , CanDivIModIntegerSameTypeCN   -- * Rounding   , CanRound(..), HasIntegerBounds(..)   -- ** Tests@@ -21,6 +26,8 @@ ) where +import Utils.TH.DeclForTypes+ import Numeric.MixedTypes.PreludeHiding import qualified Prelude as P import Text.Printf@@ -31,8 +38,8 @@ import Test.Hspec import Test.QuickCheck as QC -import Numeric.CollectErrors--- import Control.CollectErrors+import Numeric.CollectErrors ( CN )+import qualified Numeric.CollectErrors as CN  import Numeric.MixedTypes.Literals import Numeric.MixedTypes.Bool@@ -46,9 +53,8 @@  class CanDivIMod t1 t2 where   type DivIType t1 t2-  type DivIType t1 t2 = CN Integer   type ModType t1 t2-  type ModType t1 t2 = EnsureCN t1+  type ModType t1 t2 = t1   divIMod :: t1 -> t2 -> (DivIType t1 t2, ModType t1 t2)   mod :: t1 -> t2 -> ModType t1 t2   mod a b = snd $ divIMod a b@@ -56,102 +62,89 @@   divI a b = fst $ divIMod a b  type CanDivIModIntegerSameType t =-  (CanDivIMod t t, CanEnsureCN t, DivIType t t ~ CN Integer, ModType t t ~ EnsureCN t)--modNoCN :: -  (CanDivIMod t1 t2-  , ModType t1 t2 ~ EnsureCN t1, CanEnsureCN t1)-  => -  t1 -> t2 -> t1-modNoCN x m = -  case deEnsureCN $ x `mod` m of-    Left err -> error $ show err-    Right xm -> xm--divINoCN :: -  (CanDivIMod t1 t2, DivIType t1 t2 ~ CN Integer)-  => -  t1 -> t2 -> Integer-divINoCN x m = (~!) $ x `divI` m+  (CanDivIMod t t, DivIType t t ~ Integer, ModType t t ~ t) -divIModNoCN :: -  (CanDivIMod t1 t2-  , ModType t1 t2 ~ EnsureCN t1, CanEnsureCN t1-  , DivIType t1 t2 ~ CN Integer)-  => -  t1 -> t2 -> (Integer, t1)-divIModNoCN x m = -  case deEnsureCN xm of-    Left err -> error $ show err-    Right xm2 -> ((~!) d, xm2)-  where-  (d,xm) = divIMod x m+type CanDivIModIntegerSameTypeCN t =+  (CanDivIMod t t, DivIType t t ~ CN Integer, ModType t t ~ t)  instance CanDivIMod Integer Integer where-  divIMod x m -    | m > 0 = (cn d, cn xm)-    | otherwise = (err, err)+  type DivIType Integer Integer = Integer+  divIMod = P.divMod++instance (CanDivIMod t1 t2, CanTestPosNeg t2) => CanDivIMod (CN t1) (CN t2) where+  type DivIType (CN t1) (CN t2) = (CN (DivIType t1 t2))+  type ModType (CN t1) (CN t2) = (CN (ModType t1 t2))+  divIMod x m+    | isCertainlyPositive m = (d, xm)+    | isCertainlyNegative m = (noval, noval)+    | otherwise = (errPote d, errPote xm)     where-    (d,xm) = P.divMod x m-    err = noValueNumErrorCertainECN sample_v $ OutOfRange $ "modulus not positive: " ++ show m-    sample_v = Just x+    (d,xm) = CN.lift2pair divIMod x m +noval :: CN v+noval = CN.noValueNumErrorCertain err+errPote :: CN t -> CN t+errPote = CN.prependErrorPotential err+err :: CN.NumError+err = CN.OutOfDomain "divIMod: modulus not positive"++$(declForTypes+  [[t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]+  (\ t -> [d|++    instance (CanDivIMod t1 $t) => CanDivIMod (CN t1) $t where+      type DivIType (CN t1) $t = (CN (DivIType t1 $t))+      type ModType (CN t1) $t = (CN (ModType t1 $t))+      divIMod x m+        | isCertainlyPositive m = (d, xm)+        | isCertainlyNegative m = (noval, noval)+        | otherwise = (errPote d, errPote xm)+        where+        (d,xm) = CN.lift1Tpair divIMod x m++    instance (CanDivIMod $t t2, CanTestPosNeg t2) => CanDivIMod $t (CN t2) where+      type DivIType $t (CN t2) = (CN (DivIType $t t2))+      type ModType $t (CN t2) = (CN (ModType $t t2))+      divIMod x m+        | isCertainlyPositive m = (d, xm)+        | isCertainlyNegative m = (noval, noval)+        | otherwise = (errPote d, errPote xm)+        where+        (d,xm) = CN.liftT1pair divIMod x m+  |]))+ instance CanDivIMod Rational Rational where-  divIMod x m -    | m > 0 = (cn d, cn xm)-    | otherwise = (err (d :: Integer), err xm)-    where-    (d,xm) = divMod' x m-    err :: (CanEnsureCN t) => t -> EnsureCN t-    err s = noValueNumErrorCertainECN (Just s) $ OutOfRange $ "modulus not positive: " ++ show m+  type DivIType Rational Rational = Integer+  divIMod = divMod'  instance CanDivIMod Rational Integer where+  type DivIType Rational Integer = Integer   divIMod x m = divIMod x (rational m)  instance CanDivIMod Double Double where-  divIMod x m -    | m > 0 = (cn d, cn xm)-    | otherwise = (err (d :: Integer), err xm)-    where-    (d,xm) = divMod' x m-    err :: (CanEnsureCN t) => t -> EnsureCN t-    err s = noValueNumErrorCertainECN (Just s) $ OutOfRange $ "modulus not positive: " ++ show m+  type DivIType Double Double = Integer+  divIMod = divMod'  instance CanDivIMod Double Integer where+  type DivIType Double Integer = Integer   divIMod x m = divIMod x (double m) -type CanDivIModX t =-  (CanDivIMod t t,-   ModType t t ~ EnsureCN t,-   DivIType t t ~ CN Integer,-   EnsureNoCN t ~ t,-   CanEnsureCN t,-   CanMulBy t Integer,-   CanAddSameType t,-   HasOrderCertainly t Integer,-   HasOrderCertainly t t,-   HasEqCertainly t t,-   CanTestFinite t,-   Show t, Arbitrary t)- {-|   HSpec properties that each implementation of CanRound should satisfy.  -} specCanDivIMod ::-  (CanDivIModX t, HasIntegers t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanDivIMod (T typeName :: T t) =   describe (printf "CanDivMod %s %s" typeName typeName) $ do     it "holds 0 <= x `mod` m < m" $ do       property $ \ (x :: t)  (m :: t) ->         isFinite x && m !>! 0 ==>-          let xm = x `modNoCN` m in+          let xm = x `mod` m in           (0 ?<=?$ xm) .&&. (xm ?<?$ m)     it "holds x == (x `div'` m)*m + (x `mod` m)" $ do       property $ \ (x :: t)  (m :: t) ->         isFinite x && m !>! 0 ==>-          let (d,xm) = divIModNoCN x m in+          let (d,xm) = divIMod x m in           (x ?==?$ (d*m + xm))   where   (?<=?$) :: (HasOrderCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property@@ -173,13 +166,15 @@   In other cases, it is sufficient to define `properFraction`. -} class CanRound t where-  properFraction :: t -> (Integer, t)-  default properFraction :: (P.RealFrac t) => t -> (Integer, t)+  type RoundType t+  type RoundType t = Integer+  properFraction :: t -> (RoundType t, t)+  default properFraction :: (P.RealFrac t, RoundType t ~ Integer) => t -> (RoundType t, t)   properFraction = P.properFraction-  truncate :: t -> Integer+  truncate :: t -> RoundType t   truncate = fst . properFraction-  round :: t -> Integer-  default round :: (HasOrderCertainly t Rational) => t -> Integer+  round :: t -> RoundType t+  default round :: (HasOrderCertainly t Rational, RoundType t ~ Integer) => t -> RoundType t   round x     | -0.5 !<! r && r !<! 0.5 = n     | r !<! -0.5 = n - 1@@ -190,15 +185,15 @@     | otherwise = error "round default defn: Bad value"     where     (n,r) = properFraction x-  ceiling :: t -> Integer-  default ceiling :: (CanTestPosNeg t) => t -> Integer+  ceiling :: t -> RoundType t+  default ceiling :: (CanTestPosNeg t, RoundType t ~ Integer) => t -> RoundType t   ceiling x     | isCertainlyPositive r = n + 1     | otherwise = n     where     (n,r) = properFraction x-  floor :: t -> Integer-  default floor :: (CanTestPosNeg t) => t -> Integer+  floor :: t -> RoundType t+  default floor :: (CanTestPosNeg t, RoundType t ~ Integer) => t -> RoundType t   floor x     | isCertainlyNegative r = n - 1     | otherwise = n@@ -211,21 +206,11 @@   ceiling = P.ceiling   floor = P.floor -type CanRoundX t =-  (CanRound t,-   CanNegSameType t,-   CanTestPosNeg t,-   HasOrderCertainly t Integer,-   CanTestFinite t,-   Show t, Arbitrary t)- {-|   HSpec properties that each implementation of CanRound should satisfy.  -} specCanRound ::-  (CanRoundX t, HasIntegers t)-  =>-  T t -> Spec+  _ => T t -> Spec specCanRound (T typeName :: T t) =   describe (printf "CanRound %s" typeName) $ do     it "holds floor x <= x <= ceiling x" $ do@@ -239,7 +224,8 @@     it "0 <= ceiling x - floor x <= 1" $ do       property $ \ (x :: t) ->         isFinite x ==>-          (ceiling x - floor x) `elem_PF` [0,1]+          let diffCeilingFloorX = ceiling x - floor x in+          (0 ?<=? diffCeilingFloorX) .&&. (diffCeilingFloorX ?<=? 1)     it "holds floor x = round x = ceiling x for integers" $ do       property $ \ (xi :: Integer) ->         let x = convertExactly xi :: t in@@ -251,12 +237,11 @@   (!<=!$) = printArgsIfFails2 "!<=!" (!<=!)   (!==!$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property   (!==!$) = printArgsIfFails2 "!==!" (!==!)-  elem_PF = printArgsIfFails2 "elem" elem   class HasIntegerBounds t where   integerBounds :: t -> (Integer, Integer)-  default integerBounds :: (CanRound t) => t -> (Integer, Integer)+  default integerBounds :: (CanRound t, RoundType t ~ Integer) => t -> (Integer, Integer)   integerBounds x = (floor x, ceiling x)  instance HasIntegerBounds Rational@@ -266,22 +251,11 @@ instance HasIntegerBounds Int where   integerBounds n = (n',n') where n' = integer n -type HasIntegerBoundsX t =-  (HasIntegerBounds t,-  --  CanNegSameType t,-  --  CanTestPosNeg t,-   HasOrderCertainly t Integer,-   CanTestFinite t,-   Show t, Arbitrary t)-- {-|   HSpec properties that each implementation of CanRound should satisfy.  -} specHasIntegerBounds ::-  (HasIntegerBoundsX t)-  =>-  T t -> Spec+  _ => T t -> Spec specHasIntegerBounds (T typeName :: T t) =   describe (printf "HasIntegerBounds %s" typeName) $ do     it "holds l <= x <= r" $ do

@@ -30,7 +30,7 @@ import Numeric.MixedTypes.Round  type CanEnforceRange t b =-    (CanAddSubMulDivCNBy t Integer+    (CanAddSubMulDivBy t Integer     , CanAddSameType t, CanSubSameType t, CanAbsSameType t     , CanDivIModIntegerSameType t     , ConvertibleExactly b t@@ -48,11 +48,11 @@     | not (l !<! u) = error "enforceRange: inconsistent range"     | l !<! a && a !<! u = a     | l !<! b && b !<! u = b-    | otherwise = (u-l)/!2+    | otherwise = (u+l)/2     where     l = convertExactly l_ :: t     u = convertExactly u_ :: t-    b = l + ((abs a) `modNoCN` (u-l))+    b = l + ((abs a) `mod` (u-l)) enforceRange (Just l_, _) (a::t)     | l !<! a = a     | otherwise = (2*l-a+1)

@@ -17,7 +17,7 @@  spec :: Spec spec = do-  specCanDivIMod tInteger-  specCanDivIMod tRational+  specCanDivIMod tCNInteger+  specCanDivIMod tCNRational   specCanRound tRational   -- specCanRound tDouble