Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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

…error in preprocessing
  • Loading branch information...
commit d5d0bb3162d0d1197984f3901f1a196dd6c47922 1 parent 85d978b
Diego Echeverri authored
4 Config/Master.hs
@@ -11,8 +11,8 @@ import Config.App
11 11
12 12 compileArgs =
13 13 [ "-fglasgow-exts"
14   - , "-fallow-overlapping-instances"
15   - , "-fallow-undecidable-instances"
  14 + , "-XOverlappingInstances"
  15 + , "-XUndecidableInstances"
16 16 , "-F", "-pgmFtrhsx"
17 17 , "-fno-warn-overlapping-patterns"
18 18 , "-odir " ++ compiledDir
185 Turbinado/Environment/CodeStore.hs
@@ -15,7 +15,12 @@ import Prelude hiding (lookup,catch)
15 15 import System.Directory
16 16 import System.FilePath
17 17 import System.IO
18   -import System.Plugins
  18 +--import System.Plugins
  19 +import GHC
  20 +import GHC.Paths
  21 +import DynFlags
  22 +import Unsafe.Coerce
  23 +
19 24 import System.Plugins.Utils
20 25 import System.Time
21 26
@@ -76,7 +81,6 @@ checkReloadCode ct cmap cstat cl = do
76 81 return cmap
77 82 True -> do debugM $ " CodeStore : checkReloadCode : Need reload"
78 83 loadCode ct cmap cl
79   -
80 84
81 85 -- The beast
82 86 -- 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
90 94
91 95 mergeCode :: CodeType -> CodeMap -> CodeLocation -> Controller CodeMap
92 96 mergeCode ct cmap cl = do
93   - debugM $ "\tMerging " ++ (fst cl)
94   - -- d <- getCurrentDirectory
95   - --debugM $ " stub " ++ joinPath [normalise d, normalise $ getStub ct]
96   - ms <- customMergeToDir (joinPath [{-normalise d,-} normalise $ getStub ct]) (fst cl) compiledDir
97   - case ms of
98   - MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
99   - return $ insert cl (CodeLoadFailure $ unlines err) cmap
100   - MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
101   - return cmap
102   - MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
103   - makeCode ct cmap cl args fp
  97 + debugM ("\t Dummy merge : " )
  98 + makeCode ct cmap cl [] ""
  99 +
  100 +-- Not using plugins
  101 +-- MergeFailure err -> do debugM ("\tMerge error : " ++ (show err))
  102 +-- return $ insert cl (CodeLoadFailure $ unlines err) cmap
  103 +-- MergeSuccess NotReq _ _ -> do debugM ("\tMerge success (No recompilation required) : " ++ (fst cl))
  104 +-- return cmap
  105 +-- MergeSuccess _ args fp -> do debugM ("\tMerge success : " ++ (fst cl))
  106 +-- makeCode ct cmap cl args fp
104 107
105 108 makeCode :: CodeType -> CodeMap -> CodeLocation -> [Arg] -> FilePath -> Controller CodeMap
106 109 makeCode ct cmap cl args fp = do
107   - ms <- doIO $ makeAll fp (compileArgs++args)
108   - case ms of
109   - MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
110   - return (insert cl (CodeLoadFailure $ unlines err) cmap)
111   - MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
112   - return cmap
113   - MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
114   - case ct of
115   - CTController -> _loadController ct cmap cl fp
116   - _ -> _loadView ct cmap cl fp
  110 + case ct of
  111 + CTController -> _loadController ct cmap cl fp
  112 + _ -> _loadView ct cmap cl fp
  113 +
  114 + -- ms <- doIO $ makeAll fp (compileArgs++args)
  115 + -- case ms of
  116 + -- MakeFailure err -> do debugM ("\tMake error : " ++ (show err))
  117 + -- return (insert cl (CodeLoadFailure $ unlines err) cmap)
  118 + -- MakeSuccess NotReq _ -> do debugM ("\tMake success : No recomp required")
  119 + -- return cmap
  120 + -- MakeSuccess _ fp -> do debugM ("\tMake success : " ++ fp)
117 121
118 122 _loadController :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
119 123 _loadController ct cmap cl fp = do
120   - debugM ("loadController : " ++ (fst cl) ++ " : " ++ (snd cl))
121   - ls <- doIO $ load_ fp [compiledDir] (snd cl)
122   - case ls of
123   - LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
124   - return (insert cl (CodeLoadFailure $ unlines err) cmap)
125   - LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
126   - doIO $ unload m
127   - t <- doIO $ getClockTime
128   - return (insert cl (CodeLoadController f m t) cmap)
  124 + debugM ("loadController : "++ fp ++ " : " ++ (fst cl) ++ " : " ++ (snd cl))
  125 + debugM ("LoadSuccess : " ++ fst cl )
  126 + return cmap
  127 +
  128 +
  129 +
  130 + -- return (insert cl (CodeLoadController f m t) cmap)
  131 + -- ls <- doIO $ load_ fp [compiledDir] (snd cl)
  132 + -- case ls of
  133 + -- LoadFailure err -> do debugM ("LoadFailure : " ++ (show err))
  134 + -- return (insert cl (CodeLoadFailure $ unlines err) cmap)
  135 + -- LoadSuccess m f -> do debugM ("LoadSuccess : " ++ fst cl )
  136 + -- doIO $ unload m
  137 + -- t <- doIO $ getClockTime
  138 + -- return (insert cl (CodeLoadController f m t) cmap)
129 139
130 140 _loadView :: CodeType -> CodeMap -> CodeLocation -> FilePath -> Controller CodeMap
131 141 _loadView ct cmap cl fp = do
132 142 debugM ("loadView : " ++ (fst cl) ++ " : " ++ (snd cl))
133   - ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
134   - case ls of
135   - LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
136   - return (insert cl (CodeLoadFailure $ unlines err) cmap)
137   - LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
138   - doIO $ unload m
139   - t <- doIO $ getClockTime
140   - return (insert cl (CodeLoadView f m t) cmap)
  143 + debugM ("LoadSuccess : " ++ fst cl )
  144 +-- func <- runGhc (Just libdir) $ do
  145 +-- m <- moduleM "Test.hs" "Test"
  146 +-- f::String -> IO () <- (functionByNameM f m )
  147 +-- return f
  148 +
  149 + return cmap
  150 +
  151 + -- ls <- doIO $ load_ fp (compiledDir:searchDirs) (snd cl)
  152 + -- case ls of
  153 + -- LoadFailure err -> do debugM ("\tLoadFailure : " ++ (show err))
  154 + -- return (insert cl (CodeLoadFailure $ unlines err) cmap)
  155 + -- LoadSuccess m f -> do debugM ("\tLoadSuccess : " ++ fst cl )
  156 + -- doIO $ unload m
  157 + -- t <- doIO $ getClockTime
  158 + -- return (insert cl (CodeLoadView f m t) cmap)
141 159
142 160
143 161 -------------------------------------------------------------------------------------------------
144 162 -- Utility functions
145 163 -------------------------------------------------------------------------------------------------
146 164
  165 +--- Loads the module from the given path and given name
  166 +--- within the GhcMonad.
  167 +-- Path Module
  168 +moduleM :: GhcMonad m => String -> String -> m Module
  169 +moduleM p mod = do
  170 + dflags <- getSessionDynFlags
  171 + setSessionDynFlags dflags
  172 + target <- guessTarget p Nothing
  173 + addTarget target
  174 + r <- load LoadAllTargets
  175 + case r of
  176 + Failed -> error "Compilation failed"
  177 + Succeeded -> do
  178 + findModule (mkModuleName mod) Nothing
  179 +
  180 +
  181 +
  182 +--- Loads the function in the given module
  183 +--- within the GhcMonad.
  184 +--- Any alternative to unsafeCoerce?
  185 +functionByNameM :: GhcMonad m => String -> Module -> m (a)
  186 +functionByNameM name mod = do
  187 + setContext [] [mod]
  188 + f <- compileExpr (name)
  189 + do let value' = (unsafeCoerce f) :: a
  190 + return value'
  191 +
  192 +
  193 +controller :: IO ()
  194 +controller =
  195 + defaultErrorHandler defaultDynFlags $ do
  196 + func <- runGhc (Just libdir) $ do
  197 + m <- moduleM "Test.hs" "Test"
  198 + f::String -> IO () <- (functionByNameM "f" m )
  199 + return f
  200 + func "Hello"
  201 +
  202 +
  203 +
  204 +-- We are not generating .o files. So this is not going to be necessary
  205 +
147 206 -- Custom merge function because I don't want to have to use a custom
148 207 -- version of Plugins (with HSX enabled)
149   -customMergeToDir :: FilePath -> FilePath -> FilePath -> Controller MergeStatus
150   -customMergeToDir stb src dir = do
151   - src_exists <- doIO $ doesFileExist src
152   - stb_exists <- doIO $ doesFileExist stb
153   - let outFile = joinPath [dir, src]
154   - outDir = joinPath $ init $ splitDirectories outFile
155   - outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
156   - outTitle = "module " ++ outMod ++ " where \n\n"
157   - case (src_exists, stb_exists) of
158   - (False, _) -> return $
159   - MergeFailure ["Source file does not exist : "++src]
160   - (_, False) -> return $
161   - MergeFailure ["Source file does not exist : "++stb]
162   - _ -> do
163   - src_str <- doIO $ readFile src
164   - stb_str <- doIO $ readFile stb
165   - let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
166   - mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
167   - doIO $ createDirectoryIfMissing True outDir
168   - hdl <- doIO $ openFile outFile WriteMode -- overwrite!
169   - doIO $ hPutStr hdl mrg_str
170   - doIO $ hClose hdl
171   - return $ MergeSuccess ReComp [] outFile -- must have recreated file
  208 +-- customMergeToDir :: FilePath -> FilePath -> FilePath -> Controller MergeStatus
  209 +-- customMergeToDir stb src dir = do
  210 +-- src_exists <- doIO $ doesFileExist src
  211 +-- stb_exists <- doIO $ doesFileExist stb
  212 +-- let outFile = joinPath [dir, src]
  213 +-- outDir = joinPath $ init $ splitDirectories outFile
  214 +-- outMod = concat $ intersperse "." $ splitDirectories $ dropExtension src
  215 +-- outTitle = "module " ++ outMod ++ " where \n\n"
  216 +-- case (src_exists, stb_exists) of
  217 +-- (False, _) -> return $
  218 +-- MergeFailure ["Source file does not exist : "++src]
  219 +-- (_, False) -> return $
  220 +-- MergeFailure ["Source file does not exist : "++stb]
  221 +-- _ -> do
  222 +-- src_str <- doIO $ readFile src
  223 +-- stb_str <- doIO $ readFile stb
  224 +-- let (stbimps, stbdecls) = span ( not . isPrefixOf "-- SPLIT HERE") $ lines stb_str
  225 +-- mrg_str = outTitle ++ (unlines stbimps) ++ src_str ++ (unlines stbdecls)
  226 +-- doIO $ createDirectoryIfMissing True outDir
  227 +-- hdl <- doIO $ openFile outFile WriteMode -- overwrite!
  228 +-- doIO $ hPutStr hdl mrg_str
  229 +-- doIO $ hClose hdl
  230 +-- return $ MergeSuccess ReComp [] outFile -- must have recreated file
172 231
173 232
174 233 needReloadCode :: FilePath -> CodeDate -> Controller Bool
4 turbinado.cabal
@@ -16,8 +16,8 @@ Executable trhaml
16 16
17 17 Executable turbinado
18 18 Main-is: Turbinado/Server.hs
19   - 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
20   - ghc-options: -F -pgmFtrhsx -O
  19 + 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
  20 + ghc-options: -O
21 21 Extensions: MultiParamTypeClasses,
22 22 FunctionalDependencies,
23 23 TypeFamilies,

0 comments on commit d5d0bb3

Please sign in to comment.
Something went wrong with that request. Please try again.