diff options
Diffstat (limited to 'testsuite/tests/plugins/simple-plugin')
7 files changed, 151 insertions, 0 deletions
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 |