Applied.hs

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fplugin-opt=NoRecursion:ignore-methods:sconcat #-}

-- __NB__: base-4.17 moves `IsList` to its own module, which avoids the unsafety
--         of importing "GHC.Exts". With prior versions of base, we at least
--         mark the module @Trustworthy@.
#if MIN_VERSION_base(4, 17, 0)
{-# LANGUAGE Safe #-}
#else
{-# LANGUAGE Trustworthy #-}
#endif
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Yaya.Applied
  ( Void,
    absurd,
    append,
    at,
    atMay,
    constantly,
    drop',
    drop,
    fibonacci,
    fibonacciPolynomials,
    fromList,
    fromListN,
    fromMaybe,
    height,
    jacobsthal,
    length,
    lucas,
    lucasSequenceU,
    lucasSequenceV,
    maybeReify,
    mersenne,
    naturals,
    now,
    pell,
    reifyUpTo,
    reverse',
    reverse,
    runToEnd,
    succN,
    tail,
    take,
    takeUpTo,
    toList,
    truncate,
    vacuous,
    zeroN,
  )
where

import safe "base" Control.Category (Category (id, (.)))
import safe "base" Data.Foldable (Foldable (foldr))
import safe "base" Data.Function (flip)
import safe "base" Data.Functor (Functor (fmap))
import safe "base" Data.Functor.Identity (Identity (runIdentity))
import safe "base" Data.Int (Int)
import safe "base" Data.Monoid (Monoid (mempty))
import safe "base" Data.Ord (Ord (max))
import safe "base" Data.Semigroup (Semigroup, stimes, stimesMonoid, (<>))

-- See comment on @{-# LANGUAGE Safe #-}@ above.
#if MIN_VERSION_base(4, 17, 0)
import "base" GHC.IsList (IsList)
import qualified "base" GHC.IsList as IsList
#else
import "base" GHC.Exts (IsList)
import qualified "base" GHC.Exts as IsList
#endif
import safe "base" Numeric.Natural (Natural)
import safe "free" Control.Monad.Trans.Free (FreeF (Free, Pure))
import safe "this" Yaya.Fold
  ( Algebra,
    Corecursive (ana),
    Mu,
    Nu,
    Projectable (project),
    Recursive (cata),
    Steppable (embed),
    cata2,
  )
import safe "this" Yaya.Fold.Common
  ( diagonal,
    fromEither,
    lucasSequence',
    maybeTakeNext,
    never,
    replaceNeither,
    takeAnother,
    takeAvailable,
    takeNext,
    toRight,
    truncate',
    unarySequence,
  )
import safe "this" Yaya.Fold.Native (Fix)
import safe "this" Yaya.Pattern
  ( Either (Left),
    Maybe (Just, Nothing),
    Pair,
    XNor (Both, Neither),
    maybe,
  )
import safe "base" Prelude (Integral, fromIntegral)

now :: (Steppable (->) t (Either a)) => a -> t
now = embed . Left

-- | This will collapse all the intermediate steps to get to the value that must
--   exist at the end.
runToEnd :: (Recursive (->) t (Either a)) => t -> a
runToEnd = cata fromEither

-- | Converts exceptional divergence to non-termination.
fromMaybe :: (Steppable (->) t (Either a), Corecursive (->) t (Either a)) => Maybe a -> t
fromMaybe = maybe (ana (toRight . never) ()) now

type Void = Mu Identity

absurd :: (Recursive (->) t Identity) => t -> a
absurd = cata runIdentity

vacuous :: (Functor f, Recursive (->) t Identity) => f t -> f a
vacuous = fmap absurd

zeroN :: (Steppable (->) t Maybe) => t
zeroN = embed Nothing

succN :: (Steppable (->) t Maybe) => t -> t
succN = embed . Just

height :: (Foldable f, Steppable (->) n Maybe, Ord n) => f n -> n
height = foldr (max . succN) zeroN

naturals :: (Steppable (->) n Maybe, Corecursive (->) t ((,) n)) => t
naturals = ana (unarySequence succN) zeroN

length :: (Recursive (->) t (XNor a), Steppable (->) n Maybe, Ord n) => t -> n
length = cata height

append :: (Recursive (->) t (XNor a), Steppable (->) u (XNor a)) => t -> u -> u
append front back = cata (embed . replaceNeither (project back)) front

instance Semigroup (Fix (XNor a)) where
  (<>) = append
  stimes = stimesMonoid

instance Monoid (Fix (XNor a)) where
  mempty = embed Neither

instance Semigroup (Mu (XNor a)) where
  (<>) = append
  stimes = stimesMonoid

instance Monoid (Mu (XNor a)) where
  mempty = embed Neither

drop' :: (Projectable (->) t (XNor a)) => Maybe (t -> t) -> t -> t
drop' (Just fn) (project -> Both _ t) = fn t
drop' _ t = t

drop :: (Recursive (->) n Maybe, Projectable (->) t (XNor a)) => n -> t -> t
drop = cata drop'

tail :: (Projectable (->) t (XNor a)) => t -> t
tail = drop (1 :: Natural)

reverse' ::
  (Steppable (->) t (XNor a)) =>
  XNor a (XNor a t -> XNor a t) ->
  XNor a t ->
  XNor a t
reverse' Neither = id
reverse' (Both a fn) = fn . Both a . embed

reverse :: (Recursive (->) t (XNor a), Steppable (->) u (XNor a)) => t -> u
reverse = embed . flip (cata reverse') Neither

-- | Extracts _no more than_ @n@ elements from the possibly-infinite sequence
--  @s@.
takeUpTo ::
  ( Recursive (->) n Maybe,
    Projectable (->) s (XNor a),
    Steppable (->) l (XNor a)
  ) =>
  n ->
  s ->
  l
takeUpTo = cata2 (embed . takeAvailable)

-- | Extracts _exactly_ @n@ elements from the infinite stream @s@.
take ::
  ( Recursive (->) n Maybe,
    Projectable (->) s ((,) a),
    Steppable (->) l (XNor a)
  ) =>
  n ->
  s ->
  l
take = cata2 (embed . takeAnother)

-- | Extracts the element at a finite index of an infinite sequence (a
--  `Data.List.!!` that can't fail).
at :: (Recursive (->) n Maybe, Projectable (->) s ((,) a)) => n -> s -> a
at = cata2 takeNext

-- | Extracts the element at a finite index of a (co)list (a `Data.List.!!` that
--   fails with `Nothing`).
atMay ::
  (Recursive (->) n Maybe, Projectable (->) s (XNor a)) => n -> s -> Maybe a
atMay = cata2 maybeTakeNext

-- | Turns part of a structure inductive, so it can be analyzed, without forcing
--   the entire tree.
maybeReify ::
  (Projectable (->) s f, Steppable (->) l (FreeF f s), Functor f) =>
  Algebra (->) Maybe (s -> l)
maybeReify Nothing = embed . Pure
maybeReify (Just f) = embed . Free . fmap f . project

reifyUpTo ::
  ( Recursive (->) n Maybe,
    Projectable (->) s f,
    Steppable (->) l (FreeF f s),
    Functor f
  ) =>
  n ->
  s ->
  l
reifyUpTo = cata maybeReify

fibonacciPolynomials :: (Integral i, Corecursive (->) t ((,) i)) => i -> t
fibonacciPolynomials x = lucasSequenceU x (-1)

fibonacci :: (Corecursive (->) t ((,) Int)) => t
fibonacci = fibonacciPolynomials 1

lucasSequenceU :: (Integral i, Corecursive (->) t ((,) i)) => i -> i -> t
lucasSequenceU p q = lucasSequence' p q `ana` (0, 1)

lucasSequenceV :: (Integral i, Corecursive (->) t ((,) i)) => i -> i -> t
lucasSequenceV p q = lucasSequence' p q `ana` (2, p)

lucas :: (Integral i) => (Corecursive (->) t ((,) i)) => t
lucas = lucasSequenceV 1 (-1)

pell :: (Integral i, Corecursive (->) t ((,) i)) => t
pell = lucasSequenceU 2 (-1)

jacobsthal :: (Integral i, Corecursive (->) t ((,) i)) => t
jacobsthal = lucasSequenceU 1 (-2)

mersenne :: (Integral i, Corecursive (->) t ((,) i)) => t
mersenne = lucasSequenceU 3 2

-- | Creates an infinite stream of the provided value.
constantly :: (Corecursive (->) t (Pair a)) => a -> t
constantly = ana diagonal

-- | Lops off the branches of the tree below a certain depth, turning a
--   potentially-infinite structure into a finite one. Like a generalized
--  `Yaya.Applied.take`.
truncate ::
  ( Recursive (->) n Maybe,
    Projectable (->) t f,
    Steppable (->) u (FreeF f ()),
    Functor f
  ) =>
  n ->
  t ->
  u
truncate = cata2 (embed . truncate')

-- | An implementation of `IsList.toList` for `Corecursive` fixed-points of
--  `XNor`.
fromList :: (Corecursive (->) t (XNor a)) => [a] -> t
fromList = ana project

-- | An implementation of `IsList.fromListN` for `Steppable` fixed-points of
--  `XNor`.
--
--   This should return an empty structure if the `Int` is negative.
--
--   If the target structure isn’t `Steppable` or the target structure is
--  `Corecursive` (i.e., `Yaya.Unsafe.Fold.Applied.unsafeFromList` isn’t used),
--   then the default definition for `fromListN` should suffice.
fromListN :: (Steppable (->) t (XNor a)) => Int -> [a] -> t
fromListN = cata2 (embed . takeAvailable) . fromIntegral @_ @Natural

-- | An implementation of `IsList.toList` for `Projectable` fixed-points of
--  `XNor`.
toList :: (Projectable (->) t (XNor a)) => t -> [a]
toList = ana project

-- | This instance is safe, since both structures are lazy.
instance IsList (Nu (XNor a)) where
  type Item (Nu (XNor a)) = a
  fromList = fromList
  toList = toList