{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
-- |
-- Module: Numeric.Optics
-- Description: Optics for working with numeric types.
--
module Numeric.Optics
  ( base
  , integral
    -- * Predefined bases
  , binary
  , octal
  , decimal
  , hex
    -- * Arithmetic lenses
  , adding
  , subtracting
  , multiplying
  , dividing
  , exponentiating
  , negated
  , pattern Integral
  ) where

import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit)
import Data.Maybe (fromMaybe)
import GHC.Stack
import Numeric (readInt, showIntAtBase)

import Data.Tuple.Optics
import Optics.AffineFold
import Optics.Iso
import Optics.Optic
import Optics.Prism
import Optics.Review
import Optics.Setter

-- | This 'Prism' can be used to model the fact that every 'Prelude.Integral'
-- type is a subset of 'Integer'.
--
-- Embedding through the 'Prism' only succeeds if the 'Integer' would pass
-- through unmodified when re-extracted.
integral :: (Integral a, Integral b) => Prism Integer Integer a b
integral :: Prism Integer Integer a b
integral = (b -> Integer)
-> (Integer -> Either Integer a) -> Prism Integer Integer a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> Integer
forall a. Integral a => a -> Integer
toInteger ((Integer -> Either Integer a) -> Prism Integer Integer a b)
-> (Integer -> Either Integer a) -> Prism Integer Integer a b
forall a b. (a -> b) -> a -> b
$ \Integer
i -> let a :: a
a = Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i in
  if a -> Integer
forall a. Integral a => a -> Integer
toInteger a
a Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i
  then a -> Either Integer a
forall a b. b -> Either a b
Right a
a
  else Integer -> Either Integer a
forall a b. a -> Either a b
Left Integer
i
{-# INLINE integral #-}

-- | Pattern synonym that can be used to construct or pattern match on an
-- 'Integer' as if it were of any 'Prelude.Integral' type.
pattern Integral :: forall a. Integral a => a -> Integer
pattern $bIntegral :: a -> Integer
$mIntegral :: forall r a. Integral a => Integer -> (a -> r) -> (Void# -> r) -> r
Integral a <- (preview integral -> Just a) where
  Integral a
a = Optic' A_Prism NoIx Integer a -> a -> Integer
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic' A_Prism NoIx Integer a
forall a b. (Integral a, Integral b) => Prism Integer Integer a b
integral a
a

-- | A prism that shows and reads integers in base-2 through base-36
--
-- Note: This is an improper prism, since leading 0s are stripped when reading.
--
-- >>> "100" ^? base 16
-- Just 256
--
-- >>> 1767707668033969 ^. re (base 36)
-- "helloworld"
base :: (HasCallStack, Integral a) => Int -> Prism' String a
base :: Int -> Prism' String a
base Int
b
  | Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Bool -> Bool -> Bool
|| Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
36 = String -> Prism' String a
forall a. HasCallStack => String -> a
error (String
"base: Invalid base " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b)
  | Bool
otherwise       = (a -> String) -> (String -> Either String a) -> Prism' String a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> String
intShow String -> Either String a
intRead
  where
    intShow :: a -> String
intShow a
n = (Integer -> String -> String) -> Integer -> String -> String
forall a.
Real a =>
(a -> String -> String) -> a -> String -> String
showSigned' (Integer -> (Int -> Char) -> Integer -> String -> String
forall a.
(Integral a, Show a) =>
a -> (Int -> Char) -> a -> String -> String
showIntAtBase (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
b) HasCallStack => Int -> Char
Int -> Char
intToDigit') (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
n) String
""

    intRead :: String -> Either String a
intRead String
s =
      case ReadS a -> ReadS a
forall a. Real a => ReadS a -> ReadS a
readSigned' (a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
forall a. Num a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt (Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b) (Int -> Char -> Bool
isDigit' Int
b) HasCallStack => Char -> Int
Char -> Int
digitToInt') String
s of
        [(a
n,String
"")] -> a -> Either String a
forall a b. b -> Either a b
Right a
n
        [(a, String)]
_ -> String -> Either String a
forall a b. a -> Either a b
Left String
s
{-# INLINE base #-}

-- | Like 'Data.Char.intToDigit', but handles up to base-36
intToDigit' :: HasCallStack => Int -> Char
intToDigit' :: Int -> Char
intToDigit' Int
i
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0  Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10 = Int -> Char
chr (Char -> Int
ord Char
'0' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i)
  | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
36 = Int -> Char
chr (Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10)
  | Bool
otherwise = String -> Char
forall a. HasCallStack => String -> a
error (String
"intToDigit': Invalid int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
{-# INLINE intToDigit' #-}

-- | Like 'Data.Char.digitToInt', but handles up to base-36
digitToInt' :: HasCallStack => Char -> Int
digitToInt' :: Char -> Int
digitToInt' Char
c = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error (String
"digitToInt': Invalid digit " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c))
                          (Char -> Maybe Int
digitToIntMay Char
c)
{-# INLINE digitToInt' #-}

-- | A safe variant of 'digitToInt''
digitToIntMay :: Char -> Maybe Int
digitToIntMay :: Char -> Maybe Int
digitToIntMay Char
c
  | Char -> Bool
isDigit Char
c      = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')
  | Char -> Bool
isAsciiLower Char
c = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
  | Char -> Bool
isAsciiUpper Char
c = Int -> Maybe Int
forall a. a -> Maybe a
Just (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
  | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
{-# INLINE digitToIntMay #-}

-- | Select digits that fall into the given base
isDigit' :: Int -> Char -> Bool
isDigit' :: Int -> Char -> Bool
isDigit' Int
b Char
c = case Char -> Maybe Int
digitToIntMay Char
c of
  Just Int
i -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b
  Maybe Int
_ -> Bool
False
{-# INLINE isDigit' #-}

-- | A simpler variant of 'Numeric.showSigned' that only prepends a dash and
-- doesn't know about parentheses
showSigned' :: Real a => (a -> ShowS) -> a -> ShowS
showSigned' :: (a -> String -> String) -> a -> String -> String
showSigned' a -> String -> String
f a
n
  | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0     = Char -> String -> String
showChar Char
'-' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String -> String
f (a -> a
forall a. Num a => a -> a
negate a
n)
  | Bool
otherwise = a -> String -> String
f a
n
{-# INLINE showSigned' #-}

-- | A simpler variant of 'Numeric.readSigned' that supports any base, only
-- recognizes an initial dash and doesn't know about parentheses
readSigned' :: Real a => ReadS a -> ReadS a
readSigned' :: ReadS a -> ReadS a
readSigned' ReadS a
f (Char
'-':String
xs) = ReadS a
f String
xs [(a, String)] -> ((a, String) -> (a, String)) -> [(a, String)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Optic A_Lens NoIx (a, String) (a, String) a a
-> (a -> a) -> (a, String) -> (a, String)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic A_Lens NoIx (a, String) (a, String) a a
forall s t a b. Field1 s t a b => Lens s t a b
_1 a -> a
forall a. Num a => a -> a
negate
readSigned' ReadS a
f String
xs       = ReadS a
f String
xs
{-# INLINE readSigned' #-}

-- | @'binary' = 'base' 2@
binary :: Integral a => Prism' String a
binary :: Prism' String a
binary = Int -> Prism' String a
forall a. (HasCallStack, Integral a) => Int -> Prism' String a
base Int
2
{-# INLINE binary #-}

-- | @'octal' = 'base' 8@
octal :: Integral a => Prism' String a
octal :: Prism' String a
octal = Int -> Prism' String a
forall a. (HasCallStack, Integral a) => Int -> Prism' String a
base Int
8
{-# INLINE octal #-}

-- | @'decimal' = 'base' 10@
decimal :: Integral a => Prism' String a
decimal :: Prism' String a
decimal = Int -> Prism' String a
forall a. (HasCallStack, Integral a) => Int -> Prism' String a
base Int
10
{-# INLINE decimal #-}

-- | @'hex' = 'base' 16@
hex :: Integral a => Prism' String a
hex :: Prism' String a
hex = Int -> Prism' String a
forall a. (HasCallStack, Integral a) => Int -> Prism' String a
base Int
16
{-# INLINE hex #-}

-- | @'adding' n = 'iso' (+n) (subtract n)@
--
-- >>> [1..3] ^.. traversed % adding 1000
-- [1001,1002,1003]
adding :: Num a => a -> Iso' a a
adding :: a -> Iso' a a
adding a
n = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (a -> a -> a
forall a. Num a => a -> a -> a
+a
n) (a -> a -> a
forall a. Num a => a -> a -> a
subtract a
n)
{-# INLINE adding #-}

-- | @
-- 'subtracting' n = 'iso' (subtract n) ((+n)
-- 'subtracting' n = 'Optics.Re.re' ('adding' n)
-- @
subtracting :: Num a => a -> Iso' a a
subtracting :: a -> Iso' a a
subtracting a
n = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (a -> a -> a
forall a. Num a => a -> a -> a
subtract a
n) (a -> a -> a
forall a. Num a => a -> a -> a
+a
n)
{-# INLINE subtracting #-}

-- | @'multiplying' n = iso (*n) (/n)@
--
-- Note: This errors for n = 0
--
-- >>> 5 & multiplying 1000 %~ (+3)
-- 5.003
--
-- >>> let fahrenheit = multiplying (9/5) % adding 32 in 230 ^. re fahrenheit
-- 110.0
multiplying :: (Fractional a, Eq a) => a -> Iso' a a
multiplying :: a -> Iso' a a
multiplying a
0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error String
"Numeric.Optics.multiplying: factor 0"
multiplying a
n = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (a -> a -> a
forall a. Num a => a -> a -> a
*a
n) (a -> a -> a
forall a. Fractional a => a -> a -> a
/a
n)
{-# INLINE multiplying #-}

-- | @
-- 'dividing' n = 'iso' (/n) (*n)
-- 'dividing' n = 'Optics.Re.re' ('multiplying' n)@
--
-- Note: This errors for n = 0
dividing :: (Fractional a, Eq a) => a -> Iso' a a
dividing :: a -> Iso' a a
dividing a
0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error String
"Numeric.Optics.dividing: divisor 0"
dividing a
n = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (a -> a -> a
forall a. Fractional a => a -> a -> a
/a
n) (a -> a -> a
forall a. Num a => a -> a -> a
*a
n)
{-# INLINE dividing #-}

-- | @'exponentiating' n = 'iso' (**n) (**recip n)@
--
-- Note: This errors for n = 0
--
-- >>> au (coerced1 @Sum % re (exponentiating 2)) (foldMapOf each) (3,4) == 5
-- True
exponentiating :: (Floating a, Eq a) => a -> Iso' a a
exponentiating :: a -> Iso' a a
exponentiating a
0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error String
"Numeric.Optics.exponentiating: exponent 0"
exponentiating a
n = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (a -> a -> a
forall a. Floating a => a -> a -> a
**a
n) (a -> a -> a
forall a. Floating a => a -> a -> a
**a -> a
forall a. Fractional a => a -> a
recip a
n)
{-# INLINE exponentiating #-}

-- | @'negated' = 'iso' 'negate' 'negate'@
--
-- >>> au (coerced1 @Sum % negated) (foldMapOf each) (3,4) == 7
-- True
--
-- >>> au (coerced1 @Sum) (foldMapOf (each % negated)) (3,4) == -7
-- True
negated :: Num a => Iso' a a
negated :: Iso' a a
negated = (a -> a) -> (a -> a) -> Iso' a a
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso a -> a
forall a. Num a => a -> a
negate a -> a
forall a. Num a => a -> a
negate
{-# INLINE negated #-}

-- $setup
-- >>> import Data.Monoid
-- >>> import Optics.Core