-----------------------------------------------------------------------------

-- Copyright 2018, Ideas project team. This file is distributed under the

-- terms of the Apache License 2.0. For more information, see the files

-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.

-----------------------------------------------------------------------------

-- |

-- Maintainer  :  bastiaan.heeren@ou.nl

-- Stability   :  provisional

-- Portability :  portable (depends on ghc)

--

-- A datatype, parser, and pretty printer for XML documents. Re-exports

-- functions defined elsewhere.

--

-----------------------------------------------------------------------------



module Ideas.Text.XML

   ( XML, Attr, AttrList, Element(..), InXML(..)

   , XMLBuilder, makeXML

   , parseXML, parseXMLFile, compactXML, findAttribute

   , children, Attribute(..), fromBuilder, findChild, findChildren, getData

   , BuildXML(..)

   , module Data.Monoid

   , (<>)

   , munless, mwhen

   ) where



import Control.Monad

import Data.Char

import Data.Foldable (toList)

import Data.List

import Data.Monoid hiding ((<>))

import Data.Semigroup as Sem

import Data.String

import Ideas.Text.XML.Interface hiding (parseXML)

import System.IO

import qualified Data.Map as M

import qualified Data.Sequence as Seq

import qualified Ideas.Text.XML.Interface as I



----------------------------------------------------------------

-- Datatype definitions



-- two helper types for attributes

type XML      = Element

type Attr     = Attribute  -- (String, String)

type AttrList = Attributes -- [Attr]



class InXML a where

   toXML       :: a -> XML

   listToXML   :: [a] -> XML

   fromXML     :: Monad m => XML -> m a

   listFromXML :: Monad m => XML -> m [a]

   -- default definitions

   listToXML = Element "list" [] . map (Right . toXML)

   listFromXML xml

      | name xml == "list" && null (attributes xml) =

           mapM fromXML (children xml)

      | otherwise = fail "expecting a list tag"



----------------------------------------------------------------

-- XML parser (a scanner and a XML tree constructor)



parseXMLFile :: FilePath -> IO XML

parseXMLFile file =

   withBinaryFile file ReadMode $

      hGetContents >=> either fail return . parseXML



parseXML :: String -> Either String XML

parseXML input = do

   xml <- I.parseXML input

   return (ignoreLayout xml)



ignoreLayout :: XML -> XML

ignoreLayout (Element n as xs) =

   let f = either (Left . trim) (Right . ignoreLayout)

   in Element n as (map f xs)



----------------------------------------------------------------

-- XML builders



infix 7 .=.



class (Sem.Semigroup a, Monoid a) => BuildXML a where

   (.=.)     :: String -> String -> a   -- attribute

   unescaped :: String -> a             -- parsed character data (unescaped!)

   builder   :: Element -> a            -- (named) xml element

   tag       :: String -> a -> a        -- tag (with content)

   -- functions with a default

   string   :: String -> a -- escaped text

   text     :: Show s => s -> a -- escaped text with Show class

   element  :: String -> [a] -> a

   emptyTag :: String -> a

   -- implementations

   string     = unescaped . escape

   text       = string . show

   element s  = tag s . mconcat

   emptyTag s = tag s mempty



data XMLBuilder = BS (Seq.Seq Attr) (Seq.Seq (Either String Element))



-- local helper: merge attributes, but preserve order

fromBS :: XMLBuilder -> (AttrList, Content)

fromBS (BS as elts) = (attrList, toList elts)

 where

   attrMap = foldr add M.empty as

   add (k := v) = M.insertWith (\x y -> x ++ " " ++ y) k v

   attrList = nubBy eqKey (map make (toList as))

   make (k := _) = k := M.findWithDefault "" k attrMap

   eqKey (k1 := _) (k2 := _) = k1 == k2



instance Sem.Semigroup XMLBuilder where

  BS as1 elts1 <> BS as2 elts2 =

      BS (as1 <> as2) (elts1 <> elts2)



instance Monoid XMLBuilder where

   mempty  = BS mempty mempty

   mappend = (<>)



instance BuildXML XMLBuilder where

   n .=. s   = BS (Seq.singleton (n := escapeAttr s)) mempty

   unescaped = BS mempty . Seq.singleton . Left

   builder   = BS mempty . Seq.singleton . Right

   tag s     = builder . uncurry (Element s) . fromBS



instance IsString XMLBuilder where

   fromString = string



makeXML :: String -> XMLBuilder -> XML

makeXML s = uncurry (Element s) . fromBS



mwhen :: Monoid a => Bool -> a -> a

mwhen True  a = a

mwhen False _ = mempty



munless :: Monoid a => Bool -> a -> a

munless = mwhen . not



escapeAttr :: String -> String

escapeAttr = concatMap f

 where

   f '<' = "&lt;"

   f '&' = "&amp;"

   f '"' = "&quot;"

   f c   = [c]



fromBuilder :: XMLBuilder -> Maybe Element

fromBuilder m =

   case fromBS m of

      ([], [Right a]) -> Just a

      _               -> Nothing



escape :: String -> String

escape = concatMap f

 where

   f '<'  = "&lt;"

   f '>'  = "&gt;"

   f '&'  = "&amp;"

   f '"'  = "&quot;"

   f '\'' = "&apos;"

   f '\n' = "&#10;"

   f c   = [c]



trim :: String -> String

trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse