View geoalg.hs
{-# LANGUAGE
GADTs
, DataKinds
, InstanceSigs
, ViewPatterns
, TypeFamilies
, TypeOperators
, TypeApplications
, FlexibleInstances
, StandaloneDeriving
View adicity.hs
runAdicity_0_1 :: (() -> (a, ()))
-> a
runAdicity_0_1 f = fst (f ())
adicity_0_1 :: a
-> t -> (a, t)
adicity_0_1 x t = (x, t)
adicity_1_1 :: (a -> b)
-> (a, t) -> (b, t)
View minimal.swift
struct MinimalDecoder : Decoder {
var codingPath = [CodingKey?]()
var userInfo = [CodingUserInfoKey : Any]()
public func container<Key>(keyedBy type: Key.Type) throws -> KeyedDecodingContainer<Key> {
return KeyedDecodingContainer(MinimalKeyedDecodingContainer<Key>(decoder: self))
}
public func unkeyedContainer() throws -> UnkeyedDecodingContainer {
return DecodingContainer(decoder: self)
View generic-unification.hs
-- See https://www.reddit.com/r/haskell/comments/6htj7z/generic_unification/
default zipMatch :: (ADT1 t, Constraints01 t Eq Unifiable) => t a -> t a -> Maybe (t (Either a (a, a)))
zipMatch = runZip $ generic01 @Eq @Unifiable
(Zip $ \a b -> if a == b then Just a else Nothing)
(\(Zip f) -> Zip $ \a b -> zipMatch a b >>= traverse (either (\x -> f x x) (uncurry f)))
(Zip $ \a b -> Just $ Right (a, b))
View instruments_ep.hs
class Instrument a where
sell :: a -> Price
play :: a -> Note -> Sound
data AcousticGuitar
= AcousticGuitar
{ tuning :: [Frequency]
, material :: WoodType
}
View finally-tagless-hoas.swift
// A (sadly untyped) adaptation of http://okmij.org/ftp/tagless-final/CB98.hs
protocol EDSL : ExpressibleByIntegerLiteral {
static func add(_ lhs: Self, _ rhs: Self) -> Self?
static func mul(_ lhs: Self, _ rhs: Self) -> Self?
static func lam(_ body: @escaping (Self) -> Self) -> Self
static func app(_ fn: Self, _ arg: Self) -> Self?
}
extension EDSL {
View HasSuperClassesProduct.hs
class (c x, d x) => (c :&: d) x
instance (c x, d x) => (c :&: d) x
instance (HasSuperClasses c, HasSuperClasses d, Distr (SuperClasses c)) => HasSuperClasses (c :&: d) where
type SuperClasses (c :&: d) = (c :&: d) ': SuperClasses c ++ SuperClasses d
superClasses = h superClasses superClasses
where
h :: forall x. c x :- FoldConstraints (SuperClasses c) x
-> d x :- FoldConstraints (SuperClasses d) x
-> (c :&: d) x :- FoldConstraints (SuperClasses (c :&: d)) x
View traversing.hs
-- based on https://github.com/ekmett/profunctors/pull/40
wander :: forall p a b s t. (Choice p, ProductProfunctor p)
=> (forall f. (Applicative f) => (a -> f b) -> s -> f t)
-> p a b -> p s t
wander tr p = lmap (runTrav . tr tLift) go where
go :: forall u. p (Coyo (TList a b) u) u
go = dimap unTList (either id id) . right' $ lmap fst go **** lmap snd p
-- This makes Costar Traversing and so also Strong! Bad idea, it just hangs when it's impossible to answer.
View oneliner-repr.hs
{-# LANGUAGE RankNTypes, TypeOperators, DefaultSignatures, FlexibleContexts, DeriveGeneric, DeriveAnyClass #-}
import Generics.OneLiner
import Data.Profunctor
import Data.Functor.Contravariant
import GHC.Generics
import Control.Applicative
import Unsafe.Coerce (unsafeCoerce)
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type Key t = forall x. Lens (t x) (t x) x x
View tinplate.hs
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, UndecidableInstances, TypeFamilies, DataKinds #-}
import Generics.OneLiner
import GHC.Generics
import Data.Proxy
class Tinplate' (p :: Bool) a b where
trav' :: Applicative f => proxy p -> (a -> f a) -> b -> f b
instance Tinplate' True a a where