{-# LANGUAGE OverloadedStrings #-}

module Repr
    ( Repr
    , value
    , renderer
    , Renderer
    , Precedence
    , Fixity(..)
    , render
    , (<?>)
    ) where


--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------

import Data.String             ( IsString, fromString )
import Data.String.ToString    ( ToString, toString )
import Data.String.Combinators ( (<>)
                               , (<+>)
                               , between
                               , paren
                               , thenParen
                               , fromShow
                               , integer
                               , int
                               , hsep
                               )
import Data.DString            ( DString, fromShowS )
import Control.Applicative     ( liftA2 )


--------------------------------------------------------------------------------
-- Repr
--------------------------------------------------------------------------------

-- | @Repr a@ is a value of type @a@ paired with a way to render that value to a
-- string which will contain a representation of the value.
--
-- Note that @Repr a@ is overloaded for all the numeric classes provided that
-- @a@ has instances for the respected classes. This allows you to write a
-- numeric expression of type @Repr a@. For example:
--
-- @
-- *Repr> let rd = 1.5 + 2 + (3 + (-4) * (5 - pi / sqrt 6)) :: Repr Double
-- @
--
-- You can extract the value of @rd@:
--
-- @
-- *Repr> value rd
-- 17.281195923884734
-- @
--
-- And you can than render @rd@ to its textual representation:
--
-- @
-- *Repr> render rd
-- \"fromRational (3 % 2) + fromInteger 2 + (fromInteger 3 + negate (fromInteger 4) * (fromInteger 5 - pi / sqrt (fromInteger 6)))\"
-- @
data Repr a = S { value    :: a        -- ^ Extract the value of the @Repr@.
                , renderer :: Renderer -- ^ Extrac the renderer of the @Repr@.
                }

-- | To render you need to supply the precedence and fixity of the enclosing
-- context.
--
-- For more documentation about precedence and fixity see:
--
-- <http://haskell.org/onlinereport/decls.html#sect4.4.2>
--
-- 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.
type Renderer = Precedence ->  Fixity -> DString

-- | The precedence of operators and function application.
--
-- * Operators usually have a precedence in the range of 0 to 9.
--
-- * Function application always has precedence 10.
type Precedence = Int

-- | Fixity of operators.
data Fixity = Non -- ^ No fixity information.
            | L   -- ^ Left associative operator.
            | R   -- ^ Right associative operator.
              deriving Eq

-- | Render a /top-level/ value to a 'String'.
--
-- Note that: @render r = 'toString' $ 'renderer' r 0 'Non'@
render :: Repr a -> String
render r = toString $ renderer r 0 Non

-- | @x \<?\> s@ annotates the rendering with the given string.
--
-- The output wil look like: @\"({- s -} ...)\"@ where @...@ is the rendering of
-- @x@.
--
-- This combinator is handy when you want to render the ouput of a function and
-- you want to see how the parameters of the function contribute to the
-- result. For example, suppose you defined the following function @f@:
--
-- @
-- f p0 p1 p2 = p0 ^ 2 + sqrt p1 * ([p2..] !! 10)
-- @
--
-- You can then apply @f@ to some parameters annotated with some descriptive
-- strings (the name of the parameter is usally a good idea):
--
-- @
-- f (1 \<?\> \"p0\") (2 \<?\> \"p1\") (3 \<?\> \"p2\")
-- @
--
-- The rendering will then look like:
--
-- @
-- \"({- p0 -} fromInteger 1) * ({- p0 -} fromInteger 1) + sqrt ({- p1 -} (fromInteger 2)) * enumFrom ({- p2 -} (fromInteger 3)) !! 10\"
-- @
(<?>) :: Repr a -> DString -> Repr a
(S x rx) <?> s = S x $ \prec fixity -> paren (between "{- " " -}" s <+> rx prec fixity)


--------------------------------------------------------------------------------
-- Instances
--------------------------------------------------------------------------------

instance Show (Repr a) where
    show = render

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 (S x rx) =
        let (n, f) = properFraction x
        in (n, S 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       (S x rx)                   = enum "From"       (enumFrom       x)     [rx]
    enumFromThen   (S x rx) (S y ry)          = enum "FromThen"   (enumFromThen   x y)   [rx, ry]
    enumFromTo     (S x rx) (S y ry)          = enum "FromTo"     (enumFromTo     x y)   [rx, ry]
    enumFromThenTo (S x rx) (S y ry) (S z rz) = enum "FromThenTo" (enumFromThenTo x y z) [rx, ry, rz]

enum :: DString -> [a] -> [Renderer] -> [Repr a]
enum enumStr xs rxs = zipWith combine [0..] xs
    where
      combine i y = S y $ \prec fixity -> (prec > 9 || (prec == 9 && fixity /= Non && fixity /= L))
                                          `thenParen`
                                          ("enum" <> enumStr <+> args rxs <+> "!!" <+> integer i)

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 IsString a => IsString (Repr a) where
    fromString = liftA2 constant fromString fromShow


--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------

-- | Construct 'Repr' from a given value and string.
constant :: a -> DString -> Repr a
constant x xStr = S x $ \_ _ -> xStr

-- | Precedence of function application.
funAppPrec :: Precedence
funAppPrec = 10

from :: Show a => (a -> b) -> DString -> (a -> Repr b)
from f fStr = \x -> S (f x) $
              \prec _ -> (prec >= funAppPrec)
                         `thenParen`
                         (fStr <+> fromShowS (showsPrec funAppPrec x))

from2 :: (Show a, Show b) => (a -> b -> c) -> DString -> (a -> b -> Repr c)
from2 f fStr = \x y -> S (f x y) $
               \prec _ -> (prec >= funAppPrec)
                          `thenParen`
                          (fStr <+> fromShowS (showsPrec funAppPrec x)
                                <+> fromShowS (showsPrec funAppPrec y))

to :: (a -> b) -> Repr a -> b
to f = f . value

to2 :: (a -> b -> c) -> Repr a -> Repr b -> c
to2 f x y = f (value x) (value y)

app :: (a -> b) -> DString -> (Repr a -> Repr b)
app fun funStr =
    \(S x rx) -> S (fun x) $ funStr `apply` args [rx]

app2 :: (a -> b -> c) -> DString -> (Repr a -> Repr b -> Repr c)
app2 fun funStr =
    \(S x rx) (S y ry) -> S (fun x y) $ funStr `apply` args [rx, ry]

infx :: Fixity -> Precedence -> (a -> b -> c) -> DString
     -> (Repr a -> Repr b -> Repr c)
infx opFix opPrec op opStr =
    \(S x rx) (S y ry) ->
        S (x `op` y) $
              \prec fixity -> (prec > opPrec ||
                               (prec == opPrec &&
                                fixity /= Non &&
                                fixity /= opFix))
                              `thenParen`
                              (rx opPrec L <+> opStr <+> ry opPrec R)

tup :: (a -> b -> (c, d)) -> DString
    -> (Repr a -> Repr b -> (Repr c, Repr d))
tup f fStr =
    \(S x rx) (S y ry) ->
        let (q, r) = f x y
            s = paren (fStr <+> args [rx, ry])
        in ( S q $ "fst" `apply` s
           , S r $ "snd" `apply` s
           )

args :: [Renderer] -> DString
args = hsep . map (\rx -> rx funAppPrec Non)

apply :: DString -> DString -> Renderer
funStr `apply` argsStr = \prec _ -> (prec >= funAppPrec)
                                    `thenParen`
                                    (funStr <+> argsStr)


-- The End ---------------------------------------------------------------------