{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
module Test.IOTasks.Internal.Overflow (
OverflowWarning(..),
evalOverflow,
OverflowTreatment(..), SubCheck(..),
modifySubCheck,
EffectEval(..),
effectEval,
I, fromInt,
unwrapI, unwrapIs,
) where
import Control.Monad.Identity (runIdentity)
import Data.Maybe (fromMaybe)
import Data.Bifunctor (second)
import Type.Reflection
import Type.Match
data OverflowWarning = OverflowOccurred | NoOverflow deriving (OverflowWarning -> OverflowWarning -> Bool
(OverflowWarning -> OverflowWarning -> Bool)
-> (OverflowWarning -> OverflowWarning -> Bool)
-> Eq OverflowWarning
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OverflowWarning -> OverflowWarning -> Bool
== :: OverflowWarning -> OverflowWarning -> Bool
$c/= :: OverflowWarning -> OverflowWarning -> Bool
/= :: OverflowWarning -> OverflowWarning -> Bool
Eq,Int -> OverflowWarning -> ShowS
[OverflowWarning] -> ShowS
OverflowWarning -> String
(Int -> OverflowWarning -> ShowS)
-> (OverflowWarning -> String)
-> ([OverflowWarning] -> ShowS)
-> Show OverflowWarning
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OverflowWarning -> ShowS
showsPrec :: Int -> OverflowWarning -> ShowS
$cshow :: OverflowWarning -> String
show :: OverflowWarning -> String
$cshowList :: [OverflowWarning] -> ShowS
showList :: [OverflowWarning] -> ShowS
Show)
instance Semigroup OverflowWarning where
OverflowWarning
NoOverflow <> :: OverflowWarning -> OverflowWarning -> OverflowWarning
<> OverflowWarning
o = OverflowWarning
o
OverflowWarning
o <> OverflowWarning
NoOverflow = OverflowWarning
o
OverflowWarning
OverflowOccurred <> OverflowWarning
OverflowOccurred = OverflowWarning
OverflowOccurred
instance Monoid OverflowWarning where
mempty :: OverflowWarning
mempty = OverflowWarning
NoOverflow
class EffectEval t where
type Env t
pureEval :: (Applicative f, Typeable a) => (forall x. Typeable x => t x -> f x) -> Env t -> t a -> f a
eval :: Typeable a => Env t -> t a -> a
eval Env t
d = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> (t a -> Identity a) -> t a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Typeable x => t x -> Maybe (Identity x))
-> Env t -> t a -> Identity a
forall (t :: * -> *) (f :: * -> *) a.
(EffectEval t, Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t a -> f a
effectEval (Maybe (Identity x) -> t x -> Maybe (Identity x)
forall a b. a -> b -> a
const Maybe (Identity x)
forall a. Maybe a
Nothing) Env t
d
effectEval :: (EffectEval t, Applicative f, Typeable a) => (forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t a -> f a
effectEval :: forall (t :: * -> *) (f :: * -> *) a.
(EffectEval t, Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t a -> f a
effectEval forall x. Typeable x => t x -> Maybe (f x)
f Env t
d t a
x = f a -> Maybe (f a) -> f a
forall a. a -> Maybe a -> a
fromMaybe ((forall x. Typeable x => t x -> f x) -> Env t -> t a -> f a
forall (t :: * -> *) (f :: * -> *) a.
(EffectEval t, Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> f x) -> Env t -> t a -> f a
forall (f :: * -> *) a.
(Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> f x) -> Env t -> t a -> f a
pureEval ((forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t x -> f x
forall (t :: * -> *) (f :: * -> *) a.
(EffectEval t, Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t a -> f a
effectEval t x -> Maybe (f x)
forall x. Typeable x => t x -> Maybe (f x)
f Env t
d) Env t
d t a
x) (Maybe (f a) -> f a) -> Maybe (f a) -> f a
forall a b. (a -> b) -> a -> b
$ t a -> Maybe (f a)
forall x. Typeable x => t x -> Maybe (f x)
f t a
x
evalOverflow :: (EffectEval t, Typeable a) => OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
evalOverflow :: forall (t :: * -> *) a.
(EffectEval t, Typeable a) =>
OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
evalOverflow = OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
forall (t :: * -> *) a.
(EffectEval t, Typeable a) =>
OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
evalOverflow' where
evalOverflow' :: forall t a. (EffectEval t, Typeable a) => OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
evalOverflow' :: forall (t :: * -> *) a.
(EffectEval t, Typeable a) =>
OverflowTreatment t -> Env t -> t a -> (OverflowWarning, a)
evalOverflow' OverflowTreatment{Env t -> t Integer -> Either (SubCheck t I) I
Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
evalITerm :: Env t -> t Integer -> Either (SubCheck t I) I
evalIList :: Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
evalIList :: forall (t :: * -> *).
OverflowTreatment t
-> Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
evalITerm :: forall (t :: * -> *).
OverflowTreatment t
-> Env t -> t Integer -> Either (SubCheck t I) I
..} Env t
d = (forall x. Typeable x => t x -> Maybe (OverflowWarning, x))
-> Env t -> t a -> (OverflowWarning, a)
forall (t :: * -> *) (f :: * -> *) a.
(EffectEval t, Applicative f, Typeable a) =>
(forall x. Typeable x => t x -> Maybe (f x)) -> Env t -> t a -> f a
effectEval (Env t -> t x -> Maybe (OverflowWarning, x)
forall a. Typeable a => Env t -> t a -> Maybe (OverflowWarning, a)
effect Env t
d) Env t
d
where
effect :: forall a. Typeable a => Env t -> t a -> Maybe (OverflowWarning, a)
effect :: forall a. Typeable a => Env t -> t a -> Maybe (OverflowWarning, a)
effect Env t
d t a
x = forall {k} (a :: k) r. Typeable a => [Case a r] -> r
forall a r. Typeable a => [Case a r] -> r
matchType @a
[ forall {k1} {k} (a :: k1) (x :: k) r.
Typeable a =>
((a :~~: x) -> r) -> Case x r
forall a x r. Typeable a => ((a :~~: x) -> r) -> Case x r
inCaseOfE' @Integer (((Integer :~~: a) -> Maybe (OverflowWarning, a))
-> Case a (Maybe (OverflowWarning, a)))
-> ((Integer :~~: a) -> Maybe (OverflowWarning, a))
-> Case a (Maybe (OverflowWarning, a))
forall a b. (a -> b) -> a -> b
$ \Integer :~~: a
HRefl ->
case Env t -> t Integer -> Either (SubCheck t I) I
evalITerm Env t
d t a
t Integer
x of
Right I
i -> (OverflowWarning, Integer) -> Maybe (OverflowWarning, Integer)
forall a. a -> Maybe a
Just ((OverflowWarning, Integer) -> Maybe (OverflowWarning, Integer))
-> (OverflowWarning, Integer) -> Maybe (OverflowWarning, Integer)
forall a b. (a -> b) -> a -> b
$ I -> (OverflowWarning, Integer)
unwrapI I
i
Left (SubCheck t a
t a -> I
f) -> do
(OverflowWarning, a)
fx <- Env t -> t a -> Maybe (OverflowWarning, a)
forall a. Typeable a => Env t -> t a -> Maybe (OverflowWarning, a)
effect Env t
d t a
t
(OverflowWarning, a) -> Maybe (OverflowWarning, a)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((OverflowWarning, a) -> Maybe (OverflowWarning, a))
-> (OverflowWarning, a) -> Maybe (OverflowWarning, a)
forall a b. (a -> b) -> a -> b
$ do
a
x <- (OverflowWarning, a)
fx
I -> (OverflowWarning, Integer)
unwrapI (I -> (OverflowWarning, Integer))
-> I -> (OverflowWarning, Integer)
forall a b. (a -> b) -> a -> b
$ a -> I
f a
x
, forall {k1} {k} (a :: k1) (x :: k) r.
Typeable a =>
((a :~~: x) -> r) -> Case x r
forall a x r. Typeable a => ((a :~~: x) -> r) -> Case x r
inCaseOfE' @[Integer] ((([Integer] :~~: a) -> Maybe (OverflowWarning, a))
-> Case a (Maybe (OverflowWarning, a)))
-> (([Integer] :~~: a) -> Maybe (OverflowWarning, a))
-> Case a (Maybe (OverflowWarning, a))
forall a b. (a -> b) -> a -> b
$ \[Integer] :~~: a
HRefl ->
case Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
evalIList Env t
d t a
t [Integer]
x of
Right [I]
i -> (OverflowWarning, [Integer]) -> Maybe (OverflowWarning, [Integer])
forall a. a -> Maybe a
Just ((OverflowWarning, [Integer])
-> Maybe (OverflowWarning, [Integer]))
-> (OverflowWarning, [Integer])
-> Maybe (OverflowWarning, [Integer])
forall a b. (a -> b) -> a -> b
$ [I] -> (OverflowWarning, [Integer])
unwrapIs [I]
i
Left (SubCheck t a
t a -> [I]
f) -> do
(OverflowWarning, a)
fx <- Env t -> t a -> Maybe (OverflowWarning, a)
forall a. Typeable a => Env t -> t a -> Maybe (OverflowWarning, a)
effect Env t
d t a
t
(OverflowWarning, a) -> Maybe (OverflowWarning, a)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((OverflowWarning, a) -> Maybe (OverflowWarning, a))
-> (OverflowWarning, a) -> Maybe (OverflowWarning, a)
forall a b. (a -> b) -> a -> b
$ do
a
x <- (OverflowWarning, a)
fx
[I] -> (OverflowWarning, [Integer])
unwrapIs ([I] -> (OverflowWarning, [Integer]))
-> [I] -> (OverflowWarning, [Integer])
forall a b. (a -> b) -> a -> b
$ a -> [I]
f a
x
, Maybe (OverflowWarning, a) -> Case a (Maybe (OverflowWarning, a))
forall {k} r (x :: k). r -> Case x r
fallbackCase' Maybe (OverflowWarning, a)
forall a. Maybe a
Nothing
]
data OverflowTreatment t = OverflowTreatment
{ forall (t :: * -> *).
OverflowTreatment t
-> Env t -> t Integer -> Either (SubCheck t I) I
evalITerm :: Env t -> t Integer -> Either (SubCheck t I) I
, forall (t :: * -> *).
OverflowTreatment t
-> Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
evalIList :: Env t -> t [Integer] -> Either (SubCheck t [I]) [I]
}
data SubCheck t x where
SubCheck :: Typeable a => t a -> (a -> x) -> SubCheck t x
modifySubCheck :: (forall a. t a -> t' a) -> SubCheck t x -> SubCheck t' x
modifySubCheck :: forall (t :: * -> *) (t' :: * -> *) x.
(forall a. t a -> t' a) -> SubCheck t x -> SubCheck t' x
modifySubCheck forall a. t a -> t' a
n (SubCheck t a
t a -> x
f) = t' a -> (a -> x) -> SubCheck t' x
forall a (t :: * -> *) x.
Typeable a =>
t a -> (a -> x) -> SubCheck t x
SubCheck (t a -> t' a
forall a. t a -> t' a
n t a
t) a -> x
f
data I = I Integer Int deriving (I -> I -> Bool
(I -> I -> Bool) -> (I -> I -> Bool) -> Eq I
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: I -> I -> Bool
== :: I -> I -> Bool
$c/= :: I -> I -> Bool
/= :: I -> I -> Bool
Eq,Eq I
Eq I =>
(I -> I -> Ordering)
-> (I -> I -> Bool)
-> (I -> I -> Bool)
-> (I -> I -> Bool)
-> (I -> I -> Bool)
-> (I -> I -> I)
-> (I -> I -> I)
-> Ord I
I -> I -> Bool
I -> I -> Ordering
I -> I -> I
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: I -> I -> Ordering
compare :: I -> I -> Ordering
$c< :: I -> I -> Bool
< :: I -> I -> Bool
$c<= :: I -> I -> Bool
<= :: I -> I -> Bool
$c> :: I -> I -> Bool
> :: I -> I -> Bool
$c>= :: I -> I -> Bool
>= :: I -> I -> Bool
$cmax :: I -> I -> I
max :: I -> I -> I
$cmin :: I -> I -> I
min :: I -> I -> I
Ord)
fromInt :: Int -> I
fromInt :: Int -> I
fromInt Int
x = Integer -> Int -> I
I (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
x) Int
x
instance Show I where
show :: I -> String
show i :: I
i@(I Integer
x Int
_)
| I -> Bool
hasDiverged I
i = Integer -> String
forall a. Show a => a -> String
show Integer
x
| Bool
otherwise = Integer -> String
forall a. Show a => a -> String
show Integer
x
hasDiverged :: I -> Bool
hasDiverged :: I -> Bool
hasDiverged (I Integer
x Int
x') = Integer
x Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x'
unwrapI :: I -> (OverflowWarning, Integer)
unwrapI :: I -> (OverflowWarning, Integer)
unwrapI I
i = (if I -> Bool
hasDiverged I
i then OverflowWarning
OverflowOccurred else OverflowWarning
NoOverflow, I -> Integer
forall a. Integral a => a -> Integer
toInteger I
i)
unwrapIs :: [I] -> (OverflowWarning, [Integer])
unwrapIs :: [I] -> (OverflowWarning, [Integer])
unwrapIs = (I -> (OverflowWarning, [Integer]))
-> [I] -> (OverflowWarning, [Integer])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Integer -> [Integer])
-> (OverflowWarning, Integer) -> (OverflowWarning, [Integer])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Integer -> [Integer]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((OverflowWarning, Integer) -> (OverflowWarning, [Integer]))
-> (I -> (OverflowWarning, Integer))
-> I
-> (OverflowWarning, [Integer])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I -> (OverflowWarning, Integer)
unwrapI)
instance Num I where
+ :: I -> I -> I
(+) = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(+) Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
* :: I -> I -> I
(*) = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(*) Int -> Int -> Int
forall a. Num a => a -> a -> a
(*)
(-) = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 (-) (-)
abs :: I -> I
abs = (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp Integer -> Integer
forall a. Num a => a -> a
abs Int -> Int
forall a. Num a => a -> a
abs
signum :: I -> I
signum = (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp Integer -> Integer
forall a. Num a => a -> a
signum Int -> Int
forall a. Num a => a -> a
signum
fromInteger :: Integer -> I
fromInteger Integer
n = Integer -> Int -> I
I Integer
n (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)
liftOp :: (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp :: (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp Integer -> Integer
f Int -> Int
g (I Integer
x Int
x') = Integer -> Int -> I
I (Integer -> Integer
f Integer
x) (Int -> Int
g Int
x')
liftOp2 :: (Integer -> Integer -> Integer) -> (Int -> Int -> Int) -> I -> I -> I
liftOp2 :: (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
f Int -> Int -> Int
g (I Integer
x Int
x') (I Integer
y Int
y') = Integer -> Int -> I
I (Integer -> Integer -> Integer
f Integer
x Integer
y) (Int -> Int -> Int
g Int
x' Int
y')
instance Enum I where
succ :: I -> I
succ = (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp Integer -> Integer
forall a. Enum a => a -> a
succ Int -> Int
succO
pred :: I -> I
pred = (Integer -> Integer) -> (Int -> Int) -> I -> I
liftOp Integer -> Integer
forall a. Enum a => a -> a
pred Int -> Int
predO
toEnum :: Int -> I
toEnum Int
n = Integer -> Int -> I
I (Int -> Integer
forall a. Enum a => Int -> a
toEnum Int
n) (Int -> Int
forall a. Enum a => Int -> a
toEnum Int
n)
fromEnum :: I -> Int
fromEnum (I Integer
n Int
_) = Integer -> Int
forall a. Enum a => a -> Int
fromEnum Integer
n
enumFrom :: I -> [I]
enumFrom I
x = I
x I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> [I]
forall a. Enum a => a -> [a]
enumFrom (I -> I
forall a. Enum a => a -> a
succ I
x)
enumFromThen :: I -> I -> [I]
enumFromThen I
x I
y = I
x I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> [I]
f I
y where
s :: I
s = I
y I -> I -> I
forall a. Num a => a -> a -> a
- I
x
f :: I -> [I]
f I
v = I
v I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> [I]
f (I
v I -> I -> I
forall a. Num a => a -> a -> a
+ I
s)
enumFromTo :: I -> I -> [I]
enumFromTo I
x I
y =
case I -> I -> Ordering
forall a. Ord a => a -> a -> Ordering
compare I
x I
y of
Ordering
GT -> []
Ordering
EQ -> [I
x]
Ordering
LT -> I
x I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> I -> [I]
forall a. Enum a => a -> a -> [a]
enumFromTo (I -> I
forall a. Enum a => a -> a
succ I
x) I
y
enumFromThenTo :: I -> I -> I -> [I]
enumFromThenTo I
x I
y I
z
| I
z I -> I -> Bool
forall a. Ord a => a -> a -> Bool
< I
x = []
| Bool
otherwise = I
x I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> [I]
f I
y
where
s :: I
s = I
y I -> I -> I
forall a. Num a => a -> a -> a
- I
x
f :: I -> [I]
f I
v | I
v I -> I -> Bool
forall a. Ord a => a -> a -> Bool
> I
z = []
| Bool
otherwise = I
v I -> [I] -> [I]
forall a. a -> [a] -> [a]
: I -> [I]
f (I
vI -> I -> I
forall a. Num a => a -> a -> a
+I
s)
instance Integral I where
toInteger :: I -> Integer
toInteger (I Integer
n Int
_) = Integer
n
quot :: I -> I -> I
quot = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
quot Int -> Int -> Int
forall a. Integral a => a -> a -> a
quot
rem :: I -> I -> I
rem = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
rem Int -> Int -> Int
forall a. Integral a => a -> a -> a
rem
div :: I -> I -> I
div = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
div Int -> Int -> Int
forall a. Integral a => a -> a -> a
div
mod :: I -> I -> I
mod = (Integer -> Integer -> Integer)
-> (Int -> Int -> Int) -> I -> I -> I
liftOp2 Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
mod Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod
quotRem :: I -> I -> (I, I)
quotRem I
x I
y = (I -> I -> I
forall a. Integral a => a -> a -> a
quot I
x I
y, I -> I -> I
forall a. Integral a => a -> a -> a
rem I
x I
y)
divMod :: I -> I -> (I, I)
divMod I
x I
y = (I -> I -> I
forall a. Integral a => a -> a -> a
div I
x I
y, I -> I -> I
forall a. Integral a => a -> a -> a
mod I
x I
y)
instance Real I where
toRational :: I -> Rational
toRational (I Integer
n Int
_) = Integer -> Rational
forall a. Real a => a -> Rational
toRational Integer
n
succO :: Int -> Int
succO :: Int -> Int
succO Int
x
| Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound = Int
forall a. Bounded a => a
minBound
| Bool
otherwise = Int -> Int
forall a. Enum a => a -> a
succ Int
x
predO :: Int -> Int
predO :: Int -> Int
predO Int
x
| Int
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
minBound = Int
forall a. Bounded a => a
maxBound
| Bool
otherwise = Int -> Int
forall a. Enum a => a -> a
pred Int
x