{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE OverloadedStrings          #-}
-- |
-- Module:     Typograffiti.Monad
-- Copyright:  (c) 2018 Schell Scivally
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--             & Adrian Cochrane <alcinnz@argonaut-constellation.org>
--
-- Text rendering abstraction, hiding the details of
-- the Atlas, Cache, and the Harfbuzz library.
module Typograffiti.Text where


import           Control.Monad.Except   (MonadError (..), runExceptT)
import           Control.Monad.Fail     (MonadFail (..))
import           Control.Monad.IO.Class (MonadIO (..))
import           Control.Monad          (foldM, forM, unless)
import qualified Data.IntSet            as IS
import           Linear                 (V2 (..))
import qualified Data.ByteString        as B
import           Data.Text.Glyphize     (defaultBuffer, shape, GlyphInfo (..),
                                        parseFeature, parseVariation, Variation (..),
                                        FontOptions (..), defaultFontOptions)
import qualified Data.Text.Glyphize     as HB
import           FreeType.Core.Base
import           FreeType.Core.Types    (FT_Fixed, FT_UShort)
import           FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates)
import           Data.Text.Lazy         (Text, pack)
import qualified Data.Text.Lazy         as Txt
import           Data.Word              (Word32)
import           Foreign.Storable       (peek)

import           Typograffiti.Atlas
import           Typograffiti.Cache
import           Typograffiti.Rich      (RichText(..))

-- | How large the text should be rendered.
data GlyphSize = CharSize Float Float Int Int
                -- ^ Size in Pts at given DPI.
               | PixelSize Int Int
               -- ^ Size in device pixels.
               deriving (Show, Eq, Ord)

-- | Extra parameters for constructing a font atlas,
-- and determining which glyphs should be in it.
data SampleText = SampleText {
    sampleFeatures :: [HB.Feature],
    -- ^ Which OpenType Features you want available to be used in the rendered text.
    -- Defaults to none.
    sampleText :: Text,
    -- ^ Indicates which characters & ligatures will be in the text to be rendered.
    -- Defaults to ASCII, no ligatures.
    tabwidth :: Int,
    -- ^ How many spaces wide should a tab be rendered?
    -- Defaults to 4 spaces.
    fontOptions :: FontOptions,
    -- ^ Additional font options offered by Harfbuzz.
    minLineHeight :: Float
    -- ^ Number of pixels tall each line should be at minimum.
    -- Defaults to 0 indicate to use the font's default lineheight.
}

-- | Constructs a `SampleText` with default values.
defaultSample :: SampleText
defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions 0
-- | Appends an OpenType feature callers may use to the `Sample` ensuring its
-- glyphs are available. Call after setting `sampleText`.
addSampleFeature :: String -> Word32 -> SampleText -> SampleText
addSampleFeature name value sample@SampleText {..} = sample {
        sampleFeatures =
            HB.Feature (HB.tag_from_string name) value (n*i) (n*succ i) : sampleFeatures
    }
  where
    n = w $ fromEnum $ Txt.length sampleText
    i = w $ length sampleFeatures
    w :: Int -> Word
    w = toEnum
-- | Parse an OpenType feature into this font using syntax akin to
-- CSS font-feature-settings.
parseSampleFeature :: String -> SampleText -> SampleText
parseSampleFeature syntax sample | Just feat <- parseFeature syntax = sample {
        sampleFeatures = feat : sampleFeatures sample
    }
  | otherwise = sample
-- | Parse multiple OpenType features into this font.
parseSampleFeatures :: [String] -> SampleText -> SampleText
parseSampleFeatures = flip $ foldl $ flip parseSampleFeature
-- | Alter which OpenType variant of this font will be rendered.
-- Please check your font which variants are supported.
addFontVariant :: String -> Float -> SampleText -> SampleText
addFontVariant name val sampleText = sampleText {
    fontOptions = (fontOptions sampleText) {
        optionVariations = Variation (HB.tag_from_string name) val :
            optionVariations (fontOptions sampleText)
    }
  }
-- | Parse a OpenType variant into the configured font using syntax akin to
-- CSS font-variant-settings.
parseFontVariant :: String -> SampleText -> SampleText
parseFontVariant syntax sample | Just var <- parseVariation syntax = sample {
        fontOptions = (fontOptions sample) {
            optionVariations = var : optionVariations (fontOptions sample)
        }
    }
  | otherwise = sample
-- | Parse multiple OpenType variants into this font.
parseFontVariants :: [String] -> SampleText -> SampleText
parseFontVariants = flip $ foldl $ flip parseFontVariant

-- | Standard italic font variant. Please check if your font supports this.
varItalic = "ital"
-- | Standard optical size font variant. Please check if your font supports this.
varOptSize = "opsz"
-- | Standard slant (oblique) font variant. Please check if your font supports this.
varSlant = "slnt"
-- | Standard width font variant. Please check if your font supports this.
varWidth = "wdth"
-- | Standard weight (boldness) font variant. Please check if your font supports this.
varWeight = "wght"

-- | Opens a font sized to the given value & prepare to render text in it.
-- There is no need to keep the given `FT_Library` live before rendering the text.
makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m,
    MonadIO n, MonadFail n, MonadError TypograffitiError n) =>
    FT_Library -> FilePath -> Int -> GlyphSize -> SampleText ->
    m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawText lib filepath index fontsize SampleText {..} = do
    font <- liftFreetype $ ft_New_Face lib filepath $ toEnum index
    liftFreetype $ case fontsize of
        PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h)
        CharSize w h dpix dpiy -> ft_Set_Char_Size font (floor $ 26.6 * 2 * w)
                                                    (floor $ 26.6 * 2 * h)
                                                    (toEnum dpix) (toEnum dpiy)

    font_ <- liftIO $ peek font
    size <- srMetrics <$> liftIO (peek $ frSize font_)
    let lineHeight = if minLineHeight == 0 then fixed2float $ smHeight size else minLineHeight
    let upem = short2float $ frUnits_per_EM font_
    let scale = (short2float (smX_ppem size)/upem/2, short2float (smY_ppem size)/upem/2)

    bytes <- liftIO $ B.readFile filepath
    let fontOpts' = fontOptions {
            HB.optionScale = Nothing, HB.optionPtEm = Nothing, HB.optionPPEm = Nothing
      }
    let font' = HB.createFontWithOptions fontOpts' $ HB.createFace bytes $ toEnum index
    let glyphs = map (codepoint . fst) $
            shape font' defaultBuffer {
                HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText
            } sampleFeatures
    let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs

    let designCoords = map float2fixed $ HB.fontVarCoordsDesign font'
    unless (null designCoords) $
        liftFreetype $ ft_Set_Var_Design_Coordinates font designCoords

    atlas <- allocAtlas (glyphRetriever font) glyphs' scale
    liftFreetype $ ft_Done_Face font

    drawGlyphs <- makeDrawGlyphs
    return $ freeAtlasWrapper atlas $ drawLinesWrapper tabwidth lineHeight
        $ \RichText {..} ->
            drawGlyphs atlas $ shape font' defaultBuffer { HB.text = text } features
  where
    x2 = (*2)
    float2fixed :: Float -> FT_Fixed
    float2fixed = toEnum . fromEnum . (*bits16)
    fixed2float :: FT_Fixed -> Float
    fixed2float = (/bits16) . toEnum . fromEnum
    bits16 = 2**16
    short2float :: FT_UShort -> Float
    short2float = toEnum . fromEnum

-- | Variant of `makeDrawText` which initializes FreeType itself.
makeDrawText' a b c d =
    ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d

-- | Internal utility for rendering multiple lines of text & expanding tabs as configured.
type TextRenderer m = RichText -> m (AllocatedRendering [TextTransform])
drawLinesWrapper :: (MonadIO m, MonadFail m) => Int -> Float -> TextRenderer m -> TextRenderer m
drawLinesWrapper indent lineheight cb RichText {..} = do
    let features' = splitFeatures 0 features (Txt.lines text) ++ repeat []
    let cb' (a, b) = cb $ RichText a b
    renderers <- mapM cb' $ flip zip features' $ map processLine $ Txt.lines text
    let drawLine ts wsz y renderer = do
            arDraw renderer (move 0 y:ts) wsz
            let V2 _ height = arSize renderer
            return (y + max lineheight (toEnum height))
    let draw ts wsz = do
            foldM (drawLine ts wsz) 0 renderers
            return ()
    let sizes = map arSize renderers
    let size = V2 (maximum [x | V2 x _ <- sizes]) (sum [y | V2 _ y <- sizes])
    let release = do
            forM renderers arRelease
            return ()
    return AllocatedRendering {
            arDraw = draw,
            arRelease = release,
            arSize = size
          }
  where
    splitFeatures :: Word -> [HB.Feature] -> [Text] -> [[HB.Feature]]
    splitFeatures _ [] _ = []
    splitFeatures _ _ [] = []
    splitFeatures offset features' (line:lines') = let n = fromEnum $ Txt.length line
        in [feat {
                HB.featStart = max 0 (start - offset),
                HB.featEnd = min (toEnum n) (end - offset)
              }
            | feat@HB.Feature {HB.featStart = start, HB.featEnd = end} <- features',
            fromEnum end <= n + fromEnum offset && end >= offset] :
            splitFeatures (offset + toEnum n) features' lines'

    processLine :: Text -> Text
    processLine cs = expandTabs 0 cs
    -- monospace tabshaping, good enough outside full line-layout.
    expandTabs n cs = case Txt.break (== '\t') cs of
        (tail, "") -> tail
        (pre, cs') ->
            let spaces = indent - ((fromEnum (Txt.length pre) + fromEnum n) `rem` indent)
            in Txt.concat [pre, Txt.replicate (toEnum spaces) " ",
                expandTabs (n + Txt.length pre + toEnum spaces) $ Txt.tail cs']

freeAtlasWrapper :: MonadIO m => Atlas -> TextRenderer m -> TextRenderer m
freeAtlasWrapper atlas cb text = do
    ret <- cb text
    return ret {
        arRelease = do
            arRelease ret
            freeAtlas atlas
    }