{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Text
-- Copyright   :  (c) 2011-2015 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Very basic text primitives along with associated attributes.
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Text (
  -- * Creating text diagrams
    Text(..), TextAlignment(..)
  , text, topLeftText, alignedText, baselineText
  , mkText, mkText'

  -- * Text attributes

  -- ** Font family
  , Font(..), _Font
  , getFont, font, _font

  -- ** Font size
  , FontSize(..), _FontSize
  , fontSize, recommendFontSize
  , fontSizeN, fontSizeO, fontSizeL, fontSizeG
  , getFontSize, fontSizeM
  , _fontSizeR, _fontSize, _fontSizeU

  -- ** Font slant
  , FontSlant(..)
  , getFontSlant, fontSlant, italic, oblique, _fontSlant

  -- ** Font weight
  , FontWeight(..)
  , getFontWeight, fontWeight, bold, bolder, lighter, _fontWeight
  , thinWeight, ultraLight, light, mediumWeight, heavy, semiBold, ultraBold

  ) where

import           Control.Lens             hiding (transform)
import           Diagrams.Attributes      (committed)
import           Diagrams.Core
import           Diagrams.Core.Envelope   (pointEnvelope)
import           Diagrams.TwoD.Attributes (recommendFillColor)
import           Diagrams.TwoD.Types

import           Data.Colour              hiding (over)
import           Data.Default.Class
import           Data.Monoid.Recommend
import           Data.Semigroup
import           Data.Typeable

import           Linear.Affine

------------------------------------------------------------
-- Text diagrams
------------------------------------------------------------

-- | A 'Text' primitive consists of the string contents, text alignment
--   and the transformation to be applied. The transformation is scale
--   invarient, the average scale of the transform should always be 1.
--   All text scaling is obtained from the 'FontSize' attribute.
--
--   This constructor should not be used directly. Use 'text',
--   'alignedText' or 'baselineText'.
data Text n = Text (T2 n) (TextAlignment n) String
  deriving Typeable

type instance V (Text n) = V2
type instance N (Text n) = n

instance Floating n => Transformable (Text n) where
  transform t (Text tt a s) = Text (t <> tt <> t') a s
    where t' = scaling (1 / avgScale t)

instance Floating n => HasOrigin (Text n) where
  moveOriginTo p = translate (origin .-. p)

instance Floating n => Renderable (Text n) NullBackend where
  render _ _ = mempty

-- | @TextAlignment@ specifies the alignment of the text's origin.
data TextAlignment n = BaselineText | BoxAlignedText n n

-- | Make a text from a 'TextAlignment', recommending a fill colour of
--   'black' and 'fontSize' of @'local' 1@.
mkText :: (TypeableFloat n, Renderable (Text n) b)
  => TextAlignment n -> String -> QDiagram b V2 n Any
mkText a = recommendFillColor black
           -- See Note [recommendFillColor]
         . recommendFontSize (local 1)
           -- See Note [recommendFontSize]
         . mkText' a

-- | Make a text from a 'TextAlignment' without any default size or fill
--   colour. This is useful is you want to recommend your own using
--   'recommendFillColor' or 'recommendFontSize'.
mkText' :: (TypeableFloat n, Renderable (Text n) b)
  => TextAlignment n -> String -> QDiagram b V2 n Any
mkText' a t = mkQD (Prim $ Text mempty a t)
                   (pointEnvelope origin)
                   mempty
                   mempty
                   mempty


-- ~~~~ Note [recommendFillColor]

-- The reason we "recommend" a fill color of black instead of setting
-- it directly (or instead of simply not specifying a fill color at
-- all) was originally to support the SVG backend, though it is
-- actually in some sense the "right thing" to do, and other backends
-- we add later may conceivably need it as well.  The cairo backend
-- defaults happen to be to use a transparent fill for paths and a
-- black fill for text.  The SVG standard, however, specifies a
-- default fill of black for everything (both text and paths).  In
-- order to correctly render paths with no fill set, the SVG backend
-- must therefore explicitly set the fill to transparent -- but this
-- meant that it was also drawing text with a transparent fill.  The
-- solution is that we now explicitly inform all backends that the
-- *default* ("recommended") fill color for text should be black; an
-- absence of fill specification now consistently means to use a
-- "transparent" fill no matter what the primitive.  The reason we
-- need the special recommend/commit distinction is because if the
-- user explicitly sets a fill color later it should override this
-- recommendation; normally, the innermost occurrence of an attribute
-- would override all outer occurrences.

-- ~~~~ Note [recommendFontSize]
-- The reason we "recommend" a font size is so any local scales get
-- recorded.

-- | Create a primitive text diagram from the given string, with center
--   alignment, equivalent to @'alignedText' 0.5 0.5@.
--
--   Note that it /takes up no space/, as text size information is not
--   available.
text :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
text = alignedText 0.5 0.5

-- | Create a primitive text diagram from the given string, origin at
--   the top left corner of the text's bounding box, equivalent to
--   @'alignedText' 0 1@.
--
--   Note that it /takes up no space/.
topLeftText :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
topLeftText = alignedText 0 1

-- | Create a primitive text diagram from the given string, with the
--   origin set to a point interpolated within the bounding box.  The
--   first parameter varies from 0 (left) to 1 (right), and the second
--   parameter from 0 (bottom) to 1 (top). Some backends do not
--   implement this and instead snap to closest corner or the center.
--
--   The height of this box is determined by the font's potential ascent
--   and descent, rather than the height of the particular string.
--
--   Note that it /takes up no space/.
alignedText :: (TypeableFloat n, Renderable (Text n) b)
  => n -> n -> String -> QDiagram b V2 n Any
alignedText w h = mkText (BoxAlignedText w h)

-- | Create a primitive text diagram from the given string, with the
--   origin set to be on the baseline, at the beginning (although not
--   bounding).  This is the reference point of showText in the Cairo
--   graphics library.
--
--   Note that it /takes up no space/.
baselineText :: (TypeableFloat n, Renderable (Text n) b)
  => String -> QDiagram b V2 n Any
baselineText = mkText BaselineText

------------------------------------------------------------
-- Text attributes
------------------------------------------------------------

--------------------------------------------------
-- Font family

-- | The @Font@ attribute specifies the name of a font family.  Inner
--   @Font@ attributes override outer ones.
newtype Font = Font (Last String)
  deriving (Typeable, Semigroup, Eq)

_Font :: Iso' Font String
_Font = iso getFont (Font . Last)

instance AttributeClass Font

-- | Extract the font family name from a @Font@ attribute.
getFont :: Font -> String
getFont (Font (Last f)) = f

-- | Specify a font family to be used for all text within a diagram.
font :: HasStyle a => String -> a -> a
font = applyAttr . Font . Last

-- | Lens onto the font name of a style.
_font :: Lens' (Style v n) (Maybe String)
_font = atAttr . mapping _Font

--------------------------------------------------
-- Font size

-- | The @FontSize@ attribute specifies the size of a font's
--   em-square.  Inner @FontSize@ attributes override outer ones.
newtype FontSize n = FontSize (Recommend (Last n))
  deriving (Typeable, Semigroup)

-- not sure why this can't be derived
instance Functor FontSize where
  fmap f (FontSize (Recommend (Last a))) = FontSize (Recommend (Last (f a)))
  fmap f (FontSize (Commit (Last a)))    = FontSize (Commit (Last (f a)))

_FontSize :: Iso' (FontSize n) (Recommend n)
_FontSize = iso getter setter
  where getter (FontSize (Recommend (Last a))) = Recommend a
        getter (FontSize (Commit    (Last a))) = Commit a
        setter (Recommend a) = FontSize $ Recommend (Last a)
        setter (Commit    a) = FontSize $ Commit (Last a)
      -- = iso (\(FontSize a) -> a) FontSize . mapping _Wrapped
      -- once we depend on monoid-extras-0.4

_FontSizeM :: Iso' (FontSizeM n) (Measured n (Recommend n))
_FontSizeM = mapping _FontSize

type FontSizeM n = Measured n (FontSize n)

instance Typeable n => AttributeClass (FontSize n)

instance Num n => Default (FontSizeM n) where
  def = FontSize . Recommend . Last <$> local 1

-- | Extract the size from a @FontSize@ attribute.
getFontSize :: FontSize n -> n
getFontSize (FontSize (Recommend (Last s))) = s
getFontSize (FontSize (Commit (Last s)))    = s

-- | Set the font size, that is, the size of the font's em-square as
--   measured within the current local vector space. The default size
--   is @local 1@ (which is applied by 'recommendFontSize').
fontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a
fontSize = applyMAttr . fmap (FontSize . Commit . Last)

-- | 'Recommend' a font size. Any use of 'fontSize' above this will
--   overwrite any recommended size. This should only be used with
--   'mkText'', other text functions already has a recommended font
--   size so this will be ignored.
recommendFontSize :: (N a ~ n, Typeable n, HasStyle a) => Measure n -> a -> a
recommendFontSize = applyMAttr . fmap (FontSize . Recommend . Last)

-- | A convenient synonym for 'fontSize (Global w)'.
fontSizeG :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a
fontSizeG = fontSize . global

-- | A convenient synonym for 'fontSize (Normalized w)'.
fontSizeN :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a
fontSizeN = fontSize . normalized

-- | A convenient synonym for 'fontSize (Output w)'.
fontSizeO :: (N a ~ n, Typeable n, HasStyle a) => n -> a -> a
fontSizeO = fontSize . output

-- | A convenient sysnonym for 'fontSize (Local w)'.
fontSizeL :: (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a
fontSizeL = fontSize . local

-- | Apply a 'FontSize' attribute.
fontSizeM :: (N a ~ n, Typeable n, HasStyle a) => FontSizeM n -> a -> a
fontSizeM = applyMAttr

_fontSizeR :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measured n (Recommend n))
_fontSizeR = atMAttr . anon def (const False) . _FontSizeM

-- | Lens to commit a font size. This is *not* a valid lens (see
--   'commited'.
_fontSize :: (Typeable n, OrderedField n) => Lens' (Style v n) (Measure n)
_fontSize = _fontSizeR . mapping committed

_fontSizeU :: (Typeable n) => Lens' (Style v n) (Maybe n)
_fontSizeU = atAttr . mapping (_FontSize . committed)

--------------------------------------------------
-- Font slant

-- | The @FontSlantA@ attribute specifies the slant (normal, italic,
--   or oblique) that should be used for all text within a diagram.
--   Inner @FontSlantA@ attributes override outer ones.
data FontSlant = FontSlantNormal
               | FontSlantItalic
               | FontSlantOblique
  deriving (Eq, Show, Typeable, Ord)

instance AttributeClass FontSlant where
instance Semigroup FontSlant where
  _ <> b = b

instance Default FontSlant where
  def = FontSlantNormal

-- | Extract the font slant from a 'FontSlantA' attribute.
getFontSlant :: FontSlant -> FontSlant
getFontSlant = id

-- | Specify the slant (normal, italic, or oblique) that should be
--   used for all text within a diagram.  See also 'italic' and
--   'oblique' for useful special cases.
fontSlant :: HasStyle a => FontSlant -> a -> a
fontSlant = applyAttr

-- | Lens onto the font slant in a style.
_fontSlant :: Lens' (Style v n) FontSlant
_fontSlant = atAttr . non def

-- | Set all text in italics.
italic :: HasStyle a => a -> a
italic = fontSlant FontSlantItalic

-- | Set all text using an oblique slant.
oblique :: HasStyle a => a -> a
oblique = fontSlant FontSlantOblique

--------------------------------------------------
-- Font weight

-- | The @FontWeightA@ attribute specifies the weight (normal or bold)
--   that should be used for all text within a diagram.  Inner
--   @FontWeightA@ attributes override outer ones.
data FontWeight = FontWeightNormal
                | FontWeightBold
                | FontWeightBolder
                | FontWeightLighter
                | FontWeightThin
                | FontWeightUltraLight
                | FontWeightLight
                | FontWeightMedium
                | FontWeightSemiBold
                | FontWeightUltraBold
                | FontWeightHeavy
    deriving (Eq,
              Ord, Show, Typeable)

instance AttributeClass FontWeight

-- | Last semigroup structure
instance Semigroup FontWeight where
  _ <> b = b

instance Default FontWeight where
  def = FontWeightNormal

-- | Extract the font weight.
getFontWeight :: FontWeight -> FontWeight
getFontWeight = id

-- | Specify the weight (normal, bolder, lighter or bold) that should be
--   used for all text within a diagram.  See also 'bold'
--   for a useful special case.
fontWeight :: HasStyle a => FontWeight -> a -> a
fontWeight = applyAttr

-- | Set all text using a bold font weight.
bold :: HasStyle a => a -> a
bold = fontWeight FontWeightBold

-- | Set all text using a thin font weight.
thinWeight :: HasStyle a => a -> a
thinWeight = fontWeight FontWeightThin

-- | Set all text using a extra light font weight.
ultraLight :: HasStyle a => a -> a
ultraLight = fontWeight FontWeightUltraLight

-- | Set all text using a light font weight.
light :: HasStyle a => a -> a
light = fontWeight FontWeightLight

-- | Set all text using a medium font weight.
mediumWeight :: HasStyle a => a -> a
mediumWeight = fontWeight FontWeightMedium

-- | Set all text using a semi-bold font weight.
semiBold :: HasStyle a => a -> a
semiBold = fontWeight FontWeightSemiBold

-- | Set all text using an ultra-bold font weight.
ultraBold :: HasStyle a => a -> a
ultraBold = fontWeight FontWeightUltraBold

-- | Set all text using a heavy/black font weight.
heavy :: HasStyle a => a -> a
heavy = fontWeight FontWeightHeavy

-- | Set all text to be bolder than the inherited font weight.
bolder :: HasStyle a => a -> a
bolder = fontWeight FontWeightBolder

-- | Set all text to be lighter than the inherited font weight.
lighter :: HasStyle a => a -> a
lighter = fontWeight FontWeightLighter

-- | Lens onto the font weight in a style.
_fontWeight :: Lens' (Style v n) FontWeight
_fontWeight = atAttr . non def