diff --git a/Text/Repr.hs b/Text/Repr.hs --- a/Text/Repr.hs +++ b/Text/Repr.hs @@ -1,8 +1,12 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Text.Repr ( Repr + , repr , extract , renderer , Renderer @@ -17,77 +21,73 @@ -- Imports -------------------------------------------------------------------------------- -import Data.String ( IsString, fromString ) -import Data.String.ToString ( ToString, toString ) -import Data.String.Combinators ( (<>) - , (<+>) - , between - , paren - , thenParen - , brackets - , punctuate - , fromShow - , integer - , int - , hsep - ) -import Data.DString ( DString, fromShowS, toShowS ) -import Data.Monoid ( Monoid, mempty, mappend, mconcat ) -import Data.Bits ( Bits - , (.&.) - , (.|.) - , xor - , complement - , shift - , rotate - , bit - , setBit - , clearBit - , complementBit - , testBit - , bitSize - , isSigned - , shiftL - , shiftR - , rotateL - , rotateR - ) -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 +-- from base: +import Prelude ( Eq(..) + , Ord(..) + , Enum(..) + , Bounded(..) + , Num(..) + , Real(..) + , Integral(..) + , Fractional(..) + , Floating(..) + , RealFrac(..) + , RealFloat(..) + , undefined ) +import Data.String ( IsString(..) ) +import Data.Monoid ( Monoid(..) ) +import Data.Bits ( Bits(..) ) +import Data.Function ( ($) ) +import Data.Fixed ( HasResolution(..) ) +import Data.List ( foldr, map, zipWith, take, length ) +import Data.Int ( Int ) +import Data.Ix ( Ix(..) ) +import Foreign.Storable ( Storable(..) ) import Foreign.Ptr ( castPtr ) import Data.Typeable ( Typeable, typeOf) -import System.Random ( Random, randomR, random ) import Control.Applicative ( liftA2 ) +import Control.Monad ( return, (>>=), fail, fmap ) import Control.Arrow ( first ) +import Text.Show ( Show(..) ) +import Text.Read ( Read(..) ) #if MIN_VERSION_base(4,0,0) -import Control.Exception ( Exception, toException, fromException ) +import Control.Exception ( Exception(..) ) #endif +-- from base-unicode-symbols: +import Data.Function.Unicode ( (∘) ) +import Data.Bool.Unicode ( (∧), (∨) ) +-- from random: +import System.Random ( Random(..) ) + +-- from to-string-class: +import Data.String.ToString ( ToString(..) ) + +-- from string-combinators: +import Data.String.Combinators ( (<>), (<+>) + , between, paren, thenParen, brackets + , punctuate, fromShow, integer, int, hsep + ) +-- from dstring: +import Data.DString ( DString, fromShowS, toShowS ) + + -------------------------------------------------------------------------------- -- Repr -------------------------------------------------------------------------------- -{-| @Repr a@ is a value of type @a@ paired with a way to render that value to +{-| @Repr α@ is a value of type @α@ 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@ +Note that @Repr α@ has an instance for most classes in 'base' provided that @α@ has instances for the respected classes. This allows you to write a numeric -expression of type @Repr a@. For example: +expression of type @Repr α@. For example: @ *Repr> let r = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double @@ -104,13 +104,17 @@ @ *Repr> show r -\"fromRational (3 % 2) + fromInteger 2 + (fromInteger 3 + negate (fromInteger 4) * (fromInteger 5 - pi / sqrt (fromInteger 6)))\" +\"fromRational (3 % 2) + 2 + (3 + negate 4 * (5 - pi / sqrt 6))\" @ -} -data Repr a = Repr { extract :: a -- ^ Extract the value of the @Repr@. - , renderer :: Renderer -- ^ Extract the renderer of the @Repr@. +data Repr α = Repr { extract ∷ α -- ^ Extract the value of the @Repr@. + , renderer ∷ Renderer -- ^ Extract the renderer of the @Repr@. } +-- | Construct a @Repr@ from the given value and its renderer. +repr ∷ α → Renderer → Repr α +repr = Repr + {-| To render you need to supply the precedence and fixity of the enclosing context. @@ -124,7 +128,7 @@ equivalent to a 'ShowS', has a O(1) append operation while a 'String' has a O(n) append. -} -type Renderer = Precedence -> Fixity -> DString +type Renderer = Precedence → Fixity → DString {-| The precedence of operators and function application. @@ -135,7 +139,7 @@ type Precedence = Int -- | Precedence of function application. -funAppPrec :: Precedence +funAppPrec ∷ Precedence funAppPrec = 10 -- | Fixity of operators. @@ -170,8 +174,8 @@ \"({\- p0 -\} fromInteger 1) * ({\- p0 -\} fromInteger 1) + sqrt ({\- p1 -\} (fromInteger 2)) * enumFrom ({\- p2 -\} (fromInteger 3)) !! 10\" @ -} -() :: Repr a -> DString -> Repr a -(Repr x rx) s = constant x $ topLevel rx `annotateWith` s +() ∷ Repr α → DString → Repr α +(Repr x rx) s = constant x $ paren $ between "{- " " -}" s <+> topLevel rx {-| @pure x@ constructs a 'Repr' which has @x@ as value and the showed @x@ as rendering. For example: @@ -184,20 +188,20 @@ \"[1,2,3]\" @ -} -pure :: Show a => a -> Repr a -pure x = Repr x $ \prec _ -> fromShowS $ showsPrec prec x +pure ∷ Show α => α → Repr α +pure x = Repr x $ \prec _ → fromShowS $ showsPrec prec x -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- -instance Show (Repr a) where +instance Show (Repr α) where showsPrec prec r = toShowS $ renderer r prec Non -instance Read a => Read (Repr a) where +instance Read α => Read (Repr α) where readsPrec prec str = - map (\(x, rst) -> ( constant x $ + map (\(x, rst) → ( constant x $ fromString $ take (length str - length rst) str @@ -205,39 +209,39 @@ ) ) $ readsPrec prec str -instance IsString a => IsString (Repr a) where +instance IsString α => IsString (Repr α) where fromString = liftA2 constant fromString fromShow -instance ToString a => ToString (Repr a) where +instance ToString α => ToString (Repr α) where toString = to toString -instance Num a => Num (Repr a) where - fromInteger = from fromInteger "fromInteger" - (+) = infx L 6 (+) "+" - (-) = infx L 6 (-) "-" - (*) = infx L 7 (*) "*" - negate = app negate "negate" - abs = app abs "abs" - signum = app signum "signum" +instance Num α => Num (Repr α) where + fromInteger n = repr (fromInteger n) $ \p _ → fromShowS $ showsPrec p n + (+) = infx L 6 (+) "+" + (-) = infx L 6 (-) "-" + (*) = infx L 7 (*) "*" + negate = app negate "negate" + abs = app abs "abs" + signum = app signum "signum" -instance Real a => Real (Repr a) where +instance Real α => Real (Repr α) where toRational = to toRational -instance Integral a => Integral (Repr a) where - quot = app2 quot "quot" - rem = app2 rem "rem" - div = app2 div "div" - mod = app2 mod "mod" - quotRem = tup quotRem "quotRem" - divMod = tup divMod "divMod" - toInteger = to toInteger +instance Integral α => Integral (Repr α) where + quot = app2 quot "quot" + rem = app2 rem "rem" + div = app2 div "div" + mod = app2 mod "mod" + quotRem = tup quotRem "quotRem" + divMod = tup divMod "divMod" + toInteger = to toInteger -instance Fractional a => Fractional (Repr a) where +instance Fractional α => Fractional (Repr α) where (/) = infx L 7 (*) "/" recip = app recip "recip" fromRational = from fromRational "fromRational" -instance Floating a => Floating (Repr a) where +instance Floating α => Floating (Repr α) where pi = constant pi "pi" (**) = infx R 8 (**) "**" logBase = app2 logBase "logBase" @@ -257,12 +261,12 @@ atanh = app atanh "atanh" acosh = app acosh "acosh" -instance RealFrac a => RealFrac (Repr a) where +instance RealFrac α => RealFrac (Repr α) where properFraction (Repr x rx) = let (n, f) = properFraction x in (n, Repr f $ "snd" `apply` paren ("properFraction" <+> args [rx])) -instance RealFloat a => RealFloat (Repr a) where +instance RealFloat α => RealFloat (Repr α) where floatRadix = to floatRadix floatDigits = to floatDigits floatRange = to floatRange @@ -278,7 +282,7 @@ isIEEE = to isIEEE atan2 = app2 atan2 "atan2" -instance Enum a => Enum (Repr a) where +instance Enum α => Enum (Repr α) where succ = app succ "succ" pred = app pred "pred" toEnum = from toEnum "toEnum" @@ -292,10 +296,10 @@ (Repr y ry) (Repr z rz) = enum "FromThenTo" (enumFromThenTo x y z) [rx, ry, rz] -enum :: DString -> [a] -> [Renderer] -> [Repr a] +enum ∷ DString → [α] → [Renderer] → [Repr α] enum enumStr xs rxs = list xs (("enum" <> enumStr) `applies` rxs) -instance Ord a => Ord (Repr a) where +instance Ord α => Ord (Repr α) where compare = to2 compare (<) = to2 (<) (>=) = to2 (>=) @@ -304,22 +308,22 @@ max = app2 max "max" min = app2 min "min" -instance Eq a => Eq (Repr a) where +instance Eq α => Eq (Repr α) where (==) = to2 (==) (/=) = to2 (/=) -instance Bounded a => Bounded (Repr a) where +instance Bounded α => Bounded (Repr α) where minBound = constant minBound "minBound" maxBound = constant maxBound "maxBound" -instance Monoid a => Monoid (Repr a) where +instance Monoid α => Monoid (Repr α) where mempty = constant mempty "mempty" mappend = app2 mappend "mappend" mconcat reprs = let (xs, rs) = unzipReprs reprs in Repr (mconcat xs) ("mconcat" `apply` brackets (commas rs)) -instance Bits a => Bits (Repr a) where +instance Bits α => Bits (Repr α) where (.&.) = infx L 7 (.&.) ".&." (.|.) = infx L 5 (.|.) ".|." xor = app2 xor "xor" @@ -338,10 +342,15 @@ rotateL = app2Show rotateL "rotateL" rotateR = app2Show rotateR "rotateR" -instance HasResolution a => HasResolution (Repr a) where +#if MIN_VERSION_base(4,2,0) +instance HasResolution α => HasResolution (Repr α) where + resolution (_ ∷ p (Repr α)) = resolution (undefined ∷ p α) +#else +instance HasResolution α => HasResolution (Repr α) where resolution = to resolution +#endif -instance Ix a => Ix (Repr a) where +instance Ix α => Ix (Repr α) where range (Repr b rb, Repr e re) = list (range (b, e)) ("range" `apply` paren (commas [rb, re])) @@ -349,137 +358,134 @@ 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 +instance (Show α, Storable α) => Storable (Repr α) where sizeOf = to sizeOf alignment = to alignment peekElemOff rPtr off = do - x <- peekElemOff (castPtr rPtr) off + x ← peekElemOff (castPtr rPtr) off return $ pure x ("peekElemOff" <+> showFuncArg rPtr <+> showFuncArg off) peekByteOff ptr off = do - x <- peekByteOff ptr off + x ← peekByteOff ptr off return $ pure x ("peekByteOff" <+> showFuncArg ptr <+> showFuncArg off) peek rPtr = do - x <- peek (castPtr rPtr) + 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 +instance Typeable α => Typeable (Repr α) where typeOf = to typeOf #if MIN_VERSION_base(4,0,0) -instance Exception a => Exception (Repr a) where +instance Exception α => Exception (Repr α) where toException = to toException fromException se = - fmap (\x -> pure x ( "fromJust" - <+> paren ( "fromException" - <+> paren ( "toException" - <+> paren (showFuncArg x) - ) - ) - ) + 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 +instance (Random α, Show α) => Random (Repr α) where + randomR (b, e) = first pure ∘ randomR (extract b, extract e) + random = first pure ∘ random -------------------------------------------------------------------------------- -- Utility functions -------------------------------------------------------------------------------- -annotateWith :: DString -> DString -> DString -s `annotateWith` a = paren $ between "{- " " -}" a <+> s - -topLevel :: Renderer -> DString +topLevel ∷ Renderer → DString topLevel r = r 0 Non -constant :: a -> DString -> Repr a -constant x xStr = Repr x $ \_ _ -> xStr +constant ∷ α → DString → Repr α +constant x xStr = repr x $ \_ _ → xStr -showFuncArg :: Show a => a -> DString -showFuncArg = fromShowS . showsPrec funAppPrec +showFuncArg ∷ Show α => α → DString +showFuncArg = fromShowS ∘ showsPrec funAppPrec -from :: Show a => (a -> b) -> DString -> (a -> Repr b) +from ∷ Show α => (α → β) → DString → (α → Repr β) from f fStr = - \x -> Repr (f x) $ fStr `apply` showFuncArg x + \x → repr (f x) $ fStr `apply` showFuncArg x -from2 :: (Show a, Show b) => (a -> b -> c) -> DString -> (a -> b -> Repr c) +from2 ∷ (Show α, Show β) => (α → β → γ) → DString → (α → β → Repr γ) from2 f fStr = - \x y -> Repr (f x y) $ fStr `apply`(showFuncArg x <+> showFuncArg y) + \x y → repr (f x y) $ fStr `apply`(showFuncArg x <+> showFuncArg y) -to :: (a -> b) -> (Repr a -> b) -to f = f . extract +to ∷ (α → β) → (Repr α → β) +to f = f ∘ extract -to2 :: (a -> b -> c) -> (Repr a -> Repr b -> c) -to2 f = \x y -> f (extract x) (extract y) +to2 ∷ (α → β → γ) → (Repr α → Repr β → γ) +to2 f = \x y → f (extract x) (extract y) -app :: (a -> b) -> DString -> (Repr a -> Repr b) +app ∷ (α → β) → DString → (Repr α → Repr β) app f fStr = - \(Repr x rx) -> Repr (f x) $ fStr `applies` [rx] + \(Repr x rx) → repr (f x) $ fStr `applies` [rx] -app2 :: (a -> b -> c) -> DString -> (Repr a -> Repr b -> Repr c) +app2 ∷ (α → β → γ) → DString → (Repr α → Repr β → Repr γ) app2 f fStr = - \(Repr x rx) (Repr y ry) -> Repr (f x y) $ fStr `applies` [rx, ry] + \(Repr x rx) (Repr y ry) → repr (f x y) $ fStr `applies` [rx, ry] -app2Show :: Show b => (a -> b -> a) -> DString -> (Repr a -> b -> Repr a) +app2Show ∷ Show β => (α → β → α) → DString → (Repr α → β → Repr α) app2Show f fStr = - \(Repr x rx) y -> - Repr (f x y) - (fStr `applies` [rx, \prec _ -> fromShowS $ showsPrec prec y]) + \(Repr x rx) 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) +infx ∷ Fixity → Precedence → (α → β → γ) → DString + → (Repr α → Repr β → Repr γ) infx opFix opPrec op opStr = - \(Repr x rx) (Repr y ry) -> - Repr (x `op` y) $ bin opFix opPrec opStr rx ry + \(Repr x rx) (Repr y ry) → + repr (x `op` y) $ bin opFix opPrec opStr rx ry -bin :: Fixity -> Precedence -> DString -> Renderer -> Renderer -> Renderer +bin ∷ Fixity → Precedence → DString → Renderer → Renderer → Renderer bin opFix opPrec opStr l r = - \prec fixity -> (prec > opPrec || - (prec == opPrec && - fixity /= Non && - fixity /= opFix)) - `thenParen` - (l opPrec L <+> opStr <+> r opPrec R) + \prec fixity → (prec > opPrec ∨ + (prec == opPrec ∧ + fixity /= Non ∧ + fixity /= opFix)) + `thenParen` + (l opPrec L <+> opStr <+> r opPrec R) -apply :: DString -> DString -> Renderer -fStr `apply` argsStr = \prec _ -> (prec >= funAppPrec) - `thenParen` - (fStr <+> argsStr) +apply ∷ DString → DString → Renderer +fStr `apply` argsStr = \prec _ → (prec >= funAppPrec) + `thenParen` + (fStr <+> argsStr) -applies :: DString -> [Renderer] -> Renderer +applies ∷ DString → [Renderer] → Renderer applies fStr rs = fStr `apply` args rs -args :: [Renderer] -> DString -args = hsep . map (\rx -> rx funAppPrec Non) +args ∷ [Renderer] → DString +args = hsep ∘ map (\rx → rx funAppPrec Non) -list :: [a] -> Renderer -> [Repr a] +list ∷ [α] → Renderer → [Repr α] list xs rXs = zipWith combine [0..] xs where - combine ix x = Repr x $ bin L 9 "!!" rXs (\_ _ -> integer ix) + combine ix x = repr x $ bin L 9 "!!" rXs (\_ _ → integer ix) -commas :: [Renderer] -> DString -commas = hsep . punctuate "," . map topLevel +commas ∷ [Renderer] → DString +commas = hsep ∘ punctuate "," ∘ map topLevel -unzipReprs :: [Repr a] -> ([a], [Renderer]) -unzipReprs = foldr (\(Repr x r) ~(xs, rs) -> (x:xs, r:rs)) ([], []) +unzipReprs ∷ [Repr α] → ([α], [Renderer]) +unzipReprs = foldr (\(Repr x r) ~(xs, rs) → (x:xs, r:rs)) ([], []) -tup :: (a -> b -> (c, d)) -> DString - -> (Repr a -> Repr b -> (Repr c, Repr d)) +tup ∷ (α → β → (γ, δ)) → DString + → (Repr α → Repr β → (Repr γ, Repr δ)) tup f fStr = - \(Repr x rx) (Repr y ry) -> let (q, r) = f x y - s = paren (fStr <+> args [rx, ry]) - in ( Repr q $ "fst" `apply` s - , Repr r $ "snd" `apply` s - ) + \(Repr x rx) (Repr y ry) → let (q, r) = f x y + s = paren (fStr <+> args [rx, ry]) + in ( repr q $ "fst" `apply` s + , repr r $ "snd" `apply` s + ) -- The End --------------------------------------------------------------------- diff --git a/repr.cabal b/repr.cabal --- a/repr.cabal +++ b/repr.cabal @@ -1,5 +1,5 @@ name: repr -version: 0.3.1 +version: 0.3.2 cabal-version: >= 1.6 build-type: Simple stability: experimental @@ -17,7 +17,7 @@ @ *Repr> let rd = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double *Repr> show rd - \"fromRational (3 % 2) + fromInteger 2 + (fromInteger 3 + negate (fromInteger 4) * (fromInteger 5 - pi / sqrt (fromInteger 6)))\" + \"fromRational (3 % 2) + 2 + (3 + negate 4 * (5 - pi / sqrt 6))\" @ source-repository head @@ -25,10 +25,11 @@ Location: http://code.haskell.org/~basvandijk/code/repr library - build-depends: base >= 3 && < 4.2 - , random >= 1.0 && < 1.1 - , string-combinators == 0.4.* - , to-string-class >= 0.1.2 && < 0.2 - , dstring >= 0.3.0.1 && < 0.4 + build-depends: base >= 3 && < 4.3 + , base-unicode-symbols >= 0.1.1 && < 0.2 + , random >= 1.0 && < 1.1 + , string-combinators == 0.4.* + , to-string-class >= 0.1.2 && < 0.2 + , dstring >= 0.3.0.1 && < 0.4 exposed-modules: Text.Repr ghc-options: -Wall -O2