Rename literal constructors
[ghc.git] / testsuite / tests / plugins / simple-plugin / Simple / Plugin.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 module Simple.Plugin(plugin) where
4
5 import UniqFM
6 import GhcPlugins
7 import qualified ErrUtils
8
9 -- For annotation tests
10 import Simple.DataStructures
11
12 import Control.Monad
13 import Data.Monoid
14 import Data.Dynamic
15 import qualified Language.Haskell.TH as TH
16
17 plugin :: Plugin
18 plugin = defaultPlugin {
19 installCoreToDos = install,
20 pluginRecompile = purePlugin
21 }
22
23 install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
24 install options todos = do
25 putMsgS $ "Simple Plugin Passes Queried"
26 putMsgS $ "Got options: " ++ unwords options
27
28 -- Create some actual passes to continue the test.
29 return $ CoreDoPluginPass "Main pass" mainPass
30 : todos
31
32 findNameBinds :: String -> [CoreBind] -> First Name
33 findNameBinds target = mconcat . map (findNameBind target)
34
35 findNameBind :: String -> CoreBind -> First Name
36 findNameBind target (NonRec b e) = findNameBndr target b
37 findNameBind target (Rec bes) = mconcat (map (findNameBndr target . fst) bes)
38
39 findNameBndr :: String -> CoreBndr -> First Name
40 findNameBndr target b
41 = if getOccString (varName b) == target
42 then First (Just (varName b))
43 else First Nothing
44
45
46 mainPass :: ModGuts -> CoreM ModGuts
47 mainPass guts = do
48 putMsgS "Simple Plugin Pass Run"
49 anns <- getAnnotations deserializeWithData guts
50 bindsOnlyPass (mapM (changeBind anns Nothing)) guts
51
52 changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind
53 changeBind anns mb_replacement (NonRec b e) = changeBindPr anns mb_replacement b e >>= (return . uncurry NonRec)
54 changeBind anns mb_replacement (Rec bes) = liftM Rec $ mapM (uncurry (changeBindPr anns mb_replacement)) bes
55
56 changeBindPr :: UniqFM [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr)
57 changeBindPr anns mb_replacement b e = do
58 case lookupWithDefaultUFM anns [] b of
59 [] -> do
60 e' <- changeExpr anns mb_replacement e
61 return (b, e')
62 [ReplaceWith replace_string] -> do
63 e' <- changeExpr anns (Just replace_string) e
64 return (b, e')
65 _ -> do dflags <- getDynFlags
66 error ("Too many change_anns on one binder:" ++ showPpr dflags b)
67
68 changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr
69 changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of
70 Lit (LitString _) -> case mb_replacement of
71 Nothing -> return e
72 Just replacement -> do
73 putMsgS "Performing Replacement"
74 return $ Lit (LitString (fastStringToByteString (mkFastString replacement)))
75 App e1 e2 -> liftM2 App (go e1) (go e2)
76 Lam b e -> liftM (Lam b) (go e)
77 Let bind e -> liftM2 Let (changeBind anns mb_replacement bind) (go e)
78 Case e b ty alts -> liftM4 Case (go e) (return b) (return ty) (mapM (changeAlt anns mb_replacement) alts)
79 Cast e coerce -> liftM2 Cast (go e) (return coerce)
80 Tick t e -> liftM (Tick t) (go e)
81 _ -> return e
82
83 changeAlt :: UniqFM [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt
84 changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e)