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       ctx :: InterpreterContext
  71       ctx = InterpreterContext {
  72                   ctxPage    = page
  73                 , ctxTree    = blocks
  74                 , ctxStorage = envStorage env
  75                 , ctxSysConf = envSysConf env
  76                 }
  77
  78       interpBlock :: BlockElement -> IO BlockElement
  79       interpBlock (List list)           = interpList list >>= return . List
  80       interpBlock (DefinitionList defs) = mapM interpDefinition defs >>= return . DefinitionList
  81       interpBlock (Preformatted xs)     = mapM interpInline xs >>= return . Preformatted
  82       interpBlock (Paragraph xs)        = mapM interpInline xs >>= return . Paragraph
  83       interpBlock (Div attrs xs)        = mapM interpBlock xs >>= return . Div attrs
  84       interpBlock (BlockCmd cmd)        = interpBlockCmd cmd
  85       interpBlock others                = return others
  86
  87       interpList :: ListElement -> IO ListElement
  88       interpList list = do items <- mapM interpListItem (listItems list)
  89                            return $ list { listItems = items }
  90
  91       interpListItem :: ListItem -> IO ListItem
  92       interpListItem []                  = return []
  93       interpListItem ((Left  nested):xs) = do x  <- interpList nested >>= return . Left
  94                                               xs <- interpListItem xs
  95                                               return (x:xs)
  96       interpListItem ((Right inline):xs) = do x  <- interpInline inline >>= return . Right
  97                                               xs <- interpListItem xs
  98                                               return (x:xs)
  99
 100       interpDefinition :: Definition -> IO Definition
 101       interpDefinition def = do term <- mapM interpInline (defTerm def)
 102                                 desc <- mapM interpInline (defDesc def)
 103                                 return $ def { defTerm = term, defDesc = desc }
 104
 105       interpBlockCmd :: BlockCommand -> IO BlockElement
 106       interpBlockCmd cmd
 107           = case M.lookup (bCmdName cmd) table of
 108               Nothing
 109                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 110
 111               Just interp
 112                   -> bciInterpret interp ctx cmd
 113                      >>=
 114                      interpBlock
 115
 116       interpInline :: InlineElement -> IO InlineElement
 117       interpInline (Italic xs)     = mapM interpInline xs >>= return . Italic
 118       interpInline (Bold xs )      = mapM interpInline xs >>= return . Bold
 119       interpInline (Span attrs xs) = mapM interpInline xs >>= return . Span attrs
 120       interpInline (InlineCmd cmd) = interpInlineCmd cmd
 121       interpInline others          = return others
 122
 123       interpInlineCmd :: InlineCommand -> IO InlineElement
 124       interpInlineCmd cmd
 125           = case M.lookup (iCmdName cmd) table of
 126               Nothing
 127                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 128
 129               Just interp
 130                   -> iciInterpret interp ctx cmd
 131                      >>=
 132                      interpInline
 133
 134
 135 formatParseError :: ArrowXml a => a ParseError XmlTree
 136 formatParseError
 137     = proc err -> (eelem "pre" += txt (show err)) -<< ()
 138
 139
 140 attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree
 141 attachXHtmlNs = processBottomUp (changeQName attach')
 142     where
 143       attach' :: QName -> QName
 144       attach' qn = qn {
 145                      namePrefix   = "xhtml"
 146                    , namespaceUri = "http://www.w3.org/1999/xhtml"
 147                    }