Skip to content

Instantly share code, notes, and snippets.

@maksbotan
Created April 27, 2022 10:56
Show Gist options
  • Save maksbotan/8c7a8f531163c58da9983fbc48d45fff to your computer and use it in GitHub Desktop.
Save maksbotan/8c7a8f531163c58da9983fbc48d45fff to your computer and use it in GitHub Desktop.
Haskell Language Server + haskell.nix patch
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
index 99938bd4..471b184c 100644
--- a/ghcide/src/Development/IDE/Core/Compile.hs
+++ b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -122,6 +122,15 @@ import GHC.Hs (LEpaComment)
import qualified GHC.Types.Error as Error
#endif
+import StgSyn
+import FastString
+import Unique
+import CostCentre
+import Data.Either
+import CoreSyn
+import CoreToStg
+import SimplStg
+
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
:: IdeOptions
@@ -256,9 +265,37 @@ captureSplicesAndDeps env k = do
; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
; let hval = (expectJust "hscCompileCoreExpr'" $ lookup (idName binding_id) fv_hvs)
#else
+ {- Create a temporary binding and convert to STG -}
+ ; let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
+ (mkPseudoUniqueE 0)
+ (exprType prepd_expr)
+ ; (binds, _) <-
+ myCoreToStg hsc_env
+ (icInteractiveModule (hsc_IC hsc_env))
+ [NonRec bco_tmp_id prepd_expr]
+
+ ; let (_strings, lifted_binds) = partitionEithers $ do -- list monad
+ bnd <- binds
+ case bnd of
+ StgTopLifted (StgNonRec i expr) -> [Right (i, expr)]
+ StgTopLifted (StgRec bnds) -> map Right bnds
+ StgTopStringLit b str -> [Left (b, str)]
+
+ ; let stg_expr = case lifted_binds of
+ [(_i, e)] -> e
+ _ ->
+ StgRhsClosure noExtFieldSilent
+ dontCareCCS
+ ReEntrant
+ []
+ (StgLet noExtFieldSilent
+ (StgRec lifted_binds)
+ (StgApp bco_tmp_id []))
{- Convert to BCOs -}
; bcos <- coreExprToBCOs hsc_env
- (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+ (icInteractiveModule (hsc_IC hsc_env))
+ bco_tmp_id
+ stg_expr
; let needed_mods = mkUniqSet [ moduleName mod | n <- uniqDSetToList (bcoFreeNames bcos)
, Just mod <- [nameModule_maybe n] -- Names from other modules
@@ -1342,3 +1379,16 @@ pathToModuleName = mkModuleName . map rep
rep c | isPathSeparator c = '_'
rep ':' = '_'
rep c = c
+
+myCoreToStg :: HscEnv -> Module -> CoreProgram
+ -> IO ( [StgTopBinding] -- output program
+ , CollectedCCs ) -- CAF cost centre info (declared and used)
+myCoreToStg hsc_env this_mod prepd_binds = do
+ let (stg_binds, cost_centre_info)
+ = {-# SCC "Core2Stg" #-}
+ coreToStg (hsc_dflags hsc_env) this_mod prepd_binds
+ stg_binds2
+ <- {-# SCC "Stg2Stg" #-}
+ stg2stg hsc_env this_mod stg_binds
+
+ return (stg_binds2, cost_centre_info)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment