Move HoleFitPlugin definitions and instances to TcRnTypes
authorMatthías Páll Gissurarson <pallm@chalmers.se>
Thu, 23 May 2019 10:46:32 +0000 (12:46 +0200)
committerMatthías Páll Gissurarson <pallm@chalmers.se>
Fri, 31 May 2019 17:15:26 +0000 (19:15 +0200)
compiler/typecheck/TcHoleErrors.hs
compiler/typecheck/TcRnTypes.hs

index 74736ad..7f11c2d 100644 (file)
@@ -3,7 +3,10 @@
 module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits
                     , tcCheckHoleFit, tcSubsumes
                     , withoutUnification
-                    , fromPurePlugin
+                    , fromPureHFPlugin
+                    -- Re-exports for convenience
+                    , hfName, hfIsLcl
+                    , pprHoleFit, debugHoleFitDispConfig
 
                     -- Re-exported from TcRnTypes
                     , TypedHole (..), HoleFit (..), HoleFitCandidate (..)
@@ -40,7 +43,6 @@ import Control.Arrow ( (&&&) )
 import Control.Monad    ( filterM, replicateM, foldM )
 import Data.List        ( partition, sort, sortOn, nubBy )
 import Data.Graph       ( graphFromEdges, topSort )
-import Data.Function    ( on )
 
 
 import TcSimplify    ( simpl_top, runTcSDeriveds )
@@ -428,7 +430,6 @@ getSortingAlg =
                               then BySize
                               else NoSorting }
 
-
 hfName :: HoleFit -> Maybe Name
 hfName hf@(HoleFit {}) = Just $ case hfCand hf of
                                   IdHFCand id -> idName id
@@ -443,27 +444,6 @@ hfIsLcl hf@(HoleFit {}) = case hfCand hf of
                             GreHFCand gre -> gre_lcl gre
 hfIsLcl _ = False
 
-
--- We define an Eq and Ord instance to be able to build a graph.
-instance Eq HoleFit where
-   (==) = (==) `on` hfId
-
--- We compare HoleFits by their name instead of their Id, since we don't
--- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
--- which is used to compare Ids. When comparing, we want HoleFits with a lower
--- refinement level to come first.
-instance Ord HoleFit where
-  compare (RawHoleFit _) (RawHoleFit _) = EQ
-  compare (RawHoleFit _) _ = LT
-  compare _ (RawHoleFit _) = GT
-  compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
-    where cmp  = if hfRefLvl a == hfRefLvl b
-                 then compare `on` hfName
-                 else compare `on` hfRefLvl
-
-instance Outputable HoleFit where
-    ppr = pprHoleFit debugHoleFitDispConfig
-
 -- If enabled, we go through the fits and add any associated documentation,
 -- by looking it up in the module or the environment (for local fits)
 addDocs :: [HoleFit] -> TcM [HoleFit]
@@ -952,16 +932,6 @@ tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
 tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b
   where dummyHole = TyH emptyBag [] Nothing
 
-
-
-
-
-fromPurePlugin :: HoleFitPlugin -> HoleFitPluginR
-fromPurePlugin plug =
-  HoleFitPluginR { hfPluginInit = newTcRef ()
-                 , holeFitPluginR = const plug
-                 , hfPluginStop = const $ return () }
-
 -- | A tcSubsumes which takes into account relevant constraints, to fix trac
 -- #14273. This makes sure that when checking whether a type fits the hole,
 -- the type has to be subsumed by type of the hole as well as fulfill all
@@ -1022,3 +992,10 @@ tcCheckHoleFit (TyH {..}) hole_ty ty = discardErrs $
        setWCAndBinds binds imp wc
          = WC { wc_simple = emptyBag
               , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
+
+-- | Maps a plugin that needs no state to one with an empty one.
+fromPureHFPlugin :: HoleFitPlugin -> HoleFitPluginR
+fromPureHFPlugin plug =
+  HoleFitPluginR { hfPluginInit = newTcRef ()
+                 , holeFitPluginR = const plug
+                 , hfPluginStop = const $ return () }
index cb18d94..22fb6f7 100644 (file)
@@ -202,6 +202,7 @@ import CostCentreState
 import Control.Monad (ap, liftM, msum)
 import qualified Control.Monad.Fail as MonadFail
 import Data.Set      ( Set )
+import Data.Function ( on )
 import qualified Data.Set as S
 
 import Data.List ( sort )
@@ -3938,27 +3939,14 @@ instance Outputable TypedHole where
     = hang (text "TypedHole") 2
         (ppr rels $+$ ppr implics $+$ ppr ct)
 
--- | A plugin for modifying the candidate hole fits *before* they're checked.
-type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
-
--- | A plugin for modifying hole fits  *after* they've been found.
-type FitPlugin =  TypedHole -> [HoleFit] -> TcM [HoleFit]
-
-data HoleFitPlugin = HoleFitPlugin
-  { candPlugin :: CandPlugin
-  , fitPlugin :: FitPlugin }
-
-data HoleFitPluginR = forall s. HoleFitPluginR
-  { hfPluginInit :: TcM (TcRef s)
-  , holeFitPluginR :: TcRef s -> HoleFitPlugin
-  , hfPluginStop :: TcRef s -> TcM () }
 
--- | HoleFitCandidates are passed to the filter and checked whether they can be
--- made to fit.
+-- | HoleFitCandidates are passed to hole fit plugins and then
+-- checked whether they fit a given typed-hole.
 data HoleFitCandidate = IdHFCand Id             -- An id, like locals.
                       | NameHFCand Name         -- A name, like built-in syntax.
                       | GreHFCand GlobalRdrElt  -- A global, like imported ids.
                       deriving (Eq)
+
 instance Outputable HoleFitCandidate where
   ppr = pprHoleFitCand
 
@@ -3973,20 +3961,70 @@ instance HasOccName HoleFitCandidate where
                   NameHFCand name -> occName name
                   GreHFCand gre -> occName (gre_name gre)
 
+instance Ord HoleFitCandidate where
+  compare = compare `on` occName
+
 -- | HoleFit is the type we use for valid hole fits. It contains the
 -- element that was checked, the Id of that element as found by `tcLookup`,
 -- and the refinement level of the fit, which is the number of extra argument
 -- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
 data HoleFit =
-  HoleFit { hfId   :: Id       -- The elements id in the TcM
-          , hfCand :: HoleFitCandidate  -- The candidate that was checked.
-          , hfType :: TcType -- The type of the id, possibly zonked.
-          , hfRefLvl :: Int  -- The number of holes in this fit.
-          , hfWrap :: [TcType] -- The wrapper for the match.
-          , hfMatches :: [TcType]  -- What the refinement variables got matched
-                                   -- with, if anything
-          , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
-                                         -- available.
+  HoleFit { hfId   :: Id       -- ^ The elements id in the TcM
+          , hfCand :: HoleFitCandidate  -- ^ The candidate that was checked.
+          , hfType :: TcType -- ^ The type of the id, possibly zonked.
+          , hfRefLvl :: Int  -- ^ The number of holes in this fit.
+          , hfWrap :: [TcType] -- ^ The wrapper for the match.
+          , hfMatches :: [TcType]
+          -- ^ What the refinement variables got matched with, if anything
+          , hfDoc :: Maybe HsDocString
+          -- ^ Documentation of this HoleFit, if available.
+          }
  | RawHoleFit SDoc
  -- ^ A fit that is just displayed as is. Here so thatHoleFitPlugins
  --   can inject any fit they want.
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+   (==) = (==) `on` hfId
+
+instance Outputable HoleFit where
+  ppr (RawHoleFit sd) = sd
+  ppr (HoleFit _ cand ty _ _ mtchs _) =
+    hang (name <+> holes) 2 (text "where" <+> name <+> dcolon <+> (ppr ty))
+    where name = ppr $ occName cand
+          holes = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) mtchs
+
+-- We compare HoleFits by their name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+  compare (RawHoleFit _) (RawHoleFit _) = EQ
+  compare (RawHoleFit _) _ = LT
+  compare _ (RawHoleFit _) = GT
+  compare a@(HoleFit {}) b@(HoleFit {}) = cmp a b
+    where cmp  = if hfRefLvl a == hfRefLvl b
+                 then compare `on` hfCand
+                 else compare `on` hfRefLvl
+
+
+-- | A plugin for modifying the candidate hole fits *before* they're checked.
+type CandPlugin = TypedHole -> [HoleFitCandidate] -> TcM [HoleFitCandidate]
+
+-- | A plugin for modifying hole fits  *after* they've been found.
+type FitPlugin =  TypedHole -> [HoleFit] -> TcM [HoleFit]
+
+-- | A HoleFitPlugin is a pair of candidate and fit plugins.
+data HoleFitPlugin = HoleFitPlugin
+  { candPlugin :: CandPlugin
+  , fitPlugin :: FitPlugin }
+
+-- | HoleFitPluginR allows plugins to use an internal TcRef for tracking state.
+data HoleFitPluginR = forall s. HoleFitPluginR
+  { hfPluginInit :: TcM (TcRef s)
+    -- ^ Initializes the TcRef to be passed to the plugin
+  , holeFitPluginR :: TcRef s -> HoleFitPlugin
+    -- ^
+  , hfPluginStop :: TcRef s -> TcM ()
+    -- ^ Cleanup of state, guaranteed to be called even on error.
+  }