Permalink
Browse files

POSSIBLY BROKEN; Requires GHC 6.10

  • Loading branch information...
1 parent 7aa1e0d commit 116a98e3f2593ff89a857e46234eee5ab870911d @alsonkemp committed Feb 1, 2009
Showing 689 changed files with 99 additions and 84,738 deletions.
View
@@ -8,16 +8,16 @@ import Config.App
----------------------------------------------------------------
-- Arguments to the make system used in the Dynamic Loader
----------------------------------------------------------------
-
-compileArgs =
+compileArgs =
[ "-fglasgow-exts"
, "-XOverlappingInstances"
, "-XUndecidableInstances"
, "-F", "-pgmFtrhsx"
- , "-fno-warn-overlapping-patterns"
+ , "-fno-warn-overlapping-patterns"
, "-odir " ++ compiledDir
, "-hidir " ++ compiledDir
, "-package HDBC"
+ , "-O"
]
mUserPkgConf = [""]
View
@@ -7,9 +7,9 @@ module Turbinado.Controller (
redirectTo,
-- * Database
- quickQuery,
- quickQuery',
- run,
+ --quickQuery,
+ --quickQuery',
+ --run,
HDBC.SqlValue(..),
HDBC.SqlType(..),
@@ -27,7 +27,7 @@ module Turbinado.Controller (
module Turbinado.Environment.ViewData
) where
-import Control.Exception (catchDyn)
+import Control.OldException (catchDyn)
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans (MonadIO(..))
@@ -65,18 +65,18 @@ redirectTo l = redirectResponse l
-- * Database functions
--
-quickQuery :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
-quickQuery s vs = do e <- get
- let c = fromJust $ getDatabase e
- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery c s vs
+--quickQuery :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
+--quickQuery s vs = do e <- get
+-- let c = fromJust $ getDatabase e
+-- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery c s vs
-quickQuery' :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
-quickQuery' s vs = do e <- get
- let c = fromJust $ getDatabase e
- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' c s vs
+--quickQuery' :: String -> [HDBC.SqlValue] -> Controller [[HDBC.SqlValue]]
+--quickQuery' s vs = do e <- get
+-- let c = fromJust $ getDatabase e
+-- liftIO $ HDBC.handleSqlError $ HDBC.quickQuery' c s vs
-run :: String -> [HDBC.SqlValue] -> Controller Integer
-run s vs = do e <- get
- let c = fromJust $ getDatabase e
- liftIO $ HDBC.handleSqlError $ HDBC.run c s vs
+--run :: String -> [HDBC.SqlValue] -> Controller Integer
+--run s vs = do e <- get
+-- let c = fromJust $ getDatabase e
+-- liftIO $ HDBC.handleSqlError $ HDBC.run c s vs
@@ -14,7 +14,7 @@ module Turbinado.Controller.Exception (
) where
import Data.Typeable
-import Control.Exception (throwDyn)
+import Control.OldException (throwDyn)
data Exception
= ParameterLookupFailed String -- ^ User tried to do an irrefutable parameter lookup
@@ -10,7 +10,7 @@ module Turbinado.Controller.Monad (
liftIO, catch
) where
-import Control.Exception (catchDyn)
+import Control.OldException (catchDyn)
import Control.Monad.State
import Control.Monad.Trans (MonadIO(..), liftIO)
@@ -177,13 +177,13 @@ generateCommon = unlines $
,""
,"module App.Models.Bases.Common("
," module App.Models.Bases.Common,"
- ," module Control.Exception,"
+ ," module Control.OldException,"
," module Control.Monad.Trans,"
," module Data.Int"
," ) where"
,""
,"import Control.Monad.Trans"
- ,"import Control.Exception"
+ ,"import Control.OldException"
,"import Database.HDBC"
,"import Data.Int"
,""
@@ -65,13 +65,13 @@ retrieveCode ct cl' = do
return CodeLoadMissing
Just (CodeLoadFailure e) -> do debugM (fst cl ++ " : CodeLoadFailure " )
return (CodeLoadFailure e)
- Just clc@(CodeLoadController _ _ _) -> do debugM (fst cl ++ " : CodeLoadController " )
+ Just clc@(CodeLoadController _ _) -> do debugM (fst cl ++ " : CodeLoadController " )
return clc
- Just clv@(CodeLoadView _ _ _) -> do debugM (fst cl ++ " : CodeLoadView" )
+ Just clv@(CodeLoadView _ _) -> do debugM (fst cl ++ " : CodeLoadView" )
return clv
- Just clc@(CodeLoadComponentController _ _ _) -> do debugM (fst cl ++ " : CodeLoadComponentController " )
+ Just clc@(CodeLoadComponentController _ _) -> do debugM (fst cl ++ " : CodeLoadComponentController " )
return clc
- Just clv@(CodeLoadComponentView _ _ _) -> do debugM (fst cl ++ " : CodeLoadComponentView" )
+ Just clv@(CodeLoadComponentView _ _) -> do debugM (fst cl ++ " : CodeLoadComponentView" )
return clv
-- | Checks to see if the file exists and if the file is newer than the loaded function. If the
@@ -129,58 +129,55 @@ makeCode :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> [Arg] -
makeCode ct cmap cl args fp = do
ms <- liftIO $ makeAll fp (compileArgs++args)
case ms of
- MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
- return (insert cl (CodeLoadFailure $ unlines err) cmap)
- MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
- return cmap
- MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
- case ct of
- CTLayout -> _loadView ct cmap cl fp
- CTView -> _loadView ct cmap cl fp
- CTComponentView -> _loadView ct cmap cl fp
- CTController -> _loadController ct cmap cl fp
- CTComponentController -> _loadController ct cmap cl fp
+ MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
+ MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
+ return cmap
+ MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
+ case ct of
+ CTLayout -> _loadView ct cmap cl args fp
+ CTView -> _loadView ct cmap cl args fp
+ CTComponentView -> _loadView ct cmap cl args fp
+ CTController -> _loadController ct cmap cl args fp
+ CTComponentController -> _loadController ct cmap cl args fp
-- | Attempt to load the code and return the 'CodeMap' with the newly loaded code in it. This
-- function is specialized for Views.
-_loadView :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
-_loadView ct cmap cl fp = do
+_loadView :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> m CodeMap
+_loadView ct cmap cl args fp = do
debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
ls <- liftIO $ load_ fp [compiledDir] (snd cl)
case ls of
- LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
- return (insert cl (CodeLoadFailure $ unlines err) cmap)
- LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
- liftIO $ unload m
- t <- liftIO $ getClockTime
- case ct of
- CTLayout -> return (insert cl (CodeLoadView f m t) cmap)
- CTView -> return (insert cl (CodeLoadView f m t) cmap)
- CTComponentView -> return (insert cl (CodeLoadComponentView f m t) cmap)
- _ -> error $ "_loadView: passed an invalid CodeType (" ++ (show ct) ++ ")"
+ LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
+ LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
+ liftIO $ unload m
+ t <- liftIO $ getClockTime
+ case ct of
+ CTLayout -> return (insert cl (CodeLoadView f t) cmap)
+ CTView -> return (insert cl (CodeLoadView f t) cmap)
-- | Attempt to load the code and return the 'CodeMap' with the newly loaded code in it. This
-- function is specialized for Controllers.
-_loadController :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> FilePath -> m CodeMap
-_loadController ct cmap cl fp = do
+_loadController :: (HasEnvironment m) => CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> m CodeMap
+_loadController ct cmap cl args fp = do
debugM ("_load : " ++ (show ct) ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
ls <- liftIO $ load_ fp [compiledDir] (snd cl)
- case ls of
- LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
- return (insert cl (CodeLoadFailure $ unlines err) cmap)
- LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
- liftIO $ unload m
- t <- liftIO $ getClockTime
- case ct of
- CTController -> return (insert cl (CodeLoadController f m t) cmap)
- CTComponentController -> return (insert cl (CodeLoadComponentController f m t) cmap)
- _ -> error $ "_loadController: passed an invalid CodeType (" ++ (show ct) ++ ")"
-
+ case ls of
+ LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
+ return (insert cl (CodeLoadFailure $ unlines err) cmap)
+ LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
+ liftIO $ unload m
+ t <- liftIO $ getClockTime
+ case ct of
+ CTController -> return (insert cl (CodeLoadController f t) cmap)
+ CTComponentController -> return (insert cl (CodeLoadComponentController f t) cmap)
+ _ -> error $ "_loadController: passed an invalid CodeType (" ++ (show ct) ++ ")"
+
-------------------------------------------------------------------------------------------------
-- Utility functions
-------------------------------------------------------------------------------------------------
-
-- | Custom merge function because I don't want to have to use a custom
-- version of Plugins (with HSX enabled)
customMergeToDir :: (HasEnvironment m) => FilePath -> FilePath -> FilePath -> m MergeStatus
@@ -228,7 +225,7 @@ getStub ct = case ct of
getDate (CodeLoadMissing) = error "getDate called with CodeLoadMissing"
getDate (CodeLoadFailure e) = error "getDate called with CodeLoadFailure"
-getDate (CodeLoadView _ _ d) = d
-getDate (CodeLoadController _ _ d) = d
-getDate (CodeLoadComponentView _ _ d) = d
-getDate (CodeLoadComponentController _ _ d) = d
+getDate (CodeLoadView _ d) = d
+getDate (CodeLoadController _ d) = d
+getDate (CodeLoadComponentView _ d) = d
+getDate (CodeLoadComponentController _ d) = d
@@ -14,7 +14,6 @@ import HSX.XMLGenerator (XMLGenT(..), unXMLGenT)
import Turbinado.View.XML
import Config.Master
import System.Time
-import System.Plugins
-- | The class of types which hold an 'Environment'.
@@ -65,10 +64,10 @@ data CodeStore = CodeStore (MVar CodeMap)
type CodeMap = M.Map CodeLocation CodeStatus
data CodeStatus = CodeLoadMissing |
CodeLoadFailure String |
- CodeLoadController (StateT Environment IO ()) Module CodeDate |
- CodeLoadView (XMLGenT (StateT Environment IO) XML ) Module CodeDate |
- CodeLoadComponentController (StateT Environment IO ()) Module CodeDate |
- CodeLoadComponentView (XMLGenT (StateT Environment IO) XML ) Module CodeDate
+ CodeLoadController (StateT Environment IO ()) CodeDate |
+ CodeLoadView (XMLGenT (StateT Environment IO) XML ) CodeDate |
+ CodeLoadComponentController (StateT Environment IO ()) CodeDate |
+ CodeLoadComponentView (XMLGenT (StateT Environment IO) XML ) CodeDate
--
-- * Types for Database
@@ -4,11 +4,11 @@ module Turbinado.Server.Exception (
, catchTurbinado
, throwTurbinado
, throwTurbinadoTo
- , module Control.Exception
+ , module Control.OldException
) where
import Data.Typeable
-import Control.Exception
+import Control.OldException
import Control.Concurrent(ThreadId)
catchTurbinado :: IO a -> (TurbinadoException -> IO a) -> IO a
@@ -21,7 +21,6 @@ import Network.URI
import Prelude hiding (catch)
import System.Directory
import System.FilePath
-import System.Plugins
import Control.Monad
import Data.Maybe
import Data.List
@@ -85,10 +84,10 @@ retrieveAndRunController =
False -> do co <- getController
p <- retrieveCode CTController co
case p of
- CodeLoadController p' _ _ -> p'
- CodeLoadFailure e -> errorResponse e
- CodeLoadView _ _ _ -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadView"
- CodeLoadMissing -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadMissing"
+ CodeLoadController p' _ -> p'
+ CodeLoadFailure e -> errorResponse e
+ CodeLoadView _ _ -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadView"
+ CodeLoadMissing -> error "retrieveAndRunController: retrieveCode called, but returned CodeLoadMissing"
-- | This function dynamically loads (if needed) the 'View'
-- using the information provided by the 'Routes'. Views reside
@@ -109,9 +108,9 @@ retrieveAndRunLayout =
retrieveCode CTView v -- If no Layout, then pull a View
Just l' -> retrieveCode CTLayout (l', "markup")
case p of
- CodeLoadView p' _ _ -> evalView p'
- CodeLoadFailure e -> errorResponse e
- CodeLoadController _ _ _ -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadController"
- CodeLoadMissing -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadMissing"
+ CodeLoadView p' _ -> evalView p'
+ CodeLoadFailure e -> errorResponse e
+ CodeLoadController _ _ -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadController"
+ CodeLoadMissing -> error "retrieveAndRunLayout: retrieveCode called, but returned CodeLoadMissing"
View
@@ -24,7 +24,7 @@ module Turbinado.View (
module Turbinado.Environment.ViewData
) where
-import Control.Exception (catchDyn)
+import Control.OldException (catchDyn)
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans (MonadIO(..))
@@ -68,17 +68,17 @@ insertDefaultView =
debugM $ " Layout: insertDefaultView : loading " ++ (fst cl) ++ " - " ++ (snd cl)
c <- retrieveCode CTView cl
case c of
- CodeLoadView v _ _ -> v
- CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
+ CodeLoadView v _ -> v
+ CodeLoadController _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
CodeLoadFailure e -> return $ cdata e
insertView :: String -> String -> View XML
insertView c a =
do debugM $ " Layout: insertView : loading " ++ c ++ " - " ++ a
c <- retrieveCode CTView (c, (toLower (head a)):(tail a))
case c of
- CodeLoadView v _ _ -> v
- CodeLoadController _ _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
+ CodeLoadView v _ -> v
+ CodeLoadController _ _ -> error "retrieveAndRunLayout called, but returned CodeLoadController"
CodeLoadFailure e -> return $ cdata e
insertComponent :: String -> String -> [(String, String)] -> View XML
@@ -88,7 +88,7 @@ insertComponent controller action opts =
case p of
CodeLoadMissing -> return $ cdata $ "insertComponent error: code missing : " ++ controller ++ " - " ++ action
CodeLoadFailure e -> return $ cdata $ "insertComponent error: " ++ e
- CodeLoadComponentController p' _ _ -> do oldE <- getEnvironment
+ CodeLoadComponentController p' _ -> do oldE <- getEnvironment
mapM_ (\(k, v) -> setSetting k v) opts
lift $ p'
-- allow for overloading of the Component Controller and View
@@ -106,7 +106,7 @@ insertComponentView oldE controller action =
return $ cdata $ "insertComponentView error: code missing : " ++ (joinPath [controller, action]) ++ " - markup"
CodeLoadFailure e -> do setEnvironment oldE
return $ cdata $ "insertComponentView error: " ++ e
- CodeLoadComponentView v' _ _ -> do res <- v'
+ CodeLoadComponentView v' _ -> do res <- v'
setEnvironment oldE
return res
_ -> do setEnvironment oldE
@@ -18,7 +18,7 @@ module Turbinado.View.Exception (
) where
import Data.Typeable
-import Control.Exception (throwDyn)
+import Control.OldException (throwDyn)
data Exception
= ParameterLookupFailed String -- ^ User tried to do an irrefutable parameter lookup
Oops, something went wrong.

0 comments on commit 116a98e

Please sign in to comment.