<commit_before>{-# LANGUAGE TypeFamilies
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
           , TypeSynonymInstances
           , DeriveDataTypeable
           , ViewPatterns
           , OverloadedStrings
           , TypeHoles
           , InstanceSigs
  #-}

module Diagrams.Backend.GHCJS
  ( Canvas(..)
  , Options(..)
  ) where

import           Control.Lens         hiding ((#))
import           Control.Monad        (when)
import           Control.Monad.Reader
import           Control.Monad.State
import qualified Data.Foldable        as F
import           Data.Maybe           (catMaybes, maybe, isJust, fromJust)
import           Data.Monoid          ((<>))
import           Data.Typeable
import qualified Data.Text            as T

import           Diagrams.Prelude     hiding ((<>), view)
import           Diagrams.TwoD.Adjust (adjustDia2D)
import           Diagrams.TwoD.Path   (getFillRule, Clip(..))
import           Diagrams.TwoD.Text   (getFont, getFontSize)
import qualified Diagrams.TwoD.Text   as D
import           Diagrams.Segment

import qualified Graphics.Rendering.GHCJS as G

-- | This data declaration is simply used as a token to distinguish this
-- rendering engine.
data Canvas = Canvas deriving Typeable

instance Monoid (Render Canvas R2) where
  mempty  = C $ return ()
  (C c1) `mappend` (C c2) = C (c1 >> c2)

-- | Did we see any lines in the most recent path (as opposed to loops)? If
-- so then we should ignore any fill attribute because diagrams-lib
-- separates lines and loops into separate path primitives so we don't have
-- to worry about seeing them in the same path
-- type G.Render a = StateT Bool G.Render a

instance Backend Canvas R2 where
    data Render  Canvas R2 = C (G.Render ())
    type Result  Canvas R2 = IO ()
    data Options Canvas R2 = CanvasOptions
            { canvasSize   :: SizeSpec2D   -- ^ the requested size
            , context      :: G.Context    -- ^ drawing context to render to
            }

    withStyle _ s t (C r) = C $ G.tempState $ do
        clearPath  -- path is not part of the drawing state :/
        canvasMiscStyle s
        G.setIgnoreFill False
        r
        ignoreFill <- G.getIgnoreFill
        canvasTransf t
        canvasStyle ignoreFill s
        G.stroke

    doRender _ (CanvasOptions _ c) (C r) = G.doRender c r

    adjustDia c opts d = adjustDia2D canvasSize setCanvasSize c opts
                         -- (d # reflectY # fcA transparent # lw 0.01)
                         (d # reflectY)
        where setCanvasSize sz o = o { canvasSize = sz }

clearPath :: G.Render()
clearPath = G.newPath >> G.closePath

renderC :: (Renderable a Canvas, V a ~ R2) => a -> G.Render ()
renderC a = case (render Canvas a) of C r -> r

canvasMiscStyle :: Style v -> G.Render ()
canvasMiscStyle s = sequence_ $ catMaybes
    [ handleClipping s
    , handleFont s
    , handle fColor
    , handle fRule
    ] where
        handle :: AttributeClass a => (a -> G.Render ()) -> Maybe (G.Render ())
        handle f = f `fmap` getAttr s
        fColor   = G.fillColor   . getFillColor
        fRule    = G.setFill     . getFillRule

handleFont s = Just $ G.setFont $
    G.fromFontSlant fontSlant
    <> G.fromFontWeight fontWeight
    <> T.pack (show fontSize)
    <> "px "
    <> (T.pack fontFamily)
    where
        fontFamily' = getAttr s :: Maybe (D.Font)
        fontSize'   = getAttr s :: Maybe (D.FontSize)
        fontSlant'  = getAttr s :: Maybe (D.FontSlantA)
        fontWeight' = getAttr s :: Maybe (D.FontWeightA)
        fontFamily  = maybe "Arial" getFont fontFamily'
        fontSize    = maybe 10 getFontSize fontSize'
        fontSlant   = maybe D.FontSlantNormal D.getFontSlant fontSlant'
        fontWeight  = maybe D.FontWeightNormal D.getFontWeight fontWeight'

handleClipping :: Style v -> Maybe (G.Render ())
handleClipping s = (clipCanv . view (unwrapping Clip)) `fmap` getAttr s

canvasStyle :: Bool -> Style v -> G.Render ()
canvasStyle ignoreFill s = foldr (>>) (return ()) . catMaybes $
    [ handle lColor
    , handle lWidth
    , handle lJoin
    , handle lCap
    , handle opacity_
    , handle dashing_
    , if ignoreFill then Nothing else handle fRule
    , if ignoreFill then Nothing else handle fColor
    ] where
        handle :: AttributeClass a => (a -> G.Render ()) -> Maybe (G.Render ())
        handle f = f `fmap` getAttr s
        lColor   = G.strokeColor . getLineColor
        fColor s = (G.fillColor   $ getFillColor s) >> G.fill
        lWidth   = G.lineWidth   . getLineWidth
        lCap     = G.lineCap     . getLineCap
        lJoin    = G.lineJoin    . getLineJoin
        opacity_ = G.globalAlpha . getOpacity
        fRule    = G.setFill     . getFillRule
        dashing_ = G.dashing     . getDashing

clipCanv :: [Path R2] -> G.Render ()
clipCanv pths = mapM_ renderPath pths >> G.clip

renderPath :: Path R2 -> G.Render ()
renderPath (Path trs) = G.newPath >> F.mapM_ renderTrail trs<commit_msg>remove unsupported TypeHoles extension and make compatible with lens 4<commit_after>{-# LANGUAGE TypeFamilies
           , MultiParamTypeClasses
           , FlexibleInstances
           , FlexibleContexts
           , TypeSynonymInstances
           , DeriveDataTypeable
           , ViewPatterns
           , OverloadedStrings
           , InstanceSigs
  #-}

module Diagrams.Backend.GHCJS
  ( Canvas(..)
  , Options(..)
  ) where

import           Control.Lens         hiding ((#))
import           Control.Monad        (when)
import           Control.Monad.Reader
import           Control.Monad.State
import qualified Data.Foldable        as F
import           Data.Maybe           (catMaybes, maybe, isJust, fromJust)
import           Data.Monoid          ((<>))
import           Data.Typeable
import qualified Data.Text            as T

import           Diagrams.Prelude     hiding ((<>), view)
import           Diagrams.TwoD.Adjust (adjustDia2D)
import           Diagrams.TwoD.Path   (getFillRule, Clip(..))
import           Diagrams.TwoD.Text   (getFont, getFontSize)
import qualified Diagrams.TwoD.Text   as D
import           Diagrams.Segment

import qualified Graphics.Rendering.GHCJS as G

-- | This data declaration is simply used as a token to distinguish this
-- rendering engine.
data Canvas = Canvas deriving Typeable

instance Monoid (Render Canvas R2) where
  mempty  = C $ return ()
  (C c1) `mappend` (C c2) = C (c1 >> c2)

-- | Did we see any lines in the most recent path (as opposed to loops)? If
-- so then we should ignore any fill attribute because diagrams-lib
-- separates lines and loops into separate path primitives so we don't have
-- to worry about seeing them in the same path
-- type G.Render a = StateT Bool G.Render a

instance Backend Canvas R2 where
    data Render  Canvas R2 = C (G.Render ())
    type Result  Canvas R2 = IO ()
    data Options Canvas R2 = CanvasOptions
            { canvasSize   :: SizeSpec2D   -- ^ the requested size
            , context      :: G.Context    -- ^ drawing context to render to
            }

    withStyle _ s t (C r) = C $ G.tempState $ do
        clearPath  -- path is not part of the drawing state :/
        canvasMiscStyle s
        G.setIgnoreFill False
        r
        ignoreFill <- G.getIgnoreFill
        canvasTransf t
        canvasStyle ignoreFill s
        G.stroke

    doRender _ (CanvasOptions _ c) (C r) = G.doRender c r

    adjustDia c opts d = adjustDia2D canvasSize setCanvasSize c opts
                         -- (d # reflectY # fcA transparent # lw 0.01)
                         (d # reflectY)
        where setCanvasSize sz o = o { canvasSize = sz }

clearPath :: G.Render()
clearPath = G.newPath >> G.closePath

renderC :: (Renderable a Canvas, V a ~ R2) => a -> G.Render ()
renderC a = case (render Canvas a) of C r -> r

canvasMiscStyle :: Style v -> G.Render ()
canvasMiscStyle s = sequence_ $ catMaybes
    [ handleClipping s
    , handleFont s
    , handle fColor
    , handle fRule
    ] where
        handle :: AttributeClass a => (a -> G.Render ()) -> Maybe (G.Render ())
        handle f = f `fmap` getAttr s
        fColor   = G.fillColor   . getFillColor
        fRule    = G.setFill     . getFillRule

handleFont s = Just $ G.setFont $
    G.fromFontSlant fontSlant
    <> G.fromFontWeight fontWeight
    <> T.pack (show fontSize)
    <> "px "
    <> (T.pack fontFamily)
    where
        fontFamily' = getAttr s :: Maybe (D.Font)
        fontSize'   = getAttr s :: Maybe (D.FontSize)
        fontSlant'  = getAttr s :: Maybe (D.FontSlantA)
        fontWeight' = getAttr s :: Maybe (D.FontWeightA)
        fontFamily  = maybe "Arial" getFont fontFamily'
        fontSize    = maybe 10 getFontSize fontSize'
        fontSlant   = maybe D.FontSlantNormal D.getFontSlant fontSlant'
        fontWeight  = maybe D.FontWeightNormal D.getFontWeight fontWeight'

handleClipping :: Style v -> Maybe (G.Render ())
handleClipping s = (clipCanv . \(Clip x) -> x) `fmap` getAttr s

canvasStyle :: Bool -> Style v -> G.Render ()
canvasStyle ignoreFill s = foldr (>>) (return ()) . catMaybes $
    [ handle lColor
    , handle lWidth
    , handle lJoin
    , handle lCap
    , handle opacity_
    , handle dashing_
    , if ignoreFill then Nothing else handle fRule
    , if ignoreFill then Nothing else handle fColor
    ] where
        handle :: AttributeClass a => (a -> G.Render ()) -> Maybe (G.Render ())
        handle f = f `fmap` getAttr s
        lColor   = G.strokeColor . getLineColor
        fColor s = (G.fillColor   $ getFillColor s) >> G.fill
        lWidth   = G.lineWidth   . getLineWidth
        lCap     = G.lineCap     . getLineCap
        lJoin    = G.lineJoin    . getLineJoin
        opacity_ = G.globalAlpha . getOpacity
        fRule    = G.setFill     . getFillRule
        dashing_ = G.dashing     . getDashing

clipCanv :: [Path R2] -> G.Render ()
clipCanv pths = mapM_ renderPath pths >> G.clip

renderPath :: Path R2 -> G.Render ()
renderPath (Path trs) = G.newPath >> F.mapM_ renderTrail trs
{'fraction_non_alphanumeric': 0.09012961116650049, 'fraction_numerical': 0.004087736789631107, 'mean_word_length': 2.1132836747361887, 'pattern_counts': {'":': 0, '<': 17, '<?xml version=': 0, '>': 70, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5805688', 'n_tokens_mistral': 3085, 'n_tokens_neox': 3037, 'n_words': 979}