{-# 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 toInteger $ \i -> let a = fromInteger i in
  if toInteger a == i
  then Right a
  else Left 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 Integral a <- (preview integral -> Just a) where
  Integral a = review integral 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 b
  | b < 2 || b > 36 = error ("base: Invalid base " ++ show b)
  | otherwise       = prism intShow intRead
  where
    intShow n = showSigned' (showIntAtBase (toInteger b) intToDigit') (toInteger n) ""

    intRead s =
      case readSigned' (readInt (fromIntegral b) (isDigit' b) digitToInt') s of
        [(n,"")] -> Right n
        _ -> Left s
{-# INLINE base #-}

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

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

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

-- | Select digits that fall into the given base
isDigit' :: Int -> Char -> Bool
isDigit' b c = case digitToIntMay c of
  Just i -> i < b
  _ -> 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' f n
  | n < 0     = showChar '-' . f (negate n)
  | otherwise = f 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' f ('-':xs) = f xs <&> over _1 negate
readSigned' f xs       = f xs
{-# INLINE readSigned' #-}

-- | @'binary' = 'base' 2@
binary :: Integral a => Prism' String a
binary = base 2
{-# INLINE binary #-}

-- | @'octal' = 'base' 8@
octal :: Integral a => Prism' String a
octal = base 8
{-# INLINE octal #-}

-- | @'decimal' = 'base' 10@
decimal :: Integral a => Prism' String a
decimal = base 10
{-# INLINE decimal #-}

-- | @'hex' = 'base' 16@
hex :: Integral a => Prism' String a
hex = base 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 n = iso (+n) (subtract n)
{-# INLINE adding #-}

-- | @
-- 'subtracting' n = 'iso' (subtract n) ((+n)
-- 'subtracting' n = 'Optics.Re.re' ('adding' n)
-- @
subtracting :: Num a => a -> Iso' a a
subtracting n = iso (subtract n) (+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 0 = error "Numeric.Optics.multiplying: factor 0"
multiplying n = iso (*n) (/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 0 = error "Numeric.Optics.dividing: divisor 0"
dividing n = iso (/n) (*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 0 = error "Numeric.Optics.exponentiating: exponent 0"
exponentiating n = iso (**n) (**recip 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 negate negate
{-# INLINE negated #-}

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