lude

Lude.hs (15460B)

---

 module Lude (
 -- Types,
 -- Constraint,
 -- Levity (..),
 -- RuntimeRep (..),
 -- Thunked,
 -- LRep,
 -- URep,
 -- Type,
 -- BoxedType,
 -- LType,
 -- UType,
 -- Kind,
 -- Unlift (..),
 -- Function
 -- const,
 -- fix,
 -- flip,
 -- ($),
 -- ($!),
 -- (&),
 -- (&!),
 -- Bool
 -- IsBool (..),
 -- Bool (..),
 -- (&&),
 -- (||),
 -- not,
 -- Category
 -- Category (identity, compose),
 -- (<.),
 -- (.>),
 -- Functor
 {-
 Functor,
 void,
 Compose (Compose, getCompose),
 Const (Const, getConst),
 Identity (Identity, runIdentity),
 map,
 ($^),
 for,
 (^&),
 flap,
 (^$),
 flor,
 (&^),
 (<<^),
 (^>>),
 (^<<),
 (>>^),
 -- Applicative
 Applicative (pure),
 pass,
 ap,
 (^$^),
 plug,
 (^&^),
 (^<<^),
 (^>>^),
 -- Monad
 Monad,
 map',
 ($!^),
 for',
 (^&!),
 flap',
 (^$!),
 flor',
 (&!^),
 ap',
 (^$!^),
 plug',
 (^&!^),
 -}
 
 ) where
 
 {-
 
 -- import Control.Applicative (Alternative (empty, (<|>)), Applicative (liftA2, pure, (<*>)), (<**>))
 -- import Control.Monad (Monad ((>>=)))
 -- import Data.Bool (Bool (..), not, (&&), (||))
 -- import Data.Foldable (Foldable)
 -- import Data.Function (const, fix, flip)
 -- import Data.Functor (Functor (fmap), void)
 -- import Data.Functor.Compose (Compose (Compose, getCompose))
 -- import Data.Functor.Const (Const (Const, getConst))
 -- import Data.Functor.Identity (Identity (Identity, runIdentity))
 -- import Data.Maybe (Maybe (..))
 -- import Data.Traversable (Traversable (sequenceA))
 
 -- TODO: SIMD: VecCount (..) and VecElem (..)
 import GHC.Exts (Constraint, Levity (..), RuntimeRep (..))
 import GHC.Exts qualified as GHC
 
 --------------------------------------------------------------------------------
 -- Types
 
 -- | Types with an unlifted alternative.
 --
 -- Laws:
 --   - @force (lift x)  =  x@
 class Unlift a where
     type U a :: UType
     force :: a -> U a
     lift :: U a -> a
 
 --------------------------------------------------------------------------------
 
 -- type Functor :: forall r s. (Type r -> Type s) -> Constraint
 -- class Functor @r f where
 --     map :: forall (a :: Type r) (b :: Type r). (a -> b) -> f a -> f b
 
 -- type SemiApplicative :: forall r s. (Type r -> Type s) -> Constraint
 -- class (Functor f) => SemiApplicative @r f where
 --     map2 :: forall (a :: Type r) (b :: Type r) (c :: Type r). (a -> b -> c) -> f a -> f b -> f c
 
 -- type Applicative :: forall r s. (Type r -> Type s) -> Constraint
 -- class (SemiApplicative f) => Applicative @r f where
 --     pure :: forall (a :: Type r). a -> f a
 
 -- type SemiMonad :: forall r s. (Type r -> Type s) -> Constraint
 -- class (SemiApplicative f) => SemiMonad @r f where
 --     bind :: forall (a :: Type r) (b :: Type r). (a -> f b) -> f a -> f b
 
 -- type Monad :: forall r s. (Type r -> Type s) -> Constraint
 -- class (Applicative f, SemiMonad f) => Monad @r f
 
 -- type SemiComonad :: forall r s.
 
 --------------------------------------------------------------------------------
 -- Function
 
 -- Note how the associativities and (relative) precedences differ with the
 -- infix operators in Data.Function.
 -- infixl 0 &, &!
 -- infixl 1 $, $!
 
 -- | Function application.
 -- ($) :: (a -> b) -> a -> b
 -- f $ x = f x
 
 -- | Strict function application.
 -- ($!) :: (a -> b) -> a -> b
 -- f $! !x = f x
 
 -- Flipped function application, or "pipe".
 -- (&) :: a -> (a -> b) -> b
 -- x & f = f x
 
 -- Strict flipped function application, or "pipe".
 -- (&!) :: a -> (a -> b) -> b
 -- !x &! f = f x
 
 --------------------------------------------------------------------------------
 -- Bool
 
 -- class IsBool (bool :: Type r) where
 --     true :: (Thunked) => bool
 --     false :: (Thunked) => bool
 --     bool :: a -> a -> bool -> a
 
 -- instance IsBool Bool where
 --     true = True
 --     false = False
 --     bool t f = \case
 --         True -> t
 --         False -> f
 
 -- data UBool :: UType where
 --     UTrue :: UBool
 --     UFalse :: UBool
 
 -- instance IsBool UBool where
 --     true = UTrue
 --     false = UFalse
 --     bool t f = \case
 --         UTrue -> t
 --         UFalse -> f
 
 -- instance Unlift Bool where
 --     type U Bool = UBool
 
 --     force True = UTrue
 --     force False = UFalse
 
 --     lift UTrue = True
 --     lift UFalse = False
 
 --------------------------------------------------------------------------------
 -- Maybe
 
 -- class IsMaybe (maybe :: Type s -> Type r) where
 --     just :: a -> maybe a
 --     nothing :: (Thunked) => maybe a
 --     maybe :: b -> (a -> b) -> maybe a -> b
 
 -- instance IsMaybe Maybe where
 --     just = Just
 --     nothing = Nothing
 --     maybe n j = \case
 --         Just a -> j a
 --         Nothing -> n
 
 -- data UMaybe :: LType -> UType where
 --     UJust :: a -> UMaybe a
 --     UNothing :: UMaybe a
 
 -- instance IsMaybe UMaybe where
 --     just = UJust
 --     nothing = UNothing
 --     maybe n j = \case
 --         UJust a -> j a
 --         UNothing -> n
 
 -- instance Unlift (Maybe a) where
 --     type U (Maybe a) = UMaybe a
 
 --     force (Just a) = UJust a
 --     force Nothing = UNothing
 
 --     lift (UJust a) = Just a
 --     lift UNothing = Nothing
 
 -- data Maybe' :: UType -> LType where
 --     Just' :: a -> Maybe' a
 --     Nothing' :: Maybe' a
 
 -- instance IsMaybe Maybe' where
 --     just = Just'
 --     nothing = Nothing'
 --     maybe n j = \case
 --         Just' a -> j a
 --         Nothing' -> n
 
 -- data UMaybe' :: UType -> UType where
 --     UJust' :: a -> UMaybe' a
 --     UNothing' :: UMaybe' a
 
 -- instance IsMaybe UMaybe' where
 --     just = UJust'
 --     nothing = UNothing'
 --     maybe n j = \case
 --         UJust' a -> j a
 --         UNothing' -> n
 
 -- instance Unlift (Maybe' a) where
 --     type U (Maybe' a) = UMaybe' a
 
 --     force (Just' a) = UJust' a
 --     force Nothing' = UNothing'
 
 --     lift (UJust' a) = Just' a
 --     lift UNothing' = Nothing'
 
 -- isJust :: forall s r (maybe :: Type s -> Type r) a. (IsMaybe maybe) => maybe a -> Bool
 -- isJust = maybe False (const True)
 
 -- isNothing :: (IsMaybe maybe) => maybe a -> Bool
 -- isNothing = maybe True (const False)
 
 -- type family Maybe# (r :: RuntimeRep) (l :: Levity) :: Type r -> BoxedType l
 -- type instance Maybe# LRep Lifted = Maybe
 -- type instance Maybe# URep Lifted = Maybe'
 -- type instance Maybe# LRep Unlifted = UMaybe
 -- type instance Maybe# URep Unlifted = UMaybe'
 
 -- type family Lower (a :: Kind) :: Kind where
 --     Lower (BoxedType l) = TypeU
 --     Lower (k -> l) = k -> Lower l
 -- type family X (a :: k) :: Lower k
 -- type instance X (MaybeL @l) = MaybeL @Unlifted
 
 --------------------------------------------------------------------------------
 -- Numeric types
 
 -- TODO
 
 --------------------------------------------------------------------------------
 -- Category
 
 -- infixr 9 ∘
 
 -- infixr 2 <.
 -- infixl 2 .>
 
 -- (⊲⊳)
 -- (⋖⋗)
 -- (⩹⩺)
 -- (⨟)
 -- (⦂)
 -- (⋄)
 -- (∧∨)
 -- (⩓⩔)
 -- (∩∪)
 -- (=≠≡≢≈≉)
 -- (<>≤≥≮≯≰≱)
 -- (≺≻≼≽⊀⊁⋠⋡)
 -- (⊂⊃⊆⊇⊄⊅⊈⊉)
 -- (⊏⊐⊑⊒)
 -- (⊢⊣⊤⊥)
 -- y = h ∘ g ∘ f ∙^ x
 -- (f ⦾ g ⦿ x)
 -- y = h ◁ g ◁ f ◀ x
 -- y = x ▶ f ▷ g ▷ h
 -- (⧑⧒⧓⧔⧕⧖⧗⋈⋉⋊)
 -- (↑↓↔↕↖↗↘↙)
 -- (⥼⥽⥾⥿)
 -- (⊰⊱)
 -- (⭘∘)
 -- (⦁∙⋅)
 -- (⊙)
 -- (⊚)
 -- (⬬⬭⬮⬯)
 -- (⬝⬞)
 -- (⋆)
 -- (⬥⬦⬧⬨⬩⬪⬫)
 -- (◖◗)
 -- (◐◑)
 -- (⫾)
 -- (■▪▬▮▰▲▶▼◀◆)
 -- (∙⋆⋄*≀⌑▫)
 -- y = x ▪ f ▫ g ▫ h
 -- y = x ⦂ f ⨟ g ⨟ h
 
 -- TODO: Op, Products, Sums, Clown, Joker
 
 {-
 
 class (Bifunctor f, LDomOf f ~ Hask ρ, RDomOf f ~ Hask ρ) => Monoidal (f :: Type ρ -> Type ρ -> Type ρ) where
     type UnitOf f :: Type ρ
     unitl :: Iso (Hask ρ) (f (UnitOf f) a) a
     unitr :: Iso (Hask ρ) (f a (UnitOf f)) a
     assoc :: Iso (Hask ρ) (f (f a b) c) (f a (f b c))
 
 -- TODO: Having this only work for Hask sucks and is needlessly specialized.
 -- We can generalize this and some above definitions to any category whose
 -- objects have kind Type ρ, which isn't just Hask (e.g., Kleisli).
 class (Monoidal f) => Cartesian (f :: Type ρ -> Type ρ -> Type ρ) where
     fst :: forall (a :: Type ρ) (b :: Type ρ). f a b -> a
     snd :: forall (a :: Type ρ) (b :: Type ρ). f a b -> b
 
     pair :: forall (a :: Type ρ) (b :: Type ρ) (c :: Type ρ). (a -> b) -> (a -> c) -> a -> f b c
     pair f g = bimap f g ∘ diag
 
     diag :: forall (a :: Type ρ). a -> f a a
     diag = pair identity identity
 
 -}
 
 -- | Right-to-left composition.
 --
 -- This operator is right associative to exploit laziness in the case where
 -- the outer function doesn't need its argument:
 --
 -- > (const x <. (f <. g)) y  --->  const x ((f <. g) y)  --->  x
 --
 -- Note that @f <. g@ is never evaluated.
 -- (<.) :: (Category v) => v b c -> v a b -> v a c
 -- (<.) = (.)
 
 -- | Left-to-right composition.
 --
 -- This operator is left associative to exploit laziness in the case where
 -- the outer function doesn't need its argument:
 --
 -- > ((g .> f) .> const x) y  --->  const x ((g .> f) y)  --->  x
 --
 -- Note that @g .> f@ is never evaluated.
 -- (.>) :: (Category v) => v a b -> v b c -> v a c
 -- (.>) = flip (.)
 
 -- TODO: (.:), (<.:), (.:>)
 
 --------------------------------------------------------------------------------
 -- Functor
 
 {-
 infixl 0 ^&, &^, ~^&, ^&~, ~&^, &^~
 infixl 1 $^, ^$, $^~, ~$^, ^$~, ~^$
 infixr 2 <<^, ^>>, ^<<, >>^
 
 -- | The action of a functor on a function.
 map, ($^) :: (Functor f) => (a -> b) -> f a -> f b
 map = fmap
 ($^) = map
 
 -- | The action of a functor on a function, flipped.
 --
 -- With the BlockArguments extension, expressions like "@for xs \\x -> ...@"
 -- look like for-loops, hence the name "for".
 for, (^&) :: (Functor f) => f a -> (a -> b) -> f b
 for = flip map
 (^&) = for
 
 -- | Application of a function in a functor to a pure value.
 flap, (^$) :: (Functor f) => f (a -> b) -> a -> f b
 flap f a = f ^& ($ a)
 (^$) = flap
 
 -- | Flipped application of a function in a functor to a pure value.
 flor, (&^) :: (Functor f) => a -> f (a -> b) -> f b
 flor = flip flap
 (&^) = flor
 
 ($^~) :: (Functor f, Functor g) => (a -> b) -> g (f a) -> g (f b)
 f $^~ a = (f $^) $^ a
 
 (~^&) :: (Functor f, Functor g) => g (f a) -> (a -> b) -> g (f b)
 (~^&) = flip ($^~)
 
 (~$^) :: (Functor f, Functor g) => g (a -> b) -> f a -> g (f b)
 f ~$^ a = f ^& ($^ a)
 
 (^&~) :: (Functor f, Functor g) => f a -> g (a -> b) -> g (f b)
 (^&~) = flip (~$^)
 
 (^$~) :: (Functor f, Functor g) => f (a -> b) -> g a -> g (f b)
 f ^$~ a = (f ^$) $^ a
 
 (~&^) :: (Functor f, Functor g) => g a -> f (a -> b) -> g (f b)
 (~&^) = flip (^$~)
 
 (~^$) :: (Functor f, Functor g) => g (f (a -> b)) -> a -> g (f b)
 f ~^$ a = f ^& (^$ a)
 
 (&^~) :: (Functor f, Functor g) => a -> g (f (a -> b)) -> g (f b)
 (&^~) = flip (~^$)
 
 -- TODO
 
 -- | Right-to-left composition with the first function in a functor.
 (<<^) :: (Functor f, Category v) => v b c -> f (v a b) -> f (v a c)
 g <<^ f = (g <.) $^ f
 
 -- TODO
 
 -- | Left-to-right composition with the first function in a functor.
 (^>>) :: (Functor f, Category v) => f (v a b) -> v b c -> f (v a c)
 f ^>> g = f ^& (.> g)
 
 -- TODO
 
 -- | Right-to-left composition with the second function in a functor.
 (^<<) :: (Functor f, Category v) => f (v b c) -> v a b -> f (v a c)
 g ^<< f = g ^& (<. f)
 
 -- TODO
 
 -- | Left-to-right composition with the second function in a functor.
 (>>^) :: (Functor f, Category v) => v a b -> f (v b c) -> f (v a c)
 f >>^ g = (f .>) $^ g
 
 -- TODO: *^, ^*
 
 --------------------------------------------------------------------------------
 -- Applicative
 
 infixl 0 ^&^, ~^&^~
 infixl 1 ^$^, ~^$^~
 infixr 2 ^<<^, ^>>^
 
 -- | Functions with applicative effects.
 newtype Appy f a b = Appy {runAppy :: f (a -> b)}
 
 instance (Functor f) => Functor (Appy f a) where
     fmap f (Appy a) = Appy (f $^~ a)
 
 instance (Applicative f) => Applicative (Appy f a) where
     pure = Appy . pure . const
     Appy f <*> Appy a = Appy (f ~^$^~ a)
 
 hom :: (a -> b) -> (b -> b -> c) -> a -> a -> c
 hom f g x y = g (f x) (f y)
 
 instance (Alternative f) => Alternative (Appy f a) where
     empty = Appy empty
 
 -- Appy x <|> Appy y = Appy (x <|> y)
 -- (<|>) = hom runAppy (<|>)
 
 instance (Applicative f) => Category (Appy f) where
     id = Appy (pure id)
     Appy f . Appy g = Appy ((.) $^ f ^$^ g)
 
 -- TODO: Remove ap and plug?
 -- TODO: liftA{,1,2,3,4}
 
 -- | An alias for @pure ()@.
 pass :: (Applicative f) => f ()
 pass = pure ()
 
 -- | Application in an applicative functor.
 ap, (^$^) :: (Applicative f) => f (a -> b) -> f a -> f b
 ap = (<*>)
 (^$^) = ap
 
 -- | Flipped application in an applicative functor (with effects resolved as
 -- they appear, left-to-right).
 plug, (^&^) :: (Applicative f) => f a -> f (a -> b) -> f b
 plug = (<**>)
 (^&^) = plug
 
 (~^$^~) :: (Applicative f, Applicative g) => g (f (a -> b)) -> g (f a) -> g (f b)
 f ~^$^~ a = (^$^) $^ f ^$^ a
 
 (~^&^~) :: (Applicative f, Applicative g) => g (f a) -> g (f (a -> b)) -> g (f b)
 f ~^&^~ a = (^&^) $^ f ^$^ a
 
 -- TODO: document
 (^<<^) :: (Applicative f, Category v) => f (v b c) -> f (v a b) -> f (v a c)
 (^<<^) = liftA2 (<.)
 
 -- TODO: document
 (^>>^) :: (Applicative f, Category v) => f (v a b) -> f (v b c) -> f (v a c)
 (^>>^) = liftA2 (.>)
 
 -- TODO: "semicolons"
 
 --------------------------------------------------------------------------------
 -- Monad
 
 infixl 0 ^&!, &!^, ^&!^
 infixl 1 $!^, ^$!, ^$!^
 
 map', ($!^) :: (Monad m) => (a -> b) -> m a -> m b
 map' f mx = mx >>= \x -> pure $! f x
 ($!^) = map'
 
 for', (^&!) :: (Monad m) => m a -> (a -> b) -> m b
 for' = flip map'
 (^&!) = for
 
 flap', (^$!) :: (Monad m) => m (a -> b) -> a -> m b
 flap' mf x = mf >>= \f -> pure $! f x
 (^$!) = flap'
 
 flor', (&!^) :: (Monad m) => a -> m (a -> b) -> m b
 flor' = flip flap'
 (&!^) = flor'
 
 ap', (^$!^) :: (Monad m) => m (a -> b) -> m a -> m b
 ap' mf mx = do
     f <- mf
     x <- mx
     pure $! f x
 (^$!^) = ap'
 
 plug', (^&!^) :: (Monad m) => m a -> m (a -> b) -> m b
 plug' mx mf = do
     x <- mx
     f <- mf
     pure $! f x
 (^&!^) = plug'
 -}
 
 -- (.) :: (b0 -> c) -> (a0 -> b0) -> (a0 -> c)
 -- (g . f) a0 = g (f a0)
 -- (^.) :: (b0 -> b1 -> c) -> (a0 -> b1) -> (b0 -> a0 -> c)
 -- (g ^. f) b0 a0 = g b0 (f a0)
 -- (^^.) :: (b0 -> b1 -> b2 -> c) -> (a0 -> b2) -> (b0 -> b1 -> a0 -> c)
 -- (g ^^. f) b0 b1 a0 = g b0 b1 (f a0)
 -- (^^^.) :: (b0 -> b1 -> b2 -> b3 -> c) -> (a0 -> b3) -> (b0 -> b1 -> b2 -> a0 -> c)
 -- (g ^^^. f) b0 b1 b2 a0 = g b0 b1 b2 (f a0)
 -- (.^) :: (b0 -> c) -> (a0 -> a1 -> b0) -> (a0 -> a1 -> c)
 -- (g .^ f) a0 a1 = g (f a0 a1)
 -- (^.^) :: (b0 -> b1 -> c) -> (a0 -> a1 -> b1) -> (b0 -> a0 -> a1 -> c)
 -- (g ^.^ f) b0 a0 a1 = g b0 (f a0 a1)
 -- (^^.^) :: (b0 -> b1 -> b2 -> c) -> (a0 -> a1 -> b2) -> (b0 -> b1 -> a0 -> a1 -> c)
 -- (g ^^.^ f) b0 b1 a0 a1 = g b0 b1 (f a0 a1)
 -- (^^^.^) :: (b0 -> b1 -> b2 -> b3 -> c) -> (a0 -> a1 -> b3) -> (b0 -> b1 -> b2 -> a0 -> a1 -> c)
 -- (g ^^^.^ f) b0 b1 b2 a0 a1 = g b0 b1 b2 (f a0 a1)
 -- (.^^) :: (b0 -> c) -> (a0 -> a1 -> a2 -> b0) -> (a0 -> a1 -> a2 -> c)
 -- (^.^^) :: (b0 -> b1 -> c) -> (a0 -> a1 -> a2 -> b1) -> (b0 -> a0 -> a1 -> a2 -> c)
 -- (^^.^^) :: (b0 -> b1 -> b2 -> c) -> (a0 -> a1 -> a2 -> b2) -> (b0 -> b1 -> a0 -> a1 -> a2 -> c)
 -- (^^^.^^) :: (b0 -> b1 -> b2 -> b3 -> c) -> (a0 -> a1 -> a2 -> b3) -> (b0 -> b1 -> b2 -> a0 -> a1 -> a2 -> c)
 -- (.^^^) :: (b0 -> c) -> (a0 -> a1 -> a2 -> a3 -> b0) -> (a0 -> a1 -> a2 -> a3 -> c)
 -- (^.^^^) :: (b0 -> b1 -> c) -> (a0 -> a1 -> a2 -> a3 -> b1) -> (b0 -> a0 -> a1 -> a2 -> a3 -> c)
 -- (^^.^^^) :: (b0 -> b1 -> b2 -> c) -> (a0 -> a1 -> a2 -> a3 -> b2) -> (b0 -> b1 -> a0 -> a1 -> a2 -> a3 -> c)
 -- (^^^.^^^) :: (b0 -> b1 -> b2 -> b3 -> c) -> (a0 -> a1 -> a2 -> a3 -> b3) -> (b0 -> b1 -> b2 -> a0 -> a1 -> a2 -> a3 -> c)
 
 -}