blob: b20f3fe80aae6791f9a6a3dd86d71b6427d433c1 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module Simple.ReplacePlugin(plugin) where
import GHC.Types.Unique.FM
import GHC.Plugins
import qualified GHC.Utils.Error
import GHC.Types.TyThing
import Debug.Trace
import Data.Bifunctor (second)
import Control.Monad
import qualified Language.Haskell.TH as TH
import Data.List (isSuffixOf)
woz :: Int -> Int
woz x = trace ("Got " ++ show x) x
plugin :: Plugin
plugin = defaultPlugin {
installCoreToDos = install,
pluginRecompile = purePlugin
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install options todos = do
mb <- thNameToGhcName 'woz
case mb of
Nothing -> error "Failed to locate woz"
Just m -> do
rep <- lookupId m
return $ CoreDoPluginPass "Replace wiz with woz" (fixGuts rep) : todos
fixGuts :: Id -> ModGuts -> CoreM ModGuts
fixGuts rep guts = pure $ guts { mg_binds = fmap fix_bind (mg_binds guts) }
where
fix_bind (NonRec b e) = NonRec b (fix_expr e)
fix_bind (Rec bes) = Rec (fmap (second fix_expr) bes)
fix_expr :: CoreExpr -> CoreExpr
fix_expr = \case
Var i -> if "$wiz" `isSuffixOf` nameStableString (idName i)
then Var rep
else Var i
Lit l -> Lit l
App e1 e2 -> App (fix_expr e1) (fix_expr e2)
Lam b e -> Lam b (fix_expr e)
Case e b t as -> Case (fix_expr e) b t (map fix_alt as)
Cast e c -> Cast (fix_expr e) c
Tick t e -> Tick t (fix_expr e)
Type t -> Type t
Coercion c -> Coercion c
fix_alt (Alt c bs e) = Alt c bs (fix_expr e)
|
