diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,21 @@ -Unreleased -========== - + + + +0.5.0 +===== +* [!1001](https://gitlab.com/morley-framework/morley/-/merge_requests/1001) + Make fromIntegralNoOverflow safe(r) + + `fromIntegralNoOverflow` now doesn't throw `ArithException` `Underflow` + + Moved `fromIntegralNoOverflow` from `Unsafe` to `Prelude` +* [!936](https://gitlab.com/morley-framework/morley/-/merge_requests/936) + + Hide `Universum`'s `fromIntegral` and redefine it as `intCast` in `Prelude`. + + Re-export `intCastMaybe` as `fromIntegralMaybe` in `Prelude`. + + Add `fromIntegralToRealFrac` to `Prelude`. + + Add `fromIntegralOverflowing` to `Prelude`. + + Add `fromIntegralNoOverflow` to `Unsafe`. + + Add `Unsafe.fromIntegral` which is like `Universum`'s `fromIntegral` but raises exception on overflow/underflow. +* [!945](https://gitlab.com/morley-framework/morley/-/merge_requests/945) + + Bump Stackage LTS version from 17.9 to 18.10. 0.4.2 ===== diff --git a/morley-prelude.cabal b/morley-prelude.cabal --- a/morley-prelude.cabal +++ b/morley-prelude.cabal @@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.3. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack name: morley-prelude -version: 0.4.2 +version: 0.5.0 synopsis: A custom prelude used in Morley description: A custom prelude used in Morley. It re-exports the Universum prelude and makes some tiny changes. category: Prelude @@ -27,6 +27,7 @@ library exposed-modules: Morley.Prelude.Boolean + Morley.Prelude.FromIntegral Prelude Unsafe other-modules: @@ -35,10 +36,57 @@ Paths_morley_prelude hs-source-dirs: src - default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumericUnderscores NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + EmptyCase + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NegativeLiterals + NumericUnderscores + NumDecimals + OverloadedLabels + OverloadedStrings + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + StrictData + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + UndecidableSuperClasses + ViewPatterns ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages build-depends: base-noprelude >=4.7 && <5 + , int-cast , lens , universum default-language: Haskell2010 diff --git a/src/Morley/Prelude/Boolean.hs b/src/Morley/Prelude/Boolean.hs --- a/src/Morley/Prelude/Boolean.hs +++ b/src/Morley/Prelude/Boolean.hs @@ -4,7 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} --- | This module replaces the monomorphic boolean operators from 'Prelude' +-- | This module replaces the monomorphic boolean operators from "Prelude" -- with a set of polymorphic operators. module Morley.Prelude.Boolean ( Boolean(..) diff --git a/src/Morley/Prelude/FromIntegral.hs b/src/Morley/Prelude/FromIntegral.hs new file mode 100644 --- /dev/null +++ b/src/Morley/Prelude/FromIntegral.hs @@ -0,0 +1,111 @@ +-- SPDX-FileCopyrightText: 2021 Tocqueville Group +-- +-- SPDX-License-Identifier: LicenseRef-MIT-TQ + +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Safe(r) converters from @Integral@ types +module Morley.Prelude.FromIntegral + ( IntBaseType + , IsIntSubType + , fromIntegral + , fromIntegralMaybe + , fromIntegralNoOverflow + , fromIntegralOverflowing + , fromIntegralToRealFrac + ) where + +import Control.Exception (ArithException(..)) +import Data.Bits (Bits) +import Data.IntCast (IntBaseType, IsIntSubType, intCast, intCastMaybe) +import Data.Ratio ((%)) +import System.IO.Unsafe (unsafePerformIO) +import Universum hiding (fromInteger, fromIntegral) +import qualified Universum (fromIntegral) + +-- | Statically safe converter between 'Integral' +-- types, which is just 'intCast' under the hood. +-- +-- It is used to turn the value of type @a@ into +-- the value of type @b@ such that @a@ is subtype +-- of @b@. It is needed to prevent silent unsafe +-- conversions. +fromIntegral :: (Integral a, Integral b, IsIntSubType a b ~ 'True) => a -> b +fromIntegral = intCast + +-- | Statically safe converter between 'Integral' +-- types, which is just 'intCastMaybe' under the +-- hood. Unlike 'fromIntegral' accept any @a@ and +-- @b@. Return @Just value@ if conversion is +-- possible at runtime and @Nothing@ otherwise. +fromIntegralMaybe :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b +fromIntegralMaybe = intCastMaybe + +-- | Statically safe converter between 'Integral' +-- and 'RealFrac' types. Could be applied to cast +-- common types like @Float@, @Double@ and @Scientific@. +-- +-- It is primarily needed to replace usages of +-- 'Unsafe.fromIntegral', which are safe actually +-- as integral numbers are being casted to +-- fractional ones. +fromIntegralToRealFrac :: (Integral a, RealFrac b, IsIntSubType a Integer ~ 'True) => a -> b +fromIntegralToRealFrac = fromRational . (% 1) . fromIntegral + +{- | Runtime-safe converter between 'Integral' types, which is just +'Universum.fromIntegral' under the hood. + +It is needed to semantically distinguish usages, where overflow is intended, +from those that have to fail on overflow. E.g. @Int8 -> Word8@ with intended +bits reinterpretation from lossy @Integer -> Int@. + +>>> fromIntegralOverflowing @Int8 @Word8 (-1) +255 +>>> fromIntegralOverflowing @Natural @Int8 450 +-62 + +Please note that like @fromIntegral@ from @base@, this will throw on some +conversions! + +>>> fromIntegralOverflowing @Int @Natural (-1) +*** Exception: arithmetic underflow + +See 'fromIntegralNoOverflow' for an alternative that doesn't throw. +-} +fromIntegralOverflowing :: (Integral a, Num b) => a -> b +fromIntegralOverflowing = Universum.fromIntegral + +{- | Statically safe converter between 'Integral' types +checking for overflow/underflow. Returns @Right value@ if conversion does not +produce overflow/underflow and @Left ArithException@ with corresponding +'ArithException' (@Overflow@/@Underflow@) otherwise. + +Note the function is strict in its argument. + +>>> fromIntegralNoOverflow @Int @Word 123 +Right 123 +>>> fromIntegralNoOverflow @Int @Word (-123) +Left arithmetic underflow +>>> fromIntegralNoOverflow @Int @Integer (-123) +Right (-123) +>>> fromIntegralNoOverflow @Int @Natural (-123) +Left arithmetic underflow +>>> fromIntegralNoOverflow @Int @Int8 127 +Right 127 +>>> fromIntegralNoOverflow @Int @Int8 128 +Left arithmetic overflow +-} +fromIntegralNoOverflow :: (Integral a, Integral b) => a -> Either ArithException b +fromIntegralNoOverflow !a = do + b <- tryFromIntegral a + case compare (toInteger a) (toInteger b) of + EQ -> Right b + LT -> Left Underflow + GT -> Left Overflow + where + tryFromIntegral x = unsafePerformIO $ + (let !y = Universum.fromIntegral x in pure (Right y)) + `catch` \case + Overflow -> pure $ Left Overflow + Underflow -> pure $ Left Underflow + e -> throwM e diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -2,16 +2,20 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ --- | This module essentially replaces the default Prelude with Universum. +-- | This module essentially replaces the default "Prelude" with "Universum". -- --- It works because we are using the 'base-noprelude' package instead of 'base'. +-- It works because we are using the @base-noprelude@ package instead of @base@. module Prelude ( module Control.Lens , module Universum , for + -- * Converters from @Integral@ types + , module FromIntegral -- * Overloaded boolean operators , module Boolean + -- * Unsafe conversions + , Unsafe.fromInteger ) where import Control.Lens @@ -19,6 +23,9 @@ (%~), (&), (.~), (<&>), (^.), (^..), (^?)) import Data.Traversable (for) import Morley.Prelude.Boolean as Boolean +import Morley.Prelude.FromIntegral as FromIntegral import Universum hiding - (Key, Lens, Lens', Nat, Traversal, Traversal', Val, _1, _2, _3, _4, _5, over, preuse, preview, - readFile, set, use, view, writeFile, (%~), (&&), (&), (.~), (<&>), (^.), (^..), (^?), (||)) + (Key, Lens, Lens', Nat, Traversal, Traversal', Val, _1, _2, _3, _4, _5, fromInteger, fromIntegral, + over, preuse, preview, readFile, set, use, view, writeFile, (%~), (&&), (&), (.~), (<&>), (^.), + (^..), (^?), (||)) +import qualified Unsafe (fromInteger) diff --git a/src/Unsafe.hs b/src/Unsafe.hs --- a/src/Unsafe.hs +++ b/src/Unsafe.hs @@ -2,11 +2,42 @@ -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ +{-# LANGUAGE NoImplicitPrelude #-} + -- | Unsafe utilities. -- -- This module should be imported qualified. module Unsafe - ( module Universum.Unsafe - ) where + ( module Universum.Unsafe + -- * Unsafe converters between @Integral@ types checking for overflow/underflow + , Unsafe.fromIntegral + , Unsafe.fromInteger + ) where + +import Morley.Prelude.FromIntegral (fromIntegralNoOverflow) +import Universum import Universum.Unsafe + +-- | Unsafe converter between 'Integral' types +-- checking for overflow/underflow. Return +-- @value@ if conversion does not produce +-- overflow/underflow and raise an exception +-- with corresponding error message otherwise. +-- +-- It is needed to replace 'Universum.Base.fromIntegral' +-- which misses most of the overflow/underflow checks. +-- +-- Note the function is strict in its argument. +fromIntegral :: (HasCallStack, Integral a, Integral b) => a -> b +fromIntegral = either (error . fromString . displayException) id . fromIntegralNoOverflow + +-- | Unsafe converter between 'Integer' and 'Integral' +-- types checking for overflow/underflow. Return @value@ +-- if conversion does not produce overflow/underflow and +-- raise an exception with corresponding error message +-- otherwise. +-- +-- Note the function is strict in its argument. +fromInteger :: (HasCallStack, Integral a) => Integer -> a +fromInteger = Unsafe.fromIntegral