{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Strongweak.Strengthen
  (
  -- * 'Strengthen' class
    Strengthen(..)
  , restrengthen
  , Result

  -- ** Helpers
  , strengthenBounded

  -- * Strengthen failures
  , Fails
  , Fail(..)
  , prettyFail

  -- ** Helpers
  , fail1
  , failOther
  , failShow
  , maybeFailShow

  -- * Re-exports
  , Strongweak.Weaken.Weak
  ) where

import Strongweak.Util.Typeable ( typeRep' )
import Strongweak.Util.Text ( tshow )
import Strongweak.Weaken ( Weaken(..) )
import Data.Either.Validation
import Data.Typeable ( Typeable, TypeRep )
import Prettyprinter qualified as Pretty
import Prettyprinter ( Pretty(pretty), (<+>) )
import Prettyprinter.Render.String qualified as Pretty
import Prettyprinter.Render.Text qualified as Pretty

import Data.Text ( Text )
import Data.Text.Lazy qualified as Text.Lazy
import GHC.TypeNats ( Natural, KnownNat )
import Data.Word
import Data.Int
import Refined hiding ( Weaken, weaken, strengthen, NonEmpty )
import Data.Vector.Generic.Sized qualified as VGS -- Shazbot!
import Data.Vector.Generic qualified as VG
import Data.Foldable qualified as Foldable
import Control.Applicative ( liftA2 )
import Data.Functor.Identity
import Data.Functor.Const
import Acc.NeAcc
import Data.List.NonEmpty qualified as NonEmpty
import Data.List.NonEmpty ( NonEmpty )

type Result = Validation Fails
type Fails = NeAcc Fail

{- | Attempt to strengthen some @'Weak' a@, asserting certain invariants.

We take 'Weaken' as a superclass in order to maintain strong/weak type pair
consistency. We choose this dependency direction because we treat the strong
type as the "canonical" one, so 'Weaken' is the more natural (and
straightforward) class to define. That does mean the instances for this class
are a little confusingly worded. Alas.

See "Strongweak" for class design notes and laws.
-}
class Weaken a => Strengthen a where
    -- | Attempt to strengthen some @'Weak' a@ to its associated strong type
    --   @a@.
    strengthen :: Weak a -> Result a

-- | Weaken a strong value, then strengthen it again.
--
-- Potentially useful if you have previously used
-- 'Strongweak.Strengthen.Unsafe.unsafeStrengthen' and now wish to check the
-- invariants. For example:
--
-- >>> restrengthen $ unsafeStrengthen @(Vector 2 Natural) [0]
-- Failure ...
restrengthen
    :: (Strengthen a, Weaken a)
    => a -> Result a
restrengthen :: forall a. (Strengthen a, Weaken a) => a -> Result a
restrengthen = Weak a -> Result a
forall a. Strengthen a => Weak a -> Result a
strengthen (Weak a -> Result a) -> (a -> Weak a) -> a -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Weak a
forall a. Weaken a => a -> Weak a
weaken

-- | A failure encountered during strengthening.
data Fail
  -- | A failure containing lots of detail. Use in concrete instances where you
  --   already have the 'Show's and 'Typeable's needed.
  = FailShow
        TypeRep -- ^ weak   type
        TypeRep -- ^ strong type
        (Maybe Text) -- ^ weak value
        [Text] -- ^ failure description

  -- | A failure. Use in abstract instances to avoid heavy contexts. (Remember
  --   that generic strengtheners should wrap these nicely anyway!)
  | FailOther
        [Text] -- ^ failure description

  -- | Some failures occurred when strengthening from one data type to another.
  --
  -- Field indices are from 0 in the respective constructor. Field names are
  -- provided if are present in the type.
  --
  -- This is primarily intended to be used by generic strengtheners.
  | FailField
        String                      -- ^ weak   datatype name
        String                      -- ^ strong datatype name
        String                      -- ^ weak   constructor name
        String                      -- ^ strong constructor name
        Natural                     -- ^ weak   field index
        (Maybe String)              -- ^ weak   field name (if present)
        Natural                     -- ^ strong field index
        (Maybe String)              -- ^ strong field name (if present)
        Fails                       -- ^ failures

prettyFail :: Fail -> Text.Lazy.Text
prettyFail :: Fail -> Text
prettyFail = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Pretty.renderLazy (SimpleDocStream Any -> Text)
-> (Fail -> SimpleDocStream Any) -> Fail -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail -> SimpleDocStream Any
forall ann. Fail -> SimpleDocStream ann
prettyLayoutFail

prettyLayoutFail :: Fail -> Pretty.SimpleDocStream ann
prettyLayoutFail :: forall ann. Fail -> SimpleDocStream ann
prettyLayoutFail = LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
Pretty.layoutPretty LayoutOptions
Pretty.defaultLayoutOptions (Doc ann -> SimpleDocStream ann)
-> (Fail -> Doc ann) -> Fail -> SimpleDocStream ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Fail -> Doc ann
pretty

fail1 :: Fail -> Result a
fail1 :: forall a. Fail -> Result a
fail1 = Fails -> Validation Fails a
forall e a. e -> Validation e a
Failure (Fails -> Validation Fails a)
-> (Fail -> Fails) -> Fail -> Validation Fails a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail -> Fails
forall a. a -> NeAcc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure

failOther :: [Text] -> Result a
failOther :: forall a. [Text] -> Result a
failOther = Fail -> Result a
forall a. Fail -> Result a
fail1 (Fail -> Result a) -> ([Text] -> Fail) -> [Text] -> Result a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Fail
FailOther

buildFailShow
    :: forall w s. (Typeable w, Typeable s)
    => Maybe Text -> [Text] -> Result s
buildFailShow :: forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
Maybe Text -> [Text] -> Result s
buildFailShow Maybe Text
mwv = Fail -> Result s
forall a. Fail -> Result a
fail1 (Fail -> Result s) -> ([Text] -> Fail) -> [Text] -> Result s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> TypeRep -> Maybe Text -> [Text] -> Fail
FailShow (forall (a :: k). Typeable a => TypeRep
forall {k} (a :: k). Typeable a => TypeRep
typeRep' @w) (forall a. Typeable a => TypeRep
forall {k} (a :: k). Typeable a => TypeRep
typeRep' @s) Maybe Text
mwv

failShow'
    :: forall s w. (Typeable w, Show w, Typeable s)
    => (w -> Text) -> w -> [Text] -> Result s
failShow' :: forall s w.
(Typeable w, Show w, Typeable s) =>
(w -> Text) -> w -> [Text] -> Result s
failShow' w -> Text
f w
w = forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
Maybe Text -> [Text] -> Result s
forall w s.
(Typeable w, Typeable s) =>
Maybe Text -> [Text] -> Result s
buildFailShow @w @s (Text -> Maybe Text
forall a. a -> Maybe a
Just (w -> Text
f w
w))

failShow
    :: forall s w. (Typeable w, Show w, Typeable s)
    => w -> [Text] -> Result s
failShow :: forall s w.
(Typeable w, Show w, Typeable s) =>
w -> [Text] -> Result s
failShow = (w -> Text) -> w -> [Text] -> Result s
forall s w.
(Typeable w, Show w, Typeable s) =>
(w -> Text) -> w -> [Text] -> Result s
failShow' w -> Text
forall a. Show a => a -> Text
tshow

-- | This reports the weak and strong type, so no need to include those in the
--   failure detail.
failShowNoVal :: forall w s. (Typeable w, Typeable s) => [Text] -> Result s
failShowNoVal :: forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
[Text] -> Result s
failShowNoVal = forall (w :: k) s.
(Typeable w, Typeable s) =>
Maybe Text -> [Text] -> Result s
forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
Maybe Text -> [Text] -> Result s
buildFailShow @w @s Maybe Text
forall a. Maybe a
Nothing

instance Show Fail where
    showsPrec :: Int -> Fail -> ShowS
showsPrec Int
_ = SimpleDocStream Any -> ShowS
forall ann. SimpleDocStream ann -> ShowS
Pretty.renderShowS (SimpleDocStream Any -> ShowS)
-> (Fail -> SimpleDocStream Any) -> Fail -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fail -> SimpleDocStream Any
forall ann. Fail -> SimpleDocStream ann
prettyLayoutFail

-- TODO shorten value if over e.g. 50 chars. e.g. @[0,1,2,...,255] -> FAIL@
instance Pretty Fail where
    pretty :: forall ann. Fail -> Doc ann
pretty = \case
      FailShow TypeRep
wt TypeRep
st Maybe Text
mwv [Text]
detail -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
Pretty.vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
        case Maybe Text
mwv of
          Maybe Text
Nothing -> [Doc ann
typeDoc, Doc ann
detailDoc]
          Just Text
wv ->
            let valueDoc :: Doc ann
valueDoc = Doc ann
"value: "Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
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"
            in  [Doc ann
typeDoc, Doc ann
valueDoc, Doc ann
detailDoc]
        where
          typeDoc :: Doc ann
typeDoc   = Doc ann
"type:  "Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>TypeRep -> Doc ann
forall a. TypeRep -> Doc a
prettyTypeRep TypeRep
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
<+>TypeRep -> Doc ann
forall a. TypeRep -> Doc a
prettyTypeRep TypeRep
st
          detailDoc :: Doc ann
detailDoc = case [Text]
detail of
            []           -> Doc ann
"<no detail>"
            [Text
detailLine] -> Doc ann
"detail:"Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
detailLine
            [Text]
_            -> Doc ann
"detail:"Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Doc ann
forall ann. Doc ann
Pretty.lineDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>[Text] -> Doc ann
forall (f :: Type -> Type) a ann.
(Foldable f, Pretty a) =>
f a -> Doc ann
prettyList [Text]
detail

      FailOther [Text]
detail -> [Text] -> Doc ann
forall ann. [Text] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty [Text]
detail

      -- TODO should inspect meta, shorten if identical (currently only using
      -- weak)
      FailField String
dw String
_ds String
cw String
_cs Natural
iw Maybe String
fw Natural
_is Maybe String
_fs Fails
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
Pretty.nest Int
0 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall ann. 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 ann. 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 ann. 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
Pretty.lineDoc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<>Fails -> Doc ann
forall (f :: Type -> Type) a ann.
(Foldable f, Pretty a) =>
f a -> Doc ann
prettyList Fails
es

-- mutually recursive with its 'Pretty' instance. safe, but a bit confusing -
-- clean up
prettyList :: (Foldable f, Pretty a) => f a -> Pretty.Doc ann
prettyList :: forall (f :: Type -> Type) a ann.
(Foldable f, Pretty a) =>
f a -> Doc ann
prettyList = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
Pretty.vsep ([Doc ann] -> Doc ann) -> (f a -> [Doc ann]) -> f a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc ann) -> [a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc ann
forall {a} {ann}. Pretty a => a -> Doc ann
go ([a] -> [Doc ann]) -> (f a -> [a]) -> f a -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall a. f a -> [a]
forall (t :: Type -> Type) 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
Pretty.indent Int
0 (a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
e)

-- | Succeed on 'Just', fail with given detail on 'Nothing'.
maybeFailShow
    :: forall a. (Typeable (Weak a), Typeable a)
    => [Text] -> Maybe a -> Result a
maybeFailShow :: forall a.
(Typeable (Weak a), Typeable a) =>
[Text] -> Maybe a -> Result a
maybeFailShow [Text]
detail = \case
    Just a
a  -> a -> Result a
forall e a. a -> Validation e a
Success a
a
    Maybe a
Nothing -> forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
[Text] -> Result s
forall w s. (Typeable w, Typeable s) => [Text] -> Result s
failShowNoVal @(Weak a) [Text]
detail

-- | Assert a predicate to refine a type.
instance (Predicate p a, Typeable a)
  => Strengthen (Refined p a) where
    strengthen :: Weak (Refined p a) -> Result (Refined p a)
strengthen = a -> Either RefineException (Refined p a)
forall {k} (p :: k) x.
Predicate p x =>
x -> Either RefineException (Refined p x)
refine (a -> Either RefineException (Refined p a))
-> (Either RefineException (Refined p a) -> Result (Refined p a))
-> a
-> Result (Refined p a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> \case
      Left  RefineException
rex -> forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
[Text] -> Result s
forall w s. (Typeable w, Typeable s) => [Text] -> Result s
failShowNoVal @a
        [ Text
"refinement: "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>TypeRep -> Text
forall a. Show a => a -> Text
tshow (forall (a :: k). Typeable a => TypeRep
forall {k} (a :: k). Typeable a => TypeRep
typeRep' @p)
        , Text
"failed with..."
        , String -> Text
forall a. Show a => a -> Text
tshow (RefineException -> String
displayRefineException RefineException
rex)
        ]
      Right Refined p a
ra  -> Refined p a -> Result (Refined p a)
forall e a. a -> Validation e a
Success Refined p a
ra

-- | Assert a functor predicate to refine a type.
instance (Predicate1 p f, Typeable f, Typeable (a :: ak), Typeable ak)
  => Strengthen (Refined1 p f a) where
    strengthen :: Weak (Refined1 p f a) -> Result (Refined1 p f a)
strengthen = f a -> Either RefineException (Refined1 p f a)
forall {k1} {k} (p :: k1) (f :: k -> Type) (x :: k).
Predicate1 p f =>
f x -> Either RefineException (Refined1 p f x)
refine1 (f a -> Either RefineException (Refined1 p f a))
-> (Either RefineException (Refined1 p f a)
    -> Result (Refined1 p f a))
-> f a
-> Result (Refined1 p f a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> \case
      Left  RefineException
rex -> forall {k} (w :: k) s.
(Typeable w, Typeable s) =>
[Text] -> Result s
forall w s. (Typeable w, Typeable s) => [Text] -> Result s
failShowNoVal @(f a)
        [ Text
"refinement: "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>TypeRep -> Text
forall a. Show a => a -> Text
tshow (forall (a :: k1). Typeable a => TypeRep
forall {k} (a :: k). Typeable a => TypeRep
typeRep' @p)
        , Text
"failed with..."
        , String -> Text
forall a. Show a => a -> Text
tshow (RefineException -> String
displayRefineException RefineException
rex)
        ]
      Right Refined1 p f a
ra  -> Refined1 p f a -> Result (Refined1 p f a)
forall e a. a -> Validation e a
Success Refined1 p f a
ra

-- | Strengthen a plain list into a non-empty list by asserting non-emptiness.
instance Typeable a => Strengthen (NonEmpty a) where
    strengthen :: Weak (NonEmpty a) -> Result (NonEmpty a)
strengthen = [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ([a] -> Maybe (NonEmpty a))
-> (Maybe (NonEmpty a) -> Result (NonEmpty a))
-> [a]
-> Result (NonEmpty a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> [Text] -> Maybe (NonEmpty a) -> Result (NonEmpty a)
forall a.
(Typeable (Weak a), Typeable a) =>
[Text] -> Maybe a -> Result a
maybeFailShow [Text
"empty list"]

-- | Strengthen a plain list into a sized vector by asserting length.
instance
  ( VG.Vector v a, KnownNat n
  , Typeable v, Typeable a
  ) => Strengthen (VGS.Vector v n a) where
      strengthen :: Weak (Vector v n a) -> Result (Vector v n a)
strengthen = [a] -> Maybe (Vector v n a)
forall (v :: Type -> Type) a (n :: Natural).
(Vector v a, KnownNat n) =>
[a] -> Maybe (Vector v n a)
VGS.fromList ([a] -> Maybe (Vector v n a))
-> (Maybe (Vector v n a) -> Result (Vector v n a))
-> [a]
-> Result (Vector v n a)
forall a b c. (a -> b) -> (b -> c) -> a -> c
.> [Text] -> Maybe (Vector v n a) -> Result (Vector v n a)
forall a.
(Typeable (Weak a), Typeable a) =>
[Text] -> Maybe a -> Result a
maybeFailShow [Text
"incorrect length"]

-- | Add wrapper.
instance Strengthen (Identity a) where
    strengthen :: Weak (Identity a) -> Result (Identity a)
strengthen = Identity a -> Result (Identity a)
forall a. a -> Validation Fails a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Identity a -> Result (Identity a))
-> (a -> Identity a) -> a -> Result (Identity a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Identity a
forall a. a -> Identity a
Identity

-- | Add wrapper.
instance Strengthen (Const a b) where
    strengthen :: Weak (Const a b) -> Result (Const a b)
strengthen = Const a b -> Result (Const a b)
forall a. a -> Validation Fails a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Const a b -> Result (Const a b))
-> (a -> Const a b) -> a -> Result (Const a b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Const a b
forall {k} a (b :: k). a -> Const a b
Const

{- TODO controversial. seems logical, but also kinda annoying.
instance (Show a, Typeable a) => Strengthen (Maybe a) where
    strengthen = \case [a] -> pure $ Just a
                       []  -> pure Nothing
                       x   -> strengthenFailBase x "list wasn't [a] or []"
-}

-- Strengthen 'Natural's into Haskell's bounded unsigned numeric types.
instance Strengthen Word8  where strengthen :: Weak Word8 -> Result Word8
strengthen = Natural -> Result Word8
Weak Word8 -> Result Word8
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Word16 where strengthen :: Weak Word16 -> Result Word16
strengthen = Natural -> Result Word16
Weak Word16 -> Result Word16
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Word32 where strengthen :: Weak Word32 -> Result Word32
strengthen = Natural -> Result Word32
Weak Word32 -> Result Word32
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Word64 where strengthen :: Weak Word64 -> Result Word64
strengthen = Natural -> Result Word64
Weak Word64 -> Result Word64
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded

-- Strengthen 'Integer's into Haskell's bounded signed numeric types.
instance Strengthen Int8   where strengthen :: Weak Int8 -> Result Int8
strengthen = Integer -> Result Int8
Weak Int8 -> Result Int8
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Int16  where strengthen :: Weak Int16 -> Result Int16
strengthen = Integer -> Result Int16
Weak Int16 -> Result Int16
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Int32  where strengthen :: Weak Int32 -> Result Int32
strengthen = Integer -> Result Int32
Weak Int32 -> Result Int32
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded
instance Strengthen Int64  where strengthen :: Weak Int64 -> Result Int64
strengthen = Integer -> Result Int64
Weak Int64 -> Result Int64
forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded

-- | Strengthen one numeric type into another.
--
-- @n@ must be "wider" than @m@.
strengthenBounded
    :: forall m n
    .  ( Typeable n, Integral n, Show n
       , Typeable m, Integral m, Show m, Bounded m
       ) => n -> Result m
strengthenBounded :: forall m n.
(Typeable n, Integral n, Show n, Typeable m, Integral m, Show m,
 Bounded m) =>
n -> Result m
strengthenBounded n
n
  | 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 = m -> Validation Fails m
forall e a. a -> Validation e a
Success (n -> m
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
n)
  | Bool
otherwise = n -> [Text] -> Validation Fails m
forall s w.
(Typeable w, Show w, Typeable s) =>
w -> [Text] -> Result s
failShow n
n
        [ Text
"not well bounded, require: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>n -> Text
forall a. Show a => a -> Text
tshow n
minBText -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
" <= n <= "Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>n -> Text
forall a. Show a => a -> Text
tshow n
maxB
        ]
  where
    maxB :: n
maxB = forall a b. (Integral a, Num b) => a -> b
fromIntegral @m @n m
forall a. Bounded a => a
maxBound
    minB :: n
minB = forall a b. (Integral a, Num b) => a -> b
fromIntegral @m @n m
forall a. Bounded a => a
minBound

--------------------------------------------------------------------------------

-- | Decomposer. Strengthen every element in a list.
instance Strengthen a => Strengthen [a] where
    strengthen :: Weak [a] -> Result [a]
strengthen = (Weak a -> Validation Fails a) -> [Weak a] -> Result [a]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Weak a -> Validation Fails a
forall a. Strengthen a => Weak a -> Result a
strengthen

-- | Decomposer. Strengthen both elements of a tuple.
instance (Strengthen a, Strengthen b) => Strengthen (a, b) where
    strengthen :: Weak (a, b) -> Result (a, b)
strengthen (Weak a
a, Weak b
b) = (a -> b -> (a, b))
-> Validation Fails a -> Validation Fails b -> Result (a, b)
forall a b c.
(a -> b -> c)
-> Validation Fails a -> Validation Fails b -> Validation Fails c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Weak a -> Validation Fails a
forall a. Strengthen a => Weak a -> Result a
strengthen Weak a
a) (Weak b -> Validation Fails b
forall a. Strengthen a => Weak a -> Result a
strengthen Weak b
b)

-- | Decomposer. Strengthen either side of an 'Either'.
instance (Strengthen a, Strengthen b) => Strengthen (Either a b) where
    strengthen :: Weak (Either a b) -> Result (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 Fails a -> Result (Either a b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak a -> Validation Fails a
forall a. Strengthen a => Weak a -> Result 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 Fails b -> Result (Either a b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Weak b -> Validation Fails b
forall a. Strengthen a => Weak a -> Result a
strengthen Weak b
b

--------------------------------------------------------------------------------

prettyTypeRep :: TypeRep -> Pretty.Doc a
prettyTypeRep :: forall a. TypeRep -> Doc a
prettyTypeRep = String -> Doc a
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc a) -> (TypeRep -> String) -> TypeRep -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall a. Show a => a -> String
show

-- from flow
(.>) :: (a -> b) -> (b -> c) -> a -> c
a -> b
f .> :: forall a b c. (a -> b) -> (b -> c) -> a -> c
.> b -> c
g = b -> c
g (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f