[Git][ghc/ghc][wip/D5373] Add a test for hole fit plugins
Matthías Páll Gissurarson
gitlab at gitlab.haskell.org
Tue Jun 4 19:08:38 UTC 2019
Matthías Páll Gissurarson pushed to branch wip/D5373 at Glasgow Haskell Compiler / GHC
Commits:
36239989 by Matthías Páll Gissurarson at 2019-06-04T19:08:26Z
Add a test for hole fit plugins
- - - - -
8 changed files:
- testsuite/tests/plugins/Makefile
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal
- + testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
- + testsuite/tests/plugins/hole-fit-plugin/Makefile
- + testsuite/tests/plugins/hole-fit-plugin/Setup.hs
- + testsuite/tests/plugins/test-hole-plugin.hs
- + testsuite/tests/plugins/test-hole-plugin.stderr
Changes:
=====================================
testsuite/tests/plugins/Makefile
=====================================
@@ -130,3 +130,7 @@ T16104:
T16260:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T16260.hs -package-db simple-plugin/pkg.T16260/local.package.conf -fplugin Simple.TrustworthyPlugin
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 T16260.hs -package-db simple-plugin/pkg.T16260/local.package.conf -fplugin Simple.TrustworthyPlugin -fplugin-trustworthy
+
+.PHONY: HoleFitPlugin
+HoleFitPlugin:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 HoleFitPlugin.hs -package-db hole-fit-plugin/pkg.hole-fit-plugin/local.package.conf
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -200,8 +200,16 @@ test('T16104',
],
makefile_test, [])
+
test('T16260',
[extra_files(['simple-plugin/']),
pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.T16260 TOP={top}')
],
makefile_test, [])
+
+test('test-hole-plugin',
+ [extra_files(['hole-fit-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C hole-fit-plugin package.hole-fit-plugin TOP={top}'),
+ extra_hc_opts("-package-db hole-fit-plugin/pkg.hole-fit-plugin/local.package.conf ")
+ ],
+ compile, ['-fdefer-typed-holes'])
=====================================
testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.cabal
=====================================
@@ -0,0 +1,11 @@
+name: HoleFitPlugin
+cabal-version: >= 1.24
+build-type: Simple
+version: 1.0.0
+
+
+library
+ default-language: Haskell2010
+ build-depends: base, ghc, time
+ exposed-modules: HoleFitPlugin
+ ghc-options: -Wall
=====================================
testsuite/tests/plugins/hole-fit-plugin/HoleFitPlugin.hs
=====================================
@@ -0,0 +1,89 @@
+{-# LANGUAGE TypeApplications, RecordWildCards #-}
+module HoleFitPlugin where
+
+import GhcPlugins hiding ((<>))
+
+import TcHoleErrors
+
+import Data.List (stripPrefix, sortOn)
+
+import TcRnTypes
+
+import TcRnMonad
+
+import Text.Read
+
+
+
+data HolePluginState = HPS { holesChecked :: Int
+ , holesLimit :: Maybe Int}
+
+bumpHolesChecked :: HolePluginState -> HolePluginState
+bumpHolesChecked (HPS h l) = HPS (h + 1) l
+
+initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
+initPlugin [limit] = newTcRef $ HPS 0 $
+ case readMaybe @Int limit of
+ Just number -> Just number
+ _ -> error $ "Invalid argument to plugin: " <> show limit
+initPlugin _ = newTcRef $ HPS 0 Nothing
+
+fromModule :: HoleFitCandidate -> [String]
+fromModule (GreHFCand gre) =
+ map (moduleNameString . importSpecModule) $ gre_imp gre
+fromModule _ = []
+
+toHoleFitCommand :: TypedHole -> String -> Maybe String
+toHoleFitCommand TyH{holeCt = Just (CHoleCan _ h)} str
+ = stripPrefix ("_" <> str) $ occNameString $ holeOcc h
+toHoleFitCommand _ _ = Nothing
+
+
+-- | This candidate plugin filters the candidates by module,
+-- using the name of the hole as module to search in
+modFilterTimeoutP :: [CommandLineOption] -> TcRef HolePluginState -> CandPlugin
+modFilterTimeoutP _ ref hole cands = do
+ updTcRef ref bumpHolesChecked
+ HPS {..} <- readTcRef ref
+ return $ case holesLimit of
+ -- If we're out of checks, remove any candidates, so nothing is checked.
+ Just limit | holesChecked > limit -> []
+ _ -> case toHoleFitCommand hole "only_" of
+ Just modName -> filter (inScopeVia modName) cands
+ _ -> cands
+ where inScopeVia modNameStr cand@(GreHFCand _) =
+ elem (toModName modNameStr) $ fromModule cand
+ inScopeVia _ _ = False
+ toModName = replace '_' '.'
+ replace :: Eq a => a -> a -> [a] -> [a]
+ replace _ _ [] = []
+ replace a b (x:xs) = (if x == a then b else x):replace a b xs
+
+
+modSortP :: [CommandLineOption] -> TcRef HolePluginState -> FitPlugin
+modSortP _ ref hole hfs = do
+ HPS {..} <- readTcRef ref
+ return $ case holesLimit of
+ Just limit | holesChecked > limit -> [RawHoleFit $ text msg]
+ _ -> case toHoleFitCommand hole "sort_by_mod" of
+ -- If only_ is on, the fits will all be from the same module.
+ Just ('_':'d':'e':'s':'c':_) -> reverse hfs
+ Just _ -> orderByModule hfs
+ _ -> hfs
+ where orderByModule :: [HoleFit] -> [HoleFit]
+ orderByModule = sortOn (fmap fromModule . mbHFCand)
+ mbHFCand :: HoleFit -> Maybe HoleFitCandidate
+ mbHFCand HoleFit {hfCand = c} = Just c
+ mbHFCand _ = Nothing
+ msg = "Error: Too many holes were checked, and the search aborted for"
+ <> "this hole. Try again with a higher limit."
+
+plugin :: Plugin
+plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
+
+holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
+holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
+ where initP = initPlugin opts
+ stopP = const $ return ()
+ pluginDef ref = HoleFitPlugin { candPlugin = modFilterTimeoutP opts ref
+ , fitPlugin = modSortP opts ref }
=====================================
testsuite/tests/plugins/hole-fit-plugin/Makefile
=====================================
@@ -0,0 +1,18 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean.%:
+ rm -rf pkg.$*
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package.%:
+ $(MAKE) -s --no-print-directory clean.$*
+ mkdir pkg.$*
+ "$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
+ "$(GHC_PKG)" init pkg.$*/local.package.conf
+ pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling) --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf
+ pkg.$*/setup build --distdir pkg.$*/dist -v0
+ pkg.$*/setup install --distdir pkg.$*/dist -v0
=====================================
testsuite/tests/plugins/hole-fit-plugin/Setup.hs
=====================================
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
=====================================
testsuite/tests/plugins/test-hole-plugin.hs
=====================================
@@ -0,0 +1,19 @@
+{-# OPTIONS -fplugin=HoleFitPlugin
+ -fplugin-opt=HoleFitPlugin:4
+ -funclutter-valid-hole-fits #-}
+module Main where
+
+import Prelude hiding (head, last)
+
+import Data.List (head, last)
+
+
+f, g, h, i, j :: [Int] -> Int
+f = _too_long
+j = _
+i = _sort_by_mod_desc
+g = _only_Data_List
+h = _only_Prelude
+
+main :: IO ()
+main = return ()
=====================================
testsuite/tests/plugins/test-hole-plugin.stderr
=====================================
@@ -0,0 +1,66 @@
+
+test-hole-plugin.hs:12:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _too_long :: [Int] -> Int
+ Or perhaps ‘_too_long’ is mis-spelled, or not in scope
+ • In the expression: _too_long
+ In an equation for ‘f’: f = _too_long
+ • Relevant bindings include
+ f :: [Int] -> Int (bound at test-hole-plugin.hs:12:1)
+ Valid hole fits include
+ Error: Too many holes were checked, and the search aborted forthis hole. Try again with a higher limit.
+
+test-hole-plugin.hs:13:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _ :: [Int] -> Int
+ • In the expression: _
+ In an equation for ‘j’: j = _
+ • Relevant bindings include
+ j :: [Int] -> Int (bound at test-hole-plugin.hs:13:1)
+ Valid hole fits include
+ j :: [Int] -> Int
+ f :: [Int] -> Int
+ i :: [Int] -> Int
+ g :: [Int] -> Int
+ h :: [Int] -> Int
+ head :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+
+test-hole-plugin.hs:14:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _sort_by_mod_desc :: [Int] -> Int
+ Or perhaps ‘_sort_by_mod_desc’ is mis-spelled, or not in scope
+ • In the expression: _sort_by_mod_desc
+ In an equation for ‘i’: i = _sort_by_mod_desc
+ • Relevant bindings include
+ i :: [Int] -> Int (bound at test-hole-plugin.hs:14:1)
+ Valid hole fits include
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ last :: forall a. [a] -> a
+ (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
+
+test-hole-plugin.hs:15:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _only_Data_List :: [Int] -> Int
+ Or perhaps ‘_only_Data_List’ is mis-spelled, or not in scope
+ • In the expression: _only_Data_List
+ In an equation for ‘g’: g = _only_Data_List
+ • Relevant bindings include
+ g :: [Int] -> Int (bound at test-hole-plugin.hs:15:1)
+ Valid hole fits include
+ head :: forall a. [a] -> a
+ last :: forall a. [a] -> a
+
+test-hole-plugin.hs:16:5: warning: [-Wtyped-holes (in -Wdefault)]
+ • Found hole: _only_Prelude :: [Int] -> Int
+ Or perhaps ‘_only_Prelude’ is mis-spelled, or not in scope
+ • In the expression: _only_Prelude
+ In an equation for ‘h’: h = _only_Prelude
+ • Relevant bindings include
+ h :: [Int] -> Int (bound at test-hole-plugin.hs:16:1)
+ Valid hole fits include
+ length :: forall (t :: * -> *) a. Foldable t => t a -> Int
+ maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ minimum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
+ product :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
+ sum :: forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/36239989ba692c4a4d4a707be9882eb8d5f0dde8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/36239989ba692c4a4d4a707be9882eb8d5f0dde8
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190604/8f89ada4/attachment-0001.html>
More information about the ghc-commits
mailing list