From 751199afa974f4ad234640124aa4cf2b15b86b57 Mon Sep 17 00:00:00 2001 From: Peter Trsko Date: Mon, 30 Jan 2017 18:32:51 +0100 Subject: [PATCH] Code cleanup; coding style --- README.md | 1 + freer-effects.cabal | 1 + src/Data/FTCQueue.hs | 102 ++++++++++++++++---------------- src/Data/Open/Union.hs | 99 ++++++++++++++++++------------- src/Data/Open/Union/Internal.hs | 92 +++++++++++++++++----------- 5 files changed, 167 insertions(+), 128 deletions(-) diff --git a/README.md b/README.md index 119b693..b17ace8 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/freer-effects.cabal b/freer-effects.cabal index 5d4bfd9..48137d7 100644 --- a/freer-effects.cabal +++ b/freer-effects.cabal @@ -6,6 +6,7 @@ description: Oleg Kiselyov et al.: . * + * * . The key features are: diff --git a/src/Data/FTCQueue.hs b/src/Data/FTCQueue.hs index 05490da..07456d1 100644 --- a/src/Data/FTCQueue.hs +++ b/src/Data/FTCQueue.hs @@ -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 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 as a starting +-- point. +-- +-- A minimal version of FTCQueue from "Reflection w/o Remorse": +-- +-- * Research: +-- * (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) diff --git a/src/Data/Open/Union.hs b/src/Data/Open/Union.hs index e2b1f95..ac1da5e 100644 --- a/src/Data/Open/Union.hs +++ b/src/Data/Open/Union.hs @@ -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 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 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 = () diff --git a/src/Data/Open/Union/Internal.hs b/src/Data/Open/Union/Internal.hs index f187412..8c50eb1 100644 --- a/src/Data/Open/Union/Internal.hs +++ b/src/Data/Open/Union/Internal.hs @@ -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