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

import Control.Arrow
import Data.Foldable (asum)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import System.FilePath.Posix (takeExtension)
import Text.XML
import Text.XML.Cursor

import Codec.Xlsx.Parser.Internal

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

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

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

lookup :: FilePath -> ContentTypes -> Maybe Text
lookup :: FilePath -> ContentTypes -> Maybe Text
lookup FilePath
path ContentTypes{Map FilePath Text
ctTypes :: Map FilePath Text
ctDefaults :: Map FilePath Text
ctTypes :: ContentTypes -> Map FilePath Text
ctDefaults :: ContentTypes -> Map FilePath Text
..} =
    [Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ (FilePath -> Map FilePath Text -> Maybe Text)
-> Map FilePath Text -> FilePath -> Maybe Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> Map FilePath Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map FilePath Text
ctDefaults (FilePath -> Maybe Text) -> Maybe FilePath -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FilePath
ext, FilePath -> Map FilePath Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
path Map FilePath Text
ctTypes ]
  where
    ext :: Maybe FilePath
ext = case ShowS
takeExtension FilePath
path of
        Char
'.':FilePath
e -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
e
        FilePath
_     -> Maybe FilePath
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Parsing
-------------------------------------------------------------------------------}
instance FromCursor ContentTypes where
    fromCursor :: Cursor -> [ContentTypes]
fromCursor Cursor
cur = do
        let ds :: Map FilePath Text
ds = [(FilePath, Text)] -> Map FilePath Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, Text)] -> Map FilePath Text)
-> ([CtDefault] -> [(FilePath, Text)])
-> [CtDefault]
-> Map FilePath Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CtDefault -> (FilePath, Text))
-> [CtDefault] -> [(FilePath, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (CtDefault -> FilePath
dfltExtension (CtDefault -> FilePath)
-> (CtDefault -> Text) -> CtDefault -> (FilePath, Text)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CtDefault -> Text
dfltContentType) ([CtDefault] -> Map FilePath Text)
-> [CtDefault] -> Map FilePath Text
forall a b. (a -> b) -> a -> b
$
                 Cursor
cur Cursor -> (Cursor -> [CtDefault]) -> [CtDefault]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
ctText
"Default") Axis -> (Cursor -> [CtDefault]) -> Cursor -> [CtDefault]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [CtDefault]
forall a. FromCursor a => Cursor -> [a]
fromCursor
            ts :: Map FilePath Text
ts = [(FilePath, Text)] -> Map FilePath Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, Text)] -> Map FilePath Text)
-> ([Override] -> [(FilePath, Text)])
-> [Override]
-> Map FilePath Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Override -> (FilePath, Text)) -> [Override] -> [(FilePath, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Override -> FilePath
ovrPartName (Override -> FilePath)
-> (Override -> Text) -> Override -> (FilePath, Text)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Override -> Text
ovrContentType) ([Override] -> Map FilePath Text)
-> [Override] -> Map FilePath Text
forall a b. (a -> b) -> a -> b
$
                 Cursor
cur Cursor -> (Cursor -> [Override]) -> [Override]
forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$/ Name -> Axis
element (Text -> Name
ctText
"Override") Axis -> (Cursor -> [Override]) -> Cursor -> [Override]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Cursor -> [Override]
forall a. FromCursor a => Cursor -> [a]
fromCursor
        ContentTypes -> [ContentTypes]
forall (m :: * -> *) a. Monad m => a -> m a
return (Map FilePath Text -> Map FilePath Text -> ContentTypes
ContentTypes Map FilePath Text
ds Map FilePath Text
ts)

instance FromCursor CtDefault where
   fromCursor :: Cursor -> [CtDefault]
fromCursor Cursor
cur = do
       FilePath
dfltExtension <- 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
"Extension" Cursor
cur
       Text
dfltContentType <- Name -> Cursor -> [Text]
attribute Name
"ContentType" Cursor
cur
       CtDefault -> [CtDefault]
forall (m :: * -> *) a. Monad m => a -> m a
return CtDefault :: FilePath -> Text -> CtDefault
CtDefault{FilePath
Text
dfltContentType :: Text
dfltExtension :: FilePath
dfltContentType :: Text
dfltExtension :: FilePath
..}

instance FromCursor Override where
   fromCursor :: Cursor -> [Override]
fromCursor Cursor
cur = do
       FilePath
ovrPartName <- 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
"PartName" Cursor
cur
       Text
ovrContentType <- Name -> Cursor -> [Text]
attribute Name
"ContentType" Cursor
cur
       Override -> [Override]
forall (m :: * -> *) a. Monad m => a -> m a
return Override :: FilePath -> Text -> Override
Override{FilePath
Text
ovrContentType :: Text
ovrPartName :: FilePath
ovrContentType :: Text
ovrPartName :: FilePath
..}

-- | Add package relationship namespace to name
ct :: Text -> Name
ct :: Text -> Name
ct 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
contentTypesNs
  , namePrefix :: Maybe Text
namePrefix = Maybe Text
forall a. Maybe a
Nothing
  }

contentTypesNs :: Text
contentTypesNs :: Text
contentTypesNs = Text
"http://schemas.openxmlformats.org/package/2006/content-types"