{-# LANGUAGE DeriveDataTypeable   #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Network.Web.GHCLive.Display where

import           Data.Aeson                    (FromJSON, ToJSON, Value, (.:), (.=))
import qualified Data.Aeson                    as J
import qualified Data.Aeson                    as A
import           Data.Aeson.TH
import qualified Data.Aeson.Types              as J
import           Data.Char
import           Data.Word
import           Data.Int
import           Data.Monoid
import qualified Data.Text                     as T
import qualified Data.Text.Lazy                as TL
import           Data.Typeable
import qualified Diagrams.Backend.SVG          as D
import qualified Diagrams.Prelude              as D
import           GHC.Generics
import           Text.Blaze.Html.Renderer.Text
import qualified Text.Blaze.Html5              as B
import           Prelude hiding (span)

data ClientType = Html | Svg | Text deriving (Eq, Show, Enum)

instance J.ToJSON ClientType where toJSON = J.toJSON . map toLower . show

newtype DisplayResult = DisplayResult [DR] deriving (Eq, Monoid, Typeable, ToJSON)

-- instance ToJSON DisplayResult where toJSON (DisplayResult rs) = J.object [ T.pack "results" .= rs ]

data DR = DR {
      clientType :: ClientType, -- "SVG" "IMG" etc, changes how the browser-side javascript handles this result.
      result :: TL.Text            -- actual result data
      } deriving (Eq, Show, Typeable)

instance ToJSON DR where toJSON (DR c r) = J.object [ T.pack "t" .= c, T.pack "r" .= r ]

text :: TL.Text -> DisplayResult
text x = DisplayResult [ DR Text x ]

html :: B.Markup -> DisplayResult
html x = DisplayResult [ DR Html (renderHtml x) ]

svg :: B.Markup -> DisplayResult
svg x = DisplayResult [ DR Svg (renderHtml x) ]

displayString :: String -> DisplayResult
displayString = text . TL.pack

displayChar :: Char -> DisplayResult
displayChar = displayString . return

displayListOf :: (a -> DisplayResult) ->  [a] -> DisplayResult
displayListOf _     []     = displayString "[]"
displayListOf showx (x:xs) = displayChar '[' <> showx x <> showl xs
  where
    showl []     = displayChar ']'
    showl (y:ys) = displayChar ',' <> showx y <> showl ys

-- | Too fool ExtendedDefaultRules into firing
displaying :: (Display a, Show a) => a -> DisplayResult
displaying = display

class GDisplay f where
  gdisplay :: f a -> DisplayResult

instance GDisplay U1 where
  gdisplay U1 = mempty

instance Display a => GDisplay (K1 i a) where
  gdisplay (K1 a) = display a

instance (GDisplay f, GDisplay g) => GDisplay (f :+: g) where
  gdisplay (L1 f) = gdisplay f
  gdisplay (R1 g) = gdisplay g

instance (GDisplay f, GDisplay g) => GDisplay (f :*: g) where
  gdisplay (f :*: g) = gdisplay f <> displayChar ' ' <> gdisplay g

instance (Constructor c, GDisplay f) => GDisplay (M1 C c f) where
  gdisplay m@(M1 x) = displayString (conName m) <> displayChar ' ' <> gdisplay x

instance GDisplay f => GDisplay (M1 S c f) where
  gdisplay (M1 x) = gdisplay x

instance GDisplay f => GDisplay (M1 D c f) where
  gdisplay (M1 x) = gdisplay x

class Display a where
    displayList :: [a] -> DisplayResult
    displayList = displayListOf display

    display :: a -> DisplayResult
    default display :: (Generic a, GDisplay (Rep a)) => a -> DisplayResult
    display = gdisplay . from

{-
    default display :: Show a => a -> DisplayResult
    display = display . show
-}

displayEmpty :: DisplayResult
displayEmpty = DisplayResult []

renderMyDiagramToSvg :: Double -> D.Diagram D.SVG D.R2 -> B.Html
renderMyDiagramToSvg size dia =
   D.renderDia D.SVG (D.SVGOptions "output.file" (D.Dims size size)) dia

instance Display DisplayResult where
  display d = d

instance (a ~ D.SVG, b ~ D.R2, c ~ Any) => Display (D.QDiagram a b c) where
  display     = svg . renderMyDiagramToSvg 150
  displayList = displayListOf (svg . renderMyDiagramToSvg 75)

instance Display TL.Text where
  display d = displayChar '"' <> text d <> displayChar '"'

instance Display T.Text where
  display d = displayChar '"' <> text (TL.fromStrict d) <> displayChar '"'

instance Display a => Display [a] where
  display = displayList

instance Display B.Markup where
  display d = html d

instance (Display a, Display b) => Display (a,b) where
  display (a, b) = displayChar '(' <> display a <> displayChar ',' <> display b <> displayChar ')'

instance (Display a, Display b, Display c) => Display (a,b,c) where
  display (a, b, c) = displayChar '(' <> display a <> displayChar ',' <> display b <> displayChar ',' <> display c <> displayChar ')'

instance Display Int where display = displayString . show
instance Display Int8 where display = displayString . show
instance Display Int16 where display = displayString . show
instance Display Int32 where display = displayString . show
instance Display Int64 where display = displayString . show
instance Display Word where display = displayString . show
instance Display Word8 where display = displayString . show
instance Display Word16 where display = displayString . show
instance Display Word32 where display = displayString . show
instance Display Word64 where display = displayString . show
instance Display Integer where display = displayString . show
instance Display Float where display = displayString . show
instance Display Double where display = displayString . show
instance Display Char where
  display = displayString . show
  displayList = display . TL.pack
instance Display () where display () = displayString "()"

-- generic instances
instance Display a => Display (Maybe a)
instance (Display a, Display b) => Display (Either a b)

-- orphans
instance Show B.Markup where
  show = TL.unpack . renderHtml

instance Show (D.QDiagram b v m) where
  showsPrec _ _ = showString "<diagram>"