Fix Show instances on newtypes.
[doclang.git] / Language / DTC / Write / XML.hs
index 0f0b20011d2ceef64f0fc279caecb3ffaf88c03f..66d85321fec7aa2236bab34604186df7b553a544 100644 (file)
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.DTC.Write.XML where
 
--- import Data.Foldable (Foldable(..))
-import Control.Monad (forM_, mapM_)
+import Control.Monad (forM_)
 import Data.Bool
+import Data.Foldable (Foldable(..))
 import Data.Function (($), (.))
+import Data.Functor ((<$>))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
-import Data.Semigroup (Semigroup(..))
-import Data.Text (Text)
+import Data.Sequence (Seq)
+import Data.TreeSeq.Strict (Tree(..))
 import Text.Blaze ((!))
 import Text.Blaze.Utils
 import Text.Blaze.XML (XML)
-import Data.TreeSeq.Strict (Tree(..))
-import qualified Data.Char as Char
-import qualified Data.Map.Strict as Map
-import qualified Data.Text as Text
+import qualified Data.Function as Fun
+import qualified Data.Text.Lazy as TL
 import qualified Text.Blaze as B
 import qualified Text.Blaze.DTC as XML
 import qualified Text.Blaze.DTC.Attributes as XA
 import qualified Text.Blaze.Internal as B
 
 import Data.Locale
-import Language.DTC.Document (MayText(..), whenMayText)
-import qualified Language.DTC.Document as DTC
-
-xmlText :: Text -> XML
-xmlText = B.toMarkup
+import Language.DTC.Anchor (plainifyWords)
+import Language.DTC.Document as DTC hiding (XML)
 
-xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
-xmlDocument loc DTC.Document{..} = do
-       let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
+writeXML :: Locales ls => LocaleIn ls -> Document -> XML
+writeXML _loc Document{..} = do
        XML.xmlModel "./schema/dtc.rnc"
+       {-
+       let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
        XML.xmlStylesheet   $ "./xsl/document.html5."<>lang<>".xsl"
        XML.html5Stylesheet $ "./xsl/document.html5."<>lang<>".xsl"
        XML.atomStylesheet  $ "./xsl/document.atom."<>lang<>".xsl"
+       -}
        XML.document $ do
-               xmlHead head
-               xmlBody body
-
-xmlHead :: DTC.Head -> XML
-xmlHead DTC.Head{..} =
-       XML.about $ xmlAbout about
-
-xmlBody :: DTC.Body -> XML
-xmlBody = mapM_ $ \case
-        TreeN k ts -> xmlBodyKey k $ xmlBody ts
-        Tree0 vs -> xmlBodyValue `mapM_` vs
-
-xmlBodyKey :: DTC.BodyKey -> XML -> XML
-xmlBodyKey k body = case k of
-        DTC.Section{..} ->
+               xmlify head
+               xmlify body
+
+-- * Class 'Xmlify'
+class Xmlify a where
+       xmlify :: a -> XML
+
+instance Xmlify TL.Text where
+       xmlify = B.toMarkup
+instance Xmlify Head where
+       xmlify Head{..} =
+               xmlify about
+instance Xmlify (Tree BodyNode) where
+       xmlify (Tree n ts) =
+               case n of
+                BodyBlock b -> xmlify b
+                BodySection{..} ->
+                       xmlCommonAttrs attrs $
+                       XML.section $ do
+                               xmlify title
+                               forM_ aliases xmlify
+                               xmlify ts
+instance Xmlify Block where
+       xmlify = \case
+        BlockPara para -> xmlify para
+        BlockBreak{..} ->
                xmlCommonAttrs attrs $
-               XML.section $ do
-                       xmlTitle title
-                       forM_ aliases xmlAlias
-                       body
-
-xmlBodyValue :: DTC.BodyValue -> XML
-xmlBodyValue = \case
-        DTC.ToC{..} ->
+               XML.break
+        BlockToC{..} ->
                xmlCommonAttrs attrs $
                XML.toc
                 !?? mayAttr XA.depth depth
-        DTC.ToF{..} ->
+        BlockToF{..} ->
                xmlCommonAttrs attrs $
-               XML.tof
-                !?? mayAttr XA.depth depth
-        DTC.Figure{..} ->
+               XML.tof $
+                       XML.ul $
+                               forM_ types $
+                                       XML.li . xmlify
+        BlockIndex{..} ->
+               xmlCommonAttrs attrs $
+               XML.index $ do
+                       XML.ul $
+                               forM_ terms $ \aliases ->
+                                       XML.li $
+                                               xmlify $
+                                               TL.unlines $
+                                               plainifyWords <$> aliases
+        BlockFigure{..} ->
                xmlCommonAttrs attrs $
                XML.figure
-                ! XA.type_ (attrValue type_) $ do
-                       xmlTitle title
-                       xmlVerticals verts
-        DTC.Vertical v -> xmlVertical v
-
-xmlAbout :: DTC.About -> XML
-xmlAbout DTC.About{..} = do
-       forM_ titles   $ xmlTitle
-       forM_ authors  $ xmlAuthor
-       forM_ editor   $ xmlEditor
-       forM_ date     $ xmlDate
-       whenMayText version xmlVersion
-       forM_ keywords $ xmlKeyword
-       forM_ links    $ xmlLink
-       forM_ includes $ xmlInclude
-
-xmlInclude :: DTC.Include -> XML
-xmlInclude DTC.Include{..} =
-       XML.include True
-        ! XA.href (attrValue href)
-
-xmlKeyword :: Text -> XML
-xmlKeyword = XML.keyword . xmlText
-
-xmlVersion :: MayText -> XML
-xmlVersion (MayText t) = XML.version $ xmlText t
-
-xmlDate :: DTC.Date -> XML
-xmlDate DTC.Date{..} =
-       XML.date
-        !   XA.year (attrValue year)
-        !?? mayAttr XA.month month
-        !?? mayAttr XA.day day
-
-xmlLink :: DTC.Link -> XML
-xmlLink DTC.Link{..} =
-       XML.link
-        !?? mayAttr XA.name name
-        !?? mayAttr XA.rel  rel
-        !?? mayAttr XA.href href
-        $ xmlHorizontals body
-
-xmlAddress :: DTC.Address -> XML
-xmlAddress DTC.Address{..} =
-       XML.address
-        !?? mayAttr XA.street street
-        !?? mayAttr XA.zipcode zipcode
-        !?? mayAttr XA.city    city
-        !?? mayAttr XA.region  region
-        !?? mayAttr XA.country country
-        !?? mayAttr XA.email   email
-        !?? mayAttr XA.tel     tel
-        !?? mayAttr XA.fax     fax
-
-xmlAuthor :: DTC.Entity -> XML
-xmlAuthor DTC.Entity{..} =
-       XML.author
-        !?? mayAttr XA.name name
-        $ xmlAddress address
-
-xmlEditor :: DTC.Entity -> XML
-xmlEditor DTC.Entity{..} =
-       XML.editor
-        !?? mayAttr XA.name name
-        $ xmlAddress address
-
-xmlTitle :: DTC.Title -> XML
-xmlTitle (DTC.Title t) = XML.title $ xmlHorizontals t
-
-xmlAlias :: DTC.Alias -> XML
-xmlAlias DTC.Alias{..} = XML.alias !?? mayAttr XA.id id
-
-xmlId :: DTC.Ident -> B.Attribute
-xmlId (DTC.Ident i) = XA.id $ attrValue i
-
-xmlVerticals :: DTC.Verticals -> XML
-xmlVerticals = (`forM_` xmlVertical)
-
-xmlCommonAttrs :: DTC.CommonAttrs -> XML -> XML
-xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
+                ! XA.type_ (attrify type_) $ do
+                       xmlify mayTitle
+                       xmlify paras
+        BlockReferences{..} ->
+               xmlCommonAttrs attrs $
+               XML.references $ xmlify refs
+instance Xmlify Para where
+       xmlify = \case
+        ParaItem{..}  -> xmlify item
+        ParaItems{..} -> xmlCommonAttrs attrs $ XML.para $ xmlify items
+instance Xmlify ParaItem where
+       xmlify = \case
+        ParaPlain p -> XML.p $ xmlify p
+        ParaComment c ->
+               XML.comment $ TL.toStrict c
+        ParaArtwork{..} ->
+               XML.artwork
+                ! XA.type_ (attrify type_) $ do
+                       xmlify text
+        ParaQuote{..} ->
+               XML.quote
+                ! XA.type_ (attrify type_) $ do
+                       xmlify paras
+        ParaOL items -> XML.ol $ forM_ items xmlify
+        ParaUL items -> XML.ul $ forM_ items $ XML.li . xmlify
+instance Xmlify ListItem where
+       xmlify ListItem{..} =
+               XML.li ! XA.name (attrify name) $ xmlify paras
+instance Xmlify (Tree PlainNode) where
+       xmlify (Tree n ts) =
+               case n of
+                PlainText t   -> xmlify t
+                PlainBreak    -> XML.br
+                PlainGroup    -> xmlify ts
+                PlainB        -> XML.b    $ xmlify ts
+                PlainCode     -> XML.code $ xmlify ts
+                PlainDel      -> XML.del  $ xmlify ts
+                PlainI        -> XML.i    $ xmlify ts
+                PlainNote{..} -> XML.note $ xmlify note
+                PlainQ        -> XML.q    $ xmlify ts
+                PlainSC       -> XML.sc   $ xmlify ts
+                PlainSub      -> XML.sub  $ xmlify ts
+                PlainSup      -> XML.sup  $ xmlify ts
+                PlainU        -> XML.u    $ xmlify ts
+                PlainEref to  -> XML.eref ! XA.to (attrify to) $ xmlify ts
+                PlainIref{..} -> XML.iref ! XA.term (attrify $ plainifyWords term) $ xmlify ts
+                PlainRef  to  -> XML.ref  ! XA.to (attrify to) $ xmlify ts
+                PlainRref{..} -> XML.rref ! XA.to (attrify to) $ xmlify ts
+
+instance Xmlify About where
+       xmlify About{..} = do
+               XML.about
+                !?? mayAttr XA.url url
+                $ do
+                       xmlify titles
+                       xmlify authors
+                       xmlify editor
+                       xmlify date
+                       forM_ tags $ XML.tag . xmlify
+                       xmlify links
+                       xmlify includes
+instance Xmlify Include where
+       xmlify Include{..} =
+               XML.include True
+                ! XA.href (attrify href)
+instance Xmlify Date where
+       xmlify Date{..} =
+               XML.date
+                !   XA.year (attrify year)
+                !?? mayAttr XA.month month
+                !?? mayAttr XA.day day
+instance Xmlify Link where
+       xmlify Link{..} =
+               XML.link
+                !?? mayAttr XA.name name
+                !?? mayAttr XA.rel  rel
+                !?? mayAttr XA.href href
+                $ xmlify plain
+instance Xmlify Entity where
+       xmlify Entity{..} =
+               XML.entity
+                !?? mayAttr XA.name    name
+                !?? mayAttr XA.street  street
+                !?? mayAttr XA.zipcode zipcode
+                !?? mayAttr XA.city    city
+                !?? mayAttr XA.region  region
+                !?? mayAttr XA.country country
+                !?? mayAttr XA.email   email
+                !?? mayAttr XA.tel     tel
+                !?? mayAttr XA.fax     fax
+instance Xmlify Title where
+       xmlify (Title t) = XML.title $ xmlify t
+instance Xmlify Alias where
+       xmlify Alias{..} = XML.alias !?? mayAttr XA.id id
+instance Xmlify Reference where
+       xmlify Reference{..} = XML.reference mempty -- TODO: to be coded
+
+instance Xmlify a => Xmlify (Maybe a) where
+       xmlify = foldMap xmlify
+instance Xmlify a => Xmlify [a] where
+       xmlify = foldMap xmlify
+instance Xmlify a => Xmlify (Seq a) where
+       xmlify = foldMap xmlify
+
+xmlId :: Ident -> B.Attribute
+xmlId (Ident i) = XA.id $ attrify i
+
+xmlCommonAttrs :: CommonAttrs -> XML -> XML
+xmlCommonAttrs CommonAttrs{id=ident, ..} =
        (case ident of
-        Nothing -> \m -> m
-        Just (DTC.Ident i)  -> B.AddCustomAttribute "id" (B.Text i)) .
+        Nothing -> Fun.id
+        Just (Ident i) ->
+               B.AddCustomAttribute "id" $
+               B.String $ TL.unpack i) .
        case classes of
-        [] -> \m -> m
-        _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
-
-xmlVertical :: DTC.Vertical -> XML
-xmlVertical = \case
-        DTC.Para{..} ->
-               xmlCommonAttrs attrs $
-               XML.para $ xmlHorizontals horis
-        DTC.OL{..} ->
-               xmlCommonAttrs attrs $
-               XML.ol $ forM_ items $ XML.li . xmlVerticals
-        DTC.UL{..} ->
-               xmlCommonAttrs attrs $
-               XML.ul $ forM_ items $ XML.li . xmlVerticals
-        DTC.RL{..} ->
-               xmlCommonAttrs attrs $
-               XML.rl $ forM_ refs $ xmlReference
-        -- DTC.Index -> XML.index
-        DTC.Comment c ->
-               XML.comment c
-        DTC.Artwork{..} ->
-               xmlCommonAttrs attrs $
-               XML.artwork mempty
-
-xmlHorizontals :: DTC.Horizontals -> XML
-xmlHorizontals = (`forM_` xmlHorizontal)
-
-xmlHorizontal :: DTC.Horizontal -> XML
-xmlHorizontal = \case
- DTC.Plain txt -> B.toMarkup txt
- DTC.BR -> XML.br
- DTC.B       hs -> XML.b    $ xmlHorizontals hs
- DTC.Code    hs -> XML.code $ xmlHorizontals hs
- DTC.Del     hs -> XML.del  $ xmlHorizontals hs
- DTC.I       hs -> XML.i    $ xmlHorizontals hs
- DTC.Note    hs -> XML.note $ xmlHorizontals hs
- DTC.Q       hs -> XML.q    $ xmlHorizontals hs
- DTC.SC      hs -> XML.sc   $ xmlHorizontals hs
- DTC.Sub     hs -> XML.sub  $ xmlHorizontals hs
- DTC.Sup     hs -> XML.sup  $ xmlHorizontals hs
- DTC.Eref to hs -> XML.eref ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Iref to hs -> XML.iref ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Ref  to hs -> XML.ref  ! XA.to (attrValue to) $ xmlHorizontals hs
- DTC.Rref to hs -> XML.rref ! XA.to (attrValue to) $ xmlHorizontals hs
-
-xmlReference :: DTC.Reference -> XML
-xmlReference DTC.Reference{..} =
-       XML.reference mempty
+        [] -> Fun.id
+        _ ->
+               B.AddCustomAttribute "class" $
+               B.String $ TL.unpack $ TL.unwords classes