{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Diagrams.Attributes.Compile (
SplitAttribute(..), splitAttr
) where
import Data.Typeable
import Control.Arrow (second)
import Control.Lens ((%~), (&), _Wrapping')
import qualified Data.HashMap.Strict as HM
import Data.Semigroup
import Data.Tree (Tree (..))
import Diagrams.Core
import Diagrams.Core.Style (Style (..), attributeToStyle)
import Diagrams.Core.Types (RNode (..), RTree)
class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where
type AttrType code :: *
type PrimType code :: *
primOK :: code -> PrimType code -> Bool
splitAttr :: forall code b v n a. SplitAttribute code => code -> RTree b v n a -> RTree b v n a
splitAttr :: code -> RTree b v n a -> RTree b v n a
splitAttr code :: code
code = (RTree b v n a, Bool) -> RTree b v n a
forall a b. (a, b) -> a
fst ((RTree b v n a, Bool) -> RTree b v n a)
-> (RTree b v n a -> (RTree b v n a, Bool))
-> RTree b v n a
-> RTree b v n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool)
splitAttr' Maybe (AttrType code)
forall a. Maybe a
Nothing
where
splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool)
splitAttr' :: Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool)
splitAttr' mattr :: Maybe (AttrType code)
mattr (Node (RStyle sty :: Style v n
sty) cs :: Forest (RNode b v n a)
cs) = (RTree b v n a
t', Bool
ok)
where
mattr' :: Maybe (AttrType code)
mattr' = Maybe (AttrType code)
mattr Maybe (AttrType code)
-> Maybe (AttrType code) -> Maybe (AttrType code)
forall a. Semigroup a => a -> a -> a
<> Style v n -> Maybe (AttrType code)
forall a (v :: * -> *) n. AttributeClass a => Style v n -> Maybe a
getAttr Style v n
sty
sty' :: Style v n
sty' = Style v n
sty Style v n -> (Style v n -> Style v n) -> Style v n
forall a b. a -> (a -> b) -> b
& (Unwrapped (Style v n) -> Style v n)
-> Iso' (Style v n) (Unwrapped (Style v n))
forall s. Wrapped s => (Unwrapped s -> s) -> Iso' s (Unwrapped s)
_Wrapping' Unwrapped (Style v n) -> Style v n
forall (v :: * -> *) n.
HashMap TypeRep (Attribute v n) -> Style v n
Style ((HashMap TypeRep (Attribute v n)
-> Identity (HashMap TypeRep (Attribute v n)))
-> Style v n -> Identity (Style v n))
-> (HashMap TypeRep (Attribute v n)
-> HashMap TypeRep (Attribute v n))
-> Style v n
-> Style v n
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ TypeRep
-> HashMap TypeRep (Attribute v n)
-> HashMap TypeRep (Attribute v n)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HM.delete TypeRep
ty
ty :: TypeRep
ty = AttrType code -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (AttrType code
forall a. HasCallStack => a
undefined :: AttrType code)
(cs' :: Forest (RNode b v n a)
cs', ok :: Bool
ok) = Maybe (AttrType code)
-> Forest (RNode b v n a) -> (Forest (RNode b v n a), Bool)
splitAttr'Forest Maybe (AttrType code)
mattr' Forest (RNode b v n a)
cs
t' :: RTree b v n a
t' | Bool
ok = Maybe (AttrType code)
-> Bool -> RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
rebuildNode Maybe (AttrType code)
forall a. Maybe a
Nothing Bool
ok (Style v n -> RNode b v n a
forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle Style v n
sty) Forest (RNode b v n a)
cs'
| Bool
otherwise = Maybe (AttrType code)
-> Bool -> RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
rebuildNode Maybe (AttrType code)
mattr Bool
ok (Style v n -> RNode b v n a
forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle Style v n
sty') Forest (RNode b v n a)
cs'
splitAttr' mattr :: Maybe (AttrType code)
mattr (Node rp :: RNode b v n a
rp@(RPrim (Prim prm :: p
prm)) _) =
case p -> Maybe (PrimType code)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
prm :: Maybe (PrimType code) of
Nothing -> (RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
forall a. a -> Forest a -> Tree a
Node RNode b v n a
rp [], Bool
True)
Just p :: PrimType code
p ->
if code -> PrimType code -> Bool
forall code. SplitAttribute code => code -> PrimType code -> Bool
primOK code
code PrimType code
p
then (Maybe (AttrType code)
-> Bool -> RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
rebuildNode Maybe (AttrType code)
mattr Bool
True RNode b v n a
rp [], Bool
True)
else (RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
forall a. a -> Forest a -> Tree a
Node RNode b v n a
rp [], Bool
False)
splitAttr' mattr :: Maybe (AttrType code)
mattr (Node nd :: RNode b v n a
nd cs :: Forest (RNode b v n a)
cs) = (RTree b v n a
t', Bool
ok)
where
(cs' :: Forest (RNode b v n a)
cs', ok :: Bool
ok) = Maybe (AttrType code)
-> Forest (RNode b v n a) -> (Forest (RNode b v n a), Bool)
splitAttr'Forest Maybe (AttrType code)
mattr Forest (RNode b v n a)
cs
t' :: RTree b v n a
t' = Maybe (AttrType code)
-> Bool -> RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
rebuildNode Maybe (AttrType code)
mattr Bool
ok RNode b v n a
nd Forest (RNode b v n a)
cs'
splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v n a] -> ([RTree b v n a], Bool)
splitAttr'Forest :: Maybe (AttrType code)
-> Forest (RNode b v n a) -> (Forest (RNode b v n a), Bool)
splitAttr'Forest mattr :: Maybe (AttrType code)
mattr cs :: Forest (RNode b v n a)
cs = (Forest (RNode b v n a)
cs', Bool
ok)
where
(cs' :: Forest (RNode b v n a)
cs', ok :: Bool
ok) = ([Bool] -> Bool)
-> (Forest (RNode b v n a), [Bool])
-> (Forest (RNode b v n a), Bool)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Forest (RNode b v n a), [Bool])
-> (Forest (RNode b v n a), Bool))
-> (Forest (RNode b v n a) -> (Forest (RNode b v n a), [Bool]))
-> Forest (RNode b v n a)
-> (Forest (RNode b v n a), Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RTree b v n a, Bool)] -> (Forest (RNode b v n a), [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(RTree b v n a, Bool)] -> (Forest (RNode b v n a), [Bool]))
-> (Forest (RNode b v n a) -> [(RTree b v n a, Bool)])
-> Forest (RNode b v n a)
-> (Forest (RNode b v n a), [Bool])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RTree b v n a -> (RTree b v n a, Bool))
-> Forest (RNode b v n a) -> [(RTree b v n a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (AttrType code) -> RTree b v n a -> (RTree b v n a, Bool)
splitAttr' Maybe (AttrType code)
mattr) (Forest (RNode b v n a) -> (Forest (RNode b v n a), Bool))
-> Forest (RNode b v n a) -> (Forest (RNode b v n a), Bool)
forall a b. (a -> b) -> a -> b
$ Forest (RNode b v n a)
cs
rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v n a -> [RTree b v n a] -> RTree b v n a
rebuildNode :: Maybe (AttrType code)
-> Bool -> RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
rebuildNode mattr :: Maybe (AttrType code)
mattr ok :: Bool
ok nd :: RNode b v n a
nd cs :: Forest (RNode b v n a)
cs
| Bool
ok = Maybe (AttrType code) -> RTree b v n a -> RTree b v n a
applyMattr Maybe (AttrType code)
mattr (RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
forall a. a -> Forest a -> Tree a
Node RNode b v n a
nd Forest (RNode b v n a)
cs)
| Bool
otherwise = RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
forall a. a -> Forest a -> Tree a
Node RNode b v n a
nd Forest (RNode b v n a)
cs
applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a
applyMattr :: Maybe (AttrType code) -> RTree b v n a -> RTree b v n a
applyMattr Nothing t :: RTree b v n a
t = RTree b v n a
t
applyMattr (Just a :: AttrType code
a) t :: RTree b v n a
t = RNode b v n a -> Forest (RNode b v n a) -> RTree b v n a
forall a. a -> Forest a -> Tree a
Node (Style v n -> RNode b v n a
forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle (Style v n -> RNode b v n a) -> Style v n -> RNode b v n a
forall a b. (a -> b) -> a -> b
$ Attribute v n -> Style v n
forall (v :: * -> *) n. Attribute v n -> Style v n
attributeToStyle (AttrType code -> Attribute v n
forall a (v :: * -> *) n. AttributeClass a => a -> Attribute v n
Attribute AttrType code
a)) [RTree b v n a
t]