{-# OPTIONS_GHC -fdefer-typed-holes #-}

import Prelude hiding (Word)
import Svg
import Glyphs (Glyph (..), Segs)
import qualified Glyphs as G
import Options.Applicative
import qualified Data.Text as Text
import Data.Functor
import Numeric
import Data.List.NonEmpty (NonEmpty (..))
import Data.Semigroup (sconcat)


data Options =
  Opts { width, size, stroke :: {-# UNPACK #-} !Double }
  deriving Show

options :: IO Options
options = execParser desc where
  desc = info (opts <**> helper) $
    fullDesc <> header "render lántas text as svg"
  opts =
    Opts <$> dimOpt  'W' "width" Nothing
         <*> (dimOpt' 'S' "size" "text size" (Just 10)
               <&> (/ G.lineHeight'))
         <*> dimOpt'  'K' "stroke" "line thickness" (Just 2)
  dimOpt s l d = dimOpt' s l l d
  dimOpt' s l n d = option auto $ mconcat $
    [short s, long l, help $ n <> " in pixels", metavar "SIZE"] <>
    maybe [] (\x -> [value x]) d

toPx :: Double -> Text
toPx x = Text.pack (showFFloat (Just 4) x "px")


data TextSize = T {width, height :: !Double}

run :: M a -> Env -> (a, TextSize)
run m e@(E {size, stroke}) =
    let (res, S {..}) = runState (runReaderT m e) s in
    (res, T {width = textWidth + 2 * margin, height = textHeight'})
  where
    margin = stroke
    ascHeight = size * 3
    s = S {x = margin, y = margin + ascHeight, textWidth = 0, textHeight' = 0}


type EGlyph = (Glyph, [Segs])
type Word   = [EGlyph]

doGlyphs :: [Word] -> Env -> Element
doGlyphs gs e = wrap $ run act e where
  act = do
    E {stroke} <- ask
    let gattrs = [Stroke_ <<- "black", Stroke_width_ <<- toPx stroke,
                  Stroke_linecap_ <<- "round", Fill_ <<- "none"]
    g_ gattrs . mconcat <$> traverse placeWord gs <* newline
  wrap (content, T {width, height}) =
    let sattrs = [Height_ <<- toPx height, Width_ <<- toPx width] in
    doctype <> svg11_ content `with` sattrs


eglyphWidth :: EGlyph -> M Double
eglyphWidth (G {width}, _) = G.withSize (* width)

wordWidth :: Word -> M Double
wordWidth = fmap sum . traverse eglyphWidth

placeWord :: Word -> M Element
placeWord w = do
  wwidth <- wordWidth w
  margin <- G.margin
  S {x} <- get
  E {width} <- ask
  if x > margin && x + wwidth > width then
    newline *> placeWord w
  else do
    mconcat <$> traverse placeGlyph w <* G.space

placeGlyph :: EGlyph -> M Element
placeGlyph (G {path = path1, width = w}, segss) = do
  E {size} <- ask
  S {x} <- get
  gwidth <- G.withSize (* w)
  path' <- G.joinSegs $ sconcat (path1 :| segss)
  modify \s -> s {x = x + gwidth + size}
  pure $ path_ [D_ <<- path']

newline :: M ()
newline = do
  lh <- G.lineHeight
  E {stroke = margin} <- ask
  modify \s@(S {x, y, textWidth, textHeight'}) ->
    s {x = margin, y = y + lh,
       textWidth = textWidth `max` x,
       textHeight' = textHeight' + lh}

main :: IO ()
main = do
  Opts {..} <- options
  let lántas = [(G.l, [G.dá]), (G.nt, [G.da]), (G.s0, [])]
  let res = doGlyphs [lántas, lántas] (E {..})
  writeFile "/home/niss/e.svg" $ show res