Rakka/Wiki/Engine.hs

   1 module Rakka.Wiki.Engine
   2     ( formatPage
   3     )
   4     where
   5
   6 import           Control.Arrow
   7 import           Control.Arrow.ArrowIO
   8 import           Control.Arrow.ArrowTree
   9 import           Data.Encoding
  10 import           Data.Encoding.UTF8
  11 import qualified Data.Map as M
  12 import           Network.HTTP.Lucu
  13 import           Rakka.Environment
  14 import           Rakka.Page
  15 import           Rakka.SystemConfig
  16 import           Rakka.Wiki
  17 import           Rakka.Wiki.Parser
  18 import           Rakka.Wiki.Formatter
  19 import           Rakka.Wiki.Interpreter
  20 import           Text.ParserCombinators.Parsec
  21 import           Text.XML.HXT.Arrow.XmlArrow
  22 import           Text.XML.HXT.DOM.TypeDefs
  23
  24
  25 formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  26               Environment
  27            -> a Page XmlTree
  28 formatPage env
  29     = proc page
  30     -> do tree <- case pageType page of
  31                     MIMEType "text" "x-rakka" _
  32                         -> do let source = decodeLazy UTF8 (pageContent page)
  33                               formatWikiPage env -< (Just page, source)
  34           attachXHtmlNs -< tree
  35
  36
  37 formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
  38                   Environment
  39                -> a (Maybe Page, String) XmlTree
  40 formatWikiPage env
  41     = proc (page, source)
  42     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
  43           interpTable     <- getInterpTableA env -< ()
  44
  45           let parser = wikiPage (tableToFunc interpTable)
  46
  47           case parse parser "" source of
  48             Left  err
  49                 -> formatParseError -< err
  50
  51             Right blocks
  52                 -> do xs <- interpretCommandsA env -< (interpTable, (page, blocks))
  53                       formatWikiBlocks -< (baseURI, xs)
  54     where
  55       tableToFunc :: InterpTable -> String -> Maybe CommandType
  56       tableToFunc table name
  57           = fmap commandType (M.lookup name table)
  58
  59
  60 interpretCommandsA :: ArrowIO a =>
  61                       Environment
  62                    -> a (InterpTable, (Maybe Page, WikiPage)) WikiPage
  63 interpretCommandsA = arrIO3 . interpretCommands
  64
  65
  66 interpretCommands :: Environment -> InterpTable -> Maybe Page -> WikiPage -> IO WikiPage
  67 interpretCommands _   _     _    []     = return []
  68 interpretCommands env table page blocks = mapM interpBlock blocks
  69     where
  70       interpBlock :: BlockElement -> IO BlockElement
  71       interpBlock (List           list) = interpList list >>= return . List
  72       interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
  73       interpBlock (Preformatted   xs  ) = mapM interpInline xs >>= return . Preformatted
  74       interpBlock (Paragraph      xs  ) = mapM interpInline xs >>= return . Paragraph
  75       interpBlock others                = return others
  76
  77       interpList :: ListElement -> IO ListElement
  78       interpList list = do items <- mapM interpListItem (listItems list)
  79                            return $ list { listItems = items }
  80
  81       interpListItem :: ListItem -> IO ListItem
  82       interpListItem []                  = return []
  83       interpListItem ((Left  nested):xs) = do x  <- interpList nested >>= return . Left
  84                                               xs <- interpListItem xs
  85                                               return (x:xs)
  86       interpListItem ((Right inline):xs) = do x  <- interpInline inline >>= return . Right
  87                                               xs <- interpListItem xs
  88                                               return (x:xs)
  89
  90       interpDefinition :: Definition -> IO Definition
  91       interpDefinition def = do term <- mapM interpInline (defTerm def)
  92                                 desc <- mapM interpInline (defDesc def)
  93                                 return $ def { defTerm = term, defDesc = desc }
  94
  95       interpInline :: InlineElement -> IO InlineElement
  96       interpInline (Italic    xs ) = mapM interpInline xs >>= return . Italic
  97       interpInline (Bold      xs ) = mapM interpInline xs >>= return . Bold
  98       interpInline (InlineCmd cmd) = interpInlineCmd cmd
  99       interpInline others          = return others
 100
 101       interpInlineCmd :: InlineCommand -> IO InlineElement
 102       interpInlineCmd cmd
 103           = case M.lookup (iCmdName cmd) table of
 104               Nothing
 105                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 106
 107               Just interp
 108                   -> iciInterpret interp cmd page (envStorage env) (envSysConf env)
 109                      >>=
 110                      interpInline
 111
 112
 113 formatParseError :: ArrowXml a => a ParseError XmlTree
 114 formatParseError
 115     = proc err -> (eelem "pre" += txt (show err)) -<< ()
 116
 117
 118 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
 119 attachXHtmlNs = processBottomUp (changeQName attach')
 120     where
 121       attach' :: QName -> QName
 122       attach' qn = qn {
 123                      namePrefix   = "xhtml"
 124                    , namespaceUri = "http://www.w3.org/1999/xhtml"
 125                    }