diff --git a/Text/Repr.hs b/Text/Repr.hs --- a/Text/Repr.hs +++ b/Text/Repr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Text.Repr @@ -53,11 +54,27 @@ ) import Data.Fixed ( HasResolution, resolution ) import Data.Ix ( Ix, range, index, inRange, rangeSize ) +import Foreign.Storable ( Storable + , sizeOf + , alignment + , peekElemOff + , pokeElemOff + , peekByteOff + , pokeByteOff + , peek + , poke + ) +import Foreign.Ptr ( castPtr ) +import Data.Typeable ( Typeable, typeOf) import System.Random ( Random, randomR, random ) import Control.Applicative ( liftA2 ) import Control.Arrow ( first ) +#if MIN_VERSION_base(4,0,0) +import Control.Exception ( Exception, toException, fromException ) +#endif + -------------------------------------------------------------------------------- -- Repr -------------------------------------------------------------------------------- @@ -65,6 +82,9 @@ {-| @Repr a@ is a value of type @a@ paired with a way to render that value to its textual representation. +@Repr@s follow the property that given a @Repr@ @r@ if you evaluate the textual +representation of @r@ you should get the value or @r@. + Note that @Repr a@ has an instance for most classes in 'base' provided that @a@ has instances for the respected classes. This allows you to write a numeric expression of type @Repr a@. For example: @@ -98,11 +118,11 @@ -The reason the renderer returns a 'DString', instead of for example a 'String', -is that the rendering of numeric expression involves lots of left-factored -appends i.e.: @((a ++ b) ++ c) ++ d@. A 'DString' has a O(1) append operation -while a 'String' just has a O(n) append. So choosing a 'DString' is more -efficient. +The reason the renderer returns a 'DString', instead of for example a 'String' +has to do with efficiency. The rendering of expressions involves lots of +left-factored appends i.e.: @((a ++ b) ++ c) ++ d@. A 'DString', which is +equivalent to a 'ShowS', has a O(1) append operation while a 'String' has a O(n) +append. -} type Renderer = Precedence -> Fixity -> DString @@ -151,7 +171,7 @@ @ -} () :: Repr a -> DString -> Repr a -(Repr x rx) s = constant x $ paren (between "{- " " -}" s <+> topLevel rx) +(Repr x rx) s = constant x $ topLevel rx `annotateWith` s {-| @pure x@ constructs a 'Repr' which has @x@ as value and the showed @x@ as rendering. For example: @@ -165,7 +185,7 @@ @ -} pure :: Show a => a -> Repr a -pure x = Repr x $ \prec _ -> showsPrecDS prec x +pure x = Repr x $ \prec _ -> fromShowS $ showsPrec prec x -------------------------------------------------------------------------------- @@ -329,6 +349,43 @@ inRange (b, e) p = inRange (extract b, extract e) (extract p) rangeSize (b, e) = rangeSize (extract b, extract e) +instance (Show a, Storable a) => Storable (Repr a) where + sizeOf = to sizeOf + alignment = to alignment + + peekElemOff rPtr off = do + x <- peekElemOff (castPtr rPtr) off + return $ pure x ("peekElemOff" <+> showFuncArg rPtr <+> showFuncArg off) + + peekByteOff ptr off = do + x <- peekByteOff ptr off + return $ pure x ("peekByteOff" <+> showFuncArg ptr <+> showFuncArg off) + + peek rPtr = do + x <- peek (castPtr rPtr) + return $ pure x ("peek" <+> showFuncArg rPtr) + + poke rPtr r = poke (castPtr rPtr) (extract r) + pokeElemOff rPtr off r = pokeElemOff (castPtr rPtr) off (extract r) + pokeByteOff ptr off r = pokeByteOff ptr off (extract r) + +instance Typeable a => Typeable (Repr a) where + typeOf = to typeOf + +#if MIN_VERSION_base(4,0,0) +instance Exception a => Exception (Repr a) where + toException = to toException + fromException se = + fmap (\x -> pure x ( "fromJust" + <+> paren ( "fromException" + <+> paren ( "toException" + <+> paren (showFuncArg x) + ) + ) + ) + ) $ fromException se +#endif + instance (Random a, Show a) => Random (Repr a) where randomR (b, e) = first pure . randomR (extract b, extract e) random = first pure . random @@ -338,24 +395,25 @@ -- Utility functions -------------------------------------------------------------------------------- +annotateWith :: DString -> DString -> DString +s `annotateWith` a = paren $ between "{- " " -}" a <+> s + topLevel :: Renderer -> DString topLevel r = r 0 Non constant :: a -> DString -> Repr a constant x xStr = Repr x $ \_ _ -> xStr -showsPrecDS :: Show a => Precedence -> a -> DString -showsPrecDS prec = fromShowS . showsPrec prec +showFuncArg :: Show a => a -> DString +showFuncArg = fromShowS . showsPrec funAppPrec from :: Show a => (a -> b) -> DString -> (a -> Repr b) from f fStr = - \x -> Repr (f x) $ fStr `apply` showsPrecDS funAppPrec x + \x -> Repr (f x) $ fStr `apply` showFuncArg x from2 :: (Show a, Show b) => (a -> b -> c) -> DString -> (a -> b -> Repr c) from2 f fStr = - \x y -> Repr (f x y) $ fStr `apply`( showsPrecDS funAppPrec x - <+> showsPrecDS funAppPrec y - ) + \x y -> Repr (f x y) $ fStr `apply`(showFuncArg x <+> showFuncArg y) to :: (a -> b) -> (Repr a -> b) to f = f . extract @@ -374,7 +432,8 @@ app2Show :: Show b => (a -> b -> a) -> DString -> (Repr a -> b -> Repr a) app2Show f fStr = \(Repr x rx) y -> - Repr (f x y) (fStr `applies` [rx, \prec _ -> showsPrecDS prec y]) + Repr (f x y) + (fStr `applies` [rx, \prec _ -> fromShowS $ showsPrec prec y]) infx :: Fixity -> Precedence -> (a -> b -> c) -> DString -> (Repr a -> Repr b -> Repr c) diff --git a/repr.cabal b/repr.cabal --- a/repr.cabal +++ b/repr.cabal @@ -1,5 +1,5 @@ name: repr -version: 0.3 +version: 0.3.1 cabal-version: >= 1.6 build-type: Simple stability: experimental