Browse files

Started to make the migration to ghc.load. Still not working strange …

…error in preprocessing
  • Loading branch information...
1 parent 85d978b commit d5d0bb3162d0d1197984f3901f1a196dd6c47922 Diego Echeverri committed Dec 29, 2008
Showing with 126 additions and 67 deletions.
  1. +2 −2 Config/Master.hs
  2. +122 −63 Turbinado/Environment/CodeStore.hs
  3. +2 −2 turbinado.cabal
View
4 Config/Master.hs
@@ -11,8 +11,8 @@ import Config.App
compileArgs =
[ "-fglasgow-exts"
- , "-fallow-overlapping-instances"
- , "-fallow-undecidable-instances"
+ , "-XOverlappingInstances"
+ , "-XUndecidableInstances"
, "-F", "-pgmFtrhsx"
, "-fno-warn-overlapping-patterns"
, "-odir " ++ compiledDir
View
185 Turbinado/Environment/CodeStore.hs
@@ -15,7 +15,12 @@ import Prelude hiding (lookup,catch)
import System.Directory
import System.FilePath
import System.IO
-import System.Plugins
+--import System.Plugins
+import GHC
+import GHC.Paths
+import DynFlags
+import Unsafe.Coerce
+
import System.Plugins.Utils
import System.Time
@@ -76,7 +81,6 @@ checkReloadCode ct cmap cstat cl = do
return cmap
True -> do debugM $ " CodeStore : checkReloadCode : Need reload"
loadCode ct cmap cl
-
-- The beast
-- In cases of Merge, Make or Load failures leave the original files in place and log the error
@@ -90,85 +94,140 @@ loadCode ct cmap cl = do
mergeCode :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
mergeCode ct cmap cl = do
- debugM $ "\tMerging " ++ (fst cl)
- -- d <- getCurrentDirectory
- --debugM $ " stub " ++ joinPath [normalise d, normalise $ getStub ct]
- ms <- customMergeToDir (joinPath [{-normalise d,-} normalise $ getStub ct]) (fst cl) compiledDir
- case ms of
- MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
- return $ insert cl (CodeLoadFailure $ unlines err) cmap
- MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
- return cmap
- MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
- makeCode ct cmap cl args fp
+ debugM ("\t Dummy merge : " )
+ makeCode ct cmap cl [] ""
+
+-- Not using plugins
+-- MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
+-- return $ insert cl (CodeLoadFailure $ unlines err) cmap
+-- MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
+-- return cmap
+-- MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
+-- makeCode ct cmap cl args fp
makeCode :: CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> Controller CodeMap
makeCode ct cmap cl args fp = do
- ms <- doIO $ 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
- CTController -> _loadController ct cmap cl fp
- _ -> _loadView ct cmap cl fp
+ case ct of
+ CTController -> _loadController ct cmap cl fp
+ _ -> _loadView ct cmap cl fp
+
+ -- ms <- doIO $ 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)
_loadController :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
_loadController ct cmap cl fp = do
- debugM ("loadController : " ++ (fst cl) ++ " : " ++ (snd cl))
- ls <- doIO $ 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 )
- doIO $ unload m
- t <- doIO $ getClockTime
- return (insert cl (CodeLoadController f m t) cmap)
+ debugM ("loadController : "++ fp ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
+ debugM ("LoadSuccess : " ++ fst cl )
+ return cmap
+
+
+
+ -- return (insert cl (CodeLoadController f m t) cmap)
+ -- ls <- doIO $ 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 )
+ -- doIO $ unload m
+ -- t <- doIO $ getClockTime
+ -- return (insert cl (CodeLoadController f m t) cmap)
_loadView :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
_loadView ct cmap cl fp = do
debugM ("loadView : " ++ (fst cl) ++ " : " ++ (snd cl))
- ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
- case ls of
- LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
- return (insert cl (CodeLoadFailure $ unlines err) cmap)
- LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
- doIO $ unload m
- t <- doIO $ getClockTime
- return (insert cl (CodeLoadView f m t) cmap)
+ debugM ("LoadSuccess : " ++ fst cl )
+-- func <- runGhc (Just libdir) $ do
+-- m <- moduleM "Test.hs" "Test"
+-- f::String -> IO () <- (functionByNameM f m )
+-- return f
+
+ return cmap
+
+ -- ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
+ -- case ls of
+ -- LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
+ -- return (insert cl (CodeLoadFailure $ unlines err) cmap)
+ -- LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
+ -- doIO $ unload m
+ -- t <- doIO $ getClockTime
+ -- return (insert cl (CodeLoadView f m t) cmap)
-------------------------------------------------------------------------------------------------
-- Utility functions
-------------------------------------------------------------------------------------------------
+--- Loads the module from the given path and given name
+--- within the GhcMonad.
+-- Path Module
+moduleM :: GhcMonad m => String -> String -> m Module
+moduleM p mod = do
+ dflags <- getSessionDynFlags
+ setSessionDynFlags dflags
+ target <- guessTarget p Nothing
+ addTarget target
+ r <- load LoadAllTargets
+ case r of
+ Failed -> error "Compilation failed"
+ Succeeded -> do
+ findModule (mkModuleName mod) Nothing
+
+
+
+--- Loads the function in the given module
+--- within the GhcMonad.
+--- Any alternative to unsafeCoerce?
+functionByNameM :: GhcMonad m => String -> Module -> m (a)
+functionByNameM name mod = do
+ setContext [] [mod]
+ f <- compileExpr (name)
+ do let value' = (unsafeCoerce f) :: a
+ return value'
+
+
+controller :: IO ()
+controller =
+ defaultErrorHandler defaultDynFlags $ do
+ func <- runGhc (Just libdir) $ do
+ m <- moduleM "Test.hs" "Test"
+ f::String -> IO () <- (functionByNameM "f" m )
+ return f
+ func "Hello"
+
+
+
+-- We are not generating .o files. So this is not going to be necessary
+
-- Custom merge function because I don't want to have to use a custom
-- version of Plugins (with HSX enabled)
-customMergeToDir :: FilePath -> FilePath -> FilePath -> Controller MergeStatus
-customMergeToDir stb src dir = do
- src_exists <- doIO $ doesFileExist src
- stb_exists <- doIO $ doesFileExist stb
- let outFile = joinPath [dir, src]
- outDir = joinPath $ init $ splitDirectories outFile
- outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
- outTitle = "module " ++ outMod ++ " where \n\n"
- case (src_exists, stb_exists) of
- (False, _) -> return $
- MergeFailure ["Source file does not exist : "++src]
- (_, False) -> return $
- MergeFailure ["Source file does not exist : "++stb]
- _ -> do
- src_str <- doIO $ readFile src
- stb_str <- doIO $ readFile stb
- let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
- mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
- doIO $ createDirectoryIfMissing True outDir
- hdl <- doIO $ openFile outFile WriteMode -- overwrite!
- doIO $ hPutStr hdl mrg_str
- doIO $ hClose hdl
- return $ MergeSuccess ReComp [] outFile -- must have recreated file
+-- customMergeToDir :: FilePath -> FilePath -> FilePath -> Controller MergeStatus
+-- customMergeToDir stb src dir = do
+-- src_exists <- doIO $ doesFileExist src
+-- stb_exists <- doIO $ doesFileExist stb
+-- let outFile = joinPath [dir, src]
+-- outDir = joinPath $ init $ splitDirectories outFile
+-- outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
+-- outTitle = "module " ++ outMod ++ " where \n\n"
+-- case (src_exists, stb_exists) of
+-- (False, _) -> return $
+-- MergeFailure ["Source file does not exist : "++src]
+-- (_, False) -> return $
+-- MergeFailure ["Source file does not exist : "++stb]
+-- _ -> do
+-- src_str <- doIO $ readFile src
+-- stb_str <- doIO $ readFile stb
+-- let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
+-- mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
+-- doIO $ createDirectoryIfMissing True outDir
+-- hdl <- doIO $ openFile outFile WriteMode -- overwrite!
+-- doIO $ hPutStr hdl mrg_str
+-- doIO $ hClose hdl
+-- return $ MergeSuccess ReComp [] outFile -- must have recreated file
needReloadCode :: FilePath -> CodeDate -> Controller Bool
View
4 turbinado.cabal
@@ -16,8 +16,8 @@ Executable trhaml
Executable turbinado
Main-is: Turbinado/Server.hs
- Build-Depends: base, bytestring, containers, directory, filepath, harp, HDBC, HDBC-postgresql, hslogger, hsx, HTTP, mtl, network, old-locale, old-time, parsec, plugins, pretty, regex-compat, time
- ghc-options: -F -pgmFtrhsx -O
+ Build-Depends: base, ghc, ghc-paths, bytestring, containers, directory, filepath, harp, HDBC, HDBC-postgresql, hslogger, hsx, HTTP, mtl, network, old-locale, old-time, parsec, plugins, pretty, regex-compat, time
+ ghc-options: -O
Extensions: MultiParamTypeClasses,
FunctionalDependencies,
TypeFamilies,

0 comments on commit d5d0bb3

Please sign in to comment.