From: pho <pho@cielonegro.org>
Date: Tue, 23 Oct 2007 15:32:43 +0000 (+0900)
Subject: Farewell the dream of plug-in system... It's way too hard to implement nicely. Many... 
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=commitdiff_plain;h=8f77b5949ccd5f2272a02c852d51bfa2ecfa84c8

Farewell the dream of plug-in system... It's way too hard to implement nicely. Many problems arose during the implementation.

darcs-hash:20071023153243-62b54-c6bcb14fd0d8be2231448cbfafec9b2b086184d2.gz
---

diff --git a/Makefile b/Makefile
index b64ac45..624dbea 100644
--- a/Makefile
+++ b/Makefile
@@ -1,11 +1,11 @@
 CABAL_FILE = Rakka.cabal
 GHC        = ghc
-EXECUTABLE = sudo rakka -p 8989 -l DEBUG
+EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG
 
 build: .setup-config Setup
 	./Setup build
 
-run: install
+run: build
 	$(EXECUTABLE)
 
 .setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in
diff --git a/Rakka.cabal b/Rakka.cabal
index 4d72b21..7df3dc4 100644
--- a/Rakka.cabal
+++ b/Rakka.cabal
@@ -20,23 +20,9 @@ Category:
     Web
 Tested-With:
     GHC == 6.6.1
-Extensions:
-    Arrows
-GHC-Options:
-    -fwarn-unused-imports -fglasgow-exts
 Build-Depends:
     Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hslogger,
     hxt, mtl, network, parsec, stm, unix
-Exposed-Modules:
-    Rakka.Page
-    Rakka.Plugin
-    Rakka.Storage
-    Rakka.SystemConfig
-    Rakka.Utils
-    Rakka.Wiki
-    Rakka.Wiki.Interpreter
-Other-Modules:
-    Rakka.Storage.DefaultPage
 Data-Files:
     defaultpages/Help/SampleImage/Large
     defaultpages/Help/SampleImage/Small
@@ -55,13 +41,21 @@ Main-Is:
     Main.hs
 Other-Modules:
     Rakka.Environment
+    Rakka.Page
+    Rakka.Plugin
     Rakka.Resource
     Rakka.Resource.Index
     Rakka.Resource.Object
     Rakka.Resource.Render
+    Rakka.Storage
+    Rakka.Storage.DefaultPage
+    Rakka.SystemConfig
+    Rakka.Utils
+    Rakka.Wiki
+    Rakka.Wiki.Interpreter
     Rakka.Wiki.Interpreter.Base
-    Rakka.Wiki.Interpreter.Base.Image
-    Rakka.Wiki.Interpreter.Base.Outline
+    Rakka.Wiki.Interpreter.Image
+    Rakka.Wiki.Interpreter.Outline
     Rakka.Wiki.Engine
     Rakka.Wiki.Formatter
     Rakka.Wiki.Parser
diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs
index 6ae6f11..48105b4 100644
--- a/Rakka/Environment.hs
+++ b/Rakka/Environment.hs
@@ -2,13 +2,9 @@ module Rakka.Environment
     ( Environment(..)
     , InterpTable
     , setupEnv
-    , getInterpTable
-    , getInterpTableA
     )
     where
 
-import           Control.Concurrent.STM
-import           Control.Arrow.ArrowIO
 import           Data.Map (Map)
 import qualified Data.Map as M
 import           Network
@@ -16,7 +12,9 @@ import qualified Network.HTTP.Lucu.Config as LC
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Wiki.Interpreter
-import           Rakka.Wiki.Interpreter.Base
+import qualified Rakka.Wiki.Interpreter.Base    as Base
+import qualified Rakka.Wiki.Interpreter.Image   as Image
+import qualified Rakka.Wiki.Interpreter.Outline as Outline
 import           Subversion.Repository
 import           System.Directory
 import           System.FilePath
@@ -31,7 +29,7 @@ data Environment = Environment {
     , envRepository    :: !Repository
     , envStorage       :: !Storage
     , envSysConf       :: !SystemConfig
-    , envInterpTable   :: !(TVar InterpTable)
+    , envInterpTable   :: !InterpTable
     }
 
 
@@ -40,11 +38,12 @@ type InterpTable = Map String Interpreter
 
 setupEnv :: FilePath -> PortNumber -> IO Environment
 setupEnv lsdir portNum
-    = do let lucuConf  = LC.defaultConfig {
-                           LC.cnfServerPort = PortNumber portNum
-                         }
-             reposPath = lsdir `combine` "repos"
-             storage   = mkStorage
+    = do let lucuConf    = LC.defaultConfig {
+                             LC.cnfServerPort = PortNumber portNum
+                           }
+             reposPath   = lsdir `combine` "repos"
+             storage     = mkStorage
+             interpTable = mkInterpTable
          
          reposExist  <- doesDirectoryExist reposPath
          repos       <- if reposExist then
@@ -54,7 +53,7 @@ setupEnv lsdir portNum
                             do noticeM logger ("Creating a subversion repository on " ++ reposPath)
                                createRepository reposPath [] []
          sysConf     <- mkSystemConfig lucuConf repos
-         interpTable <- mkInterpTable
+         
 
          return $ Environment {
                       envLocalStateDir = lsdir
@@ -66,17 +65,13 @@ setupEnv lsdir portNum
                     }
 
 
-mkInterpTable :: IO (TVar InterpTable)
-mkInterpTable = newTVarIO (listToTable baseInterpreters)
+mkInterpTable :: InterpTable
+mkInterpTable = listToTable $
+                foldl (++) [] [ Base.interpreters
+                              , Image.interpreters
+                              , Outline.interpreters
+                              ]
     where
       listToTable :: [Interpreter] -> InterpTable
       listToTable xs
           = M.fromList [ (commandName x, x) | x <- xs ]
-
-
-getInterpTable :: Environment -> IO InterpTable
-getInterpTable = atomically . readTVar . envInterpTable
-
-
-getInterpTableA :: ArrowIO a => Environment -> a b InterpTable
-getInterpTableA = arrIO0 . getInterpTable
diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index eb986ea..2b751d4 100644
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -29,9 +29,8 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 formatPage env
     = proc page
     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
-          interpTable     <- getInterpTableA env -< ()
-          wiki            <- wikifyPage env -< (interpTable, page)
-          xs              <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki)))
+          wiki            <- wikifyPage env -< page
+          xs              <- interpretCommandsA env -< (pageName page, (Just wiki, wiki))
           formatWikiBlocks -< (baseURI, xs)
 
 
@@ -41,27 +40,26 @@ formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
 formatSubPage env
     = proc (mainPageName, (mainPage, subPage))
     -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< ()
-          interpTable     <- getInterpTableA env -< ()
           mainWiki        <- case mainPage of
                                Just page
-                                   -> do wiki <- wikifyPage env -< (interpTable, page)
+                                   -> do wiki <- wikifyPage env -< page
                                          returnA -< Just wiki
                                Nothing
                                    -> returnA -< Nothing
-          subWiki        <- wikifyPage env -< (interpTable, subPage)
-          xs             <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki)))
+          subWiki        <- wikifyPage env -< subPage
+          xs             <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki))
           formatWikiBlocks -< (baseURI, xs)
 
 
 wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                  Environment
-              -> a (InterpTable, Page) WikiPage
+              -> a Page WikiPage
 wikifyPage env
-    = proc (interpTable, page)
+    = proc page
     -> case pageType page of
          MIMEType "text" "x-rakka" _
              -> do let source = decodeLazy UTF8 (pageContent page)
-                       parser = wikiPage (tableToFunc interpTable)
+                       parser = wikiPage tableToFunc
 
                    case parse parser "" source of
                      Left  err
@@ -70,20 +68,20 @@ wikifyPage env
                      Right xs
                          -> returnA -< xs
     where
-      tableToFunc :: InterpTable -> String -> Maybe CommandType
-      tableToFunc table name
-          = fmap commandType (M.lookup name table)
+      tableToFunc :: String -> Maybe CommandType
+      tableToFunc name
+          = fmap commandType (M.lookup name (envInterpTable env))
 
 
 interpretCommandsA :: ArrowIO a =>
                       Environment
-                   -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage
-interpretCommandsA = arrIO4 . interpretCommands
+                   -> a (PageName, (Maybe WikiPage, WikiPage)) WikiPage
+interpretCommandsA = arrIO3 . interpretCommands
 
 
-interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
-interpretCommands _   _     _    _        []         = return []
-interpretCommands env table name mainTree targetTree
+interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage
+interpretCommands _   _    _        []         = return []
+interpretCommands env name mainTree targetTree
     = everywhereM' (mkM interpBlockCmd) targetTree
       >>=
       everywhereM' (mkM interpInlineCmd)
@@ -103,7 +101,7 @@ interpretCommands env table name mainTree targetTree
 
       interpBlockCmd' :: BlockCommand -> IO BlockElement
       interpBlockCmd' cmd
-          = case M.lookup (bCmdName cmd) table of
+          = case M.lookup (bCmdName cmd) (envInterpTable env) of
               Nothing
                   -> fail ("no such interpreter: " ++ bCmdName cmd)
 
@@ -117,7 +115,7 @@ interpretCommands env table name mainTree targetTree
 
       interpInlineCmd' :: InlineCommand -> IO InlineElement
       interpInlineCmd' cmd
-          = case M.lookup (iCmdName cmd) table of
+          = case M.lookup (iCmdName cmd) (envInterpTable env) of
               Nothing
                   -> fail ("no such interpreter: " ++ iCmdName cmd)
 
diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs
index f2fd602..0070a83 100644
--- a/Rakka/Wiki/Interpreter/Base.hs
+++ b/Rakka/Wiki/Interpreter/Base.hs
@@ -1,24 +1,18 @@
 module Rakka.Wiki.Interpreter.Base
-    ( baseInterpreters
+    ( interpreters
     )
     where
 
 import           Rakka.Wiki
 import           Rakka.Wiki.Interpreter
-import           Rakka.Wiki.Interpreter.Base.Image
-import           Rakka.Wiki.Interpreter.Base.Outline
 
 
-baseInterpreters :: [Interpreter]
-baseInterpreters = [ lineBreakInterp
-                   , spanInterp
-                   , divInterp
-                   , imageInterp
-                   , imgFrameInterp
-
-                   , pageNameInterp
-                   , outlineInterp
-                   ]
+interpreters :: [Interpreter]
+interpreters = [ lineBreakInterp
+               , spanInterp
+               , divInterp
+               , pageNameInterp
+               ]
 
 
 lineBreakInterp :: Interpreter
diff --git a/Rakka/Wiki/Interpreter/Base/Image.hs b/Rakka/Wiki/Interpreter/Image.hs
similarity index 95%
rename from Rakka/Wiki/Interpreter/Base/Image.hs
rename to Rakka/Wiki/Interpreter/Image.hs
index f73b205..7f64de0 100644
--- a/Rakka/Wiki/Interpreter/Base/Image.hs
+++ b/Rakka/Wiki/Interpreter/Image.hs
@@ -1,6 +1,5 @@
-module Rakka.Wiki.Interpreter.Base.Image
-    ( imageInterp
-    , imgFrameInterp
+module Rakka.Wiki.Interpreter.Image
+    ( interpreters
     )
     where
 
@@ -13,6 +12,12 @@ import           Rakka.Wiki.Interpreter
 import           Rakka.Wiki
 
 
+interpreters :: [Interpreter]
+interpreters = [ imageInterp
+               , imgFrameInterp
+               ]
+
+
 -- <a href="..." class="inlineImage ...">
 --   <img src="..." alt="..." />
 -- </a>
diff --git a/Rakka/Wiki/Interpreter/Base/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs
similarity index 95%
rename from Rakka/Wiki/Interpreter/Base/Outline.hs
rename to Rakka/Wiki/Interpreter/Outline.hs
index d0e21ab..04554a6 100644
--- a/Rakka/Wiki/Interpreter/Base/Outline.hs
+++ b/Rakka/Wiki/Interpreter/Outline.hs
@@ -1,5 +1,5 @@
-module Rakka.Wiki.Interpreter.Base.Outline
-    ( outlineInterp
+module Rakka.Wiki.Interpreter.Outline
+    ( interpreters
     )
     where
 
@@ -8,6 +8,10 @@ import           Rakka.Wiki
 import           Rakka.Wiki.Interpreter
 
 
+interpreters :: [Interpreter]
+interpreters = [ outlineInterp ]
+
+
 outlineInterp :: Interpreter
 outlineInterp = BlockCommandInterpreter {
                   bciName      = "outline"