{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Strongweak.Strengthen
(
Strengthen(..)
, StrengthenFail(..)
, strengthenFailPretty
, strengthenFailBase
, restrengthen
, strengthenBounded
, Strongweak.Weaken.Weak
) where
import Strongweak.Weaken ( Weaken(..) )
import Data.Either.Validation
import Type.Reflection ( Typeable, typeRep )
import Prettyprinter
import Prettyprinter.Render.String
import GHC.TypeNats ( Natural, KnownNat )
import Data.Word
import Data.Int
import Refined ( Refined, refine, Predicate )
import Data.Vector.Sized qualified as Vector
import Data.Vector.Sized ( Vector )
import Data.Foldable qualified as Foldable
import Control.Applicative ( liftA2 )
import Data.Functor.Identity
import Data.Functor.Const
import Data.List.NonEmpty ( NonEmpty( (:|) ) )
import Data.List.NonEmpty qualified as NonEmpty
class Weaken a => Strengthen a where
strengthen :: Weak a -> Validation (NonEmpty StrengthenFail) a
restrengthen
:: (Strengthen a, Weaken a)
=> a -> Validation (NonEmpty StrengthenFail) a
restrengthen :: forall a.
(Strengthen a, Weaken a) =>
a -> Validation (NonEmpty StrengthenFail) a
restrengthen = Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen (Weak a -> Validation (NonEmpty StrengthenFail) a)
-> (a -> Weak a) -> a -> Validation (NonEmpty StrengthenFail) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Weak a
forall a. Weaken a => a -> Weak a
weaken
data StrengthenFail
= StrengthenFailBase
String
String
String
String
| StrengthenFailField
String
String
String
String
Natural
(Maybe String)
Natural
(Maybe String)
(NonEmpty StrengthenFail)
deriving stock StrengthenFail -> StrengthenFail -> Bool
(StrengthenFail -> StrengthenFail -> Bool)
-> (StrengthenFail -> StrengthenFail -> Bool) -> Eq StrengthenFail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StrengthenFail -> StrengthenFail -> Bool
$c/= :: StrengthenFail -> StrengthenFail -> Bool
== :: StrengthenFail -> StrengthenFail -> Bool
$c== :: StrengthenFail -> StrengthenFail -> Bool
Eq
instance Show StrengthenFail where
showsPrec :: Int -> StrengthenFail -> ShowS
showsPrec Int
_ = SimpleDocStream Any -> ShowS
forall ann. SimpleDocStream ann -> ShowS
renderShowS (SimpleDocStream Any -> ShowS)
-> (StrengthenFail -> SimpleDocStream Any)
-> StrengthenFail
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (StrengthenFail -> Doc Any)
-> StrengthenFail
-> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrengthenFail -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty
instance Pretty StrengthenFail where
pretty :: forall ann. StrengthenFail -> Doc ann
pretty = \case
StrengthenFailBase String
wt String
st String
wv String
msg ->
[Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep [ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
wtDoc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Doc ann
"->"Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
st
, String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
wvDoc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Doc ann
"->"Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Doc ann
"FAIL"
, String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
msg ]
StrengthenFailField String
dw String
_ds String
cw String
_cs Natural
iw Maybe String
fw Natural
_is Maybe String
_fs NonEmpty StrengthenFail
es ->
let sw :: String
sw = String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Natural -> String
forall a. Show a => a -> String
show Natural
iw) ShowS
forall a. a -> a
id Maybe String
fw
in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
0 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
dwDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Doc ann
"."Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
cwDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Doc ann
"."Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
swDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Doc ann
forall ann. Doc ann
lineDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>NonEmpty StrengthenFail -> Doc ann
forall a. NonEmpty StrengthenFail -> Doc a
strengthenFailPretty NonEmpty StrengthenFail
es
strengthenFailPretty :: NonEmpty StrengthenFail -> Doc a
strengthenFailPretty :: forall a. NonEmpty StrengthenFail -> Doc a
strengthenFailPretty = [Doc a] -> Doc a
forall ann. [Doc ann] -> Doc ann
vsep ([Doc a] -> Doc a)
-> (NonEmpty StrengthenFail -> [Doc a])
-> NonEmpty StrengthenFail
-> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrengthenFail -> Doc a) -> [StrengthenFail] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map StrengthenFail -> Doc a
forall {a} {ann}. Pretty a => a -> Doc ann
go ([StrengthenFail] -> [Doc a])
-> (NonEmpty StrengthenFail -> [StrengthenFail])
-> NonEmpty StrengthenFail
-> [Doc a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty StrengthenFail -> [StrengthenFail]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList
where go :: a -> Doc ann
go a
e = Doc ann
"-"Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
0 (a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
e)
strengthenFailBase
:: forall s w. (Typeable w, Show w, Typeable s)
=> w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase :: forall s w.
(Typeable w, Show w, Typeable s) =>
w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase w
w String
msg = NonEmpty StrengthenFail -> Validation (NonEmpty StrengthenFail) s
forall e a. e -> Validation e a
Failure (StrengthenFail
e StrengthenFail -> [StrengthenFail] -> NonEmpty StrengthenFail
forall a. a -> [a] -> NonEmpty a
:| [])
where e :: StrengthenFail
e = String -> String -> String -> String -> StrengthenFail
StrengthenFailBase (TypeRep w -> String
forall a. Show a => a -> String
show (TypeRep w -> String) -> TypeRep w -> String
forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @w) (TypeRep s -> String
forall a. Show a => a -> String
show (TypeRep s -> String) -> TypeRep s -> String
forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @s) (w -> String
forall a. Show a => a -> String
show w
w) String
msg
instance (Typeable a, Show a) => Strengthen (NonEmpty a) where
strengthen :: Weak (NonEmpty a)
-> Validation (NonEmpty StrengthenFail) (NonEmpty a)
strengthen Weak (NonEmpty a)
a =
case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [a]
Weak (NonEmpty a)
a of
Just NonEmpty a
a' -> NonEmpty a -> Validation (NonEmpty StrengthenFail) (NonEmpty a)
forall e a. a -> Validation e a
Success NonEmpty a
a'
Maybe (NonEmpty a)
Nothing -> [a] -> String -> Validation (NonEmpty StrengthenFail) (NonEmpty a)
forall s w.
(Typeable w, Show w, Typeable s) =>
w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase [a]
Weak (NonEmpty a)
a String
"empty list"
instance (KnownNat n, Typeable a, Show a) => Strengthen (Vector n a) where
strengthen :: Weak (Vector n a)
-> Validation (NonEmpty StrengthenFail) (Vector n a)
strengthen Weak (Vector n a)
w =
case [a] -> Maybe (Vector n a)
forall (n :: Natural) a. KnownNat n => [a] -> Maybe (Vector n a)
Vector.fromList [a]
Weak (Vector n a)
w of
Maybe (Vector n a)
Nothing -> [a] -> String -> Validation (NonEmpty StrengthenFail) (Vector n a)
forall s w.
(Typeable w, Show w, Typeable s) =>
w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase [a]
Weak (Vector n a)
w String
"TODO bad size vector"
Just Vector n a
s -> Vector n a -> Validation (NonEmpty StrengthenFail) (Vector n a)
forall e a. a -> Validation e a
Success Vector n a
s
instance (Predicate (p :: k) a, Typeable k, Typeable a, Show a) => Strengthen (Refined p a) where
strengthen :: Weak (Refined p a)
-> Validation (NonEmpty StrengthenFail) (Refined p a)
strengthen Weak (Refined p a)
a =
case a -> Either RefineException (Refined p a)
forall {k} (p :: k) x.
Predicate p x =>
x -> Either RefineException (Refined p x)
refine a
Weak (Refined p a)
a of
Left RefineException
err -> a -> String -> Validation (NonEmpty StrengthenFail) (Refined p a)
forall s w.
(Typeable w, Show w, Typeable s) =>
w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase a
Weak (Refined p a)
a (RefineException -> String
forall a. Show a => a -> String
show RefineException
err)
Right Refined p a
ra -> Refined p a -> Validation (NonEmpty StrengthenFail) (Refined p a)
forall e a. a -> Validation e a
Success Refined p a
ra
instance Strengthen Word8 where strengthen :: Weak Word8 -> Validation (NonEmpty StrengthenFail) Word8
strengthen = Weak Word8 -> Validation (NonEmpty StrengthenFail) Word8
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Word16 where strengthen :: Weak Word16 -> Validation (NonEmpty StrengthenFail) Word16
strengthen = Weak Word16 -> Validation (NonEmpty StrengthenFail) Word16
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Word32 where strengthen :: Weak Word32 -> Validation (NonEmpty StrengthenFail) Word32
strengthen = Weak Word32 -> Validation (NonEmpty StrengthenFail) Word32
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Word64 where strengthen :: Weak Word64 -> Validation (NonEmpty StrengthenFail) Word64
strengthen = Weak Word64 -> Validation (NonEmpty StrengthenFail) Word64
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Int8 where strengthen :: Weak Int8 -> Validation (NonEmpty StrengthenFail) Int8
strengthen = Weak Int8 -> Validation (NonEmpty StrengthenFail) Int8
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Int16 where strengthen :: Weak Int16 -> Validation (NonEmpty StrengthenFail) Int16
strengthen = Weak Int16 -> Validation (NonEmpty StrengthenFail) Int16
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Int32 where strengthen :: Weak Int32 -> Validation (NonEmpty StrengthenFail) Int32
strengthen = Weak Int32 -> Validation (NonEmpty StrengthenFail) Int32
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
instance Strengthen Int64 where strengthen :: Weak Int64 -> Validation (NonEmpty StrengthenFail) Int64
strengthen = Weak Int64 -> Validation (NonEmpty StrengthenFail) Int64
forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded
strengthenBounded
:: forall b n
. (Integral b, Bounded b, Show b, Typeable b, Integral n, Show n, Typeable n)
=> n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded :: forall b n.
(Integral b, Bounded b, Show b, Typeable b, Integral n, Show n,
Typeable n) =>
n -> Validation (NonEmpty StrengthenFail) b
strengthenBounded n
n =
if n
n n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
maxB Bool -> Bool -> Bool
&& n
n n -> n -> Bool
forall a. Ord a => a -> a -> Bool
>= n
minB then b -> Validation (NonEmpty StrengthenFail) b
forall e a. a -> Validation e a
Success (n -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
n)
else n -> String -> Validation (NonEmpty StrengthenFail) b
forall s w.
(Typeable w, Show w, Typeable s) =>
w -> String -> Validation (NonEmpty StrengthenFail) s
strengthenFailBase n
n (String -> Validation (NonEmpty StrengthenFail) b)
-> String -> Validation (NonEmpty StrengthenFail) b
forall a b. (a -> b) -> a -> b
$ String
"not well bounded, require: "
String -> ShowS
forall a. Semigroup a => a -> a -> a
<>n -> String
forall a. Show a => a -> String
show n
minBString -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
" <= n <= "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>n -> String
forall a. Show a => a -> String
show n
maxB
where
maxB :: n
maxB = forall a b. (Integral a, Num b) => a -> b
fromIntegral @b @n b
forall a. Bounded a => a
maxBound
minB :: n
minB = forall a b. (Integral a, Num b) => a -> b
fromIntegral @b @n b
forall a. Bounded a => a
minBound
instance Strengthen a => Strengthen [a] where
strengthen :: Weak [a] -> Validation (NonEmpty StrengthenFail) [a]
strengthen = (Weak a -> Validation (NonEmpty StrengthenFail) a)
-> [Weak a] -> Validation (NonEmpty StrengthenFail) [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen
instance (Strengthen a, Strengthen b) => Strengthen (a, b) where
strengthen :: Weak (a, b) -> Validation (NonEmpty StrengthenFail) (a, b)
strengthen (Weak a
a, Weak b
b) = (a -> b -> (a, b))
-> Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) b
-> Validation (NonEmpty StrengthenFail) (a, b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen Weak a
a) (Weak b -> Validation (NonEmpty StrengthenFail) b
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen Weak b
b)
instance Strengthen a => Strengthen (Maybe a) where
strengthen :: Weak (Maybe a) -> Validation (NonEmpty StrengthenFail) (Maybe a)
strengthen = \case Just Weak a
a -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen Weak a
a
Maybe (Weak a)
Weak (Maybe a)
Nothing -> Maybe a -> Validation (NonEmpty StrengthenFail) (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
instance (Strengthen a, Strengthen b) => Strengthen (Either a b) where
strengthen :: Weak (Either a b)
-> Validation (NonEmpty StrengthenFail) (Either a b)
strengthen = \case Left Weak a
a -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b)
-> Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen Weak a
a
Right Weak b
b -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b)
-> Validation (NonEmpty StrengthenFail) b
-> Validation (NonEmpty StrengthenFail) (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak b -> Validation (NonEmpty StrengthenFail) b
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen Weak b
b
instance Strengthen a => Strengthen (Identity a) where
strengthen :: Weak (Identity a)
-> Validation (NonEmpty StrengthenFail) (Identity a)
strengthen = (a -> Identity a)
-> Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Identity a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Identity a
forall a. a -> Identity a
Identity (Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Identity a))
-> (Identity (Weak a) -> Validation (NonEmpty StrengthenFail) a)
-> Identity (Weak a)
-> Validation (NonEmpty StrengthenFail) (Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen (Weak a -> Validation (NonEmpty StrengthenFail) a)
-> (Identity (Weak a) -> Weak a)
-> Identity (Weak a)
-> Validation (NonEmpty StrengthenFail) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity (Weak a) -> Weak a
forall a. Identity a -> a
runIdentity
instance Strengthen a => Strengthen (Const a b) where
strengthen :: Weak (Const a b)
-> Validation (NonEmpty StrengthenFail) (Const a b)
strengthen = (a -> Const a b)
-> Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Const a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const (Validation (NonEmpty StrengthenFail) a
-> Validation (NonEmpty StrengthenFail) (Const a b))
-> (Const (Weak a) b -> Validation (NonEmpty StrengthenFail) a)
-> Const (Weak a) b
-> Validation (NonEmpty StrengthenFail) (Const a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weak a -> Validation (NonEmpty StrengthenFail) a
forall a.
Strengthen a =>
Weak a -> Validation (NonEmpty StrengthenFail) a
strengthen (Weak a -> Validation (NonEmpty StrengthenFail) a)
-> (Const (Weak a) b -> Weak a)
-> Const (Weak a) b
-> Validation (NonEmpty StrengthenFail) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (Weak a) b -> Weak a
forall {k} a (b :: k). Const a b -> a
getConst