adaptive-containers 0.2.1 → 0.3

raw patch · 3 files changed

+386/−2 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Adaptive/Maybe.hs +242/−0
• adaptive-containers.cabal +3/−2
• scripts/derive-maybe.hs +141/−0

@@ -0,0 +1,242 @@+{-# LANGUAGE TypeFamilies          #-}++-- |+-- Module      : Data.Adaptive.Maybe+-- Copyright   : (c) Don Stewart 2009+-- License     : BSD-style+-- Maintainer  : dons@galois.com+-- Stability   : experimental+-- +-- Self optimzing sum types.+--+-- This library statically adapts the polymorphic container+-- representation of Maybe to specific, more efficient representations,+-- when instantiated with particular monomorphic types. It does this via+-- an associated more efficient data type for each pair of elements you+-- wish to store in your container.+--+-- That is, instead of representing 'Maybe Int' as:+--+-- >           Just+-- >             | +-- >           I# 3#+--+-- A self-optimizing pair will unpack the constructors, yielding this+-- data representation:+--+-- >       JustInt 3#+--+-- Saving an indirection. The resulting structure should be both more+-- time and space efficient than the generic polymorphic container it is+-- derived from.+--+-- Self adaptive polymorphic containers are able to unpack their+-- components, something not possible with, for example, strict+-- polymorphic containers.+--++module Data.Adaptive.Maybe where++import Prelude hiding (Maybe(..), maybe)+import Data.Word+import Data.Int++class AdaptMaybe a where++    data Maybe a++    -- construction+    just    :: a -> Maybe a+    {-# INLINE just #-}++    nothing :: Maybe a+    {-# INLINE nothing #-}++    -- | The 'isJust' function returns 'True' iff its argument is of the+    -- form @Just _@.+    isJust  :: Maybe a -> Bool+    {-# INLINE isJust #-}++    -- elimination+    maybe   :: b -> (a -> b) -> Maybe a -> b+    {-# INLINE maybe #-}++------------------------------------------------------------------------++-- | The 'isNothing' function returns 'True' iff its argument is 'Nothing'.+isNothing :: AdaptMaybe a => Maybe a -> Bool+isNothing = not . isJust+{-# INLINE isNothing #-}++-- | The 'fromJust' function extracts the element out of a 'Just' and+-- throws an error if its argument is 'Nothing'.+fromJust :: AdaptMaybe a => Maybe a -> a+fromJust = maybe (error "Data.Adaptive.Maybe.fromJust: Nothing") id+{-# INLINE fromJust #-}++-- | The 'fromMaybe' function takes a default value and and 'Maybe'+-- value.  If the 'Maybe' is 'Nothing', it returns the default values;+-- otherwise, it returns the value contained in the 'Maybe'.+fromMaybe :: AdaptMaybe a => a -> Maybe a -> a+fromMaybe d = maybe d id+{-# INLINE fromMaybe #-}++-- | The 'maybeToList' function returns an empty list when given+-- 'Nothing' or a singleton list when not given 'Nothing'.+maybeToList :: AdaptMaybe a => Maybe a -> [a]+maybeToList = maybe [] (:[])+{-# INLINE maybeToList #-}++-- | The 'listToMaybe' function returns 'Nothing' on an empty list+-- or @'Just' a@ where @a@ is the first element of the list.+listToMaybe :: AdaptMaybe a => [a] -> Maybe a+listToMaybe []        =  nothing+listToMaybe (a:_)     =  just a+{-# INLINE listToMaybe #-}++-- | The 'catMaybes' function takes a list of 'Maybe's and returns+-- a list of all the 'Just' values. +catMaybes :: AdaptMaybe a => [Maybe a] -> [a]+catMaybes ls = [ fromJust x | x <- ls, isJust x ]++-- | The 'mapMaybe' function is a version of 'map' which can throw+-- out elements.  In particular, the functional argument returns+-- something of type @'Maybe' b@.  If this is 'Nothing', no element+-- is added on to the result list.  If it just @'Just' b@, then @b@ is+-- included in the result list.+mapMaybe :: AdaptMaybe b => (a -> Maybe b) -> [a] -> [b]+mapMaybe _ []     = []+mapMaybe f (x:xs) = maybe rs (:rs) (f x)+ where+    rs = mapMaybe f xs++------------------------------------------------------------------------+-- Generated by scripts/derive-maybe.hs+-- Instances+--++instance AdaptMaybe Int where+    data Maybe Int = NothingInt | JustInt {-# UNPACK #-}!Int+    just = JustInt+    nothing = NothingInt+    isJust (JustInt _) = True+    isJust _ = False+    maybe n _ NothingInt = n+    maybe _ f (JustInt x) = f x++instance AdaptMaybe Integer where+    data Maybe Integer = NothingInteger | JustInteger {-# UNPACK #-}!Integer+    just = JustInteger+    nothing = NothingInteger+    isJust (JustInteger _) = True+    isJust _ = False+    maybe n _ NothingInteger = n+    maybe _ f (JustInteger x) = f x++instance AdaptMaybe Int8 where+    data Maybe Int8 = NothingInt8 | JustInt8 {-# UNPACK #-}!Int8+    just = JustInt8+    nothing = NothingInt8+    isJust (JustInt8 _) = True+    isJust _ = False+    maybe n _ NothingInt8 = n+    maybe _ f (JustInt8 x) = f x++instance AdaptMaybe Int16 where+    data Maybe Int16 = NothingInt16 | JustInt16 {-# UNPACK #-}!Int16+    just = JustInt16+    nothing = NothingInt16+    isJust (JustInt16 _) = True+    isJust _ = False+    maybe n _ NothingInt16 = n+    maybe _ f (JustInt16 x) = f x++instance AdaptMaybe Int32 where+    data Maybe Int32 = NothingInt32 | JustInt32 {-# UNPACK #-}!Int32+    just = JustInt32+    nothing = NothingInt32+    isJust (JustInt32 _) = True+    isJust _ = False+    maybe n _ NothingInt32 = n+    maybe _ f (JustInt32 x) = f x++instance AdaptMaybe Int64 where+    data Maybe Int64 = NothingInt64 | JustInt64 {-# UNPACK #-}!Int64+    just = JustInt64+    nothing = NothingInt64+    isJust (JustInt64 _) = True+    isJust _ = False+    maybe n _ NothingInt64 = n+    maybe _ f (JustInt64 x) = f x++instance AdaptMaybe Word where+    data Maybe Word = NothingWord | JustWord {-# UNPACK #-}!Word+    just = JustWord+    nothing = NothingWord+    isJust (JustWord _) = True+    isJust _ = False+    maybe n _ NothingWord = n+    maybe _ f (JustWord x) = f x++instance AdaptMaybe Word8 where+    data Maybe Word8 = NothingWord8 | JustWord8 {-# UNPACK #-}!Word8+    just = JustWord8+    nothing = NothingWord8+    isJust (JustWord8 _) = True+    isJust _ = False+    maybe n _ NothingWord8 = n+    maybe _ f (JustWord8 x) = f x++instance AdaptMaybe Word16 where+    data Maybe Word16 = NothingWord16 | JustWord16 {-# UNPACK #-}!Word16+    just = JustWord16+    nothing = NothingWord16+    isJust (JustWord16 _) = True+    isJust _ = False+    maybe n _ NothingWord16 = n+    maybe _ f (JustWord16 x) = f x++instance AdaptMaybe Word32 where+    data Maybe Word32 = NothingWord32 | JustWord32 {-# UNPACK #-}!Word32+    just = JustWord32+    nothing = NothingWord32+    isJust (JustWord32 _) = True+    isJust _ = False+    maybe n _ NothingWord32 = n+    maybe _ f (JustWord32 x) = f x++instance AdaptMaybe Word64 where+    data Maybe Word64 = NothingWord64 | JustWord64 {-# UNPACK #-}!Word64+    just = JustWord64+    nothing = NothingWord64+    isJust (JustWord64 _) = True+    isJust _ = False+    maybe n _ NothingWord64 = n+    maybe _ f (JustWord64 x) = f x++instance AdaptMaybe Double where+    data Maybe Double = NothingDouble | JustDouble {-# UNPACK #-}!Double+    just = JustDouble+    nothing = NothingDouble+    isJust (JustDouble _) = True+    isJust _ = False+    maybe n _ NothingDouble = n+    maybe _ f (JustDouble x) = f x++instance AdaptMaybe Float where+    data Maybe Float = NothingFloat | JustFloat {-# UNPACK #-}!Float+    just = JustFloat+    nothing = NothingFloat+    isJust (JustFloat _) = True+    isJust _ = False+    maybe n _ NothingFloat = n+    maybe _ f (JustFloat x) = f x++instance AdaptMaybe Char where+    data Maybe Char = NothingChar | JustChar {-# UNPACK #-}!Char+    just = JustChar+    nothing = NothingChar+    isJust (JustChar _) = True+    isJust _ = False+    maybe n _ NothingChar = n+    maybe _ f (JustChar x) = f x

@@ -1,5 +1,5 @@ name:               adaptive-containers-version:            0.2.1+version:            0.3 homepage:           http://code.haskell.org/~dons/code/adaptive-containers synopsis:           Self optimizing container types description:@@ -24,7 +24,7 @@     .     * /List (Pair Int Int)/: An adaptive list of adaptive pairs <http://code.haskell.org/~dons/images/vacuum/list-pair.png>     .-    Currently supported adaptive containers: pairs, lists+    Currently supported adaptive containers: pairs, lists, maybes     .     Most unboxed element types are supported. @@ -39,6 +39,7 @@ library     exposed-modules:    Data.Adaptive.Tuple                         Data.Adaptive.List+                        Data.Adaptive.Maybe      ghc-options:        -O2                         -fdicts-cheap

@@ -0,0 +1,141 @@++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS -fglasgow-exts #-}++module AdaptiveDerive where++import Data.Generics+import Data.List+import Text.PrettyPrint+import Control.Monad++import Data.Int+import Data.Word++{-++instance Adapt Int Int where++  data Pair Int Int = PIntInt {-# UNPACK #-}!Int {-# UNPACK #-}!Int++  fst (PIntInt a _) = a+  snd (PIntInt _ b) = b+  curry f x y    =  f (PIntInt x y)+  uncurry f p    =  f (fst p) (snd p)++ -}++------------------------------------------------------------------------++main = sequence_  . intersperse (putStrLn "") $+    [ deriveM t | Box t <- types ]++data Box = forall a. (Typeable a, Data a) => Box a++types :: [Box]+types = [ Box (undefined :: Int)+        , Box (undefined :: Integer)+        , Box (undefined :: Int8)+        , Box (undefined :: Int16)+        , Box (undefined :: Int32)+        , Box (undefined :: Int64)+        , Box (undefined :: Word)+        , Box (undefined :: Word8)+        , Box (undefined :: Word16)+        , Box (undefined :: Word32)+        , Box (undefined :: Word64)+        , Box (undefined :: Double)+        , Box (undefined :: Float)+        , Box (undefined :: Char)+        ]++------------------------------------------------------------------------++deriveM :: forall a . (Typeable a, Data a) => a -> IO ()+deriveM (a :: a) = putStrLn $ derive (undefined :: a)++{-+instance AdaptList Int where+    data List Int = EmptyInt | ConsInt {-# UNPACK #-}!Int (List Int)++    empty               = EmptyInt+    cons x xs           = ConsInt x xs+    null EmptyInt       = True+    null _              = False+    head EmptyInt       = errorEmptyList "head"+    head (ConsInt x _)  = x+    tail EmptyInt       = errorEmptyList "tail"+    tail (ConsInt _ xs) = xs+-}++derive :: (Typeable a, Data a) => a  -> String+derive x = render $++   hang+    (hsep [text "instance", text "AdaptMaybe", text type_x, text "where"])+    4+    (vcat [+        hsep [ text "data"+             ,      text "Maybe"+             ,      text type_x+             , char '='+             ,      text myNothingConstr+             , char '|'+             ,      text myJustConstr+             ,      text "{-# UNPACK #-}!" <> text type_x+             ]++{-+maybe n _ NothingInt  = n+maybe _ f (JustInt x) = f x+-}++       ,hsep [  text "just"+             ,char '='+             ,  text myJustConstr]++       ,hsep [  text "nothing"+             ,char '='+             ,  text myNothingConstr]++       ,hsep [  text "isJust"+             ,  parens (text myJustConstr <+> char '_' )+             ,char '='+             ,  text "True"]+       ,hsep [  text "isJust"+             ,  char '_'+             ,char '='+             ,  text "False"]++       ,hsep [  text "maybe"+             ,  char 'n'+             ,  char '_'+             ,  text myNothingConstr+             ,char '='+             ,  char 'n'+             ]+       ,hsep [  text "maybe"+             ,  char '_'+             ,  char 'f'+             ,  parens (text myJustConstr <+> char 'x')+             ,char '='+             ,  char 'f'+             ,  char 'x']++        ])+++ where+    type_x = inst_a++    myNothingConstr = "Nothing" ++ type_x+    myJustConstr = "Just" ++ type_x++    inst_a = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters+        where (typeName,typeChildren) = splitTyConApp (typeOf x)+              typeLetters = take nTypeChildren manyLetters+              nTypeChildren = length typeChildren+              wrap x = if nTypeChildren > 0 then "("++x++")" else x++    manyLetters = map (:[]) ['a'..'z']