diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009-2010 Bas van Dijk +Copyright (c) 2009-2011 Bas van Dijk All rights reserved. diff --git a/Prelude/Repr.hs b/Prelude/Repr.hs new file mode 100644 --- /dev/null +++ b/Prelude/Repr.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE UnicodeSyntax, NoImplicitPrelude, OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Prelude.Repr +-- Copyright : (c) 2009–2011 Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- The numeric functions from the 'Prelude' lifted into @'Repr's@. +-- +-------------------------------------------------------------------------------- + +module Prelude.Repr where + +-------------------------------------------------------------------------------- +-- Imports +-------------------------------------------------------------------------------- + +-- from base: +import qualified Prelude ( subtract + , even + , odd + , gcd + , lcm + , (^) + , (^^) + , fromIntegral + , realToFrac + ) + +import Prelude ( Num, Integral, Fractional, Real ) +import Data.Bool ( Bool ) + +-- from repr: +import Text.Repr ( Repr, Fixity(R), to, app, app2, infx ) + + +-------------------------------------------------------------------------------- +-- Numeric functions +-------------------------------------------------------------------------------- + +-- | Lifts @Prelude.'Prelude.subtract'@ into @'Repr's@ +subtract ∷ Num α ⇒ Repr α → Repr α → Repr α +subtract = app2 Prelude.subtract "subtract" + +-- | Lifts @Prelude.'Prelude.even'@ into a 'Repr' +even ∷ Integral α ⇒ Repr α → Bool +even = to Prelude.even + +-- | Lifts @Prelude.'Prelude.odd'@ into a 'Repr' +odd ∷ Integral α ⇒ Repr α → Bool +odd = to Prelude.odd + +-- | Lifts @Prelude.'Prelude.gcd'@ into @'Repr's@ +gcd ∷ Integral α ⇒ Repr α → Repr α → Repr α +gcd = app2 Prelude.gcd "gcd" + +-- | Lifts @Prelude.'Prelude.lcm'@ into @'Repr's@ +lcm ∷ Integral α ⇒ Repr α → Repr α → Repr α +lcm = app2 Prelude.lcm "lcm" + +-- | Lifts @Prelude.'Prelude.^'@ into @'Repr's@ +(^) ∷ (Num α, Integral β) ⇒ Repr α → Repr β → Repr α +(^) = infx R 8 (Prelude.^) "^" + +-- | Lifts @Prelude.'Prelude.^^'@ into @'Repr's@ +(^^) ∷ (Fractional α, Integral β) ⇒ Repr α → Repr β → Repr α +(^^) = infx R 8 (Prelude.^^) "^^" + +-- | Lifts @Prelude.'Prelude.fromIntegral'@ into @'Repr's@ +fromIntegral ∷ (Integral α, Num β) ⇒ Repr α → Repr β +fromIntegral = app Prelude.fromIntegral "fromIntegral" + +-- | Lifts @Prelude.'Prelude.realToFrac'@ into @'Repr's@ +realToFrac ∷ (Real α, Fractional β) ⇒ Repr α → Repr β +realToFrac = app Prelude.realToFrac "realToFrac" + + +-- The End --------------------------------------------------------------------- diff --git a/Text/Repr.hs b/Text/Repr.hs --- a/Text/Repr.hs +++ b/Text/Repr.hs @@ -6,9 +6,19 @@ , DeriveDataTypeable #-} +-------------------------------------------------------------------------------- +-- | +-- Module : Text.Repr +-- Copyright : (c) 2009–2011 Bas van Dijk +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Bas van Dijk +-- +-- Textual representation of values. +-- +-------------------------------------------------------------------------------- + module Text.Repr ( Repr - , repr , extract , renderer , Renderer @@ -16,6 +26,14 @@ , Fixity(..) , () , pure + , repr + + -- * Utilities + -- | Handy utilities when writing type class instances for @Reprs@. + , constant + , to, to2 + , app, app2 + , infx ) where @@ -43,15 +61,15 @@ import Data.Function ( ($) ) import Data.Functor ( fmap ) import Data.Fixed ( HasResolution(..) ) -import Data.List ( foldr, map, zipWith, take, length ) +import Data.List ( map, zipWith, take, length, unzip ) import Data.Int ( Int ) import Data.Ix ( Ix(..) ) import Foreign.Storable ( Storable(..) ) import Foreign.Ptr ( castPtr ) import Data.Typeable ( Typeable ) import Control.Applicative ( liftA2 ) -import Control.Monad ( return, (>>=), fail ) -import Control.Arrow ( first ) +import Control.Monad ( return ) +import Control.Arrow ( first, (&&&) ) import Text.Show ( Show(..) ) import Text.Read ( Read(..) ) @@ -59,6 +77,10 @@ import Control.Exception ( Exception(..) ) #endif +#if __GLASGOW_HASKELL__ < 700 +import Control.Monad ( (>>=), fail ) +#endif + -- from base-unicode-symbols: import Data.Function.Unicode ( (∘) ) import Data.Bool.Unicode ( (∧), (∨) ) @@ -93,7 +115,7 @@ *Repr> let r = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double @ -You can extract the value of @r@: +You can 'extract' the value of @r@: @ *Repr> extract r @@ -104,7 +126,7 @@ @ *Repr> show r -\"fromRational (3 % 2) + 2 + (3 + negate 4 * (5 - pi / sqrt 6))\" +\"1.5 + 2.0 + (3.0 + negate 4.0 * (5.0 - pi / sqrt 6.0))\" @ -} data Repr α = Repr { extract ∷ α -- ^ Extract the value of the @Repr@. @@ -112,10 +134,6 @@ } deriving Typeable --- | 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. @@ -176,7 +194,7 @@ @ -} () ∷ Repr α → DString → Repr α -(Repr x rx) s = constant x $ parens $ between "{- " " -}" s <+> topLevel rx +(Repr x rx) s = constant x $ parens $ between "{- " " -}" s <+> runRenderer rx {-| @pure x@ constructs a 'Repr' which has @x@ as value and the showed @x@ as rendering. For example: @@ -190,10 +208,31 @@ @ -} pure ∷ Show α ⇒ α → Repr α -pure x = Repr x $ \prec _ → fromShowS $ showsPrec prec x +pure x = repr x $ \prec _ → fromShowS $ showsPrec prec x +-- | Construct a @Repr@ from the given value and its renderer. +repr ∷ α → Renderer → Repr α +repr = Repr + -------------------------------------------------------------------------------- +-- Handy CPP macro's +-------------------------------------------------------------------------------- + +#define PURE(N) N = pure ∘ (N) +#define TO(N) N = to (N) +#define TO2(N) (N) = to2 (N) +#define FROM(N) N = from (N) "N" +#define FROM2(N) N = from2 (N) "N" +#define INFX(F,P,N) (N) = infx F P (N) "N" +#define APP(N) N = app (N) "N" +#define APP2(N) N = app2 (N) "N" +#define APP2SHOW(N) N = app2Show (N) "N" +#define TUP(N) N = tup (N) "N" +#define CONSTANT(N) N = constant (N) "N" + + +-------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- @@ -214,81 +253,84 @@ fromString = liftA2 constant fromString fromShow 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" + PURE(fromInteger) + INFX(L, 6, +) + INFX(L, 6, -) + INFX(L, 7, *) + APP(negate) + APP(abs) + APP(signum) instance Real α ⇒ Real (Repr α) where - toRational = to toRational + TO(toRational) 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 + APP2(quot) + APP2(rem) + APP2(div) + APP2(mod) + TUP(quotRem) + TUP(divMod) + TO(toInteger) instance Fractional α ⇒ Fractional (Repr α) where - (/) = infx L 7 (*) "/" - recip = app recip "recip" - fromRational = from fromRational "fromRational" + INFX(L, 7, /) + APP(recip) + PURE(fromRational) instance Floating α ⇒ Floating (Repr α) where - pi = constant pi "pi" - (**) = infx R 8 (**) "**" - logBase = app2 logBase "logBase" - exp = app exp "exp" - sqrt = app sqrt "sqrt" - log = app log "log" - sin = app sin "sin" - tan = app tan "tan" - cos = app cos "cos" - asin = app asin "asin" - atan = app atan "atan" - acos = app acos "acos" - sinh = app sinh "sinh" - tanh = app tanh "tanh" - cosh = app cosh "cosh" - asinh = app asinh "asinh" - atanh = app atanh "atanh" - acosh = app acosh "acosh" + CONSTANT(pi) + INFX(R, 8, **) + APP2(logBase) + APP(exp) + APP(sqrt) + APP(log) + APP(sin) + APP(tan) + APP(cos) + APP(asin) + APP(atan) + APP(acos) + APP(sinh) + APP(tanh) + APP(cosh) + APP(asinh) + APP(atanh) + APP(acosh) instance RealFrac α ⇒ RealFrac (Repr α) where + TO(truncate) + TO(round) + TO(ceiling) + TO(floor) + properFraction (Repr x rx) = let (n, f) = properFraction x - in (n, Repr f $ "snd" `apply` parens ("properFraction" <+> args [rx])) - truncate = to truncate - round = to round - ceiling = to ceiling - floor = to floor + in (n, repr f $ "snd" `apply` parens ("properFraction" <+> args [rx])) instance RealFloat α ⇒ RealFloat (Repr α) where - floatRadix = to floatRadix - floatDigits = to floatDigits - floatRange = to floatRange - decodeFloat = to decodeFloat - encodeFloat = from2 encodeFloat "encodeFloat" - exponent = to exponent - significand = app significand "significand" - scaleFloat i = app (scaleFloat i) ("scaleFloat" <+> int i) - isNaN = to isNaN - isInfinite = to isInfinite - isDenormalized = to isDenormalized - isNegativeZero = to isNegativeZero - isIEEE = to isIEEE - atan2 = app2 atan2 "atan2" + TO(floatRadix) + TO(floatDigits) + TO(floatRange) + TO(decodeFloat) + TO(isNaN) + TO(isInfinite) + TO(isDenormalized) + TO(isNegativeZero) + TO(isIEEE) + TO(exponent) + APP(significand) + APP2(atan2) + FROM2(encodeFloat) + scaleFloat i = app (scaleFloat i) ("scaleFloat" <+> int i) + instance Enum α ⇒ Enum (Repr α) where - succ = app succ "succ" - pred = app pred "pred" - toEnum = from toEnum "toEnum" - fromEnum = to fromEnum + APP(succ) + APP(pred) + FROM(toEnum) + TO(fromEnum) + enumFrom (Repr x rx) = enum "From" (enumFrom x) [rx] enumFromThen (Repr x rx) (Repr y ry) = enum "FromThen" (enumFromThen x y) [rx, ry] @@ -302,54 +344,58 @@ enum enumStr xs rxs = list xs (("enum" <> enumStr) `applies` rxs) instance Ord α ⇒ Ord (Repr α) where - compare = to2 compare - (<) = to2 (<) - (>=) = to2 (>=) - (>) = to2 (>) - (<=) = to2 (<=) - max = app2 max "max" - min = app2 min "min" + compare = to2 compare + TO2(<) + TO2(>=) + TO2(>) + TO2(<=) + APP2(max) + APP2(min) instance Eq α ⇒ Eq (Repr α) where - (==) = to2 (==) - (/=) = to2 (/=) + TO2(==) + TO2(/=) instance Bounded α ⇒ Bounded (Repr α) where - minBound = constant minBound "minBound" - maxBound = constant maxBound "maxBound" + CONSTANT(minBound) + CONSTANT(maxBound) instance Monoid α ⇒ Monoid (Repr α) where - mempty = constant mempty "mempty" - mappend = app2 mappend "mappend" + CONSTANT(mempty) + APP2(mappend) + mconcat reprs = let (xs, rs) = unzipReprs reprs in Repr (mconcat xs) ("mconcat" `apply` brackets (commas rs)) +unzipReprs ∷ [Repr α] → ([α], [Renderer]) +unzipReprs = unzip ∘ map (extract &&& renderer) + instance Bits α ⇒ Bits (Repr α) where - (.&.) = infx L 7 (.&.) ".&." - (.|.) = infx L 5 (.|.) ".|." - xor = app2 xor "xor" - complement = app complement "complement" - shift = app2Show shift "shift" - rotate = app2Show rotate "rotate" - bit = from bit "bit" - setBit = app2Show setBit "setBit" - clearBit = app2Show clearBit "clearBit" - complementBit = app2Show complementBit "complementBit" - testBit = to testBit - bitSize = to bitSize - isSigned = to isSigned - shiftL = app2Show shiftL "shiftL" - shiftR = app2Show shiftR "shiftR" - rotateL = app2Show rotateL "rotateL" - rotateR = app2Show rotateR "rotateR" + INFX(L, 7, .&.) + INFX(L, 5, .|.) + APP2(xor) + APP(complement) + APP2SHOW(shift) + APP2SHOW(rotate) + FROM(bit) + APP2SHOW(setBit) + APP2SHOW(clearBit) + APP2SHOW(complementBit) + TO(testBit) + TO(bitSize) + TO(isSigned) + APP2SHOW(shiftL) + APP2SHOW(shiftR) + APP2SHOW(rotateL) + APP2SHOW(rotateR) #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 + TO(resolution) #endif instance Ix α ⇒ Ix (Repr α) where @@ -361,8 +407,8 @@ rangeSize (b, e) = rangeSize (extract b, extract e) instance (Show α, Storable α) ⇒ Storable (Repr α) where - sizeOf = to sizeOf - alignment = to alignment + TO(sizeOf) + TO(alignment) peekElemOff rPtr off = do x ← peekElemOff (castPtr rPtr) off @@ -382,7 +428,7 @@ #if MIN_VERSION_base(4,0,0) instance Exception α ⇒ Exception (Repr α) where - toException = to toException + TO(toException) fromException se = fmap (\x → pure x ( "fromJust" <+> parens ( "fromException" @@ -403,9 +449,18 @@ -- Utility functions -------------------------------------------------------------------------------- -topLevel ∷ Renderer → DString -topLevel r = r 0 Non +mapRepr ∷ (α → β) → (Renderer → Renderer) + → (Repr α → Repr β) +mapRepr f g = \(Repr x rx) → repr (f x) (g rx) +mapRepr2 ∷ (α → β → γ) → (Renderer → Renderer → Renderer) + → (Repr α → Repr β → Repr γ) +mapRepr2 f g = \(Repr x rx) (Repr y ry) → repr (f x y) (g rx ry) + +runRenderer ∷ Renderer → DString +runRenderer r = r 0 Non + +-- | For example: @pi = 'constant' 'pi' \"pi\"@ constant ∷ α → DString → Repr α constant x xStr = repr x $ \_ _ → xStr @@ -413,26 +468,26 @@ showFuncArg = fromShowS ∘ showsPrec funAppPrec from ∷ Show α ⇒ (α → β) → DString → (α → Repr β) -from f fStr = - \x → repr (f x) $ fStr `apply` showFuncArg x +from f fStr = \x → repr (f x) $ fStr `apply` showFuncArg x from2 ∷ (Show α, Show β) ⇒ (α → β → γ) → DString → (α → β → Repr γ) -from2 f fStr = - \x y → repr (f x y) $ fStr `apply`(showFuncArg x <+> showFuncArg y) +from2 f fStr = \x y → repr (f x y) $ fStr `apply`(showFuncArg x <+> showFuncArg y) +-- | For example: @toInteger = 'to' 'toInteger'@ to ∷ (α → β) → (Repr α → β) to f = f ∘ extract +-- | For example: @(<) = 'to2' ('<')@ to2 ∷ (α → β → γ) → (Repr α → Repr β → γ) to2 f = \x y → f (extract x) (extract y) +-- | For example: @abs = 'app' 'abs' \"abs\"@ app ∷ (α → β) → DString → (Repr α → Repr β) -app f fStr = - \(Repr x rx) → repr (f x) $ fStr `applies` [rx] +app f fStr = mapRepr f (\rx → fStr `applies` [rx]) +-- | For example: @div = 'app2' 'div' \"div\"@ app2 ∷ (α → β → γ) → DString → (Repr α → Repr β → Repr γ) -app2 f fStr = - \(Repr x rx) (Repr y ry) → repr (f x y) $ fStr `applies` [rx, ry] +app2 f fStr = mapRepr2 f (\rx ry → fStr `applies` [rx, ry]) app2Show ∷ Show β ⇒ (α → β → α) → DString → (Repr α → β → Repr α) app2Show f fStr = @@ -440,11 +495,10 @@ repr (f x y) (fStr `applies` [rx, \prec _ → fromShowS $ showsPrec prec y]) +-- | For example: @(+) = 'infx' 'L' 6 ('+') \"+\"@ 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 +infx opFix opPrec op opStr = mapRepr2 op (bin opFix opPrec opStr) bin ∷ Fixity → Precedence → DString → Renderer → Renderer → Renderer bin opFix opPrec opStr l r = @@ -472,19 +526,16 @@ combine ix x = repr x $ bin L 9 "!!" rXs (\_ _ → integer ix) commas ∷ [Renderer] → DString -commas = unwords ∘ punctuate "," ∘ map topLevel - -unzipReprs ∷ [Repr α] → ([α], [Renderer]) -unzipReprs = foldr (\(Repr x r) ~(xs, rs) → (x:xs, r:rs)) ([], []) +commas = unwords ∘ punctuate "," ∘ map runRenderer tup ∷ (α → β → (γ, δ)) → DString → (Repr α → Repr β → (Repr γ, Repr δ)) -tup f fStr = - \(Repr x rx) (Repr y ry) → let (q, r) = f x y - s = parens (fStr <+> args [rx, ry]) - in ( repr q $ "fst" `apply` s - , repr r $ "snd" `apply` s - ) +tup f fStr = \(Repr x rx) (Repr y ry) → + let (q, r) = f x y + s = parens (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,12 +1,11 @@ name: repr -version: 0.4 +version: 0.4.1 cabal-version: >= 1.6 build-type: Simple stability: experimental -tested-with: GHC ==6.10.4 author: Bas van Dijk maintainer: v.dijk.bas@gmail.com -copyright: (c) 2009-2010 Bas van Dijk +copyright: (c) 2009-2011 Bas van Dijk license: BSD3 license-file: LICENSE category: Numeric, Text @@ -15,9 +14,11 @@ textual representation. For example: . @ - *Repr> let rd = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double + *Repr> let r = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double + *Repr> extract r + 17.281195923884734 *Repr> show rd - \"fromRational (3 % 2) + 2 + (3 + negate 4 * (5 - pi / sqrt 6))\" + \"1.5 + 2.0 + (3.0 + negate 4.0 * (5.0 - pi / sqrt 6.0))\" @ source-repository head @@ -30,5 +31,5 @@ , random >= 1.0 && < 1.1 , string-combinators >= 0.6 && < 0.7 , dstring >= 0.3.0.1 && < 0.5 - exposed-modules: Text.Repr + exposed-modules: Text.Repr, Prelude.Repr ghc-options: -Wall