content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# LANGUAGE DeriveGeneric #-}
  module Codec.Xlsx.Types.Drawing where
  
  import Control.Arrow (first)
  import Control.DeepSeq (NFData)
  import Codec.Xlsx.LensCompat (makeLenses)
  import Data.ByteString.Lazy (ByteString)
  import Data.Default
  import qualified Data.Map as M
  import Data.Maybe (catMaybes, listToMaybe, mapMaybe)
  import Data.Text (Text)
  import qualified Data.Text as T
  import GHC.Generics (Generic)
  import Text.XML
  import Text.XML.Cursor
  
  import Codec.Xlsx.Parser.Internal
  import Codec.Xlsx.Types.Drawing.Chart
  import Codec.Xlsx.Types.Drawing.Common
  import Codec.Xlsx.Types.Internal
  import Codec.Xlsx.Types.Internal.Relationships
  import Codec.Xlsx.Writer.Internal
  
  -- | information about image file as a par of a drawing
  data FileInfo = FileInfo
      { _fiFilename    :: FilePath
      -- ^ image filename, images are assumed to be stored under path "xl\/media\/"
      , _fiContentType :: Text
      -- ^ image content type, ECMA-376 advises to use "image\/png" or "image\/jpeg"
      -- if interoperability is wanted
      , _fiContents    :: ByteString
      -- ^ image file contents
      } deriving (Eq, Show, Generic)
  instance NFData FileInfo
  
  data Marker = Marker
      { _mrkCol    :: Int
      , _mrkColOff :: Coordinate
      , _mrkRow    :: Int
      , _mrkRowOff :: Coordinate
      } deriving (Eq, Show, Generic)
  instance NFData Marker
  
  unqMarker :: (Int, Int) -> (Int, Int) -> Marker
  unqMarker (col, colOff) (row, rowOff) =
      Marker col (UnqCoordinate colOff) row (UnqCoordinate rowOff)
  
  data EditAs
      = EditAsTwoCell
      | EditAsOneCell
      | EditAsAbsolute
      deriving (Eq, Show, Generic)
  instance NFData EditAs
  
  data Anchoring
      = AbsoluteAnchor
        { absaPos :: Point2D
        , absaExt :: PositiveSize2D
        }
      | OneCellAnchor
        { onecaFrom :: Marker
        , onecaExt  :: PositiveSize2D
        }
      | TwoCellAnchor
        { tcaFrom   :: Marker
        , tcaTo     :: Marker
        , tcaEditAs :: EditAs
        }
      deriving (Eq, Show, Generic)
  instance NFData Anchoring
  
  data DrawingObject p g
    = Picture { _picMacro :: Maybe Text
             ,  _picPublished :: Bool
             ,  _picNonVisual :: PicNonVisual
             ,  _picBlipFill :: BlipFillProperties p
             ,  _picShapeProperties :: ShapeProperties
                -- TODO: style
              }
    | Graphic { _grNonVisual :: GraphNonVisual
             ,  _grChartSpace :: g
             ,  _grTransform :: Transform2D}
      -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart
    deriving (Eq, Show, Generic)
  instance (NFData p, NFData g) => NFData (DrawingObject p g)
  
  -- | basic function to create picture drawing object
  --
  -- /Note:/ specification says that drawing element ids need to be
  -- unique within 1 document, otherwise /...document shall be
  -- considered non-conformant/.
  picture :: DrawingElementId -> FileInfo -> DrawingObject FileInfo c
  picture dId fi =
    Picture
    { _picMacro = Nothing
    , _picPublished = False
    , _picNonVisual = nonVis
    , _picBlipFill = bfProps
    , _picShapeProperties = shProps
    }
    where
      nonVis =
        PicNonVisual $
        NonVisualDrawingProperties
        { _nvdpId = dId
        , _nvdpName = T.pack $ _fiFilename fi
        , _nvdpDescription = Nothing
        , _nvdpHidden = False
        , _nvdpTitle = Nothing
        }
      bfProps =
        BlipFillProperties
        {_bfpImageInfo = Just fi, _bfpFillMode = Just FillStretch}
      shProps =
        ShapeProperties
        { _spXfrm = Nothing
        , _spGeometry = Nothing
        , _spFill = Just NoFill
        , _spOutline = Just $ def {_lnFill = Just NoFill}
        }
  
  -- | helper to retrive information about all picture files in
  -- particular drawing alongside with their anchorings (i.e. sizes and
  -- positions)
  extractPictures :: Drawing -> [(Anchoring, FileInfo)]
  extractPictures dr = mapMaybe maybePictureInfo $ _xdrAnchors dr
    where
      maybePictureInfo Anchor {..} =
        case _anchObject of
          Picture {..} -> (_anchAnchoring,) <$> _bfpImageInfo _picBlipFill
          _ -> Nothing
  
  -- | This element is used to set certain properties related to a drawing
  -- element on the client spreadsheet application.
  --
  -- see 20.5.2.3 "clientData (Client Data)" (p. 3156)
  data ClientData = ClientData
      { _cldLcksWithSheet   :: Bool
      -- ^ This attribute indicates whether to disable selection on
      -- drawing elements when the sheet is protected.
      , _cldPrintsWithSheet :: Bool
      -- ^ This attribute indicates whether to print drawing elements
      -- when printing the sheet.
      } deriving (Eq, Show, Generic)
  instance NFData ClientData
  
  data PicNonVisual = PicNonVisual
    { _pnvDrawingProps :: NonVisualDrawingProperties
      -- TODO: cNvPicPr
    } deriving (Eq, Show, Generic)
  instance NFData PicNonVisual
  
  data GraphNonVisual = GraphNonVisual
    { _gnvDrawingProps :: NonVisualDrawingProperties
      -- TODO cNvGraphicFramePr
    } deriving (Eq, Show, Generic)
  instance NFData GraphNonVisual
  
  newtype DrawingElementId = DrawingElementId
    { unDrawingElementId :: Int
    } deriving (Eq, Show, Generic)
  instance NFData DrawingElementId
  
  -- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731)
  data NonVisualDrawingProperties = NonVisualDrawingProperties
      { _nvdpId          :: DrawingElementId
      -- ^ Specifies a unique identifier for the current
      -- DrawingML object within the current
      --
      -- TODO: make ids internal and consistent by construction
      , _nvdpName        :: Text
      -- ^ Specifies the name of the object.
      -- Typically, this is used to store the original file
      -- name of a picture object.
      , _nvdpDescription :: Maybe Text
      -- ^ Alternative Text for Object
      , _nvdpHidden      :: Bool
      , _nvdpTitle       :: Maybe Text
      } deriving (Eq, Show, Generic)
  instance NFData NonVisualDrawingProperties
  
  data BlipFillProperties a = BlipFillProperties
      { _bfpImageInfo :: Maybe a
      , _bfpFillMode  :: Maybe FillMode
      -- TODO: dpi, rotWithShape, srcRect
      } deriving (Eq, Show, Generic)
  instance NFData a => NFData (BlipFillProperties a)
  
  -- see @a_EG_FillModeProperties@ (p. 4319)
  data FillMode
      -- See 20.1.8.58 "tile (Tile)" (p. 2880)
      = FillTile    -- TODO: tx, ty, sx, sy, flip, algn
      -- See 20.1.8.56 "stretch (Stretch)" (p. 2879)
      | FillStretch -- TODO: srcRect
      deriving (Eq, Show, Generic)
  instance NFData FillMode
  
  -- See @EG_Anchor@ (p. 4052)
  data Anchor p g = Anchor
      { _anchAnchoring  :: Anchoring
      , _anchObject     :: DrawingObject p g
      , _anchClientData :: ClientData
      } deriving (Eq, Show, Generic)
  instance (NFData p, NFData g) => NFData (Anchor p g)
  
  data GenericDrawing p g = Drawing
      { _xdrAnchors :: [Anchor p g]
      } deriving (Eq, Show, Generic)
  instance (NFData p, NFData g) => NFData (GenericDrawing p g)
  
  -- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176)
  type Drawing = GenericDrawing FileInfo ChartSpace
  
  type UnresolvedDrawing = GenericDrawing RefId RefId
  
  makeLenses ''Anchor
  makeLenses ''DrawingObject
  makeLenses ''BlipFillProperties
  makeLenses ''GenericDrawing
  
  -- | simple drawing object anchoring using one cell as a top lelft
  -- corner and dimensions of that object
  simpleAnchorXY :: (Int, Int) -- ^ x+y coordinates of a cell used as
                               -- top left anchoring corner
                 -> PositiveSize2D -- ^ size of drawing object to be
                                   -- anchored
                 -> DrawingObject p g
                 -> Anchor p g
  simpleAnchorXY (x, y) sz obj =
    Anchor
    { _anchAnchoring =
        OneCellAnchor {onecaFrom = unqMarker (x, 0) (y, 0), onecaExt = sz}
    , _anchObject = obj
    , _anchClientData = def
    }
  
  {-------------------------------------------------------------------------------
    Default instances
  -------------------------------------------------------------------------------}
  
  instance Default ClientData where
      def = ClientData True True
  
  {-------------------------------------------------------------------------------
    Parsing
  -------------------------------------------------------------------------------}
  
  instance FromCursor UnresolvedDrawing where
      fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor]
  
  instance FromCursor (Anchor RefId RefId) where
      fromCursor cur = do
          _anchAnchoring  <- fromCursor cur
          _anchObject     <- cur $/ anyElement >=> fromCursor
          _anchClientData <- cur $/ element (xdr"clientData") >=> fromCursor
          return Anchor{..}
  
  instance FromCursor Anchoring where
      fromCursor = anchoringFromNode . node
  
  anchoringFromNode :: Node -> [Anchoring]
  anchoringFromNode n | n `nodeElNameIs` xdr "twoCellAnchor" = do
                            tcaEditAs <- fromAttributeDef "editAs" EditAsTwoCell cur
                            tcaFrom <- cur $/ element (xdr"from") >=> fromCursor
                            tcaTo <- cur $/ element (xdr"to") >=> fromCursor
                            return TwoCellAnchor{..}
                      | n `nodeElNameIs` xdr "oneCellAnchor" = do
                            onecaFrom <- cur $/ element (xdr"from") >=> fromCursor
                            onecaExt <- cur $/ element (xdr"ext") >=> fromCursor
                            return OneCellAnchor{..}
                      | n `nodeElNameIs` xdr "absolueAnchor" = do
                            absaPos <- cur $/ element (xdr"pos") >=> fromCursor
                            absaExt <- cur $/ element (xdr"ext") >=> fromCursor
                            return AbsoluteAnchor{..}
                      | otherwise = fail "no matching anchoring node"
    where
      cur = fromNode n
  
  instance FromCursor Marker where
      fromCursor cur = do
          _mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal
          _mrkColOff <- cur $/ element (xdr"colOff") &/ content >=> coordinate
          _mrkRow <- cur $/ element (xdr"row") &/ content >=> decimal
          _mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate
          return Marker{..}
  
  instance FromCursor (DrawingObject RefId RefId) where
      fromCursor = drawingObjectFromNode . node
  
  drawingObjectFromNode :: Node -> [DrawingObject RefId RefId]
  drawingObjectFromNode n
    | n `nodeElNameIs` xdr "pic" = do
      _picMacro <- maybeAttribute "macro" cur
      _picPublished <- fromAttributeDef "fPublished" False cur
      _picNonVisual <- cur $/ element (xdr "nvPicPr") >=> fromCursor
      _picBlipFill <- cur $/ element (xdr "blipFill") >=> fromCursor
      _picShapeProperties <- cur $/ element (xdr "spPr") >=> fromCursor
      return Picture {..}
    | n `nodeElNameIs` xdr "graphicFrame" = do
      _grNonVisual <-
        cur $/ element (xdr "nvGraphicFramePr") >=> fromCursor
      _grTransform <- cur $/ element (xdr "xfrm") >=> fromCursor
      _grChartSpace <-
        cur $/ element (a_ "graphic") &/ element (a_ "graphicData") &/
        element (c_ "chart") >=> fmap RefId .  attribute (odr "id")
      return Graphic {..}
    | otherwise = fail "no matching drawing object node"
    where
      cur = fromNode n
  
  instance FromCursor PicNonVisual where
      fromCursor cur = do
          _pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor
          return PicNonVisual{..}
  
  instance FromCursor GraphNonVisual where
    fromCursor cur = do
      _gnvDrawingProps <- cur $/ element (xdr "cNvPr") >=> fromCursor
      return GraphNonVisual {..}
  
  instance FromCursor NonVisualDrawingProperties where
      fromCursor cur = do
          _nvdpId <- fromAttribute "id" cur
          _nvdpName <- fromAttribute "name" cur
          _nvdpDescription <- maybeAttribute "descr" cur
          _nvdpHidden <- fromAttributeDef "hidden" False cur
          _nvdpTitle <- maybeAttribute "title" cur
          return NonVisualDrawingProperties{..}
  
  instance FromAttrVal DrawingElementId where
    fromAttrVal = fmap (first DrawingElementId) . fromAttrVal
  
  instance FromCursor (BlipFillProperties RefId) where
      fromCursor cur = do
          let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=>
                              fmap RefId . attribute (odr"embed")
              _bfpFillMode  = listToMaybe $ cur $/ anyElement >=> fromCursor
          return BlipFillProperties{..}
  
  instance FromCursor FillMode where
      fromCursor = fillModeFromNode . node
  
  fillModeFromNode :: Node -> [FillMode]
  fillModeFromNode n | n `nodeElNameIs` a_ "stretch" = return FillStretch
                     | n `nodeElNameIs` a_ "stretch" = return FillTile
                     | otherwise = fail "no matching fill mode node"
  
  -- see 20.5.3.2 "ST_EditAs (Resizing Behaviors)" (p. 3177)
  instance FromAttrVal EditAs where
      fromAttrVal "absolute" = readSuccess EditAsAbsolute
      fromAttrVal "oneCell"  = readSuccess EditAsOneCell
      fromAttrVal "twoCell"  = readSuccess EditAsTwoCell
      fromAttrVal t          = invalidText "EditAs" t
  
  instance FromCursor ClientData where
      fromCursor cur = do
          _cldLcksWithSheet   <- fromAttributeDef "fLocksWithSheet"  True cur
          _cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur
          return ClientData{..}
  
  {-------------------------------------------------------------------------------
    Rendering
  -------------------------------------------------------------------------------}
  
  instance ToDocument UnresolvedDrawing where
      toDocument = documentFromNsElement "Drawing generated by xlsx" xlDrawingNs
                   . toElement "wsDr"
  
  instance ToElement UnresolvedDrawing where
      toElement nm (Drawing anchors) = Element
          { elementName       = nm
          , elementAttributes = M.empty
          , elementNodes      = map NodeElement $
                                map anchorToElement anchors
          }
  
  anchorToElement :: Anchor RefId RefId -> Element
  anchorToElement Anchor{..} = el
      { elementNodes = elementNodes el ++
                       map NodeElement [ drawingObjEl, cdEl ] }
    where
      el = anchoringToElement _anchAnchoring
      drawingObjEl = drawingObjToElement _anchObject
      cdEl = toElement "clientData" _anchClientData
  
  anchoringToElement :: Anchoring -> Element
  anchoringToElement anchoring = elementList nm attrs elements
    where
      (nm, attrs, elements) = case anchoring of
          AbsoluteAnchor{..} ->
              ("absoluteAnchor", [],
               [ toElement "pos" absaPos, toElement "ext" absaExt ])
          OneCellAnchor{..}  ->
              ("oneCellAnchor", [],
               [ toElement "from" onecaFrom, toElement "ext" onecaExt ])
          TwoCellAnchor{..}  ->
              ("twoCellAnchor", [ "editAs" .= tcaEditAs ],
               [ toElement "from" tcaFrom, toElement "to" tcaTo ])
  
  instance ToElement Marker where
      toElement nm Marker{..} = elementListSimple nm elements
        where
          elements = [ elementContent "col"    (toAttrVal _mrkCol)
                     , elementContent "colOff" (toAttrVal _mrkColOff)
                     , elementContent "row"    (toAttrVal _mrkRow)
                     , elementContent "rowOff" (toAttrVal _mrkRowOff)]
  
  drawingObjToElement :: DrawingObject RefId RefId -> Element
  drawingObjToElement Picture {..} = elementList "pic" attrs elements
    where
      attrs =
        catMaybes ["macro" .=? _picMacro, "fPublished" .=? justTrue _picPublished]
      elements =
        [ toElement "nvPicPr" _picNonVisual
        , toElement "blipFill" _picBlipFill
        , toElement "spPr" _picShapeProperties
        ]
  drawingObjToElement Graphic {..} = elementListSimple "graphicFrame" elements
    where
      elements =
        [ toElement "nvGraphicFramePr" _grNonVisual
        , toElement "xfrm" _grTransform
        , graphicEl
        ]
      graphicEl =
        elementListSimple
          (a_ "graphic")
          [ elementList
              (a_ "graphicData")
              ["uri" .= chartNs]
              [leafElement (c_ "chart") [odr "id" .= _grChartSpace]]
          ]
  
  instance ToElement PicNonVisual where
    toElement nm PicNonVisual {..} =
      elementListSimple
        nm
        [toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"]
  
  instance ToElement GraphNonVisual where
    toElement nm GraphNonVisual {..} =
      elementListSimple
        nm
        [toElement "cNvPr" _gnvDrawingProps, emptyElement "cNvGraphicFramePr"]
  
  instance ToElement NonVisualDrawingProperties where
      toElement nm NonVisualDrawingProperties{..} =
          leafElement nm attrs
        where
          attrs = [ "id"    .= _nvdpId
                  , "name"  .= _nvdpName ] ++
                  catMaybes [ "descr"  .=? _nvdpDescription
                            , "hidden" .=? justTrue _nvdpHidden
                            , "title"  .=? _nvdpTitle ]
  
  instance ToAttrVal DrawingElementId where
    toAttrVal = toAttrVal . unDrawingElementId
  
  instance ToElement (BlipFillProperties RefId) where
      toElement nm BlipFillProperties{..} =
          elementListSimple nm elements
        where
          elements = catMaybes [ (\rId -> leafElement (a_ "blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo
                               , fillModeToElement <$> _bfpFillMode ]
  
  fillModeToElement :: FillMode -> Element
  fillModeToElement FillStretch = emptyElement (a_ "stretch")
  fillModeToElement FillTile    = emptyElement (a_ "stretch")
  
  instance ToElement ClientData where
      toElement nm ClientData{..} = leafElement nm attrs
        where
          attrs = catMaybes [ "fLocksWithSheet"  .=? justFalse _cldLcksWithSheet
                            , "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet
                            ]
  
  instance ToAttrVal EditAs where
      toAttrVal EditAsAbsolute = "absolute"
      toAttrVal EditAsOneCell  = "oneCell"
      toAttrVal EditAsTwoCell  = "twoCell"
  
  -- | Add Spreadsheet DrawingML namespace to name
  xdr :: Text -> Name
  xdr x = Name
    { nameLocalName = x
    , nameNamespace = Just xlDrawingNs
    , namePrefix = Nothing
    }
  
  xlDrawingNs :: Text
  xlDrawingNs = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing"
  