Compile.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Attributes.Compile
-- Copyright   :  (c) 2014 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- XXX
--
-----------------------------------------------------------------------------

module Diagrams.Attributes.Compile (
    SplitAttribute(..), splitAttr
  ) where

import           Data.Typeable

import           Control.Arrow       (second)
import           Control.Lens        ((%~), (&), _Wrapping')
import qualified Data.Map            as M
import           Data.Semigroup      ((<>))
import           Data.Tree           (Tree (..))

import           Diagrams.Core
import           Diagrams.Core.Style (Style (..), attrToStyle)
import           Diagrams.Core.Types (RNode (..), RTree)

------------------------------------------------------------

-- This is a sort of roundabout, overly-general way to define
-- splitFills; it's done this way to facilitate testing.

class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where
  type AttrType code :: *
  type PrimType code :: *

  primOK :: code -> PrimType code -> Bool

-- | Push certain attributes down until they are at the roots of trees
--   containing only "safe" nodes.  In particular this is used to push
--   fill attributes down until they are over only loops; see
--   'splitFills'.
splitAttr :: forall code b v a. SplitAttribute code => code -> RTree b v a -> RTree b v a
splitAttr code = fst . splitAttr' Nothing
  where

  -- splitAttr' is where the most interesting logic happens.
  -- Mutually recursive with splitAttr'Forest. rebuildNode and
  -- applyMfc are helper functions.
  --
  -- Input: attribute to apply to "safe" subtrees.
  --
  -- Output: tree with attributes pushed down appropriately, and
  -- a Bool indicating whether the tree contains only "safe" prims (True) or
  -- contains some unsafe ones (False).
  splitAttr' :: Maybe (AttrType code) -> RTree b v a -> (RTree b v a, Bool)

  -- RStyle node: Check for the special attribute, and split it out of
  -- the style, combining it with the incoming attribute.  Recurse and
  -- rebuild. The tricky bit is that we use some knot-tying to
  -- determine the right attribute to pass down to the subtrees based
  -- on this computed Bool: if all subtrees are safe, then we will
  -- apply the attribute at the root of this tree, and pass Nothing to
  -- all the subtrees.  Otherwise, we pass the given attribute along.
  -- This works out because the attribute does not need to be
  -- pattern-matched until actually applying it at some root, so the
  -- recursion can proceed and the Bool values be computed with the
  -- actual value of the attributes nodes filled in lazily.
  splitAttr' mattr (Node (RStyle sty) cs) = (t', ok)
    where
      mattr' = mattr <> getAttr sty
      sty' = sty & _Wrapping' Style %~ M.delete ty
      ty   = show . typeOf $ (undefined :: AttrType code)
      (cs', ok) = splitAttr'Forest mattr' cs
      t' | ok        = rebuildNode Nothing ok (RStyle sty) cs'
         | otherwise = rebuildNode mattr ok (RStyle sty') cs'

  -- RPrim node: check whether it
  --   * is some sort of prim not under consideration: don't apply the attribute; return True
  --   * is unsafe: don't apply the attribute; return False
  --   * is safe  :  do   apply the attribute; return True
  splitAttr' mattr (Node rp@(RPrim (Prim prm)) _) =
      case cast prm :: Maybe (PrimType code) of
        Nothing  -> (Node rp [], True)
        Just p ->
          case primOK code p of
            True  -> (rebuildNode mattr True rp [], True)
            False -> (Node rp [], False)

  -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild.  Note
  -- we assume that transformations do not affect the attributes.
  splitAttr' mattr (Node nd cs)    = (t', ok)
    where
      (cs', ok) = splitAttr'Forest mattr cs
      t'        = rebuildNode mattr ok nd cs'

  -- Recursively call splitAttr' on all subtrees, returning the
  -- logical AND of the Bool results returned (the whole forest is
  -- safe iff all subtrees are).
  splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v a] -> ([RTree b v a], Bool)
  splitAttr'Forest mattr cs = (cs', ok)
    where
      (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs

  -- Given a fill attribute, a Bool indicating whether the given
  -- subforest contains only loops, a node, and a subforest, rebuild a
  -- tree, applying the fill attribute as appropriate (only if the
  -- Bool is true and the attribute is not Nothing).
  rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a
  rebuildNode mattr ok nd cs
    | ok        = applyMattr mattr (Node nd cs)
    | otherwise = Node nd cs

  -- Prepend a new fill color node if Just; the identity function if
  -- Nothing.
  applyMattr :: Maybe (AttrType code) -> RTree b v a -> RTree b v a
  applyMattr Nothing  t = t
  applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t]