Commit ee479722 authored by batterseapower's avatar batterseapower

Plugin tests

parent 075af955
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
.PHONY: plugins01 clean
plugins01:
# This test is extremely fragile because any change in the output of the following
# commands invalidates the output of the run. In fact, we really want to ignore the
# output resulting from building the simple-plugin, and only look at a few lines of
# the output of the call to the TEST_HC (probably just the last 2).
#
# Suggestions to make this better gratefully recieved.
(cd simple-plugin; make package)
@$(RM) plugins01.hi plugins01.o
$(TEST_HC) $(HC_OPTS) --make -v0 plugins01.hs -package-conf simple-plugin/local.package.conf -fplugin Simple.Plugin -fplugin-opt Simple.Plugin:Irrelevant_Option -package simple-plugin
./plugins01
clean:
cd simple-plugin && make clean
module Plugins05_Helper where
import GHCPlugins
plugin :: Plugin
plugin = defaultPlugin {
installCoreToDos = install
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _options todos = do
return $ (CoreDoPluginPass "String replacement" $ BindsToBindsPluginPass stringReplacementPass) : todos
stringReplacementPass :: [CoreBind] -> CoreM [CoreBind]
stringReplacementPass binds = return $ map replaceInBind binds
replaceInBind :: CoreBind -> CoreBind
replaceInBind (NonRec b e) = NonRec b (replaceInExpr e)
replaceInBind (Rec bes) = Rec [(b, replaceInExpr e) | (b, e) <- bes]
replaceInExpr :: CoreExpr -> CoreExpr
replaceInExpr (Var x) = Var x
replaceInExpr (Lit (MachStr _)) = mkStringLit "Hello From The Plugin" -- The payload
replaceInExpr (Lit l) = Lit l
replaceInExpr (Lam b e) = Lam b (replaceInExpr e)
replaceInExpr (App e1 e2) = App (replaceInExpr e1) (replaceInExpr e2)
replaceInExpr (Let bi e) = Let (replaceInBind bi) (replaceInExpr e)
replaceInExpr (Note no e) = Note no (replaceInExpr e)
replaceInExpr (Cast e co) = Cast (replaceInExpr e) co
replaceInExpr (Case e b ty alts) = Case (replaceInExpr e) b ty (map replaceInAlt alts)
replaceInExpr (Type ty) = Type ty
replaceInAlt :: CoreAlt -> CoreAlt
replaceInAlt (ac, bs, e) = (ac, bs, replaceInExpr e)
\ No newline at end of file
def f(opts):
if (ghc_with_interpreter == 0):
opts.skip = 1
setTestOpts(f)
setTestOpts(compose(alone, if_compiler_lt('ghc', '7.1', skip)))
test('plugins01', normal, run_command, ['$MAKE -s --no-print-directory plugins01'])
test('plugins02', normal, compile_fail, ['-package-conf simple-plugin/local.package.conf -fplugin Simple.BadlyTypedPlugin -package simple-plugin'])
test('plugins03', normal, compile_fail, ['-package-conf simple-plugin/local.package.conf -fplugin Simple.NonExistantPlugin -package simple-plugin'])
test('plugins05', extra_clean(['Plugins05_Helper.hi', 'Plugins05_Helper.o']), multimod_compile_and_run, ['plugins05', '-package ghc'])
if default_testopts.cleanup != '':
runCmd('$MAKE -C ' + in_testdir('') + ' clean')
-- Intended to test that the plugins have basic functionality --
-- * Can modify the program
-- * Get to see command line options
module Main where
import Simple.DataStructures
{-# ANN theMessage (ReplaceWith "Right") #-}
{-# NOINLINE theMessage #-}
theMessage = "Wrong"
main = do
putStrLn "Program Started"
putStrLn theMessage
putStrLn "Program Ended"
\ No newline at end of file
Simple Plugin Passes Queried
Got options: Irrelevant_Option
Simple Plugin Pass Run
Performing Replacement
Writing new package config file... done.
Reading package info from "dist/installed-pkg-config" ... done.
Writing new package config file... done.
Program Started
Right
Also Correct
Program Ended
-- Just used to test that badly typed plugins raise an error
module Main where
-- The contents of this file are actually irrelevant
main = return ()
\ No newline at end of file
<command line>: The value Simple.BadlyTypedPlugin.plugin did not have the type CoreMonad.Plugin as required
-- Just used to test that we correctly handle non-existant plugins
module Main where
-- The contents of this file are actually irrelevant
main = return ()
\ No newline at end of file
<command line>: Could not find module `Simple.NonExistantPlugin' Use -v to see a list of the files searched for.
{-# OPTIONS_GHC -fplugin Plugins05_Helper #-}
-- Tests home-package plugins
module Main where
main :: IO ()
main = putStrLn "Hello From The Program"
\ No newline at end of file
Copyright (c) 2008, Max Bolingbroke
All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
* Neither the name of Max Bolingbroke nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
LOCAL_PKGCONF=local.package.conf
PKG_NAME=simple-plugin
clean:
rm -f $(LOCAL_PKGCONF)
rm -rf dist
rm -rf install
PREFIX := $(abspath install)
$(eval $(call canonicalise,PREFIX))
package:
$(TEST_HC) --make -v0 -o setup Setup.hs
echo "[]" >$(LOCAL_PKGCONF)
./setup configure -v0 --prefix=$(PREFIX) --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=$(LOCAL_PKGCONF)
./setup build -v0
./setup install -v0
import Distribution.Simple
main = defaultMain
module Simple.BadlyTypedPlugin where
plugin :: Int
plugin = 1
\ No newline at end of file
{-# LANGUAGE DeriveDataTypeable #-}
module Simple.DataStructures where
import Data.Data
import Data.Typeable
data ReplaceWith = ReplaceWith String
deriving (Data, Typeable)
\ No newline at end of file
{-# LANGUAGE TemplateHaskell #-}
module Simple.Plugin(plugin) where
import UniqFM
import GhcPlugins
import qualified ErrUtils
-- For annotation tests
import Simple.DataStructures
import Control.Monad
import Data.Monoid
import Data.Dynamic
import qualified Language.Haskell.TH as TH
plugin :: Plugin
plugin = defaultPlugin {
installCoreToDos = install
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install options todos = do
putMsgS $ "Simple Plugin Passes Queried"
putMsgS $ "Got options: " ++ unwords options
-- Create some actual passes to continue the test.
return $ CoreDoPluginPass "Main pass" mainPass
: todos
findNameBinds :: String -> [CoreBind] -> First Name
findNameBinds target = mconcat . map (findNameBind target)
findNameBind :: String -> CoreBind -> First Name
findNameBind target (NonRec b e) = findNameBndr target b
findNameBind target (Rec bes) = mconcat (map (findNameBndr target . fst) bes)
findNameBndr :: String -> CoreBndr -> First Name
findNameBndr target b
= if getOccString (varName b) == target
then First (Just (varName b))
else First Nothing
mainPass :: ModGuts -> CoreM ModGuts
mainPass guts = do
putMsgS "Simple Plugin Pass Run"
anns <- getAnnotations deserializeWithData guts
bindsOnlyPass (mapM (changeBind anns Nothing)) guts
changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind
changeBind anns mb_replacement (NonRec b e) = changeBindPr anns mb_replacement b e >>= (return . uncurry NonRec)
changeBind anns mb_replacement (Rec bes) = liftM Rec $ mapM (uncurry (changeBindPr anns mb_replacement)) bes
changeBindPr :: UniqFM [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr)
changeBindPr anns mb_replacement b e = do
case lookupWithDefaultUFM anns [] b of
[] -> do
e' <- changeExpr anns mb_replacement e
return (b, e')
[ReplaceWith replace_string] -> do
e' <- changeExpr anns (Just replace_string) e
return (b, e')
_ -> error $ "Too many change_anns on one binder:" ++ showSDoc (ppr b)
changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr
changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of
Lit (MachStr _) -> case mb_replacement of
Nothing -> return e
Just replacement -> do
putMsgS "Performing Replacement"
return $ Lit (MachStr (mkFastString replacement))
App e1 e2 -> liftM2 App (go e1) (go e2)
Lam b e -> liftM (Lam b) (go e)
Let bind e -> liftM2 Let (changeBind anns mb_replacement bind) (go e)
Case e b ty alts -> liftM4 Case (go e) (return b) (return ty) (mapM (changeAlt anns mb_replacement) alts)
Cast e coerce -> liftM2 Cast (go e) (return coerce)
Note note e -> liftM (Note note) (go e)
_ -> return e
changeAlt :: UniqFM [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt
changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e)
Name: simple-plugin
Version: 0.1
Synopsis: A demonstration of the GHC plugin system.
Cabal-Version: >= 1.2
Build-Type: Simple
License: BSD3
License-File: LICENSE
Author: Max Bolingbroke
Homepage: http://blog.omega-prime.co.uk
Library
Extensions: CPP
Build-Depends:
base,
template-haskell,
ghc >= 6.11
Exposed-Modules:
Simple.Plugin
Simple.BadlyTypedPlugin
Simple.DataStructures
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment