Code cleanup; coding style

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

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.: which is based on the work of Oleg Kiselyov et al.:
* [Freer Monads, More Extensible Effects](http://okmij.org/ftp/Haskell/extensible/more.pdf) * [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) * [Extensible Effects](http://okmij.org/ftp/Haskell/extensible/exteff.pdf)
Much of the implementation is a repackaging and cleaning up of the reference Much of the implementation is a repackaging and cleaning up of the reference

View File

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

View File

@ -1,75 +1,73 @@
{-# LANGUAGE GADTs #-} {-# 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 -- left-leaning
data FTCQueue m a b where data FTCQueue m a b where
Leaf :: (a -> m 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 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 :: (a -> m b) -> FTCQueue m a b
tsingleton = Leaf 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 (|>) :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
t |> r = Node t (Leaf r) t |> r = Node t (Leaf r)
{-# INLINE (|>) #-}
{-# INLINE snoc #-}
-- | An alias for '(|>)' -- | An alias for '(|>)'
snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b snoc :: FTCQueue m a x -> (x -> m b) -> FTCQueue m a b
snoc = (|>) 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 (><) :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
t1 >< t2 = Node t1 t2 t1 >< t2 = Node t1 t2
{-# INLINE (><) #-}
{-# INLINE append #-}
-- | An alias for '(><)' -- | An alias for '(><)'
append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b append :: FTCQueue m a x -> FTCQueue m x b -> FTCQueue m a b
append = (><) append = (><)
{-# INLINE append #-}
-- | Left view deconstruction data structure -- | Left view deconstruction data structure.
data ViewL m a b where data ViewL m a b where
TOne :: (a -> m b) -> ViewL m a b TOne :: (a -> m b) -> ViewL m a b
(:|) :: (a -> m x) -> FTCQueue m x 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 :: FTCQueue m a b -> ViewL m a b
tviewl (Leaf r) = TOne r tviewl (Leaf r) = TOne r
tviewl (Node t1 t2) = go t1 t2 tviewl (Node t1 t2) = go t1 t2

View File

@ -1,52 +1,69 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# 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
{-| -- * Open Union Operations
Module : Data.Open.Union , decomp
Description : Open unions (type-indexed co-products) for extensible effects. , weaken
Copyright : Allele Dev 2016 , extract
License : BSD-3
Maintainer : allele.dev@gmail.com
Stability : experimental
Portability : POSIX
This implementation relies on _closed_ type families added to GHC -- * Open Union Membership Constraints
7.8. It has NO overlapping instances and NO Typeable. Alas, the , Member(..)
absence of Typeable means the projections and injections generally , Members
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 -- * Re-exported
nested Either data type. , Functor(..)
)
where
Using <http://okmij.org/ftp/Haskell/extensible/OpenUnion41.hs> as a #if MIN_VERSION_base(4,9,0)
starting point. 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 import Data.Open.Union.Internal
( Member(inj, prj)
, Union
, decomp
, extract
, weaken
)
--------------------------------------------------------------------------------
-- Interface --
--------------------------------------------------------------------------------
type family Members m r :: Constraint where type family Members m r :: Constraint where
Members (t ': c) r = (Member t r, Members c r) Members (t ': c) r = (Member t r, Members c r)
Members '[] r = () Members '[] r = ()

View File

@ -1,21 +1,41 @@
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds, PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# 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 module Data.Open.Union.Internal where
data Union (r :: [ * -> * ]) v where data Union (r :: [ * -> * ]) v where
UNow :: t v -> Union (t ': r) v UNow :: t v -> Union (t ': r) v
UNext :: Union (t ': r) v -> Union (any ': 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 data Nat = S Nat | Z
-- | Represents position @(n :: 'Nat')@ in a type list.
data P (n :: Nat) = P 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 class Member' t r (n :: Nat) where
inj' :: P n -> t v -> Union r v inj' :: P n -> t v -> Union r v
prj' :: P n -> Union r v -> Maybe (t v) prj' :: P n -> Union r v -> Maybe (t v)
@ -30,10 +50,9 @@ instance (r ~ (t' ': r' ': rs'), Member' t (r' ': rs') n) => Member' t r ('S n)
prj' _ (UNow _) = Nothing prj' _ (UNow _) = Nothing
prj' _ (UNext x) = prj' (P::P n) x prj' _ (UNext x) = prj' (P::P n) x
-- Find an index of an element in a `list' -- | Find an index of an element in a type list. The element must exist.
-- The element must exist --
-- This closed type family disambiguates otherwise overlapping -- This closed type family disambiguates otherwise overlapping instances.
-- instances
type family FindElem (t :: * -> *) r :: Nat where type family FindElem (t :: * -> *) r :: Nat where
FindElem t (t ': r) = 'Z FindElem t (t ': r) = 'Z
FindElem t (any ': r) = 'S (FindElem t r) FindElem t (any ': r) = 'S (FindElem t r)
@ -52,30 +71,33 @@ type family Tail (xs :: [x]) :: [x] where
-- Interface -- -- Interface --
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
{-# INLINE decomp #-}
decomp :: Union (t ': r) v -> Either (Union r v) (t v) decomp :: Union (t ': r) v -> Either (Union r v) (t v)
decomp (UNow x) = Right x decomp (UNow x) = Right x
decomp (UNext v) = Left v decomp (UNext v) = Left v
{-# INLINE decomp #-}
{-# INLINE weaken #-}
weaken :: Union (t ': r) w -> Union (any ': t ': r) w weaken :: Union (t ': r) w -> Union (any ': t ': r) w
weaken = UNext weaken = UNext
{-# INLINE weaken #-}
{-# INLINE extract #-}
extract :: Union '[t] v -> t v extract :: Union '[t] v -> t v
extract (UNow x) = x extract (UNow x) = x
{-# INLINE extract #-}
class (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r where class (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r where
inj :: t v -> Union r v inj :: t v -> Union r v
prj :: Union r v -> Maybe (t v) prj :: Union r v -> Maybe (t v)
instance (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r where instance (Member' t r (FindElem t r), r ~ (Head r ': Tail r)) => Member t r
where
inj = inj' (P :: P (FindElem t r)) inj = inj' (P :: P (FindElem t r))
prj = prj' (P :: P (FindElem t r)) prj = prj' (P :: P (FindElem t r))
instance (Functor f) => Functor (Union '[f]) where instance (Functor f) => Functor (Union '[f]) where
fmap f = inj . fmap f . extract fmap f = inj . fmap f . extract
instance (Functor f1, Functor (Union (f2 ': fs))) =>
Functor (Union (f1 ': f2 ': fs)) where 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 = either (weaken . fmap f) (inj . fmap f) . decomp