diff options
Diffstat (limited to 'testsuite/tests/plugins')
24 files changed, 293 insertions, 0 deletions
diff --git a/testsuite/tests/plugins/HomePackagePlugin.hs b/testsuite/tests/plugins/HomePackagePlugin.hs new file mode 100644 index 0000000000..3a5318a2b7 --- /dev/null +++ b/testsuite/tests/plugins/HomePackagePlugin.hs @@ -0,0 +1,34 @@ +module HomePackagePlugin where + +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _options todos = do + return $ (CoreDoPluginPass "String replacement" $ bindsOnlyPass 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 diff --git a/testsuite/tests/plugins/LinkerTicklingPlugin.hs b/testsuite/tests/plugins/LinkerTicklingPlugin.hs new file mode 100644 index 0000000000..52d5e177bb --- /dev/null +++ b/testsuite/tests/plugins/LinkerTicklingPlugin.hs @@ -0,0 +1,15 @@ +module LinkerTicklingPlugin where + +import GhcPlugins +import StaticFlags + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +-- This tests whether plugins are linking against the *running* GHC +-- or a new instance of it. If it is a new instance the staticFlags +-- won't have been initialised, so we'll get a GHC panic here: +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _options todos = length staticFlags `seq` return todos diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile new file mode 100644 index 0000000000..8edee2305e --- /dev/null +++ b/testsuite/tests/plugins/Makefile @@ -0,0 +1,20 @@ +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 diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T new file mode 100644 index 0000000000..b9d4e4497d --- /dev/null +++ b/testsuite/tests/plugins/all.T @@ -0,0 +1,18 @@ +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('plugins04', extra_clean(['HomePackagePlugin.hi', 'HomePackagePlugin.o']), multimod_compile_fail, ['plugins04', '-package ghc -fplugin HomePackagePlugin']) +test('plugins05', extra_clean(['HomePackagePlugin.hi', 'HomePackagePlugin.o']), multimod_compile_and_run, ['plugins05', '-package ghc']) + +test('plugins06', compose(expect_broken(3843), extra_clean(['LinkerTicklingPlugin.hi', 'LinkerTicklingPlugin.o'])), multimod_compile_and_run, ['plugins06', '-package ghc']) + +if default_testopts.cleanup != '': + runCmd('$MAKE -C ' + in_testdir('') + ' clean') diff --git a/testsuite/tests/plugins/plugins01.hs b/testsuite/tests/plugins/plugins01.hs new file mode 100644 index 0000000000..7bb2ec7e2e --- /dev/null +++ b/testsuite/tests/plugins/plugins01.hs @@ -0,0 +1,15 @@ +-- 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 diff --git a/testsuite/tests/plugins/plugins01.stderr b/testsuite/tests/plugins/plugins01.stderr new file mode 100644 index 0000000000..d3e2a886d9 --- /dev/null +++ b/testsuite/tests/plugins/plugins01.stderr @@ -0,0 +1,4 @@ +Simple Plugin Passes Queried +Got options: Irrelevant_Option +Simple Plugin Pass Run +Performing Replacement diff --git a/testsuite/tests/plugins/plugins01.stdout b/testsuite/tests/plugins/plugins01.stdout new file mode 100644 index 0000000000..5633757f84 --- /dev/null +++ b/testsuite/tests/plugins/plugins01.stdout @@ -0,0 +1,3 @@ +Program Started +Right +Program Ended diff --git a/testsuite/tests/plugins/plugins02.hs b/testsuite/tests/plugins/plugins02.hs new file mode 100644 index 0000000000..4fdf45c5cb --- /dev/null +++ b/testsuite/tests/plugins/plugins02.hs @@ -0,0 +1,5 @@ +-- 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 diff --git a/testsuite/tests/plugins/plugins02.stderr b/testsuite/tests/plugins/plugins02.stderr new file mode 100644 index 0000000000..2fee69361e --- /dev/null +++ b/testsuite/tests/plugins/plugins02.stderr @@ -0,0 +1 @@ +<command line>: The value Simple.BadlyTypedPlugin.plugin did not have the type CoreMonad.Plugin as required diff --git a/testsuite/tests/plugins/plugins03.hs b/testsuite/tests/plugins/plugins03.hs new file mode 100644 index 0000000000..7cc679b38f --- /dev/null +++ b/testsuite/tests/plugins/plugins03.hs @@ -0,0 +1,5 @@ +-- 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 diff --git a/testsuite/tests/plugins/plugins03.stderr b/testsuite/tests/plugins/plugins03.stderr new file mode 100644 index 0000000000..f3fbc8e9f2 --- /dev/null +++ b/testsuite/tests/plugins/plugins03.stderr @@ -0,0 +1 @@ +<command line>: Could not find module `Simple.NonExistantPlugin' Use -v to see a list of the files searched for. diff --git a/testsuite/tests/plugins/plugins04.hs b/testsuite/tests/plugins/plugins04.hs new file mode 100644 index 0000000000..ad40b2c800 --- /dev/null +++ b/testsuite/tests/plugins/plugins04.hs @@ -0,0 +1,5 @@ +-- Tests home-package plugins from command line +module Main where + +main :: IO () +main = putStrLn "Hello From The Program"
\ No newline at end of file diff --git a/testsuite/tests/plugins/plugins04.stderr b/testsuite/tests/plugins/plugins04.stderr new file mode 100644 index 0000000000..95034a449a --- /dev/null +++ b/testsuite/tests/plugins/plugins04.stderr @@ -0,0 +1,2 @@ +Module imports form a cycle: + module `HomePackagePlugin' imports itself diff --git a/testsuite/tests/plugins/plugins05.hs b/testsuite/tests/plugins/plugins05.hs new file mode 100644 index 0000000000..718939b904 --- /dev/null +++ b/testsuite/tests/plugins/plugins05.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fplugin HomePackagePlugin #-} + +-- Tests home-package plugins from OPTIONS pragma +module Main where + +main :: IO () +main = putStrLn "Hello From The Program"
\ No newline at end of file diff --git a/testsuite/tests/plugins/plugins05.stdout b/testsuite/tests/plugins/plugins05.stdout new file mode 100644 index 0000000000..ec5d984277 --- /dev/null +++ b/testsuite/tests/plugins/plugins05.stdout @@ -0,0 +1 @@ +Hello From The Plugin diff --git a/testsuite/tests/plugins/plugins06.hs b/testsuite/tests/plugins/plugins06.hs new file mode 100644 index 0000000000..ad80d2c636 --- /dev/null +++ b/testsuite/tests/plugins/plugins06.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -fplugin LinkerTicklingPlugin #-} + +module Main where + +main :: IO () +main = return () diff --git a/testsuite/tests/plugins/plugins06.stdout b/testsuite/tests/plugins/plugins06.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/plugins/plugins06.stdout diff --git a/testsuite/tests/plugins/simple-plugin/LICENSE b/testsuite/tests/plugins/simple-plugin/LICENSE new file mode 100644 index 0000000000..6297f71b3f --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/LICENSE @@ -0,0 +1,10 @@ +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. diff --git a/testsuite/tests/plugins/simple-plugin/Makefile b/testsuite/tests/plugins/simple-plugin/Makefile new file mode 100644 index 0000000000..53842deb9d --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/Makefile @@ -0,0 +1,23 @@ +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 diff --git a/testsuite/tests/plugins/simple-plugin/Setup.hs b/testsuite/tests/plugins/simple-plugin/Setup.hs new file mode 100644 index 0000000000..e8ef27dbba --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/testsuite/tests/plugins/simple-plugin/Simple/BadlyTypedPlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/BadlyTypedPlugin.hs new file mode 100644 index 0000000000..7db041232b --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/Simple/BadlyTypedPlugin.hs @@ -0,0 +1,4 @@ +module Simple.BadlyTypedPlugin where + +plugin :: Int +plugin = 1
\ No newline at end of file diff --git a/testsuite/tests/plugins/simple-plugin/Simple/DataStructures.hs b/testsuite/tests/plugins/simple-plugin/Simple/DataStructures.hs new file mode 100644 index 0000000000..ffad889c60 --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/Simple/DataStructures.hs @@ -0,0 +1,9 @@ +{-# 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 diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs new file mode 100644 index 0000000000..d362518e4f --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs @@ -0,0 +1,82 @@ +{-# 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) diff --git a/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal b/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal new file mode 100644 index 0000000000..011ed67e23 --- /dev/null +++ b/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal @@ -0,0 +1,20 @@ +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 |