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