Output.hs

module Numeric.LAPACK.Output (
   Output (text, above, beside, formatRow, formatColumn, formatTable),
   formatAligned, formatSeparateTriangle, decorateTriangle,
   Separator(..), Style(..),

   (/+/),
   (<+>),
   hyper,
   ) where

import qualified Hyper
import qualified Text.Blaze.Html4.Transitional as Html
import qualified Text.Blaze.Html4.Transitional.Attributes as Attr
import qualified Text.Blaze.Html.Renderer.Text as RenderHtml
import Text.Blaze.Html ((!))

import qualified Text.PrettyPrint.Boxes as TextBox
import Text.PrettyPrint.Boxes (Box)

import qualified Data.Text.Lazy as TextLazy
import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Foldable (Foldable)
import Data.String (fromString)
import Data.Maybe.HT (toMaybe)
import Data.Maybe (fromMaybe)


class Output out where
   text :: String -> out
   above :: out -> out -> out
   beside :: out -> out -> out
   formatRow, formatColumn :: [out] -> out
   formatTable :: [[(Separator, Style, out)]] -> out

data Style = Stored | Derived deriving (Eq, Enum)


(/+/) :: (Output out) => out -> out -> out
(/+/) = above

(<+>) :: (Output out) => out -> out -> out
(<+>) = beside


newtype Html = Html {unHtml :: Html.Html}

hyper :: Html -> Hyper.Graphic
hyper = Hyper.html . TextLazy.toStrict . RenderHtml.renderHtml . unHtml

instance Output Html where
   text = Html . Html.toHtml
   above (Html a) (Html b) = Html $ a >> Html.br >> b
   beside (Html a) (Html b) = Html $ a >> Html.string " " >> b
   formatRow = Html . Html.table . Html.tr . mapM_ (td . unHtml)
   formatColumn = Html . Html.table . mapM_ (Html.tr . td . unHtml)
   formatTable =
      let applyStyle style = case style of Stored -> id; Derived -> Html.i in
      Html . Html.table .
      mapM_
         (Html.tr . mapM_ (\(_sep,style,x) -> td $ applyStyle style $ unHtml x))

td :: Html.Html -> Html.Html
td = Html.td ! Attr.align (fromString "right")


instance Output Box where
   text = TextBox.text
   above = (TextBox./+/)
   beside = (TextBox.<+>)
   formatRow = TextBox.hsep 1 TextBox.right
   formatColumn = TextBox.vsep 1 TextBox.right
   formatTable = alignSeparated . map (map (\(sep,_style,x) -> (sep,x)))


formatAligned :: (Foldable f, Output out) => [[f out]] -> out
formatAligned = formatTable . map (concatMap (plainCells Space Stored))

formatSeparateTriangle :: (Foldable f, Output out) => [[f out]] -> out
formatSeparateTriangle =
   formatTable . decorateTriangle (((concat.).) . zipWith3 plainCells)

decorateTriangle :: ([Separator] -> [Style] -> f a -> f b) -> [f a] -> [f b]
decorateTriangle f =
   zipWith3 f
      (iterate (Space:) (Bar : repeat Space))
      (iterate (Derived:) (repeat Stored))

plainCells :: (Foldable f, Output c) => a -> b -> f c -> [(a, b, c)]
plainCells sep style = map ((,,) sep style) . Fold.toList


data Separator = Empty | Space | Bar
   deriving (Eq, Ord, Show)

alignSeparated :: [[(Separator, Box)]] -> Box
alignSeparated =
   TextBox.hcat TextBox.top .
   map (TextBox.vcat TextBox.right) .
   concatMap
      ((\(seps,column) -> [map (TextBox.text . formatSeparator) seps, column])
         . unzip) .
   List.unfoldr (viewLAll (Empty, TextBox.text ""))

viewLAll :: a -> [[a]] -> Maybe ([a], [[a]])
viewLAll x0 xs =
   toMaybe (any (not.null) xs)
      (unzip $ map (fromMaybe (x0,[]) . ListHT.viewL) xs)

formatSeparator :: Separator -> String
formatSeparator sep = case sep of Empty -> ""; Space -> " "; Bar -> "|"