Language/DTC/Document.hs

   1 {-# LANGUAGE DisambiguateRecordFields #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 module Language.DTC.Document where
   7
   8 import Control.Applicative (Applicative(..))
   9 import Data.Eq (Eq)
  10 import Data.Int (Int)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Ord (Ord)
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Sequence (Seq)
  15 import Data.String (IsString(..))
  16 import Data.Text (Text)
  17 import Text.Show (Show)
  18 import qualified Data.Sequence as Seq
  19 import Language.TCT.Write.XML (XmlPos(..))
  20
  21 -- * Class 'Default'
  22 class Default a where
  23         def :: a
  24 instance Default Text where
  25         def = ""
  26 instance Default (Maybe a) where
  27         def = Nothing
  28 instance Default [a] where
  29         def = []
  30 instance Default (Seq a) where
  31         def = Seq.empty
  32
  33 -- * Type 'MayText'
  34 newtype MayText
  35  =      MayText { unMayText :: Text }
  36  deriving (Eq,Show,Default)
  37 instance Semigroup MayText where
  38         MayText "" <> y = y
  39         x <> MayText "" = x
  40         _x <> y          = y
  41
  42 whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
  43 whenMayText (MayText "") _f = pure ()
  44 whenMayText t f = f t
  45
  46 -- * Type 'Nat'
  47 newtype Nat = Nat Int
  48  deriving (Eq, Ord, Show)
  49
  50 -- * Type 'Nat1'
  51 newtype Nat1 = Nat1 Int
  52  deriving (Eq, Ord, Show)
  53
  54 -- * Type 'Document'
  55 data Document
  56  =   Document
  57  {   head  :: Head
  58  ,   body  :: [Body]
  59  } deriving (Eq,Show)
  60 instance Default Document where
  61         def = Document
  62          { head  = def
  63          , body  = def
  64          }
  65
  66 -- * Type 'Head'
  67 data Head
  68  =   Head
  69  {   about :: About
  70  } deriving (Eq,Show)
  71 instance Default Head where
  72         def = Head
  73          { about = def
  74          }
  75
  76 -- ** Type 'About'
  77 data About
  78  =   About
  79  {   titles   :: [Title]
  80  ,   authors  :: [Entity]
  81  ,   editor   :: Maybe Entity
  82  ,   date     :: Maybe Date
  83  ,   version  :: MayText
  84  ,   keywords :: [Text]
  85  ,   links    :: [Link]
  86  ,   series   :: [Serie]
  87  ,   includes :: [Include]
  88  } deriving (Eq,Show)
  89 instance Default About where
  90         def = About
  91          { includes = def
  92          , titles   = def
  93          , date     = def
  94          , version  = def
  95          , editor   = def
  96          , authors  = def
  97          , keywords = def
  98          , links    = def
  99          , series   = def
 100          }
 101 instance Semigroup About where
 102         x <> y = About
 103          { titles   = titles   x <> titles   y
 104          , authors  = authors  x <> authors  y
 105          , editor   = editor   x <> editor   y
 106          , date     = date     x <> date     y
 107          , version  = version  x <> version  y
 108          , keywords = keywords x <> keywords y
 109          , links    = links    x <> links    y
 110          , series   = series   x <> series   y
 111          , includes = includes x <> includes y
 112          }
 113
 114 -- * Type 'Body'
 115 data Body
 116  = Section { attrs   :: CommonAttrs
 117            , title   :: Title
 118            , aliases :: [Alias]
 119            , body    :: [Body]
 120            , pos     :: XmlPos
 121            }
 122  | Verticals [Vertical]
 123  deriving (Eq,Show)
 124
 125 -- * Type 'Vertical'
 126 data Vertical
 127  = Para    { attrs :: CommonAttrs
 128            , horis :: Horizontals
 129            , pos   :: XmlPos
 130            }
 131  | OL      { attrs :: CommonAttrs
 132            , items :: [Verticals]
 133            , pos   :: XmlPos
 134            }
 135  | UL      { attrs :: CommonAttrs
 136            , items :: [Verticals]
 137            , pos   :: XmlPos
 138            }
 139  | RL      { attrs :: CommonAttrs
 140            , refs  :: [Reference]
 141            , pos   :: XmlPos
 142            }
 143  | ToC     { attrs :: CommonAttrs
 144            , depth :: Maybe Int
 145            , pos   :: XmlPos
 146            }
 147  | ToF     { attrs :: CommonAttrs
 148            , depth :: Maybe Int
 149            , pos   :: XmlPos
 150            }
 151  | Index   { attrs :: CommonAttrs
 152            , pos   :: XmlPos
 153            }
 154  | Figure  { type_ :: Text
 155            , attrs :: CommonAttrs
 156            , title :: Title
 157            , verts :: Verticals
 158            , pos   :: XmlPos
 159            }
 160  | Artwork { attrs :: CommonAttrs
 161            , art   :: Artwork
 162            , pos   :: XmlPos
 163            }
 164  | Comment Text
 165  deriving (Eq,Show)
 166
 167 -- * Type 'CommonAttrs'
 168 data CommonAttrs
 169  =   CommonAttrs
 170  {   id      :: Maybe Ident
 171  ,   classes :: [Text]
 172  } deriving (Eq,Show)
 173
 174 -- * Type 'Auto'
 175 data Auto
 176  =   Auto
 177  {   auto_id :: Ident
 178  } deriving (Eq,Show)
 179
 180 -- * Type 'Verticals'
 181 type Verticals = [Vertical]
 182
 183 -- * Type 'Artwork'
 184 data Artwork
 185  =   Raw Text
 186  deriving (Eq,Show)
 187
 188 -- * Type 'Horizontal'
 189 data Horizontal
 190  =   BR
 191  |   B    Horizontals
 192  |   Code Horizontals
 193  |   Del  Horizontals
 194  |   I    Horizontals
 195  |   Note Horizontals
 196  |   Q    Horizontals
 197  |   SC   Horizontals
 198  |   Sub  Horizontals
 199  |   Sup  Horizontals
 200  |   U    Horizontals
 201  |   Eref {href :: URL  , text :: Horizontals}
 202  |   Iref {to   :: Ident, text :: Horizontals}
 203  |   Ref  {to   :: Ident, text :: Horizontals}
 204  |   Rref {to   :: Ident, text :: Horizontals}
 205  |   Plain Text
 206  deriving (Eq,Show)
 207
 208 -- * Type 'Horizontals'
 209 type Horizontals = [Horizontal]
 210
 211 -- * Type 'Ident'
 212 newtype Ident = Ident { unIdent :: Text }
 213  deriving (Eq,Show,Default,IsString)
 214
 215 -- * Type 'Title'
 216 newtype Title = Title { unTitle :: Horizontals }
 217  deriving (Eq,Show,Default)
 218
 219 -- * Type 'URL'
 220 newtype URL = URL Text
 221  deriving (Eq,Show,Default)
 222
 223 -- * Type 'Path'
 224 newtype Path = Path Text
 225  deriving (Eq,Show,Default)
 226
 227
 228 -- ** Type 'Address'
 229 data Address
 230  =   Address
 231  {   street  :: Text
 232  ,   zipcode :: Text
 233  ,   city    :: Text
 234  ,   region  :: Text
 235  ,   country :: Text
 236  ,   email   :: Text
 237  ,   tel     :: Text
 238  ,   fax     :: Text
 239  } deriving (Eq,Show)
 240 instance Default Address where
 241         def = Address
 242          { street  = def
 243          , zipcode = def
 244          , city    = def
 245          , region  = def
 246          , country = def
 247          , email   = def
 248          , tel     = def
 249          , fax     = def
 250          }
 251
 252 -- * Type 'Include'
 253 data Include
 254  =   Include
 255  {   href :: Path
 256  } deriving (Eq,Show)
 257 instance Default Include where
 258         def = Include
 259          { href = def
 260          }
 261
 262 -- * Type 'Reference'
 263 data Reference
 264  =   Reference
 265  {   id    :: Ident
 266  ,   to    :: Maybe URL
 267  ,   about :: About
 268  } deriving (Eq,Show)
 269 reference :: Ident -> Reference
 270 reference id =
 271         Reference
 272          { id
 273          , to    = def
 274          , about = def
 275          }
 276 instance Default Reference where
 277         def = reference def
 278
 279 -- * Type 'Entity'
 280 data Entity
 281  =   Entity
 282  {   name    :: Text
 283  ,   address :: Address
 284  } deriving (Eq,Show)
 285 instance Default Entity where
 286         def = Entity
 287          { name    = def
 288          , address = def
 289          }
 290 instance Semigroup Entity where
 291         _x <> y = y
 292
 293 -- * Type 'Date'
 294 data Date
 295  =   Date
 296  {   year  :: Int
 297  ,   month :: Maybe Nat1
 298  ,   day   :: Maybe Nat1
 299  } deriving (Eq,Show)
 300 instance Default Date where
 301         def = Date
 302          { year  = 1970
 303          , month = Just (Nat1 01)
 304          , day   = Just (Nat1 01)
 305          }
 306 instance Semigroup Date where
 307         _x <> y = y
 308
 309 -- * Type 'Link'
 310 data Link
 311  =   Link
 312  {   name  :: Text
 313  ,   href  :: URL
 314  ,   rel   :: Text
 315  ,   body  :: Horizontals
 316  } deriving (Eq,Show)
 317 instance Default Link where
 318         def = Link
 319          { name = def
 320          , href = def
 321          , rel  = def
 322          , body = def
 323          }
 324
 325 -- * Type 'Alias'
 326 data Alias
 327  =   Alias
 328  {   id :: Ident
 329  } deriving (Eq,Show)
 330 instance Default Alias where
 331         def = Alias
 332          { id = def
 333          }
 334
 335 -- * Type 'Serie'
 336 data Serie
 337  =   Serie
 338  {   name :: Text
 339  ,   key  :: Text
 340  } deriving (Eq,Show)
 341 instance Default Serie where
 342         def = Serie
 343          { name = def
 344          , key  = def
 345          }