{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Internal.Relationships where

import Data.List (find)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.URI hiding (path)
import Prelude hiding (abs, lookup)
import Safe
import Text.XML
import Text.XML.Cursor

import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Internal
import Codec.Xlsx.Writer.Internal

data Relationship = Relationship
    { Relationship -> Text
relType   :: Text
    , Relationship -> FilePath
relTarget :: FilePath
    } deriving (Relationship -> Relationship -> Bool
(Relationship -> Relationship -> Bool)
-> (Relationship -> Relationship -> Bool) -> Eq Relationship
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relationship -> Relationship -> Bool
$c/= :: Relationship -> Relationship -> Bool
== :: Relationship -> Relationship -> Bool
$c== :: Relationship -> Relationship -> Bool
Eq, Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> FilePath
(Int -> Relationship -> ShowS)
-> (Relationship -> FilePath)
-> ([Relationship] -> ShowS)
-> Show Relationship
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> FilePath
$cshow :: Relationship -> FilePath
showsPrec :: Int -> Relationship -> ShowS
$cshowsPrec :: Int -> Relationship -> ShowS
Show, (forall x. Relationship -> Rep Relationship x)
-> (forall x. Rep Relationship x -> Relationship)
-> Generic Relationship
forall x. Rep Relationship x -> Relationship
forall x. Relationship -> Rep Relationship x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Relationship x -> Relationship
$cfrom :: forall x. Relationship -> Rep Relationship x
Generic)

-- | Describes relationships according to Open Packaging Convention
--
-- See ECMA-376, 4th Edition Office Open XML File Formats — Open Packaging
-- Conventions
newtype Relationships = Relationships
    { Relationships -> Map RefId Relationship
relMap :: Map RefId Relationship
    } deriving (Relationships -> Relationships -> Bool
(Relationships -> Relationships -> Bool)
-> (Relationships -> Relationships -> Bool) -> Eq Relationships
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relationships -> Relationships -> Bool
$c/= :: Relationships -> Relationships -> Bool
== :: Relationships -> Relationships -> Bool
$c== :: Relationships -> Relationships -> Bool
Eq, Int -> Relationships -> ShowS
[Relationships] -> ShowS
Relationships -> FilePath
(Int -> Relationships -> ShowS)
-> (Relationships -> FilePath)
-> ([Relationships] -> ShowS)
-> Show Relationships
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Relationships] -> ShowS
$cshowList :: [Relationships] -> ShowS
show :: Relationships -> FilePath
$cshow :: Relationships -> FilePath
showsPrec :: Int -> Relationships -> ShowS
$cshowsPrec :: Int -> Relationships -> ShowS
Show, (forall x. Relationships -> Rep Relationships x)
-> (forall x. Rep Relationships x -> Relationships)
-> Generic Relationships
forall x. Rep Relationships x -> Relationships
forall x. Relationships -> Rep Relationships x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Relationships x -> Relationships
$cfrom :: forall x. Relationships -> Rep Relationships x
Generic)

fromList :: [(RefId, Relationship)] -> Relationships
fromList :: [(RefId, Relationship)] -> Relationships
fromList = Map RefId Relationship -> Relationships
Relationships (Map RefId Relationship -> Relationships)
-> ([(RefId, Relationship)] -> Map RefId Relationship)
-> [(RefId, Relationship)]
-> Relationships
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RefId, Relationship)] -> Map RefId Relationship
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

empty :: Relationships
empty :: Relationships
empty = [(RefId, Relationship)] -> Relationships
fromList []

size :: Relationships -> Int
size :: Relationships -> Int
size = Map RefId Relationship -> Int
forall k a. Map k a -> Int
Map.size (Map RefId Relationship -> Int)
-> (Relationships -> Map RefId Relationship)
-> Relationships
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relationships -> Map RefId Relationship
relMap

relEntry :: RefId -> Text -> FilePath -> (RefId, Relationship)
relEntry :: RefId -> Text -> FilePath -> (RefId, Relationship)
relEntry RefId
rId Text
typ FilePath
trg = (RefId
rId, Text -> FilePath -> Relationship
Relationship (Text -> Text
stdRelType Text
typ) FilePath
trg)

lookup :: RefId -> Relationships -> Maybe Relationship
lookup :: RefId -> Relationships -> Maybe Relationship
lookup RefId
ref = RefId -> Map RefId Relationship -> Maybe Relationship
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RefId
ref (Map RefId Relationship -> Maybe Relationship)
-> (Relationships -> Map RefId Relationship)
-> Relationships
-> Maybe Relationship
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relationships -> Map RefId Relationship
relMap

setTargetsFrom :: FilePath -> Relationships -> Relationships
setTargetsFrom :: FilePath -> Relationships -> Relationships
setTargetsFrom FilePath
fp (Relationships Map RefId Relationship
m) = Map RefId Relationship -> Relationships
Relationships ((Relationship -> Relationship)
-> Map RefId Relationship -> Map RefId Relationship
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Relationship -> Relationship
fixPath Map RefId Relationship
m)
    where
        fixPath :: Relationship -> Relationship
fixPath Relationship
rel = Relationship
rel{ relTarget :: FilePath
relTarget = FilePath
fp FilePath -> ShowS
`joinRel` Relationship -> FilePath
relTarget Relationship
rel}

-- | joins relative URI (actually a file path as an internal relation target)
joinRel :: FilePath -> FilePath -> FilePath
joinRel :: FilePath -> ShowS
joinRel FilePath
abs FilePath
rel = ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id (URI
relPath URI -> URI -> URI
`nonStrictRelativeTo` URI
base) FilePath
""
  where
    base :: URI
base = FilePath -> Maybe URI -> URI
forall a. Partial => FilePath -> Maybe a -> a
fromJustNote FilePath
"joinRel base path" (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe URI
parseURIReference FilePath
abs
    relPath :: URI
relPath = FilePath -> Maybe URI -> URI
forall a. Partial => FilePath -> Maybe a -> a
fromJustNote FilePath
"joinRel relative path" (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe URI
parseURIReference FilePath
rel

relFrom :: FilePath -> FilePath -> FilePath
relFrom :: FilePath -> ShowS
relFrom FilePath
path FilePath
base = ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id (URI
pathURI URI -> URI -> URI
`relativeFrom` URI
baseURI) FilePath
""
  where
    baseURI :: URI
baseURI = FilePath -> Maybe URI -> URI
forall a. Partial => FilePath -> Maybe a -> a
fromJustNote FilePath
"joinRel base path" (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe URI
parseURIReference FilePath
base
    pathURI :: URI
pathURI = FilePath -> Maybe URI -> URI
forall a. Partial => FilePath -> Maybe a -> a
fromJustNote FilePath
"joinRel relative path" (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe URI
parseURIReference FilePath
path

findRelByType :: Text -> Relationships -> Maybe Relationship
findRelByType :: Text -> Relationships -> Maybe Relationship
findRelByType Text
t (Relationships Map RefId Relationship
m) = (Relationship -> Bool) -> [Relationship] -> Maybe Relationship
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
t) (Text -> Bool) -> (Relationship -> Text) -> Relationship -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relationship -> Text
relType) (Map RefId Relationship -> [Relationship]
forall k a. Map k a -> [a]
Map.elems Map RefId Relationship
m)

allByType :: Text -> Relationships -> [Relationship]
allByType :: Text -> Relationships -> [Relationship]
allByType Text
t (Relationships Map RefId Relationship
m) = (Relationship -> Bool) -> [Relationship] -> [Relationship]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
t) (Text -> Bool) -> (Relationship -> Text) -> Relationship -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Relationship -> Text
relType) (Map RefId Relationship -> [Relationship]
forall k a. Map k a -> [a]
Map.elems Map RefId Relationship
m)

{-------------------------------------------------------------------------------
  Rendering
-------------------------------------------------------------------------------}

instance ToDocument Relationships where
  toDocument :: Relationships -> Document
toDocument = Text -> Text -> Element -> Document
documentFromNsElement Text
"Relationships generated by xlsx" Text
pkgRelNs
               (Element -> Document)
-> (Relationships -> Element) -> Relationships -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Relationships -> Element
forall a. ToElement a => Name -> a -> Element
toElement Name
"Relationships"

instance ToElement Relationships where
  toElement :: Name -> Relationships -> Element
toElement Name
nm Relationships{Map RefId Relationship
relMap :: Map RefId Relationship
relMap :: Relationships -> Map RefId Relationship
..} = Element :: Name -> Map Name Text -> [Node] -> Element
Element
      { elementName :: Name
elementName       = Name
nm
      , elementAttributes :: Map Name Text
elementAttributes = Map Name Text
forall k a. Map k a
Map.empty
      , elementNodes :: [Node]
elementNodes      = ((RefId, Relationship) -> Node)
-> [(RefId, Relationship)] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map (Element -> Node
NodeElement (Element -> Node)
-> ((RefId, Relationship) -> Element)
-> (RefId, Relationship)
-> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> (RefId, Relationship) -> Element
forall a a. (ToAttrVal a, ToElement a) => Name -> (a, a) -> Element
relToEl Name
"Relationship") ([(RefId, Relationship)] -> [Node])
-> [(RefId, Relationship)] -> [Node]
forall a b. (a -> b) -> a -> b
$
                            Map RefId Relationship -> [(RefId, Relationship)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RefId Relationship
relMap
      }
    where
      relToEl :: Name -> (a, a) -> Element
relToEl Name
nm' (a
relId, a
rel) = Name -> a -> Element -> Element
forall a. ToAttrVal a => Name -> a -> Element -> Element
setAttr Name
"Id" a
relId (Name -> a -> Element
forall a. ToElement a => Name -> a -> Element
toElement Name
nm' a
rel)

instance ToElement Relationship where
  toElement :: Name -> Relationship -> Element
toElement Name
nm Relationship{FilePath
Text
relTarget :: FilePath
relType :: Text
relTarget :: Relationship -> FilePath
relType :: Relationship -> Text
..} = Element :: Name -> Map Name Text -> [Node] -> Element
Element
      { elementName :: Name
elementName       = Name
nm
      , elementAttributes :: Map Name Text
elementAttributes = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ Name
"Target" Name -> FilePath -> (Name, Text)
forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= FilePath
relTarget
                                         , Name
"Type"   Name -> Text -> (Name, Text)
forall a. ToAttrVal a => Name -> a -> (Name, Text)
.= Text
relType ]
      , elementNodes :: [Node]
elementNodes      = []
      }

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}
instance FromCursor Relationships where
  fromCursor :: Cursor -> [Relationships]
fromCursor Cursor
cur = do
    let items :: [(RefId, Relationship)]
items = Cursor
cur Cursor
-> (Cursor -> [(RefId, Relationship)]) -> [(RefId, Relationship)]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
prText
"Relationship") Axis
-> (Cursor -> [(RefId, Relationship)])
-> Cursor
-> [(RefId, Relationship)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [(RefId, Relationship)]
parseRelEntry
    Relationships -> [Relationships]
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationships -> [Relationships])
-> (Map RefId Relationship -> Relationships)
-> Map RefId Relationship
-> [Relationships]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RefId Relationship -> Relationships
Relationships (Map RefId Relationship -> [Relationships])
-> Map RefId Relationship -> [Relationships]
forall a b. (a -> b) -> a -> b
$ [(RefId, Relationship)] -> Map RefId Relationship
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RefId, Relationship)]
items

parseRelEntry :: Cursor -> [(RefId, Relationship)]
parseRelEntry :: Cursor -> [(RefId, Relationship)]
parseRelEntry Cursor
cur = do
  Relationship
rel <- Cursor -> [Relationship]
forall a. FromCursor a => Cursor -> [a]
fromCursor Cursor
cur
  Text
rId <- Name -> Cursor -> [Text]
attribute Name
"Id" Cursor
cur
  (RefId, Relationship) -> [(RefId, Relationship)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> RefId
RefId Text
rId, Relationship
rel)

instance FromCursor Relationship where
  fromCursor :: Cursor -> [Relationship]
fromCursor Cursor
cur =  do
    Text
ty <- Name -> Cursor -> [Text]
attribute Name
"Type" Cursor
cur
    FilePath
trg <- Text -> FilePath
T.unpack (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Cursor -> [Text]
attribute Name
"Target" Cursor
cur
    Relationship -> [Relationship]
forall (m :: * -> *) a. Monad m => a -> m a
return (Relationship -> [Relationship]) -> Relationship -> [Relationship]
forall a b. (a -> b) -> a -> b
$ Text -> FilePath -> Relationship
Relationship Text
ty FilePath
trg

-- | Add package relationship namespace to name
pr :: Text -> Name
pr :: Text -> Name
pr Text
x = Name :: Text -> Maybe Text -> Maybe Text -> Name
Name
  { nameLocalName :: Text
nameLocalName = Text
x
  , nameNamespace :: Maybe Text
nameNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
pkgRelNs
  , namePrefix :: Maybe Text
namePrefix = Maybe Text
forall a. Maybe a
Nothing
  }

-- | Add office document relationship namespace to name
odr :: Text -> Name
odr :: Text -> Name
odr Text
x = Name :: Text -> Maybe Text -> Maybe Text -> Name
Name
  { nameLocalName :: Text
nameLocalName = Text
x
  , nameNamespace :: Maybe Text
nameNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
odRelNs
  , namePrefix :: Maybe Text
namePrefix = Maybe Text
forall a. Maybe a
Nothing
  }

odRelNs :: Text
odRelNs :: Text
odRelNs = Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships"

pkgRelNs :: Text
pkgRelNs :: Text
pkgRelNs = Text
"http://schemas.openxmlformats.org/package/2006/relationships"

stdRelType :: Text -> Text
stdRelType :: Text -> Text
stdRelType Text
t = Text
stdPart Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
  where
    stdPart :: Text
stdPart = Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/"