Language/DTC/Sym.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DuplicateRecordFields #-}
   3 {-# LANGUAGE NamedFieldPuns #-}
   4 {-# LANGUAGE NoMonomorphismRestriction #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE TypeFamilyDependencies #-}
   8 module Language.DTC.Sym where
   9
  10 import Control.Applicative (Applicative(..), Alternative(..), optional, (<$>), (<$))
  11 import Data.Foldable (Foldable,foldl',foldr)
  12 import Data.Function (($),(.),flip)
  13 import Data.Int (Int)
  14 import Data.Maybe (Maybe(..), maybe)
  15 import Data.Text (Text)
  16 import Text.Show (Show)
  17 import qualified Data.Text as Text
  18
  19 import Language.DTC.Document (Default(..), MayText(..))
  20 import Language.TCT.Write.XML (XmlName(..))
  21 import qualified Language.DTC.Document as DTC
  22
  23 foldlApp :: (DTC.Default a, Foldable t) => t (a -> a) -> a
  24 foldlApp = foldl' (flip ($)) def
  25 foldrApp :: (DTC.Default a, Foldable t) => t (a -> a) -> a
  26 foldrApp = foldr ($) def
  27
  28 class (Applicative repr, Alternative repr) => Sym_RNC repr where
  29         rule      :: Show a => Text -> repr a -> repr a
  30         element   :: XmlName -> repr a -> repr a
  31         attribute :: XmlName -> repr a -> repr a
  32         comment   :: repr Text
  33         try       :: repr a -> repr a
  34         none      :: repr ()
  35         anyElem   :: Show a => (XmlName -> repr a) -> repr a
  36         any       :: repr ()
  37         text      :: repr Text
  38         int       :: repr Int
  39         nat       :: repr DTC.Nat
  40         nat1      :: repr DTC.Nat1
  41         choice    :: [repr a] -> repr a
  42         intermany :: [repr a] -> repr [a]
  43         intermany = many . choice . (try <$>)
  44
  45         type Perm repr = (r :: * -> *) | r -> repr
  46         interleaved :: Perm repr a -> repr a
  47         (<$$>) :: (a -> b) -> repr a -> Perm repr b
  48
  49         (<$?>) :: (a -> b) -> (a,repr a) -> Perm repr b
  50         (<||>) :: Perm repr (a -> b) -> repr a -> Perm repr b
  51         (<|?>) :: Perm repr (a -> b) -> (a,repr a) -> Perm repr b
  52
  53         (<$*>) :: ([a] -> b) -> repr a -> Perm repr b
  54         (<|*>) :: Perm repr ([a] -> b) -> repr a -> Perm repr b
  55
  56 infixl 2 <$$>, <$?>, <$*>
  57 infixl 1 <||>, <|?>, <|*>
  58
  59 class Sym_RNC repr => Sym_DTC repr where
  60         title       :: repr DTC.Title
  61         name        :: repr Text
  62         url         :: repr DTC.URL
  63         path        :: repr DTC.Path
  64         ident       :: repr DTC.Ident
  65         to          :: repr DTC.Ident
  66         id          :: repr DTC.Ident
  67         date        :: repr DTC.Date
  68         include     :: repr DTC.Include
  69         horizontals :: repr DTC.Horizontals
  70         horizontal  :: repr DTC.Horizontal
  71         verticals   :: repr DTC.Verticals
  72         vertical    :: repr DTC.Vertical
  73         reference   :: repr DTC.Reference
  74         document    :: repr DTC.Document
  75         head        :: repr DTC.Head
  76         about       :: repr DTC.About
  77         keyword     :: repr Text
  78         version     :: repr MayText
  79         author      :: repr DTC.Entity
  80         editor      :: repr DTC.Entity
  81         entity      :: repr DTC.Entity
  82         address     :: repr DTC.Address
  83         link        :: repr DTC.Link
  84         serie       :: repr DTC.Serie
  85         alias       :: repr DTC.Alias
  86         commonAttrs :: repr DTC.CommonAttrs
  87         commonAttrs =
  88                 interleaved $
  89                 DTC.CommonAttrs
  90                  <$?> (def, id)
  91                  <|?> (def, rule "class" $ attribute "class" $ Text.words <$> text)
  92
  93         document = rule "document" $
  94                 DTC.Document
  95                  <$> head
  96                  <*> many (
  97                         choice
  98                          [ rule "section" $
  99                                 element "section" $
 100                                 DTC.Section
 101                                  <$> commonAttrs
 102                                  <*> title
 103                                  <*> many alias
 104                                  <*> verticals
 105                          , vertical
 106                          ]
 107                  )
 108         head = rule "head" $
 109                 maybe def DTC.Head
 110                  <$> optional (rule "about" $ element "about" about)
 111         title = rule "title" $ DTC.Title <$> element "title" horizontals
 112         name  = rule "name"  $ attribute "name" text
 113         url   = rule "url"   $ DTC.URL   <$> text
 114         path  = rule "path"  $ DTC.Path  <$> text
 115         ident = rule "ident" $ DTC.Ident <$> text
 116         to    = rule "to"    $ attribute "to" ident
 117         id    = rule "id"    $ attribute "id" ident
 118         date  = rule "date"  $
 119                 element "date" $
 120                 interleaved $
 121                 DTC.Date
 122                  <$?> (0, attribute "year" int)
 123                  <|?> (Nothing, Just <$> attribute "month" nat1)
 124                  <|?> (Nothing, Just <$> attribute "day"   nat1)
 125         include  = rule "include"  $
 126                 element "include" $
 127                 interleaved $
 128                 DTC.Include
 129                  <$?> (def, attribute "href" path)
 130         verticals = many vertical
 131         vertical = rule "vertical" $
 132                 choice
 133                  [ DTC.Comment <$> comment
 134                  , element "para" $ DTC.Para
 135                          <$> commonAttrs
 136                          <*> horizontals
 137                  , element "ol" $ DTC.OL
 138                          <$> commonAttrs
 139                          <*> many (element "li" verticals)
 140                  , element "ul" $ DTC.UL
 141                          <$> commonAttrs
 142                          <*> many (element "li" verticals)
 143                  , element "rl" $ DTC.RL
 144                          <$> commonAttrs
 145                          <*> many reference
 146                  , element "toc" $ DTC.ToC
 147                          <$> commonAttrs
 148                          <*> optional (attribute "depth" int)
 149                  , element "tof" $ DTC.ToF
 150                          <$> commonAttrs
 151                          <*> optional (attribute "depth" int)
 152                  , element "index" $ DTC.Index
 153                          <$> commonAttrs
 154                          <*  any
 155                  , anyElem $ \XmlName{..} ->
 156                                 case xmlNameSpace of
 157                                  "" ->
 158                                         rule "figure" $
 159                                         DTC.Figure
 160                                          <$> commonAttrs
 161                                          <*> pure xmlNameLocal
 162                                          <*> title
 163                                          <*> verticals
 164                  ]
 165         horizontals = many horizontal
 166         horizontal = rule "horizontal" $
 167                 choice
 168                  [ DTC.BR   <$  element "br"   none
 169                  , DTC.B    <$> element "b"    horizontals
 170                  , DTC.Code <$> element "code" horizontals
 171                  , DTC.Del  <$> element "del"  horizontals
 172                  , DTC.I    <$> element "i"    horizontals
 173                  , DTC.Note <$> element "note" horizontals
 174                  , DTC.Q    <$> element "q"    horizontals
 175                  , DTC.SC   <$> element "sc"   horizontals
 176                  , DTC.Sub  <$> element "sub"  horizontals
 177                  , DTC.Sup  <$> element "sup"  horizontals
 178                  , DTC.U    <$> element "u"    horizontals
 179                  , element "eref" $ DTC.Eref
 180                          <$> attribute "to" url
 181                          <*> horizontals
 182                  , element "iref" $ DTC.Iref <$> to <*> horizontals
 183                  , element "ref"  $ DTC.Ref  <$> to <*> horizontals
 184                  , element "rref" $ DTC.Rref <$> to <*> horizontals
 185                  , DTC.Plain <$> text
 186                  ]
 187         keyword = rule "keyword" $
 188                 element "keyword" text
 189         version = rule "version" $
 190                 MayText <$>
 191                 element "version" text
 192         about =
 193                 interleaved $
 194                 DTC.About
 195                  <$*> title
 196                  <|*> author
 197                  <|?> (Nothing, Just <$> editor)
 198                  <|?> (Nothing, Just <$> date)
 199                  <|?> (def, version)
 200                  <|*> keyword
 201                  <|*> link
 202                  <|*> serie
 203                  <|*> include
 204         author = rule "author" $ element "author" entity
 205         editor = rule "editor" $ element "editor" entity
 206         entity = rule "entity" $
 207                 DTC.Entity
 208                  <$> name
 209                  <*> address
 210         address = rule "address" $
 211                 element "address" $
 212                 interleaved $
 213                 DTC.Address
 214                  <$?> (def, attribute "street"  text)
 215                  <|?> (def, attribute "zipcode" text)
 216                  <|?> (def, attribute "city"    text)
 217                  <|?> (def, attribute "region"  text)
 218                  <|?> (def, attribute "country" text)
 219                  <|?> (def, attribute "email"   text)
 220                  <|?> (def, attribute "tel"     text)
 221                  <|?> (def, attribute "fax"     text)
 222         serie = rule "serie" $
 223                 element "serie" $
 224                 interleaved $
 225                 DTC.Serie
 226                  <$?> (def, attribute "name" text)
 227                  <|?> (def, attribute "key"  text)
 228         link = rule "link" $
 229                 element "link" $
 230                 interleaved $
 231                 DTC.Link
 232                  <$?> (def, attribute "name" text)
 233                  <|?> (def, attribute "href" url)
 234                  <|?> (def, attribute "rel"  text)
 235                  <|*> horizontal
 236         alias = rule "alias" $
 237                 element "alias" $
 238                 interleaved $
 239                 DTC.Alias
 240                  <$?> (def, id)
 241         reference = rule "reference" $
 242                 element "reference" $
 243                 DTC.Reference
 244                  <$> id
 245                  <*> optional (attribute "to" url)
 246                  <*> about
 247
 248          {-
 249          , element "figure" $ ul
 250                { type_ :: Text
 251                , body  :: Verticals
 252                }
 253          , Artwork     Artwork
 254          -}