lexi-lambda/freer-simple
1
1
Fork 0
mirror of https://github.com/lexi-lambda/freer-simple.git synced 2024-12-24 22:54:27 +03:00
Code Issues Projects Releases Wiki Activity

Code cleanup; coding style

Browse Source
This commit is contained in:
Peter Trsko 2017-01-30 18:32:51 +01:00 committed by Peter Trško
parent 4ce0bfb6be
commit 751199afa9
5 changed files with 167 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
README.md
View File

@ -14,6 +14,7 @@ Library `freer-effects` is an implementation of effect system for Haskell,
which is based on the work of Oleg Kiselyov et al.:
* [Freer Monads, More Extensible Effects](http://okmij.org/ftp/Haskell/extensible/more.pdf)
* [Reflection without Remorse](http://okmij.org/ftp/Haskell/zseq.pdf)
* [Extensible Effects](http://okmij.org/ftp/Haskell/extensible/exteff.pdf)
Much of the implementation is a repackaging and cleaning up of the reference

1
freer-effects.cabal
View File

@ -6,6 +6,7 @@ description:
Oleg Kiselyov et al.:
.
* <http://okmij.org/ftp/Haskell/extensible/more.pdf Freer Monads, More Extensible Effects>
* <http://okmij.org/ftp/Haskell/zseq.pdf Reflection without Remorse>
* <http://okmij.org/ftp/Haskell/extensible/exteff.pdf Extensible Effects>
.
The key features are:

102
src/Data/FTCQueue.hs
View File

@ -1,79 +1,77 @@
{-# LANGUAGE GADTs #-}
{-|
Module : Data.FTCQueue
Description : Fast type-aligned queue optimized to effectful functions.
Copyright : Allele Dev 2016
License : BSD-3
Maintainer : allele.dev@gmail.com
Stability : experimental
Portability : POSIX
* Constant-time append/(><) and snoc/(|>)
* Average constant-time viewL (left-edge deconstruction)
Using <http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs> as a
starting point.
A minimal version of FTCQueue from "Reflection w/o Remorse":
* research: http://okmij.org/ftp/Haskell/Reflection.html
* type-aligned(FTCQueue): https://hackage.haskell.org/package/type-aligned
-}
module Data.FTCQueue (
FTCQueue,
tsingleton,
(|>),
snoc,
(><),
append,
ViewL(..),
tviewl
) where
-- |
-- Non-empty tree. Deconstruction operations make it more and more
-- Module: Data.FTCQueue
-- Description: Fast type-aligned queue optimized to effectful functions.
-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
-- License: BSD3
-- Maintainer: ixcom-core@ixperta.com
-- Stability: experimental
-- Portability: POSIX
--
-- * Constant-time append\/('><') and snoc\/('|>')
-- * Average constant-time 'viewL' (left-edge deconstruction).
--
-- Using <http://okmij.org/ftp/Haskell/extensible/FTCQueue1.hs> as a starting
-- point.
--
-- A minimal version of FTCQueue from "Reflection w/o Remorse":
--
-- * Research: <http://okmij.org/ftp/Haskell/Reflection.html>
-- * <https://hackage.haskell.org/package/type-aligned type-aligned> (FTCQueue)
module Data.FTCQueue
( FTCQueue
, tsingleton
, (|>)
, snoc
, (><)
, append
, ViewL(..)
, tviewl
)
where
-- | Non-empty tree. Deconstruction operations make it more and more
-- left-leaning
data FTCQueue m a b where
Leaf :: (a -> m b) -> FTCQueue m a b
Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
Leaf :: (a -> m b) -> FTCQueue m a b
Node :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
{-# INLINE tsingleton #-}
-- | Build a leaf from a single operation [O(1)]
-- | Build a leaf from a single operation. [O(1)]
tsingleton :: (a -> m b) -> FTCQueue m a b
tsingleton = Leaf
{-# INLINE tsingleton #-}
{-# INLINE (|>) #-}
-- | Append an operation to the right of the tree [O(1)]
-- | Append an operation to the right of the tree. [O(1)]
(|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
t |> r = Node t (Leaf r)
{-# INLINE (|>) #-}
{-# INLINE snoc #-}
-- | An alias for '(|>)'
snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
snoc = (|>)
{-# INLINE snoc #-}
{-# INLINE (><) #-}
-- | Append two trees of operations [O(1)]
-- | Append two trees of operations. [O(1)]
(><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
t1 >< t2 = Node t1 t2
{-# INLINE (><) #-}
{-# INLINE append #-}
-- | An alias for '(><)'
append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
append = (><)
{-# INLINE append #-}
-- | Left view deconstruction data structure
-- | Left view deconstruction data structure.
data ViewL m a b where
TOne :: (a -> m b) -> ViewL m a b
(:|) :: (a -> m x) -> FTCQueue m x b -> ViewL m a b
TOne :: (a -> m b) -> ViewL m a b
(:|) :: (a -> m x) -> FTCQueue m x b -> ViewL m a b
-- | Left view deconstruction [average O(1)]
-- | Left view deconstruction. [average O(1)]
tviewl :: FTCQueue m a b -> ViewL m a b
tviewl (Leaf r) = TOne r
tviewl (Node t1 t2) = go t1 t2
where
go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
go (Leaf r) tr = r :| tr
go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)
where
go :: FTCQueue m a x -> FTCQueue m x b -> ViewL m a b
go (Leaf r) tr = r :| tr
go (Node tl1 tl2) tr = go tl1 (Node tl2 tr)

99
src/Data/Open/Union.hs
View File

@ -1,52 +1,69 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module: Data.Open.Union
-- Description: Open unions (type-indexed co-products) for extensible effects.
-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
-- License: BSD3
-- Maintainer: ixcom-core@ixperta.com
-- Stability: experimental
-- Portability: POSIX
--
-- This implementation relies on _closed_ type families added to GHC 7.8. It
-- has NO overlapping instances and NO @Typeable@. Alas, the absence of
-- @Typeable@ means the projections and injections generally take linear time.
-- The code illustrate how to use closed type families to disambiguate
-- otherwise overlapping instances.
--
-- The data constructors of 'Union' are not exported. Essentially, the nested
-- 'Either' data type.
--
-- Using <http://okmij.org/ftp/Haskell/extensible/OpenUnion41.hs> as a starting
-- point.
module Data.Open.Union
(
-- * Open Union
Union
{-|
Module : Data.Open.Union
Description : Open unions (type-indexed co-products) for extensible effects.
Copyright : Allele Dev 2016
License : BSD-3
Maintainer : allele.dev@gmail.com
Stability : experimental
Portability : POSIX
-- * Open Union Operations
, decomp
, weaken
, extract
This implementation relies on _closed_ type families added to GHC
7.8. It has NO overlapping instances and NO Typeable. Alas, the
absence of Typeable means the projections and injections generally
take linear time. The code illustrate how to use closed type families
to disambiguate otherwise overlapping instances.
-- * Open Union Membership Constraints
, Member(..)
, Members
The data constructors of Union are not exported. Essentially, the
nested Either data type.
-- * Re-exported
, Functor(..)
)
where
Using <http://okmij.org/ftp/Haskell/extensible/OpenUnion41.hs> as a
starting point.
#if MIN_VERSION_base(4,9,0)
import Data.Kind (Constraint)
#else
import GHC.Exts (Constraint)
#endif
-}
module Data.Open.Union (
module Data.Open.Union,
Union,
Member(..),
decomp,
weaken,
extract,
Functor(..)
) where
import GHC.Exts
import Data.Open.Union.Internal
( Member(inj, prj)
, Union
, decomp
, extract
, weaken
)
--------------------------------------------------------------------------------
-- Interface --
--------------------------------------------------------------------------------
type family Members m r :: Constraint where
Members (t ': c) r = (Member t r, Members c r)
Members '[] r = ()
Members (t ': c) r = (Member t r, Members c r)
Members '[] r = ()

92
src/Data/Open/Union/Internal.hs
View File

@ -1,46 +1,65 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module: Control.Monad.Freer
-- Description: Open unions (type-indexed co-products) for extensible effects.
--
-- Copyright: (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.
-- License: BSD3
-- Maintainer: ixcom-core@ixperta.com
-- Stability: experimental
-- Portability: POSIX
--
-- These are internal definitions and should be used with caution. There are no
-- guarantees that the API of this module will be preserved between minor
-- versions of this package.
module Data.Open.Union.Internal where
data Union (r :: [ * -> * ]) v where
UNow :: t v -> Union (t ': r) v
UNext :: Union (t ': r) v -> Union (any ': t ': r) v
-- | Type level naturals are used to disambiguate otherwise overlapping
-- instances when iterating through a type list.
data Nat = S Nat | Z
-- | Represents position @(n :: 'Nat')@ in a type list.
data P (n :: Nat) = P
-- injecting/projecting at a specified position P n
-- | Injecting\/projecting at a specified position @P n@.
class Member' t r (n :: Nat) where
inj' :: P n -> t v -> Union r v
prj' :: P n -> Union r v -> Maybe (t v)
inj' :: P n -> t v -> Union r v
prj' :: P n -> Union r v -> Maybe (t v)
instance (r ~ (t ': r')) => Member' t r 'Z where
inj' _ = UNow
prj' _ (UNow x) = Just x
prj' _ _ = Nothing
inj' _ = UNow
prj' _ (UNow x) = Just x
prj' _ _ = Nothing
instance (r ~ (t' ': r' ': rs'), Member' t (r' ': rs') n) => Member' t r ('S n) where
inj' _ = UNext . inj' (P::P n)
prj' _ (UNow _) = Nothing
prj' _ (UNext x) = prj' (P::P n) x
inj' _ = UNext . inj' (P::P n)
prj' _ (UNow _) = Nothing
prj' _ (UNext x) = prj' (P::P n) x
-- Find an index of an element in a `list'
-- The element must exist
-- This closed type family disambiguates otherwise overlapping
-- instances
-- | Find an index of an element in a type list. The element must exist.
--
-- This closed type family disambiguates otherwise overlapping instances.
type family FindElem (t :: * -> *) r :: Nat where
FindElem t (t ': r) = 'Z
FindElem t (any ': r) = 'S (FindElem t r)
FindElem t (t ': r) = 'Z
FindElem t (any ': r) = 'S (FindElem t r)
type family EQU (a :: k) (b :: k) :: Bool where
EQU a a = 'True
EQU a b = 'False
EQU a a = 'True
EQU a b = 'False
type family Head (xs :: [x]) :: x where
Head (x ': xs) = x
@ -52,30 +71,33 @@ type family Tail (xs :: [x]) :: [x] where
-- Interface --
--------------------------------------------------------------------------------
{-# INLINE decomp #-}
decomp :: Union (t ': r) v -> Either (Union r v) (t v)
decomp (UNow x) = Right x
decomp (UNext v) = Left v
{-# INLINE decomp #-}
{-# INLINE weaken #-}
weaken :: Union (t ': r) w -> Union (any ': t ': r) w
weaken = UNext
{-# INLINE weaken #-}
{-# INLINE extract #-}
extract :: Union '[t] v -> t v
extract (UNow x) = x
{-# INLINE extract #-}
class (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r where
inj :: t v -> Union r v
prj :: Union r v -> Maybe (t v)
inj :: t v -> Union r v
prj :: Union r v -> Maybe (t v)
instance (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r where
inj = inj' (P :: P (FindElem t r))
prj = prj' (P :: P (FindElem t r))
instance (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r
where
inj = inj' (P :: P (FindElem t r))
prj = prj' (P :: P (FindElem t r))
instance (Functor f) => Functor (Union '[f]) where
fmap f = inj . fmap f . extract
instance (Functor f1, Functor (Union (f2 ': fs))) =>
Functor (Union (f1 ': f2 ': fs)) where
fmap f = either (weaken . fmap f) (inj . fmap f) . decomp
fmap f = inj . fmap f . extract
instance
( Functor f1, Functor (Union (f2 ': fs))
) => Functor (Union (f1 ': f2 ': fs))
where
fmap f = either (weaken . fmap f) (inj . fmap f) . decomp