{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Numeric.Optics
( base
, integral
, binary
, octal
, decimal
, hex
, 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
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
$ \i :: 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 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
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
base :: (HasCallStack, Integral a) => Int -> Prism' String a
base :: Int -> Prism' String a
base b :: Int
b
| Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 Bool -> Bool -> Bool
|| Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 36 = String -> Prism' String a
forall a. HasCallStack => String -> a
error ("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 n :: 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) ""
intRead :: String -> Either String a
intRead s :: 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
[(n :: a
n,"")] -> a -> Either String a
forall a b. b -> Either a b
Right a
n
_ -> String -> Either String a
forall a b. a -> Either a b
Left String
s
{-# INLINE base #-}
intToDigit' :: HasCallStack => Int -> Char
intToDigit' :: Int -> Char
intToDigit' i :: Int
i
| Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 10 = Int -> Char
chr (Char -> Int
ord '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
>= 10 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 36 = Int -> Char
chr (Char -> Int
ord 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- 10)
| Bool
otherwise = String -> Char
forall a. HasCallStack => String -> a
error ("intToDigit': Invalid int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i)
{-# INLINE intToDigit' #-}
digitToInt' :: HasCallStack => Char -> Int
digitToInt' :: Char -> Int
digitToInt' c :: Char
c = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (String -> Int
forall a. HasCallStack => String -> a
error ("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' #-}
digitToIntMay :: Char -> Maybe Int
digitToIntMay :: Char -> Maybe Int
digitToIntMay c :: 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 '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 'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 10)
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
{-# INLINE digitToIntMay #-}
isDigit' :: Int -> Char -> Bool
isDigit' :: Int -> Char -> Bool
isDigit' b :: Int
b c :: Char
c = case Char -> Maybe Int
digitToIntMay Char
c of
Just i :: Int
i -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
b
_ -> Bool
False
{-# INLINE isDigit' #-}
showSigned' :: Real a => (a -> ShowS) -> a -> ShowS
showSigned' :: (a -> String -> String) -> a -> String -> String
showSigned' f :: a -> String -> String
f n :: a
n
| a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Char -> String -> String
showChar '-' (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' #-}
readSigned' :: Real a => ReadS a -> ReadS a
readSigned' :: ReadS a -> ReadS a
readSigned' f :: ReadS a
f ('-':xs :: 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' f :: ReadS a
f xs :: String
xs = ReadS a
f String
xs
{-# INLINE readSigned' #-}
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 2
{-# INLINE binary #-}
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 8
{-# INLINE octal #-}
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 10
{-# INLINE decimal #-}
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 16
{-# INLINE hex #-}
adding :: Num a => a -> Iso' a a
adding :: a -> Iso' a a
adding n :: 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 :: Num a => a -> Iso' a a
subtracting :: a -> Iso' a a
subtracting n :: 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 :: (Fractional a, Eq a) => a -> Iso' a a
multiplying :: a -> Iso' a a
multiplying 0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error "Numeric.Optics.multiplying: factor 0"
multiplying n :: 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 :: (Fractional a, Eq a) => a -> Iso' a a
dividing :: a -> Iso' a a
dividing 0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error "Numeric.Optics.dividing: divisor 0"
dividing n :: 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 :: (Floating a, Eq a) => a -> Iso' a a
exponentiating :: a -> Iso' a a
exponentiating 0 = String -> Iso' a a
forall a. HasCallStack => String -> a
error "Numeric.Optics.exponentiating: exponent 0"
exponentiating n :: 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 :: 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 #-}