module Text.Repr
( Repr
, extract
, renderer
, Renderer
, Precedence
, Fixity(..)
, (<?>)
, pure
) where
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
)
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
data Repr a = Repr { extract :: a
, renderer :: Renderer
}
type Renderer = Precedence -> Fixity -> DString
type Precedence = Int
funAppPrec :: Precedence
funAppPrec = 10
data Fixity = Non
| L
| R
deriving Eq
(<?>) :: Repr a -> DString -> Repr a
(Repr x rx) <?> s = constant x $ topLevel rx `annotateWith` s
pure :: Show a => a -> Repr a
pure x = Repr x $ \prec _ -> fromShowS $ showsPrec prec x
instance Show (Repr a) where
showsPrec prec r = toShowS $ renderer r prec Non
instance Read a => Read (Repr a) where
readsPrec prec str =
map (\(x, rst) -> ( constant x $
fromString $
take (length str length rst)
str
, rst
)
) $ readsPrec prec str
instance IsString a => IsString (Repr a) where
fromString = liftA2 constant fromString fromShow
instance ToString a => ToString (Repr a) 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 Real a => Real (Repr a) 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 Fractional a => Fractional (Repr a) where
(/) = infx L 7 (*) "/"
recip = app recip "recip"
fromRational = from fromRational "fromRational"
instance Floating a => Floating (Repr a) 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"
instance RealFrac a => RealFrac (Repr a) 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
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"
instance Enum a => Enum (Repr a) where
succ = app succ "succ"
pred = app pred "pred"
toEnum = from toEnum "toEnum"
fromEnum = 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]
enumFromTo (Repr x rx)
(Repr y ry) = enum "FromTo" (enumFromTo x y) [rx, ry]
enumFromThenTo (Repr x rx)
(Repr y ry)
(Repr z rz) = enum "FromThenTo" (enumFromThenTo x y z) [rx, ry, rz]
enum :: DString -> [a] -> [Renderer] -> [Repr a]
enum enumStr xs rxs = list xs (("enum" <> enumStr) `applies` rxs)
instance Ord a => Ord (Repr a) where
compare = to2 compare
(<) = to2 (<)
(>=) = to2 (>=)
(>) = to2 (>)
(<=) = to2 (<=)
max = app2 max "max"
min = app2 min "min"
instance Eq a => Eq (Repr a) where
(==) = to2 (==)
(/=) = to2 (/=)
instance Bounded a => Bounded (Repr a) where
minBound = constant minBound "minBound"
maxBound = constant maxBound "maxBound"
instance Monoid a => Monoid (Repr a) 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
(.&.) = 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 x i = testBit (extract x) i
bitSize = to bitSize
isSigned = to isSigned
shiftL = app2Show shiftL "shiftL"
shiftR = app2Show shiftR "shiftR"
rotateL = app2Show rotateL "rotateL"
rotateR = app2Show rotateR "rotateR"
instance HasResolution a => HasResolution (Repr a) where
resolution = to resolution
instance Ix a => Ix (Repr a) where
range (Repr b rb, Repr e re) =
list (range (b, e)) ("range" `apply` paren (commas [rb, re]))
index (b, e) p = index (extract b, extract e) (extract p)
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
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
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` 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`(showFuncArg x <+> showFuncArg y)
to :: (a -> b) -> (Repr a -> b)
to f = f . extract
to2 :: (a -> b -> c) -> (Repr a -> Repr b -> c)
to2 f = \x y -> f (extract x) (extract y)
app :: (a -> b) -> DString -> (Repr a -> Repr b)
app f fStr =
\(Repr x rx) -> Repr (f x) $ fStr `applies` [rx]
app2 :: (a -> b -> c) -> DString -> (Repr a -> Repr b -> Repr c)
app2 f fStr =
\(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 f fStr =
\(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 opFix opPrec op opStr =
\(Repr x rx) (Repr y ry) ->
Repr (x `op` y) $ bin opFix opPrec opStr rx ry
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)
apply :: DString -> DString -> Renderer
fStr `apply` argsStr = \prec _ -> (prec >= funAppPrec)
`thenParen`
(fStr <+> argsStr)
applies :: DString -> [Renderer] -> Renderer
applies fStr rs = fStr `apply` args rs
args :: [Renderer] -> DString
args = hsep . map (\rx -> rx funAppPrec Non)
list :: [a] -> Renderer -> [Repr a]
list xs rXs = zipWith combine [0..] xs
where
combine ix x = Repr x $ bin L 9 "!!" rXs (\_ _ -> integer ix)
commas :: [Renderer] -> DString
commas = hsep . punctuate "," . map topLevel
unzipReprs :: [Repr a] -> ([a], [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 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
)