{-# LANGUAGE CPP, Rank2Types #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}
-- Unfortunately GHC < 6.10 needs -fglasgow-exts in order to actually
-- parse RULES (see -ddump-rules); the -frewrite-rules flag only
-- enables the application of rules, instead of doing what we want.
-- Apparently this is fixed in 6.10.
--
-- http://hackage.haskell.org/trac/ghc/ticket/2213
-- http://www.mail-archive.com/glasgow-haskell-users@haskell.org/msg14313.html
{-# OPTIONS_GHC -O2 -fglasgow-exts -frewrite-rules #-}
----------------------------------------------------------------
-- ~ 2012.07.19
-- |
-- Module : Data.List.Scott
-- Copyright : Copyright (c) 2010--2015 wren gayle romano
-- License : BSD
-- Maintainer : wren@community.haskell.org
-- Stability : experimental
-- Portability : semi-portable (CPP, Rank2Types)
--
-- This module defines the Scott encoding of lists. While Church
-- encodings are more popular, Scott encodings offer a number of
-- benefits and deserve to be more widely used. In particular, Scott
-- encodings are /exact/; meaning that all operations on the encoding
-- can be performed with the same complexity as on the data type
-- (with a larger or smaller constant factor, depending on how
-- efficiently the compiler handles functions vs structures). And
-- since the conversion from the Scott encoding to case-elimination
-- form is immediate, using Scott encodings should facilitate fusion
-- without special support for optimizing away allocations that
-- will be immediately case-analyzed (only support for fusing and
-- partially evaluating functions is necessary, and should already
-- be available).
--
-- Thus,
-- Scott encodings provide an alternative to having case analysis
-- built into the language. On the other hand, Scott encodings
-- require the language to support term- and type-level recursive
-- bindings, whereas Church encodings do not. Also, because they
-- are inexact, Church encodings can optimize certain operations
-- (like concatenation) but must pessimize other operations (like
-- case analysis, 'tail', etc).
----------------------------------------------------------------
module Data.List.Scott where
import Prelude hiding (mapM, sequence, foldr, foldr1, foldl, foldl1)
import qualified Prelude
import Data.Or
import Data.Foldable
import Data.Traversable
import Control.Applicative
import Data.Monoid
#ifdef __GLASGOW_HASKELL__
import GHC.Exts (build)
#endif
----------------------------------------------------------------
----------------------------------------------------------------
-- | A Scott-encoded list. The Scott encoding of a datatype is its
-- case-analysis elimination.
newtype ScottList a =
SL { caseSL :: forall r. r -> (a -> ScottList a -> r) -> r }
-- | /O(1)/. The empty list.
nilSL :: ScottList a
nilSL = SL const
-- | /O(1)/. Add an element to the front of the list.
consSL :: a -> ScottList a -> ScottList a
consSL x xs = SL $ \_n c -> c x xs
-- | /O(n)/. The right fold eliminator.
foldrSL :: (a -> b -> b) -> b -> ScottList a -> b
foldrSL c n xs = caseSL xs n (\x xs' -> c x (foldrSL c n xs'))
{-# INLINE [0] foldrSL #-}
-- | /O(n)/. Convert to plain lists.
scottToList :: ScottList a -> [a]
#ifdef __GLASGOW_HASKELL__
scottToList xs = build (\c n -> foldrSL c n xs)
#else
scottToList = foldrSL (:) []
#endif
-- | /O(n)/. Convert from plain lists.
scottFromList :: [a] -> ScottList a
scottFromList = Prelude.foldr consSL nilSL
----------------------------------------------------------------
instance (Show a) => Show (ScottList a) where
show xs = "SL " ++ show (scottToList xs)
instance (Eq a) => Eq (ScottList a) where
xs == ys = scottToList xs == scottToList ys
instance (Ord a) => Ord (ScottList a) where
-- TODO: implement directly via bifoldlSL/bifoldl'SL
xs `compare` ys = scottToList xs `compare` scottToList ys
instance Functor ScottList where
-- TODO: Is there a more efficient implementation?
fmap f = foldrSL (consSL . f) nilSL
instance Foldable ScottList where
foldr f z xs = caseSL xs z (\x xs' -> f x (foldr f z xs'))
instance Traversable ScottList where
traverse f xs =
caseSL xs
(pure nilSL)
(\x xs' -> consSL <$> f x <*> traverse f xs')
----------------------------------------------------------------
-- | /O(1)/. Return the first element in a stream, if any exists.
headSL :: ScottList a -> Maybe a
headSL xs = caseSL xs Nothing (\hd _ -> Just hd)
-- | /O(1)/. Drop the first element in a stream, if any exists.
tailSL :: ScottList a -> Maybe (ScottList a)
tailSL xs = caseSL xs Nothing (\_ tl -> Just tl)
-- | /O(1)/. Drop the first element in a stream.
drop1SL :: ScottList a -> ScottList a
drop1SL xs = caseSL xs nilSL (\_ tl -> tl)
-- | /O(n)/. The left fold eliminator.
foldlSL :: (b -> a -> b) -> b -> ScottList a -> b
foldlSL s n xs = caseSL xs n (\x xs' -> foldlSL s (s n x) xs')
-- | /O(n)/. The strict left fold eliminator.
foldl'SL :: (b -> a -> b) -> b -> ScottList a -> b
foldl'SL s n xs = caseSL xs n (\x xs' -> (foldl'SL s $! s n x) xs')
-- | /O(n)/. Append two lists.
appendSL :: ScottList a -> ScottList a -> ScottList a
appendSL xs ys = foldrSL consSL ys xs
-- TODO: Is there a more efficient implementation?
zipSL :: ScottList a -> ScottList b -> ScottList (a,b)
zipSL = zipWithSL (,)
zipWithSL :: (a -> b -> c) -> ScottList a -> ScottList b -> ScottList c
zipWithSL f = bifoldrSL phi nilSL
where
phi (Both x y) zs = consSL (f x y) zs
phi _ _ = nilSL
bifoldrSL :: (Or a b -> c -> c) -> c -> ScottList a -> ScottList b -> c
bifoldrSL k z = go
where
go xs ys =
caseSL xs
(caseSL ys
z
(\y ys' -> k (Snd y) (foldrSL (k . Snd) z ys')))
(\x xs' ->
(caseSL ys
(k (Fst x) (foldrSL (k . Fst) z xs'))
(\y ys' -> k (Both x y) (go xs' ys'))))
bifoldlSL :: (c -> Or a b -> c) -> c -> ScottList a -> ScottList b -> c
bifoldlSL k z xs ys =
caseSL xs
(caseSL ys
z
(\y ys' -> foldlSL (\z' y' -> k z' $ Snd y') (k z $ Snd y) ys'))
(\x xs' ->
(caseSL ys
(foldlSL (\z' x' -> k z' $ Fst x') (k z $ Fst x) xs')
(\y ys' -> bifoldlSL k (k z $ Both x y) xs' ys')))
----------------------------------------------------------------
----------------------------------------------------------- fin.