module FP.Core
( module Prelude
, module FP.Core
, module GHC.Exts
, module Data.Char
, module Language.Haskell.TH
) where
import qualified Prelude
import Prelude
( Eq(..), Ord(..), Ordering(..)
, id, (.), ($), const, flip, curry, uncurry
, fst, snd
, Bool(..), (||), (&&), not, otherwise
, Char, Int, Integer, Double, Rational
, Maybe(..)
, undefined, seq
, IO
)
import Data.Text (Text)
import GHC.Exts (type Constraint)
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.Map as Map
import Language.Haskell.TH (Q)
import Data.Char (isSpace, isAlphaNum, isLetter, isDigit)
infix 9 ?
infixl 9 #
infixl 9 #!
infixl 9 <@>
infixl 9 *@
infixl 9 ^@
infixl 9 ^*@
infixr 9 *.
infixr 9 ^.
infixr 9 .^
infixr 9 ^^.
infixr 9 ^.:
infixr 9 ^*.
infixr 9 <.>
infixr 9 .:
infixr 9 ..:
infixr 9 :.:
infixr 9 :..:
infix 7 /
infix 7 //
infixr 7 *
infixr 7 <*>
infixr 7 /\
infix 6
infix 6 \-\
infixr 6 +
infixr 6 ++
infixr 6 :+:
infixr 6 <+>
infixr 6 \/
infix 4 <~
infix 4 <.
infixl 1 >>=
infixl 1 >>
infixr 1 ~>
infixr 0 *$
infixr 0 ^$
infixr 0 ^*$
infixr 0 <$>
infixr 0 ~:
infixr 0 =:
infixr 0 |:
data W (c :: Constraint) where
W :: (c) => W c
with :: W c -> (c => a) -> a
with W x = x
class Universal a where
instance Universal a
class (c1 a, c2 a) => (c1 ::*:: c2) a where
instance (c1 a, c2 a) => (c1 ::*:: c2) a where
class (t (u a)) => (t ::.:: u) a where
instance (t (u a)) => (t ::.:: u) a where
class (c1 ::=>:: c2) where
impl :: (c1) => W c2
class Functorial c t where
functorial :: (c a) => W (c (t a))
class Bifunctorial c t where
bifunctorial :: (c a, c b) => W (c (t a b))
bifunctorialP :: (Bifunctorial c t, c a, c b) => P c -> P t -> P a -> P b -> W (c (t a b))
bifunctorialP P P P P = bifunctorial
class ToInteger a where
toInteger :: a -> Integer
class FromInteger a where
fromInteger :: Integer -> a
class ToInt a where
toInt :: a -> Int
class FromInt a where
fromInt :: Int -> a
class ToRational a where
toRational :: a -> Rational
class FromRational a where
fromRational :: Rational -> a
class ToDouble a where
toDouble :: a -> Double
class FromDouble a where
fromDouble :: Double -> a
class ToChars a where
toChars :: a -> Chars
class FromChars a where
fromChars :: Chars -> a
fromString :: Chars -> String
fromString = fromChars
class ToString t where
toString :: t -> String
class FromString t where
fromString' :: String -> t
class Commute t u where
commute :: t (u a) -> u (t a)
class Peano a where
zer :: a
suc :: a -> a
niter :: (Eq a, Peano a) => (b -> b) -> b -> a -> b
niter f i0 x = loop i0 zer
where
loop i j
| j == x = i
| otherwise =
let i' = f i
in i' `seq` loop i' $ suc j
niterOn :: (Eq a, Peano a) => a -> b -> (b -> b) -> b
niterOn = mirror niter
class (Peano a) => Additive a where
zero :: a
(+) :: a -> a -> a
class (Additive a) => Subtractive a where
() :: a -> a -> a
class (Additive a) => Multiplicative a where
one :: a
(*) :: a -> a -> a
class (Multiplicative a) => Divisible a where
(/) :: a -> a -> a
class (Multiplicative a) => TruncateDivisible a where
(//) :: a -> a -> a
negate :: (Subtractive a) => a -> a
negate x = zero x
inverse :: (Divisible a) => a -> a
inverse x = one / x
class
( TruncateDivisible a
, ToInteger a, FromInteger a
, ToInt a, FromInt a
, ToRational a
, ToDouble a
) => Integral a where
class
( Divisible a
, ToRational a, FromRational a
, ToDouble a, FromDouble a
, FromInteger a
, FromInt a
) => Floating a where
class Category t where
catid :: t a a
(<.>) :: t b c -> t a b -> t a c
type m ~> n = forall a. m a -> n a
type t ~~> u = forall a m. t m a -> u m a
class Morphism a b where
morph :: a -> b
class Morphism2 m n where
morph2 :: m ~> n
class Morphism3 t u where
morph3 :: t ~~> u
class (Morphism a b, Morphism b a) => Isomorphism a b where
isoto :: (Isomorphism a b) => a -> b
isoto = morph
isofrom :: (Isomorphism a b) => b -> a
isofrom = morph
class (Morphism2 t u, Morphism2 u t) => Isomorphism2 t u where
isoto2 :: (Isomorphism2 t u) => t ~> u
isoto2 = morph2
isofrom2 :: (Isomorphism2 t u) => u ~> t
isofrom2 = morph2
onIso2 :: (Isomorphism2 t u) => (u a -> u b) -> t a -> t b
onIso2 f = isofrom2 . f . isoto2
class (Morphism3 v w, Morphism3 w v) => Isomorphism3 v w where
isoto3 :: (Isomorphism3 v w) => v ~~> w
isoto3 = morph3
isofrom3 :: (Isomorphism3 v w) => w ~~> v
isofrom3 = morph3
class HasLens a b where
view :: Lens a b
instance HasLens a a where
view = catid
viewP :: (HasLens a b) => P b -> Lens a b
viewP P = view
data POrdering = PEQ | PLT | PGT | PUN
fromOrdering :: Ordering -> POrdering
fromOrdering EQ = PEQ
fromOrdering LT = PLT
fromOrdering GT = PGT
class PartialOrder a where
pcompare :: a -> a -> POrdering
pcompare x y = case (x <~ y, y <~ x) of
(True , True ) -> PEQ
(True , False) -> PLT
(False, True ) -> PGT
(False, False) -> PUN
(<~) :: a -> a -> Bool
x <~ y = case pcompare x y of
PLT -> True
PEQ -> True
_ -> False
(<.) :: a -> a -> Bool
x <. y = case pcompare x y of
PLT -> True
_ -> False
(<=>) :: (Ord a) => a -> a -> Ordering
(<=>) = compare
(<~>) :: (PartialOrder a) => a -> a -> POrdering
(<~>) = pcompare
(>~) :: (PartialOrder a) => a -> a -> Bool
x >~ y = y <~ x
(>.) :: (PartialOrder a) => a -> a -> Bool
x >. y = y <. x
class PartialOrderF t where
partialOrderF :: (PartialOrder a) => W (PartialOrder (t a))
discreteOrder :: (Eq a) => a -> a -> POrdering
discreteOrder x y = if x == y then PEQ else PUN
poiter :: (PartialOrder a) => (a -> a) -> a -> a
poiter f = loop
where
loop x =
let x' = f x
in if x' <~ x then x else loop x'
class Monoid a where
null :: a
(++) :: a -> a -> a
iterateAppend :: (Monoid a, Eq n, Peano n) => n -> a -> a
iterateAppend n a = niterOn n null (a ++)
class JoinLattice a where
bot :: a
(\/) :: a -> a -> a
collect :: (JoinLattice a, PartialOrder a) => (a -> a) -> a -> a
collect f = poiter $ \ x -> x \/ f x
collectN :: (JoinLattice a, PartialOrder a, Eq n, Peano n) => n -> (a -> a) -> a -> a
collectN n f x0 = niterOn n x0 $ \ x -> x \/ f x
class MeetLattice a where
top :: a
(/\) :: a -> a -> a
class (JoinLattice a, MeetLattice a) => Lattice a where
class Unit t where
unit :: a -> t a
class Functor t where
map :: (a -> b) -> t a -> t b
(^@) :: (Functor t) => (a -> b) -> t a -> t b
(^@) = map
(^$) :: (Functor t) => (a -> b) -> t a -> t b
(^$) = map
(^.) :: (Functor t) => (b -> c) -> (a -> t b) -> a -> t c
g ^. f = map g . f
(.^) :: (Functor t) => (t b -> c) -> (a -> b) -> t a -> c
g .^ f = g . map f
(^.:) :: (Functor t) => (c -> d) -> (a -> b -> t c) -> a -> b -> t d
g ^.: f = map g .: f
(^..:) :: (Functor t) => (d -> e) -> (a -> b -> c -> t d) -> a -> b -> c -> t e
g ^..: f = map g ..: f
(^^.) :: (Functor t, Functor u) => (b -> c) -> (a -> t (u b)) -> a -> (t (u c))
g ^^. f = map (map g) . f
mapOn :: (Functor t) => t a -> (a -> b) -> t b
mapOn = flip map
class FunctorM t where
mapM :: (Monad m) => (a -> m b) -> t a -> m (t b)
(^*@) :: (FunctorM t, Monad m) => (a -> m b) -> t a -> m (t b)
(^*@) = mapM
(^*$) :: (FunctorM t, Monad m) => (a -> m b) -> t a -> m (t b)
(^*$) = mapM
(^*.) :: (FunctorM t, Monad m) => (b -> m c) -> (a -> m b) -> t a -> m (t c)
(g ^*. f) aT = mapM g *$ f ^*$ aT
mapOnM :: (FunctorM t, Monad m) => t a -> (a -> m b) -> m (t b)
mapOnM = flip mapM
sequence :: (FunctorM t, Monad m) => t (m a) -> m (t a)
sequence = mapM id
class Product t where
(<*>) :: t a -> t b -> t (a, b)
class Applicative t where
(<@>) :: t (a -> b) -> t a -> t b
(<$>) :: (Applicative t) => t (a -> b) -> t a -> t b
(<$>) = (<@>)
class Bind (m :: * -> *) where
(>>=) :: m a -> (a -> m b) -> m b
class (Unit m, Functor m, Product m, Applicative m, Bind m) => Monad m where
fail :: Chars -> m a
fail = Prelude.error
return :: (Monad m) => a -> m a
return = unit
kleisli :: (Monad m) => (a -> b) -> (a -> m b)
kleisli = (.) return
(>>) :: (Bind m) => m a -> m b -> m b
aM >> bM = aM >>= const bM
extend :: (Bind m) => (a -> m b) -> (m a -> m b)
extend = flip (>>=)
void :: (Functor m) => m a -> m ()
void = map (const ())
(*@) :: (Bind m) => (a -> m b) -> (m a -> m b)
(*@) = extend
(*$) :: (Bind m) => (a -> m b) -> (m a -> m b)
(*$) = extend
(*.) :: (Bind m) => (b -> m c) -> (a -> m b) -> (a -> m c)
(g *. f) x = g *$ f x
mmap :: (Bind m, Unit m) => (a -> b) -> m a -> m b
mmap f aM = do
a <- aM
unit $ f a
mpair :: (Bind m, Unit m) => m a -> m b -> m (a, b)
mpair aM bM = do
a <- aM
b <- bM
unit (a, b)
mapply :: (Bind m, Unit m) => m (a -> b) -> m a -> m b
mapply fM aM = do
f <- fM
a <- aM
unit $ f a
mjoin :: (Bind m) => m (m a) -> m a
mjoin = extend id
when :: (Unit m) => Bool -> m () -> m ()
when True = id
when False = const $ unit ()
class Unit2 t where
unit2 :: m ~> t m
class Join2 t where
join2 :: t (t m) ~> t m
class Functor2 t where
map2 :: (m ~> n) -> t m ~> t n
class IsoFunctor2 t where
isoMap2 :: (m ~> n) -> (n ~> m) -> t m ~> t n
class FunctorUnit2 t where
funit2 :: (Functor m) => m ~> t m
class FunctorJoin2 t where
fjoin2 :: (Functor m) => t (t m) ~> t m
class FunctorFunctor2 t where
fmap2 :: (Functor m, Functor n) => (m ~> n) -> t m ~> t n
class FunctorIsoFunctor2 t where
fisoMap2 :: (Functor m, Functor n) => (m ~> n) -> (n ~> m) -> t m ~> t n
class MonadUnit2 t where
munit2 :: (Monad m) => m ~> t m
class MonadJoin2 t where
mjoin2 :: (Monad m) => t (t m) ~> t m
class MonadFunctor2 t where
mmap2 :: (Monad m, Monad n) => (m ~> n) -> t m ~> t n
class MonadIsoFunctor2 t where
misoMap2 :: (Monad m, Monad n) => (m ~> n) -> (n ~> m) -> t m ~> t n
class MonadZero (m :: * -> *) where
mzero :: m a
guard :: (Unit m, MonadZero m) => Bool -> m ()
guard True = unit ()
guard False = mzero
liftMaybeZero :: (Unit m, MonadZero m) => Maybe a -> m a
liftMaybeZero Nothing = mzero
liftMaybeZero (Just a) = unit a
class MonadConcat (m :: * -> *) where
(<++>) :: m a -> m a -> m a
class MonadPlus (m :: * -> *) where
(<+>) :: m a -> m a -> m a
oneOrMore :: (Monad m, MonadZero m, MonadConcat m) => m a -> m (a, [a])
oneOrMore aM = do
x <- aM
xs <- many aM
return (x, xs)
twoOrMore :: (Monad m, MonadZero m, MonadConcat m) => m a -> m (a, a, [a])
twoOrMore aM = do
x1 <- aM
(x2, xs) <- oneOrMore aM
return (x1, x2, xs)
oneOrMoreList :: (Monad m, MonadZero m, MonadConcat m) => m a -> m [a]
oneOrMoreList = uncurry (:) ^. oneOrMore
many :: (Monad m, MonadZero m, MonadConcat m) => m a -> m [a]
many aM = mconcat
[ oneOrMoreList aM
, return []
]
newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
class (Monad m) => MonadMaybeI m where
maybeI :: m ~> MaybeT m
class (Monad m) => MonadMaybeE m where
maybeE :: MaybeT m ~> m
class (MonadMaybeI m, MonadMaybeE m) => MonadMaybe m where
maybeEM :: (MonadMaybeE m) => m (Maybe a) -> m a
maybeEM = maybeE . MaybeT
lookMaybe :: (MonadMaybeI m) => m a -> m (Maybe a)
lookMaybe = runMaybeT . maybeI
abort :: (MonadMaybeE m) => m a
abort = maybeEM $ return Nothing
(<|>) :: (MonadMaybeI m) => m a -> m a -> m a
aM1 <|> aM2 = do
aM' <- lookMaybe aM1
case aM' of
Just a -> return a
Nothing -> aM2
newtype ErrorT e m a = ErrorT { runErrorT :: m (e :+: a) }
class (Monad m) => MonadErrorE e m where
errorE :: ErrorT e m ~> m
class (Monad m) => MonadErrorI e m where
errorI :: m ~> ErrorT e m
class (MonadErrorE e m, MonadErrorI e m) => MonadError e m where
liftSum :: (MonadErrorE e m) => e :+: a -> m a
liftSum = errorE . ErrorT . return
throw :: (MonadErrorE e m) => e -> m a
throw e = errorE $ ErrorT $ return $ Inl e
catch :: (MonadErrorI e m) => m a -> (e -> m a) -> m a
catch aM h = do
aeM <- runErrorT $ errorI aM
case aeM of
Inl e -> h e
Inr a -> return a
catchP :: (MonadErrorI e m) => P e -> m a -> (e -> m a) -> m a
catchP _ = catch
newtype ReaderT r m a = ReaderT { unReaderT :: r -> m a }
runReaderT :: r -> ReaderT r m a -> m a
runReaderT = flip unReaderT
class (Monad m) => MonadReaderI r m where
readerI :: m ~> ReaderT r m
class (Monad m) => MonadReaderE r m where
readerE :: ReaderT r m ~> m
class (MonadReaderI r m, MonadReaderE r m) => MonadReader r m where
ask :: (MonadReaderE r m) => m r
ask = readerE $ ReaderT return
askP :: (MonadReaderE r m) => P r -> m r
askP P = ask
askL :: (MonadReaderE r m) => Lens r a -> m a
askL l = access l ^$ ask
local :: (MonadReader r m) => (r -> r) -> m a -> m a
local f aM = readerE $ ReaderT $ \ e -> runReaderT (f e) $ readerI aM
localP :: (MonadReader r m) => P r -> (r -> r) -> m a -> m a
localP P = local
localSet :: (MonadReader r m) => r -> m a -> m a
localSet = local . const
localL :: (MonadReader r m) => Lens r b -> (b -> b) -> m a -> m a
localL = local .: update
localSetL :: (MonadReader r m) => Lens r b -> b -> m a -> m a
localSetL l = localL l . const
newtype WriterT o m a = WriterT { runWriterT :: m (a, o) }
class (Monad m) => MonadWriterI o m | m -> o where
writerI :: m ~> WriterT o m
class (Monad m) => MonadWriterE o m | m -> o where
writerE :: WriterT o m ~> m
class (MonadWriterI o m, MonadWriterE o m) => MonadWriter o m | m -> o where
tell :: (MonadWriterE o m) => o -> m ()
tell = writerE . WriterT . return . ((),)
tellP :: (MonadWriterE o m) => P o -> o -> m ()
tellP P = tell
hijack :: (MonadWriterI o m) => m a -> m (a, o)
hijack = runWriterT . writerI
newtype StateT s m a = StateT { unStateT :: s -> m (a, s) }
class MonadStateI s m | m -> s where
stateI :: m ~> StateT s m
class MonadStateE s m | m -> s where
stateE :: StateT s m ~> m
class (MonadStateI s m, MonadStateE s m) => MonadState s m | m -> s where
get :: (Monad m, MonadStateE s m) => m s
get = stateE $ StateT $ \ s -> return (s, s)
getP :: (Monad m, MonadStateE s m) => P s -> m s
getP P = get
getL :: (Monad m, MonadStateE s m) => Lens s a -> m a
getL l = map (access l) get
put :: (Monad m, MonadStateE s m) => s -> m ()
put s = stateE $ StateT $ \ _ -> return ((), s)
putP :: (Monad m, MonadStateE s m) => P s -> s -> m ()
putP P = put
putL :: (Monad m, MonadStateE s m) => Lens s a -> a -> m ()
putL = modify .: set
modifyM :: (Monad m, MonadStateE s m) => (s -> m s) -> m ()
modifyM f = stateE $ StateT $ \ s -> return () <*> f s
modify :: (Monad m, MonadStateE s m) => (s -> s) -> m ()
modify = modifyM . kleisli
modifyP :: (Monad m, MonadStateE s m) => P s -> (s -> s) -> m ()
modifyP P = modify
modifyL :: (Monad m, MonadStateE s m) => Lens s a -> (a -> a) -> m ()
modifyL = modify .: update
modifyLM :: (Monad m, MonadStateE s m) => Lens s a -> (a -> m a) -> m ()
modifyLM = modifyM .: updateM
localStateSet :: (Monad m, MonadStateI s m) => s -> m a -> m (a, s)
localStateSet s aM = unStateT (stateI aM) s
next :: (Monad m, MonadStateE s m, Peano s) => m s
next = do
i <- get
put $ suc i
return i
nextL :: (Monad m, MonadStateE s m, Peano a) => Lens s a -> m a
nextL l = do
i <- getL l
putL l $ suc i
return i
bumpL :: (Monad m, MonadStateE s m, Peano a) => Lens s a -> m ()
bumpL l = modifyL l suc
newtype RWST r o s m a = RWST { unRWST :: ReaderT r (WriterT o (StateT s m)) a }
class (MonadReaderI r m, MonadWriterI o m, MonadStateI s m) => MonadRWSI r o s m where
rwsI :: m ~> RWST r o s m
class (MonadReaderE r m, MonadWriterE o m, MonadStateE s m) => MonadRWSE r o s m where
rwsE :: RWST r o s m ~> m
class (MonadReader r m, MonadWriter o m, MonadState s m) => MonadRWS r o s m where
newtype ListT m a = ListT { runListT :: m [a] }
class (Monad m) => MonadListI m where
listI :: m ~> ListT m
class (Monad m) => MonadListE m where
listE :: ListT m ~> m
class (MonadListI m, MonadListE m) => MonadList m where
liftList :: (Monad m, MonadListE m) => [a] -> m a
liftList = listE . ListT . return
listAbort :: (MonadListE m) => m a
listAbort = listE $ ListT $ unit []
newtype ListSetT m a = ListSetT { runListSetT :: m (ListSet a) }
class (Monad m) => MonadListSetI m where
listSetI :: m ~> ListSetT m
class (Monad m) => MonadListSetE m where
listSetE :: ListSetT m ~> m
class (MonadListSetI m, MonadListSetE m) => MonadListSet m where
class MonadIO m where
liftIO :: IO ~> m
class MonadQ m where
liftQ :: Q ~> m
newtype SetT m a = SetT { runSetT :: m (Set a) }
mapSetT :: (m (Set a) -> m (Set b)) -> SetT m a -> SetT m b
mapSetT f = SetT . f . runSetT
class (Bind m) => MonadSetI m where
setI :: m ~> SetT m
class (Bind m) => MonadSetE m where
setE :: SetT m ~> m
newtype KonT r m a = KonT { runKonT :: (a -> m r) -> m r }
class (Monad m) => MonadKonI r m | m -> r where
konI :: m ~> KonT r m
class (Monad m) => MonadKonE r m | m -> r where
konE :: KonT r m ~> m
class (MonadKonI r m, MonadKonE r m) => MonadKon r m | m -> r where
callCC :: (MonadKonE r m) => ((a -> m r) -> m r) -> m a
callCC = konE . KonT
withC :: (MonadKonI r m) => (a -> m r) -> m a -> m r
withC k aM = runKonT (konI aM) k
reset :: (MonadKon r m) => m r -> m r
reset aM = callCC $ \ k -> k *$ withC return aM
modifyC :: (MonadKon r m) => (r -> m r) -> m a -> m a
modifyC f aM = callCC $ \ k -> withC (f *. k) aM
newtype KFun r m a = KFun { runKFun :: a -> m r }
newtype OpaqueKonT k r m a = OpaqueKonT { runOpaqueKonT :: k r m a -> m r }
class (MonadKonI r m, Monad m) => MonadOpaqueKonI k r m | m -> k, m -> r where
withOpaqueC :: k r m a -> m a -> m r
class (MonadKonE r m, Monad m) => MonadOpaqueKonE k r m | m -> k, m -> r where
callOpaqueCC :: (k r m a -> m r) -> m a
class (MonadKon r m, MonadOpaqueKonI k r m, MonadOpaqueKonE k r m) => MonadOpaqueKon k r m | m -> k, m -> r where
class Iterable a t | t -> a where
foldlk :: forall b. (b -> a -> (b -> b) -> b) -> b -> t -> b
foldlk f i0 t = foldl (\ (iK :: (b -> b) -> b) (a :: a) (k :: b -> b) ->
iK $ \ i -> f i a k) ($ i0) t id
foldl :: (b -> a -> b) -> b -> t -> b
foldl f = foldlk $ \ a i k -> let i' = f a i in i' `seq` k i'
foldr :: (a -> b -> b) -> b -> t -> b
foldr f = foldlk $ \ i a k -> f a $ k i
iter :: (a -> b -> b) -> b -> t -> b
iter = foldl . flip
size :: (Integral n) => t -> n
size = iter (const suc) 0
concat :: (Iterable a t, Monoid a) => t -> a
concat = foldr (++) null
mconcat :: (Iterable (m a) t, MonadZero m, MonadConcat m) => t -> m a
mconcat = foldr (<++>) mzero
mlist :: (Iterable a t, MonadZero m, Unit m, MonadConcat m) => t -> m a
mlist = foldr ((<++>) . unit) mzero
mtry :: (MonadMaybe m) => [m a] -> m a
mtry = foldr (<|>) abort
joins :: (Iterable a t, JoinLattice a) => t -> a
joins = iter (\/) bot
msum :: (Iterable (m a) t, MonadZero m, MonadPlus m) => t -> m a
msum = iter (<+>) mzero
mset :: (Iterable a t, MonadZero m, Unit m, MonadPlus m) => t -> m a
mset = iter ((<+>) . unit) mzero
iterOn :: (Iterable a t) => t -> b -> (a -> b -> b) -> b
iterOn = mirror iter
iterFrom :: (Iterable a t) => b -> (a -> b -> b) -> t -> b
iterFrom = flip iter
foldlOn :: (Iterable a t) => t -> b -> (b -> a -> b) -> b
foldlOn = mirror foldl
foldlFrom :: (Iterable a t) => b -> (b -> a -> b) -> t -> b
foldlFrom = flip foldl
foldrOn :: (Iterable a t) => t -> b -> (a -> b -> b) -> b
foldrOn = mirror foldr
foldrFrom :: (Iterable a t) => b -> (a -> b -> b) -> t -> b
foldrFrom = flip foldr
findMax :: (Iterable a t, PartialOrder b) => (a -> b) -> a -> t -> a
findMax p i0 = iterFrom i0 $ \ a i -> if p a >. p i then a else i
findMaxFrom :: (Iterable a t, PartialOrder b) => a -> (a -> b) -> t -> a
findMaxFrom = flip findMax
isElem :: (Iterable a t, Eq a) => a -> t -> Bool
isElem x = foldlk (\ _ x' k -> if x == x' then True else k False) False
elemAtN :: (Iterable a t, Peano n, Eq n) => n -> t -> Maybe a
elemAtN n t = case foldlk ff (Inr zer) t of
Inl x -> Just x
Inr _ -> Nothing
where
ff (Inr i) x' k = if i == n then Inl x' else k $ Inr $ suc i
ff (Inl _) _ _ = error "internal error"
traverse :: (Iterable a t, Monad m) => (a -> m ()) -> t -> m ()
traverse f = foldl (\ m a -> m >> f a) $ return ()
traverseOn :: (Iterable a t, Monad m) => t -> (a -> m ()) -> m ()
traverseOn = flip traverse
exec :: (Iterable (m ()) t, Monad m) => t -> m ()
exec = traverse id
toList :: (Iterable a t) => t -> [a]
toList = foldr (:) []
class Buildable a t | t -> a where
nil :: t
cons :: a -> t -> t
fromList :: (Buildable a t) => [a] -> t
fromList = foldr cons nil
class Container e t | t -> e where
(?) :: t -> e -> Bool
elem :: (Container e t) => e -> t -> Bool
elem = flip (?)
class Indexed k v t | t -> k, t -> v where
(#) :: t -> k -> Maybe v
index :: (Indexed k v t) => t -> k -> Maybe v
index = (#)
(#!) :: (Indexed k v t) => t -> k -> v
(#!) = unsafe_coerce justL .: (#)
lookup :: (Indexed k v t) => k -> t -> Maybe v
lookup = flip (#)
class (Iterable a t, Buildable a t) => ListLike a t | t -> a where
isNil :: t -> Bool
isNil = isL nothingL . uncons
uncons :: t -> Maybe (a, t)
toListLike :: (ListLike a t) => [a] -> t
toListLike = foldr cons nil
fromListLike :: (ListLike a t) => t -> [a]
fromListLike = foldr cons nil
single :: a -> [a]
single = flip (:) []
filter :: (a -> Bool) -> [a] -> [a]
filter p = foldr (\ x -> if p x then (x :) else id) []
reverse :: [a] -> [a]
reverse = foldl (flip (:)) []
uniques :: (Eq a) => [a] -> [a]
uniques = foldrFrom [] $ \ x xs -> x : filter ((/=) x) xs
zip :: [a] -> [b] -> Maybe [(a, b)]
zip [] [] = return []
zip (_:_) [] = Nothing
zip [] (_:_) = Nothing
zip (x:xs) (y:ys) = do
xys <- zip xs ys
return $ (x,y) : xys
unzip :: [(a, b)] -> ([a], [b])
unzip [] = ([], [])
unzip ((x, y):xys) =
let (xs, ys) = unzip xys
in (x:xs, y:ys)
replicate :: (Eq n, Peano n) => n -> a -> [a]
replicate n = niterOn n [] . (:)
firstN :: (Eq n, Integral n) => n -> [a] -> [a]
firstN n = recur 0
where
recur _ [] = []
recur i (x:xs)
| i == n = []
| otherwise = x : recur (suc i) xs
intersperse :: a -> [a] -> [a]
intersperse _ [] = []
intersperse _ [x] = [x]
intersperse i (x:xs) = x : recur xs
where
recur [] = []
recur (x':xs') = i : x' : recur xs'
mapHead :: (a -> a) -> [a] -> [a]
mapHead _ [] = []
mapHead f (x:xs) = f x:xs
mapTail :: (a -> a) -> [a] -> [a]
mapTail _ [] = []
mapTail f (x:xs) = x:map f xs
head :: [a] -> Maybe a
head [] = Nothing
head (x:_) = Just x
tail :: [a] -> Maybe [a]
tail [] = Nothing
tail (_:xs) = Just xs
length :: (Peano n) => [a] -> n
length [] = zer
length (_:xs) = suc $ length xs
class (Iterable e t, Container e t) => SetLike e t | t -> e where
learnSet :: t -> b -> ((Ord e) => b) -> b
empty :: t
isEmpty :: t -> Bool
isEmpty = isL nothingL . remove
insert :: (Ord e) => e -> t -> t
remove :: t -> Maybe (e, t)
union :: t -> t -> t
union s1 s2 = learnSet s2 s1 $ iter insert s2 s1
intersection :: t -> t -> t
intersection s1 s2 = s1 \-\ (s1 \-\ s2)
(\-\) :: t -> t -> t
s1 \-\ s2 = learnSet s2 s1 $ iter (\ e -> if s2 ? e then id else insert e) empty s1
singleton :: (Ord e) => e -> Set e
singleton = flip insert empty
setMap :: (Ord b) => (a -> b) -> Set a -> Set b
setMap f = iter (insert . f) empty
liftMaybeSet :: (Ord a) => Maybe a -> Set a
liftMaybeSet Nothing = empty
liftMaybeSet (Just a) = singleton a
toSet :: (Ord a) => [a] -> Set a
toSet = iter insert empty
fromSet :: Set a -> [a]
fromSet = iter (:) []
class (Iterable (k,v) t, Indexed k v t) => MapLike k v t | t -> k, t -> v where
learnMap :: t -> b -> ((Ord k) => b) -> b
mapEmpty :: t
mapIsEmpty :: t -> Bool
mapInsertWith :: (Ord k) => (v -> v -> v) -> k -> v -> t -> t
mapRemove :: t -> Maybe ((k, v), t)
mapUnionWith :: (v -> v -> v) -> t -> t -> t
mapUnionWith f m1 m2 = learnMap m2 m1 $ iter (\ (k,v) -> mapInsertWith f k v) m2 m1
mapIntersectionWith :: (v -> v -> v) -> t -> t -> t
mapIntersectionWith f m1 m2 =
learnMap m2 mapEmpty $
iterOn (mapKeys m1 `union` mapKeys m2) mapEmpty $ \ k ->
case (m1 # k, m2 # k) of
(Nothing, Nothing) -> id
(Just v, Nothing) -> mapInsert k v
(Nothing, Just v) -> mapInsert k v
(Just v1, Just v2) -> mapInsert k $ f v1 v2
mapModify :: (v -> v) -> k -> t -> t
mapModify f k m =
learnMap m mapEmpty $
case m # k of
Nothing -> m
Just v -> mapInsert k (f v) m
mapKeys :: t -> Set k
mapKeys m = learnMap m empty $ iter (insert . fst) empty m
mapInsert :: (MapLike k v t, Ord k) => k -> v -> t -> t
mapInsert = mapInsertWith $ const id
onlyKeys :: (SetLike k t, MapLike k v u) => t -> u -> u
onlyKeys t u = learnMap u mapEmpty $ iter (\ k -> maybeElim id (mapInsert k) $ u # k) mapEmpty t
toMap :: (Ord k) => [(k,v)] -> Map k v
toMap = iter (uncurry mapInsert) mapEmpty
fromMap :: Map k v -> [(k,v)]
fromMap = foldr (:) []
data P a = P
data Cursor a b = Cursor { focus :: a, construct :: a -> b }
data Lens a b = Lens { runLens :: a -> Cursor b a }
lens :: (a -> b) -> (a -> b -> a) -> Lens a b
lens getter setter = Lens $ \ s -> Cursor (getter s) (setter s)
isoLens :: (a -> b) -> (b -> a) -> Lens a b
isoLens to from = lens to $ const from
instance Category Lens where
catid = isoLens id id
g <.> f = Lens $ \ a ->
let Cursor b ba = runLens f a
Cursor c cb = runLens g b
in Cursor c $ ba . cb
access :: Lens a b -> a -> b
access = focus .: runLens
update :: Lens a b -> (b -> b) -> a -> a
update l f a =
let Cursor b ba = runLens l a
in ba $ f b
(~:) :: Lens a b -> (b -> b) -> a -> a
(~:) = update
updateM :: (Monad m) => Lens a b -> (b -> m b) -> a -> m a
updateM l f a =
let Cursor b ba = runLens l a
in map ba $ f b
set :: Lens a b -> b -> a -> a
set l = update l . const
(=:) :: Lens a b -> b -> a -> a
(=:) = set
(|:) :: a -> (a -> a) -> a
(|:) = applyTo
data Prism a b = Prism { coerce :: a -> Maybe b, inject :: b -> a }
unsafe_coerce :: Prism a b -> a -> b
unsafe_coerce p a = case coerce p a of
Nothing -> error "unsafe_coerce"
Just b -> b
prism :: (a -> Maybe b) -> (b -> a) -> Prism a b
prism = Prism
isoPrism :: (a -> b) -> (b -> a) -> Prism a b
isoPrism to from = prism (Just . to) from
instance Category Prism where
catid = isoPrism id id
g <.> f = Prism
{ coerce = coerce g *. coerce f
, inject = inject f . inject g
}
isL :: Prism a b -> a -> Bool
isL p a = case coerce p a of
Just _ -> True
Nothing -> False
alter :: Prism a b -> (b -> b) -> a -> a
alter p f a = maybeElim a (inject p . f) $ coerce p a
pset :: Prism a b -> b -> a -> a
pset p = alter p . const
(~^) :: Prism a b -> (b -> b) -> a -> a
(~^) = alter
instance Category (->) where
catid = id
(<.>) = (.)
instance Functor ((->) a) where
map = (.)
instance (Monoid b) => Monoid (a -> b) where
null = const null
(++) f g x = f x ++ g x
instance (JoinLattice b) => JoinLattice (a -> b) where
bot = const bot
(\/) f g x = f x \/ g x
instance (MeetLattice b) => MeetLattice (a -> b) where
top = const top
(/\) f g x = f x /\ g x
instance (Lattice b) => Lattice (a -> b) where
applyTo :: a -> (a -> b) -> b
applyTo = flip ($)
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(.:) = (.) . (.)
(..:) :: (d -> e) -> (a -> b -> c -> d) -> (a -> b -> c -> e)
(..:) = (.) . (.:)
(...:) :: (e -> f) -> (a -> b -> c -> d -> e) -> (a -> b -> c -> d -> f)
(...:) = (.) . (..:)
(....:) :: (f -> g) -> (a -> b -> c -> d -> e -> f) -> (a -> b -> c -> d -> e -> g)
(....:) = (.) . (...:)
rotateR :: (a -> b -> c -> d) -> (c -> a -> b -> d)
rotateR f c a b = f a b c
rotateL :: (a -> b -> c -> d) -> (b -> c -> a -> d)
rotateL f b c a = f a b c
mirror :: (a -> b -> c -> d) -> (c -> b -> a -> d)
mirror f c b a = f a b c
on :: (b -> b -> c) -> (a -> b) -> (a -> a -> c)
on p f x y = p (f x) (f y)
composition :: [a -> a] -> a -> a
composition = unEndo . concat . map Endo
data Endo a = Endo { unEndo :: a -> a }
runEndo :: a -> Endo a -> a
runEndo = flip unEndo
instance Monoid (Endo a) where
null = Endo id
g ++ f = Endo $ unEndo g . unEndo f
data KleisliEndo m a = KleisliEndo { unKleisliEndo :: a -> m a }
runKleisliEndo :: a -> KleisliEndo m a -> m a
runKleisliEndo = flip unKleisliEndo
instance (Monad m) => Monoid (KleisliEndo m a) where
null = KleisliEndo return
g ++ f = KleisliEndo $ unKleisliEndo g *. unKleisliEndo f
instance JoinLattice Bool where
bot = False
(\/) = (||)
instance MeetLattice Bool where
top = True
(/\) = (&&)
instance Monoid Bool where
null = bot
(++) = (\/)
instance ToString Bool where
toString = show
fif :: Bool -> a -> a -> a
fif True x _ = x
fif False _ y = y
cond :: (a -> Bool) -> c -> c -> (a -> c)
cond p t f x = if p x then t else f
ifThenElse :: Bool -> a -> a -> a
ifThenElse = fif
instance ToString Char where
toString = show
type String = Text
type Chars = [Char]
instance ToChars String where
toChars = Text.unpack
instance FromChars String where
fromChars = Text.pack
instance Monoid String where
null = Text.empty
(++) = Text.append
instance Iterable Char String where
foldl = Text.foldl'
foldr = Text.foldr
iter = foldl . flip
size = fromInt . Text.length
instance ToString String where
toString = show
error :: String -> a
error = Prelude.error . toChars
show :: (Prelude.Show a) => a -> String
show = fromChars . Prelude.show
instance FromInteger Int where
fromInteger = Prelude.fromIntegral
instance ToInteger Int where
toInteger = Prelude.toInteger
instance Peano Int where
zer = 0
suc = Prelude.succ
instance Additive Int where
zero = 0
(+) = (Prelude.+)
instance Subtractive Int where
() = (Prelude.-)
instance Multiplicative Int where
one = 1
(*) = (Prelude.*)
instance TruncateDivisible Int where
(//) = Prelude.div
instance ToInt Int where
toInt = id
instance FromInt Int where
fromInt = id
instance ToRational Int where
toRational = Prelude.fromIntegral
instance ToDouble Int where
toDouble = Prelude.fromIntegral
instance Integral Int where
instance ToString Int where
toString = show
instance PartialOrder Int where
pcompare = fromOrdering .: compare
instance JoinLattice Int where
bot = Prelude.minBound
x \/ y = Prelude.max x y
instance Monoid Int where
null = 0
(++) = (+)
instance FromInteger Integer where
fromInteger = id
instance ToInteger Integer where
toInteger = id
instance Peano Integer where
zer = 0
suc = Prelude.succ
instance Additive Integer where
zero = 0
(+) = (Prelude.+)
instance Subtractive Integer where
() = (Prelude.-)
instance Multiplicative Integer where
one = 1
(*) = (Prelude.*)
instance TruncateDivisible Integer where
(//) = Prelude.div
instance ToString Integer where
toString = show
instance ToInt Integer where
toInt = Prelude.fromIntegral
instance FromInt Integer where
fromInt = Prelude.fromIntegral
instance ToRational Integer where
toRational = Prelude.fromIntegral
instance ToDouble Integer where
toDouble = Prelude.fromIntegral
instance Integral Integer where
instance ToString Double where toString = show
instance FromString Double where fromString' = Prelude.read . toChars
instance FromInt Double where
fromInt = Prelude.fromIntegral
instance FromInteger Double where
fromInteger = Prelude.fromInteger
instance Peano Double where
zer = 0
suc = (1+)
instance Additive Double where
zero = 0
(+) = (Prelude.+)
instance Subtractive Double where
() = (Prelude.-)
instance Multiplicative Double where
one = 1
(*) = (Prelude.*)
instance Divisible Double where
(/) = (Prelude./)
instance (PartialOrder a, PartialOrder b) => PartialOrder (a, b) where
(a1, b1) <~ (a2, b2) = (a1 <~ a2) /\ (b1 <~ b2)
instance (PartialOrder a, PartialOrder b, PartialOrder c) => PartialOrder (a, b, c) where
(a1, b1, c1) <~ (a2, b2, c2) = (a1 <~ a2) /\ (b1 <~ b2) /\ (c1 <~ c2)
instance (PartialOrder a, PartialOrder b, PartialOrder c, PartialOrder d, PartialOrder e) => PartialOrder (a, b, c, d, e) where
(a1, b1, c1, d1, e1) <~ (a2, b2, c2, d2, e2) = (a1 <~ a2) /\ (b1 <~ b2) /\ (c1 <~ c2) /\ (d1 <~ d2) /\ (e1 <~ e2)
instance (Monoid a, Monoid b) => Monoid (a, b) where
null = (null, null)
(a1, b1) ++ (a2, b2) = (a1 ++ a2, b1 ++ b2)
instance (JoinLattice a, JoinLattice b) => JoinLattice (a, b) where
bot = (bot, bot)
(a1, b1) \/ (a2, b2) = (a1 \/ a2, b1 \/ b2)
instance (JoinLattice a, JoinLattice b, JoinLattice c) => JoinLattice (a, b, c) where
bot = (bot, bot, bot)
(a1, b1, c1) \/ (a2, b2, c2) = (a1 \/ a2, b1 \/ b2, c1 \/ c2)
instance (JoinLattice a, JoinLattice b, JoinLattice c, JoinLattice d, JoinLattice e) => JoinLattice (a, b, c, d, e) where
bot = (bot, bot, bot, bot, bot)
(a1, b1, c1, d1, e1) \/ (a2, b2, c2, d2, e2) = (a1 \/ a2, b1 \/ b2, c1 \/ c2, d1 \/ d2, e1 \/ e2)
instance (JoinLattice a) => Functorial JoinLattice ((,) a) where functorial = W
instance Bifunctorial Eq (,) where
bifunctorial = W
instance Bifunctorial Ord (,) where
bifunctorial = W
swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)
fstL :: Lens (a, b) a
fstL = lens fst $ \ (_,b) -> (,b)
sndL :: Lens (a, b) b
sndL = lens snd $ \ (a,_) -> (a,)
mapFst :: (a -> a') -> (a, b) -> (a', b)
mapFst f (a, b) = (f a, b)
mapSnd :: (b -> b') -> (a, b) -> (a, b')
mapSnd f (a, b) = (a, f b)
data a :+: b = Inl a | Inr b
deriving (Eq, Ord)
instance Unit ((:+:) a) where
unit = Inr
instance Functor ((:+:) a) where
map _ (Inl a) = Inl a
map f (Inr b) = Inr $ f b
instance Product ((:+:) a) where
Inl a <*> _ = Inl a
_ <*> Inl a = Inl a
Inr b <*> Inr c = Inr (b, c)
instance Applicative ((:+:) a) where
Inl a <@> _ = Inl a
_ <@> Inl a = Inl a
Inr f <@> Inr b = Inr $ f b
instance Bind ((:+:) a) where
Inl a >>= _ = Inl a
Inr a >>= k = k a
instance Monad ((:+:) a) where
instance MonadErrorE a ((:+:) a) where
errorE :: ErrorT a ((:+:) a) b -> a :+: b
errorE aME = case runErrorT aME of
Inl a -> Inl a
Inr (Inl a) -> Inl a
Inr (Inr b) -> Inr b
instance MonadErrorI a ((:+:) a) where
errorI :: a :+: b -> ErrorT a ((:+:) a) b
errorI ab = ErrorT $ Inr ab
sumElim :: (a -> c) -> (b -> c) -> a :+: b -> c
sumElim f _ (Inl a) = f a
sumElim _ g (Inr b) = g b
inlL :: Prism (a :+: b) a
inlL = Prism
{ coerce = \ case
Inl a -> Just a
Inr _ -> Nothing
, inject = Inl
}
inrL :: Prism (a :+: b) b
inrL = Prism
{ coerce = \ case
Inl _ -> Nothing
Inr b -> Just b
, inject = Inr
}
mapInl :: (a -> a') -> a :+: b -> a' :+: b
mapInl f (Inl a) = Inl $ f a
mapInl _ (Inr a) = Inr a
mapInr :: (b -> b') -> a :+: b -> a :+: b'
mapInr _ (Inl a) = Inl a
mapInr f (Inr b) = Inr $ f b
newtype (t :.: u) a = Compose { runCompose :: t (u a) }
deriving (Eq, Ord, JoinLattice, PartialOrder)
onComposeIso :: (t (u a) -> t (u b)) -> (t :.: u) a -> (t :.: u) b
onComposeIso f (Compose x) = Compose $ f x
instance (Unit t, Unit u) => Unit (t :.: u) where
unit = Compose . unit . unit
instance (Functor t, Functor u) => Functor (t :.: u) where
map = onComposeIso . map . map
instance (Functorial JoinLattice t, Functorial JoinLattice u) => Functorial JoinLattice (t :.: u) where
functorial :: forall a. (JoinLattice a) => W (JoinLattice ((t :.: u) a))
functorial =
with (functorial :: W (JoinLattice (u a))) $
with (functorial :: W (JoinLattice (t (u a)))) $
W
newtype (t :..: u) m a = Compose2 { runCompose2 :: t (u m) a }
instance Unit Maybe where
unit = Just
instance Functor Maybe where map = mmap
instance Product Maybe where (<*>) = mpair
instance Applicative Maybe where (<@>) = mapply
instance Bind Maybe where
Nothing >>= _ = Nothing
Just x >>= k = k x
instance Monad Maybe where
instance MonadZero Maybe where
mzero = Nothing
instance MonadMaybeI Maybe where
maybeI :: Maybe ~> MaybeT Maybe
maybeI = MaybeT . Just
instance MonadMaybeE Maybe where
maybeE :: MaybeT Maybe ~> Maybe
maybeE aM = case runMaybeT aM of
Nothing -> Nothing
Just aM' -> aM'
instance MonadMaybe Maybe where
instance Monoid (Maybe a) where
null = Nothing
Just x ++ _ = Just x
Nothing ++ aM = aM
nothingL :: Prism (Maybe a) ()
nothingL = Prism
{ coerce = \ case
Nothing -> Just ()
Just _ -> Nothing
, inject = \ () -> Nothing
}
justL :: Prism (Maybe a) a
justL = Prism
{ coerce = id
, inject = Just
}
maybeElim :: b -> (a -> b) -> Maybe a -> b
maybeElim i _ Nothing = i
maybeElim _ f (Just a) = f a
maybeElimOn :: Maybe a -> b -> (a -> b) -> b
maybeElimOn = rotateR maybeElim
whenNothing :: a -> Maybe a -> a
whenNothing x Nothing = x
whenNothing _ (Just x) = x
instance Functorial Eq [] where functorial = W
instance Functorial Ord [] where functorial = W
instance Iterable a [a] where
foldl _ i [] = i
foldl f i (x:xs) = let i' = f i x in i' `seq` foldl f i' xs
foldlk _ i [] = i
foldlk f i (x:xs) = f i x $ \ i' -> i' `seq` foldlk f i' xs
foldr _ i [] = i
foldr f i (x:xs) = f x $ foldr f i xs
instance (Eq a) => Container a [a] where
(?) = flip isElem
instance (Eq k) => Indexed k v [(k, v)] where
[] # _ = Nothing
((k,v):kvs) # k' | k == k' = Just v
| otherwise = kvs # k'
instance (Ord k) => MapLike k v [(k, v)] where
learnMap :: [(k, v)] -> b -> ((Ord k) => b) -> b
learnMap _ _ x = x
mapEmpty :: [(k, v)]
mapEmpty = []
mapIsEmpty :: [(k, v)] -> Bool
mapIsEmpty = isNil
mapInsertWith :: (Ord k) => (v -> v -> v) -> k -> v -> [(k, v)] -> [(k, v)]
mapInsertWith _f _k _v [] = []
mapInsertWith f k v ((k',v'):kvs) | k == k' = (k, f v' v):kvs
| otherwise = (k',v'):mapInsertWith f k v kvs
mapRemove :: [(k, v)] -> Maybe ((k, v), [(k, v)])
mapRemove = uncons
instance Monoid [a] where
null = []
xs ++ ys = foldr (:) ys xs
instance Functorial Monoid [] where functorial = W
instance Unit [] where
unit = (:[])
instance Buildable a [a] where
nil = []
cons = (:)
instance ListLike a [a] where
uncons = coerce consL
instance Bind [] where
[] >>= _ = []
(x:xs) >>= k = k x ++ (xs >>= k)
instance Monad [] where
instance Product [] where
(<*>) = mpair
instance Applicative [] where
(<@>) = mapply
instance MonadZero [] where
mzero = []
instance MonadConcat [] where
(<++>) = (++)
instance Functor [] where
map _ [] = []
map f (x:xs) = f x:map f xs
instance FunctorM [] where
mapM _ [] = return []
mapM f (x:xs) = do
y <- f x
ys <- mapM f xs
return $ y:ys
nilL :: Prism [a] ()
nilL = Prism
{ coerce = \ case
[] -> Just ()
_:_ -> Nothing
, inject = \ () -> []
}
consL :: Prism [a] (a,[a])
consL = Prism
{ coerce = \ case
[] -> Nothing
x:xs' -> Just (x,xs')
, inject = uncurry (:)
}
singleL :: Prism [a] a
singleL = Prism
{ coerce = \ case
[a] -> Just a
_ -> Nothing
, inject = single
}
pluck :: [a] -> [[a]] -> Maybe ([a], [[a]])
pluck [] _ = Nothing
pluck (x:xs) [] = Just ([x], [xs])
pluck (x1:xs1) (xs2:xss) = do
(ys2, xss') <- pluck xs2 xss
return (x1 : ys2, xs1 : xss')
transpose :: [[a]] -> [[a]]
transpose [] = [[]]
transpose (xs:xss) =
case pluck xs xss of
Nothing -> []
Just (ys, xss') -> ys : transpose xss'
data Set a where
EmptySet :: Set a
Set :: (Ord a) => Set.Set a -> Set a
instance Container a (Set a) where
EmptySet ? _ = False
Set s ? e = Set.member e s
instance Iterable a (Set a) where
foldl _ i EmptySet = i
foldl f i (Set s) = Set.foldl' f i s
foldr _ i EmptySet = i
foldr f i (Set s) = Set.foldr' f i s
instance (Ord a) => Buildable a (Set a) where
nil = empty
cons = insert
instance Eq (Set a) where
s1 == s2 = (s1 <= s2) /\ (s2 <= s1)
instance Ord (Set a) where
EmptySet <= _ = True
_ <= EmptySet = False
Set s1 <= Set s2 = s1 <= s2
instance PartialOrder (Set a) where
s1 <~ s2 = iterOn s1 True $ \ e -> (/\) $ s2 ? e
instance SetLike a (Set a) where
learnSet EmptySet i _ = i
learnSet (Set _) _ b = b
empty = EmptySet
isEmpty EmptySet = True
isEmpty (Set s) = Set.null s
insert e EmptySet = Set $ Set.singleton e
insert e (Set s) = Set $ Set.insert e s
remove EmptySet = Nothing
remove (Set s) = map (mapSnd Set) $ Set.minView s
instance Bind Set where
aM >>= k = joins $ map k $ fromSet aM
instance MonadZero Set where
mzero = empty
instance MonadPlus Set where
(<+>) = union
instance MonadConcat Set where
(<++>) = union
instance JoinLattice (Set a) where
bot = empty
(\/) = union
instance Monoid (Set a) where
null = empty
(++) = union
setTranspose :: Set (Set a) -> Set (Set a)
setTranspose aMM = loop $ fromSet aMM
where
loop :: [(Set a)] -> Set (Set a)
loop [] = EmptySet
loop (s:ss) =
learnSet s (loop ss) $
toSet $ map toSet $ transpose $ map fromSet $ s:ss
newtype ListSet a = ListSet { runListSet :: [a] }
deriving (Monoid, Unit, Functor, Product, Applicative, Bind, Monad, Iterable a, Buildable a, Container a)
instance (Ord a) => PartialOrder (ListSet a) where
pcompare = pcompare `on` (toSet . toList)
instance JoinLattice (ListSet a) where
bot = ListSet []
xs1 \/ xs2 = ListSet $ runListSet xs1 ++ runListSet xs2
instance MonadPlus ListSet where
(<+>) = (\/)
data Map k v where
EmptyMap :: Map k v
Map :: (Ord k) => Map.Map k v -> Map k v
instance (Eq k, Eq v) => Eq (Map k v) where
EmptyMap == EmptyMap = True
EmptyMap == Map m = Map.null m
Map m == EmptyMap = Map.null m
Map m1 == Map m2 = m1 == m2
instance (Ord k, Ord v) => Ord (Map k v) where
EmptyMap <= _ = True
_ <= EmptyMap = False
Map m1 <= Map m2 = m1 <= m2
instance (Ord k, PartialOrder v) => PartialOrder (Map k v) where
m1 <~ m2 = iter (\ (k,v) -> (/\) $ maybeElim False (v <~) $ m2 # k) True m1
instance Indexed k v (Map k v) where
EmptyMap # _ = Nothing
Map m # k = Map.lookup k m
instance (Eq v) => Container (k, v) (Map k v) where
m ? (k,v) = case m # k of
Nothing -> False
Just v'
| v == v' -> True
| otherwise -> False
instance Iterable (k, v) (Map k v) where
foldl _ i EmptyMap = i
foldl f i (Map m) = Map.foldlWithKey' (curry . f) i m
foldr _ i EmptyMap = i
foldr f i (Map m) = Map.foldrWithKey' (curry f) i m
instance (Ord k) => Buildable (k, v) (Map k v) where
nil = mapEmpty
cons = uncurry mapInsert
instance MapLike k v (Map k v) where
learnMap EmptyMap i _ = i
learnMap (Map _) _ f = f
mapEmpty = EmptyMap
mapIsEmpty EmptyMap = True
mapIsEmpty (Map m) = Map.null m
mapInsertWith _ k v EmptyMap = Map $ Map.singleton k v
mapInsertWith f k v (Map m) = Map $ Map.insertWith (flip f) k v m
mapRemove EmptyMap = Nothing
mapRemove (Map m) = map (mapSnd Map) $ Map.minViewWithKey m
instance (Eq v, JoinLattice v) => JoinLattice (Map k v) where
bot = mapEmpty
(\/) = mapUnionWith (\/)
data Annotated ann a = Annotated
{ annotation :: ann
, annValue :: a
}
data Stamped a f = Stamped
{ stampedID :: a
, stamped :: f
}
instance (Eq a) => Eq (Stamped a f) where
(==) = (==) `on` stampedID
instance (Ord a) => Ord (Stamped a f) where
compare = compare `on` stampedID
newtype Fix f = Fix { runFix :: f (Fix f) }
data StampedFix a f = StampedFix
{ stampedFixID :: a
, stampedFix :: f (StampedFix a f)
}
stripStampedFix :: (Functor f) => StampedFix a f -> Fix f
stripStampedFix (StampedFix _ f) = Fix $ map stripStampedFix f
instance (Eq a) => Eq (StampedFix a f) where
(==) = (==) `on` stampedFixID
instance (Ord a) => Ord (StampedFix a f) where
compare = compare `on` stampedFixID
instance (PartialOrder a) => PartialOrder (StampedFix a f) where
pcompare = pcompare `on` stampedFixID
instance Unit IO where
unit = Prelude.return
instance Functor IO where
map = mmap
instance Applicative IO where
(<@>) = mapply
instance Product IO where
(<*>) = mpair
instance Bind IO where
(>>=) = (Prelude.>>=)
instance Monad IO where
instance MonadIO IO where
liftIO = id
instance MonadErrorE String IO where
errorE :: ErrorT String IO ~> IO
errorE = sumElim (Prelude.fail . toChars) return *. runErrorT
print :: String -> IO ()
print = Prelude.putStrLn . toChars
instance Unit Q where
unit = Prelude.return
instance Functor Q where
map = mmap
instance Applicative Q where
(<@>) = mapply
instance Product Q where
(<*>) = mpair
instance Bind Q where
(>>=) = (Prelude.>>=)
instance Monad Q where
instance MonadQ Q where
liftQ = id
instance MonadZero Q where
mzero = Prelude.fail $ toChars "mzero"
instance MonadErrorE String Q where
errorE :: ErrorT String Q ~> Q
errorE = sumElim (Prelude.fail . toChars) return *. runErrorT