Fix writing TCT to XML.

[doclang.git] / Language / DTC / Document.hs

{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.DTC.Document
 ( module Language.DTC.Document
 , module Language.XML
 ) where

import Data.Default.Class (Default(..))
import Data.Default.Instances.Containers ()
import Data.Eq (Eq)
import Data.Function (on)
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..), Trees)
import Text.Show (Show)

import Language.XML

-- * Type 'Document'
data Document
 =   Document
 {   head  :: Head
 ,   body  :: Body
 } deriving (Eq,Show)
instance Default Document where
        def = Document
         { head  = def
         , body  = mempty
         }

-- * Type 'Head'
data Head
 =   Head
 {   about :: About
 } deriving (Eq,Show)
instance Default Head where
        def = Head
         { about = def
         }

-- ** Type 'About'
data About
 =   About
 {   titles   :: [Title]
 ,   url      :: Maybe URL
 ,   authors  :: [Entity]
 ,   editor   :: Maybe Entity
 ,   date     :: Maybe Date
 ,   version  :: MayText
 ,   keywords :: [Text]
 ,   links    :: [Link]
 ,   series   :: [Serie]
 ,   includes :: [Include]
 } deriving (Eq,Show)
instance Default About where
        def = About
         { includes = def
         , titles   = def
         , url      = def
         , date     = def
         , version  = def
         , editor   = def
         , authors  = def
         , keywords = def
         , links    = def
         , series   = def
         }
instance Semigroup About where
        x <> y = About
         { titles   = titles   x <> titles   y
         , url      = url (x::About) <> url (y::About)
         , authors  = authors  x <> authors  y
         , editor   = editor   x <> editor   y
         , date     = date     x <> date     y
         , version  = version  x <> version  y
         , keywords = keywords x <> keywords y
         , links    = links    x <> links    y
         , series   = series   x <> series   y
         , includes = includes x <> includes y
         }

-- * Type 'Body'
type Body = Trees BodyKey BodyValue

-- ** Type 'BodyKey'
data BodyKey
 = Section { pos     :: Pos
           , attrs   :: CommonAttrs
           , title   :: Title
           , aliases :: [Alias]
           }
 deriving (Eq,Show)

-- ** Type 'BodyValue'
data BodyValue
 = ToC        { pos   :: Pos
              , attrs :: CommonAttrs
              , depth :: Maybe Nat
              }
 | ToF        { pos   :: Pos
              , attrs :: CommonAttrs
              , types :: [Text]
              }
 | Figure     { pos    :: Pos
              , attrs  :: CommonAttrs
              , type_  :: Text
              , title  :: Maybe Title
              , blocks :: Blocks
              }
 | Index      { pos   :: Pos
              , attrs :: CommonAttrs
              , terms :: Terms
              }
 | References { pos   :: Pos
              , attrs :: CommonAttrs
              , refs  :: [Reference]
              }
 | Block Block
 deriving (Eq,Show)

-- ** Type 'Pos'
data Pos
 =   Pos
 {   posAncestors                :: PosPath
 ,   posAncestorsWithFigureNames :: PosPath
 ,   posPrecedingsSiblings       :: Map XmlName Rank
 } deriving (Eq,Show)
instance Ord Pos where
        compare = compare `on` posAncestors
instance Default Pos where
        def = Pos mempty mempty mempty

-- *** Type 'PosPath'
type PosPath = Seq (XmlName,Rank)

-- ** Type 'Word'
type Word = Text

-- *** Type 'Words'
type Words = [WordOrSpace]

-- **** Type 'WordOrSpace'
data WordOrSpace
 =   Word Word
 |   Space
 deriving (Eq,Ord,Show)

-- ** Type 'Aliases'
type Aliases = [Words]

-- ** Type 'Terms'
type Terms = [Aliases]

-- * Type 'Count'
type Count = Int

-- * Type 'Block'
data Block
 = Para    { pos   :: Pos
           , attrs :: CommonAttrs
           , para  :: Para
           }
 | OL      { pos   :: Pos
           , attrs :: CommonAttrs
           , items :: [Blocks]
           }
 | UL      { pos   :: Pos
           , attrs :: CommonAttrs
           , items :: [Blocks]
           }
 | Artwork { pos   :: Pos
           , attrs :: CommonAttrs
           , art   :: Artwork
           }
 | Comment Text
 deriving (Eq,Show)

-- * Type 'CommonAttrs'
data CommonAttrs
 =   CommonAttrs
 {   id      :: Maybe Ident
 ,   classes :: [Text]
 } deriving (Eq,Show)

-- * Type 'Blocks'
type Blocks = [Block]

-- * Type 'Artwork'
data Artwork
 =   Raw Text
 deriving (Eq,Show)

-- * Type 'Para'
type Para = Seq Lines

-- * Type 'Lines'
type Lines = Tree LineKey LineValue

-- ** Type 'LineKey'
data LineKey
 = B
 | Code
 | Del
 | I
 | Note {number :: Maybe Nat1}
 | Q
 | SC
 | Sub
 | Sup
 | U
 | Eref {href :: URL}
 | Iref {anchor :: Maybe Anchor, term :: Words}
 | Ref  {to :: Ident}
 | Rref {anchor :: Maybe Anchor, to :: Ident}
 deriving (Eq,Show)

-- ** Type 'Anchor'
data Anchor
 =   Anchor
 {   section :: Pos
 ,   count   :: Nat1
 } deriving (Eq,Ord,Show)

-- ** Type 'LineValue'
data LineValue
 = BR
 | Plain Text
 deriving (Eq,Show)

-- * Type 'Title'
newtype Title = Title { unTitle :: Para }
 deriving (Eq,Show,Semigroup,Monoid,Default)

-- ** Type 'Entity'
data Entity
 =   Entity
 {   name    :: Text
 ,   street  :: Text
 ,   zipcode :: Text
 ,   city    :: Text
 ,   region  :: Text
 ,   country :: Text
 ,   email   :: Text
 ,   tel     :: Text
 ,   fax     :: Text
 ,   url     :: Maybe URL
 ,   org     :: Maybe Entity
 } deriving (Eq,Show)
instance Default Entity where
        def = Entity
         { name    = def
         , street  = def
         , zipcode = def
         , city    = def
         , region  = def
         , country = def
         , email   = def
         , tel     = def
         , fax     = def
         , url     = def
         , org     = def
         }
instance Semigroup Entity where
        _x <> y = y

-- * Type 'Include'
data Include
 =   Include
 {   href :: Path
 } deriving (Eq,Show)
instance Default Include where
        def = Include
         { href = def
         }

-- * Type 'Reference'
data Reference
 =   Reference
 {   id    :: Ident
 ,   about :: About
 } deriving (Eq,Show)
reference :: Ident -> Reference
reference id =
        Reference
         { id
         , about = def
         }
instance Default Reference where
        def = reference def

-- * Type 'Date'
data Date
 =   Date
 {   year  :: Int
 ,   month :: Maybe Nat1
 ,   day   :: Maybe Nat1
 } deriving (Eq,Show)
instance Default Date where
        def = Date
         { year  = 1970
         , month = Just (Nat1 01)
         , day   = Just (Nat1 01)
         }
instance Semigroup Date where
        _x <> y = y

-- * Type 'Link'
data Link
 =   Link
 {   name :: Text
 ,   href :: URL
 ,   rel  :: Text
 ,   para :: Para
 } deriving (Eq,Show)
instance Default Link where
        def = Link
         { name = def
         , href = def
         , rel  = def
         , para = def
         }

-- * Type 'Alias'
data Alias
 =   Alias
 {   id :: Ident
 } deriving (Eq,Show)
instance Default Alias where
        def = Alias
         { id = def
         }

-- * Type 'Serie'
data Serie
 =   Serie
 {   name :: Text
 ,   key  :: Text
 } deriving (Eq,Show)
instance Default Serie where
        def = Serie
         { name = def
         , key  = def
         }