{-# LANGUAGE OverloadedStrings #-}

module HieDb.Html
    ( Color (..)
    , Span (..)
    , generate
    ) where

import           Control.Monad (forM_)
import           Data.Function (on)
import           Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IM
import           Data.List (foldl', sortBy)
import           Data.Text   (Text)
import qualified Data.Text as T
import           Lucid

import           HieDb.Compat

generate :: FilePath -> ModuleName -> [Text] -> [Span] -> IO ()
generate :: String -> ModuleName -> [Text] -> [Span] -> IO ()
generate String
fp ModuleName
mn [Text]
ts [Span]
sps = forall a. String -> Html a -> IO ()
renderToFile String
fp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => HtmlT m a -> HtmlT m a
doctypehtml_ forall a b. (a -> b) -> a -> b
$ do
    forall arg result. Term arg result => arg -> result
head_ forall a b. (a -> b) -> a -> b
$ forall arg result. Term arg result => arg -> result
title_ forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml forall a b. (a -> b) -> a -> b
$ ModuleName -> String
moduleNameString ModuleName
mn
    forall arg result. Term arg result => arg -> result
body_ forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Text] -> [Span] -> [(Int, Text, [LineSpan])]
layout [Text]
ts [Span]
sps) (Int, Text, [LineSpan]) -> HtmlT Identity ()
generateLine'
  where
    generateLine' :: (Int, Text, [LineSpan]) -> Html ()
    generateLine' :: (Int, Text, [LineSpan]) -> HtmlT Identity ()
generateLine' (Int
i, Text
t, [LineSpan]
lsps) = forall arg result. Term arg result => arg -> result
pre_ [forall arg result. TermRaw arg result => arg -> result
style_ Text
"margin:0em;font-size:large"] forall a b. (a -> b) -> a -> b
$ do
        forall arg result. Term arg result => arg -> result
span_ [forall arg result. TermRaw arg result => arg -> result
style_ Text
"background-color:lightcyan;padding-right:1em"] forall a b. (a -> b) -> a -> b
$ Int -> HtmlT Identity ()
padLineNumber Int
i
        Int -> Text -> [LineSpan] -> HtmlT Identity ()
go Int
1 Text
t [LineSpan]
lsps

    go :: Int -> Text -> [LineSpan] -> Html ()
    go :: Int -> Text -> [LineSpan] -> HtmlT Identity ()
go Int
_   Text
t [] = forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t
    go Int
col Text
t lsps :: [LineSpan]
lsps@(LineSpan
lsp : [LineSpan]
lsps')
        | Int
col forall a. Ord a => a -> a -> Bool
< LineSpan -> Int
lspStartColumn LineSpan
lsp = do
            let (Text
t1, Text
t2) = Int -> Text -> (Text, Text)
T.splitAt (LineSpan -> Int
lspStartColumn LineSpan
lsp forall a. Num a => a -> a -> a
- Int
col) Text
t
            forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t1
            Int -> Text -> [LineSpan] -> HtmlT Identity ()
go (LineSpan -> Int
lspStartColumn LineSpan
lsp) Text
t2 [LineSpan]
lsps
        | Bool
otherwise = do
            let l :: Int
l        = LineSpan -> Int
lspEndColumn LineSpan
lsp forall a. Num a => a -> a -> a
- LineSpan -> Int
lspStartColumn LineSpan
lsp forall a. Num a => a -> a -> a
+ Int
1
                (Text
t1, Text
t2) = Int -> Text -> (Text, Text)
T.splitAt Int
l Text
t
            forall arg result. Term arg result => arg -> result
span_ [LineSpan -> Attribute
lineSpanAttribute LineSpan
lsp] forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
t1
            Int -> Text -> [LineSpan] -> HtmlT Identity ()
go (LineSpan -> Int
lspEndColumn LineSpan
lsp forall a. Num a => a -> a -> a
+ Int
1) Text
t2 [LineSpan]
lsps'

padLineNumber :: Int -> Html ()
padLineNumber :: Int -> HtmlT Identity ()
padLineNumber Int
n = let s :: String
s = forall a. Show a => a -> String
show Int
n in forall {t} {m :: * -> *}.
(Ord t, Num t, Monad m) =>
String -> t -> HtmlT m ()
go String
s forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
  where
    go :: String -> t -> HtmlT m ()
go String
s t
l
        | t
l forall a. Ord a => a -> a -> Bool
>= t
6    = forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml String
s
        | Bool
otherwise = String -> t -> HtmlT m ()
go (Char
' ' forall a. a -> [a] -> [a]
: String
s) (t
l forall a. Num a => a -> a -> a
+ t
1)

data Color = Reachable | Unreachable deriving (Int -> Color -> ShowS
[Color] -> ShowS
Color -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> Color -> ShowS
Show, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Color]
$creadListPrec :: ReadPrec [Color]
readPrec :: ReadPrec Color
$creadPrec :: ReadPrec Color
readList :: ReadS [Color]
$creadList :: ReadS [Color]
readsPrec :: Int -> ReadS Color
$creadsPrec :: Int -> ReadS Color
Read, Color -> Color -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: Color -> Color -> Bool
Eq, Eq Color
Color -> Color -> Bool
Color -> Color -> Ordering
Color -> Color -> Color
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Color -> Color -> Color
$cmin :: Color -> Color -> Color
max :: Color -> Color -> Color
$cmax :: Color -> Color -> Color
>= :: Color -> Color -> Bool
$c>= :: Color -> Color -> Bool
> :: Color -> Color -> Bool
$c> :: Color -> Color -> Bool
<= :: Color -> Color -> Bool
$c<= :: Color -> Color -> Bool
< :: Color -> Color -> Bool
$c< :: Color -> Color -> Bool
compare :: Color -> Color -> Ordering
$ccompare :: Color -> Color -> Ordering
Ord)

data Span = Span
    { Span -> Int
spStartLine   :: !Int
    , Span -> Int
spStartColumn :: !Int
    , Span -> Int
spEndLine     :: !Int
    , Span -> Int
spEndColumn   :: !Int
    , Span -> Color
spColor       :: !Color
    } deriving (Int -> Span -> ShowS
[Span] -> ShowS
Span -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span] -> ShowS
$cshowList :: [Span] -> ShowS
show :: Span -> String
$cshow :: Span -> String
showsPrec :: Int -> Span -> ShowS
$cshowsPrec :: Int -> Span -> ShowS
Show, ReadPrec [Span]
ReadPrec Span
Int -> ReadS Span
ReadS [Span]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Span]
$creadListPrec :: ReadPrec [Span]
readPrec :: ReadPrec Span
$creadPrec :: ReadPrec Span
readList :: ReadS [Span]
$creadList :: ReadS [Span]
readsPrec :: Int -> ReadS Span
$creadsPrec :: Int -> ReadS Span
Read, Span -> Span -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span -> Span -> Bool
$c/= :: Span -> Span -> Bool
== :: Span -> Span -> Bool
$c== :: Span -> Span -> Bool
Eq, Eq Span
Span -> Span -> Bool
Span -> Span -> Ordering
Span -> Span -> Span
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Span -> Span -> Span
$cmin :: Span -> Span -> Span
max :: Span -> Span -> Span
$cmax :: Span -> Span -> Span
>= :: Span -> Span -> Bool
$c>= :: Span -> Span -> Bool
> :: Span -> Span -> Bool
$c> :: Span -> Span -> Bool
<= :: Span -> Span -> Bool
$c<= :: Span -> Span -> Bool
< :: Span -> Span -> Bool
$c< :: Span -> Span -> Bool
compare :: Span -> Span -> Ordering
$ccompare :: Span -> Span -> Ordering
Ord)

data LineSpan = LineSpan
    { LineSpan -> Int
lspLine        :: !Int
    , LineSpan -> Int
lspStartColumn :: !Int
    , LineSpan -> Int
lspEndColumn   :: !Int
    , LineSpan -> Color
lspColor       :: !Color
    } deriving (Int -> LineSpan -> ShowS
[LineSpan] -> ShowS
LineSpan -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LineSpan] -> ShowS
$cshowList :: [LineSpan] -> ShowS
show :: LineSpan -> String
$cshow :: LineSpan -> String
showsPrec :: Int -> LineSpan -> ShowS
$cshowsPrec :: Int -> LineSpan -> ShowS
Show, ReadPrec [LineSpan]
ReadPrec LineSpan
Int -> ReadS LineSpan
ReadS [LineSpan]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [LineSpan]
$creadListPrec :: ReadPrec [LineSpan]
readPrec :: ReadPrec LineSpan
$creadPrec :: ReadPrec LineSpan
readList :: ReadS [LineSpan]
$creadList :: ReadS [LineSpan]
readsPrec :: Int -> ReadS LineSpan
$creadsPrec :: Int -> ReadS LineSpan
Read, LineSpan -> LineSpan -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LineSpan -> LineSpan -> Bool
$c/= :: LineSpan -> LineSpan -> Bool
== :: LineSpan -> LineSpan -> Bool
$c== :: LineSpan -> LineSpan -> Bool
Eq, Eq LineSpan
LineSpan -> LineSpan -> Bool
LineSpan -> LineSpan -> Ordering
LineSpan -> LineSpan -> LineSpan
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LineSpan -> LineSpan -> LineSpan
$cmin :: LineSpan -> LineSpan -> LineSpan
max :: LineSpan -> LineSpan -> LineSpan
$cmax :: LineSpan -> LineSpan -> LineSpan
>= :: LineSpan -> LineSpan -> Bool
$c>= :: LineSpan -> LineSpan -> Bool
> :: LineSpan -> LineSpan -> Bool
$c> :: LineSpan -> LineSpan -> Bool
<= :: LineSpan -> LineSpan -> Bool
$c<= :: LineSpan -> LineSpan -> Bool
< :: LineSpan -> LineSpan -> Bool
$c< :: LineSpan -> LineSpan -> Bool
compare :: LineSpan -> LineSpan -> Ordering
$ccompare :: LineSpan -> LineSpan -> Ordering
Ord)

lineSpanAttribute :: LineSpan -> Attribute
lineSpanAttribute :: LineSpan -> Attribute
lineSpanAttribute LineSpan
lsp =
    let color :: Text
color = case LineSpan -> Color
lspColor LineSpan
lsp of
            Color
Reachable   -> Text
"lightgreen"
            Color
Unreachable -> Text
"yellow"
    in  forall arg result. TermRaw arg result => arg -> result
style_ forall a b. (a -> b) -> a -> b
$ Text
"background-color:" forall a. Semigroup a => a -> a -> a
<> Text
color

lineSpans :: (Int -> Int) -> Span -> [LineSpan]
lineSpans :: (Int -> Int) -> Span -> [LineSpan]
lineSpans Int -> Int
cols Span
sp
    | Span -> Int
spStartLine Span
sp forall a. Eq a => a -> a -> Bool
== Span -> Int
spEndLine Span
sp = forall (m :: * -> *) a. Monad m => a -> m a
return LineSpan
        { lspLine :: Int
lspLine        = Span -> Int
spStartLine Span
sp
        , lspStartColumn :: Int
lspStartColumn = Span -> Int
spStartColumn Span
sp
        , lspEndColumn :: Int
lspEndColumn   = Span -> Int
spEndColumn Span
sp
        , lspColor :: Color
lspColor       = Span -> Color
spColor Span
sp
        }
    | Bool
otherwise =
        let lsp1 :: LineSpan
lsp1  = LineSpan
                        { lspLine :: Int
lspLine        = Span -> Int
spStartLine Span
sp
                        , lspStartColumn :: Int
lspStartColumn = Span -> Int
spStartColumn Span
sp
                        , lspEndColumn :: Int
lspEndColumn   = Int -> Int
cols forall a b. (a -> b) -> a -> b
$ Span -> Int
spStartLine Span
sp
                        , lspColor :: Color
lspColor       = Span -> Color
spColor Span
sp
                        }
            lsp :: Int -> LineSpan
lsp Int
i = LineSpan
                        { lspLine :: Int
lspLine        = Int
i
                        , lspStartColumn :: Int
lspStartColumn = Int
1
                        , lspEndColumn :: Int
lspEndColumn   = Int -> Int
cols Int
i
                        , lspColor :: Color
lspColor       = Span -> Color
spColor Span
sp
                        }
            lsp2 :: LineSpan
lsp2  = LineSpan
                        { lspLine :: Int
lspLine        = Span -> Int
spEndLine Span
sp
                        , lspStartColumn :: Int
lspStartColumn = Int
1
                        , lspEndColumn :: Int
lspEndColumn   = Span -> Int
spEndColumn Span
sp
                        , lspColor :: Color
lspColor       = Span -> Color
spColor Span
sp
                        }
        in  LineSpan
lsp1 forall a. a -> [a] -> [a]
: [Int -> LineSpan
lsp Int
i | Int
i <- [Span -> Int
spStartLine Span
sp forall a. Num a => a -> a -> a
+ Int
1 .. Span -> Int
spEndLine Span
sp forall a. Num a => a -> a -> a
- Int
1]] forall a. [a] -> [a] -> [a]
++ [LineSpan
lsp2]

layout :: [Text] -> [Span] -> [(Int, Text, [LineSpan])]
layout :: [Text] -> [Span] -> [(Int, Text, [LineSpan])]
layout [Text]
ts [Span]
ss =
    let m1 :: IntMap (Text, Int, [a])
m1 = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int
i, (Text
t, Text -> Int
T.length Text
t, [])) | (Int
i, Text
t) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Text]
ts]
        m2 :: IntMap (Text, Int, [LineSpan])
m2 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap (Text, Int, [LineSpan])
-> Span -> IntMap (Text, Int, [LineSpan])
f forall {a}. IntMap (Text, Int, [a])
m1 [Span]
ss :: IntMap (Text, Int, [LineSpan])
    in  [(Int
i, Text
t, [LineSpan]
lsps) | (Int
i, (Text
t, [LineSpan]
lsps)) <- forall a. IntMap a -> [(Int, a)]
IM.toList forall a b. (a -> b) -> a -> b
$ (Text, Int, [LineSpan]) -> (Text, [LineSpan])
j forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntMap (Text, Int, [LineSpan])
m2]
  where
    f :: IntMap (Text, Int, [LineSpan]) -> Span -> IntMap (Text, Int, [LineSpan])
    f :: IntMap (Text, Int, [LineSpan])
-> Span -> IntMap (Text, Int, [LineSpan])
f IntMap (Text, Int, [LineSpan])
m = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' IntMap (Text, Int, [LineSpan])
-> LineSpan -> IntMap (Text, Int, [LineSpan])
g IntMap (Text, Int, [LineSpan])
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Span -> [LineSpan]
lineSpans Int -> Int
lookup'
      where lookup' :: Int -> Int
lookup' Int
i = case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap (Text, Int, [LineSpan])
m of
                Maybe (Text, Int, [LineSpan])
Nothing        -> Int
0
                Just (Text
_, Int
l, [LineSpan]
_) -> Int
l

    g :: IntMap (Text, Int, [LineSpan]) -> LineSpan -> IntMap (Text, Int, [LineSpan])
    g :: IntMap (Text, Int, [LineSpan])
-> LineSpan -> IntMap (Text, Int, [LineSpan])
g IntMap (Text, Int, [LineSpan])
m LineSpan
lsp = forall a. (a -> a) -> Int -> IntMap a -> IntMap a
IM.adjust (LineSpan -> (Text, Int, [LineSpan]) -> (Text, Int, [LineSpan])
h LineSpan
lsp) (LineSpan -> Int
lspLine LineSpan
lsp) IntMap (Text, Int, [LineSpan])
m

    h :: LineSpan -> (Text, Int, [LineSpan]) -> (Text, Int, [LineSpan])
    h :: LineSpan -> (Text, Int, [LineSpan]) -> (Text, Int, [LineSpan])
h LineSpan
lsp (Text
t, Int
l, [LineSpan]
lsps) = (Text
t, Int
l, LineSpan
lsp forall a. a -> [a] -> [a]
: [LineSpan]
lsps)

    j :: (Text, Int, [LineSpan]) -> (Text, [LineSpan])
    j :: (Text, Int, [LineSpan]) -> (Text, [LineSpan])
j (Text
t, Int
_, [LineSpan]
lsps) = (Text
t, forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` LineSpan -> Int
lspStartColumn) [LineSpan]
lsps)