{-# 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
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
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. 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
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
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. 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
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
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. 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
..} =
    forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum [ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map FilePath Text
ctDefaults forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe FilePath
ext, 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 -> forall a. a -> Maybe a
Just FilePath
e
        FilePath
_     -> forall a. Maybe a
Nothing

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

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