packages feed

hls-tactics-plugin 1.7.0.0 → 1.8.0.0

raw patch · 1011 files changed

+20435/−10281 lines, 1011 filesdep ~ghcidedep ~hls-plugin-apidep ~hls-test-utils

Dependency ranges changed: ghcide, hls-plugin-api, hls-test-utils

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

hls-tactics-plugin.cabal view
@@ -1,7 +1,7 @@ cabal-version:      2.4 category:           Development name:               hls-tactics-plugin-version:            1.7.0.0+version:            1.8.0.0 synopsis:           Wingman plugin for Haskell Language Server description:   Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -15,21 +15,34 @@ build-type:         Simple extra-source-files:   README.md-  test/golden/*.cabal-  test/golden/*.hs-  test/golden/*.yaml+  new/src/**/*.hs-boot+  old/src/**/*.hs-boot+  new/test/golden/*.cabal+  new/test/golden/*.hs+  new/test/golden/*.yaml+  old/test/golden/*.cabal+  old/test/golden/*.hs+  old/test/golden/*.yaml +source-repository head+    type:     git+    location: https://github.com/haskell/haskell-language-server.git+ flag pedantic   description: Enable -Werror   default:     False   manual:      True  library-  if impl(ghc >= 9.3)+  if impl(ghc >= 9.2.1)     buildable: False   else     buildable: True-  hs-source-dirs:     src++  if impl(ghc >= 9.2.1)+    hs-source-dirs:     new/src+  else+    hs-source-dirs:     old/src   exposed-modules:     Ide.Plugin.Tactic     Refinery.Future@@ -86,9 +99,9 @@     , ghc-boot-th     , ghc-exactprint     , ghc-source-gen        ^>=0.4.1-    , ghcide                ^>= 1.8+    , ghcide                ^>= 1.9     , hls-graph-    , hls-plugin-api        ^>=1.5+    , hls-plugin-api        ^>=1.6     , hls-refactor-plugin     , hyphenation     , lens@@ -131,7 +144,7 @@     ViewPatterns  test-suite tests-  if impl(ghc >= 9.3)+  if impl(ghc >= 9.2.1)     buildable: False   else     buildable: True@@ -154,7 +167,10 @@     UnificationSpec     Utils -  hs-source-dirs:     test+  if impl(ghc >= 9.2.1)+    hs-source-dirs: new/test+  else+    hs-source-dirs: old/test   ghc-options:     -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N @@ -169,7 +185,7 @@     , ghcide     , hls-plugin-api     , hls-tactics-plugin-    , hls-test-utils      ^>=1.4+    , hls-test-utils      ^>=1.5     , hspec     , hspec-expectations     , lens
+ new/src/Ide/Plugin/Tactic.hs view
@@ -0,0 +1,5 @@+-- | A plugin that uses tactics to synthesize code+module Ide.Plugin.Tactic (descriptor, Log(..)) where++import Wingman.Plugin+
+ new/src/Refinery/Future.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE RankNTypes #-}++------------------------------------------------------------------------------+-- | Things that belong in the future release of refinery v5.+module Refinery.Future+  ( runStreamingTacticT+  , hoistListT+  , consume+  ) where++import Control.Applicative+import Control.Monad (ap, (>=>))+import Control.Monad.State.Lazy (runStateT)+import Control.Monad.Trans+import Data.Either (isRight)+import Data.Functor ((<&>))+import Data.Tuple (swap)+import Refinery.ProofState+import Refinery.Tactic.Internal++++hoistElem :: Functor m => (forall x. m x -> n x) -> Elem m a -> Elem n a+hoistElem _ Done = Done+hoistElem f (Next a lt) = Next a $ hoistListT f lt+++hoistListT :: Functor m => (forall x. m x -> n x) -> ListT m a -> ListT n a+hoistListT f t = ListT $ f $ fmap (hoistElem f) $ unListT t+++consume :: Monad m => ListT m a -> (a -> m ()) -> m ()+consume lt f = unListT lt >>= \case+  Done -> pure ()+  Next a lt' -> f a >> consume lt' f+++newHole :: MonadExtract meta ext err s m => s -> m (s, (meta, ext))+newHole = fmap swap . runStateT hole++runStreamingTacticT :: (MonadExtract meta ext err s m) => TacticT jdg ext err s m () -> jdg -> s -> ListT m (Either err (Proof s meta jdg ext))+runStreamingTacticT t j s = streamProofs s $ fmap snd $ proofState t j++data Elem m a+    = Done+    | Next a (ListT m a)+    deriving stock Functor+++point :: Applicative m => a -> Elem m a+point a = Next a $ ListT $ pure Done++newtype ListT m a = ListT { unListT :: m (Elem m a) }++cons :: (Applicative m) => a -> ListT m a -> ListT m a+cons x xs = ListT $ pure $ Next x xs++instance Functor m => Functor (ListT m) where+    fmap f (ListT xs) = ListT $ xs <&> \case+        Done -> Done+        Next a xs -> Next (f a) (fmap f xs)++instance (Monad m) => Applicative (ListT m) where+    pure = return+    (<*>) = ap++instance (Monad m) => Alternative (ListT m) where+    empty = ListT $ pure Done+    (ListT xs) <|> (ListT ys) =+        ListT $ xs >>= \case+          Done -> ys+          Next x xs -> pure (Next x (xs <|> ListT ys))++instance (Monad m) => Monad (ListT m) where+    return a = cons a empty+    (ListT xs) >>= k =+        ListT $ xs >>= \case+          Done -> pure Done+          Next x xs -> unListT $ k x <|> (xs >>= k)+++instance MonadTrans ListT where+    lift m = ListT $ fmap (\x -> Next x empty) m+++interleaveT :: (Monad m) => Elem m a -> Elem m a -> Elem m a+interleaveT xs ys =+    case xs of+      Done -> ys+      Next x xs -> Next x $ ListT $ fmap (interleaveT ys) $ unListT xs++--         ys <&> \case+--           Done -> Next x xs+--           Next y ys -> Next x (cons y (interleaveT xs ys))++force :: (Monad m) => Elem m a -> m [a]+force = \case+    Done -> pure []+    Next x xs' -> (x:) <$> (unListT xs' >>= force)++ofList :: Monad m => [a] -> Elem m a+ofList [] = Done+ofList (x:xs) = Next x $ ListT $ pure $ ofList xs++streamProofs :: forall ext err s m goal meta. (MonadExtract meta ext err s m) => s -> ProofStateT ext ext err s m goal -> ListT m (Either err (Proof s meta goal ext))+streamProofs s p = ListT $ go s [] pure p+    where+      go :: s -> [(meta, goal)] -> (err -> m err) -> ProofStateT ext ext err s m goal -> m (Elem m (Either err (Proof s meta goal ext)))+      go s goals _ (Subgoal goal k) = do+         (s', (meta, h)) <- newHole s+         -- Note [Handler Reset]:+         -- We reset the handler stack to avoid the handlers leaking across subgoals.+         -- This would happen when we had a handler that wasn't followed by an error call.+         --     pair >> goal >>= \g -> (handler_ $ \_ -> traceM $ "Handling " <> show g) <|> failure "Error"+         -- We would see the "Handling a" message when solving for b.+         go s' (goals ++ [(meta, goal)]) pure $ k h+      go s goals handlers (Effect m) = m >>= go s goals handlers+      go s goals handlers (Stateful f) =+          let (s', p) = f s+          in go s' goals handlers p+      go s goals handlers (Alt p1 p2) =+          unListT $ ListT (go s goals handlers p1) <|> ListT (go s goals handlers p2)+      go s goals handlers (Interleave p1 p2) =+          interleaveT <$> go s goals handlers p1 <*> go s goals handlers p2+      go s goals handlers (Commit p1 p2) = do+          solns <- force =<< go s goals handlers p1+          if any isRight solns then pure $ ofList solns else go s goals handlers p2+      go _ _ _ Empty = pure Done+      go _ _ handlers (Failure err _) = do+          annErr <- handlers err+          pure $ point $ Left annErr+      go s goals handlers (Handle p h) =+          -- Note [Handler ordering]:+          -- If we have multiple handlers in scope, then we want the handlers closer to the error site to+          -- run /first/. This allows the handlers up the stack to add their annotations on top of the+          -- ones lower down, which is the behavior that we desire.+          -- IE: for @handler f >> handler g >> failure err@, @g@ ought to be run before @f@.+          go s goals (h >=> handlers) p+      go s goals _ (Axiom ext) = pure $ point $ Right (Proof ext s goals)+
+ new/src/Wingman/AbstractLSP.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecordWildCards     #-}++{-# LANGUAGE NoMonoLocalBinds    #-}++{-# OPTIONS_GHC -Wno-orphans     #-}++module Wingman.AbstractLSP (installInteractions) where++import           Control.Monad (void)+import           Control.Monad.IO.Class+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import qualified Data.Aeson as A+import           Data.Coerce+import           Data.Foldable (traverse_)+import           Data.Monoid (Last (..))+import qualified Data.Text as T+import           Data.Traversable (for)+import           Data.Tuple.Extra (uncurry3)+import           Development.IDE (IdeState)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource))+import qualified Ide.Plugin.Config as Plugin+import           Ide.Types+import           Language.LSP.Server (LspM, sendRequest, getClientCapabilities)+import qualified Language.LSP.Types as LSP+import           Language.LSP.Types hiding (CodeLens, CodeAction)+import           Wingman.AbstractLSP.Types+import           Wingman.EmptyCase (fromMaybeT)+import           Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)+import           Wingman.StaticPlugin (enableQuasiQuotes)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are+-- self-contained request/response pairs that abstract over the LSP, and+-- provide a unified interface for doing interesting things, without needing to+-- dive into the underlying API too directly.+installInteractions+    :: [Interaction]+    -> PluginDescriptor IdeState+    -> PluginDescriptor IdeState+installInteractions is desc =+  let plId = pluginId desc+   in desc+        { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is+        , pluginHandlers = pluginHandlers desc <> buildHandlers is+        }+++------------------------------------------------------------------------------+-- | Extract 'PluginHandlers' from 'Interaction's.+buildHandlers+    :: [Interaction]+    -> PluginHandlers IdeState+buildHandlers cs =+  flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) ->+    case c_makeCommand c of+      SynthesizeCodeAction k ->+        mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k+      SynthesizeCodeLens k ->+        mkPluginHandler STextDocumentCodeLens   $ codeLensProvider   @target (c_sort c) k+++------------------------------------------------------------------------------+-- | Extract a 'PluginCommand' from an 'Interaction'.+buildCommand+  :: PluginId+  -> Interaction+  -> PluginCommand IdeState+buildCommand plId (Interaction (c :: Continuation sort target b)) =+  PluginCommand+    { commandId = toCommandId $ c_sort c+    , commandDesc = T.pack ""+    , commandFunc = runContinuation plId c+    }+++------------------------------------------------------------------------------+-- | Boilerplate for running a 'Continuation' as part of an LSP command.+runContinuation+    :: forall sort a b+     . IsTarget a+    => PluginId+    -> Continuation sort a b+    -> CommandFunction IdeState (FileContext, b)+runContinuation plId cont state (fc, b) = do+  fromMaybeT+    (Left $ ResponseError+              { _code = InternalError+              , _message = T.pack "TODO(sandy)"+              , _xdata =  Nothing+              } ) $ do+      env@LspEnv{..} <- buildEnv state plId fc+      nfp <- getNfp $ fc_uri le_fileContext+      let stale a = runStaleIde "runContinuation" state nfp a+      args <- fetchTargetArgs @a env+      res <- c_runCommand cont env args fc b++      -- This block returns a maybe error.+      fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $+        for res $ \case+          ErrorMessages errs -> do+            traverse_ showUserFacingMessage errs+            pure Nothing+          RawEdit edits -> do+            sendEdits edits+            pure Nothing+          GraftEdit gr -> do+            ccs <- lift getClientCapabilities+            TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+            case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of+              Left errs ->+                pure $ Just $ ResponseError+                  { _code    = InternalError+                  , _message = T.pack $ show errs+                  , _xdata   = Nothing+                  }+              Right edits -> do+                sendEdits edits+                pure Nothing+++------------------------------------------------------------------------------+-- | Push a 'WorkspaceEdit' to the client.+sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) ()+sendEdits edits =+  void $ lift $+    sendRequest+      SWorkspaceApplyEdit+      (ApplyWorkspaceEditParams Nothing edits)+      (const $ pure ())+++------------------------------------------------------------------------------+-- | Push a 'UserFacingMessage' to the client.+showUserFacingMessage+    :: UserFacingMessage+    -> MaybeT (LspM Plugin.Config) ()+showUserFacingMessage ufm =+  void $ lift $ showLspMessage $ mkShowMessageParams ufm+++------------------------------------------------------------------------------+-- | Build an 'LspEnv', which contains the majority of things we need to know+-- in a 'Continuation'.+buildEnv+    :: IdeState+    -> PluginId+    -> FileContext+    -> MaybeT (LspM Plugin.Config) LspEnv+buildEnv state plId fc = do+  cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId+  nfp <- getNfp $ fc_uri fc+  dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp+  pure $ LspEnv+    { le_ideState = state+    , le_pluginId = plId+    , le_dflags   = dflags+    , le_config   = cfg+    , le_fileContext = fc+    }+++------------------------------------------------------------------------------+-- | Lift a 'Continuation' into an LSP CodeAction.+codeActionProvider+    :: forall target sort b+     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)+    => sort+    -> ( LspEnv+     -> TargetArgs target+     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]+       )+    -> PluginMethodHandler IdeState TextDocumentCodeAction+codeActionProvider sort k state plId+                   (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do+  fromMaybeT (Right $ List []) $ do+    let fc = FileContext+                { fc_uri   = uri+                , fc_range = Just $ unsafeMkCurrent range+                }+    env <- buildEnv state plId fc+    args <- fetchTargetArgs @target env+    actions <- k env args+    pure+      $ Right+      $ List+      $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions+++------------------------------------------------------------------------------+-- | Lift a 'Continuation' into an LSP CodeLens.+codeLensProvider+    :: forall target sort b+     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)+    => sort+    -> ( LspEnv+     -> TargetArgs target+     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]+      )+    -> PluginMethodHandler IdeState TextDocumentCodeLens+codeLensProvider sort k state plId+                 (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do+      fromMaybeT (Right $ List []) $ do+        let fc = FileContext+                   { fc_uri   = uri+                   , fc_range = Nothing+                   }+        env <- buildEnv state plId fc+        args <- fetchTargetArgs @target env+        actions <- k env args+        pure+          $ Right+          $ List+          $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions+++------------------------------------------------------------------------------+-- | Build a 'LSP.CodeAction'.+makeCodeAction+    :: (A.ToJSON b, IsContinuationSort sort)+    => PluginId+    -> FileContext+    -> sort+    -> Metadata+    -> b+    -> LSP.CodeAction+makeCodeAction plId fc sort (Metadata title kind preferred) b =+  let cmd_id = toCommandId sort+      cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)]+   in LSP.CodeAction+        { _title       = title+        , _kind        = Just kind+        , _diagnostics = Nothing+        , _isPreferred = Just preferred+        , _disabled    = Nothing+        , _edit        = Nothing+        , _command     = Just cmd+        , _xdata       = Nothing+        }+++------------------------------------------------------------------------------+-- | Build a 'LSP.CodeLens'.+makeCodeLens+    :: (A.ToJSON b, IsContinuationSort sort)+    => PluginId+    -> sort+    -> FileContext+    -> Range+    -> Metadata+    -> b+    -> LSP.CodeLens+makeCodeLens plId sort fc range (Metadata title _ _) b =+  let fc' = fc { fc_range = Just $ unsafeMkCurrent range }+      cmd_id = toCommandId sort+      cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)]+   in LSP.CodeLens+        { _range = range+        , _command = Just cmd+        , _xdata = Nothing+        }+
+ new/src/Wingman/AbstractLSP/TacticActions.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE RecordWildCards  #-}++{-# LANGUAGE NoMonoLocalBinds #-}++module Wingman.AbstractLSP.TacticActions where++import           Control.Monad (when)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.Maybe (mapMaybeT)+import           Data.Foldable+import           Data.Maybe (listToMaybe)+import           Data.Proxy+import           Development.IDE hiding (rangeToRealSrcSpan)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.ExactPrint+import           Generics.SYB.GHC (mkBindListT, everywhereM')+import           Wingman.AbstractLSP.Types+import           Wingman.CaseSplit+import           Wingman.GHC (liftMaybe, isHole, pattern AMatch)+import           Wingman.Judgements (jNeedsToBindArgs)+import           Wingman.LanguageServer (runStaleIde)+import           Wingman.LanguageServer.TacticProviders+import           Wingman.Machinery (runTactic, scoreSolution)+import           Wingman.Range+import           Wingman.Types+import Development.IDE.Core.Service (getIdeOptionsIO)+import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting))+++------------------------------------------------------------------------------+-- | An 'Interaction' for a 'TacticCommand'.+makeTacticInteraction+    :: TacticCommand+    -> Interaction+makeTacticInteraction cmd =+  Interaction $ Continuation @_ @HoleTarget cmd+    (SynthesizeCodeAction $ \env hj -> do+      pure $ commandProvider cmd $+            TacticProviderData+              { tpd_lspEnv    = env+              , tpd_jdg       = hj_jdg hj+              , tpd_hole_sort = hj_hole_sort hj+              }+    )+    $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do+        nfp <- getNfp fc_uri+        let stale a = runStaleIde "tacticCmd" le_ideState nfp a++        let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range+        TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+        pm_span <- liftMaybe $ mapAgeFrom pmmap span+        IdeOptions{optTesting = IdeTesting isTesting} <-+            liftIO $ getIdeOptionsIO (shakeExtras le_ideState)++        let t = commandTactic cmd var_name+            timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds++        liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case+          Left err ->+            pure+              $ pure+              $ ErrorMessages+              $ pure+              $ mkUserFacingMessage err+          Right rtr ->+            case rtr_extract rtr of+              L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->+                pure+                  $ addTimeoutMessage rtr+                  $ pure+                  $ ErrorMessages+                  $ pure NothingToDo+              _ -> do+                for_ (rtr_other_solns rtr) $ \soln -> do+                  traceMX "other solution" $ syn_val soln+                  traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) []+                traceMX "solution" $ rtr_extract rtr+                pure+                  $ addTimeoutMessage rtr+                  $ pure+                  $ GraftEdit+                  $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr+++addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult]+addTimeoutMessage rtr = mappend+  [ ErrorMessages $ pure TimedOut+  | rtr_timed_out rtr+  ]+++------------------------------------------------------------------------------+-- | The number of microseconds in a second+seconds :: Num a => a+seconds = 1e6+++------------------------------------------------------------------------------+-- | Transform some tactic errors into a 'UserFacingMessage'.+mkUserFacingMessage :: [TacticError] -> UserFacingMessage+mkUserFacingMessage errs+  | elem OutOfGas errs = NotEnoughGas+mkUserFacingMessage [] = NothingToDo+mkUserFacingMessage _ = TacticErrors+++------------------------------------------------------------------------------+-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly+-- deals with top-level holes, in which we might need to fiddle with the+-- 'Match's that bind variables.+graftHole+    :: SrcSpan+    -> RunTacticResults+    -> Graft (Either String) ParsedSource+graftHole span rtr+  | _jIsTopHole (rtr_jdg rtr)+      = genericGraftWithSmallestM+            (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span+      $ \dflags matches ->+          everywhereM'+            $ mkBindListT $ \ix ->+              graftDecl dflags span ix $ \name pats ->+              splitToDecl+                (case not $ jNeedsToBindArgs (rtr_jdg rtr) of+                   -- If the user has explicitly bound arguments, use the+                   -- fixity they wrote.+                   True -> matchContextFixity . m_ctxt . unLoc+                             =<< listToMaybe matches+                   -- Otherwise, choose based on the name of the function.+                   False -> Nothing+                )+                (occName name)+            $ iterateSplit+            $ mkFirstAgda pats+            $ unLoc+            $ rtr_extract rtr+graftHole span rtr+  = graft span+  $ rtr_extract rtr+++------------------------------------------------------------------------------+-- | Keep a fixity if one was present in the 'HsMatchContext'.+matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity+matchContextFixity (FunRhs _ l _) = Just l+matchContextFixity _ = Nothing+++------------------------------------------------------------------------------+-- | Helper function to route 'mergeFunBindMatches' into the right place in an+-- AST --- correctly dealing with inserting into instance declarations.+graftDecl+    :: DynFlags+    -> SrcSpan+    -> Int+    -> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)+    -> LMatch GhcPs (LHsExpr GhcPs)+    -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]+graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _))+  | dst `isSubspanOf` src = do+      L _ dec <- annotateDecl dflags $ make_decl name pats+      case dec of+        ValD _ FunBind{ fun_matches = MG { mg_alts = L _ alts@(first_match : _)}+                      } -> do+          -- For whatever reason, ExactPrint annotates newlines to the ends of+          -- case matches and type signatures, but only allows us to insert+          -- them at the beginning of those things. Thus, we need want to+          -- insert a preceding newline (done in 'annotateDecl') on all+          -- matches, except for the first one --- since it gets its newline+          -- from the line above.+          when (ix == 0) $+            setPrecedingLinesT first_match 0 0+          pure alts+        _ -> lift $ Left "annotateDecl didn't produce a funbind"+graftDecl _ _ _ _ x = pure $ pure x+
+ new/src/Wingman/AbstractLSP/Types.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Wingman.AbstractLSP.Types where++import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT)+import qualified Data.Aeson as A+import           Data.Text (Text)+import           Development.IDE (IdeState)+import           Development.IDE.GHC.ExactPrint (Graft)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (Target)+import           GHC.Generics (Generic)+import qualified Ide.Plugin.Config as Plugin+import           Ide.Types hiding (Config)+import           Language.LSP.Server (LspM)+import           Language.LSP.Types hiding (CodeLens, CodeAction)+import           Wingman.LanguageServer (judgementForHole)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | An 'Interaction' is an existential 'Continuation', which handles both+-- sides of the request/response interaction for LSP.+data Interaction where+  Interaction+      :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b)+      => Continuation sort target b+      -> Interaction+++------------------------------------------------------------------------------+-- | Metadata for a command. Used by both code actions and lenses, though for+-- lenses, only 'md_title' is currently used.+data Metadata+  = Metadata+      { md_title     :: Text+      , md_kind      :: CodeActionKind+      , md_preferred :: Bool+      }+  deriving stock (Eq, Show)+++------------------------------------------------------------------------------+-- | Whether we're defining a CodeAction or CodeLens.+data SynthesizeCommand a b+  = SynthesizeCodeAction+      ( LspEnv+     -> TargetArgs a+     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]+      )+  | SynthesizeCodeLens+      ( LspEnv+     -> TargetArgs a+     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]+      )+++------------------------------------------------------------------------------+-- | Transform a "continuation sort" into a 'CommandId'.+class IsContinuationSort a where+  toCommandId :: a -> CommandId++instance IsContinuationSort CommandId where+  toCommandId = id++instance IsContinuationSort Text where+  toCommandId = CommandId+++------------------------------------------------------------------------------+-- | Ways a 'Continuation' can resolve.+data ContinuationResult+  = -- | Produce some error messages.+    ErrorMessages [UserFacingMessage]+    -- | Produce an explicit 'WorkspaceEdit'.+  | RawEdit WorkspaceEdit+    -- | Produce a 'Graft', corresponding to a transformation of the current+    -- AST.+  | GraftEdit (Graft (Either String) ParsedSource)+++------------------------------------------------------------------------------+-- | A 'Continuation' is a single object corresponding to an action that users+-- can take via LSP. It generalizes codeactions and codelenses, allowing for+-- a significant amount of code reuse.+--+-- Given @Continuation sort target payload@:+--+-- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions+-- rather than working directly with text. This functionality is driven via+-- 'IsContinuationSort'.+--+-- the @target@ is used to fetch data from LSP on both sides of the+-- request/response barrier. For example, you can use it to resolve what node+-- in the AST the incoming range refers to. This functionality is driven via+-- 'IsTarget'.+--+-- the @payload@ is used for data you'd explicitly like to send from the+-- request to the response. It's like @target@, but only gets computed once.+-- This is beneficial if you can do it, but requires that your data is+-- serializable via JSON.+data Continuation sort target payload = Continuation+  { c_sort :: sort+  , c_makeCommand :: SynthesizeCommand target payload+  , c_runCommand+        :: LspEnv+        -> TargetArgs target+        -> FileContext+        -> payload+        -> MaybeT (LspM Plugin.Config) [ContinuationResult]+  }+++------------------------------------------------------------------------------+-- | What file are we looking at, and what bit of it?+data FileContext = FileContext+  { fc_uri      :: Uri+  , fc_range    :: Maybe (Tracked 'Current Range)+    -- ^ For code actions, this is 'Just'. For code lenses, you'll get+    -- a 'Nothing' in the request, and a 'Just' in the response.+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (A.ToJSON, A.FromJSON)+++------------------------------------------------------------------------------+-- | Everything we need to resolve continuations.+data LspEnv = LspEnv+  { le_ideState    :: IdeState+  , le_pluginId    :: PluginId+  , le_dflags      :: DynFlags+  , le_config      :: Config+  , le_fileContext :: FileContext+  }+++------------------------------------------------------------------------------+-- | Extract some information from LSP, so it can be passed to the requests and+-- responses of a 'Continuation'.+class IsTarget t where+  type TargetArgs t+  fetchTargetArgs+      :: LspEnv+      -> MaybeT (LspM Plugin.Config) (TargetArgs t)++------------------------------------------------------------------------------+-- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given+-- range is an HsExpr hole. It gives continuations access to the resulting+-- tactic judgement.+data HoleTarget = HoleTarget+  deriving stock (Eq, Ord, Show, Enum, Bounded)++getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath+getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri++instance IsTarget HoleTarget where+  type TargetArgs HoleTarget = HoleJudgment+  fetchTargetArgs LspEnv{..} = do+    let FileContext{..} = le_fileContext+    range <- MaybeT $ pure fc_range+    nfp <- getNfp fc_uri+    mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config+
+ new/src/Wingman/Auto.hs view
@@ -0,0 +1,32 @@++module Wingman.Auto where++import           Control.Monad.Reader.Class (asks)+import           Control.Monad.State (gets)+import qualified Data.Set as S+import           Refinery.Tactic+import           Wingman.Judgements+import           Wingman.KnownStrategies+import           Wingman.Machinery (tracing, getCurrentDefinitions)+import           Wingman.Tactics+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Automatically solve a goal.+auto :: TacticsM ()+auto = do+  jdg <- goal+  skolems <- gets ts_skolems+  gas <- asks $ cfg_auto_gas . ctxConfig+  current <- getCurrentDefinitions+  traceMX "goal" jdg+  traceMX "ctx" current+  traceMX "skolems" skolems+  commit knownStrategies+    . tracing "auto"+    . localTactic (auto' gas)+    . disallowing RecursiveCall+    . S.fromList+    $ fmap fst current+
+ new/src/Wingman/CaseSplit.hs view
@@ -0,0 +1,109 @@+module Wingman.CaseSplit+  ( mkFirstAgda+  , iterateSplit+  , splitToDecl+  ) where++import           Data.Bool (bool)+import           Data.Data+import           Data.Generics+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.GHC.Compat+import           GHC.Exts (IsString (fromString))+import           GHC.SourceGen (funBindsWithFixity, match, wildP)+import           Wingman.GHC+import           Wingman.Types++++------------------------------------------------------------------------------+-- | Construct an 'AgdaMatch' from patterns in scope (should be the LHS of the+-- match) and a body.+mkFirstAgda :: [Pat GhcPs] -> HsExpr GhcPs -> AgdaMatch+mkFirstAgda pats (Lambda pats' body) = mkFirstAgda (pats <> pats') body+mkFirstAgda pats body                = AgdaMatch pats body+++------------------------------------------------------------------------------+-- | Transform an 'AgdaMatch' whose body is a case over a bound pattern, by+-- splitting it into multiple matches: one for each alternative of the case.+agdaSplit :: AgdaMatch -> [AgdaMatch]+agdaSplit (AgdaMatch pats (Case (HsVar _ (L _ var)) matches))+  -- Ensure the thing we're destructing is actually a pattern that's been+  -- bound.+  | containsVar var pats+  = do+    (pat, body) <- matches+    -- TODO(sandy): use an at pattern if necessary+    pure $ AgdaMatch (rewriteVarPat var pat pats) $ unLoc body+agdaSplit x = [x]+++------------------------------------------------------------------------------+-- | Replace unused bound patterns with wild patterns.+wildify :: AgdaMatch -> AgdaMatch+wildify (AgdaMatch pats body) =+  let make_wild = bool id (wildifyT (allOccNames body)) $ not $ containsHole body+   in AgdaMatch (make_wild pats) body+++------------------------------------------------------------------------------+-- | Helper function for 'wildify'.+wildifyT :: Data a => Set OccName -> a -> a+wildifyT (S.map occNameString -> used) = everywhere $ mkT $ \case+  VarPat _ (L _ var) | S.notMember (occNameString $ occName var) used -> wildP+  (x :: Pat GhcPs)                                                    -> x+++------------------------------------------------------------------------------+-- | Determine whether the given 'RdrName' exists as a 'VarPat' inside of @a@.+containsVar :: Data a => RdrName -> a -> Bool+containsVar name = everything (||) $+  mkQ False (\case+    VarPat _ (L _ var) -> eqRdrName name var+    (_ :: Pat GhcPs)   -> False+      )+  `extQ` \case+    HsRecField lbl _ True ->  eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl+    (_ :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> False+++------------------------------------------------------------------------------+-- | Replace a 'VarPat' with the given @'Pat' GhcPs@.+rewriteVarPat :: Data a => RdrName -> Pat GhcPs -> a -> a+rewriteVarPat name rep = everywhere $+  mkT (\case+    VarPat _ (L _ var) | eqRdrName name var -> rep+    (x :: Pat GhcPs)                        -> x+      )+  `extT` \case+    HsRecField lbl _ True+      | eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl+          -> HsRecField lbl (toPatCompat rep) False+    (x :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> x+++------------------------------------------------------------------------------+-- | Construct an 'HsDecl' from a set of 'AgdaMatch'es.+splitToDecl+    :: Maybe LexicalFixity+    -> OccName  -- ^ The name of the function+    -> [AgdaMatch]+    -> LHsDecl GhcPs+splitToDecl fixity name ams = do+  traceX "fixity" fixity $+    noLoc $+      funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do+        AgdaMatch pats body <- ams+        pure $ match pats body+++------------------------------------------------------------------------------+-- | Sometimes 'agdaSplit' exposes another opportunity to do 'agdaSplit'. This+-- function runs it a few times, hoping it will find a fixpoint.+iterateSplit :: AgdaMatch -> [AgdaMatch]+iterateSplit am =+  let iterated = iterate (agdaSplit =<<) $ pure am+   in fmap wildify . (!! 5) $ iterated+
+ new/src/Wingman/CodeGen.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module Wingman.CodeGen+  ( module Wingman.CodeGen+  , module Wingman.CodeGen.Utils+  ) where+++import           Control.Lens ((%~), (<>~), (&))+import           Control.Monad.Except+import           Control.Monad.Reader (ask)+import           Control.Monad.State+import           Data.Bifunctor (second)+import           Data.Bool (bool)+import           Data.Functor ((<&>))+import           Data.Generics.Labels ()+import           Data.List+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat+import           GHC.Exts+import           GHC.SourceGen (occNameToStr)+import           GHC.SourceGen.Binds+import           GHC.SourceGen.Expr+import           GHC.SourceGen.Overloaded+import           GHC.SourceGen.Pat+import           Wingman.CodeGen.Utils+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Judgements.Theta+import           Wingman.Machinery+import           Wingman.Naming+import           Wingman.Types+++destructMatches+    :: Bool+    -> (ConLike -> Judgement -> Rule)+       -- ^ How to construct each match+    -> Maybe OccName+       -- ^ Scrutinee+    -> CType+       -- ^ Type being destructed+    -> Judgement+    -> RuleM (Synthesized [RawMatch])+-- TODO(sandy): In an ideal world, this would be the same codepath as+-- 'destructionFor'. Make sure to change that if you ever change this.+destructMatches use_field_puns f scrut t jdg = do+  let hy = jEntireHypothesis jdg+      g  = jGoal jdg+  case tacticsGetDataCons $ unCType t of+    Nothing -> cut -- throwError $ GoalMismatch "destruct" g+    Just (dcs, apps) ->+      fmap unzipTrace $ for dcs $ \dc -> do+        let con = RealDataCon dc+            ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps+            -- We explicitly do not need to add the method hypothesis to+            -- #syn_scoped+            method_hy = foldMap evidenceToHypothesis ev+            args = conLikeInstOrigArgTys' con apps+        ctx <- ask++        let names_in_scope = hyNamesInScope hy+            names = mkManyGoodNames (hyNamesInScope hy) args+            (names', destructed) =+              mkDestructPat (bool Nothing (Just names_in_scope) use_field_puns) con names++        let hy' = patternHypothesis scrut con jdg+                $ zip names'+                $ coerce args+            j = withNewCoercions (evidenceToCoercions ev)+              $ introduce ctx hy'+              $ introduce ctx method_hy+              $ withNewGoal g jdg+        ext <- f con j+        pure $ ext+          & #syn_trace %~ rose ("match " <> show dc <> " {" <> intercalate ", " (fmap show names') <> "}")+                        . pure+          & #syn_scoped <>~ hy'+          & #syn_val %~ match [destructed] . unLoc+++------------------------------------------------------------------------------+-- | Generate just the 'Match'es for a case split on a specific type.+destructionFor :: Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)]+-- TODO(sandy): In an ideal world, this would be the same codepath as+-- 'destructMatches'. Make sure to change that if you ever change this.+destructionFor hy t = do+  case tacticsGetDataCons t of+    Nothing -> Nothing+    Just ([], _) -> Nothing+    Just (dcs, apps) -> do+      for dcs $ \dc -> do+        let con   = RealDataCon dc+            args  = conLikeInstOrigArgTys' con apps+            names = mkManyGoodNames (hyNamesInScope hy) args+        pure+          . noLoc+          . Match+              noExtField+              CaseAlt+              [toPatCompat $ snd $ mkDestructPat Nothing con names]+          . GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_")+          . noLoc+          $ EmptyLocalBinds noExtField++++------------------------------------------------------------------------------+-- | Produces a pattern for a data con and the names of its fields.+mkDestructPat :: Maybe (S.Set OccName) -> ConLike -> [OccName] -> ([OccName], Pat GhcPs)+mkDestructPat already_in_scope con names+  | RealDataCon dcon <- con+  , isTupleDataCon dcon =+      (names, tuple pat_args)+  | fields@(_:_) <- zip (conLikeFieldLabels con) names+  , Just in_scope <- already_in_scope =+      let (names', rec_fields) =+            unzip $ fields <&> \(label, name) -> do+              let label_occ = mkVarOccFS $ flLabel label+              case S.member label_occ in_scope of+                -- We have a shadow, so use the generated name instead+                True ->+                  (name,) $ noLoc $+                    HsRecField+                      (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)+                      (noLoc $ bvar' name)+                      False+                -- No shadow, safe to use a pun+                False ->+                  (label_occ,) $ noLoc $+                    HsRecField+                      (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)+                      (noLoc $ bvar' label_occ)+                      True++        in (names', )+         $ ConPatIn (noLoc $ Unqual $ occName $ conLikeName con)+         $ RecCon+         $ HsRecFields rec_fields Nothing+  | otherwise =+      (names, ) $ infixifyPatIfNecessary con $+        conP+          (coerceName $ conLikeName con)+          pat_args+  where+    pat_args = fmap bvar' names+++infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs+infixifyPatIfNecessary dcon x+  | conLikeIsInfix dcon =+      case x of+        ConPatIn op (PrefixCon [lhs, rhs]) ->+          ConPatIn op $ InfixCon lhs rhs+        y -> y+  | otherwise = x++++unzipTrace :: [Synthesized a] -> Synthesized [a]+unzipTrace = sequenceA+++-- | Essentially same as 'dataConInstOrigArgTys' in GHC,+--  but only accepts universally quantified types as the second arguments+--  and automatically introduces existentials.+--+-- NOTE: The behaviour depends on GHC's 'dataConInstOrigArgTys'.+--       We need some tweaks if the compiler changes the implementation.+conLikeInstOrigArgTys'+  :: ConLike+      -- ^ 'DataCon'structor+  -> [Type]+      -- ^ /Universally/ quantified type arguments to a result type.+      --   It /MUST NOT/ contain any dictionaries, coercion and existentials.+      --+      --   For example, for @MkMyGADT :: b -> MyGADT a c@, we+      --   must pass @[a, c]@ as this argument but not @b@, as @b@ is an existential.+  -> [Type]+      -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument.+conLikeInstOrigArgTys' con uniTys =+  let exvars = conLikeExTys con+   in fmap scaledThing $ conLikeInstOrigArgTys con $+        uniTys ++ fmap mkTyVarTy exvars+      -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys'+      -- unifies the second argument with DataCon's universals followed by existentials.+      -- If the definition of 'dataConInstOrigArgTys' changes,+      -- this place must be changed accordingly.+++conLikeExTys :: ConLike -> [TyCoVar]+conLikeExTys (RealDataCon d) = dataConExTyCoVars d+conLikeExTys (PatSynCon p) = patSynExTys p++patSynExTys :: PatSyn -> [TyCoVar]+patSynExTys ps = patSynExTyVars ps+++------------------------------------------------------------------------------+-- | Combinator for performing case splitting, and running sub-rules on the+-- resulting matches.++destruct' :: Bool -> (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule+destruct' use_field_puns f hi jdg = do+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic+  let term = hi_name hi+  ext+      <- destructMatches+           use_field_puns+           f+           (Just term)+           (hi_type hi)+           $ disallowing AlreadyDestructed (S.singleton term) jdg+  pure $ ext+    & #syn_trace     %~ rose ("destruct " <> show term) . pure+    & #syn_val       %~ noLoc . case' (var' term)+++------------------------------------------------------------------------------+-- | Combinator for performing case splitting, and running sub-rules on the+-- resulting matches.+destructLambdaCase' :: Bool -> (ConLike -> Judgement -> Rule) -> Judgement -> Rule+destructLambdaCase' use_field_puns f jdg = do+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic+  let g  = jGoal jdg+  case splitFunTy_maybe (unCType g) of+#if __GLASGOW_HASKELL__ >= 900+    Just (_multiplicity, arg, _) | isAlgType arg ->+#else+    Just (arg, _) | isAlgType arg ->+#endif+      fmap (fmap noLoc lambdaCase) <$>+        destructMatches use_field_puns f Nothing (CType arg) jdg+    _ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g+++------------------------------------------------------------------------------+-- | Construct a data con with subgoals for each field.+buildDataCon+    :: Bool       -- Should we blacklist destruct?+    -> Judgement+    -> ConLike            -- ^ The data con to build+    -> [Type]             -- ^ Type arguments for the data con+    -> RuleM (Synthesized (LHsExpr GhcPs))+buildDataCon should_blacklist jdg dc tyapps = do+  args <- case dc of+    RealDataCon dc' -> do+      let (skolems', theta, args) = dataConInstSig dc' tyapps+      modify $ \ts ->+        evidenceToSubst (foldMap mkEvidence theta) ts+          & #ts_skolems <>~ S.fromList skolems'+      pure args+    _ ->+      -- If we have a 'PatSyn', we can't continue, since there is no+      -- 'dataConInstSig' equivalent for 'PatSyn's. I don't think this is+      -- a fundamental problem, but I don't know enough about the GHC internals+      -- to implement it myself.+      --+      -- Fortunately, this isn't an issue in practice, since 'PatSyn's are+      -- never in the hypothesis.+      cut -- throwError $ TacticPanic "Can't build Pattern constructors yet"+  ext+      <- fmap unzipTrace+       $ traverse ( \(arg, n) ->+                    newSubgoal+                  . filterSameTypeFromOtherPositions dc n+                  . bool id blacklistingDestruct should_blacklist+                  . flip withNewGoal jdg+                  $ CType arg+                  ) $ zip args [0..]+  pure $ ext+    & #syn_trace %~ rose (show dc) . pure+    & #syn_val   %~ mkCon dc tyapps+++------------------------------------------------------------------------------+-- | Make a function application, correctly handling the infix case.+mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs+mkApply occ (lhs : rhs : more)+  | isSymOcc occ+  = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more+mkApply occ args = noLoc $ foldl' (@@) (var' occ) args+++------------------------------------------------------------------------------+-- | Run a tactic over each term in the given 'Hypothesis', binding the results+-- of each in a let expression.+letForEach+    :: (OccName -> OccName)           -- ^ How to name bound variables+    -> (HyInfo CType -> TacticsM ())  -- ^ The tactic to run+    -> Hypothesis CType               -- ^ Terms to generate bindings for+    -> Judgement                      -- ^ The goal of original hole+    -> RuleM (Synthesized (LHsExpr GhcPs))+letForEach rename solve (unHypothesis -> hy) jdg = do+  case hy of+    [] -> newSubgoal jdg+    _ -> do+      ctx <- ask+      let g = jGoal jdg+      terms <- fmap sequenceA $ for hy $ \hi -> do+        let name = rename $ hi_name hi+        let generalized_let_ty = CType alphaTy+        res <- tacticToRule (withNewGoal generalized_let_ty jdg) $ solve hi+        pure $ fmap ((name,) . unLoc) res+      let hy' = fmap (g <$) $ syn_val terms+          matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms+      g <- fmap (fmap unLoc) $ newSubgoal $ introduce ctx (userHypothesis hy') jdg+      pure $ fmap noLoc $ let' <$> matches <*> g+++------------------------------------------------------------------------------+-- | Let-bind the given occname judgement pairs.+nonrecLet+    :: [(OccName, Judgement)]+    -> Judgement+    -> RuleM (Synthesized (LHsExpr GhcPs))+nonrecLet occjdgs jdg = do+  occexts <- traverse newSubgoal $ fmap snd occjdgs+  ctx     <- ask+  ext     <- newSubgoal+           $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs) jdg+  pure $ fmap noLoc $+    let'+      <$> traverse+            (\(occ, ext) -> valBind (occNameToStr occ) <$> fmap unLoc ext)+            (zip (fmap fst occjdgs) occexts)+      <*> fmap unLoc ext+++------------------------------------------------------------------------------+-- | Converts a function application into applicative form+idiomize :: LHsExpr GhcPs -> LHsExpr GhcPs+idiomize x = noLoc $ case unLoc x of+  HsApp _ (L _ (HsVar _ (L _ x))) gshgp3 ->+    op (bvar' $ occName x) "<$>" (unLoc gshgp3)+  HsApp _ gsigp gshgp3 ->+    op (unLoc $ idiomize gsigp) "<*>" (unLoc gshgp3)+  RecordCon _ con flds ->+    unLoc $ idiomize $ noLoc $ foldl' (@@) (HsVar noExtField con) $ fmap unLoc flds+  y -> y+
+ new/src/Wingman/CodeGen/Utils.hs view
@@ -0,0 +1,79 @@+module Wingman.CodeGen.Utils where++import Data.String+import Data.List+import Development.IDE.GHC.Compat+import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string)+import GHC.SourceGen.Overloaded as SourceGen+import Wingman.GHC (getRecordFields)+++------------------------------------------------------------------------------+-- | Make a data constructor with the given arguments.+mkCon :: ConLike -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs+mkCon con apps (fmap unLoc -> args)+  | RealDataCon dcon <- con+  , dcon == nilDataCon+  , [ty] <- apps+  , ty `eqType` charTy = noLoc $ string ""++  | RealDataCon dcon <- con+  , isTupleDataCon dcon =+      noLoc $ tuple args++  | RealDataCon dcon <- con+  , dataConIsInfix dcon+  , (lhs : rhs : args') <- args =+      noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args'++  | Just fields <- getRecordFields con+  , length fields >= 2 =  --  record notation is unnatural on single field ctors+      noLoc $ recordConE (coerceName con_name) $ do+        (arg, (field, _)) <- zip args fields+        pure (coerceName field, arg)++  | otherwise =+      noLoc $ foldl' (@@) (bvar' $ occName con_name) args+  where+    con_name = conLikeName con+++coerceName :: HasOccName a => a -> RdrNameStr+coerceName = UnqualStr . fromString . occNameString . occName+++------------------------------------------------------------------------------+-- | Like 'var', but works over standard GHC 'OccName's.+var' :: SourceGen.Var a => OccName -> a+var' = var . fromString . occNameString+++------------------------------------------------------------------------------+-- | Like 'bvar', but works over standard GHC 'OccName's.+bvar' :: BVar a => OccName -> a+bvar' = bvar . fromString . occNameString+++------------------------------------------------------------------------------+-- | Get an HsExpr corresponding to a function name.+mkFunc :: String -> HsExpr GhcPs+mkFunc = var' . mkVarOcc+++------------------------------------------------------------------------------+-- | Get an HsExpr corresponding to a value name.+mkVal :: String -> HsExpr GhcPs+mkVal = var' . mkVarOcc+++------------------------------------------------------------------------------+-- | Like 'op', but easier to call.+infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+infixCall s = flip op (fromString s)+++------------------------------------------------------------------------------+-- | Like '(@@)', but uses a dollar instead of parentheses.+appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+appDollar = infixCall "$"+
+ new/src/Wingman/Context.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}++module Wingman.Context where++import           Control.Arrow+import           Control.Monad.Reader+import           Data.Coerce (coerce)+import           Data.Foldable.Extra (allM)+import           Data.Maybe (fromMaybe, isJust, mapMaybe)+import qualified Data.Set as S+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           Wingman.GHC (normalizeType)+import           Wingman.Judgements.Theta+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++mkContext+    :: Config+    -> [(OccName, CType)]+    -> TcGblEnv+    -> HscEnv+    -> ExternalPackageState+    -> [Evidence]+    -> Context+mkContext cfg locals tcg hscenv eps ev = fix $ \ctx ->+  Context+    { ctxDefiningFuncs+        = fmap (second $ coerce $ normalizeType ctx) locals+    , ctxModuleFuncs+        = fmap (second (coerce $ normalizeType ctx) . splitId)+        . mappend (locallyDefinedMethods tcg)+        . (getFunBindId =<<)+        . fmap unLoc+        . bagToList+        $ tcg_binds tcg+    , ctxConfig = cfg+    , ctxFamInstEnvs =+        (eps_fam_inst_env eps, tcg_fam_inst_env tcg)+    , ctxInstEnvs =+        InstEnvs+          (eps_inst_env eps)+          (tcg_inst_env tcg)+          (tcVisibleOrphanMods tcg)+    , ctxTheta = evidenceToThetaType ev+    , ctx_hscEnv = hscenv+    , ctx_occEnv = tcg_rdr_env tcg+    , ctx_module = extractModule tcg+    }+++locallyDefinedMethods :: TcGblEnv -> [Id]+locallyDefinedMethods+  = foldMap classMethods+  . mapMaybe tyConClass_maybe+  . tcg_tcs++++splitId :: Id -> (OccName, CType)+splitId = occName &&& CType . idType+++getFunBindId :: HsBindLR GhcTc GhcTc -> [Id]+getFunBindId (AbsBinds _ _ _ abes _ _ _)+  = abes >>= \case+      ABE _ poly _ _ _ -> pure poly+      _                -> []+getFunBindId _ = []+++------------------------------------------------------------------------------+-- | Determine if there is an instance that exists for the given 'Class' at the+-- specified types. Deeply checks contexts to ensure the instance is actually+-- real.+--+-- If so, this returns a 'PredType' that corresponds to the type of the+-- dictionary.+getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType))+getInstance cls tys = do+  env <- asks ctxInstEnvs+  let (mres, _, _) = lookupInstEnv False env cls tys+  case mres of+    ((inst, mapps) : _) -> do+      -- Get the instantiated type of the dictionary+      let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps+      -- pull off its resulting arguments+      let (theta, df') = tcSplitPhiTy df+      allM hasClassInstance theta >>= \case+        True -> pure $ Just (cls, df')+        False -> pure Nothing+    _ -> pure Nothing+++------------------------------------------------------------------------------+-- | Like 'getInstance', but only returns whether or not it succeeded. Can fail+-- fast, and uses a cached Theta from the context.+hasClassInstance :: MonadReader Context m => PredType -> m Bool+hasClassInstance predty = do+  theta <- asks ctxTheta+  case S.member (CType predty) theta of+    True -> pure True+    False -> do+      let (con, apps) = tcSplitTyConApp predty+      case tyConClass_maybe con of+        Nothing -> pure False+        Just cls -> fmap isJust $ getInstance cls apps+
+ new/src/Wingman/Debug.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Wingman.Debug+  ( unsafeRender+  , unsafeRender'+  , traceM+  , traceShowId+  , trace+  , traceX+  , traceIdX+  , traceMX+  , traceFX+  ) where++import           Control.DeepSeq+import           Control.Exception+import           Data.Either (fromRight)+import qualified Data.Text as T+import qualified Debug.Trace+import           Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc)+import           Development.IDE.GHC.Util (printOutputable)+import           System.IO.Unsafe  (unsafePerformIO)++------------------------------------------------------------------------------+-- | Print something+unsafeRender :: Outputable a => a -> String+unsafeRender = unsafeRender' . ppr+++unsafeRender' :: SDoc -> String+unsafeRender' sdoc = unsafePerformIO $ do+  let z = T.unpack $ printOutputable sdoc+  -- We might not have unsafeGlobalDynFlags (like during testing), in which+  -- case GHC panics. Instead of crashing, let's just fail to print.+  !res <- try @PlainGhcException $ evaluate $ deepseq z z+  pure $ fromRight "<unsafeRender'>" res+{-# NOINLINE unsafeRender' #-}++traceMX :: (Monad m, Show a) => String -> a -> m ()+traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a++traceX :: (Show a) => String -> a -> b -> b+traceX str a = trace (mappend ("!!!" <> str <> ": ") $ show a)++traceIdX :: (Show a) => String -> a -> a+traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a++traceFX :: String -> (a -> String) -> a -> a+traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a++traceM :: Applicative f => String -> f ()+trace :: String -> a -> a+traceShowId :: Show a => a -> a+#ifdef DEBUG+traceM = Debug.Trace.traceM+trace = Debug.Trace.trace+traceShowId = Debug.Trace.traceShowId+#else+traceM _ = pure ()+trace _ = id+traceShowId = id+#endif
+ new/src/Wingman/EmptyCase.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}++{-# LANGUAGE NoMonoLocalBinds  #-}++module Wingman.EmptyCase where++import           Control.Applicative (empty)+import           Control.Monad+import           Control.Monad.Except (runExcept)+import           Control.Monad.Trans+import           Control.Monad.Trans.Maybe+import           Data.Generics.Aliases (mkQ, GenericQ)+import           Data.Generics.Schemes (everything)+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+import           Data.Traversable+import           Development.IDE (hscEnv, realSrcSpanToRange)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty, EmptyCase)+import           Development.IDE.GHC.ExactPrint+import           Development.IDE.Spans.LocalBindings (getLocalScope)+import           Ide.Types+import           Language.LSP.Server+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.AbstractLSP.Types+import           Wingman.CodeGen (destructionFor)+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.LanguageServer+import           Wingman.Types+++data EmptyCaseT = EmptyCaseT++instance IsContinuationSort EmptyCaseT where+  toCommandId _ = CommandId "wingman.emptyCase"++instance IsTarget EmptyCaseT where+  type TargetArgs EmptyCaseT = ()+  fetchTargetArgs _ = pure ()++emptyCaseInteraction :: Interaction+emptyCaseInteraction = Interaction $+  Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT+    (SynthesizeCodeLens $ \LspEnv{..} _ -> do+      let FileContext{..} = le_fileContext+      nfp <- getNfp fc_uri++      let stale a = runStaleIde "codeLensProvider" le_ideState nfp a++      ccs <- lift getClientCapabilities+      TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+      TrackedStale binds bind_map <- mapMaybeT liftIO $ stale GetBindings+      holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState nfp++      for holes $ \(ss, ty) -> do+        binds_ss <- liftMaybe $ mapAgeFrom bind_map ss+        let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss+            range = realSrcSpanToRange $ unTrack ss+        matches <-+          liftMaybe $+            destructionFor+              (foldMap (hySingleton . occName . fst) bindings)+              ty+        edits <- liftMaybe $ hush $+              mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $+                graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $+                  noLoc matches+        pure+          ( range+          , Metadata+              (mkEmptyCaseLensDesc ty)+              (CodeActionUnknown "refactor.wingman.completeEmptyCase")+              False+          , edits+          )+    )+    (\ _ _ _ we -> pure $ pure $ RawEdit we)+++scrutinzedType :: EmptyCaseSort Type -> Maybe Type+scrutinzedType (EmptyCase ty) = pure  ty+scrutinzedType (EmptyLamCase ty) =+  case tacticsSplitFunTy ty of+    (_, _, tys, _) -> listToMaybe $ fmap scaledThing tys+++------------------------------------------------------------------------------+-- | The description for the empty case lens.+mkEmptyCaseLensDesc :: Type -> T.Text+mkEmptyCaseLensDesc ty =+  "Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")"+++------------------------------------------------------------------------------+-- | Silence an error.+hush :: Either e a -> Maybe a+hush (Left _) = Nothing+hush (Right a) = Just a+++------------------------------------------------------------------------------+-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly+-- deals with top-level holes, in which we might need to fiddle with the+-- 'Match's that bind variables.+graftMatchGroup+    :: SrcSpan+    -> Located [LMatch GhcPs (LHsExpr GhcPs)]+    -> Graft (Either String) ParsedSource+graftMatchGroup ss l =+  hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case+    L span (HsCase ext scrut mg) -> do+      pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }+    L span (HsLamCase ext mg) -> do+      pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }+    (_ :: LHsExpr GhcPs) -> pure Nothing+++fromMaybeT :: Functor m => a -> MaybeT m a -> m a+fromMaybeT def = fmap (fromMaybe def) . runMaybeT+++------------------------------------------------------------------------------+-- | Find the last typechecked module, and find the most specific span, as well+-- as the judgement at the given range.+emptyCaseScrutinees+    :: IdeState+    -> NormalizedFilePath+    -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]+emptyCaseScrutinees state nfp = do+    let stale a = runStaleIde "emptyCaseScrutinees" state nfp a++    TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck+    let tcg' = unTrack tcg+    hscenv <- stale GhcSessionDeps++    let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg+    fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do+      ty <- MaybeT+          . fmap (scrutinzedType <=< sequence)+          . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')+          $ scrutinee+      case null $ tacticsGetDataCons ty of+        True -> pure empty+        False ->+          case ss of+            RealSrcSpan r _ -> do+              rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r+              pure $ Just (rss', ty)+            UnhelpfulSpan _ -> empty++data EmptyCaseSort a+  = EmptyCase a+  | EmptyLamCase a+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++------------------------------------------------------------------------------+-- | Get the 'SrcSpan' and scrutinee of every empty case.+emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]+emptyCaseQ = everything (<>) $ mkQ mempty $ \case+  L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)+  L new_span expr@(LamCase []) -> pure (new_span, EmptyLamCase expr)+  (_ :: LHsExpr GhcTc) -> mempty+
+ new/src/Wingman/GHC.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Wingman.GHC where++import           Control.Monad.State+import           Control.Monad.Trans.Maybe (MaybeT(..))+import           Data.Bool (bool)+import           Data.Coerce (coerce)+import           Data.Function (on)+import           Data.Functor ((<&>))+import           Data.List (isPrefixOf)+import qualified Data.Map as M+import           Data.Maybe (isJust)+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           GHC.SourceGen (lambda)+import           Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)+import           Wingman.StaticPlugin (pattern MetaprogramSyntax)+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++tcTyVar_maybe :: Type -> Maybe Var+tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty'+tcTyVar_maybe (CastTy ty _) = tcTyVar_maybe ty  -- look through casts, as+                                                -- this is only used for+                                                -- e.g., FlexibleContexts+tcTyVar_maybe (TyVarTy v)   = Just v+tcTyVar_maybe _             = Nothing+++instantiateType :: Type -> ([TyVar], Type)+instantiateType t = do+  let vs  = tyCoVarsOfTypeList t+      vs' = fmap cloneTyVar vs+      subst = foldr (\(v,t) a -> extendTCvSubst a v $ TyVarTy t) emptyTCvSubst+            $ zip vs vs'+   in (vs', substTy subst t)+++cloneTyVar :: TyVar -> TyVar+cloneTyVar t =+  let uniq = getUnique t+      some_magic_char = 'w' -- 'w' for wingman ;D+   in setVarUnique t $ newTagUnique uniq some_magic_char+++------------------------------------------------------------------------------+-- | Is this a function type?+isFunction :: Type -> Bool+isFunction (tacticsSplitFunTy -> (_, _, [], _)) = False+isFunction _                                    = True+++------------------------------------------------------------------------------+-- | Split a function, also splitting out its quantified variables and theta+-- context.+tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type)+tacticsSplitFunTy t+  = let (vars, theta, t') = tcSplitNestedSigmaTys t+        (args, res) = tcSplitFunTys t'+     in (vars, theta, args, res)+++------------------------------------------------------------------------------+-- | Rip the theta context out of a regular type.+tacticsThetaTy :: Type -> ThetaType+tacticsThetaTy (tcSplitSigmaTy -> (_, theta,  _)) = theta+++------------------------------------------------------------------------------+-- | Get the data cons of a type, if it has any.+tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type])+tacticsGetDataCons ty+  | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty+  = tacticsGetDataCons ty'+tacticsGetDataCons ty+  | Just _ <- algebraicTyCon ty+  = splitTyConApp_maybe ty <&> \(tc, apps) ->+      ( filter (not . dataConCannotMatch apps) $ tyConDataCons tc+      , apps+      )+tacticsGetDataCons _ = Nothing++------------------------------------------------------------------------------+-- | Instantiate all of the quantified type variables in a type with fresh+-- skolems.+freshTyvars :: MonadState TacticState m => Type -> m Type+freshTyvars t = do+  let (tvs, _, _, _) = tacticsSplitFunTy t+  reps <- fmap M.fromList+        $ for tvs $ \tv -> do+            uniq <- freshUnique+            pure (tv, setTyVarUnique tv uniq)+  pure $+    everywhere+      (mkT $ \tv -> M.findWithDefault tv tv reps+      ) $ snd $ tcSplitForAllTyVars t+++------------------------------------------------------------------------------+-- | Given a datacon, extract its record fields' names and types. Returns+-- nothing if the datacon is not a record.+getRecordFields :: ConLike -> Maybe [(OccName, CType)]+getRecordFields dc =+  case conLikeFieldLabels dc of+    [] -> Nothing+    lbls -> for lbls $ \lbl -> do+      let ty = conLikeFieldType dc $ flLabel lbl+      pure (mkVarOccFS $ flLabel lbl, CType ty)+++------------------------------------------------------------------------------+-- | Is this an algebraic type?+algebraicTyCon :: Type -> Maybe TyCon+algebraicTyCon ty+  | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty+  = algebraicTyCon ty'+algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _))+  | tycon == intTyCon    = Nothing+  | tycon == floatTyCon  = Nothing+  | tycon == doubleTyCon = Nothing+  | tycon == charTyCon   = Nothing+  | tycon == funTyCon    = Nothing+  | otherwise = Just tycon+algebraicTyCon _ = Nothing+++------------------------------------------------------------------------------+-- | We can't compare 'RdrName' for equality directly. Instead, sloppily+-- compare them by their 'OccName's.+eqRdrName :: RdrName -> RdrName -> Bool+eqRdrName = (==) `on` occNameString . occName+++------------------------------------------------------------------------------+-- | Compare two 'OccName's for unqualified equality.+sloppyEqOccName :: OccName -> OccName -> Bool+sloppyEqOccName = (==) `on` occNameString+++------------------------------------------------------------------------------+-- | Does this thing contain any references to 'HsVar's with the given+-- 'RdrName'?+containsHsVar :: Data a => RdrName -> a -> Bool+containsHsVar name x = not $ null $ listify (+  \case+    ((HsVar _ (L _ a)) :: HsExpr GhcPs) | eqRdrName a name -> True+    _                                                      -> False+  ) x+++------------------------------------------------------------------------------+-- | Does this thing contain any holes?+containsHole :: Data a => a -> Bool+containsHole x = not $ null $ listify (+  \case+    ((HsVar _ (L _ name)) :: HsExpr GhcPs) -> isHole $ occName name+    MetaprogramSyntax _                    -> True+    _                                      -> False+  ) x+++------------------------------------------------------------------------------+-- | Check if an 'OccName' is a hole+isHole :: OccName -> Bool+-- TODO(sandy): Make this more robust+isHole = isPrefixOf "_" . occNameString+++------------------------------------------------------------------------------+-- | Get all of the referenced occnames.+allOccNames :: Data a => a -> Set OccName+allOccNames = everything (<>) $ mkQ mempty $ \case+    a -> S.singleton a+++------------------------------------------------------------------------------+-- | Unpack the relevant parts of a 'Match'+#if __GLASGOW_HASKELL__ >= 900+pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)+#else+pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)+#endif+pattern AMatch ctx pats body <-+  Match { m_ctxt = ctx+        , m_pats = fmap fromPatCompat -> pats+        , m_grhss = UnguardedRHSs (unLoc -> body)+        }+++pattern SingleLet :: IdP GhcPs -> [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+pattern SingleLet bind pats val expr <-+  HsLet _+    (HsValBinds _+      (ValBinds _ (bagToList ->+        [L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _))+    (L _ expr)+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs+pattern Lambda pats body <-+  HsLam _+    MG {mg_alts = L _ [L _ (AMatch _ pats body) ]}+  where+    -- If there are no patterns to bind, just stick in the body+    Lambda [] body   = body+    Lambda pats body = lambda pats body+++------------------------------------------------------------------------------+-- | A GRHS that contains no guards.+pattern UnguardedRHSs :: LHsExpr p -> GRHSs p (LHsExpr p)+pattern UnguardedRHSs body <-+  GRHSs {grhssGRHSs = [L _ (GRHS _ [] body)]}+++------------------------------------------------------------------------------+-- | A match with a single pattern. Case matches are always 'SinglePatMatch'es.+pattern SinglePatMatch :: PatCompattable p => Pat p -> LHsExpr p -> Match p (LHsExpr p)+pattern SinglePatMatch pat body <-+  Match { m_pats = [fromPatCompat -> pat]+        , m_grhss = UnguardedRHSs body+        }+++------------------------------------------------------------------------------+-- | Helper function for defining the 'Case' pattern.+unpackMatches :: PatCompattable p => [Match p (LHsExpr p)] -> Maybe [(Pat p, LHsExpr p)]+unpackMatches [] = Just []+unpackMatches (SinglePatMatch pat body : matches) =+  ((pat, body):) <$> unpackMatches matches+unpackMatches _ = Nothing+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Case :: PatCompattable p => HsExpr p -> [(Pat p, LHsExpr p)] -> HsExpr p+pattern Case scrutinee matches <-+  HsCase _ (L _ scrutinee)+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}++------------------------------------------------------------------------------+-- | Like 'Case', but for lambda cases.+pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p+pattern LamCase matches <-+  HsLamCase _+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}+++------------------------------------------------------------------------------+-- | Can ths type be lambda-cased?+--+-- Return: 'Nothing' if no+--         @Just False@ if it can't be homomorphic+--         @Just True@ if it can+lambdaCaseable :: Type -> Maybe Bool+#if __GLASGOW_HASKELL__ >= 900+lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res))+#else+lambdaCaseable (splitFunTy_maybe -> Just (arg, res))+#endif+  | isJust (algebraicTyCon arg)+  = Just $ isJust $ algebraicTyCon res+lambdaCaseable _ = Nothing++class PatCompattable p where+  fromPatCompat :: PatCompat p -> Pat p+  toPatCompat :: Pat p -> PatCompat p++instance PatCompattable GhcTc where+  fromPatCompat = unLoc+  toPatCompat = noLoc++instance PatCompattable GhcPs where+  fromPatCompat = unLoc+  toPatCompat = noLoc++type PatCompat pass = LPat pass++------------------------------------------------------------------------------+-- | Should make sure it's a fun bind+pattern TopLevelRHS+    :: OccName+    -> [PatCompat GhcTc]+    -> LHsExpr GhcTc+    -> HsLocalBindsLR GhcTc GhcTc+    -> Match GhcTc (LHsExpr GhcTc)+pattern TopLevelRHS name ps body where_binds <-+  Match _+    (FunRhs (L _ (occName -> name)) _ _)+    ps+    (GRHSs _+      [L _ (GRHS _ [] body)] (L _ where_binds))++liftMaybe :: Monad m => Maybe a -> MaybeT m a+liftMaybe a = MaybeT $ pure a+++------------------------------------------------------------------------------+-- | Get the type of an @HsExpr GhcTc@. This is slow and you should prefer to+-- not use it, but sometimes it can't be helped.+typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type)+typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr++------------------------------------------------------------------------------+-- | Expand type and data families+normalizeType :: Context -> Type -> Type+normalizeType ctx ty =+  let ty' = expandTyFam ctx ty+   in case tcSplitTyConApp_maybe ty' of+        Just (tc, tys) ->+          -- try to expand any data families+          case tcLookupDataFamInst_maybe (ctxFamInstEnvs ctx) tc tys of+            Just (dtc, dtys, _) -> mkAppTys (mkTyConTy dtc) dtys+            Nothing -> ty'+        Nothing -> ty'++------------------------------------------------------------------------------+-- | Expand type families+expandTyFam :: Context -> Type -> Type+expandTyFam ctx = snd . normaliseType  (ctxFamInstEnvs ctx) Nominal+++------------------------------------------------------------------------------+-- | Like 'tcUnifyTy', but takes a list of skolems to prevent unification of.+tryUnifyUnivarsButNotSkolems :: Set TyVar -> CType -> CType -> Maybe TCvSubst+tryUnifyUnivarsButNotSkolems skolems goal inst =+  tryUnifyUnivarsButNotSkolemsMany skolems $ coerce [(goal, inst)]++------------------------------------------------------------------------------+-- | Like 'tryUnifyUnivarsButNotSkolems', but takes a list+-- of pairs of types to unify.+tryUnifyUnivarsButNotSkolemsMany :: Set TyVar -> [(Type, Type)] -> Maybe TCvSubst+tryUnifyUnivarsButNotSkolemsMany skolems (unzip -> (goal, inst)) =+  tcUnifyTys+    (bool BindMe Skolem . flip S.member skolems)+    inst+    goal+++updateSubst :: TCvSubst -> TacticState -> TacticState+updateSubst subst s = s { ts_unifier = unionTCvSubst subst (ts_unifier s) }+++------------------------------------------------------------------------------+-- | Get the class methods of a 'PredType', correctly dealing with+-- instantiation of quantified class types.+methodHypothesis :: PredType -> Maybe [HyInfo CType]+methodHypothesis ty = do+  (tc, apps) <- splitTyConApp_maybe ty+  cls <- tyConClass_maybe tc+  let methods = classMethods cls+      tvs     = classTyVars cls+      subst   = zipTvSubst tvs apps+  pure $ methods <&> \method ->+    let (_, _, ty) = tcSplitSigmaTy $ idType method+    in ( HyInfo (occName method) (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty+       )+
+ new/src/Wingman/Judgements.hs view
@@ -0,0 +1,474 @@+module Wingman.Judgements where++import           Control.Arrow+import           Control.Lens hiding (Context)+import           Data.Bool+import           Data.Char+import           Data.Coerce+import           Data.Generics.Product (field)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.Core.UseStale (Tracked, unTrack)+import           Development.IDE.GHC.Compat hiding (isTopLevel)+import           Development.IDE.Spans.LocalBindings+import           Wingman.GHC (algebraicTyCon, normalizeType)+import           Wingman.Judgements.Theta+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis.+hypothesisFromBindings :: Tracked age RealSrcSpan -> Tracked age Bindings -> Hypothesis CType+hypothesisFromBindings (unTrack -> span) (unTrack -> bs) = buildHypothesis $ getLocalScope bs span+++------------------------------------------------------------------------------+-- | Convert a @Set Id@ into a hypothesis.+buildHypothesis :: [(Name, Maybe Type)] -> Hypothesis CType+buildHypothesis+  = Hypothesis+  . mapMaybe go+  where+    go (occName -> occ, t)+      | Just ty <- t+      , (h:_) <- occNameString occ+      , isAlpha h = Just $ HyInfo occ UserPrv $ CType ty+      | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Build a trivial hypothesis containing only a single name. The corresponding+-- HyInfo has no provenance or type.+hySingleton :: OccName -> Hypothesis ()+hySingleton n = Hypothesis . pure $ HyInfo n UserPrv ()+++blacklistingDestruct :: Judgement -> Judgement+blacklistingDestruct =+  field @"_jBlacklistDestruct" .~ True+++unwhitelistingSplit :: Judgement -> Judgement+unwhitelistingSplit =+  field @"_jWhitelistSplit" .~ False+++isDestructBlacklisted :: Judgement -> Bool+isDestructBlacklisted = _jBlacklistDestruct+++isSplitWhitelisted :: Judgement -> Bool+isSplitWhitelisted = _jWhitelistSplit+++withNewGoal :: a -> Judgement' a -> Judgement' a+withNewGoal t = field @"_jGoal" .~ t++------------------------------------------------------------------------------+-- | Like 'withNewGoal' but allows you to modify the goal rather than replacing+-- it.+withModifiedGoal :: (a -> a) -> Judgement' a -> Judgement' a+withModifiedGoal f = field @"_jGoal" %~ f+++------------------------------------------------------------------------------+-- | Add some new type equalities to the local judgement.+withNewCoercions :: [(CType, CType)] -> Judgement -> Judgement+withNewCoercions ev j =+  let subst = allEvidenceToSubst mempty $ coerce ev+   in fmap (CType . substTyAddInScope subst . unCType) j+      & field @"j_coercion" %~ unionTCvSubst subst+++normalizeHypothesis :: Functor f => Context -> f CType -> f CType+normalizeHypothesis = fmap . coerce . normalizeType++normalizeJudgement :: Functor f => Context -> f CType -> f CType+normalizeJudgement = normalizeHypothesis+++introduce :: Context -> Hypothesis CType -> Judgement' CType -> Judgement' CType+-- NOTE(sandy): It's important that we put the new hypothesis terms first,+-- since 'jAcceptableDestructTargets' will never destruct a pattern that occurs+-- after a previously-destructed term.+introduce ctx hy =+  field @"_jHypothesis" %~ mappend (normalizeHypothesis ctx hy)+++------------------------------------------------------------------------------+-- | Helper function for implementing functions which introduce new hypotheses.+introduceHypothesis+    :: (Int -> Int -> Provenance)+        -- ^ A function from the total number of args and position of this arg+        -- to its provenance.+    -> [(OccName, a)]+    -> Hypothesis a+introduceHypothesis f ns =+  Hypothesis $ zip [0..] ns <&> \(pos, (name, ty)) ->+    HyInfo name (f (length ns) pos) ty+++------------------------------------------------------------------------------+-- | Introduce bindings in the context of a lambda.+lambdaHypothesis+    :: Maybe OccName   -- ^ The name of the top level function. For any other+                       -- function, this should be 'Nothing'.+    -> [(OccName, a)]+    -> Hypothesis a+lambdaHypothesis func =+  introduceHypothesis $ \count pos ->+    maybe UserPrv (\x -> TopLevelArgPrv x pos count) func+++------------------------------------------------------------------------------+-- | Introduce a binding in a recursive context.+recursiveHypothesis :: [(OccName, a)] -> Hypothesis a+recursiveHypothesis = introduceHypothesis $ const $ const RecursivePrv+++------------------------------------------------------------------------------+-- | Introduce a binding in a recursive context.+userHypothesis :: [(OccName, a)] -> Hypothesis a+userHypothesis = introduceHypothesis $ const $ const UserPrv+++------------------------------------------------------------------------------+-- | Check whether any of the given occnames are an ancestor of the term.+hasPositionalAncestry+    :: Foldable t+    => t OccName   -- ^ Desired ancestors.+    -> Judgement+    -> OccName     -- ^ Potential child+    -> Maybe Bool  -- ^ Just True if the result is the oldest positional ancestor+                   -- just false if it's a descendent+                   -- otherwise nothing+hasPositionalAncestry ancestors jdg name+  | not $ null ancestors+  = case name `elem` ancestors of+      True  -> Just True+      False ->+        case M.lookup name $ jAncestryMap jdg of+          Just ancestry ->+            bool Nothing (Just False) $ any (flip S.member ancestry) ancestors+          Nothing -> Nothing+  | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Helper function for disallowing hypotheses that have the wrong ancestry.+filterAncestry+    :: Foldable t+    => t OccName+    -> DisallowReason+    -> Judgement+    -> Judgement+filterAncestry ancestry reason jdg =+    disallowing reason (M.keysSet $ M.filterWithKey go $ hyByName $ jHypothesis jdg) jdg+  where+    go name _+      = isNothing+      $ hasPositionalAncestry ancestry jdg name+++------------------------------------------------------------------------------+-- | @filter defn pos@ removes any hypotheses which are bound in @defn@ to+-- a position other than @pos@. Any terms whose ancestry doesn't include @defn@+-- remain.+filterPosition :: OccName -> Int -> Judgement -> Judgement+filterPosition defn pos jdg =+  filterAncestry (findPositionVal jdg defn pos) (WrongBranch pos) jdg+++------------------------------------------------------------------------------+-- | Helper function for determining the ancestry list for 'filterPosition'.+findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName+findPositionVal jdg defn pos = listToMaybe $ do+  -- It's important to inspect the entire hypothesis here, as we need to trace+  -- ancestry through potentially disallowed terms in the hypothesis.+  (name, hi) <- M.toList+              $ M.map (overProvenance expandDisallowed)+              $ hyByName+              $ jEntireHypothesis jdg+  case hi_provenance hi of+    TopLevelArgPrv defn' pos' _+      | defn == defn'+      , pos  == pos' -> pure name+    PatternMatchPrv pv+      | pv_scrutinee pv == Just defn+      , pv_position pv  == pos -> pure name+    _ -> []+++------------------------------------------------------------------------------+-- | Helper function for determining the ancestry list for+-- 'filterSameTypeFromOtherPositions'.+findDconPositionVals :: Judgement' a -> ConLike -> Int -> [OccName]+findDconPositionVals jdg dcon pos = do+  (name, hi) <- M.toList $ hyByName $ jHypothesis jdg+  case hi_provenance hi of+    PatternMatchPrv pv+      | pv_datacon  pv == Uniquely dcon+      , pv_position pv == pos -> pure name+    _ -> []+++------------------------------------------------------------------------------+-- | Disallow any hypotheses who have the same type as anything bound by the+-- given position for the datacon. Used to ensure recursive functions like+-- 'fmap' preserve the relative ordering of their arguments by eliminating any+-- other term which might match.+filterSameTypeFromOtherPositions :: ConLike -> Int -> Judgement -> Judgement+filterSameTypeFromOtherPositions dcon pos jdg =+  let hy = hyByName+         . jHypothesis+         $ filterAncestry+             (findDconPositionVals jdg dcon pos)+             (WrongBranch pos)+             jdg+      tys = S.fromList $ hi_type <$> M.elems hy+      to_remove =+        M.filter (flip S.member tys . hi_type) (hyByName $ jHypothesis jdg)+          M.\\ hy+   in disallowing Shadowed (M.keysSet to_remove) jdg+++------------------------------------------------------------------------------+-- | Return the ancestry of a 'PatVal', or 'mempty' otherwise.+getAncestry :: Judgement' a -> OccName -> Set OccName+getAncestry jdg name =+  maybe mempty pv_ancestry . M.lookup name $ jPatHypothesis jdg+++jAncestryMap :: Judgement' a -> Map OccName (Set OccName)+jAncestryMap jdg =+  M.map pv_ancestry (jPatHypothesis jdg)+++provAncestryOf :: Provenance -> Set OccName+provAncestryOf (TopLevelArgPrv o _ _) = S.singleton o+provAncestryOf (PatternMatchPrv (PatVal mo so _ _)) =+  maybe mempty S.singleton mo <> so+provAncestryOf (ClassMethodPrv _) = mempty+provAncestryOf UserPrv = mempty+provAncestryOf RecursivePrv = mempty+provAncestryOf ImportPrv = mempty+provAncestryOf (DisallowedPrv _ p2) = provAncestryOf p2+++------------------------------------------------------------------------------+-- TODO(sandy): THIS THING IS A BIG BIG HACK+--+-- Why? 'ctxDefiningFuncs' is _all_ of the functions currently being defined+-- (eg, we might be in a where block). The head of this list is not guaranteed+-- to be the one we're interested in.+extremelyStupid__definingFunction :: Context -> OccName+extremelyStupid__definingFunction =+  fst . head . ctxDefiningFuncs+++patternHypothesis+    :: Maybe OccName+    -> ConLike+    -> Judgement' a+    -> [(OccName, a)]+    -> Hypothesis a+patternHypothesis scrutinee dc jdg+  = introduceHypothesis $ \_ pos ->+      PatternMatchPrv $+        PatVal+          scrutinee+          (maybe+              mempty+              (\scrut -> S.singleton scrut <> getAncestry jdg scrut)+              scrutinee)+          (Uniquely dc)+          pos+++------------------------------------------------------------------------------+-- | Prevent some occnames from being used in the hypothesis. This will hide+-- them from 'jHypothesis', but not from 'jEntireHypothesis'.+disallowing :: DisallowReason -> S.Set OccName -> Judgement' a -> Judgement' a+disallowing reason ns =+  field @"_jHypothesis" %~ (\z -> Hypothesis . flip fmap (unHypothesis z) $ \hi ->+    case S.member (hi_name hi) ns of+      True  -> overProvenance (DisallowedPrv reason) hi+      False -> hi+                           )+++------------------------------------------------------------------------------+-- | The hypothesis, consisting of local terms and the ambient environment+-- (imports and class methods.) Hides disallowed values.+jHypothesis :: Judgement' a -> Hypothesis a+jHypothesis+  = Hypothesis+  . filter (not . isDisallowed . hi_provenance)+  . unHypothesis+  . jEntireHypothesis+++------------------------------------------------------------------------------+-- | The whole hypothesis, including things disallowed.+jEntireHypothesis :: Judgement' a -> Hypothesis a+jEntireHypothesis = _jHypothesis+++------------------------------------------------------------------------------+-- | Just the local hypothesis.+jLocalHypothesis :: Judgement' a -> Hypothesis a+jLocalHypothesis+  = Hypothesis+  . filter (isLocalHypothesis . hi_provenance)+  . unHypothesis+  . jHypothesis+++------------------------------------------------------------------------------+-- | Filter elements from the hypothesis+hyFilter :: (HyInfo a -> Bool) -> Hypothesis a -> Hypothesis a+hyFilter f  = Hypothesis . filter f . unHypothesis+++------------------------------------------------------------------------------+-- | Given a judgment, return the hypotheses that are acceptable to destruct.+--+-- We use the ordering of the hypothesis for this purpose. Since new bindings+-- are always inserted at the beginning, we can impose a canonical ordering on+-- which order to try destructs by what order they are introduced --- stopping+-- at the first one we've already destructed.+jAcceptableDestructTargets :: Judgement' CType -> [HyInfo CType]+jAcceptableDestructTargets+  = filter (isJust . algebraicTyCon . unCType . hi_type)+  . takeWhile (not . isAlreadyDestructed . hi_provenance)+  . unHypothesis+  . jEntireHypothesis+++------------------------------------------------------------------------------+-- | If we're in a top hole, the name of the defining function.+isTopHole :: Context -> Judgement' a -> Maybe OccName+isTopHole ctx =+  bool Nothing (Just $ extremelyStupid__definingFunction ctx) . _jIsTopHole+++unsetIsTopHole :: Judgement' a -> Judgement' a+unsetIsTopHole = field @"_jIsTopHole" .~ False+++------------------------------------------------------------------------------+-- | What names are currently in scope in the hypothesis?+hyNamesInScope :: Hypothesis a -> Set OccName+hyNamesInScope = M.keysSet . hyByName+++------------------------------------------------------------------------------+-- | Are there any top-level function argument bindings in this judgement?+jHasBoundArgs :: Judgement' a -> Bool+jHasBoundArgs+  = any (isTopLevel . hi_provenance)+  . unHypothesis+  . jLocalHypothesis+++jNeedsToBindArgs :: Judgement' CType -> Bool+jNeedsToBindArgs = isFunTy . unCType . jGoal+++------------------------------------------------------------------------------+-- | Fold a hypothesis into a single mapping from name to info. This+-- unavoidably will cause duplicate names (things like methods) to shadow one+-- another.+hyByName :: Hypothesis a -> Map OccName (HyInfo a)+hyByName+  = M.fromList+  . fmap (hi_name &&& id)+  . unHypothesis+++------------------------------------------------------------------------------+-- | Only the hypothesis members which are pattern vals+jPatHypothesis :: Judgement' a -> Map OccName PatVal+jPatHypothesis+  = M.mapMaybe (getPatVal . hi_provenance)+  . hyByName+  . jHypothesis+++getPatVal :: Provenance-> Maybe PatVal+getPatVal prov =+  case prov of+    PatternMatchPrv pv -> Just pv+    _                  -> Nothing+++jGoal :: Judgement' a -> a+jGoal = _jGoal+++substJdg :: TCvSubst -> Judgement -> Judgement+substJdg subst = fmap $ coerce . substTy subst . coerce+++mkFirstJudgement+    :: Context+    -> Hypothesis CType+    -> Bool  -- ^ are we in the top level rhs hole?+    -> Type+    -> Judgement' CType+mkFirstJudgement ctx hy top goal =+  normalizeJudgement ctx $+    Judgement+      { _jHypothesis        = hy+      , _jBlacklistDestruct = False+      , _jWhitelistSplit    = True+      , _jIsTopHole         = top+      , _jGoal              = CType goal+      , j_coercion          = emptyTCvSubst+      }+++------------------------------------------------------------------------------+-- | Is this a top level function binding?+isTopLevel :: Provenance -> Bool+isTopLevel TopLevelArgPrv{} = True+isTopLevel _                = False+++------------------------------------------------------------------------------+-- | Is this a local function argument, pattern match or user val?+isLocalHypothesis :: Provenance -> Bool+isLocalHypothesis UserPrv{}         = True+isLocalHypothesis PatternMatchPrv{} = True+isLocalHypothesis TopLevelArgPrv{}  = True+isLocalHypothesis _                 = False+++------------------------------------------------------------------------------+-- | Is this a pattern match?+isPatternMatch :: Provenance -> Bool+isPatternMatch PatternMatchPrv{} = True+isPatternMatch _                 = False+++------------------------------------------------------------------------------+-- | Was this term ever disallowed?+isDisallowed :: Provenance -> Bool+isDisallowed DisallowedPrv{} = True+isDisallowed _               = False++------------------------------------------------------------------------------+-- | Has this term already been disallowed?+isAlreadyDestructed :: Provenance -> Bool+isAlreadyDestructed (DisallowedPrv AlreadyDestructed _) = True+isAlreadyDestructed _ = False+++------------------------------------------------------------------------------+-- | Eliminates 'DisallowedPrv' provenances.+expandDisallowed :: Provenance -> Provenance+expandDisallowed (DisallowedPrv _ prv) = expandDisallowed prv+expandDisallowed prv                   = prv
+ new/src/Wingman/Judgements/SYB.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes          #-}++-- | Custom SYB traversals+module Wingman.Judgements.SYB where++import           Data.Foldable (foldl')+import           Data.Generics hiding (typeRep)+import qualified Data.Text as T+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util (unpackFS)+import           GHC.Exts (Any)+import           Type.Reflection+import           Unsafe.Coerce (unsafeCoerce)+import           Wingman.StaticPlugin (pattern WingmanMetaprogram)+++------------------------------------------------------------------------------+-- | Like 'everything', but only looks inside 'Located' terms that contain the+-- given 'SrcSpan'.+everythingContaining+    :: forall r+     . Monoid r+    => SrcSpan+    -> GenericQ r+    -> GenericQ r+everythingContaining dst f = go+  where+    go :: GenericQ r+    go x =+      case genericIsSubspan dst x of+        Just False -> mempty+        _ -> foldl' (<>) (f x) (gmapQ go x)+++------------------------------------------------------------------------------+-- | Helper function for implementing 'everythingWithin'+--+-- NOTE(sandy): Subtly broken. In an ideal world, this function should return+-- @Just False@ for nodes of /any type/ which do not contain the span. But if+-- this functionality exists anywhere within the SYB machinery, I have yet to+-- find it.+genericIsSubspan+    :: SrcSpan+    -> GenericQ (Maybe Bool)+genericIsSubspan dst = mkQ1 (L noSrcSpan ()) Nothing $ \case+  L span _ -> Just $ dst `isSubspanOf` span+++------------------------------------------------------------------------------+-- | Like 'mkQ', but allows for polymorphic instantiation of its specific case.+-- This instantiation matches whenever the dynamic value has the same+-- constructor as the proxy @f ()@ value.+mkQ1 :: forall a r f+      . (Data a, Data (f ()))+     => f ()                  -- ^ Polymorphic constructor to match on+     -> r                     -- ^ Default value+     -> (forall b. f b -> r)  -- ^ Polymorphic match+     -> a+     -> r+mkQ1 proxy r br a =+    case l_con == a_con && sameTypeModuloLastApp @a @(f ()) of+      -- We have proven that the two values share the same constructor, and+      -- that they have the same type if you ignore the final application.+      -- Therefore, it is safe to coerce @a@ to @f b@, since @br@ is universal+      -- over @b@ and can't inspect it.+      True  -> br $ unsafeCoerce @_ @(f Any) a+      False -> r+  where+    l_con = toConstr proxy+    a_con = toConstr a+++------------------------------------------------------------------------------+-- | Given @a ~ f1 a1@ and @b ~ f2 b2@, returns true if @f1 ~ f2@.+sameTypeModuloLastApp :: forall a b. (Typeable a, Typeable b) => Bool+sameTypeModuloLastApp =+  let tyrep1 = typeRep @a+      tyrep2 = typeRep @b+   in case (tyrep1 , tyrep2) of+        (App a _, App b _) ->+          case eqTypeRep a b of+            Just HRefl -> True+            Nothing    -> False+        _ -> False+++metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]+metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case+  L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program)+  (_ :: LHsExpr GhcTc) -> mempty+++metaprogramQ :: GenericQ [(SrcSpan, T.Text)]+metaprogramQ = everything (<>) $ mkQ mempty $ \case+  L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program)+  (_ :: LHsExpr GhcTc) -> mempty+
+ new/src/Wingman/Judgements/Theta.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++module Wingman.Judgements.Theta+  ( Evidence+  , getEvidenceAtHole+  , mkEvidence+  , evidenceToCoercions+  , evidenceToSubst+  , evidenceToHypothesis+  , evidenceToThetaType+  , allEvidenceToSubst+  ) where++import           Control.Applicative (empty)+import           Control.Lens (preview)+import           Data.Coerce (coerce)+import           Data.Maybe (fromMaybe, mapMaybe, maybeToList)+import           Data.Generics.Sum (_Ctor)+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Generics.SYB hiding (tyConName, empty, Generic)+import           GHC.Generics+import           Wingman.GHC+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++------------------------------------------------------------------------------+-- | Something we've learned about the type environment.+data Evidence+    -- | The two types are equal, via a @a ~ b@ relationship+  = EqualityOfTypes Type Type+    -- | We have an instance in scope+  | HasInstance PredType+  deriving (Show, Generic)+++------------------------------------------------------------------------------+-- | Given a 'PredType', pull an 'Evidence' out of it.+mkEvidence :: PredType -> [Evidence]+mkEvidence (getEqualityTheta -> Just (a, b))+  = pure $ EqualityOfTypes a b+mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) = do+  (_, apps) <- maybeToList $ splitTyConApp_maybe inst+  let tvs     = classTyVars cls+      subst   = zipTvSubst tvs apps+  sc_ev <- traverse (mkEvidence . substTy subst) $ classSCTheta cls+  HasInstance inst : sc_ev+mkEvidence _ = empty+++------------------------------------------------------------------------------+-- | Build a set of 'PredType's from the evidence.+evidenceToThetaType :: [Evidence] -> Set CType+evidenceToThetaType evs = S.fromList $ do+  HasInstance t <- evs+  pure $ CType t+++------------------------------------------------------------------------------+-- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'.+getEvidenceAtHole :: Tracked age SrcSpan -> Tracked age (LHsBinds GhcTc) -> [Evidence]+getEvidenceAtHole (unTrack -> dst)+  = concatMap mkEvidence+  . (everything (<>) $+        mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst)+  . unTrack+++mkSubst :: Set TyVar -> Type -> Type -> TCvSubst+mkSubst skolems a b =+  let tyvars = S.fromList $ mapMaybe getTyVar_maybe [a, b]+      -- If we can unify our skolems, at least one is no longer a skolem.+      -- Removing them from this set ensures we can get a substitution between+      -- the two. But it's okay to leave them in 'ts_skolems' in general, since+      -- they won't exist after running this substitution.+      skolems' = skolems S.\\ tyvars+   in+  case tryUnifyUnivarsButNotSkolems skolems' (CType a) (CType b) of+    Just subst -> subst+    Nothing -> emptyTCvSubst+++substPair :: TCvSubst -> (Type, Type) -> (Type, Type)+substPair subst (ty, ty') = (substTy subst ty, substTy subst ty')+++------------------------------------------------------------------------------+-- | Construct a substitution given a list of types that are equal to one+-- another. This is more subtle than it seems, since there might be several+-- equalities for the same type. We must be careful to push the accumulating+-- substitution through each pair of types before adding their equalities.+allEvidenceToSubst :: Set TyVar -> [(Type, Type)] -> TCvSubst+allEvidenceToSubst _ [] = emptyTCvSubst+allEvidenceToSubst skolems ((a, b) : evs) =+  let subst = mkSubst skolems a b+   in unionTCvSubst subst+    $ allEvidenceToSubst skolems+    $ fmap (substPair subst) evs++------------------------------------------------------------------------------+-- | Given some 'Evidence', get a list of which types are now equal.+evidenceToCoercions :: [Evidence] -> [(CType, CType)]+evidenceToCoercions = coerce . mapMaybe (preview $ _Ctor @"EqualityOfTypes")++------------------------------------------------------------------------------+-- | Update our knowledge of which types are equal.+evidenceToSubst :: [Evidence] -> TacticState -> TacticState+evidenceToSubst evs ts =+  updateSubst+    (allEvidenceToSubst (ts_skolems ts) . coerce $ evidenceToCoercions evs)+    ts+++------------------------------------------------------------------------------+-- | Get all of the methods that are in scope from this piece of 'Evidence'.+evidenceToHypothesis :: Evidence -> Hypothesis CType+evidenceToHypothesis EqualityOfTypes{} = mempty+evidenceToHypothesis (HasInstance t) =+  Hypothesis . excludeForbiddenMethods . fromMaybe [] $ methodHypothesis t+++------------------------------------------------------------------------------+-- | Given @a ~ b@ or @a ~# b@, returns @Just (a, b)@, otherwise @Nothing@.+getEqualityTheta :: PredType -> Maybe (Type, Type)+getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k, a, b]))+#if __GLASGOW_HASKELL__ > 806+  | tc == eqTyCon+#else+  | nameRdrName (tyConName tc) == eqTyCon_RDR+#endif+  = Just (a, b)+getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k1, _k2, a, b]))+  | tc == eqPrimTyCon = Just (a, b)+getEqualityTheta _ = Nothing+++------------------------------------------------------------------------------+-- | Many operations are defined in typeclasses for performance reasons, rather+-- than being a true part of the class. This function filters out those, in+-- order to keep our hypothesis space small.+excludeForbiddenMethods :: [HyInfo a] -> [HyInfo a]+excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name)+  where+    forbiddenMethods :: Set OccName+    forbiddenMethods = S.map mkVarOcc $ S.fromList+      [ -- monadfail+        "fail"+        -- show+      , "showsPrec", "showList"+        -- functor+      , "<$"+        -- applicative+      , "liftA2", "<*", "*>"+        -- monad+      , "return", ">>"+        -- alternative+      , "some", "many"+        -- foldable+      , "foldr1", "foldl1", "elem", "maximum", "minimum", "sum", "product"+        -- traversable+      , "sequenceA", "mapM", "sequence"+        -- semigroup+      , "sconcat", "stimes"+        -- monoid+      , "mconcat"+      ]+++------------------------------------------------------------------------------+-- | Extract evidence from 'AbsBinds' in scope.+absBinds ::  SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+absBinds dst (L src (FunBind w _ _ _))+  | dst `isSubspanOf` src+  = wrapper w+absBinds dst (L src (AbsBinds _ _ h _ _ z _))+#else+absBinds dst (L src (AbsBinds _ _ h _ _ _ _))+#endif+  | dst `isSubspanOf` src+  = fmap idType h+#if __GLASGOW_HASKELL__ >= 900+    <> foldMap (absBinds dst) z+#endif+absBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from 'HsWrapper's in scope+wrapperBinds ::  SrcSpan -> LHsExpr GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _))))+#else+wrapperBinds dst (L src (HsWrap _ h _))+#endif+  | dst `isSubspanOf` src+  = wrapper h+wrapperBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from the 'ConPatOut's bound in this 'Match'.+matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType]+matchBinds dst (L src (Match _ _ pats _))+  | dst `isSubspanOf` src+  = everything (<>) (mkQ mempty patBinds) pats+matchBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from a 'ConPatOut'.+patBinds ::  Pat GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }})+#else+patBinds (ConPatOut { pat_dicts = dicts })+#endif+  = fmap idType dicts+patBinds _ = []+++------------------------------------------------------------------------------+-- | Extract the types of the evidence bindings in scope.+wrapper ::  HsWrapper -> [PredType]+wrapper (WpCompose h h2) = wrapper h <> wrapper h2+wrapper (WpEvLam v) = [idType v]+wrapper _ = []+
+ new/src/Wingman/KnownStrategies.hs view
@@ -0,0 +1,82 @@+module Wingman.KnownStrategies where++import Data.Foldable (for_)+import Development.IDE.GHC.Compat.Core+import Refinery.Tactic+import Wingman.Judgements (jGoal)+import Wingman.KnownStrategies.QuickCheck (deriveArbitrary)+import Wingman.Machinery (tracing, getKnownInstance, getCurrentDefinitions)+import Wingman.Tactics+import Wingman.Types+++knownStrategies :: TacticsM ()+knownStrategies = choice+  [ known "fmap" deriveFmap+  , known "mempty" deriveMempty+  , known "arbitrary" deriveArbitrary+  , known "<>" deriveMappend+  , known "mappend" deriveMappend+  ]+++known :: String -> TacticsM () -> TacticsM ()+known name t = do+  getCurrentDefinitions >>= \case+    [(def, _)] | def == mkVarOcc name ->+      tracing ("known " <> name) t+    _ -> failure NoApplicableTactic+++deriveFmap :: TacticsM ()+deriveFmap = do+  try intros+  overAlgebraicTerms homo+  choice+    [ overFunctions (apply Saturated) >> auto' 2+    , assumption+    , recursion+    ]+++------------------------------------------------------------------------------+-- | We derive mappend by binding the arguments, introducing the constructor,+-- and then calling mappend recursively. At each recursive call, we filter away+-- any binding that isn't in an analogous position.+--+-- The recursive call first attempts to use an instance in scope. If that fails,+-- it falls back to trying a theta method from the hypothesis with the correct+-- name.+deriveMappend :: TacticsM ()+deriveMappend = do+  try intros+  destructAll+  split+  g <- goal+  minst <- getKnownInstance (mkClsOcc "Semigroup")+         . pure+         . unCType+         $ jGoal g+  for_ minst $ \(cls, df) -> do+    restrictPositionForApplication+      (applyMethod cls df $ mkVarOcc "<>")+      assumption+  try $+    restrictPositionForApplication+      (applyByName $ mkVarOcc "<>")+      assumption+++------------------------------------------------------------------------------+-- | We derive mempty by introducing the constructor, and then trying to+-- 'mempty' everywhere. This smaller 'mempty' might come from an instance in+-- scope, or it might come from the hypothesis theta.+deriveMempty :: TacticsM ()+deriveMempty = do+  split+  g <- goal+  minst <- getKnownInstance (mkClsOcc "Monoid") [unCType $ jGoal g]+  for_ minst $ \(cls, df) -> do+    applyMethod cls df $ mkVarOcc "mempty"+  try assumption+
+ new/src/Wingman/KnownStrategies/QuickCheck.hs view
@@ -0,0 +1,109 @@+module Wingman.KnownStrategies.QuickCheck where++import Data.Bool (bool)+import Data.Generics (everything, mkQ)+import Data.List (partition)+import Development.IDE.GHC.Compat+import GHC.Exts (IsString (fromString))+import GHC.List (foldl')+import GHC.SourceGen (int)+import GHC.SourceGen.Binds (match, valBind)+import GHC.SourceGen.Expr (case', lambda, let')+import GHC.SourceGen.Overloaded (App ((@@)), HasList (list))+import GHC.SourceGen.Pat (conP)+import Refinery.Tactic (goal, rule, failure)+import Wingman.CodeGen+import Wingman.Judgements (jGoal)+import Wingman.Machinery (tracePrim)+import Wingman.Types+++------------------------------------------------------------------------------+-- | Known tactic for deriving @arbitrary :: Gen a@. This tactic splits the+-- type's data cons into terminal and inductive cases, and generates code that+-- produces a terminal if the QuickCheck size parameter is <=1, or any data con+-- otherwise. It correctly scales recursive parameters, ensuring termination.+deriveArbitrary :: TacticsM ()+deriveArbitrary = do+  ty <- jGoal <$> goal+  case splitTyConApp_maybe $ unCType ty of+    Just (gen_tc, [splitTyConApp_maybe -> Just (tc, apps)])+        | occNameString (occName $ tyConName gen_tc) == "Gen" -> do+      rule $ \_ -> do+        let dcs = tyConDataCons tc+            (terminal, big) = partition ((== 0) . genRecursiveCount)+                        $ fmap (mkGenerator tc apps) dcs+            terminal_expr = mkVal "terminal"+            oneof_expr = mkVal "oneof"+        pure+          $ Synthesized (tracePrim "deriveArbitrary")+              -- TODO(sandy): This thing is not actually empty! We produced+              -- a bespoke binding "terminal", and a not-so-bespoke "n".+              -- But maybe it's fine for known rules?+              mempty+              mempty+              mempty+          $ noLoc $ case terminal of+            [onlyCon] -> genExpr onlyCon -- See #1879+            _ -> let' [valBind (fromString "terminal") $ list $ fmap genExpr terminal] $+                appDollar (mkFunc "sized") $ lambda [bvar' (mkVarOcc "n")] $+                  case' (infixCall "<=" (mkVal "n") (int 1))+                    [ match [conP (fromString "True") []] $+                        oneof_expr @@ terminal_expr+                    , match [conP (fromString "False") []] $+                        appDollar oneof_expr $+                          infixCall "<>"+                            (list $ fmap genExpr big)+                            terminal_expr+                    ]+    _ -> failure $ GoalMismatch "deriveArbitrary" ty+++------------------------------------------------------------------------------+-- | Helper data type for the generator of a specific data con.+data Generator = Generator+  { genRecursiveCount :: Integer+  , genExpr           :: HsExpr GhcPs+  }+++------------------------------------------------------------------------------+-- | Make a 'Generator' for a given tycon instantiated with the given @[Type]@.+mkGenerator :: TyCon -> [Type] -> DataCon -> Generator+mkGenerator tc apps dc = do+  let dc_expr   = var' $ occName $ dataConName dc+      args = conLikeInstOrigArgTys' (RealDataCon dc) apps+      num_recursive_calls = sum $ fmap (bool 0 1 . doesTypeContain tc) args+      mkArbitrary = mkArbitraryCall tc num_recursive_calls+  Generator num_recursive_calls $ case args of+    []  -> mkFunc "pure" @@ dc_expr+    (a : as) ->+      foldl'+        (infixCall "<*>")+        (infixCall "<$>" dc_expr $ mkArbitrary a)+        (fmap mkArbitrary as)+++------------------------------------------------------------------------------+-- | Check if the given 'TyCon' exists anywhere in the 'Type'.+doesTypeContain :: TyCon -> Type -> Bool+doesTypeContain recursive_tc =+  everything (||) $ mkQ False (== recursive_tc)+++------------------------------------------------------------------------------+-- | Generate the correct sort of call to @arbitrary@. For recursive calls, we+-- need to scale down the size parameter, either by a constant factor of 1 if+-- it's the only recursive parameter, or by @`div` n@ where n is the number of+-- recursive parameters. For all other types, just call @arbitrary@ directly.+mkArbitraryCall :: TyCon -> Integer -> Type -> HsExpr GhcPs+mkArbitraryCall recursive_tc n ty =+  let arbitrary = mkFunc "arbitrary"+   in case doesTypeContain recursive_tc ty of+        True ->+          mkFunc "scale"+            @@ bool (mkFunc "flip" @@ mkFunc "div" @@ int n)+                    (mkFunc "subtract" @@ int 1)+                    (n == 1)+            @@ arbitrary+        False -> arbitrary
+ new/src/Wingman/LanguageServer.hs view
@@ -0,0 +1,662 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}++{-# LANGUAGE NoMonoLocalBinds  #-}++module Wingman.LanguageServer where++import           Control.Arrow ((***))+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.RWS+import           Control.Monad.State (State, evalState)+import           Control.Monad.Trans.Maybe+import           Data.Bifunctor (first)+import           Data.Coerce+import           Data.Functor ((<&>))+import           Data.Functor.Identity (runIdentity)+import qualified Data.HashMap.Strict as Map+import           Data.IORef (readIORef)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text as T+import           Data.Traversable+import           Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction)+import           Development.IDE.Core.PositionMapping (idDelta)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Rules (usePropertyAction)+import           Development.IDE.Core.Service (runAction)+import           Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule)+import qualified Development.IDE.Core.Shake as IDE+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Development.IDE.GHC.Compat.ExactPrint+import qualified Development.IDE.GHC.Compat.Util as FastString+import           Development.IDE.GHC.Error (realSrcSpanToRange)+import           Development.IDE.GHC.ExactPrint hiding (LogShake, Log)+import           Development.IDE.Graph (Action, RuleResult, Rules, action)+import           Development.IDE.Graph.Classes (Hashable, NFData)+import           Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)+import           GHC.Generics (Generic)+import           Generics.SYB hiding (Generic)+import qualified Ide.Plugin.Config as Plugin+import           Ide.Plugin.Properties+import           Ide.PluginUtils (usePropertyLsp)+import           Ide.Types (PluginId)+import           Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty)+import           Language.LSP.Server (MonadLsp, sendNotification)+import           Language.LSP.Types              hiding+                                                 (SemanticTokenAbsolute (length, line),+                                                  SemanticTokenRelative (length),+                                                  SemanticTokensEdit (_start))+import           Language.LSP.Types.Capabilities+import           Prelude hiding (span)+import           Retrie (transformA)+import           Wingman.Context+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ)+import           Wingman.Judgements.Theta+import           Wingman.Range+import           Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)+import           Wingman.Types+import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import qualified Development.IDE.Core.Shake as Shake+++newtype Log+  = LogShake Shake.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog++tacticDesc :: T.Text -> T.Text+tacticDesc name = "fill the hole using the " <> name <> " tactic"+++------------------------------------------------------------------------------+-- | The name of the command for the LS.+tcCommandName :: TacticCommand -> T.Text+tcCommandName = T.pack . show+++runIde :: String -> String -> IdeState -> Action a -> IO a+runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state++runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a+runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state)+++runCurrentIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO (Tracked 'Current r)+runCurrentIde herald state nfp a =+  MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp+++runStaleIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO (TrackedStale r)+runStaleIde herald state nfp a =+  MaybeT $ runIde herald (show a) state $ useWithStale a nfp+++unsafeRunStaleIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO r+unsafeRunStaleIde herald state nfp a = do+  (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp+  pure r++unsafeRunStaleIdeFast+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO r+unsafeRunStaleIdeFast herald state nfp a = do+  (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp+  pure r+++------------------------------------------------------------------------------++properties :: Properties+  '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity))+   , 'PropertyKey "max_use_ctor_actions" 'TInteger+   , 'PropertyKey "timeout_duration" 'TInteger+   , 'PropertyKey "auto_gas" 'TInteger+   , 'PropertyKey "proofstate_styling" 'TBoolean+   ]+properties = emptyProperties+  & defineBooleanProperty #proofstate_styling+    "Should Wingman emit styling markup when showing metaprogram proof states?" True+  & defineIntegerProperty #auto_gas+    "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4+  & defineIntegerProperty #timeout_duration+    "The timeout for Wingman actions, in seconds" 2+  & defineIntegerProperty #max_use_ctor_actions+    "Maximum number of `Use constructor <x>` code actions that can appear" 5+  & defineEnumProperty #hole_severity+    "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities."+    [ (Just DsError,   "error")+    , (Just DsWarning, "warning")+    , (Just DsInfo,    "info")+    , (Just DsHint,    "hint")+    , (Nothing,        "none")+    ]+    Nothing+++-- | Get the the plugin config+getTacticConfigAction :: PluginId -> Action Config+getTacticConfigAction pId =+  Config+    <$> usePropertyAction #max_use_ctor_actions pId properties+    <*> usePropertyAction #timeout_duration pId properties+    <*> usePropertyAction #auto_gas pId properties+    <*> usePropertyAction #proofstate_styling pId properties+++getIdeDynflags+    :: IdeState+    -> NormalizedFilePath+    -> MaybeT IO DynFlags+getIdeDynflags state nfp = do+  -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'+  -- which don't change very often.+  msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps+  pure $ ms_hspp_opts $ msrModSummary msr++getAllMetaprograms :: Data a => a -> [String]+getAllMetaprograms = everything (<>) $ mkQ mempty $ \case+  WingmanMetaprogram fs -> [ FastString.unpackFS fs ]+  (_ :: HsExpr GhcTc)  -> mempty+++------------------------------------------------------------------------------+-- | Find the last typechecked module, and find the most specific span, as well+-- as the judgement at the given range.+judgementForHole+    :: IdeState+    -> NormalizedFilePath+    -> Tracked 'Current Range+    -> Config+    -> MaybeT IO HoleJudgment+judgementForHole state nfp range cfg = do+  let stale a = runStaleIde "judgementForHole" state nfp a++  TrackedStale asts amapping  <- stale GetHieAst+  case unTrack asts of+    HAR _ _  _ _ (HieFromDisk _) -> fail "Need a fresh hie file"+    HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do+      range' <- liftMaybe $ mapAgeFrom amapping range+      binds <- stale GetBindings+      tcg@(TrackedStale tcg_t tcg_map)+          <- fmap (fmap tmrTypechecked)+           $ stale TypeCheck++      hscenv <- stale GhcSessionDeps++      (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf++      new_rss <- liftMaybe $ mapAgeTo amapping rss+      tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss++      -- KnownThings is just the instances in scope. There are no ranges+      -- involved, so it's not crucial to track ages.+      let henv = untrackedStaleValue hscenv+      eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv++      (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps+      let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t++      dflags <- getIdeDynflags state nfp+      pure $ HoleJudgment+        { hj_range = fmap realSrcSpanToRange new_rss+        , hj_jdg = jdg+        , hj_ctx = ctx+        , hj_dflags = dflags+        , hj_hole_sort = holeSortFor mp+        }+++holeSortFor :: Maybe T.Text -> HoleSort+holeSortFor = maybe Hole Metaprogram+++mkJudgementAndContext+    :: Config+    -> Type+    -> TrackedStale Bindings+    -> Tracked 'Current RealSrcSpan+    -> TrackedStale TcGblEnv+    -> HscEnv+    -> ExternalPackageState+    -> Maybe (Judgement, Context)+mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do+  binds_rss <- mapAgeFrom bmap rss+  tcg_rss <- mapAgeFrom tcgmap rss++  let tcs = fmap tcg_binds tcg+      ctx = mkContext cfg+              (mapMaybe (sequenceA . (occName *** coerce))+                $ unTrack+                $ getDefiningBindings <$> binds <*> binds_rss)+              (unTrack tcg)+              hscenv+              eps+              evidence+      top_provs = getRhsPosVals tcg_rss tcs+      already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs+      local_hy = spliceProvenance top_provs+               $ hypothesisFromBindings binds_rss binds+      evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs+      cls_hy = foldMap evidenceToHypothesis evidence+      subst = ts_unifier $ evidenceToSubst evidence defaultTacticState+  pure+    ( disallowing AlreadyDestructed already_destructed+    $ fmap (CType . substTyAddInScope subst . unCType) $+        mkFirstJudgement+          ctx+          (local_hy <> cls_hy)+          (isRhsHoleWithoutWhere tcg_rss tcs)+          g+    , ctx+    )+++------------------------------------------------------------------------------+-- | Determine which bindings have already been destructed by the location of+-- the hole.+getAlreadyDestructed+    :: Tracked age SrcSpan+    -> Tracked age (LHsBinds GhcTc)+    -> Set OccName+getAlreadyDestructed (unTrack -> span) (unTrack -> binds) =+  everythingContaining span+    (mkQ mempty $ \case+      Case (HsVar _ (L _ (occName -> var))) _ ->+        S.singleton var+      (_ :: HsExpr GhcTc) -> mempty+    ) binds+++getSpanAndTypeAtHole+    :: Tracked age Range+    -> Tracked age (HieASTs Type)+    -> Maybe (Tracked age RealSrcSpan, Type)+getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do+  join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->+    case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of+      Nothing -> Nothing+      Just ast' -> do+        let info = nodeInfo ast'+        ty <- listToMaybe $ nodeType info+        guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info+        -- Ensure we're actually looking at a hole here+        occ <- (either (const Nothing) (Just . occName) =<<)+             . listToMaybe+             . S.toList+             . M.keysSet+             $ nodeIdentifiers info+        guard $ isHole occ+        pure (unsafeCopyAge r $ nodeSpan ast', ty)++++------------------------------------------------------------------------------+-- | Combine two (possibly-overlapping) hypotheses; using the provenance from+-- the first hypothesis if the bindings overlap.+spliceProvenance+    :: Hypothesis a  -- ^ Bindings to keep+    -> Hypothesis a  -- ^ Bindings to keep if they don't overlap with the first set+    -> Hypothesis a+spliceProvenance top x =+  let bound = S.fromList $ fmap hi_name $ unHypothesis top+   in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x+++------------------------------------------------------------------------------+-- | Compute top-level position vals of a function+getRhsPosVals+    :: Tracked age RealSrcSpan+    -> Tracked age TypecheckedSource+    -> Hypothesis CType+getRhsPosVals (unTrack -> rss) (unTrack -> tcs)+  = everything (<>) (mkQ mempty $ \case+      TopLevelRHS name ps+          (L (RealSrcSpan span _)  -- body with no guards and a single defn+            (HsVar _ (L _ hole)))+          _+        | containsSpan rss span  -- which contains our span+        , isHole $ occName hole  -- and the span is a hole+        -> flip evalState 0 $ buildTopLevelHypothesis name ps+      _ -> mempty+  ) tcs+++------------------------------------------------------------------------------+-- | Construct a hypothesis given the patterns from the left side of a HsMatch.+-- These correspond to things that the user put in scope before running+-- tactics.+buildTopLevelHypothesis+    :: OccName  -- ^ Function name+    -> [PatCompat GhcTc]+    -> State Int (Hypothesis CType)+buildTopLevelHypothesis name ps = do+  fmap mconcat $+    for (zip [0..] ps) $ \(ix, p) ->+      buildPatHy (TopLevelArgPrv name ix $ length ps) p+++------------------------------------------------------------------------------+-- | Construct a hypothesis for a single pattern, including building+-- sub-hypotheses for constructor pattern matches.+buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType)+buildPatHy prov (fromPatCompat -> p0) =+  case p0 of+    VarPat  _ x   -> pure $ mkIdHypothesis (unLoc x) prov+    LazyPat _ p   -> buildPatHy prov p+    AsPat   _ x p -> do+      hy' <- buildPatHy prov p+      pure $ mkIdHypothesis (unLoc x) prov <> hy'+    ParPat  _ p   -> buildPatHy prov p+    BangPat _ p   -> buildPatHy prov p+    ViewPat _ _ p -> buildPatHy prov p+    -- Desugar lists into cons+    ListPat _ [] -> pure mempty+    ListPat x@(ListPatTc ty _) (p : ps) ->+      mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty]+        [ (0, p)+        , (1, toPatCompat $ ListPat x ps)+        ]+    -- Desugar tuples into an explicit constructor+    TuplePat tys pats boxity ->+      mkDerivedConHypothesis+        prov+        (RealDataCon $ tupleDataCon boxity $ length pats)+        tys+          $ zip [0.. ] pats+#if __GLASGOW_HASKELL__ >= 900+    ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} ->+#else+    ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} ->+#endif+      case f of+        PrefixCon l_pgt ->+          mkDerivedConHypothesis prov con args $ zip [0..] l_pgt+        InfixCon pgt pgt5 ->+          mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5]+        RecCon r ->+          mkDerivedRecordHypothesis prov con args r+    SigPat  _ p _ -> buildPatHy prov p+    _             -> pure mempty+++------------------------------------------------------------------------------+-- | Like 'mkDerivedConHypothesis', but for record patterns.+mkDerivedRecordHypothesis+    :: Provenance+    -> ConLike  -- ^ Destructing constructor+    -> [Type]   -- ^ Applied type variables+    -> HsRecFields GhcTc (PatCompat GhcTc)+    -> State Int (Hypothesis CType)+mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _)+  | Just rec_fields <- getRecordFields dc+  = do+    let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..]+    mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) ->+      ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ)+      , p+      )+mkDerivedRecordHypothesis _ _ _ _ =+  error "impossible! using record pattern on something that isn't a record"+++------------------------------------------------------------------------------+-- | Construct a fake variable name. Used to track the provenance of top-level+-- pattern matches which otherwise wouldn't have anything to attach their+-- 'TopLevelArgPrv' to.+mkFakeVar :: State Int OccName+mkFakeVar = do+  i <- get+  put $ i + 1+  pure $ mkVarOcc $ "_" <> show i+++------------------------------------------------------------------------------+-- | Construct a fake variable to attach the current 'Provenance' to, and then+-- build a sub-hypothesis for the pattern match.+mkDerivedConHypothesis+    :: Provenance+    -> ConLike                   -- ^ Destructing constructor+    -> [Type]                    -- ^ Applied type variables+    -> [(Int, PatCompat GhcTc)]  -- ^ Patterns, and their order in the data con+    -> State Int (Hypothesis CType)+mkDerivedConHypothesis prov dc args ps = do+  var <- mkFakeVar+  hy' <- fmap mconcat $+    for ps $ \(ix, p) -> do+      let prov' = PatternMatchPrv+               $ PatVal (Just var)+                        (S.singleton var <> provAncestryOf prov)+                        (Uniquely dc)+                        ix+      buildPatHy prov' p+  pure+    $ mappend hy'+    $ Hypothesis+    $ pure+    $ HyInfo var (DisallowedPrv AlreadyDestructed prov)+    $ CType+    -- TODO(sandy): This is the completely wrong type, but we don't have a good+    -- way to get the real one. It's probably OK though, since we're generating+    -- this term with a disallowed provenance, and it doesn't actually exist+    -- anyway.+    $ conLikeResTy dc args+++------------------------------------------------------------------------------+-- | Build a 'Hypothesis' given an 'Id'.+mkIdHypothesis :: Id -> Provenance -> Hypothesis CType+mkIdHypothesis (splitId -> (name, ty)) prov =+  Hypothesis $ pure $ HyInfo name prov ty+++------------------------------------------------------------------------------+-- | Is this hole immediately to the right of an equals sign --- and is there+-- no where clause attached to it?+--+-- It's important that there is no where clause because otherwise it gets+-- clobbered. See #2183 for an example.+--+-- This isn't a perfect check, and produces some ugly code. But it's much much+-- better than the alternative, which is to destructively modify the user's+-- AST.+isRhsHoleWithoutWhere+    :: Tracked age RealSrcSpan+    -> Tracked age TypecheckedSource+    -> Bool+isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) =+  everything (||) (mkQ False $ \case+      TopLevelRHS _ _+          (L (RealSrcSpan span _) _)+          (EmptyLocalBinds _) -> containsSpan rss span+      _                       -> False+    ) tcs+++ufmSeverity :: UserFacingMessage -> MessageType+ufmSeverity NotEnoughGas            = MtInfo+ufmSeverity TacticErrors            = MtError+ufmSeverity TimedOut                = MtInfo+ufmSeverity NothingToDo             = MtInfo+ufmSeverity (InfrastructureError _) = MtError+++mkShowMessageParams :: UserFacingMessage -> ShowMessageParams+mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm+++showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()+showLspMessage = sendNotification SWindowShowMessage+++-- This rule only exists for generating file diagnostics+-- so the RuleResult is empty+data WriteDiagnostics = WriteDiagnostics+    deriving (Eq, Show, Typeable, Generic)++instance Hashable WriteDiagnostics+instance NFData   WriteDiagnostics++type instance RuleResult WriteDiagnostics = ()++data GetMetaprograms = GetMetaprograms+    deriving (Eq, Show, Typeable, Generic)++instance Hashable GetMetaprograms+instance NFData   GetMetaprograms++type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)]++wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+wingmanRules recorder plId = do+  define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp ->+    usePropertyAction #hole_severity plId properties >>= \case+      Nothing -> pure (mempty, Just ())+      Just severity ->+        use GetParsedModule nfp >>= \case+          Nothing ->+            pure ([], Nothing)+          Just pm -> do+            let holes :: [Range]+                holes =+                  everything (<>)+                    (mkQ mempty $ \case+                      L span (HsVar _ (L _ name))+                        | isHole (occName name) ->+                            maybeToList $ srcSpanToRange span+#if __GLASGOW_HASKELL__ >= 900+                      L span (HsUnboundVar _ occ)+#else+                      L span (HsUnboundVar _ (TrueExprHole occ))+#endif+                        | isHole occ ->+                            maybeToList $ srcSpanToRange span+                      (_ :: LHsExpr GhcPs) -> mempty+                    ) $ pm_parsed_source pm+            pure+              ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes+              , Just ()+              )++  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do+    TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp+    let scrutinees = traverse (metaprogramQ . tcg_binds) tcg+    return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do+      case ss of+        RealSrcSpan r _ -> do+          rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r+          pure (rss', program)+        UnhelpfulSpan _ -> Nothing++  -- This persistent rule helps to avoid blocking HLS hover providers at startup+  -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other+  -- hover providers from being used to produce a response+  addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing)++  action $ do+    files <- getFilesOfInterestUntracked+    void $ uses WriteDiagnostics $ Map.keys files+++mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic+mkDiagnostic severity r =+  Diagnostic r+    (Just severity)+    (Just $ InR "hole")+    (Just "wingman")+    "Hole"+    (Just $ List [DtUnnecessary])+    Nothing+++------------------------------------------------------------------------------+-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'.+mkWorkspaceEdits+    :: DynFlags+    -> ClientCapabilities+    -> Uri+    -> Annotated ParsedSource+    -> Graft (Either String) ParsedSource+    -> Either UserFacingMessage WorkspaceEdit+mkWorkspaceEdits dflags ccs uri pm g = do+  let pm' = runIdentity $ transformA pm annotateMetaprograms+  let response = transform dflags ccs uri g pm'+   in first (InfrastructureError . T.pack) response+++------------------------------------------------------------------------------+-- | Add ExactPrint annotations to every metaprogram in the source tree.+-- Usually the ExactPrint module can do this for us, but we've enabled+-- QuasiQuotes, so the round-trip print/parse journey will crash.+annotateMetaprograms :: Data a => a -> Transform a+annotateMetaprograms = everywhereM $ mkM $ \case+  L ss (WingmanMetaprogram mp) -> do+    let x = L ss $ MetaprogramSyntax mp+    let anns = addAnnotationsForPretty [] x mempty+    modifyAnnsT $ mappend anns+    pure x+  (x :: LHsExpr GhcPs) -> pure x+++------------------------------------------------------------------------------+-- | Find the source of a tactic metaprogram at the given span.+getMetaprogramAtSpan+    :: Tracked age SrcSpan+    -> Tracked age TcGblEnv+    -> Maybe T.Text+getMetaprogramAtSpan (unTrack -> ss)+  = fmap snd+  . listToMaybe+  . metaprogramAtQ ss+  . tcg_binds+  . unTrack+
+ new/src/Wingman/LanguageServer/Metaprogram.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}++{-# LANGUAGE NoMonoLocalBinds  #-}+{-# LANGUAGE RankNTypes #-}++module Wingman.LanguageServer.Metaprogram+  ( hoverProvider+  ) where++import           Control.Applicative (empty)+import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.Maybe+import           Data.List (find)+import           Data.Maybe+import qualified Data.Text as T+import           Development.IDE (positionToRealSrcLoc, realSrcSpanToRange)+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Ide.Types+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.LanguageServer+import           Wingman.Metaprogramming.Parser (attempt_it)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Provide the "empty case completion" code lens+hoverProvider :: PluginMethodHandler IdeState TextDocumentHover+hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)+  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do+      let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos+          stale = unsafeRunStaleIdeFast "hoverProvider" state nfp++      cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId)+      liftIO $ fromMaybeT (Right Nothing) $ do+        holes <- stale GetMetaprograms++        fmap (Right . Just) $+          case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of+            Just (trss, program) -> do+              let tr_range = fmap realSrcSpanToRange trss+                  rsl = realSrcSpanStart $ unTrack trss+              HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg+              z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program+              pure $ Hover+                { _contents = HoverContents+                            $ MarkupContent MkMarkdown+                            $ either T.pack T.pack z+                , _range = Just $ unTrack tr_range+                }+            Nothing -> empty+hoverProvider _ _ _ = pure $ Right Nothing++fromMaybeT :: Functor m => a -> MaybeT m a -> m a+fromMaybeT def = fmap (fromMaybe def) . runMaybeT
+ new/src/Wingman/LanguageServer/TacticProviders.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Wingman.LanguageServer.TacticProviders+  ( commandProvider+  , commandTactic+  , TacticProviderData (..)+  ) where++import           Control.Monad+import           Data.Bool (bool)+import           Data.Coerce+import           Data.Maybe+import           Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+import           Development.IDE.GHC.Compat+import           Ide.Types hiding (Config)+import           Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..))+import           Prelude hiding (span)+import           Wingman.AbstractLSP.Types+import           Wingman.Auto+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons)+import           Wingman.Metaprogramming.Parser (parseMetaprogram)+import           Wingman.Tactics+import           Wingman.Types+++------------------------------------------------------------------------------+-- | A mapping from tactic commands to actual tactics for refinery.+commandTactic :: TacticCommand -> T.Text -> TacticsM ()+commandTactic Auto                   = const auto+commandTactic Intros                 = const intros+commandTactic IntroAndDestruct       = const introAndDestruct+commandTactic Destruct               = useNameFromHypothesis destruct . mkVarOcc . T.unpack+commandTactic DestructPun            = useNameFromHypothesis destructPun . mkVarOcc . T.unpack+commandTactic Homomorphism           = useNameFromHypothesis homo . mkVarOcc . T.unpack+commandTactic DestructLambdaCase     = const destructLambdaCase+commandTactic HomomorphismLambdaCase = const homoLambdaCase+commandTactic DestructAll            = const destructAll+commandTactic UseDataCon             = userSplit . mkVarOcc . T.unpack+commandTactic Refine                 = const refine+commandTactic BeginMetaprogram       = const metaprogram+commandTactic RunMetaprogram         = parseMetaprogram+++------------------------------------------------------------------------------+-- | The LSP kind+tacticKind :: TacticCommand -> T.Text+tacticKind Auto                   = "fillHole"+tacticKind Intros                 = "introduceLambda"+tacticKind IntroAndDestruct       = "introduceAndDestruct"+tacticKind Destruct               = "caseSplit"+tacticKind DestructPun            = "caseSplitPun"+tacticKind Homomorphism           = "homomorphicCaseSplit"+tacticKind DestructLambdaCase     = "lambdaCase"+tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase"+tacticKind DestructAll            = "splitFuncArgs"+tacticKind UseDataCon             = "useConstructor"+tacticKind Refine                 = "refine"+tacticKind BeginMetaprogram       = "beginMetaprogram"+tacticKind RunMetaprogram         = "runMetaprogram"+++------------------------------------------------------------------------------+-- | Whether or not this code action is preferred -- ostensibly refers to+-- whether or not we can bind it to a key in vs code?+tacticPreferred :: TacticCommand -> Bool+tacticPreferred Auto                   = True+tacticPreferred Intros                 = True+tacticPreferred IntroAndDestruct       = True+tacticPreferred Destruct               = True+tacticPreferred DestructPun            = False+tacticPreferred Homomorphism           = True+tacticPreferred DestructLambdaCase     = False+tacticPreferred HomomorphismLambdaCase = False+tacticPreferred DestructAll            = True+tacticPreferred UseDataCon             = True+tacticPreferred Refine                 = True+tacticPreferred BeginMetaprogram       = False+tacticPreferred RunMetaprogram         = True+++mkTacticKind :: TacticCommand -> CodeActionKind+mkTacticKind =+  CodeActionUnknown . mappend "refactor.wingman." . tacticKind+++------------------------------------------------------------------------------+-- | Mapping from tactic commands to their contextual providers. See 'provide',+-- 'filterGoalType' and 'filterBindingType' for the nitty gritty.+commandProvider :: TacticCommand -> TacticProvider+commandProvider Auto  =+  requireHoleSort (== Hole) $+  provide Auto ""+commandProvider Intros =+  requireHoleSort (== Hole) $+  filterGoalType isFunction $+    provide Intros ""+commandProvider IntroAndDestruct =+  requireHoleSort (== Hole) $+  filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $+    provide IntroAndDestruct ""+commandProvider Destruct =+  requireHoleSort (== Hole) $+  filterBindingType destructFilter $ \occ _ ->+    provide Destruct $ T.pack $ occNameString occ+commandProvider DestructPun =+  requireHoleSort (== Hole) $+    filterBindingType destructPunFilter $ \occ _ ->+      provide DestructPun $ T.pack $ occNameString occ+commandProvider Homomorphism =+  requireHoleSort (== Hole) $+  filterBindingType homoFilter $ \occ _ ->+    provide Homomorphism $ T.pack $ occNameString occ+commandProvider DestructLambdaCase =+  requireHoleSort (== Hole) $+  requireExtension LambdaCase $+    filterGoalType (isJust . lambdaCaseable) $+      provide DestructLambdaCase ""+commandProvider HomomorphismLambdaCase =+  requireHoleSort (== Hole) $+  requireExtension LambdaCase $+    filterGoalType (liftLambdaCase False homoFilter) $+      provide HomomorphismLambdaCase ""+commandProvider DestructAll =+  requireHoleSort (== Hole) $+    withJudgement $ \jdg ->+      case _jIsTopHole jdg && jHasBoundArgs jdg of+        True  -> provide DestructAll ""+        False -> mempty+commandProvider UseDataCon =+  requireHoleSort (== Hole) $+  withConfig $ \cfg ->+    filterTypeProjection+        ( guardLength (<= cfg_max_use_ctor_actions cfg)+        . maybe [] fst+        . tacticsGetDataCons+        ) $ \dcon ->+      provide UseDataCon+        . T.pack+        . occNameString+        . occName+        $ dataConName dcon+commandProvider Refine =+  requireHoleSort (== Hole) $+    provide Refine ""+commandProvider BeginMetaprogram =+  requireHoleSort (== Hole) $+    provide BeginMetaprogram ""+commandProvider RunMetaprogram =+  withMetaprogram $ \mp ->+    provide RunMetaprogram mp+++------------------------------------------------------------------------------+-- | Return an empty list if the given predicate doesn't hold over the length+guardLength :: (Int -> Bool) -> [a] -> [a]+guardLength f as = bool [] as $ f $ length as+++------------------------------------------------------------------------------+-- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS+-- UI.+type TacticProvider+     = TacticProviderData+    -> [(Metadata, T.Text)]+++data TacticProviderData = TacticProviderData+  { tpd_lspEnv :: LspEnv+  , tpd_jdg    :: Judgement+  , tpd_hole_sort :: HoleSort+  }+++requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider+requireHoleSort p tp tpd =+  case p $ tpd_hole_sort tpd of+    True  -> tp tpd+    False -> []++withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider+withMetaprogram tp tpd =+  case tpd_hole_sort tpd of+    Metaprogram mp -> tp mp tpd+    _ -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+requireExtension :: Extension -> TacticProvider -> TacticProvider+requireExtension ext tp tpd =+  case xopt ext $ le_dflags $ tpd_lspEnv tpd of+    True  -> tp tpd+    False -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider+filterGoalType p tp tpd =+  case p $ unCType $ jGoal $ tpd_jdg tpd of+    True  -> tp tpd+    False -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+withJudgement :: (Judgement -> TacticProvider) -> TacticProvider+withJudgement tp tpd = tp (tpd_jdg tpd) tpd+++------------------------------------------------------------------------------+-- | Multiply a 'TacticProvider' for each binding, making sure it appears only+-- when the given predicate holds over the goal and binding types.+filterBindingType+    :: (Type -> Type -> Bool)  -- ^ Goal and then binding types.+    -> (OccName -> Type -> TacticProvider)+    -> TacticProvider+filterBindingType p tp tpd =+  let jdg = tpd_jdg tpd+      hy  = jLocalHypothesis jdg+      g   = jGoal jdg+   in unHypothesis hy >>= \hi ->+        let ty = unCType $ hi_type hi+         in case p (unCType g) ty of+              True  -> tp (hi_name hi) ty tpd+              False -> []+++------------------------------------------------------------------------------+-- | Multiply a 'TacticProvider' by some feature projection out of the goal+-- type. Used e.g. to crete a code action for every data constructor.+filterTypeProjection+    :: (Type -> [a])  -- ^ Features of the goal to look into further+    -> (a -> TacticProvider)+    -> TacticProvider+filterTypeProjection p tp tpd =+  (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a ->+      tp a tpd+++------------------------------------------------------------------------------+-- | Get access to the 'Config' when building a 'TacticProvider'.+withConfig :: (Config -> TacticProvider) -> TacticProvider+withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd+++------------------------------------------------------------------------------+-- | Terminal constructor for providing context-sensitive tactics. Tactics+-- given by 'provide' are always available.+provide :: TacticCommand -> T.Text -> TacticProvider+provide tc name _ =+  pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name)+++------------------------------------------------------------------------------+-- | Construct a 'CommandId'+tcCommandId :: TacticCommand -> CommandId+tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command"+++------------------------------------------------------------------------------+-- | We should show homos only when the goal type is the same as the binding+-- type, and that both are usual algebraic types.+homoFilter :: Type -> Type -> Bool+homoFilter codomain domain =+  case uncoveredDataCons domain codomain of+    Just s -> S.null s+    _ -> False+++------------------------------------------------------------------------------+-- | Lift a function of (codomain, domain) over a lambda case.+liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r+liftLambdaCase nil f t =+  case tacticsSplitFunTy t of+    (_, _, arg : _, res) -> f res $ scaledThing arg+    _ -> nil++++------------------------------------------------------------------------------+-- | We should show destruct for bindings only when those bindings have usual+-- algebraic types.+destructFilter :: Type -> Type -> Bool+destructFilter _ (algebraicTyCon -> Just _) = True+destructFilter _ _ = False+++------------------------------------------------------------------------------+-- | We should show destruct punning for bindings only when those bindings have+-- usual algebraic types, and when any of their data constructors are records.+destructPunFilter :: Type -> Type -> Bool+destructPunFilter _ (algebraicTyCon -> Just tc) =+  not . all (null . dataConFieldLabels) $ tyConDataCons tc+destructPunFilter _ _ = False+++instance IsContinuationSort TacticCommand where+  toCommandId = tcCommandId+
+ new/src/Wingman/Machinery.hs view
@@ -0,0 +1,450 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE TupleSections #-}++module Wingman.Machinery where++import           Control.Applicative (empty)+import           Control.Concurrent.Chan.Unagi.NoBlocking (newChan, writeChan, OutChan, tryRead, tryReadChan)+import           Control.Lens ((<>~))+import           Control.Monad.Reader+import           Control.Monad.State.Class (gets, modify, MonadState)+import           Control.Monad.State.Strict (StateT (..), execStateT)+import           Control.Monad.Trans.Maybe+import           Data.Coerce+import           Data.Foldable+import           Data.Functor ((<&>))+import           Data.Generics (everything, gcount, mkQ)+import           Data.Generics.Product (field')+import           Data.List (sortBy)+import qualified Data.Map as M+import           Data.Maybe (mapMaybe, isNothing)+import           Data.Monoid (getSum)+import           Data.Ord (Down (..), comparing)+import qualified Data.Set as S+import           Data.Traversable (for)+import           Development.IDE.Core.Compile (lookupName)+import           Development.IDE.GHC.Compat hiding (isTopLevel, empty)+import           Refinery.Future+import           Refinery.ProofState+import           Refinery.Tactic+import           Refinery.Tactic.Internal+import           System.Timeout (timeout)+import           Wingman.Context (getInstance)+import           Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars, tryUnifyUnivarsButNotSkolemsMany)+import           Wingman.Judgements+import           Wingman.Simplify (simplify)+import           Wingman.Types++#if __GLASGOW_HASKELL__ < 900+import FunDeps (fd_eqs, improveFromInstEnv)+import Pair (unPair)+#else+import GHC.Tc.Instance.FunDeps (fd_eqs, improveFromInstEnv)+import GHC.Data.Pair (unPair)+#endif+++substCTy :: TCvSubst -> CType -> CType+substCTy subst = coerce . substTy subst . coerce+++getSubstForJudgement+    :: MonadState TacticState m+    => Judgement+    -> m TCvSubst+getSubstForJudgement j = do+  -- NOTE(sandy): It's OK to use mempty here, because coercions _can_ give us+  -- substitutions for skolems.+  let coercions = j_coercion j+  unifier <- gets ts_unifier+  pure $ unionTCvSubst unifier coercions++------------------------------------------------------------------------------+-- | Produce a subgoal that must be solved before we can solve the original+-- goal.+newSubgoal+    :: Judgement+    -> Rule+newSubgoal j = do+  ctx <- ask+  unifier <- getSubstForJudgement j+  subgoal+    $ normalizeJudgement ctx+    $ substJdg unifier+    $ unsetIsTopHole+    $ normalizeJudgement ctx j+++tacticToRule :: Judgement -> TacticsM () -> Rule+tacticToRule jdg (TacticT tt) = RuleT $ execStateT tt jdg >>= flip Subgoal Axiom+++consumeChan :: OutChan (Maybe a) -> IO [a]+consumeChan chan = do+  tryReadChan chan >>= tryRead >>= \case+    Nothing -> pure []+    Just (Just a) -> (a:) <$> consumeChan chan+    Just Nothing -> pure []+++------------------------------------------------------------------------------+-- | Attempt to generate a term of the right type using in-scope bindings, and+-- a given tactic.+runTactic+    :: Int          -- ^ Timeout+    -> Context+    -> Judgement+    -> TacticsM ()  -- ^ Tactic to use+    -> IO (Either [TacticError] RunTacticResults)+runTactic duration ctx jdg t = do+    let skolems = S.fromList+                $ foldMap (tyCoVarsOfTypeWellScoped . unCType)+                $ (:) (jGoal jdg)+                $ fmap hi_type+                $ toList+                $ hyByName+                $ jHypothesis jdg+        tacticState =+          defaultTacticState+            { ts_skolems = skolems+            }++    let stream = hoistListT (flip runReaderT ctx . unExtractM)+               $ runStreamingTacticT t jdg tacticState+    (in_proofs, out_proofs) <- newChan+    (in_errs, out_errs) <- newChan+    timed_out <-+      fmap isNothing $ timeout duration $ consume stream $ \case+        Left err -> writeChan in_errs $ Just err+        Right proof -> writeChan in_proofs $ Just proof+    writeChan in_proofs Nothing++    solns <- consumeChan out_proofs+    let sorted =+          flip sortBy solns $ comparing $ \(Proof ext _ holes) ->+            Down $ scoreSolution ext jdg $ fmap snd holes+    case sorted of+      ((Proof syn _ subgoals) : _) ->+        pure $ Right $+          RunTacticResults+            { rtr_trace    = syn_trace syn+            , rtr_extract  = simplify $ syn_val syn+            , rtr_subgoals = fmap snd subgoals+            , rtr_other_solns = reverse . fmap pf_extract $ sorted+            , rtr_jdg = jdg+            , rtr_ctx = ctx+            , rtr_timed_out = timed_out+            }+      _ -> fmap Left $ consumeChan out_errs+++tracePrim :: String -> Trace+tracePrim = flip rose []+++------------------------------------------------------------------------------+-- | Mark that a tactic used the given string in its extract derivation. Mainly+-- used for debugging the search when things go terribly wrong.+tracing+    :: Functor m+    => String+    -> TacticT jdg (Synthesized ext) err s m a+    -> TacticT jdg (Synthesized ext) err s m a+tracing s = mappingExtract (mapTrace $ rose s . pure)+++------------------------------------------------------------------------------+-- | Mark that a tactic performed recursion. Doing so incurs a small penalty in+-- the score.+markRecursion+    :: Functor m+    => TacticT jdg (Synthesized ext) err s m a+    -> TacticT jdg (Synthesized ext) err s m a+markRecursion = mappingExtract (field' @"syn_recursion_count" <>~ 1)+++------------------------------------------------------------------------------+-- | Map a function over the extract created by a tactic.+mappingExtract+    :: Functor m+    => (ext -> ext)+    -> TacticT jdg ext err s m a+    -> TacticT jdg ext err s m a+mappingExtract f (TacticT m)+  = TacticT $ StateT $ \jdg ->+      mapExtract id f $ runStateT m jdg+++------------------------------------------------------------------------------+-- | Given the results of running a tactic, score the solutions by+-- desirability.+--+-- NOTE: This function is completely unprincipled and was just hacked together+-- to produce the right test results.+scoreSolution+    :: Synthesized (LHsExpr GhcPs)+    -> Judgement+    -> [Judgement]+    -> ( Penalize Int  -- number of holes+       , Reward Bool   -- all bindings used+       , Penalize Int  -- unused top-level bindings+       , Penalize Int  -- number of introduced bindings+       , Reward Int    -- number used bindings+       , Penalize Int  -- number of recursive calls+       , Penalize Int  -- size of extract+       )+scoreSolution ext goal holes+  = ( Penalize $ length holes+    , Reward   $ S.null $ intro_vals S.\\ used_vals+    , Penalize $ S.size unused_top_vals+    , Penalize $ S.size intro_vals+    , Reward   $ S.size used_vals + length used_user_vals+    , Penalize $ getSum $ syn_recursion_count ext+    , Penalize $ solutionSize $ syn_val ext+    )+  where+    initial_scope = hyByName $ jEntireHypothesis goal+    intro_vals = M.keysSet $ hyByName $ syn_scoped ext+    used_vals = S.intersection intro_vals $ syn_used_vals ext+    used_user_vals = filter (isLocalHypothesis . hi_provenance)+                   $ mapMaybe (flip M.lookup initial_scope)+                   $ S.toList+                   $ syn_used_vals ext+    top_vals = S.fromList+             . fmap hi_name+             . filter (isTopLevel . hi_provenance)+             . unHypothesis+             $ syn_scoped ext+    unused_top_vals = top_vals S.\\ used_vals+++------------------------------------------------------------------------------+-- | Compute the number of 'LHsExpr' nodes; used as a rough metric for code+-- size.+solutionSize :: LHsExpr GhcPs -> Int+solutionSize = everything (+) $ gcount $ mkQ False $ \case+  (_ :: LHsExpr GhcPs) -> True+++newtype Penalize a = Penalize a+  deriving (Eq, Ord, Show) via (Down a)++newtype Reward a = Reward a+  deriving (Eq, Ord, Show) via a+++------------------------------------------------------------------------------+-- | Generate a unique unification variable.+newUnivar :: MonadState TacticState m => m Type+newUnivar = do+  freshTyvars $+    mkInfForAllTys [alphaTyVar] alphaTy+++------------------------------------------------------------------------------+-- | Attempt to unify two types.+unify :: CType -- ^ The goal type+      -> CType -- ^ The type we are trying unify the goal type with+      -> RuleM ()+unify goal inst = do+  skolems <- gets ts_skolems+  case tryUnifyUnivarsButNotSkolems skolems goal inst of+    Just subst ->+      modify $ updateSubst subst+    Nothing -> cut++------------------------------------------------------------------------------+-- | Get a substitution out of a theta's fundeps+learnFromFundeps+    :: ThetaType+    -> RuleM ()+learnFromFundeps theta = do+  inst_envs <- asks ctxInstEnvs+  skolems <- gets ts_skolems+  subst <- gets ts_unifier+  let theta' = substTheta subst theta+      fundeps = foldMap (foldMap fd_eqs . improveFromInstEnv inst_envs (\_ _ -> ())) theta'+  case tryUnifyUnivarsButNotSkolemsMany skolems $ fmap unPair fundeps of+    Just subst ->+      modify $ updateSubst subst+    Nothing -> cut+++cut :: RuleT jdg ext err s m a+cut = RuleT Empty+++------------------------------------------------------------------------------+-- | Attempt to unify two types.+canUnify+    :: MonadState TacticState m+    => CType -- ^ The goal type+    -> CType -- ^ The type we are trying unify the goal type with+    -> m Bool+canUnify goal inst = do+  skolems <- gets ts_skolems+  case tryUnifyUnivarsButNotSkolems skolems goal inst of+    Just _ -> pure True+    Nothing -> pure False+++------------------------------------------------------------------------------+-- | Prefer the first tactic to the second, if the bool is true. Otherwise, just run the second tactic.+--+-- This is useful when you have a clever pruning solution that isn't always+-- applicable.+attemptWhen :: TacticsM a -> TacticsM a -> Bool -> TacticsM a+attemptWhen _  t2 False = t2+attemptWhen t1 t2 True  = commit t1 t2+++------------------------------------------------------------------------------+-- | Run the given tactic iff the current hole contains no univars. Skolems and+-- already decided univars are OK though.+requireConcreteHole :: TacticsM a -> TacticsM a+requireConcreteHole m = do+  jdg     <- goal+  skolems <- gets ts_skolems+  let vars = S.fromList $ tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg+  case S.size $ vars S.\\ skolems of+    0 -> m+    _ -> failure TooPolymorphic+++------------------------------------------------------------------------------+-- | The 'try' that comes in refinery 0.3 causes unnecessary backtracking and+-- balloons the search space. This thing just tries it, but doesn't backtrack+-- if it fails.+--+-- NOTE(sandy): But there's a bug! Or at least, something not understood here.+-- Using this everywhere breaks te tests, and neither I nor TOTBWF are sure+-- why.  Prefer 'try' if you can, and only try this as a last resort.+--+-- TODO(sandy): Remove this when we upgrade to 0.4+try'+    :: Functor m+    => TacticT jdg ext err s m ()+    -> TacticT jdg ext err s m ()+try' t = commit t $ pure ()+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+exact :: HsExpr GhcPs -> TacticsM ()+exact = rule . const . pure . pure . noLoc++------------------------------------------------------------------------------+-- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to+-- look it up in the hypothesis.+useNameFromHypothesis :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a+useNameFromHypothesis f name = do+  hy <- jHypothesis <$> goal+  case M.lookup name $ hyByName hy of+    Just hi -> f hi+    Nothing -> failure $ NotInScope name++------------------------------------------------------------------------------+-- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to+-- look it up in the hypothesis.+useNameFromContext :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a+useNameFromContext f name = do+  lookupNameInContext name >>= \case+    Just ty -> f $ createImportedHyInfo name ty+    Nothing -> failure $ NotInScope name+++------------------------------------------------------------------------------+-- | Find the type of an 'OccName' that is defined in the current module.+lookupNameInContext :: MonadReader Context m => OccName -> m (Maybe CType)+lookupNameInContext name = do+  ctx <- asks ctxModuleFuncs+  pure $ case find ((== name) . fst) ctx of+    Just (_, ty) -> pure ty+    Nothing      -> empty+++getDefiningType+    :: TacticsM CType+getDefiningType = do+  calling_fun_name <- asks (fst . head . ctxDefiningFuncs)+  maybe+    (failure $ NotInScope calling_fun_name)+    pure+      =<< lookupNameInContext calling_fun_name+++------------------------------------------------------------------------------+-- | Build a 'HyInfo' for an imported term.+createImportedHyInfo :: OccName -> CType -> HyInfo CType+createImportedHyInfo on ty = HyInfo+  { hi_name = on+  , hi_provenance = ImportPrv+  , hi_type = ty+  }+++getTyThing+    :: OccName+    -> TacticsM (Maybe TyThing)+getTyThing occ = do+  ctx <- ask+  case lookupOccEnv (ctx_occEnv ctx) occ of+    Just (elt : _) -> do+      mvar <- lift+            $ ExtractM+            $ lift+            $ lookupName (ctx_hscEnv ctx)+            $ gre_name elt+      pure mvar+    _ -> pure Nothing+++------------------------------------------------------------------------------+-- | Like 'getTyThing' but specialized to classes.+knownClass :: OccName -> TacticsM (Maybe Class)+knownClass occ =+  getTyThing occ <&> \case+    Just (ATyCon tc) -> tyConClass_maybe tc+    _                -> Nothing+++------------------------------------------------------------------------------+-- | Like 'getInstance', but uses a class that it just looked up.+getKnownInstance :: OccName -> [Type] -> TacticsM (Maybe (Class, PredType))+getKnownInstance f tys = runMaybeT $ do+  cls <- MaybeT $ knownClass f+  MaybeT $ getInstance cls tys+++------------------------------------------------------------------------------+-- | Lookup the type of any 'OccName' that was imported. Necessarily done in+-- IO, so we only expose this functionality to the parser. Internal Haskell+-- code that wants to lookup terms should do it via 'KnownThings'.+getOccNameType+    :: OccName+    -> TacticsM Type+getOccNameType occ = do+  getTyThing occ >>= \case+    Just (AnId v) -> pure $ varType v+    _ -> failure $ NotInScope occ+++getCurrentDefinitions :: TacticsM [(OccName, CType)]+getCurrentDefinitions = do+  ctx_funcs <- asks ctxDefiningFuncs+  for ctx_funcs $ \res@(occ, _) ->+    pure . maybe res (occ,) =<< lookupNameInContext occ+++------------------------------------------------------------------------------+-- | Given two types, see if we can construct a homomorphism by mapping every+-- data constructor in the domain to the same in the codomain. This function+-- returns 'Just' when all the lookups succeeded, and a non-empty value if the+-- homomorphism *is not* possible.+uncoveredDataCons :: Type -> Type -> Maybe (S.Set (Uniquely DataCon))+uncoveredDataCons domain codomain = do+  (g_dcs, _) <- tacticsGetDataCons codomain+  (hi_dcs, _) <- tacticsGetDataCons domain+  pure $ S.fromList (coerce hi_dcs) S.\\ S.fromList (coerce g_dcs)+
+ new/src/Wingman/Metaprogramming/Lexer.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module Wingman.Metaprogramming.Lexer where++import           Control.Applicative+import           Control.Monad+import           Data.Foldable (asum)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Void+import           Development.IDE.GHC.Compat.Core (OccName, mkVarOcc)+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as L++type Parser = P.Parsec Void Text++++lineComment :: Parser ()+lineComment = L.skipLineComment "--"++blockComment :: Parser ()+blockComment = L.skipBlockComment "{-" "-}"++sc :: Parser ()+sc = L.space P.space1 lineComment blockComment++ichar :: Parser Char+ichar = P.alphaNumChar <|> P.char '_' <|> P.char '\''++symchar :: Parser Char+symchar = asum+  [ P.symbolChar+  , P.char '!'+  , P.char '#'+  , P.char '$'+  , P.char '%'+  , P.char '^'+  , P.char '&'+  , P.char '*'+  , P.char '-'+  , P.char '='+  , P.char '+'+  , P.char ':'+  , P.char '<'+  , P.char '>'+  , P.char ','+  , P.char '.'+  , P.char '/'+  , P.char '?'+  , P.char '~'+  , P.char '|'+  , P.char '\\'+  ]++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++symbol :: Text -> Parser Text+symbol = L.symbol sc++symbol_ :: Text -> Parser ()+symbol_ = void . symbol++brackets :: Parser a -> Parser a+brackets = P.between (symbol "[") (symbol "]")++braces :: Parser a -> Parser a+braces = P.between (symbol "{") (symbol "}")++parens :: Parser a -> Parser a+parens = P.between (symbol "(") (symbol ")")++identifier :: Text -> Parser ()+identifier i = lexeme (P.string i *> P.notFollowedBy ichar)++variable :: Parser OccName+variable = lexeme $ do+    c <- P.alphaNumChar <|> P.char '('+    fmap mkVarOcc $ case c of+      '(' -> do+        cs <- P.many symchar+        void $ P.char ')'+        pure cs+      _ -> do+        cs <- P.many ichar+        pure $ c : cs++name :: Parser Text+name = lexeme $ do+    c <- P.alphaNumChar+    cs <- P.many (ichar <|> P.char '-')+    pure $ T.pack (c:cs)++keyword :: Text -> Parser ()+keyword = identifier+
+ new/src/Wingman/Metaprogramming/Parser.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module Wingman.Metaprogramming.Parser where++import qualified Control.Monad.Combinators.Expr as P+import           Data.Either (fromRight)+import           Data.Functor+import           Data.Maybe (listToMaybe)+import qualified Data.Text as T+import           Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile)+import           Development.IDE.GHC.Compat.Util (unpackFS)+import           Refinery.Tactic (failure)+import qualified Refinery.Tactic as R+import qualified Text.Megaparsec as P+import           Wingman.Auto+import           Wingman.Machinery (useNameFromHypothesis, useNameFromContext, getCurrentDefinitions)+import           Wingman.Metaprogramming.Lexer+import           Wingman.Metaprogramming.Parser.Documentation+import           Wingman.Metaprogramming.ProofState (proofState, layout)+import           Wingman.Tactics+import           Wingman.Types+++nullary :: T.Text -> TacticsM () -> Parser (TacticsM ())+nullary name tac = identifier name $> tac+++unary_occ :: T.Text -> (OccName -> TacticsM ()) -> Parser (TacticsM ())+unary_occ name tac = tac <$> (identifier name *> variable)+++------------------------------------------------------------------------------+-- | Like 'unary_occ', but runs directly in the 'Parser' monad.+unary_occM :: T.Text -> (OccName -> Parser (TacticsM ())) -> Parser (TacticsM ())+unary_occM name tac = tac =<< (identifier name *> variable)+++variadic_occ :: T.Text -> ([OccName] -> TacticsM ()) -> Parser (TacticsM ())+variadic_occ name tac = tac <$> (identifier name *> P.many variable)+++commands :: [SomeMetaprogramCommand]+commands =+  [ command "assumption" Nondeterministic Nullary+      "Use any term in the hypothesis that can unify with the current goal."+      (pure assumption)+      [ Example+          Nothing+          []+          [EHI "some_a_val" "a"]+          (Just "a")+          "some_a_val"+      ]++  , command "assume" Deterministic (Ref One)+      "Use the given term from the hypothesis, unifying it with the current goal"+      (pure . assume)+      [ Example+          Nothing+          ["some_a_val"]+          [EHI "some_a_val" "a"]+          (Just "a")+          "some_a_val"+      ]++  , command "intros" Deterministic (Bind Many)+      ( mconcat+          [ "Construct a lambda expression, using the specific names if given, "+          , "generating unique names otherwise. When no arguments are given, "+          , "all of the function arguments will be bound; otherwise, this "+          , "tactic will bind only enough to saturate the given names. Extra "+          , "names are ignored."+          ])+      (pure . \case+        []    -> intros+        names -> intros' $ IntroduceOnlyNamed names+      )+      [ Example+          Nothing+          []+          []+          (Just "a -> b -> c -> d")+          "\\a b c -> (_ :: d)"+      , Example+          Nothing+          ["aye"]+          []+          (Just "a -> b -> c -> d")+          "\\aye -> (_ :: b -> c -> d)"+      , Example+          Nothing+          ["x", "y", "z", "w"]+          []+          (Just "a -> b -> c -> d")+          "\\x y z -> (_ :: d)"+      ]++  , command "idiom" Deterministic Tactic+      "Lift a tactic into idiom brackets."+      (pure . idiom)+      [ Example+          Nothing+          ["(apply f)"]+          [EHI "f" "a -> b -> Int"]+          (Just "Maybe Int")+          "f <$> (_ :: Maybe a) <*> (_ :: Maybe b)"+      ]++  , command "intro" Deterministic (Bind One)+      "Construct a lambda expression, binding an argument with the given name."+      (pure . intros' . IntroduceOnlyNamed . pure)+      [ Example+          Nothing+          ["aye"]+          []+          (Just "a -> b -> c -> d")+          "\\aye -> (_ :: b -> c -> d)"+      ]++  , command "destruct_all" Deterministic Nullary+      "Pattern match on every function paramater, in original binding order."+      (pure destructAll)+      [ Example+          (Just "Assume `a` and `b` were bound via `f a b = _`.")+          []+          [EHI "a" "Bool", EHI "b" "Maybe Int"]+          Nothing $+          T.pack $ init $ unlines+            [ "case a of"+            , "  False -> case b of"+            , "    Nothing -> _"+            , "    Just i -> _"+            , "  True -> case b of"+            , "    Nothing -> _"+            , "    Just i -> _"+            ]+      ]++  , command "destruct" Deterministic (Ref One)+      "Pattern match on the argument."+      (pure . useNameFromHypothesis destruct)+      [ Example+          Nothing+          ["a"]+          [EHI "a" "Bool"]+          Nothing $+          T.pack $ init $ unlines+            [ "case a of"+            , "  False -> _"+            , "  True -> _"+            ]+      ]++  , command "homo" Deterministic (Ref One)+      ( mconcat+        [ "Pattern match on the argument, and fill the resulting hole in with "+        , "the same data constructor."+        ])+      (pure . useNameFromHypothesis homo)+      [ Example+          (Just $ mconcat+            [ "Only applicable when the type constructor of the argument is "+            , "the same as that of the hole."+            ])+          ["e"]+          [EHI "e" "Either a b"]+          (Just "Either x y") $+          T.pack $ init $ unlines+            [ "case e of"+            , "  Left a -> Left (_ :: x)"+            , "  Right b -> Right (_ :: y)"+            ]+      ]++  , command "application" Nondeterministic Nullary+      "Apply any function in the hypothesis that returns the correct type."+      (pure application)+      [ Example+          Nothing+          []+          [EHI "f" "a -> b"]+          (Just "b")+          "f (_ :: a)"+      ]++  , command "pointwise" Deterministic Tactic+      "Restrict the hypothesis in the holes of the given tactic to align up with the top-level bindings. This will ensure, eg, that the first hole can see only terms that came from the first position in any terms destructed from the top-level bindings."+      (pure . flip restrictPositionForApplication (pure ()))+      [ Example+          (Just "In the context of `f (a1, b1) (a2, b2) = _`. The resulting first hole can see only 'a1' and 'a2', and the second, only 'b1' and 'b2'.")+          ["(use mappend)"]+          []+          Nothing+          "mappend _ _"+      ]++  , command "apply" Deterministic (Ref One)+      "Apply the given function from *local* scope."+      (pure . useNameFromHypothesis (apply Saturated))+      [ Example+          Nothing+          ["f"]+          [EHI "f" "a -> b"]+          (Just "b")+          "f (_ :: a)"+      ]++  , command "split" Nondeterministic Nullary+      "Produce a data constructor for the current goal."+      (pure split)+      [ Example+          Nothing+          []+          []+          (Just "Either a b")+          "Right (_ :: b)"+      ]++  , command "ctor" Deterministic (Ref One)+      "Use the given data cosntructor."+      (pure . userSplit)+      [ Example+          Nothing+          ["Just"]+          []+          (Just "Maybe a")+          "Just (_ :: a)"+      ]++  , command "obvious" Nondeterministic Nullary+      "Produce a nullary data constructor for the current goal."+      (pure obvious)+      [ Example+          Nothing+          []+          []+          (Just "[a]")+          "[]"+      ]++  , command "auto" Nondeterministic Nullary+      ( mconcat+          [ "Repeatedly attempt to split, destruct, apply functions, and "+          , "recurse in an attempt to fill the hole."+          ])+      (pure auto)+      [ Example+          Nothing+          []+          [EHI "f" "a -> b", EHI "g" "b -> c"]+          (Just "a -> c")+          "g . f"+      ]++  , command "sorry" Deterministic Nullary+      "\"Solve\" the goal by leaving a hole."+      (pure sorry)+      [ Example+          Nothing+          []+          []+          (Just "b")+          "_ :: b"+      ]++  , command "unary" Deterministic Nullary+      ( mconcat+        [ "Produce a hole for a single-parameter function, as well as a hole for "+        , "its argument. The argument holes are completely unconstrained, and "+        , "will be solved before the function."+        ])+      (pure $ nary 1)+      [ Example+          (Just $ mconcat+            [ "In the example below, the variable `a` is free, and will unify "+            , "to the resulting extract from any subsequent tactic."+            ])+          []+          []+          (Just "Int")+          "(_2 :: a -> Int) (_1 :: a)"+      ]++  , command "binary" Deterministic Nullary+      ( mconcat+        [ "Produce a hole for a two-parameter function, as well as holes for "+        , "its arguments. The argument holes have the same type but are "+        , "otherwise unconstrained, and will be solved before the function."+        ])+      (pure $ nary 2)+      [ Example+          (Just $ mconcat+            [ "In the example below, the variable `a` is free, and will unify "+            , "to the resulting extract from any subsequent tactic."+            ])+          []+          []+          (Just "Int")+          "(_3 :: a -> a -> Int) (_1 :: a) (_2 :: a)"+      ]++  , command "recursion" Deterministic Nullary+      "Fill the current hole with a call to the defining function."+      ( pure $+          fmap listToMaybe getCurrentDefinitions >>= \case+            Just (self, _) -> useNameFromContext (apply Saturated) self+            Nothing -> failure $ TacticPanic "no defining function"+      )+      [ Example+          (Just "In the context of `foo (a :: Int) (b :: b) = _`:")+          []+          []+          Nothing+          "foo (_ :: Int) (_ :: b)"+      ]++  , command "use" Deterministic (Ref One)+      "Apply the given function from *module* scope."+      (pure . use Saturated)+      [ Example+          (Just "`import Data.Char (isSpace)`")+          ["isSpace"]+          []+          (Just "Bool")+          "isSpace (_ :: Char)"+      ]++  , command "cata" Deterministic (Ref One)+      "Destruct the given term, recursing on every resulting binding."+      (pure . useNameFromHypothesis cata)+      [ Example+          (Just "Assume we're called in the context of a function `f.`")+          ["x"]+          [EHI "x" "(a, a)"]+          Nothing $+          T.pack $ init $ unlines+            [ "case x of"+            , "  (a1, a2) ->"+            , "    let a1_c = f a1"+            , "        a2_c = f a2"+            , "     in _"+            ]+      ]++  , command "collapse" Deterministic Nullary+      "Collapse every term in scope with the same type as the goal."+      (pure collapse)+      [ Example+          Nothing+          []+          [ EHI "a1" "a"+          , EHI "a2" "a"+          , EHI "a3" "a"+          ]+          (Just "a")+          "(_ :: a -> a -> a -> a) a1 a2 a3"+      ]++  , command "let" Deterministic (Bind Many)+      "Create let-bindings for each binder given to this tactic."+      (pure . letBind)+      [ Example+          Nothing+          ["a", "b", "c"]+          [ ]+          (Just "x")+          $ T.pack $ unlines+            [ "let a = _1 :: a"+            , "    b = _2 :: b"+            , "    c = _3 :: c"+            , " in (_4 :: x)"+            ]+      ]++  , command "try" Nondeterministic Tactic+      "Simultaneously run and do not run a tactic. Subsequent tactics will bind on both states."+      (pure . R.try)+      [ Example+          Nothing+          ["(apply f)"]+          [ EHI "f" "a -> b"+          ]+          (Just "b")+          $ T.pack $ unlines+            [ "-- BOTH of:\n"+            , "f (_ :: a)"+            , "\n-- and\n"+            , "_ :: b"+            ]+      ]++  , command "nested" Nondeterministic (Ref One)+      "Nest the given function (in module scope) with itself arbitrarily many times. NOTE: The resulting function is necessarily unsaturated, so you will likely need `with_arg` to use this tactic in a saturated context."+      (pure . nested)+      [ Example+          Nothing+          ["fmap"]+          []+          (Just "[(Int, Either Bool a)] -> [(Int, Either Bool b)]")+          "fmap (fmap (fmap _))"+      ]++  , command "with_arg" Deterministic Nullary+      "Fill the current goal with a function application. This can be useful when you'd like to fill in the argument before the function, or when you'd like to use a non-saturated function in a saturated context."+      (pure with_arg)+      [ Example+          (Just "Where `a` is a new unifiable type variable.")+          []+          []+          (Just "r")+          "(_2 :: a -> r) (_1 :: a)"+      ]+  ]++++oneTactic :: Parser (TacticsM ())+oneTactic =+  P.choice+    [ parens tactic+    , makeParser commands+    ]+++tactic :: Parser (TacticsM ())+tactic = P.makeExprParser oneTactic operators++operators :: [[P.Operator Parser (TacticsM ())]]+operators =+    [ [ P.InfixR (symbol "|"   $> (R.<%>) )]+    , [ P.InfixL (symbol ";"   $> (>>))+      , P.InfixL (symbol ","   $> bindOne)+      ]+    ]+++tacticProgram :: Parser (TacticsM ())+tacticProgram = do+  sc+  r <- tactic P.<|> pure (pure ())+  P.eof+  pure r+++wrapError :: String -> String+wrapError err = "```\n" <> err <> "\n```\n"+++fixErrorOffset :: RealSrcLoc -> P.ParseErrorBundle a b -> P.ParseErrorBundle a b+fixErrorOffset rsl (P.ParseErrorBundle ne (P.PosState a n (P.SourcePos _ line col) pos s))+  = P.ParseErrorBundle ne+  $ P.PosState a n+      (P.SourcePos+        (unpackFS $ srcLocFile rsl)+        ((<>) line $ P.mkPos $ srcLocLine rsl - 1)+        ((<>) col  $ P.mkPos $ srcLocCol  rsl - 1 + length @[] "[wingman|")+      )+      pos+      s++------------------------------------------------------------------------------+-- | Attempt to run a metaprogram tactic, returning the proof state, or the+-- errors.+attempt_it+    :: RealSrcLoc+    -> Context+    -> Judgement+    -> String+    -> IO (Either String String)+attempt_it rsl ctx jdg program =+  case P.runParser tacticProgram "<splice>" (T.pack program) of+    Left peb -> pure $ Left $ wrapError $ P.errorBundlePretty $ fixErrorOffset rsl peb+    Right tt -> do+      res <- runTactic 2e6 ctx jdg tt+      pure $ case res of+          Left tes -> Left $ wrapError $ show tes+          Right rtr -> Right+                     $ layout (cfg_proofstate_styling $ ctxConfig ctx)+                     $ proofState rtr+++parseMetaprogram :: T.Text -> TacticsM ()+parseMetaprogram+    = fromRight (pure ())+    . P.runParser tacticProgram "<splice>"+++------------------------------------------------------------------------------+-- | Automatically generate the metaprogram command reference.+writeDocumentation :: IO ()+writeDocumentation =+  writeFile "COMMANDS.md" $+    unlines+      [ "# Wingman Metaprogram Command Reference"+      , ""+      , prettyReadme commands+      ]+
+ new/src/Wingman/Metaprogramming/Parser.hs-boot view
@@ -0,0 +1,7 @@+module Wingman.Metaprogramming.Parser where++import Wingman.Metaprogramming.Lexer+import Wingman.Types++tactic :: Parser (TacticsM ())+
+ new/src/Wingman/Metaprogramming/Parser/Documentation.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++module Wingman.Metaprogramming.Parser.Documentation where++import           Data.Functor ((<&>))+import           Data.List (sortOn)+import           Data.String (IsString)+import           Data.Text (Text)+import           Data.Text.Prettyprint.Doc hiding (parens)+import           Data.Text.Prettyprint.Doc.Render.String (renderString)+import           Development.IDE.GHC.Compat (OccName)+import qualified Text.Megaparsec as P+import           Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens)+import           Wingman.Types (TacticsM)++import {-# SOURCE #-} Wingman.Metaprogramming.Parser (tactic)+++------------------------------------------------------------------------------+-- | Is a tactic deterministic or not?+data Determinism+  = Deterministic+  | Nondeterministic++prettyDeterminism :: Determinism -> Doc b+prettyDeterminism Deterministic = "deterministic"+prettyDeterminism Nondeterministic = "non-deterministic"+++------------------------------------------------------------------------------+-- | How many arguments does the tactic take?+data Count a where+  One  :: Count OccName+  Many :: Count [OccName]++prettyCount :: Count a -> Doc b+prettyCount One  = "single"+prettyCount Many = "variadic"+++------------------------------------------------------------------------------+-- | What sorts of arguments does the tactic take? Currently there is no+-- distinction between 'Ref' and 'Bind', other than documentation.+--+-- The type index here is used for the shape of the function the parser should+-- take.+data Syntax a where+  Nullary :: Syntax (Parser (TacticsM ()))+  Ref     :: Count a -> Syntax (a -> Parser (TacticsM ()))+  Bind    :: Count a -> Syntax (a -> Parser (TacticsM ()))+  Tactic  :: Syntax (TacticsM () -> Parser (TacticsM ()))++prettySyntax :: Syntax a -> Doc b+prettySyntax Nullary   = "none"+prettySyntax (Ref co)  = prettyCount co <+> "reference"+prettySyntax (Bind co) = prettyCount co <+> "binding"+prettySyntax Tactic    = "tactic"+++------------------------------------------------------------------------------+-- | An example for the documentation.+data Example = Example+  { ex_ctx    :: Maybe Text         -- ^ Specific context information about when the tactic is applicable+  , ex_args   :: [Var]              -- ^ Arguments the tactic was called with+  , ex_hyp    :: [ExampleHyInfo]    -- ^ The hypothesis+  , ex_goal   :: Maybe ExampleType  -- ^ Current goal. Nothing indicates it's uninteresting.+  , ex_result :: Text               -- ^ Resulting extract.+  }+++------------------------------------------------------------------------------+-- | An example 'HyInfo'.+data ExampleHyInfo = EHI+  { ehi_name :: Var          -- ^ Name of the variable+  , ehi_type :: ExampleType  -- ^ Type of the variable+  }+++------------------------------------------------------------------------------+-- | A variable+newtype Var = Var+  { getVar :: Text+  }+  deriving newtype (IsString, Pretty)+++------------------------------------------------------------------------------+-- | A type+newtype ExampleType = ExampleType+  { getExampleType :: Text+  }+  deriving newtype (IsString, Pretty)+++------------------------------------------------------------------------------+-- | A command to expose to the parser+data MetaprogramCommand a = MC+  { mpc_name        :: Text         -- ^ Name of the command. This is the token necessary to run the command.+  , mpc_syntax      :: Syntax a     -- ^ The command's arguments+  , mpc_det         :: Determinism  -- ^ Determinism of the command+  , mpc_description :: Text         -- ^ User-facing description+  , mpc_tactic      :: a            -- ^ Tactic to run+  , mpc_examples    :: [Example]    -- ^ Collection of documentation examples+  }++------------------------------------------------------------------------------+-- | Existentialize the pain away+data SomeMetaprogramCommand where+  SMC :: MetaprogramCommand a -> SomeMetaprogramCommand+++------------------------------------------------------------------------------+-- | Run the 'Parser' of a 'MetaprogramCommand'+makeMPParser :: MetaprogramCommand a -> Parser (TacticsM ())+makeMPParser (MC name Nullary _ _ t _) = do+  identifier name+  t+makeMPParser (MC name (Ref One) _ _ t _) = do+  identifier name+  variable >>= t+makeMPParser (MC name (Ref Many) _ _ t _) = do+  identifier name+  P.many variable >>= t+makeMPParser (MC name (Bind One) _ _ t _) = do+  identifier name+  variable >>= t+makeMPParser (MC name (Bind Many) _ _ t _) = do+  identifier name+  P.many variable >>= t+makeMPParser (MC name Tactic _ _ t _) = do+  identifier name+  parens tactic >>= t+++------------------------------------------------------------------------------+-- | Compile a collection of metaprogram commands into a parser.+makeParser :: [SomeMetaprogramCommand] -> Parser (TacticsM ())+makeParser ps = P.choice $ ps <&> \(SMC mp) -> makeMPParser mp+++------------------------------------------------------------------------------+-- | Pretty print a command.+prettyCommand :: MetaprogramCommand a -> Doc b+prettyCommand (MC name syn det desc _ exs) = vsep+  [ "##" <+> pretty name+  , mempty+  , "arguments:" <+> prettySyntax syn <> ".  "+  , prettyDeterminism det <> "."+  , mempty+  , ">" <+> align (pretty desc)+  , mempty+  , vsep $ fmap (prettyExample name) exs+  , mempty+  ]+++------------------------------------------------------------------------------+-- | Pretty print a hypothesis.+prettyHyInfo :: ExampleHyInfo -> Doc a+prettyHyInfo hi = pretty (ehi_name hi) <+> "::" <+> pretty (ehi_type hi)+++------------------------------------------------------------------------------+-- | Append the given term only if the first argument has elements.+mappendIfNotNull :: [a] -> a -> [a]+mappendIfNotNull [] _ = []+mappendIfNotNull as a = as <> [a]+++------------------------------------------------------------------------------+-- | Pretty print an example.+prettyExample :: Text -> Example -> Doc a+prettyExample name (Example m_txt args hys goal res) =+  align $ vsep+    [ mempty+    , "### Example"+    , maybe mempty ((line <>) . (<> line) . (">" <+>) . align . pretty) m_txt+    , "Given:"+    , mempty+    , codeFence $ vsep+        $ mappendIfNotNull (fmap prettyHyInfo hys) mempty+           <> [ "_" <+> maybe mempty (("::" <+>). pretty) goal+              ]+    , mempty+    , hsep+        [ "running "+        , enclose "`" "`" $ pretty name <> hsep (mempty : fmap pretty args)+        , "will produce:"+        ]+    , mempty+    , codeFence $ align $ pretty res+    ]+++------------------------------------------------------------------------------+-- | Make a haskell code fence.+codeFence :: Doc a -> Doc a+codeFence d = align $ vsep+  [ "```haskell"+  , d+  , "```"+  ]+++------------------------------------------------------------------------------+-- | Render all of the commands.+prettyReadme :: [SomeMetaprogramCommand] -> String+prettyReadme+  = renderString+  . layoutPretty defaultLayoutOptions+  . vsep+  . fmap (\case SMC c -> prettyCommand c)+  . sortOn (\case SMC c -> mpc_name c)++++------------------------------------------------------------------------------+-- | Helper function to build a 'SomeMetaprogramCommand'.+command+    :: Text+    -> Determinism+    -> Syntax a+    -> Text+    -> a+    -> [Example]+    -> SomeMetaprogramCommand+command txt det syn txt' a exs = SMC $+  MC+    { mpc_name        = txt+    , mpc_det         = det+    , mpc_syntax      = syn+    , mpc_description = txt'+    , mpc_tactic      = a+    , mpc_examples    = exs+    }+
+ new/src/Wingman/Metaprogramming/ProofState.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++module Wingman.Metaprogramming.ProofState where++import           Data.Bool (bool)+import           Data.Functor ((<&>))+import qualified Data.Text as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Util.Panic+import           Language.LSP.Types (sectionSeparator)+import           Wingman.Judgements (jHypothesis)+import           Wingman.Types++renderSimplyDecorated+    :: Monoid out+    => (T.Text -> out) -- ^ Render plain 'Text'+    -> (ann -> out)  -- ^ How to render an annotation+    -> (ann -> out)  -- ^ How to render the removed annotation+    -> SimpleDocStream ann+    -> out+renderSimplyDecorated text push pop = go []+  where+    go _        SFail               = panicUncaughtFail+    go []       SEmpty              = mempty+    go (_:_)    SEmpty              = panicInputNotFullyConsumed+    go st       (SChar c rest)      = text (T.singleton c) <> go st rest+    go st       (SText _l t rest)   = text t <> go st rest+    go st       (SLine i rest)      =+      text (T.singleton '\n') <> text (textSpaces i) <> go st rest+    go st       (SAnnPush ann rest) = push ann <> go (ann : st) rest+    go (ann:st) (SAnnPop rest)      = pop ann <> go st rest+    go []       SAnnPop{}           = panicUnpairedPop+{-# INLINE renderSimplyDecorated #-}+++data Ann+  = Goal+  | Hypoth+  | Status+  deriving (Eq, Ord, Show, Enum, Bounded)++forceMarkdownNewlines :: String -> String+forceMarkdownNewlines = unlines . fmap (<> "  ") . lines++layout :: Bool -> Doc Ann -> String+layout use_styling+  = forceMarkdownNewlines+  . T.unpack+  . renderSimplyDecorated id+    (renderAnn use_styling)+    (renderUnann use_styling)+  . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.6)++renderAnn :: Bool -> Ann -> T.Text+renderAnn False _ = ""+renderAnn _ Goal = "<span style='color:#ef4026;'>"+renderAnn _ Hypoth = "```haskell\n"+renderAnn _ Status = "<span style='color:#6495ED;'>"++renderUnann :: Bool -> Ann -> T.Text+renderUnann False _ = ""+renderUnann _ Goal = "</span>"+renderUnann _ Hypoth = "\n```\n"+renderUnann _ Status = "</span>"++proofState :: RunTacticResults -> Doc Ann+proofState RunTacticResults{rtr_subgoals} =+  vsep+    $ ( annotate Status+      . countFinished "goals accomplished 🎉" "goal"+      $ length rtr_subgoals+      )+    : pretty sectionSeparator+    : fmap prettySubgoal rtr_subgoals+++prettySubgoal :: Judgement -> Doc Ann+prettySubgoal jdg =+  vsep $+    [ mempty | has_hy] <>+    [ annotate Hypoth $ prettyHypothesis hy | has_hy] <>+    [ "⊢" <+> annotate Goal (prettyType (_jGoal jdg))+    , pretty sectionSeparator+    ]+  where+    hy = jHypothesis jdg+    has_hy = not $ null $ unHypothesis hy+++prettyHypothesis :: Hypothesis CType -> Doc Ann+prettyHypothesis hy =+  vsep $ unHypothesis hy <&> \hi ->+    prettyHyInfo hi++prettyHyInfo :: HyInfo CType -> Doc Ann+prettyHyInfo hi = viaShow (hi_name hi) <+> "::" <+> prettyType (hi_type hi)+++prettyType :: CType -> Doc Ann+prettyType (CType ty) = viaShow ty+++countFinished :: Doc Ann -> Doc Ann -> Int -> Doc Ann+countFinished finished _ 0 = finished+countFinished _ thing n    = count thing n++count :: Doc Ann -> Int -> Doc Ann+count thing n =+  pretty n <+> thing <> bool "" "s" (n /= 1)++textSpaces :: Int -> T.Text+textSpaces n = T.replicate n $ T.singleton ' '++
+ new/src/Wingman/Naming.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP #-}++module Wingman.Naming where++import           Control.Arrow+import           Control.Monad.State.Strict+import           Data.Aeson (camelTo2)+import           Data.Bool (bool)+import           Data.Char+import           Data.List (isPrefixOf)+import           Data.List.Extra (split)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe (listToMaybe, fromMaybe)+import           Data.Monoid+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat.Core hiding (IsFunction)+import           Text.Hyphenation (hyphenate, english_US)+import           Wingman.GHC (tcTyVar_maybe)++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++------------------------------------------------------------------------------+-- | A classification of a variable, for which we have specific naming rules.+-- A variable can have multiple purposes simultaneously.+data Purpose+  = Function [Type] Type+  | Predicate+  | Continuation+  | Integral+  | Number+  | String+  | List Type+  | Maybe Type+  | TyConned TyCon [Type]+    -- ^ Something of the form @TC a b c@+  | TyVarred TyVar [Type]+    -- ^ Something of the form @m a b c@++pattern IsPredicate :: Type+pattern IsPredicate <-+  (tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True))++pattern IsFunction :: [Type] -> Type -> Type+pattern IsFunction args res <-+  (first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res))++pattern IsString :: Type+pattern IsString <-+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True]))++pattern IsMaybe :: Type -> Type+pattern IsMaybe a <-+  (splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a]))++pattern IsList :: Type -> Type+pattern IsList a <-+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a]))++pattern IsTyConned :: TyCon -> [Type] -> Type+pattern IsTyConned tc args <-+  (splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args))++pattern IsTyVarred :: TyVar -> [Type] -> Type+pattern IsTyVarred v args <-+  (tcSplitAppTys -> (tcTyVar_maybe -> Just v, args))+++------------------------------------------------------------------------------+-- | Get the 'Purpose's of a type. A type can have multiple purposes+-- simultaneously, so the order of purposes in this function corresponds to the+-- precedence of that naming rule. Which means, eg, that if a type is both+-- a 'Predicate' and a 'Function', we should prefer to use the predicate naming+-- rules, since they come first.+getPurposes :: Type -> [Purpose]+getPurposes ty = mconcat+  [ [ Predicate         | IsPredicate         <- [ty] ]+  , [ Function args res | IsFunction args res <- [ty] ]+  , with (isIntegerTy ty) [ Integral, Number          ]+  , with (isIntTy ty)     [ Integral, Number          ]+  , [ Number            | isFloatingTy ty             ]+  , [ String            | isStringTy ty               ]+  , [ Maybe a           | IsMaybe a           <- [ty] ]+  , [ List a            | IsList a            <- [ty] ]+  , [ TyVarred v args   | IsTyVarred v args   <- [ty] ]+  , [ TyConned tc args  | IsTyConned tc args  <- [ty]+                        , not (isTupleTyCon tc)+                        , tc /= listTyCon             ]+  ]+++------------------------------------------------------------------------------+-- | Return 'mempty' if the give bool is false.+with :: Monoid a => Bool -> a -> a+with False _ = mempty+with True a = a+++------------------------------------------------------------------------------+-- | Names we can give functions+functionNames :: [String]+functionNames = ["f", "g", "h"]+++------------------------------------------------------------------------------+-- | Get a ranked ordering of names for a given purpose.+purposeToName :: Purpose -> [String]+purposeToName (Function args res)+  | Just tv_args <- traverse tcTyVar_maybe $ args <> pure res+  = fmap (<> foldMap (occNameString . occName) tv_args) functionNames+purposeToName (Function _ _) = functionNames+purposeToName Predicate = pure "p"+purposeToName Continuation = pure "k"+purposeToName Integral = ["n", "i", "j"]+purposeToName Number = ["x", "y", "z", "w"]+purposeToName String = ["s", "str"]+purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t+purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t+purposeToName (TyVarred tv args)+  | Just tv_args <- traverse tcTyVar_maybe args+  = pure $ foldMap (occNameString . occName) $ tv : tv_args+purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv+purposeToName (TyConned tc args@(_:_))+  | Just tv_args <- traverse tcTyVar_maybe args+  = [ mkTyConName tc+      -- We insert primes to everything later, but it gets the lowest+      -- precedence. Here we'd like to prefer it over the more specific type+      -- name.+    , mkTyConName tc <> "'"+    , mconcat+      [ mkTyConName tc+      , bool mempty "_" $ length (mkTyConName tc) > 1+      , foldMap (occNameString . occName) tv_args+      ]+    ]+purposeToName (TyConned tc _)+  = pure+  $ mkTyConName tc+++mkTyName :: Type -> [String]+mkTyName = purposeToName <=< getPurposes+++------------------------------------------------------------------------------+-- | Get a good name for a type constructor.+mkTyConName :: TyCon -> String+mkTyConName tc+  | tc == unitTyCon = "u"+  | isSymOcc occ+      = take 1+      . fmap toLower+      . filterReplace isSymbol      's'+      . filterReplace isPunctuation 'p'+      $ name+  | camels@(_:_:_) <- camelTerms name+      = foldMap (fmap toLower . take 1) camels+  | otherwise+      = getStem+      $ fmap toLower name+  where+    occ = getOccName tc+    name = occNameString occ+++------------------------------------------------------------------------------+-- | Split a string into its camel case components.+camelTerms :: String -> [String]+camelTerms = split (== '@') . camelTo2 '@'+++------------------------------------------------------------------------------+-- | A stem of a string is either a special-case shortened form, or a shortened+-- first syllable. If the string is one syllable, we take the full word if it's+-- short, or just the first two characters if it's long. Otherwise, just take+-- the first syllable.+--+-- NOTE: There's no rhyme or reason here, I just experimented until I got+-- results that were reasonably consistent with the names I would give things.+getStem :: String -> String+getStem str =+  let s = stem str+   in case (s == str, length str) of+        (False, _)             -> s+        (True, (<= 3) -> True) -> str+        _                      -> take 2 str++------------------------------------------------------------------------------+-- | Get a special-case stem, or, failing that, give back the first syllable.+stem :: String -> String+stem "char" = "c"+stem "function" = "func"+stem "bool" = "b"+stem "either" = "e"+stem "text" = "txt"+stem s = join $ take 1 $ hyphenate english_US s+++------------------------------------------------------------------------------+-- | Maybe replace an element in the list if the predicate matches+filterReplace :: (a -> Bool) -> a -> [a] -> [a]+filterReplace f r = fmap (\a -> bool a r $ f a)+++------------------------------------------------------------------------------+-- | Produce a unique, good name for a type.+mkGoodName+    :: Set OccName  -- ^ Bindings in scope; used to ensure we don't shadow anything+    -> Type       -- ^ The type to produce a name for+    -> OccName+mkGoodName in_scope (mkTyName -> tn)+  = mkVarOcc+  . fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn)+  . getFirst+  . foldMap (\n -> bool (pure n) mempty $ check n)+  $ tn <> fmap (<> "'") tn+  where+    check n = S.member (mkVarOcc n) $ illegalNames <> in_scope+++illegalNames :: Set OccName+illegalNames = S.fromList $ fmap mkVarOcc+  [ "case"+  , "of"+  , "class"+  , "data"+  , "do"+  , "type"+  , "if"+  , "then"+  , "else"+  , "let"+  , "in"+  , "mdo"+  , "newtype"+  , "proc"+  , "rec"+  , "where"+  ]++++------------------------------------------------------------------------------+-- | Given a desired name, compute a new name for it based on how many names in+-- scope conflict with it. Eg, if we want to name something @x@, but already+-- have @x@, @x'@ and @x2@ in scope, we will give back @x3@.+mkNumericSuffix :: Set OccName -> String -> String+mkNumericSuffix s nm =+  mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s+++------------------------------------------------------------------------------+-- | Like 'mkGoodName' but creates several apart names.+mkManyGoodNames+  :: (Traversable t)+  => Set OccName+  -> t Type+  -> t OccName+mkManyGoodNames in_scope args =+  flip evalState in_scope $ for args $ \at -> do+    in_scope <- get+    let n = mkGoodName in_scope at+    modify $ S.insert n+    pure n+++------------------------------------------------------------------------------+-- | Which names are in scope?+getInScope :: Map OccName a -> [OccName]+getInScope = M.keys+
+ new/src/Wingman/Plugin.hs view
@@ -0,0 +1,46 @@+-- | A plugin that uses tactics to synthesize code+module Wingman.Plugin where++import           Control.Monad+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Plugin.CodeAction+import qualified Development.IDE.GHC.ExactPrint                   as E+import           Ide.Types+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.AbstractLSP+import           Wingman.AbstractLSP.TacticActions (makeTacticInteraction)+import           Wingman.EmptyCase+import           Wingman.LanguageServer hiding (Log)+import qualified Wingman.LanguageServer as WingmanLanguageServer+import           Wingman.LanguageServer.Metaprogram (hoverProvider)+import           Wingman.StaticPlugin+import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))++data Log+  = LogWingmanLanguageServer WingmanLanguageServer.Log +  | LogExactPrint E.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogWingmanLanguageServer log -> pretty log+    LogExactPrint exactPrintLog -> pretty exactPrintLog++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId+  = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder)+  $ installInteractions+      ( emptyCaseInteraction+      : fmap makeTacticInteraction [minBound .. maxBound]+      )+  $ (defaultPluginDescriptor plId)+      { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider+      , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId+      , pluginConfigDescriptor =+          defaultConfigDescriptor+            { configCustomConfig = mkCustomConfig properties+            }+      , pluginModifyDynflags = staticPlugin+      }+
+ new/src/Wingman/Range.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}++module Wingman.Range where++import           Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan)+import           Development.IDE.GHC.Compat.Core+import           Development.IDE.GHC.Compat.Util as FS++++------------------------------------------------------------------------------+-- | Convert a DAML compiler Range to a GHC SrcSpan+-- TODO(sandy): this doesn't belong here+rangeToSrcSpan :: String -> Range -> SrcSpan+rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing+++rangeToRealSrcSpan :: String -> Range -> RealSrcSpan+rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) =+  mkRealSrcSpan+    (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ startLn + 1) (fromIntegral $ startCh + 1))+    (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ endLn + 1) (fromIntegral $ endCh + 1))
+ new/src/Wingman/Simplify.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++module Wingman.Simplify+  ( simplify+  ) where++import Data.Generics (GenericT, everywhere, mkT)+import Data.List.Extra (unsnoc)+import Data.Monoid (Endo (..))+import Development.IDE.GHC.Compat+import GHC.SourceGen (var)+import GHC.SourceGen.Expr (lambda)+import Wingman.CodeGen.Utils+import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet)+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs+pattern Lambda pats body <-+  HsLam _+    MG {mg_alts = L _ [L _+      Match { m_pats = fmap fromPatCompat -> pats+            , m_grhss = GRHSs {grhssGRHSs = [L _ (+                 GRHS _ [] (L _ body))]}+            }]+        }+  where+    -- If there are no patterns to bind, just stick in the body+    Lambda [] body   = body+    Lambda pats body = lambda pats body++++------------------------------------------------------------------------------+-- | Simplify an expression.+simplify :: LHsExpr GhcPs -> LHsExpr GhcPs+simplify+  = (!!3) -- Do three passes; this should be good enough for the limited+          -- amount of gas we give to auto+  . iterate (everywhere $ foldEndo+    [ simplifyEtaReduce+    , simplifyRemoveParens+    , simplifyCompose+    , simplifySingleLet+    ])+++------------------------------------------------------------------------------+-- | Like 'foldMap' but for endomorphisms.+foldEndo :: Foldable t => t (a -> a) -> a -> a+foldEndo = appEndo . foldMap Endo+++------------------------------------------------------------------------------+-- | Perform an eta reduction. For example, transforms @\x -> (f g) x@ into+-- @f g@.+simplifyEtaReduce :: GenericT+simplifyEtaReduce = mkT $ \case+  Lambda+      [VarPat _ (L _ pat)]+      (HsVar _ (L _ a)) | pat == a ->+    var "id"+  Lambda+      (unsnoc -> Just (pats, VarPat _ (L _ pat)))+      (HsApp _ (L _ f) (L _ (HsVar _ (L _ a))))+      | pat == a+        -- We can only perform this simplification if @pat@ is otherwise unused.+      , not (containsHsVar pat f) ->+    Lambda pats f+  x -> x++------------------------------------------------------------------------------+-- | Eliminates the unnecessary binding in @let a = b in a@+simplifySingleLet :: GenericT+simplifySingleLet = mkT $ \case+  SingleLet bind [] val (HsVar _ (L _ a)) | a == bind -> val+  x -> x+++------------------------------------------------------------------------------+-- | Perform an eta-reducing function composition. For example, transforms+-- @\x -> f (g (h x))@ into @f . g . h@.+simplifyCompose :: GenericT+simplifyCompose = mkT $ \case+  Lambda+      (unsnoc -> Just (pats, VarPat _ (L _ pat)))+      (unroll -> (fs@(_:_), HsVar _ (L _ a)))+      | pat == a+        -- We can only perform this simplification if @pat@ is otherwise unused.+      , not (containsHsVar pat fs) ->+    Lambda pats (foldr1 (infixCall ".") fs)+  x -> x+++------------------------------------------------------------------------------+-- | Removes unnecessary parentheses on any token that doesn't need them.+simplifyRemoveParens :: GenericT+simplifyRemoveParens = mkT $ \case+  HsPar _ (L _ x) | isAtomicHsExpr x -> x+  (x :: HsExpr GhcPs)                -> x+++------------------------------------------------------------------------------+-- | Unrolls a right-associative function application of the form+-- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@.+unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)+unroll (HsPar _ (L _ x)) = unroll x+unroll (HsApp _ (L _ f) (L _ a)) =+  let (fs, r) = unroll a+   in (f : fs, r)+unroll x = ([], x)+
+ new/src/Wingman/StaticPlugin.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}++module Wingman.StaticPlugin+  ( staticPlugin+  , metaprogramHoleName+  , enableQuasiQuotes+  , pattern WingmanMetaprogram+  , pattern MetaprogramSyntax+  ) where++import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util++import Ide.Types++import Data.Data+import Generics.SYB+#if __GLASGOW_HASKELL__ >= 900+import GHC.Driver.Plugins (purePlugin)+#else+import Plugins (purePlugin)+#endif++staticPlugin :: DynFlagsModifications+staticPlugin = mempty+  { dynFlagsModifyGlobal =+      \df -> allowEmptyCaseButWithWarning+           $ flip gopt_unset Opt_SortBySubsumHoleFits+           $ flip gopt_unset Opt_ShowValidHoleFits+           $ df+             { refLevelHoleFits = Just 0+             , maxRefHoleFits   = Just 0+             , maxValidHoleFits = Just 0+             , staticPlugins = staticPlugins df <> [metaprogrammingPlugin]+             }+  , dynFlagsModifyParser = enableQuasiQuotes+  }+++pattern MetaprogramSourceText :: SourceText+pattern MetaprogramSourceText = SourceText "wingman-meta-program"+++pattern WingmanMetaprogram :: FastString -> HsExpr p+pattern WingmanMetaprogram mp <-+#if __GLASGOW_HASKELL__ >= 900+  HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp))+      (L _ ( HsVar _ _))+#else+  HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)+      (L _ ( HsVar _ _))+#endif+++enableQuasiQuotes :: DynFlags -> DynFlags+enableQuasiQuotes = flip xopt_set QuasiQuotes+++-- | Wingman wants to support destructing of empty cases, but these are a parse+-- error by default. So we want to enable 'EmptyCase', but then that leads to+-- silent errors without 'Opt_WarnIncompletePatterns'.+allowEmptyCaseButWithWarning :: DynFlags -> DynFlags+allowEmptyCaseButWithWarning =+  flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns+++metaprogrammingPlugin :: StaticPlugin+metaprogrammingPlugin =+    StaticPlugin $ PluginWithArgs pluginDefinition  []+  where+    pluginDefinition = defaultPlugin+        { parsedResultAction = worker+        , pluginRecompile = purePlugin+        }+    worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule+    worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm }++mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs+mkMetaprogram ss mp =+#if __GLASGOW_HASKELL__ >= 900+  HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp))+#else+  HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)+#endif+    $ L ss+    $ HsVar noExtField+    $ L ss+    $ mkRdrUnqual metaprogramHoleName++addMetaprogrammingSyntax :: Data a => a -> a+addMetaprogrammingSyntax =+  everywhere $ mkT $ \case+    L ss (MetaprogramSyntax mp) ->+      L ss $ mkMetaprogram ss mp+    (x :: LHsExpr GhcPs) -> x++metaprogramHoleName :: OccName+metaprogramHoleName = mkVarOcc "_$metaprogram"++pattern MetaprogramSyntax :: FastString -> HsExpr GhcPs+pattern MetaprogramSyntax mp <-+    HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp)+  where+    MetaprogramSyntax mp =+      HsSpliceE noExtField $+        HsQuasiQuote+          noExtField+          (mkRdrUnqual $ mkVarOcc "splice")+          (mkRdrUnqual $ mkVarOcc "wingman")+          noSrcSpan+          mp
+ new/src/Wingman/Tactics.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Wingman.Tactics+  ( module Wingman.Tactics+  , runTactic+  ) where++import           Control.Applicative (Alternative(empty), (<|>))+import           Control.Lens ((&), (%~), (<>~))+import           Control.Monad (filterM, unless)+import           Control.Monad (when)+import           Control.Monad.Extra (anyM)+import           Control.Monad.Reader.Class (MonadReader (ask))+import           Control.Monad.State.Strict (StateT(..), runStateT, execStateT)+import           Data.Bool (bool)+import           Data.Foldable+import           Data.Functor ((<&>))+import           Data.Generics.Labels ()+import           Data.List+import           Data.List.Extra (dropEnd, takeEnd)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable (for)+import           Development.IDE.GHC.Compat hiding (empty)+import           GHC.Exts+import           GHC.SourceGen ((@@))+import           GHC.SourceGen.Expr+import           Refinery.Tactic+import           Refinery.Tactic.Internal+import           Wingman.CodeGen+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Machinery+import           Wingman.Naming+import           Wingman.StaticPlugin (pattern MetaprogramSyntax)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Use something in the hypothesis to fill the hole.+assumption :: TacticsM ()+assumption = attemptOn (S.toList . allNames) assume+++------------------------------------------------------------------------------+-- | Use something named in the hypothesis to fill the hole.+assume :: OccName -> TacticsM ()+assume name = rule $ \jdg -> do+  case M.lookup name $ hyByName $ jHypothesis jdg of+    Just (hi_type -> ty) -> do+      unify ty $ jGoal jdg+      pure $+        -- This slightly terrible construct is producing a mostly-empty+        -- 'Synthesized'; but there is no monoid instance to do something more+        -- reasonable for a default value.+        (pure (noLoc $ var' name))+          { syn_trace = tracePrim $ "assume " <> occNameString name+          , syn_used_vals = S.singleton name <> getAncestry jdg name+          }+    Nothing -> cut+++------------------------------------------------------------------------------+-- | Like 'apply', but uses an 'OccName' available in the context+-- or the module+use :: Saturation -> OccName -> TacticsM ()+use sat occ = do+  ctx <- ask+  ty <- case lookupNameInContext occ ctx of+    Just ty -> pure ty+    Nothing -> CType <$> getOccNameType occ+  apply sat $ createImportedHyInfo occ ty+++recursion :: TacticsM ()+-- TODO(sandy): This tactic doesn't fire for the @AutoThetaFix@ golden test,+-- presumably due to running afoul of 'requireConcreteHole'. Look into this!+recursion = requireConcreteHole $ tracing "recursion" $ do+  defs <- getCurrentDefinitions+  attemptOn (const defs) $ \(name, ty) -> markRecursion $ do+    jdg <- goal+    -- Peek allows us to look at the extract produced by this block.+    peek+      ( do+          let hy' = recursiveHypothesis defs+          ctx <- ask+          localTactic (apply Saturated $ HyInfo name RecursivePrv ty) (introduce ctx hy')+            <@> fmap (localTactic assumption . filterPosition name) [0..]+      ) $ \ext -> do+        let pat_vals = jPatHypothesis jdg+        -- Make sure that the recursive call contains at least one already-bound+        -- pattern value. This ensures it is structurally smaller, and thus+        -- suggests termination.+        case any (flip M.member pat_vals) $ syn_used_vals ext of+          True -> Nothing+          False -> Just UnhelpfulRecursion+++restrictPositionForApplication :: TacticsM () -> TacticsM () -> TacticsM ()+restrictPositionForApplication f app = do+  -- NOTE(sandy): Safe use of head; context is guaranteed to have a defining+  -- binding+  name <- head . fmap fst <$> getCurrentDefinitions+  f <@>+    fmap+      (localTactic app . filterPosition name) [0..]+++------------------------------------------------------------------------------+-- | Introduce a lambda binding every variable.+intros :: TacticsM ()+intros = intros' IntroduceAllUnnamed+++data IntroParams+  = IntroduceAllUnnamed+  | IntroduceOnlyNamed [OccName]+  | IntroduceOnlyUnnamed Int+  deriving stock (Eq, Ord, Show)+++------------------------------------------------------------------------------+-- | Introduce a lambda binding every variable.+intros'+    :: IntroParams+    -> TacticsM ()+intros' params = rule $ \jdg -> do+  let g  = jGoal jdg+  case tacticsSplitFunTy $ unCType g of+    (_, _, [], _) -> cut -- failure $ GoalMismatch "intros" g+    (_, _, scaledArgs, res) -> do+      let args = fmap scaledThing scaledArgs+      ctx <- ask+      let gen_names = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) args+          occs = case params of+            IntroduceAllUnnamed -> gen_names+            IntroduceOnlyNamed names -> names+            IntroduceOnlyUnnamed n -> take n gen_names+          num_occs = length occs+          top_hole = isTopHole ctx jdg+          bindings = zip occs $ coerce args+          bound_occs = fmap fst bindings+          hy' = lambdaHypothesis top_hole bindings+          jdg' = introduce ctx hy'+               $ withNewGoal (CType $ mkVisFunTys (drop num_occs scaledArgs) res) jdg+      ext <- newSubgoal jdg'+      pure $+        ext+          & #syn_trace %~ rose ("intros {" <> intercalate ", " (fmap show bound_occs) <> "}")+                        . pure+          & #syn_scoped <>~ hy'+          & #syn_val   %~ noLoc . lambda (fmap bvar' bound_occs) . unLoc+++------------------------------------------------------------------------------+-- | Introduce a single lambda argument, and immediately destruct it.+introAndDestruct :: TacticsM ()+introAndDestruct = do+  hy <- fmap unHypothesis $ hyDiff $ intros' $ IntroduceOnlyUnnamed 1+  -- This case should never happen, but I'm validating instead of parsing.+  -- Adding a log to be reminded if the invariant ever goes false.+  --+  -- But note that this isn't a game-ending bug. In the worst case, we'll+  -- accidentally bind too many variables, and incorrectly unify between them.+  -- Which means some GADT cases that should be eliminated won't be --- not the+  -- end of the world.+  unless (length hy == 1) $+    traceMX "BUG: Introduced too many variables for introAndDestruct! Please report me if you see this! " hy++  for_ hy destruct+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches.+destructAuto :: HyInfo CType -> TacticsM ()+destructAuto hi = requireConcreteHole $ tracing "destruct(auto)" $ do+  jdg <- goal+  let subtactic = destructOrHomoAuto hi+  case isPatternMatch $ hi_provenance hi of+    True ->+      pruning subtactic $ \jdgs ->+        let getHyTypes = S.fromList . fmap hi_type . unHypothesis . jHypothesis+            new_hy = foldMap getHyTypes jdgs+            old_hy = getHyTypes jdg+        in case S.null $ new_hy S.\\ old_hy of+              True  -> Just $ UnhelpfulDestruct $ hi_name hi+              False -> Nothing+    False -> subtactic+++------------------------------------------------------------------------------+-- | When running auto, in order to prune the auto search tree, we try+-- a homomorphic destruct whenever possible. If that produces any results, we+-- can probably just prune the other side.+destructOrHomoAuto :: HyInfo CType -> TacticsM ()+destructOrHomoAuto hi = tracing "destructOrHomoAuto" $ do+  jdg <- goal+  let g  = unCType $ jGoal jdg+      ty = unCType $ hi_type hi++  attemptWhen+      (rule $ destruct' False (\dc jdg ->+        buildDataCon False jdg dc $ snd $ splitAppTys g) hi)+      (rule $ destruct' False (const newSubgoal) hi)+    $ case (splitTyConApp_maybe g, splitTyConApp_maybe ty) of+        (Just (gtc, _), Just (tytc, _)) -> gtc == tytc+        _ -> False+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches.+destruct :: HyInfo CType -> TacticsM ()+destruct hi = requireConcreteHole $ tracing "destruct(user)" $+  rule $ destruct' False (const newSubgoal) hi+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches. Performs record punning.+destructPun :: HyInfo CType -> TacticsM ()+destructPun hi = requireConcreteHole $ tracing "destructPun(user)" $+  rule $ destruct' True (const newSubgoal) hi+++------------------------------------------------------------------------------+-- | Case split, using the same data constructor in the matches.+homo :: HyInfo CType -> TacticsM ()+homo hi = requireConcreteHole . tracing "homo" $ do+  jdg <- goal+  let g = jGoal jdg++  -- Ensure that every data constructor in the domain type is covered in the+  -- codomain; otherwise 'homo' will produce an ill-typed program.+  case uncoveredDataCons (coerce $ hi_type hi) (coerce g) of+    Just uncovered_dcs ->+      unless (S.null uncovered_dcs) $+        failure  $ TacticPanic "Can't cover every datacon in domain"+    _ -> failure $ TacticPanic "Unable to fetch datacons"++  rule+    $ destruct'+        False+        (\dc jdg -> buildDataCon False jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg)+        hi+++------------------------------------------------------------------------------+-- | LambdaCase split, and leave holes in the matches.+destructLambdaCase :: TacticsM ()+destructLambdaCase =+  tracing "destructLambdaCase" $ rule $ destructLambdaCase' False (const newSubgoal)+++------------------------------------------------------------------------------+-- | LambdaCase split, using the same data constructor in the matches.+homoLambdaCase :: TacticsM ()+homoLambdaCase =+  tracing "homoLambdaCase" $+    rule $ destructLambdaCase' False $ \dc jdg ->+      buildDataCon False jdg dc+        . snd+        . splitAppTys+        . unCType+        $ jGoal jdg+++newtype Saturation = Unsaturated Int+  deriving (Eq, Ord, Show)++pattern Saturated :: Saturation+pattern Saturated = Unsaturated 0+++apply :: Saturation -> HyInfo CType -> TacticsM ()+apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do+  jdg <- goal+  let g  = jGoal jdg+      ty = unCType $ hi_type hi+      func = hi_name hi+  ty' <- freshTyvars ty+  let (_, theta, all_args, ret) = tacticsSplitFunTy ty'+      saturated_args = dropEnd n all_args+      unsaturated_args = takeEnd n all_args+  rule $ \jdg -> do+    unify g (CType $ mkVisFunTys unsaturated_args ret)+    learnFromFundeps theta+    ext+        <- fmap unzipTrace+        $ traverse ( newSubgoal+                    . blacklistingDestruct+                    . flip withNewGoal jdg+                    . CType+                    . scaledThing+                    ) saturated_args+    pure $+      ext+        & #syn_used_vals %~ (\x -> S.insert func x <> getAncestry jdg func)+        & #syn_val       %~ mkApply func . fmap unLoc++application :: TacticsM ()+application = overFunctions $ apply Saturated+++------------------------------------------------------------------------------+-- | Choose between each of the goal's data constructors.+split :: TacticsM ()+split = tracing "split(user)" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Nothing -> failure $ GoalMismatch "split" g+    Just (dcs, _) -> choice $ fmap splitDataCon dcs+++------------------------------------------------------------------------------+-- | Choose between each of the goal's data constructors. Different than+-- 'split' because it won't split a data con if it doesn't result in any new+-- goals.+splitAuto :: TacticsM ()+splitAuto = requireConcreteHole $ tracing "split(auto)" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Nothing -> failure $ GoalMismatch "split" g+    Just (dcs, _) -> do+      case isSplitWhitelisted jdg of+        True -> choice $ fmap splitDataCon dcs+        False -> do+          choice $ flip fmap dcs $ \dc -> requireNewHoles $+            splitDataCon dc+++------------------------------------------------------------------------------+-- | Like 'split', but only works if there is a single matching data+-- constructor for the goal.+splitSingle :: TacticsM ()+splitSingle = tracing "splitSingle" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Just ([dc], _) -> do+      splitDataCon dc+    _ -> failure $ GoalMismatch "splitSingle" g++------------------------------------------------------------------------------+-- | Like 'split', but prunes any data constructors which have holes.+obvious :: TacticsM ()+obvious = tracing "obvious" $ do+  pruning split $ bool (Just NoProgress) Nothing . null+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+sorry :: TacticsM ()+sorry = exact $ var' $ mkVarOcc "_"+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+metaprogram :: TacticsM ()+metaprogram = exact $ MetaprogramSyntax ""+++------------------------------------------------------------------------------+-- | Allow the given tactic to proceed if and only if it introduces holes that+-- have a different goal than current goal.+requireNewHoles :: TacticsM () -> TacticsM ()+requireNewHoles m = do+  jdg <- goal+  pruning m $ \jdgs ->+    case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of+      True  -> Nothing+      False -> Just NoProgress+++------------------------------------------------------------------------------+-- | Attempt to instantiate the given ConLike to solve the goal.+--+-- INVARIANT: Assumes the given ConLike is appropriate to construct the type+-- with.+splitConLike :: ConLike -> TacticsM ()+splitConLike dc =+  requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do+    let g = jGoal jdg+    case splitTyConApp_maybe $ unCType g of+      Just (_, apps) -> do+        buildDataCon True (unwhitelistingSplit jdg) dc apps+      Nothing -> cut -- failure $ GoalMismatch "splitDataCon" g++------------------------------------------------------------------------------+-- | Attempt to instantiate the given data constructor to solve the goal.+--+-- INVARIANT: Assumes the given datacon is appropriate to construct the type+-- with.+splitDataCon :: DataCon -> TacticsM ()+splitDataCon = splitConLike . RealDataCon+++------------------------------------------------------------------------------+-- | Perform a case split on each top-level argument. Used to implement the+-- "Destruct all function arguments" action.+destructAll :: TacticsM ()+destructAll = do+  jdg <- goal+  let args = fmap fst+           $ sortOn snd+           $ mapMaybe (\(hi, prov) ->+              case prov of+                TopLevelArgPrv _ idx _ -> pure (hi, idx)+                _ -> Nothing+                )+           $ fmap (\hi -> (hi, hi_provenance hi))+           $ filter (isAlgType . unCType . hi_type)+           $ unHypothesis+           $ jHypothesis jdg+  for_ args $ \arg -> do+    subst <- getSubstForJudgement =<< goal+    destruct $ fmap (coerce substTy subst) arg++--------------------------------------------------------------------------------+-- | User-facing tactic to implement "Use constructor <x>"+userSplit :: OccName -> TacticsM ()+userSplit occ = do+  jdg <- goal+  let g = jGoal jdg+  -- TODO(sandy): It's smelly that we need to find the datacon to generate the+  -- code action, send it as a string, and then look it up again. Can we push+  -- this over LSP somehow instead?+  case splitTyConApp_maybe $ unCType g of+    Just (tc, _) -> do+      case find (sloppyEqOccName occ . occName . dataConName)+             $ tyConDataCons tc of+        Just dc -> splitDataCon dc+        Nothing -> failure $ NotInScope occ+    Nothing -> failure $ NotInScope occ+++------------------------------------------------------------------------------+-- | @matching f@ takes a function from a judgement to a @Tactic@, and+-- then applies the resulting @Tactic@.+matching :: (Judgement -> TacticsM ()) -> TacticsM ()+matching f = TacticT $ StateT $ \s -> runStateT (unTacticT $ f s) s+++attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM ()+attemptOn getNames tac = matching (choice . fmap tac . getNames)+++localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a+localTactic t f = do+  TacticT $ StateT $ \jdg ->+    runStateT (unTacticT t) $ f jdg+++refine :: TacticsM ()+refine = intros <%> splitSingle+++auto' :: Int -> TacticsM ()+auto' 0 = failure OutOfGas+auto' n = do+  let loop = auto' (n - 1)+  try intros+  assumption <|>+    choice+      [ overFunctions $ \fname -> do+          requireConcreteHole $ apply Saturated fname+          loop+      , overAlgebraicTerms $ \aname -> do+          destructAuto aname+          loop+      , splitAuto >> loop+      , recursion+      ]++overFunctions :: (HyInfo CType -> TacticsM ()) -> TacticsM ()+overFunctions =+  attemptOn $ filter (isFunction . unCType . hi_type)+           . unHypothesis+           . jHypothesis++overAlgebraicTerms :: (HyInfo CType -> TacticsM ()) -> TacticsM ()+overAlgebraicTerms =+  attemptOn jAcceptableDestructTargets+++allNames :: Judgement -> Set OccName+allNames = hyNamesInScope . jHypothesis+++applyMethod :: Class -> PredType -> OccName -> TacticsM ()+applyMethod cls df method_name = do+  case find ((== method_name) . occName) $ classMethods cls of+    Just method -> do+      let (_, apps) = splitAppTys df+      let ty = piResultTys (idType method) apps+      apply Saturated $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty+    Nothing -> failure $ NotInScope method_name+++applyByName :: OccName -> TacticsM ()+applyByName name = do+  g <- goal+  choice $ unHypothesis (jHypothesis g) <&> \hi ->+    case hi_name hi == name of+      True  -> apply Saturated hi+      False -> empty+++------------------------------------------------------------------------------+-- | Make a function application where the function being applied itself is+-- a hole.+applyByType :: Type -> TacticsM ()+applyByType ty = tracing ("applyByType " <> show ty) $ do+  jdg <- goal+  let g  = jGoal jdg+  ty' <- freshTyvars ty+  let (_, _, args, ret) = tacticsSplitFunTy ty'+  rule $ \jdg -> do+    unify g (CType ret)+    ext+        <- fmap unzipTrace+        $ traverse ( newSubgoal+                    . blacklistingDestruct+                    . flip withNewGoal jdg+                    . CType+                    . scaledThing+                    ) args+    app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg+    pure $+      fmap noLoc $+        foldl' (@@)+          <$> fmap unLoc app+          <*> fmap (fmap unLoc) ext+++------------------------------------------------------------------------------+-- | Make an n-ary function call of the form+-- @(_ :: forall a b. a -> a -> b) _ _@.+nary :: Int -> TacticsM ()+nary n = do+  a <- newUnivar+  b <- newUnivar+  applyByType $ mkVisFunTys (replicate n $ unrestricted a) b+++self :: TacticsM ()+self =+  fmap listToMaybe getCurrentDefinitions >>= \case+    Just (self, _) -> useNameFromContext (apply Saturated) self+    Nothing -> failure $ TacticPanic "no defining function"+++------------------------------------------------------------------------------+-- | Perform a catamorphism when destructing the given 'HyInfo'. This will+-- result in let binding, making values that call the defining function on each+-- destructed value.+cata :: HyInfo CType -> TacticsM ()+cata hi = do+  (_, _, calling_args, _)+      <- tacticsSplitFunTy . unCType <$> getDefiningType+  freshened_args <- traverse (freshTyvars . scaledThing) calling_args+  diff <- hyDiff $ destruct hi++  -- For for every destructed term, check to see if it can unify with any of+  -- the arguments to the calling function. If it doesn't, we don't try to+  -- perform a cata on it.+  unifiable_diff <- flip filterM (unHypothesis diff) $ \hi ->+    flip anyM freshened_args $ \ty ->+      canUnify (hi_type hi) $ CType ty++  rule $+    letForEach+      (mkVarOcc . flip mappend "_c" . occNameString)+      (\hi -> self >> commit (assume $ hi_name hi) assumption)+      $ Hypothesis unifiable_diff+++letBind :: [OccName] -> TacticsM ()+letBind occs = do+  jdg <- goal+  occ_tys <- for occs+           $ \occ+          -> fmap (occ, )+           $ fmap (<$ jdg)+           $ fmap CType newUnivar+  rule $ nonrecLet occ_tys+++------------------------------------------------------------------------------+-- | Deeply nest an unsaturated function onto itself+nested :: OccName -> TacticsM ()+nested = deepening . use (Unsaturated 1)+++------------------------------------------------------------------------------+-- | Repeatedly bind a tactic on its first hole+deep :: Int -> TacticsM () -> TacticsM ()+deep 0 _ = pure ()+deep n t = foldr1 bindOne $ replicate n t+++------------------------------------------------------------------------------+-- | Try 'deep' for arbitrary depths.+deepening :: TacticsM () -> TacticsM ()+deepening t =+  asum $ fmap (flip deep t) [0 .. 100]+++bindOne :: TacticsM a -> TacticsM a -> TacticsM a+bindOne t t1 = t <@> [t1]+++collapse :: TacticsM ()+collapse = do+  g <- goal+  let terms = unHypothesis $ hyFilter ((jGoal g ==) . hi_type) $ jLocalHypothesis g+  case terms of+    [hi] -> assume $ hi_name hi+    _    -> nary (length terms) <@> fmap (assume . hi_name) terms+++with_arg :: TacticsM ()+with_arg = rule $ \jdg -> do+  let g = jGoal jdg+  fresh_ty <- newUnivar+  a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg+  f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [unrestricted fresh_ty] g) jdg+  pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a+++------------------------------------------------------------------------------+-- | Determine the difference in hypothesis due to running a tactic. Also, it+-- runs the tactic.+hyDiff :: TacticsM () -> TacticsM (Hypothesis CType)+hyDiff m = do+  g <- unHypothesis . jEntireHypothesis <$> goal+  let g_len = length g+  m+  g' <- unHypothesis . jEntireHypothesis <$> goal+  pure $ Hypothesis $ take (length g' - g_len) g'+++------------------------------------------------------------------------------+-- | Attempt to run the given tactic in "idiom bracket" mode. For example, if+-- the current goal is+--+--    (_ :: [r])+--+-- then @idiom apply@ will remove the applicative context, resulting in a hole:+--+--    (_ :: r)+--+-- and then use @apply@ to solve it. Let's say this results in:+--+--    (f (_ :: a) (_ :: b))+--+-- Finally, @idiom@ lifts this back into the original applicative:+--+--    (f <$> (_ :: [a]) <*> (_ :: [b]))+--+-- Idiom will fail fast if the current goal doesn't have an applicative+-- instance.+idiom :: TacticsM () -> TacticsM ()+idiom m = do+  jdg <- goal+  let hole = unCType $ jGoal jdg+  when (isFunction hole) $+    failure $ GoalMismatch "idiom" $ jGoal jdg+  case splitAppTy_maybe hole of+    Just (applic, ty) -> do+      minst <- getKnownInstance (mkClsOcc "Applicative")+            . pure+            $ applic+      case minst of+        Nothing -> failure $ GoalMismatch "idiom" $ CType applic+        Just (_, _) -> do+          rule $ \jdg -> do+            expr <- subgoalWith (withNewGoal (CType ty) jdg) m+            case unLoc $ syn_val expr of+              HsApp{}     -> pure $ fmap idiomize expr+              RecordCon{} -> pure $ fmap idiomize expr+              _       -> unsolvable $ GoalMismatch "idiom" $ jGoal jdg+          rule $ newSubgoal . withModifiedGoal (CType . mkAppTy applic . unCType)+    Nothing ->+      failure $ GoalMismatch "idiom" $ jGoal jdg++subgoalWith :: Judgement -> TacticsM () -> RuleM (Synthesized (LHsExpr GhcPs))+subgoalWith jdg t = RuleT $ flip execStateT jdg $ unTacticT t+
+ new/src/Wingman/Types.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Wingman.Types+  ( module Wingman.Types+  , module Wingman.Debug+  , OccName+  , Name+  , Type+  , TyVar+  , Span+  ) where++import           Control.Lens hiding (Context)+import           Control.Monad.Reader+import           Control.Monad.State+import qualified Control.Monad.State.Strict as Strict+import           Data.Coerce+import           Data.Function+import           Data.Generics (mkM, everywhereM, Data, Typeable)+import           Data.Generics.Labels ()+import           Data.Generics.Product (field)+import           Data.List.NonEmpty (NonEmpty (..))+import           Data.Semigroup+import           Data.Set (Set)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Tree+import           Development.IDE (Range)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (Node)+import qualified Development.IDE.GHC.Compat.Util as Util+import           Development.IDE.GHC.Orphans ()+import           GHC.Exts (fromString)+import           GHC.Generics+import           GHC.SourceGen (var)+import           Refinery.ProofState+import           Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT))+import           System.IO.Unsafe (unsafePerformIO)+import           Wingman.Debug+import           Data.IORef+++------------------------------------------------------------------------------+-- | The list of tactics exposed to the outside world. These are attached to+-- actual tactics via 'commandTactic' and are contextually provided to the+-- editor via 'commandProvider'.+data TacticCommand+  = Auto+  | Intros+  | IntroAndDestruct+  | Destruct+  | DestructPun+  | Homomorphism+  | DestructLambdaCase+  | HomomorphismLambdaCase+  | DestructAll+  | UseDataCon+  | Refine+  | BeginMetaprogram+  | RunMetaprogram+  deriving (Eq, Ord, Show, Enum, Bounded)++-- | Generate a title for the command.+tacticTitle :: TacticCommand -> T.Text -> T.Text+tacticTitle = (mappend "Wingman: " .) . go+  where+    go Auto _                   = "Attempt to fill hole"+    go Intros _                 = "Introduce lambda"+    go IntroAndDestruct _       = "Introduce and destruct term"+    go Destruct var             = "Case split on " <> var+    go DestructPun var          = "Split on " <> var <> " with NamedFieldPuns"+    go Homomorphism var         = "Homomorphic case split on " <> var+    go DestructLambdaCase _     = "Lambda case split"+    go HomomorphismLambdaCase _ = "Homomorphic lambda case split"+    go DestructAll _            = "Split all function arguments"+    go UseDataCon dcon          = "Use constructor " <> dcon+    go Refine _                 = "Refine hole"+    go BeginMetaprogram _       = "Use custom tactic block"+    go RunMetaprogram _         = "Run custom tactic"+++------------------------------------------------------------------------------+-- | Plugin configuration for tactics+data Config = Config+  { cfg_max_use_ctor_actions :: Int+  , cfg_timeout_seconds      :: Int+  , cfg_auto_gas             :: Int+  , cfg_proofstate_styling   :: Bool+  }+  deriving (Eq, Ord, Show)++emptyConfig :: Config+emptyConfig = Config+  { cfg_max_use_ctor_actions = 5+  , cfg_timeout_seconds = 2+  , cfg_auto_gas = 4+  , cfg_proofstate_styling = True+  }++------------------------------------------------------------------------------+-- | A wrapper around 'Type' which supports equality and ordering.+newtype CType = CType { unCType :: Type }+  deriving stock (Data, Typeable)++instance Eq CType where+  (==) = eqType `on` unCType++instance Ord CType where+  compare = nonDetCmpType `on` unCType++instance Show CType where+  show  = unsafeRender . unCType++instance Show Name where+  show  = unsafeRender++instance Show Type where+  show  = unsafeRender++instance Show Var where+  show  = unsafeRender++instance Show TCvSubst where+  show  = unsafeRender++instance Show DataCon where+  show  = unsafeRender++instance Show Class where+  show  = unsafeRender++instance Show (HsExpr GhcPs) where+  show  = unsafeRender++instance Show (HsExpr GhcTc) where+  show  = unsafeRender++instance Show (HsDecl GhcPs) where+  show  = unsafeRender++instance Show (Pat GhcPs) where+  show  = unsafeRender++instance Show (LHsSigType GhcPs) where+  show  = unsafeRender++instance Show TyCon where+  show  = unsafeRender++instance Show ConLike where+  show  = unsafeRender++instance Show LexicalFixity where+  show  = unsafeRender+++------------------------------------------------------------------------------+-- | The state that should be shared between subgoals. Extracts move towards+-- the root, judgments move towards the leaves, and the state moves *sideways*.+data TacticState = TacticState+    { ts_skolems         :: !(Set TyVar)+      -- ^ The known skolems.+    , ts_unifier         :: !TCvSubst+    , ts_unique_gen :: !UniqSupply+    } deriving stock (Show, Generic)++instance Show UniqSupply where+  show _ = "<uniqsupply>"+++------------------------------------------------------------------------------+-- | A 'UniqSupply' to use in 'defaultTacticState'+unsafeDefaultUniqueSupply :: UniqSupply+unsafeDefaultUniqueSupply =+  unsafePerformIO $ mkSplitUniqSupply 'w'+{-# NOINLINE unsafeDefaultUniqueSupply #-}+++defaultTacticState :: TacticState+defaultTacticState =+  TacticState+    { ts_skolems         = mempty+    , ts_unifier         = emptyTCvSubst+    , ts_unique_gen      = unsafeDefaultUniqueSupply+    }+++------------------------------------------------------------------------------+-- | Generate a new 'Unique'+freshUnique :: MonadState TacticState m => m Util.Unique+freshUnique = do+  (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen+  modify' $! field @"ts_unique_gen" .~ supply+  pure uniq+++------------------------------------------------------------------------------+-- | Describes where hypotheses came from. Used extensively to prune stupid+-- solutions from the search space.+data Provenance+  = -- | An argument given to the topmost function that contains the current+    -- hole. Recursive calls are restricted to values whose provenance lines up+    -- with the same argument.+    TopLevelArgPrv+      OccName   -- ^ Binding function+      Int       -- ^ Argument Position+      Int       -- ^ of how many arguments total?+    -- | A binding created in a pattern match.+  | PatternMatchPrv PatVal+    -- | A class method from the given context.+  | ClassMethodPrv+      (Uniquely Class)     -- ^ Class+    -- | A binding explicitly written by the user.+  | UserPrv+    -- | A binding explicitly imported by the user.+  | ImportPrv+    -- | The recursive hypothesis. Present only in the context of the recursion+    -- tactic.+  | RecursivePrv+    -- | A hypothesis which has been disallowed for some reason. It's important+    -- to keep these in the hypothesis set, rather than filtering it, in order+    -- to continue tracking downstream provenance.+  | DisallowedPrv DisallowReason Provenance+  deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Why was a hypothesis disallowed?+data DisallowReason+  = WrongBranch Int+  | Shadowed+  | RecursiveCall+  | AlreadyDestructed+  deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Provenance of a pattern value.+data PatVal = PatVal+  { pv_scrutinee :: Maybe OccName+    -- ^ Original scrutinee which created this PatVal. Nothing, for lambda+    -- case.+  , pv_ancestry  :: Set OccName+    -- ^ The set of values which had to be destructed to discover this term.+    -- Always contains the scrutinee.+  , pv_datacon   :: Uniquely ConLike+    -- ^ The datacon which introduced this term.+  , pv_position  :: Int+    -- ^ The position of this binding in the datacon's arguments.+  } deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | A wrapper which uses a 'Uniquable' constraint for providing 'Eq' and 'Ord'+-- instances.+newtype Uniquely a = Uniquely { getViaUnique :: a }+  deriving Show via a+  deriving stock (Data, Typeable)++instance Util.Uniquable a => Eq (Uniquely a) where+  (==) = (==) `on` Util.getUnique . getViaUnique++instance Util.Uniquable a => Ord (Uniquely a) where+  compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique+++-- NOTE(sandy): The usage of list here is mostly for convenience, but if it's+-- ever changed, make sure to correspondingly update+-- 'jAcceptableDestructTargets' so that it correctly identifies newly+-- introduced terms.+newtype Hypothesis a = Hypothesis+  { unHypothesis :: [HyInfo a]+  }+  deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable)+  deriving newtype (Semigroup, Monoid)+++------------------------------------------------------------------------------+-- | The provenance and type of a hypothesis term.+data HyInfo a = HyInfo+  { hi_name       :: OccName+  , hi_provenance :: Provenance+  , hi_type       :: a+  }+  deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Map a function over the provenance.+overProvenance :: (Provenance -> Provenance) -> HyInfo a -> HyInfo a+overProvenance f (HyInfo name prv ty) = HyInfo name (f prv) ty+++------------------------------------------------------------------------------+-- | The current bindings and goal for a hole to be filled by refinery.+data Judgement' a = Judgement+  { _jHypothesis        :: !(Hypothesis a)+  , _jBlacklistDestruct :: !Bool+  , _jWhitelistSplit    :: !Bool+  , _jIsTopHole         :: !Bool+  , _jGoal              :: !a+  , j_coercion          :: TCvSubst+  }+  deriving stock (Generic, Functor, Show)++type Judgement = Judgement' CType+++newtype ExtractM a = ExtractM { unExtractM :: ReaderT Context IO a }+    deriving newtype (Functor, Applicative, Monad, MonadReader Context)++------------------------------------------------------------------------------+-- | Used to ensure hole names are unique across invocations of runTactic+globalHoleRef :: IORef Int+globalHoleRef = unsafePerformIO $ newIORef 10+{-# NOINLINE globalHoleRef #-}++instance MonadExtract Int (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM where+  hole = do+    u <- lift $ ExtractM $ lift $+          readIORef globalHoleRef <* modifyIORef' globalHoleRef (+ 1)+    pure+      ( u+      , pure . noLoc $ var $ fromString $ occNameString $ occName $ mkMetaHoleName u+      )++  unsolvableHole _ = hole+++instance MonadReader r m => MonadReader r (TacticT jdg ext err s m) where+  ask = TacticT $ lift $ Effect $ asks pure+  local f (TacticT m) = TacticT $ Strict.StateT $ \jdg ->+    Effect $ local f $ pure $ Strict.runStateT m jdg++instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where+  ask = RuleT $ Effect $ asks Axiom+  local f (RuleT m) = RuleT $ Effect $ local f $ pure m++mkMetaHoleName :: Int -> RdrName+mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u)++instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where+  -- TODO(sandy): This join is to combine the synthesizeds+  substMeta u val a =  join $ a <&>+    everywhereM (mkM $ \case+      (L _ (HsVar _ (L _ name)))+        | name == mkMetaHoleName u -> val+      (t :: LHsExpr GhcPs) -> pure t)+++------------------------------------------------------------------------------+-- | Reasons a tactic might fail.+data TacticError+  = OutOfGas+  | GoalMismatch String CType+  | NoProgress+  | NoApplicableTactic+  | UnhelpfulRecursion+  | UnhelpfulDestruct OccName+  | TooPolymorphic+  | NotInScope OccName+  | TacticPanic String+  deriving (Eq)++instance Show TacticError where+    show OutOfGas = "Auto ran out of gas"+    show (GoalMismatch tac (CType typ)) =+      mconcat+        [ "The tactic "+        , tac+        , " doesn't apply to goal type "+        , unsafeRender typ+        ]+    show NoProgress =+      "Unable to make progress"+    show NoApplicableTactic =+      "No tactic could be applied"+    show UnhelpfulRecursion =+      "Recursion wasn't productive"+    show (UnhelpfulDestruct n) =+      "Destructing patval " <> show n <> " leads to no new types"+    show TooPolymorphic =+      "The tactic isn't applicable because the goal is too polymorphic"+    show (NotInScope name) =+      "Tried to do something with the out of scope name " <> show name+    show (TacticPanic err) =+      "Tactic panic: " <> err+++------------------------------------------------------------------------------+type TacticsM  = TacticT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM+type RuleM     = RuleT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM+type Rule      = RuleM (Synthesized (LHsExpr GhcPs))++type Trace = Rose String++------------------------------------------------------------------------------+-- | The extract for refinery. Represents a "synthesized attribute" in the+-- context of attribute grammars. In essence, 'Synthesized' describes+-- information we'd like to pass from leaves of the tactics search upwards.+-- This includes the actual AST we've generated (in 'syn_val').+data Synthesized a = Synthesized+  { syn_trace  :: Trace+    -- ^ A tree describing which tactics were used produce the 'syn_val'.+    -- Mainly for debugging when you get the wrong answer, to see the other+    -- things it tried.+  , syn_scoped :: Hypothesis CType+    -- ^ All of the bindings created to produce the 'syn_val'.+  , syn_used_vals :: Set OccName+    -- ^ The values used when synthesizing the 'syn_val'.+  , syn_recursion_count :: Sum Int+    -- ^ The number of recursive calls+  , syn_val    :: a+  }+  deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)++instance Monad Synthesized where+  return = pure+  Synthesized tr1 sc1 uv1 rc1 a >>= f =+    case f a of+      Synthesized tr2 sc2 uv2 rc2 b ->+        Synthesized+          { syn_trace = tr1 <> tr2+          , syn_scoped = sc1 <> sc2+          , syn_used_vals = uv1 <> uv2+          , syn_recursion_count = rc1 <> rc2+          , syn_val = b+          }++mapTrace :: (Trace -> Trace) -> Synthesized a -> Synthesized a+mapTrace f (Synthesized tr sc uv rc a) = Synthesized (f tr) sc uv rc a+++------------------------------------------------------------------------------+-- | This might not be lawful, due to the semigroup on 'Trace' maybe not being+-- lawful. But that's only for debug output, so it's not anything I'm concerned+-- about.+instance Applicative Synthesized where+  pure = Synthesized mempty mempty mempty mempty+  Synthesized tr1 sc1 uv1 rc1 f <*> Synthesized tr2 sc2 uv2 rc2 a =+    Synthesized (tr1 <> tr2) (sc1 <> sc2) (uv1 <> uv2) (rc1 <> rc2) $ f a+++------------------------------------------------------------------------------+-- | The Reader context of tactics and rules+data Context = Context+  { ctxDefiningFuncs :: [(OccName, CType)]+    -- ^ The functions currently being defined+  , ctxModuleFuncs   :: [(OccName, CType)]+    -- ^ Everything defined in the current module+  , ctxConfig        :: Config+  , ctxInstEnvs      :: InstEnvs+  , ctxFamInstEnvs   :: FamInstEnvs+  , ctxTheta         :: Set CType+  , ctx_hscEnv       :: HscEnv+  , ctx_occEnv       :: OccEnv [GlobalRdrElt]+  , ctx_module       :: Module+  }++instance Show Context where+  show Context{..} = mconcat+    [ "Context "+    , showsPrec 10 ctxDefiningFuncs ""+    , showsPrec 10 ctxModuleFuncs ""+    , showsPrec 10 ctxConfig ""+    , showsPrec 10 ctxTheta ""+    ]+++------------------------------------------------------------------------------+-- | An empty context+emptyContext :: Context+emptyContext+  = Context+      { ctxDefiningFuncs = mempty+      , ctxModuleFuncs = mempty+      , ctxConfig = emptyConfig+      , ctxFamInstEnvs = mempty+      , ctxInstEnvs = InstEnvs mempty mempty mempty+      , ctxTheta = mempty+      , ctx_hscEnv = error "empty hsc env from emptyContext"+      , ctx_occEnv = emptyOccEnv+      , ctx_module = error "empty module from emptyContext"+      }+++newtype Rose a = Rose (Tree a)+  deriving stock (Eq, Functor, Generic, Data, Typeable)++instance Show (Rose String) where+  show = unlines . dropEveryOther . lines . drawTree . coerce++dropEveryOther :: [a] -> [a]+dropEveryOther []           = []+dropEveryOther [a]          = [a]+dropEveryOther (a : _ : as) = a : dropEveryOther as++------------------------------------------------------------------------------+-- | This might not be lawful! I didn't check, and it feels sketchy.+instance (Eq a, Monoid a) => Semigroup (Rose a) where+  Rose (Node a as) <> Rose (Node b bs) = Rose $ Node (a <> b) (as <> bs)+  sconcat (a :| as) = rose mempty $ a : as++instance (Eq a, Monoid a) => Monoid (Rose a) where+  mempty = Rose $ Node mempty mempty++rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a+rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs+rose a rs = Rose $ Node a $ coerce rs+++------------------------------------------------------------------------------+-- | The results of 'Wingman.Machinery.runTactic'+data RunTacticResults = RunTacticResults+  { rtr_trace       :: Trace+  , rtr_extract     :: LHsExpr GhcPs+  , rtr_subgoals    :: [Judgement]+  , rtr_other_solns :: [Synthesized (LHsExpr GhcPs)]+  , rtr_jdg         :: Judgement+  , rtr_ctx         :: Context+  , rtr_timed_out   :: Bool+  } deriving Show+++data AgdaMatch = AgdaMatch+  { amPats :: [Pat GhcPs]+  , amBody :: HsExpr GhcPs+  }+  deriving (Show)+++data UserFacingMessage+  = NotEnoughGas+  | TacticErrors+  | TimedOut+  | NothingToDo+  | InfrastructureError Text+  deriving Eq++instance Show UserFacingMessage where+  show NotEnoughGas = "Wingman ran out of gas when trying to find a solution.  \nTry increasing the `auto_gas` setting."+  show TacticErrors = "Wingman couldn't find a solution"+  show TimedOut     = "Wingman timed out while finding a solution.  \nYou might get a better result if you increase the timeout duration."+  show NothingToDo  = "Nothing to do"+  show (InfrastructureError t) = "Internal error: " <> T.unpack t+++data HoleSort = Hole | Metaprogram T.Text+  deriving (Eq, Ord, Show)++data HoleJudgment = HoleJudgment+  { hj_range     :: Tracked 'Current Range+  , hj_jdg       :: Judgement+  , hj_ctx       :: Context+  , hj_dflags    :: DynFlags+  , hj_hole_sort :: HoleSort+  }+
+ new/test/AutoTupleSpec.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NumDecimals #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module AutoTupleSpec where++import Control.Monad (replicateM)+import Control.Monad.State (evalState)+import Data.Either (isRight)+import Development.IDE.GHC.Compat.Core ( mkVarOcc, mkBoxedTupleTy )+import System.IO.Unsafe+import Test.Hspec+import Test.QuickCheck+import Wingman.Judgements (mkFirstJudgement)+import Wingman.Machinery+import Wingman.Tactics (auto')+import Wingman.Types+++spec :: Spec+spec = describe "auto for tuple" $ do+  it "should always be able to discover an auto solution" $ do+    property $ do+      -- Pick some number of variables+      n <- choose (1, 7)+      let vars = flip evalState defaultTacticState+               $ replicateM n newUnivar+      -- Pick a random ordering+      in_vars  <- shuffle vars+      -- Randomly associate them into tuple types+      in_type  <- mkBoxedTupleTy+                . fmap mkBoxedTupleTy+              <$> randomGroups in_vars+      out_type <- mkBoxedTupleTy+                . fmap mkBoxedTupleTy+              <$> randomGroups vars+      pure $+          -- We should always be able to find a solution+          unsafePerformIO+            (runTactic+              2e6+              emptyContext+              (mkFirstJudgement+                emptyContext+                (Hypothesis $ pure $ HyInfo (mkVarOcc "x") UserPrv $ CType in_type)+                True+                out_type)+              (auto' $ n * 2)) `shouldSatisfy` isRight+++randomGroups :: [a] -> Gen [[a]]+randomGroups [] = pure []+randomGroups as = do+  n <- choose (1, length as)+  (:) <$> pure (take n as)+      <*> randomGroups (drop n as)+
+ new/test/CodeAction/AutoSpec.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.AutoSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let autoTest = goldenTest Auto ""+      autoTestNoWhitespace = goldenTestNoWhitespace Auto ""++  describe "golden" $ do+    autoTest 11  8 "AutoSplitGADT"+    autoTest  2 11 "GoldenEitherAuto"+    autoTest  4 12 "GoldenJoinCont"+    autoTest  3 11 "GoldenIdentityFunctor"+    autoTest  7 11 "GoldenIdTypeFam"+    autoTest  2 15 "GoldenEitherHomomorphic"+    autoTest  2  8 "GoldenNote"+    autoTest  2 12 "GoldenPureList"+    autoTest  2 12 "GoldenListFmap"+    autoTest  2 13 "GoldenFromMaybe"+    autoTest  2 10 "GoldenFoldr"+    autoTest  2  8 "GoldenSwap"+    autoTest  4 11 "GoldenFmapTree"+    autoTest  7 13 "GoldenGADTAuto"+    autoTest  2 12 "GoldenSwapMany"+    autoTest  4 12 "GoldenBigTuple"+    autoTest  2 10 "GoldenShow"+    autoTest  2 15 "GoldenShowCompose"+    autoTest  2  8 "GoldenShowMapChar"+    autoTest  7  8 "GoldenSuperclass"+    autoTest  2 12 "GoldenSafeHead"+    autoTest  2 12 "FmapBoth"+    autoTest  7  8 "RecordCon"+    autoTest  6  8 "NewtypeRecord"+    autoTest  2 14 "FmapJoin"+    autoTest  2  9 "Fgmap"+    autoTest  4 19 "FmapJoinInLet"+    autoTest  9 12 "AutoEndo"+    autoTest  2 16 "AutoEmptyString"+    autoTest  7 35 "AutoPatSynUse"+    autoTest  2 28 "AutoZip"+    autoTest  2 17 "AutoInfixApply"+    autoTest  2 19 "AutoInfixApplyMany"+    autoTest  2 25 "AutoInfixInfix"+    autoTest 19 12 "AutoTypeLevel"+    autoTest 11  9 "AutoForallClassMethod"+    autoTest  2  8 "AutoUnusedPatternMatch"++    failing "flaky in CI" $+      autoTest 2 11 "GoldenApplicativeThen"++    failing "not enough auto gas" $+      autoTest 5 18 "GoldenFish"++  describe "theta" $ do+    autoTest 12 10 "AutoThetaFix"+    autoTest  7 27 "AutoThetaRankN"+    autoTest  6 10 "AutoThetaGADT"+    autoTest  6  8 "AutoThetaGADTDestruct"+    autoTest  4  8 "AutoThetaEqCtx"+    autoTest  6 10 "AutoThetaEqGADT"+    autoTest  6  8 "AutoThetaEqGADTDestruct"+    autoTest  6 10 "AutoThetaRefl"+    autoTest  6  8 "AutoThetaReflDestruct"+    autoTest 19 30 "AutoThetaMultipleUnification"+    autoTest 16  9 "AutoThetaSplitUnification"++  describe "known" $ do+    autoTest 25 13 "GoldenArbitrary"+    autoTest  6 13 "GoldenArbitrarySingleConstructor"+    autoTestNoWhitespace+              6 10 "KnownBigSemigroup"+    autoTest  4 10 "KnownThetaSemigroup"+    autoTest  6 10 "KnownCounterfactualSemigroup"+    autoTest 10 10 "KnownModuleInstanceSemigroup"+    autoTest  4 22 "KnownDestructedSemigroup"+    autoTest  4 10 "KnownMissingSemigroup"+    autoTest  7 12 "KnownMonoid"+    autoTest  7 12 "KnownPolyMonoid"+    autoTest  7 12 "KnownMissingMonoid"+++  describe "messages" $ do+    mkShowMessageTest Auto ""  2 8 "MessageForallA"      TacticErrors+    mkShowMessageTest Auto ""  7 8 "MessageCantUnify"    TacticErrors+    mkShowMessageTest Auto "" 12 8 "MessageNotEnoughGas" NotEnoughGas+
+ new/test/CodeAction/DestructAllSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructAllSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructAllTest = goldenTest DestructAll ""+  describe "provider" $ do+    mkTest+      "Requires args on lhs of ="+      "DestructAllProvider" 3 21+      [ (not, DestructAll, "")+      ]+    mkTest+      "Can't be a non-top-hole"+      "DestructAllProvider" 8 19+      [ (not, DestructAll, "")+      , (id, Destruct, "a")+      , (id, Destruct, "b")+      ]+    mkTest+      "Provides a destruct all otherwise"+      "DestructAllProvider" 12 22+      [ (id, DestructAll, "")+      ]++  describe "golden" $ do+    destructAllTest 2 11 "DestructAllAnd"+    destructAllTest 4 23 "DestructAllMany"+    destructAllTest 2 18 "DestructAllNonVarTopMatch"+    destructAllTest 2 18 "DestructAllFunc"+    destructAllTest 19 18 "DestructAllGADTEvidence"+
+ new/test/CodeAction/DestructPunSpec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructPunSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructTest = goldenTest DestructPun++  describe "golden" $ do+    destructTest "x"  4  9 "PunSimple"+    destructTest "x"  6 10 "PunMany"+    destructTest "x" 11 11 "PunGADT"+    destructTest "x" 17 11 "PunManyGADT"+    destructTest "x"  4 12 "PunShadowing"+
+ new/test/CodeAction/DestructSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructTest = goldenTest Destruct++  describe "golden" $ do+    destructTest "gadt"  7 17 "GoldenGADTDestruct"+    destructTest "gadt"  8 17 "GoldenGADTDestructCoercion"+    destructTest "a"     7 25 "SplitPattern"+    destructTest "a"     6 18 "DestructPun"+    destructTest "fp"   31 14 "DestructCthulhu"+    destructTest "b"     7 10 "DestructTyFam"+    destructTest "b"     7 10 "DestructDataFam"+    destructTest "b"    17 10 "DestructTyToDataFam"+    destructTest "t"     6 10 "DestructInt"++  describe "layout" $ do+    destructTest "b"  4  3 "LayoutBind"+    destructTest "b"  2 15 "LayoutDollarApp"+    destructTest "b"  2 18 "LayoutOpApp"+    destructTest "b"  2 14 "LayoutLam"+    destructTest "x" 11 15 "LayoutSplitWhere"+    destructTest "x"  3 12 "LayoutSplitClass"+    destructTest "b"  3  9 "LayoutSplitGuard"+    destructTest "b"  4 13 "LayoutSplitLet"+    destructTest "a"  4  7 "LayoutSplitIn"+    destructTest "a"  4 31 "LayoutSplitViewPat"+    destructTest "a"  7 17 "LayoutSplitPattern"+    destructTest "a"  8 26 "LayoutSplitPatSyn"++  describe "providers" $ do+    mkTest+      "Produces destruct and homomorphism code actions"+      "T2" 2 21+      [ (id, Destruct, "eab")+      , (id, Homomorphism, "eab")+      , (not, DestructPun, "eab")+      ]++    mkTest+      "Won't suggest homomorphism on the wrong type"+      "T2" 8 8+      [ (not, Homomorphism, "global")+      ]++    mkTest+      "Produces (homomorphic) lambdacase code actions"+      "T3" 4 24+      [ (id, HomomorphismLambdaCase, "")+      , (id, DestructLambdaCase, "")+      ]++    mkTest+      "Produces lambdacase code actions"+      "T3" 7 13+      [ (id, DestructLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest lambdacase without -XLambdaCase"+      "T2" 11 25+      [ (not, DestructLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest destruct if already destructed"+      "ProvideAlreadyDestructed" 6 18+      [ (not, Destruct, "x")+      ]++    mkTest+      "...but does suggest destruct if destructed in a different branch"+      "ProvideAlreadyDestructed" 9 7+      [ (id, Destruct, "x")+      ]++    mkTest+      "Doesn't suggest destruct on class methods"+      "ProvideLocalHyOnly" 2 12+      [ (not, Destruct, "mempty")+      ]++    mkTest+      "Suggests homomorphism if the domain is bigger than the codomain"+      "ProviderHomomorphism" 12 13+      [ (id, Homomorphism, "g")+      ]++    mkTest+      "Doesn't suggest homomorphism if the domain is smaller than the codomain"+      "ProviderHomomorphism" 15 14+      [ (not, Homomorphism, "g")+      , (id, Destruct, "g")+      ]++    mkTest+      "Suggests lambda homomorphism if the domain is bigger than the codomain"+      "ProviderHomomorphism" 18 14+      [ (id, HomomorphismLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest lambda homomorphism if the domain is smaller than the codomain"+      "ProviderHomomorphism" 21 15+      [ (not, HomomorphismLambdaCase, "")+      , (id, DestructLambdaCase, "")+      ]++    -- test layouts that maintain user-written fixities+    destructTest "b"  3 13 "LayoutInfixKeep"+    destructTest "b"  2 12 "LayoutPrefixKeep"+
+ new/test/CodeAction/IntroDestructSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.IntroDestructSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let test l c = goldenTest IntroAndDestruct "" l c+               . mappend "IntroDestruct"++  describe "golden" $ do+    test 4  5 "One"+    test 2  5 "Many"+    test 4 11 "LetBinding"++  describe "provider" $ do+    mkTest+      "Can intro and destruct an algebraic ty"+      "IntroDestructProvider" 2 12+      [ (id, IntroAndDestruct, "")+      ]+    mkTest+      "Won't intro and destruct a non-algebraic ty"+      "IntroDestructProvider" 5 12+      [ (not, IntroAndDestruct, "")+      ]+    mkTest+      "Can't intro, so no option"+      "IntroDestructProvider" 8 17+      [ (not, IntroAndDestruct, "")+      ]+
+ new/test/CodeAction/IntrosSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.IntrosSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let introsTest = goldenTest Intros ""++  describe "golden" $ do+    introsTest 2 8 "GoldenIntros"++  describe "layout" $ do+    introsTest 4 24 "LayoutRec"+
+ new/test/CodeAction/RefineSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.RefineSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let refineTest = goldenTest Refine ""++  describe "golden" $ do+    refineTest  2  8 "RefineIntro"+    refineTest  2  8 "RefineCon"+    refineTest  4 10 "RefineReader"+    refineTest  8 10 "RefineGADT"+    refineTest  2  8 "RefineIntroWhere"++  describe "messages" $ do+    mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors+
+ new/test/CodeAction/RunMetaprogramSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.RunMetaprogramSpec where++import  Utils+import  Test.Hspec+import  Wingman.Types+++spec :: Spec+spec = do+  let metaTest l c f =+        goldenTest RunMetaprogram "" l c f++  describe "beginMetaprogram" $ do+    goldenTest BeginMetaprogram ""  1  7 "MetaBegin"+    goldenTest BeginMetaprogram ""  1  9 "MetaBeginNoWildify"++  describe "golden" $ do+    metaTest  6 11 "MetaMaybeAp"+    metaTest  2 32 "MetaBindOne"+    metaTest  2 32 "MetaBindAll"+    metaTest  2 13 "MetaTry"+    metaTest  2 74 "MetaChoice"+    metaTest  5 40 "MetaUseImport"+    metaTest  6 31 "MetaUseLocal"+    metaTest 11 11 "MetaUseMethod"+    metaTest  9 38 "MetaCataCollapse"+    metaTest  7 16 "MetaCataCollapseUnary"+    metaTest 10 32 "MetaCataAST"+    metaTest  6 46 "MetaPointwise"+    metaTest  4 28 "MetaUseSymbol"+    metaTest  7 53 "MetaDeepOf"+    metaTest  2 34 "MetaWithArg"+    metaTest  2 18 "MetaLetSimple"+    metaTest  5  9 "MetaIdiom"+    metaTest  7  9 "MetaIdiomRecord"++    metaTest 14 10 "MetaFundeps"++    metaTest  2 12 "IntrosTooMany"+
+ new/test/CodeAction/UseDataConSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.UseDataConSpec where++import qualified Data.Text as T+import           Wingman.Types+import           Test.Hspec+import           Utils+++spec :: Spec+spec = do+  let useTest = goldenTest UseDataCon++  describe "provider" $ do+    mkTest+      "Suggests all data cons for Either"+      "ConProviders" 5 6+      [ (id, UseDataCon, "Left")+      , (id, UseDataCon, "Right")+      , (not, UseDataCon, ":")+      , (not, UseDataCon, "[]")+      , (not, UseDataCon, "C1")+      ]+    mkTest+      "Suggests no data cons for big types"+      "ConProviders" 11 17 $ do+        c <- [1 :: Int .. 10]+        pure $ (not, UseDataCon, T.pack $ show c)+    mkTest+      "Suggests only matching data cons for GADT"+      "ConProviders" 20 12+      [ (id, UseDataCon, "IntGADT")+      , (id, UseDataCon, "VarGADT")+      , (not, UseDataCon, "BoolGADT")+      ]++  describe "golden" $ do+    useTest "(,)"   2 8 "UseConPair"+    useTest "Left"  2 8 "UseConLeft"+    useTest "Right" 2 8 "UseConRight"+
+ new/test/CodeLens/EmptyCaseSpec.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeLens.EmptyCaseSpec where++import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let test = mkCodeLensTest+      noTest = mkNoCodeLensTest++  describe "golden" $ do+    test "EmptyCaseADT"+    test "EmptyCaseShadow"+    test "EmptyCaseParens"+    test "EmptyCaseNested"+    test "EmptyCaseApply"+    test "EmptyCaseGADT"+    test "EmptyCaseLamCase"++  describe "no code lenses" $ do+    noTest "EmptyCaseSpuriousGADT"+
+ new/test/Main.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified Spec+import Test.Hls+import Test.Tasty.Hspec++main :: IO ()+main = testSpecs Spec.spec >>= defaultTestRunner . testGroup "tactics"
+ new/test/ProviderSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module ProviderSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  mkTest+    "Produces intros code action"+    "T1" 2 14+    [ (id, Intros, "")+    ]++  mkTest+    "Won't suggest intros on the wrong type"+    "T2" 8 8+    [ (not, Intros, "")+    ]++  goldenTestMany "SubsequentTactics"+    [ InvokeTactic Intros   ""   4  5+    , InvokeTactic Destruct "du" 4  8+    , InvokeTactic Auto     ""   4 15+    ]
+ new/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ new/test/UnificationSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnificationSpec where++import           Control.Arrow+import           Control.Monad (replicateM, join)+import           Control.Monad.State (evalState)+import           Data.Bool (bool)+import           Data.Functor ((<&>))+import           Data.Maybe (mapMaybe)+import qualified Data.Set as S+import           Data.Traversable+import           Data.Tuple (swap)+import           Development.IDE.GHC.Compat.Core (substTy, mkBoxedTupleTy)+import           Test.Hspec+import           Test.QuickCheck+import           Wingman.GHC+import           Wingman.Machinery (newUnivar)+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType (tcGetTyVar_maybe)+#else+import TcType  (tcGetTyVar_maybe)+#endif+++spec :: Spec+spec = describe "unification" $ do+  it "should be able to unify univars with skolems on either side of the equality" $ do+    property $ do+      -- Pick some number of unification vars and skolem+      n <- choose (1, 20)+      let (skolems, take n -> univars)+            = splitAt n+            $ flip evalState defaultTacticState+            $ replicateM (n * 2) newUnivar+      -- Randomly pair them+      skolem_uni_pairs <-+        for (zip skolems univars) randomSwap+      let (lhs, rhs)+            = mkBoxedTupleTy *** mkBoxedTupleTy+            $ unzip skolem_uni_pairs+      pure $+        counterexample (show skolems) $+        counterexample (show lhs) $+        counterexample (show rhs) $+          case tryUnifyUnivarsButNotSkolems+                 (S.fromList $ mapMaybe tcGetTyVar_maybe skolems)+                 (CType lhs)+                 (CType rhs) of+            Just subst ->+              conjoin $ join $+                [ -- For each pair, running the unification over the univar should+                  -- result in the skolem+                  zip univars skolems <&> \(uni, skolem) ->+                    let substd = substTy subst uni+                    in counterexample (show substd) $+                        counterexample (show skolem) $+                          CType substd === CType skolem++                  -- And also, no two univars should equal to one another+                  -- before or after substitution.+                , zip univars (tail univars) <&> \(uni1, uni2) ->+                    let uni1_sub = substTy subst uni1+                        uni2_sub = substTy subst uni2+                    in counterexample (show uni1) $+                        counterexample (show uni2) $+                          CType uni1 =/= CType uni2 .&&.+                          CType uni1_sub =/= CType uni2_sub+                ]+            Nothing -> True === False+++randomSwap :: (a, a) -> Gen (a, a)+randomSwap ab = do+  which <- arbitrary+  pure $ bool swap id which ab++
+ new/test/Utils.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE RecordWildCards #-}++module Utils where++import           Control.DeepSeq (deepseq)+import qualified Control.Exception as E+import           Control.Lens hiding (List, failing, (<.>), (.=))+import           Control.Monad (unless, void)+import           Control.Monad.IO.Class+import           Data.Aeson+import           Data.Foldable+import           Data.Function (on)+import           Data.IORef (writeIORef)+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Ide.Plugin.Tactic as Tactic+import           Language.LSP.Types+import           Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)+import qualified Language.LSP.Types.Lens as J+import           System.Directory (doesFileExist)+import           System.FilePath+import           Test.Hls+import           Test.Hspec+import           Test.Hspec.Formatters (FailureReason(ExpectedButGot))+import           Wingman.LanguageServer (mkShowMessageParams)+import           Wingman.Types+++plugin :: PluginDescriptor IdeState+plugin = Tactic.descriptor mempty "tactics"++------------------------------------------------------------------------------+-- | Get a range at the given line and column corresponding to having nothing+-- selected.+--+-- NB: These coordinates are in "file space", ie, 1-indexed.+pointRange :: Int -> Int -> Range+pointRange+  (subtract 1 -> fromIntegral -> line)+  (subtract 1 -> fromIntegral -> col) =+    Range (Position line col) (Position line $ col + 1)+++------------------------------------------------------------------------------+-- | Get the title of a code action.+codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle InL{}                               = Nothing+codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title+++resetGlobalHoleRef :: IO ()+resetGlobalHoleRef = writeIORef globalHoleRef 0+++runSessionForTactics :: Session a -> IO a+runSessionForTactics =+  runSessionWithServer'+    [plugin]+    def+    (def { messageTimeout = 20 } )+    fullCaps+    tacticPath++------------------------------------------------------------------------------+-- | Make a tactic unit test.+mkTest+    :: Foldable t+    => String  -- ^ The test name+    -> FilePath  -- ^ The file name stem (without extension) to load+    -> Int  -- ^ Cursor line+    -> Int  -- ^ Cursor column+    -> t ( Bool -> Bool   -- Use 'not' for actions that shouldn't be present+         , TacticCommand  -- An expected command ...+         , Text           -- ... for this variable+         ) -- ^ A collection of (un)expected code actions.+    -> SpecWith (Arg Bool)+mkTest name fp line col ts = it name $ do+  resetGlobalHoleRef+  runSessionForTactics $ do+    doc <- openDoc (fp <.> "hs") "haskell"+    -- wait for diagnostics to start coming+    void waitForDiagnostics+    -- wait for the entire build to finish, so that Tactics code actions that+    -- use stale data will get uptodate stuff+    void $ waitForTypecheck doc+    actions <- getCodeActions doc $ pointRange line col+    let titles = mapMaybe codeActionTitle actions+    for_ ts $ \(f, tc, var) -> do+      let title = tacticTitle tc var+      liftIO $+        (title `elem` titles) `shouldSatisfy` f++data InvokeTactic = InvokeTactic+  { it_command :: TacticCommand+  , it_argument :: Text+  , it_line :: Int+  , it_col :: Int+  }++invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session ()+invokeTactic doc InvokeTactic{..} = do+    -- wait for the entire build to finish, so that Tactics code actions that+    -- use stale data will get uptodate stuff+    void waitForDiagnostics+    void $ waitForTypecheck doc+    actions <- getCodeActions doc $ pointRange it_line it_col+    case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of+      Just (InR CodeAction {_command = Just c}) -> do+          executeCommand c+          void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit+      _ -> error $ show actions+++mkGoldenTest+    :: (Text -> Text -> Assertion)+    -> [InvokeTactic]+    -> FilePath+    -> SpecWith ()+mkGoldenTest eq invocations input =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      traverse_ (invokeTactic doc) invocations+      edited <- documentContents doc+      let expected_name = input <.> "expected" <.> "hs"+      -- Write golden tests if they don't already exist+      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do+          T.writeFile expected_name edited+      expected <- liftIO $ T.readFile expected_name+      liftIO $ edited `eq` expected+++mkCodeLensTest+    :: FilePath+    -> SpecWith ()+mkCodeLensTest input =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForDiagnostics+      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc+      for_ lenses $ \(CodeLens _ (Just cmd) _) ->+        executeCommand cmd+      _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)+      edited <- documentContents doc+      let expected_name = input <.> "expected" <.> "hs"+      -- Write golden tests if they don't already exist+      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do+        T.writeFile expected_name edited+      expected <- liftIO $ T.readFile expected_name+      liftIO $ edited `shouldBe` expected+++------------------------------------------------------------------------------+-- | A test that no code lenses can be run in the file+mkNoCodeLensTest+    :: FilePath+    -> SpecWith ()+mkNoCodeLensTest input =+  it (input <> " (no code lenses)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForBuildQueue+      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc+      liftIO $ lenses `shouldBe` []++++isWingmanLens :: CodeLens -> Bool+isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _)+    = T.isInfixOf ":tactics:" cmd+isWingmanLens _ = False+++mkShowMessageTest+    :: TacticCommand+    -> Text+    -> Int+    -> Int+    -> FilePath+    -> UserFacingMessage+    -> SpecWith ()+mkShowMessageTest tc occ line col input ufm =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc $ pointRange line col+      Just (InR CodeAction {_command = Just c})+        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions+      executeCommand c+      NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage)+      liftIO $ err `shouldBe` mkShowMessageParams ufm+++goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()+goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col]++goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith ()+goldenTestMany = flip $ mkGoldenTest shouldBe++goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()+goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col]+++shouldBeIgnoringSpaces :: Text -> Text -> Assertion+shouldBeIgnoringSpaces = assertFun f ""+  where+    f = (==) `on` T.unwords . T.words+++assertFun+    :: Show a+    => (a -> a -> Bool)+    -> String -- ^ The message prefix+    -> a      -- ^ The expected value+    -> a      -- ^ The actual value+    -> Assertion+assertFun eq preface expected actual =+  unless (eq actual expected) $ do+    (prefaceMsg+      `deepseq` expectedMsg+      `deepseq` actualMsg+      `deepseq`+        E.throwIO+          (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg))+  where+    prefaceMsg+      | null preface = Nothing+      | otherwise = Just preface+    expectedMsg = show expected+    actualMsg = show actual++++------------------------------------------------------------------------------+-- | Don't run a test.+failing :: Applicative m => String -> b -> m ()+failing _ _ = pure ()+++tacticPath :: FilePath+tacticPath = "old/test/golden"+++executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand)+executeCommandWithResp cmd = do+  let args = decode $ encode $ fromJust $ cmd ^. arguments+      execParams = ExecuteCommandParams Nothing (cmd ^. command) args+  request SWorkspaceExecuteCommand execParams+
+ new/test/golden/AutoEmptyString.expected.hs view
@@ -0,0 +1,2 @@+empty_string :: String+empty_string = ""
+ new/test/golden/AutoEmptyString.hs view
@@ -0,0 +1,2 @@+empty_string :: String+empty_string = _
+ new/test/golden/AutoEndo.expected.hs view
@@ -0,0 +1,11 @@+data Synthesized b a = Synthesized+  { syn_trace :: b+  , syn_val   :: a+  }+  deriving (Eq, Show)+++mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a+mapTrace fbb (Synthesized b a)+  = Synthesized {syn_trace = fbb b, syn_val = a}+
+ new/test/golden/AutoEndo.hs view
@@ -0,0 +1,10 @@+data Synthesized b a = Synthesized+  { syn_trace :: b+  , syn_val   :: a+  }+  deriving (Eq, Show)+++mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a+mapTrace = _+
+ new/test/golden/AutoForallClassMethod.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Data.Functor.Contravariant++class Semigroupal cat t1 t2 to f where+  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))++comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d)+comux = case combine of { (Op f) -> f }+
+ new/test/golden/AutoForallClassMethod.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Data.Functor.Contravariant++class Semigroupal cat t1 t2 to f where+  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))++comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d)+comux = _+
+ new/test/golden/AutoInfixApply.expected.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> c) -> a -> (a -> b) -> c+test (/:) a f = a /: f a+
+ new/test/golden/AutoInfixApply.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> c) -> a -> (a -> b) -> c+test (/:) a f = _+
+ new/test/golden/AutoInfixApplyMany.expected.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c+test (/:) a f x = (a /: f a) x+
+ new/test/golden/AutoInfixApplyMany.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c+test (/:) a f x = _+
+ new/test/golden/AutoInfixInfix.expected.hs view
@@ -0,0 +1,2 @@+test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e+test (/:) (-->) a f x = (a /: f a) --> x
+ new/test/golden/AutoInfixInfix.hs view
@@ -0,0 +1,2 @@+test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e+test (/:) (-->) a f x = _
+ new/test/golden/AutoPatSynUse.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}++pattern JustSingleton :: a -> Maybe [a]+pattern JustSingleton a <- Just [a]++amIASingleton :: Maybe [a] -> Maybe a+amIASingleton (JustSingleton a) = Just a+
+ new/test/golden/AutoPatSynUse.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}++pattern JustSingleton :: a -> Maybe [a]+pattern JustSingleton a <- Just [a]++amIASingleton :: Maybe [a] -> Maybe a+amIASingleton (JustSingleton a) = _+
+ new/test/golden/AutoSplitGADT.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}++data GADT b a where+  GBool :: b -> GADT b Bool+  GInt :: GADT b Int++-- wingman would prefer to use GBool since then it can use its argument. But+-- that won't unify with GADT Int, so it is forced to pick GInt and ignore the+-- argument.+test :: b -> GADT b Int+test _ = GInt+
+ new/test/golden/AutoSplitGADT.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}++data GADT b a where+  GBool :: b -> GADT b Bool+  GInt :: GADT b Int++-- wingman would prefer to use GBool since then it can use its argument. But+-- that won't unify with GADT Int, so it is forced to pick GInt and ignore the+-- argument.+test :: b -> GADT b Int+test = _+
+ new/test/golden/AutoThetaEqCtx.expected.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GADTs #-}++fun2 :: (a ~ b) => a -> b+fun2 = id -- id+
+ new/test/golden/AutoThetaEqCtx.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE GADTs #-}++fun2 :: (a ~ b) => a -> b+fun2 = _ -- id+
+ new/test/golden/AutoThetaEqGADT.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data Y a b = a ~ b => Y++fun3 :: Y a b -> a -> b+fun3 Y = id+
+ new/test/golden/AutoThetaEqGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data Y a b = a ~ b => Y++fun3 :: Y a b -> a -> b+fun3 Y = _+
+ new/test/golden/AutoThetaEqGADTDestruct.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE GADTs #-}++data Y a b = a ~ b => Y++fun3 :: Y a b -> a -> b+fun3 Y a = a++
+ new/test/golden/AutoThetaEqGADTDestruct.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE GADTs #-}++data Y a b = a ~ b => Y++fun3 :: Y a b -> a -> b+fun3 = _++
+ new/test/golden/AutoThetaFix.expected.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE UndecidableInstances #-}++data Fix f a = Fix (f (Fix f a))++instance ( Functor f+           -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire+           -- on this case. By explicitly adding the @Functor (Fix f)@+           -- dictionary, we can get Wingman to generate the right definition.+         , Functor (Fix f)+         ) => Functor (Fix f) where+  fmap fab (Fix f) = Fix (fmap (fmap fab) f)+
+ new/test/golden/AutoThetaFix.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE UndecidableInstances #-}++data Fix f a = Fix (f (Fix f a))++instance ( Functor f+           -- FIXME(sandy): Unfortunately, the recursion tactic fails to fire+           -- on this case. By explicitly adding the @Functor (Fix f)@+           -- dictionary, we can get Wingman to generate the right definition.+         , Functor (Fix f)+         ) => Functor (Fix f) where+  fmap = _+
+ new/test/golden/AutoThetaGADT.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data X f = Monad f => X++fun1 :: X f -> a -> f a+fun1 X = pure+
+ new/test/golden/AutoThetaGADT.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data X f = Monad f => X++fun1 :: X f -> a -> f a+fun1 X = _+
+ new/test/golden/AutoThetaGADTDestruct.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data X f = Monad f => X++fun1 :: X f -> a -> f a+fun1 X a = pure a+
+ new/test/golden/AutoThetaGADTDestruct.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data X f = Monad f => X++fun1 :: X f -> a -> f a+fun1 = _+
+ new/test/golden/AutoThetaMultipleUnification.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp AtZ (HCons t _) = t+lookMeUp (AtS ea') (HCons t hl') = _+
+ new/test/golden/AutoThetaMultipleUnification.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp AtZ (HCons t hl') = _+lookMeUp (AtS ea') (HCons t hl') = _+
+ new/test/golden/AutoThetaRankN.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RankNTypes #-}++showMe :: (forall x. Show x => x -> String) -> Int -> String+showMe f = f++showedYou :: Int -> String+showedYou = showMe (\x -> show x)+
+ new/test/golden/AutoThetaRankN.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RankNTypes #-}++showMe :: (forall x. Show x => x -> String) -> Int -> String+showMe f = f++showedYou :: Int -> String+showedYou = showMe (\x -> _)+
+ new/test/golden/AutoThetaRefl.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data Z a b where Z :: Z a a++fun4 :: Z a b -> a -> b+fun4 Z = id -- id+
+ new/test/golden/AutoThetaRefl.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}++data Z a b where Z :: Z a a++fun4 :: Z a b -> a -> b+fun4 Z = _ -- id+
+ new/test/golden/AutoThetaReflDestruct.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE GADTs #-}++data Z a b where Z :: Z a a++fun4 :: Z a b -> a -> b+fun4 Z a = a -- id++
+ new/test/golden/AutoThetaReflDestruct.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE GADTs #-}++data Z a b where Z :: Z a a++fun4 :: Z a b -> a -> b+fun4 = _ -- id++
+ new/test/golden/AutoThetaSplitUnification.expected.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++data A = A+data B = B+data X = X+data Y = Y+++data Pairrow ax by  where+  Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y)++test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y)+test2 = Pairrow+
+ new/test/golden/AutoThetaSplitUnification.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++data A = A+data B = B+data X = X+data Y = Y+++data Pairrow ax by  where+  Pairrow :: (a -> b) -> (x -> y) -> Pairrow '(a, x) '(b, y)++test2 :: (A -> B) -> (X -> Y) -> Pairrow '(A, X) '(B, Y)+test2 = _+
+ new/test/golden/AutoTypeLevel.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp AtZ (HCons t _) = t+lookMeUp (AtS ea') (HCons _ hl') = lookMeUp ea' hl'+
+ new/test/golden/AutoTypeLevel.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp = _+
+ new/test/golden/AutoUnusedPatternMatch.expected.hs view
@@ -0,0 +1,2 @@+test :: Bool -> ()+test _ = ()
+ new/test/golden/AutoUnusedPatternMatch.hs view
@@ -0,0 +1,2 @@+test :: Bool -> ()+test = _
+ new/test/golden/AutoZip.expected.hs view
@@ -0,0 +1,6 @@+zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)]+zip_it_up_and_zip_it_out _ [] = []+zip_it_up_and_zip_it_out [] (_ : _) = []+zip_it_up_and_zip_it_out (a : as') (b : bs')+  = (a, b) : zip_it_up_and_zip_it_out as' bs'+
+ new/test/golden/AutoZip.hs view
@@ -0,0 +1,3 @@+zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)]+zip_it_up_and_zip_it_out = _+
+ new/test/golden/ConProviders.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE GADTs #-}++-- Should suggest Left and Right, but not []+t1 :: Either a b+t1 = _+++data ManyConstructors = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10++noCtorsIfMany :: ManyConstructors+noCtorsIfMany = _+++data GADT a where+  IntGADT  :: GADT Int+  BoolGADT :: GADT Bool+  VarGADT  :: GADT a++gadtCtor :: GADT Int+gadtCtor = _+
+ new/test/golden/DestructAllAnd.expected.hs view
@@ -0,0 +1,5 @@+and :: Bool -> Bool -> Bool+and False False = _w0+and False True = _w1+and True False = _w2+and True True = _w3
+ new/test/golden/DestructAllAnd.hs view
@@ -0,0 +1,2 @@+and :: Bool -> Bool -> Bool+and x y = _
+ new/test/golden/DestructAllFunc.expected.hs view
@@ -0,0 +1,4 @@+has_a_func :: Bool -> (a -> b) -> Bool+has_a_func False y = _w0+has_a_func True y = _w1+
+ new/test/golden/DestructAllFunc.hs view
@@ -0,0 +1,3 @@+has_a_func :: Bool -> (a -> b) -> Bool+has_a_func x y = _+
+ new/test/golden/DestructAllGADTEvidence.expected.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp AtZ (HCons t hl') = _w0+lookMeUp (AtS ea') (HCons t hl') = _w1+
+ new/test/golden/DestructAllGADTEvidence.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators  #-}++import Data.Kind++data Nat = Z | S Nat++data HList (ls :: [Type]) where+  HNil :: HList '[]+  HCons :: t -> HList ts -> HList (t ': ts)++data ElemAt (n :: Nat) t (ts :: [Type]) where+  AtZ :: ElemAt 'Z t (t ': ts)+  AtS :: ElemAt k t ts -> ElemAt ('S k) t (u ': ts)++lookMeUp :: ElemAt i ty tys -> HList tys -> ty+lookMeUp ea hl = _+
+ new/test/golden/DestructAllMany.expected.hs view
@@ -0,0 +1,27 @@+data ABC = A | B | C++many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> ()+many () (Left a) False Nothing A = _w0+many () (Left a) False Nothing B = _w1+many () (Left a) False Nothing C = _w2+many () (Left a) False (Just abc') A = _w3+many () (Left a) False (Just abc') B = _w4+many () (Left a) False (Just abc') C = _w5+many () (Left a) True Nothing A = _w6+many () (Left a) True Nothing B = _w7+many () (Left a) True Nothing C = _w8+many () (Left a) True (Just abc') A = _w9+many () (Left a) True (Just abc') B = _wa+many () (Left a) True (Just abc') C = _wb+many () (Right b') False Nothing A = _wc+many () (Right b') False Nothing B = _wd+many () (Right b') False Nothing C = _we+many () (Right b') False (Just abc') A = _wf+many () (Right b') False (Just abc') B = _wg+many () (Right b') False (Just abc') C = _wh+many () (Right b') True Nothing A = _wi+many () (Right b') True Nothing B = _wj+many () (Right b') True Nothing C = _wk+many () (Right b') True (Just abc') A = _wl+many () (Right b') True (Just abc') B = _wm+many () (Right b') True (Just abc') C = _wn
+ new/test/golden/DestructAllMany.hs view
@@ -0,0 +1,4 @@+data ABC = A | B | C++many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> ()+many u e b mabc abc = _
+ new/test/golden/DestructAllNonVarTopMatch.expected.hs view
@@ -0,0 +1,6 @@+and :: (a, b) -> Bool -> Bool -> Bool+and (a, b) False False = _w0+and (a, b) False True = _w1+and (a, b) True False = _w2+and (a, b) True True = _w3+
+ new/test/golden/DestructAllNonVarTopMatch.hs view
@@ -0,0 +1,3 @@+and :: (a, b) -> Bool -> Bool -> Bool+and (a, b) x y = _+
+ new/test/golden/DestructAllProvider.hs view
@@ -0,0 +1,12 @@+-- we need to name the args ourselves first+nothingToDestruct :: [a] -> [a] -> [a]+nothingToDestruct = _+++-- can't destruct all for non-top-level holes+notTop :: Bool -> Bool -> Bool+notTop a b = a && _++-- destruct all is ok+canDestructAll :: Bool -> Bool -> Bool+canDestructAll a b = _
+ new/test/golden/DestructCthulhu.expected.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GADTs #-}++data FreePro r c a b where+  ID        :: FreePro r c x x+  Comp      :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z+  Copy      :: FreePro r c x (x, x)+  Consume   :: FreePro r c x ()+  Swap      :: FreePro r c (a, b) (b, a)+  SwapE     :: FreePro r c (Either a b) (Either b a)+  Fst       :: FreePro r c (a, b) a+  Snd       :: FreePro r c (a, b) b+  InjectL   :: FreePro r c a (Either a b)+  InjectR   :: FreePro r c b (Either a b)+  Unify     :: FreePro r c (Either a a) a+  First     :: FreePro r c a b -> FreePro r c (a, m) (b, m)+  Second    :: FreePro r c a b -> FreePro r c (m, a) (m, b)+  Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b')+  Fanout    :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b')+  Left'     :: FreePro r c a b -> FreePro r c (Either a x) (Either b x)+  Right'    :: FreePro r c a b -> FreePro r c (Either x a) (Either x b)+  EitherOf  :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b')+  Fanin     :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b+  LiftC     :: c a b -> FreePro r c a b+  Zero      :: FreePro r c x y+  Plus      :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y+  Unleft    :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b+  Unright   :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b+++cthulhu :: FreePro r c a b -> FreePro r c a b+cthulhu ID = _w0+cthulhu (Comp fp' fp_rcyb) = _w1+cthulhu Copy = _w2+cthulhu Consume = _w3+cthulhu Swap = _w4+cthulhu SwapE = _w5+cthulhu Fst = _w6+cthulhu Snd = _w7+cthulhu InjectL = _w8+cthulhu InjectR = _w9+cthulhu Unify = _wa+cthulhu (First fp') = _wb+cthulhu (Second fp') = _wc+cthulhu (Alongside fp' fp_rca'b') = _wd+cthulhu (Fanout fp' fp_rcab') = _we+cthulhu (Left' fp') = _wf+cthulhu (Right' fp') = _wg+cthulhu (EitherOf fp' fp_rca'b') = _wh+cthulhu (Fanin fp' fp_rca'b) = _wi+cthulhu (LiftC cab) = _wj+cthulhu Zero = _wk+cthulhu (Plus fp' fp_rcab) = _wl+cthulhu (Unleft fp') = _wm+cthulhu (Unright fp') = _wn
+ new/test/golden/DestructCthulhu.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE GADTs #-}++data FreePro r c a b where+  ID        :: FreePro r c x x+  Comp      :: FreePro r c x y -> FreePro r c y z -> FreePro r c x z+  Copy      :: FreePro r c x (x, x)+  Consume   :: FreePro r c x ()+  Swap      :: FreePro r c (a, b) (b, a)+  SwapE     :: FreePro r c (Either a b) (Either b a)+  Fst       :: FreePro r c (a, b) a+  Snd       :: FreePro r c (a, b) b+  InjectL   :: FreePro r c a (Either a b)+  InjectR   :: FreePro r c b (Either a b)+  Unify     :: FreePro r c (Either a a) a+  First     :: FreePro r c a b -> FreePro r c (a, m) (b, m)+  Second    :: FreePro r c a b -> FreePro r c (m, a) (m, b)+  Alongside :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (a, a') (b, b')+  Fanout    :: FreePro r c a b -> FreePro r c a b' -> FreePro r c a (b, b')+  Left'     :: FreePro r c a b -> FreePro r c (Either a x) (Either b x)+  Right'    :: FreePro r c a b -> FreePro r c (Either x a) (Either x b)+  EitherOf  :: FreePro r c a b -> FreePro r c a' b' -> FreePro r c (Either a a') (Either b b')+  Fanin     :: FreePro r c a b -> FreePro r c a' b -> FreePro r c (Either a a') b+  LiftC     :: c a b -> FreePro r c a b+  Zero      :: FreePro r c x y+  Plus      :: FreePro r c x y -> FreePro r c x y -> FreePro r c x y+  Unleft    :: FreePro r c (Either a d) (Either b d) -> FreePro r c a b+  Unright   :: FreePro r c (Either d a) (Either d b) -> FreePro r c a b+++cthulhu :: FreePro r c a b -> FreePro r c a b+cthulhu fp = _
+ new/test/golden/DestructDataFam.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeFamilies #-}++data family Yo+data instance Yo = Heya Int++test :: Yo -> Int+test (Heya n) = _w0+
+ new/test/golden/DestructDataFam.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeFamilies #-}++data family Yo+data instance Yo = Heya Int++test :: Yo -> Int+test b = _+
+ new/test/golden/DestructInt.expected.hs view
@@ -0,0 +1,7 @@+import Data.Int++data Test = Test Int32++test :: Test -> Int32+test (Test in') = _w0+
+ new/test/golden/DestructInt.hs view
@@ -0,0 +1,7 @@+import Data.Int++data Test = Test Int32++test :: Test -> Int32+test t = _+
+ new/test/golden/DestructPun.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}+++data Foo = Foo { a :: Bool, b :: Bool }++foo Foo {a = False, b} = _w0+foo Foo {a = True, b} = _w1+
+ new/test/golden/DestructPun.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE NamedFieldPuns #-}+++data Foo = Foo { a :: Bool, b :: Bool }++foo Foo {a, b} = _+
+ new/test/golden/DestructTyFam.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE TypeFamilies #-}++type family Yo where+  Yo = Bool++test :: Yo -> Int+test False = _w0+test True = _w1+
+ new/test/golden/DestructTyFam.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TypeFamilies #-}++type family Yo where+  Yo = Bool++test :: Yo -> Int+test b = _+
+ new/test/golden/DestructTyToDataFam.expected.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++type family T1 a where+  T1 a = T2 Int++type family T2 a+type instance T2 Int = T3++type family T3 where+  T3 = Yo++data family Yo+data instance Yo = Heya Int++test :: T1 Bool -> Int+test (Heya n) = _w0+
+ new/test/golden/DestructTyToDataFam.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++type family T1 a where+  T1 a = T2 Int++type family T2 a+type instance T2 Int = T3++type family T3 where+  T3 = Yo++data family Yo+data instance Yo = Heya Int++test :: T1 Bool -> Int+test b = _+
+ new/test/golden/EmptyCaseADT.expected.hs view
@@ -0,0 +1,8 @@+data Foo = A Int | B Bool | C++foo :: Foo -> ()+foo x = case x of+  A n -> _+  B b -> _+  C -> _+
+ new/test/golden/EmptyCaseADT.hs view
@@ -0,0 +1,5 @@+data Foo = A Int | B Bool | C++foo :: Foo -> ()+foo x = case x of+
+ new/test/golden/EmptyCaseApply.expected.hs view
@@ -0,0 +1,3 @@+blah = case show 5 of+  [] -> _+  c : s -> _
+ new/test/golden/EmptyCaseApply.hs view
@@ -0,0 +1,1 @@+blah = case show 5 of
+ new/test/golden/EmptyCaseGADT.expected.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  MyInt :: GADT Int+  MyBool :: GADT Bool+  MyVar :: GADT a+++test :: GADT Int -> GADT Bool+test x = case x of+  MyInt -> _+  MyVar -> _+
+ new/test/golden/EmptyCaseGADT.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  MyInt :: GADT Int+  MyBool :: GADT Bool+  MyVar :: GADT a+++test :: GADT Int -> GADT Bool+test x = case x of+
+ new/test/golden/EmptyCaseLamCase.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE LambdaCase #-}++test :: Bool -> Bool+test = \case+  False -> _+  True -> _
+ new/test/golden/EmptyCaseLamCase.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE LambdaCase #-}++test :: Bool -> Bool+test = \case
+ new/test/golden/EmptyCaseNested.expected.hs view
@@ -0,0 +1,5 @@+test =+  case (case (Just "") of+  Nothing -> _+  Just s -> _) of+    True -> _
+ new/test/golden/EmptyCaseNested.hs view
@@ -0,0 +1,3 @@+test =+  case (case (Just "") of) of+    True -> _
+ new/test/golden/EmptyCaseParens.expected.hs view
@@ -0,0 +1,3 @@+test = True && (case True of+   False -> _+   True -> _)
+ new/test/golden/EmptyCaseParens.hs view
@@ -0,0 +1,1 @@+test = True && case True of
+ new/test/golden/EmptyCaseShadow.expected.hs view
@@ -0,0 +1,10 @@+data Foo = A Int | B Bool | C++-- Make sure we don't shadow the i and b bindings when we empty case+-- split+foo :: Int -> Bool -> Foo -> ()+foo i b x = case x of+  A n -> _+  B b' -> _+  C -> _+
+ new/test/golden/EmptyCaseShadow.hs view
@@ -0,0 +1,7 @@+data Foo = A Int | B Bool | C++-- Make sure we don't shadow the i and b bindings when we empty case+-- split+foo :: Int -> Bool -> Foo -> ()+foo i b x = case x of+
+ new/test/golden/EmptyCaseSpuriousGADT.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE GADTs #-}++data Foo a where+  Foo :: Foo Int++foo :: Foo Bool -> ()+foo x = case x of+
+ new/test/golden/Fgmap.expected.hs view
@@ -0,0 +1,2 @@+fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b))+fgmap = fmap . fmap
+ new/test/golden/Fgmap.hs view
@@ -0,0 +1,2 @@+fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b))+fgmap = _
+ new/test/golden/FmapBoth.expected.hs view
@@ -0,0 +1,3 @@+fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b)+fmapBoth fab (fa, ga) = (fmap fab fa, fmap fab ga)+
+ new/test/golden/FmapBoth.hs view
@@ -0,0 +1,3 @@+fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b)+fmapBoth = _+
+ new/test/golden/FmapJoin.expected.hs view
@@ -0,0 +1,2 @@+fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a)+fJoin = fmap (\ m -> m >>= id)
+ new/test/golden/FmapJoin.hs view
@@ -0,0 +1,2 @@+fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a)+fJoin = fmap _
+ new/test/golden/FmapJoinInLet.expected.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}++fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a)+fJoin =  let f = ( (\ m -> m >>= id) :: m (m a) -> m a) in fmap f
+ new/test/golden/FmapJoinInLet.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-}++fJoin :: forall f m a. (Monad m, Monad f) => f (m (m a)) -> f (m a)+fJoin =  let f = (_ :: m (m a) -> m a) in fmap f
+ new/test/golden/GoldenApplicativeThen.hs view
@@ -0,0 +1,2 @@+useThen :: Applicative f => f Int -> f a -> f a+useThen = _
+ new/test/golden/GoldenArbitrary.expected.hs view
@@ -0,0 +1,53 @@+-- Emulate a quickcheck import; deriveArbitrary works on any type with the+-- right name and kind+data Gen a++data Obj+  = Square Int Int+  | Circle Int+  | Polygon [(Int, Int)]+  | Rotate2 Double Obj+  | Empty+  | Full+  | Complement Obj+  | UnionR Double [Obj]+  | DifferenceR Double Obj [Obj]+  | IntersectR Double [Obj]+  | Translate Double Double Obj+  | Scale Double Double Obj+  | Mirror Double Double Obj+  | Outset Double Obj+  | Shell Double Obj+  | WithRounding Double Obj+++arbitrary :: Gen Obj+arbitrary+  = let+      terminal+        = [(Square <$> arbitrary) <*> arbitrary, Circle <$> arbitrary,+           Polygon <$> arbitrary, pure Empty, pure Full]+    in+      sized+        $ (\ n+             -> case n <= 1 of+                  True -> oneof terminal+                  False+                    -> oneof+                         $ ([(Rotate2 <$> arbitrary) <*> scale (subtract 1) arbitrary,+                             Complement <$> scale (subtract 1) arbitrary,+                             (UnionR <$> arbitrary) <*> scale (subtract 1) arbitrary,+                             ((DifferenceR <$> arbitrary) <*> scale (flip div 2) arbitrary)+                               <*> scale (flip div 2) arbitrary,+                             (IntersectR <$> arbitrary) <*> scale (subtract 1) arbitrary,+                             ((Translate <$> arbitrary) <*> arbitrary)+                               <*> scale (subtract 1) arbitrary,+                             ((Scale <$> arbitrary) <*> arbitrary)+                               <*> scale (subtract 1) arbitrary,+                             ((Mirror <$> arbitrary) <*> arbitrary)+                               <*> scale (subtract 1) arbitrary,+                             (Outset <$> arbitrary) <*> scale (subtract 1) arbitrary,+                             (Shell <$> arbitrary) <*> scale (subtract 1) arbitrary,+                             (WithRounding <$> arbitrary) <*> scale (subtract 1) arbitrary]+                              <> terminal))+
+ new/test/golden/GoldenArbitrary.hs view
@@ -0,0 +1,26 @@+-- Emulate a quickcheck import; deriveArbitrary works on any type with the+-- right name and kind+data Gen a++data Obj+  = Square Int Int+  | Circle Int+  | Polygon [(Int, Int)]+  | Rotate2 Double Obj+  | Empty+  | Full+  | Complement Obj+  | UnionR Double [Obj]+  | DifferenceR Double Obj [Obj]+  | IntersectR Double [Obj]+  | Translate Double Double Obj+  | Scale Double Double Obj+  | Mirror Double Double Obj+  | Outset Double Obj+  | Shell Double Obj+  | WithRounding Double Obj+++arbitrary :: Gen Obj+arbitrary = _+
+ new/test/golden/GoldenArbitrarySingleConstructor.expected.hs view
@@ -0,0 +1,7 @@+data Gen a++data Obj = Obj Int Bool Char String++arbitrary :: Gen Obj+arbitrary+  = (((Obj <$> arbitrary) <*> arbitrary) <*> arbitrary) <*> arbitrary
+ new/test/golden/GoldenArbitrarySingleConstructor.hs view
@@ -0,0 +1,6 @@+data Gen a++data Obj = Obj Int Bool Char String++arbitrary :: Gen Obj+arbitrary = _
+ new/test/golden/GoldenBigTuple.expected.hs view
@@ -0,0 +1,4 @@+-- There used to be a bug where we were unable to perform a nested split. The+-- more serious regression test of this is 'AutoTupleSpec'.+bigTuple :: (a, b, c, d) -> (a, b, (c, d))+bigTuple (a, b, c, d) = (a, b, (c, d))
+ new/test/golden/GoldenBigTuple.hs view
@@ -0,0 +1,4 @@+-- There used to be a bug where we were unable to perform a nested split. The+-- more serious regression test of this is 'AutoTupleSpec'.+bigTuple :: (a, b, c, d) -> (a, b, (c, d))+bigTuple = _
+ new/test/golden/GoldenEitherAuto.expected.hs view
@@ -0,0 +1,3 @@+either' :: (a -> c) -> (b -> c) -> Either a b -> c+either' fac _ (Left a) = fac a+either' _ fbc (Right b) = fbc b
+ new/test/golden/GoldenEitherAuto.hs view
@@ -0,0 +1,2 @@+either' :: (a -> c) -> (b -> c) -> Either a b -> c+either' = _
+ new/test/golden/GoldenEitherHomomorphic.expected.hs view
@@ -0,0 +1,3 @@+eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c+eitherSplit a (Left fab) = Left (fab a)+eitherSplit a (Right fac) = Right (fac a)
+ new/test/golden/GoldenEitherHomomorphic.hs view
@@ -0,0 +1,2 @@+eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c+eitherSplit = _
+ new/test/golden/GoldenFish.hs view
@@ -0,0 +1,5 @@+-- There was an old bug where we would only pull skolems from the hole, rather+-- than the entire hypothesis. Because of this, the 'b' here would be+-- considered a univar, which could then be unified with the skolem 'c'.+fish :: Monad m => (a -> m b) -> (b -> m c) -> a -> m c+fish amb bmc a = _
+ new/test/golden/GoldenFmapTree.expected.hs view
@@ -0,0 +1,5 @@+data Tree a = Leaf a | Branch (Tree a) (Tree a)++instance Functor Tree where+   fmap fab (Leaf a) = Leaf (fab a)+   fmap fab (Branch tr' tr_a) = Branch (fmap fab tr') (fmap fab tr_a)
+ new/test/golden/GoldenFmapTree.hs view
@@ -0,0 +1,4 @@+data Tree a = Leaf a | Branch (Tree a) (Tree a)++instance Functor Tree where+   fmap = _
+ new/test/golden/GoldenFoldr.expected.hs view
@@ -0,0 +1,3 @@+foldr2 :: (a -> b -> b) -> b -> [a] -> b+foldr2 _ b [] = b+foldr2 fabb b (a : as') = fabb a (foldr2 fabb b as')
+ new/test/golden/GoldenFoldr.hs view
@@ -0,0 +1,2 @@+foldr2 :: (a -> b -> b) -> b -> [a] -> b+foldr2 = _
+ new/test/golden/GoldenFromMaybe.expected.hs view
@@ -0,0 +1,3 @@+fromMaybe :: a -> Maybe a -> a+fromMaybe a Nothing = a+fromMaybe _ (Just a') = a'
+ new/test/golden/GoldenFromMaybe.hs view
@@ -0,0 +1,2 @@+fromMaybe :: a -> Maybe a -> a+fromMaybe = _
+ new/test/golden/GoldenGADTAuto.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}+module GoldenGADTAuto where+data CtxGADT a where+  MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a++ctxGADT :: CtxGADT ()+ctxGADT = MkCtxGADT ()
+ new/test/golden/GoldenGADTAuto.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}+module GoldenGADTAuto where+data CtxGADT a where+  MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a++ctxGADT :: CtxGADT ()+ctxGADT = _auto
+ new/test/golden/GoldenGADTDestruct.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}+module GoldenGADTDestruct where+data CtxGADT where+  MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT++ctxGADT :: CtxGADT -> String+ctxGADT (MkCtxGADT a) = _w0
+ new/test/golden/GoldenGADTDestruct.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}+module GoldenGADTDestruct where+data CtxGADT where+  MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT++ctxGADT :: CtxGADT -> String+ctxGADT gadt = _decons
+ new/test/golden/GoldenGADTDestructCoercion.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+module GoldenGADTDestruct where+data E a b where+  E :: forall a b. (b ~ a, Ord a) => b -> E a [a]++ctxGADT :: E a b -> String+ctxGADT (E b) = _w0
+ new/test/golden/GoldenGADTDestructCoercion.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+module GoldenGADTDestruct where+data E a b where+  E :: forall a b. (b ~ a, Ord a) => b -> E a [a]++ctxGADT :: E a b -> String+ctxGADT gadt = _decons
+ new/test/golden/GoldenIdTypeFam.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}++type family TyFam+type instance TyFam = Int++tyblah' :: TyFam -> Int+tyblah' = id
+ new/test/golden/GoldenIdTypeFam.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TypeFamilies #-}++type family TyFam+type instance TyFam = Int++tyblah' :: TyFam -> Int+tyblah' = _
+ new/test/golden/GoldenIdentityFunctor.expected.hs view
@@ -0,0 +1,3 @@+data Ident a = Ident a+instance Functor Ident where+   fmap fab (Ident a) = Ident (fab a)
+ new/test/golden/GoldenIdentityFunctor.hs view
@@ -0,0 +1,3 @@+data Ident a = Ident a+instance Functor Ident where+   fmap = _
+ new/test/golden/GoldenIntros.expected.hs view
@@ -0,0 +1,2 @@+blah :: Int -> Bool -> (a -> b) -> String -> Int+blah n b fab s = _w0
+ new/test/golden/GoldenIntros.hs view
@@ -0,0 +1,2 @@+blah :: Int -> Bool -> (a -> b) -> String -> Int+blah = _
+ new/test/golden/GoldenJoinCont.expected.hs view
@@ -0,0 +1,4 @@+type Cont r a = ((a -> r) -> r)++joinCont :: Cont r (Cont r a) -> Cont r a+joinCont f far = f (\ g -> g far)
+ new/test/golden/GoldenJoinCont.hs view
@@ -0,0 +1,4 @@+type Cont r a = ((a -> r) -> r)++joinCont :: Cont r (Cont r a) -> Cont r a+joinCont = _
+ new/test/golden/GoldenListFmap.expected.hs view
@@ -0,0 +1,3 @@+fmapList :: (a -> b) -> [a] -> [b]+fmapList _ [] = []+fmapList fab (a : as') = fab a : fmapList fab as'
+ new/test/golden/GoldenListFmap.hs view
@@ -0,0 +1,2 @@+fmapList :: (a -> b) -> [a] -> [b]+fmapList = _
+ new/test/golden/GoldenNote.expected.hs view
@@ -0,0 +1,3 @@+note :: e -> Maybe a -> Either e a+note e Nothing = Left e+note _ (Just a) = Right a
+ new/test/golden/GoldenNote.hs view
@@ -0,0 +1,2 @@+note :: e -> Maybe a -> Either e a+note = _
+ new/test/golden/GoldenPureList.expected.hs view
@@ -0,0 +1,2 @@+pureList :: a -> [a]+pureList a = a : []
+ new/test/golden/GoldenPureList.hs view
@@ -0,0 +1,2 @@+pureList :: a -> [a]+pureList = _
+ new/test/golden/GoldenSafeHead.expected.hs view
@@ -0,0 +1,3 @@+safeHead :: [x] -> Maybe x+safeHead [] = Nothing+safeHead (x : _) = Just x
+ new/test/golden/GoldenSafeHead.hs view
@@ -0,0 +1,2 @@+safeHead :: [x] -> Maybe x+safeHead = _
+ new/test/golden/GoldenShow.expected.hs view
@@ -0,0 +1,2 @@+showMe :: Show a => a -> String+showMe = show
+ new/test/golden/GoldenShow.hs view
@@ -0,0 +1,2 @@+showMe :: Show a => a -> String+showMe = _
+ new/test/golden/GoldenShowCompose.expected.hs view
@@ -0,0 +1,2 @@+showCompose :: Show a => (b -> a) -> b -> String+showCompose fba = show . fba
+ new/test/golden/GoldenShowCompose.hs view
@@ -0,0 +1,2 @@+showCompose :: Show a => (b -> a) -> b -> String+showCompose = _
+ new/test/golden/GoldenShowMapChar.expected.hs view
@@ -0,0 +1,2 @@+test :: Show a => a -> (String -> b) -> b+test a f = f (show a)
+ new/test/golden/GoldenShowMapChar.hs view
@@ -0,0 +1,2 @@+test :: Show a => a -> (String -> b) -> b+test = _
+ new/test/golden/GoldenSuperclass.expected.hs view
@@ -0,0 +1,8 @@+class Super a where+    super :: a++class Super a => Sub a++blah :: Sub a => a+blah = super+
+ new/test/golden/GoldenSuperclass.hs view
@@ -0,0 +1,8 @@+class Super a where+    super :: a++class Super a => Sub a++blah :: Sub a => a+blah = _+
+ new/test/golden/GoldenSwap.expected.hs view
@@ -0,0 +1,2 @@+swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)
+ new/test/golden/GoldenSwap.hs view
@@ -0,0 +1,2 @@+swap :: (a, b) -> (b, a)+swap = _
+ new/test/golden/GoldenSwapMany.expected.hs view
@@ -0,0 +1,2 @@+swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)+swapMany (a, b, c, d, e) = (e, d, c, b, a)
+ new/test/golden/GoldenSwapMany.hs view
@@ -0,0 +1,2 @@+swapMany :: (a, b, c, d, e) -> (e, d, c, b, a)+swapMany = _
+ new/test/golden/IntroDestructLetBinding.expected.hs view
@@ -0,0 +1,6 @@+test :: IO ()+test = do+  let x :: Bool -> Int+      x False = _w0+      x True = _w1+  pure ()
+ new/test/golden/IntroDestructLetBinding.hs view
@@ -0,0 +1,5 @@+test :: IO ()+test = do+  let x :: Bool -> Int+      x = _+  pure ()
+ new/test/golden/IntroDestructMany.expected.hs view
@@ -0,0 +1,4 @@+x :: Bool -> Maybe Int -> String -> Int+x False = _w0+x True = _w1+
+ new/test/golden/IntroDestructMany.hs view
@@ -0,0 +1,3 @@+x :: Bool -> Maybe Int -> String -> Int+x = _+
+ new/test/golden/IntroDestructOne.expected.hs view
@@ -0,0 +1,6 @@+module Test where++x :: Bool -> Int+x False = _w0+x True = _w1+
+ new/test/golden/IntroDestructOne.hs view
@@ -0,0 +1,5 @@+module Test where++x :: Bool -> Int+x = _+
+ new/test/golden/IntroDestructProvider.hs view
@@ -0,0 +1,9 @@+hasAlgTy :: Maybe Int -> Int+hasAlgTy = _++hasFunTy :: (Int -> Int) -> Int+hasFunTy = _++isSaturated :: Bool -> Int+isSaturated b = _+
+ new/test/golden/IntrosTooMany.expected.hs view
@@ -0,0 +1,2 @@+too_many :: a -> b -> c+too_many a b = _w0
+ new/test/golden/IntrosTooMany.hs view
@@ -0,0 +1,2 @@+too_many :: a -> b -> c+too_many = [wingman| intros a b c d e f g h i j k l m n o p q r s t u v w x y z |]
+ new/test/golden/KnownBigSemigroup.expected.hs view
@@ -0,0 +1,9 @@+import Data.Monoid++data Big a = Big [Bool] (Sum Int) String (Endo a) Any++instance Semigroup (Big a) where+  (Big bs sum s en any) <> (Big bs' sum' str en' any')+    = Big+        (bs <> bs') (sum <> sum') (s <> str) (en <> en') (any <> any')+
+ new/test/golden/KnownBigSemigroup.hs view
@@ -0,0 +1,7 @@+import Data.Monoid++data Big a = Big [Bool] (Sum Int) String (Endo a) Any++instance Semigroup (Big a) where+  (<>) = _+
+ new/test/golden/KnownCounterfactualSemigroup.expected.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE UndecidableInstances #-}++data Semi = Semi [String] Int++instance Semigroup Int => Semigroup Semi where+  (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) (n <> i)+
+ new/test/golden/KnownCounterfactualSemigroup.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE UndecidableInstances #-}++data Semi = Semi [String] Int++instance Semigroup Int => Semigroup Semi where+  (<>) = _+
+ new/test/golden/KnownDestructedSemigroup.expected.hs view
@@ -0,0 +1,5 @@+data Test a = Test [a]++instance Semigroup (Test a) where+  (Test a) <> (Test c) = Test (a <> c)+
+ new/test/golden/KnownDestructedSemigroup.hs view
@@ -0,0 +1,5 @@+data Test a = Test [a]++instance Semigroup (Test a) where+  Test a <> Test c = _+
+ new/test/golden/KnownMissingMonoid.expected.hs view
@@ -0,0 +1,8 @@+data Mono a = Monoid [String] a++instance Semigroup (Mono a) where+  (<>) = undefined++instance Monoid (Mono a) where+  mempty = Monoid mempty _w0+
+ new/test/golden/KnownMissingMonoid.hs view
@@ -0,0 +1,8 @@+data Mono a = Monoid [String] a++instance Semigroup (Mono a) where+  (<>) = undefined++instance Monoid (Mono a) where+  mempty = _+
+ new/test/golden/KnownMissingSemigroup.expected.hs view
@@ -0,0 +1,5 @@+data Semi = Semi [String] Int++instance Semigroup Semi where+  (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _w0+
+ new/test/golden/KnownMissingSemigroup.hs view
@@ -0,0 +1,5 @@+data Semi = Semi [String] Int++instance Semigroup Semi where+  (<>) = _+
+ new/test/golden/KnownModuleInstanceSemigroup.expected.hs view
@@ -0,0 +1,12 @@+data Foo = Foo++instance Semigroup Foo where+  (<>) _ _ = Foo+++data Bar = Bar Foo Foo++instance Semigroup Bar where+  (Bar foo foo') <> (Bar foo2 foo3)+    = Bar (foo <> foo2) (foo' <> foo3)+
+ new/test/golden/KnownModuleInstanceSemigroup.hs view
@@ -0,0 +1,11 @@+data Foo = Foo++instance Semigroup Foo where+  (<>) _ _ = Foo+++data Bar = Bar Foo Foo++instance Semigroup Bar where+  (<>) = _+
+ new/test/golden/KnownMonoid.expected.hs view
@@ -0,0 +1,8 @@+data Mono = Monoid [String]++instance Semigroup Mono where+  (<>) = undefined++instance Monoid Mono where+  mempty = Monoid mempty+
+ new/test/golden/KnownMonoid.hs view
@@ -0,0 +1,8 @@+data Mono = Monoid [String]++instance Semigroup Mono where+  (<>) = undefined++instance Monoid Mono where+  mempty = _+
+ new/test/golden/KnownPolyMonoid.expected.hs view
@@ -0,0 +1,8 @@+data Mono a = Monoid [String] a++instance Semigroup (Mono a) where+  (<>) = undefined++instance Monoid a => Monoid (Mono a) where+  mempty = Monoid mempty mempty+
+ new/test/golden/KnownPolyMonoid.hs view
@@ -0,0 +1,8 @@+data Mono a = Monoid [String] a++instance Semigroup (Mono a) where+  (<>) = undefined++instance Monoid a => Monoid (Mono a) where+  mempty = _+
+ new/test/golden/KnownThetaSemigroup.expected.hs view
@@ -0,0 +1,5 @@+data Semi a = Semi a++instance Semigroup a => Semigroup (Semi a) where+  (Semi a) <> (Semi a') = Semi (a <> a')+
+ new/test/golden/KnownThetaSemigroup.hs view
@@ -0,0 +1,5 @@+data Semi a = Semi a++instance Semigroup a => Semigroup (Semi a) where+  (<>) = _+
+ new/test/golden/LayoutBind.expected.hs view
@@ -0,0 +1,8 @@+test :: Bool -> IO ()+test b = do+  putStrLn "hello"+  case b of+    False -> _w0+    True -> _w1+  pure ()+
+ new/test/golden/LayoutBind.hs view
@@ -0,0 +1,6 @@+test :: Bool -> IO ()+test b = do+  putStrLn "hello"+  _+  pure ()+
+ new/test/golden/LayoutDollarApp.expected.hs view
@@ -0,0 +1,5 @@+test :: Bool -> Bool+test b = id $ (case b of+   False -> _w0+   True -> _w1)+
+ new/test/golden/LayoutDollarApp.hs view
@@ -0,0 +1,3 @@+test :: Bool -> Bool+test b = id $ _+
+ new/test/golden/LayoutInfixKeep.expected.hs view
@@ -0,0 +1,5 @@+-- keep layout that was written by the user in infix+foo :: Bool -> a -> a+False `foo` a = _w0+True `foo` a = _w1+
+ new/test/golden/LayoutInfixKeep.hs view
@@ -0,0 +1,4 @@+-- keep layout that was written by the user in infix+foo :: Bool -> a -> a+b `foo` a = _+
+ new/test/golden/LayoutLam.expected.hs view
@@ -0,0 +1,5 @@+test :: Bool -> Bool+test = \b -> case b of+  False -> _w0+  True -> _w1+
+ new/test/golden/LayoutLam.hs view
@@ -0,0 +1,3 @@+test :: Bool -> Bool+test = \b -> _+
+ new/test/golden/LayoutOpApp.expected.hs view
@@ -0,0 +1,4 @@+test :: Bool -> Bool+test b = True && (case b of+   False -> _w0+   True -> _w1)
+ new/test/golden/LayoutOpApp.hs view
@@ -0,0 +1,2 @@+test :: Bool -> Bool+test b = True && _
+ new/test/golden/LayoutPrefixKeep.expected.hs view
@@ -0,0 +1,4 @@+(-/) :: Bool -> a -> a+(-/) False a = _w0+(-/) True a = _w1+
+ new/test/golden/LayoutPrefixKeep.hs view
@@ -0,0 +1,3 @@+(-/) :: Bool -> a -> a+(-/) b a = _+
+ new/test/golden/LayoutRec.expected.hs view
@@ -0,0 +1,5 @@+data Pair a b = Pair {pa :: a, pb :: b}++p :: Pair (a -> a) (a -> b -> c -> b)+p = Pair {pa = _, pb = \ a b c -> _w0}+
+ new/test/golden/LayoutRec.hs view
@@ -0,0 +1,5 @@+data Pair a b = Pair {pa :: a, pb :: b}++p :: Pair (a -> a) (a -> b -> c -> b)+p = Pair {pa = _, pb = _}+
+ new/test/golden/LayoutSplitClass.expected.hs view
@@ -0,0 +1,5 @@+class Test a where+  test :: Bool -> a+  test False = _w0+  test True = _w1+
+ new/test/golden/LayoutSplitClass.hs view
@@ -0,0 +1,4 @@+class Test a where+  test :: Bool -> a+  test x = _+
+ new/test/golden/LayoutSplitGuard.expected.hs view
@@ -0,0 +1,5 @@+test :: Bool -> Bool -> Bool+test a b+  | a = case b of+  False -> _w0+  True -> _w1
+ new/test/golden/LayoutSplitGuard.hs view
@@ -0,0 +1,3 @@+test :: Bool -> Bool -> Bool+test a b+  | a = _
+ new/test/golden/LayoutSplitIn.expected.hs view
@@ -0,0 +1,5 @@+test :: a+test =+  let a = (1,"bbb")+   in case a of { (n, s) -> _w0 }+
+ new/test/golden/LayoutSplitIn.hs view
@@ -0,0 +1,5 @@+test :: a+test =+  let a = (1,"bbb")+   in _+
+ new/test/golden/LayoutSplitLet.expected.hs view
@@ -0,0 +1,7 @@+test :: a+test =+  let t :: Bool -> a+      t False = _w0+      t True = _w1+   in _+
+ new/test/golden/LayoutSplitLet.hs view
@@ -0,0 +1,6 @@+test :: a+test =+  let t :: Bool -> a+      t b = _+   in _+
+ new/test/golden/LayoutSplitPatSyn.expected.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE PatternSynonyms #-}++pattern JustSingleton :: a -> Maybe [a]+pattern JustSingleton a <- Just [a]+++test :: Maybe [Bool] -> Maybe Bool+test (JustSingleton False) = _w0+test (JustSingleton True) = _w1++
+ new/test/golden/LayoutSplitPatSyn.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE PatternSynonyms #-}++pattern JustSingleton :: a -> Maybe [a]+pattern JustSingleton a <- Just [a]+++test :: Maybe [Bool] -> Maybe Bool+test (JustSingleton a) = _++
+ new/test/golden/LayoutSplitPattern.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE PatternSynonyms #-}++pattern Blah :: a -> Maybe a+pattern Blah a = Just a++test :: Maybe Bool -> a+test (Blah False) = _w0+test (Blah True) = _w1+
+ new/test/golden/LayoutSplitPattern.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}++pattern Blah :: a -> Maybe a+pattern Blah a = Just a++test :: Maybe Bool -> a+test (Blah a) = _+
+ new/test/golden/LayoutSplitViewPat.expected.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE ViewPatterns #-}++splitLookup :: [(Int, String)] -> String+splitLookup (lookup 5 -> Nothing) = _w0+splitLookup (lookup 5 -> (Just s)) = _w1+
+ new/test/golden/LayoutSplitViewPat.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ViewPatterns #-}++splitLookup :: [(Int, String)] -> String+splitLookup (lookup 5 -> a) = _+
+ new/test/golden/LayoutSplitWhere.expected.hs view
@@ -0,0 +1,14 @@+data A = A | B | C++some :: A -> IO ()+some a = do+    foo+    bar a+  where+      foo = putStrLn "Hi"++      bar :: A -> IO ()+      bar A = _w0+      bar B = _w1+      bar C = _w2+
+ new/test/golden/LayoutSplitWhere.hs view
@@ -0,0 +1,12 @@+data A = A | B | C++some :: A -> IO ()+some a = do+    foo+    bar a+  where+      foo = putStrLn "Hi"++      bar :: A -> IO ()+      bar x = _+
+ new/test/golden/MessageCantUnify.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds, GADTs #-}++data Z ab where+  Z :: (a -> b) -> Z '(a, b)++test :: Z ab+test = _+
+ new/test/golden/MessageForallA.hs view
@@ -0,0 +1,2 @@+test :: a+test = _
+ new/test/golden/MessageNotEnoughGas.hs view
@@ -0,0 +1,13 @@+test+   :: (a1 -> a2)+   -> (a2 -> a3)+   -> (a3 -> a4)+   -> (a4 -> a5)+   -> (a5 -> a6)+   -> (a6 -> a7)+   -> (a7 -> a8)+   -> (a8 -> a9)+   -> (a9 -> a10)+   -> a1 -> a10+test = _+
+ new/test/golden/MetaBegin.expected.hs view
@@ -0,0 +1,1 @@+foo = [wingman||]
+ new/test/golden/MetaBegin.hs view
@@ -0,0 +1,1 @@+foo = _
+ new/test/golden/MetaBeginNoWildify.expected.hs view
@@ -0,0 +1,2 @@+foo v = [wingman||]+
+ new/test/golden/MetaBeginNoWildify.hs view
@@ -0,0 +1,2 @@+foo v = _+
+ new/test/golden/MetaBindAll.expected.hs view
@@ -0,0 +1,2 @@+foo :: a -> (a, a)+foo a = (a, a)
+ new/test/golden/MetaBindAll.hs view
@@ -0,0 +1,2 @@+foo :: a -> (a, a)+foo a = [wingman| split; assumption |]
+ new/test/golden/MetaBindOne.expected.hs view
@@ -0,0 +1,2 @@+foo :: a -> (a, a)+foo a = (a, _w0)
+ new/test/golden/MetaBindOne.hs view
@@ -0,0 +1,2 @@+foo :: a -> (a, a)+foo a = [wingman| split, assumption |]
+ new/test/golden/MetaCataAST.expected.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE GADTs #-}++data AST a where+    BoolLit :: Bool -> AST Bool+    IntLit :: Int -> AST Int+    If :: AST Bool -> AST a -> AST a -> AST a+    Equal :: AST a -> AST a -> AST Bool++eval :: AST a -> a+eval (BoolLit b) = b+eval (IntLit n) = n+eval (If ast ast' ast_a)+  = let+      ast_c = eval ast+      ast'_c = eval ast'+      ast_a_c = eval ast_a+    in _w0 ast_c ast'_c ast_a_c+eval (Equal ast ast')+  = let+      ast_c = eval ast+      ast'_c = eval ast'+    in _w1 ast_c ast'_c+
+ new/test/golden/MetaCataAST.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE GADTs #-}++data AST a where+    BoolLit :: Bool -> AST Bool+    IntLit :: Int -> AST Int+    If :: AST Bool -> AST a -> AST a -> AST a+    Equal :: AST a -> AST a -> AST Bool++eval :: AST a -> a+eval = [wingman| intros x, cata x; collapse |]+
+ new/test/golden/MetaCataCollapse.expected.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE TypeOperators #-}++import GHC.Generics++class Yo f where+    yo :: f x -> Int++instance (Yo f, Yo g) => Yo (f :*: g) where+  yo (fx :*: gx)+    = let+        fx_c = yo fx+        gx_c = yo gx+      in _w0 fx_c gx_c+
+ new/test/golden/MetaCataCollapse.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeOperators #-}++import GHC.Generics++class Yo f where+    yo :: f x -> Int++instance (Yo f, Yo g) => Yo (f :*: g) where+  yo = [wingman| intros x, cata x, collapse |]+
+ new/test/golden/MetaCataCollapseUnary.expected.hs view
@@ -0,0 +1,8 @@+import GHC.Generics++class Yo f where+    yo :: f x -> Int++instance (Yo f) => Yo (M1 _1 _2 f) where+  yo (M1 fx) = yo fx+
+ new/test/golden/MetaCataCollapseUnary.hs view
@@ -0,0 +1,8 @@+import GHC.Generics++class Yo f where+    yo :: f x -> Int++instance (Yo f) => Yo (M1 _1 _2 f) where+  yo = [wingman| intros x, cata x, collapse |]+
+ new/test/golden/MetaChoice.expected.hs view
@@ -0,0 +1,2 @@+reassoc :: (a, (b, c)) -> ((a, b), c)+reassoc (a, (b, c)) = ((a, b), c)
+ new/test/golden/MetaChoice.hs view
@@ -0,0 +1,2 @@+reassoc :: (a, (b, c)) -> ((a, b), c)+reassoc (a, (b, c)) = [wingman| split; split | assume c; assume a | assume b |]
+ new/test/golden/MetaDeepOf.expected.hs view
@@ -0,0 +1,8 @@+whats_it_deep_of+    :: (a -> a)+    -> [(Int, Either Bool (Maybe [a]))]+    -> [(Int, Either Bool (Maybe [a]))]+-- The assumption here is necessary to tie-break in favor of the longest+-- nesting of fmaps.+whats_it_deep_of f = fmap (fmap (fmap (fmap (fmap f))))+
+ new/test/golden/MetaDeepOf.hs view
@@ -0,0 +1,8 @@+whats_it_deep_of+    :: (a -> a)+    -> [(Int, Either Bool (Maybe [a]))]+    -> [(Int, Either Bool (Maybe [a]))]+-- The assumption here is necessary to tie-break in favor of the longest+-- nesting of fmaps.+whats_it_deep_of f = [wingman| nested fmap, assumption |]+
+ new/test/golden/MetaFundeps.expected.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}++class Blah a b | a -> b, b -> a+instance Blah Int Bool++foo :: Int+foo = 10++bar :: Blah a b => a -> b+bar = undefined++qux :: Bool+qux = bar foo++
+ new/test/golden/MetaFundeps.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}++class Blah a b | a -> b, b -> a+instance Blah Int Bool++foo :: Int+foo = 10++bar :: Blah a b => a -> b+bar = undefined++qux :: Bool+qux = [wingman| use bar, use foo |]++
+ new/test/golden/MetaIdiom.expected.hs view
@@ -0,0 +1,6 @@+foo :: Int -> Int -> Int+foo = undefined++test :: Maybe Int+test = (foo <$> _w0) <*> _w1+
+ new/test/golden/MetaIdiom.hs view
@@ -0,0 +1,6 @@+foo :: Int -> Int -> Int+foo = undefined++test :: Maybe Int+test = [wingman| idiom (use foo) |]+
+ new/test/golden/MetaIdiomRecord.expected.hs view
@@ -0,0 +1,8 @@+data Rec = Rec+  { a :: Int+  , b :: Bool+  }++test :: Maybe Rec+test = (Rec <$> _w0) <*> _w1+
+ new/test/golden/MetaIdiomRecord.hs view
@@ -0,0 +1,8 @@+data Rec = Rec+  { a :: Int+  , b :: Bool+  }++test :: Maybe Rec+test = [wingman| idiom (ctor Rec) |]+
+ new/test/golden/MetaLetSimple.expected.hs view
@@ -0,0 +1,7 @@+test :: Int+test+  = let+      a = _w0+      b = _w1+      c = _w2+    in _w3
+ new/test/golden/MetaLetSimple.hs view
@@ -0,0 +1,2 @@+test :: Int+test = [wingman| let a b c |]
+ new/test/golden/MetaMaybeAp.expected.hs view
@@ -0,0 +1,5 @@+maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b+maybeAp Nothing Nothing = Nothing+maybeAp Nothing (Just _) = Nothing+maybeAp (Just _) Nothing = Nothing+maybeAp (Just fab) (Just a) = Just (fab a)
+ new/test/golden/MetaMaybeAp.hs view
@@ -0,0 +1,11 @@+maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b+maybeAp = [wingman|+  intros,+  destruct_all,+  obvious,+  obvious,+  obvious,+  ctor Just,+  application,+  assumption+  |]
+ new/test/golden/MetaPointwise.expected.hs view
@@ -0,0 +1,8 @@+import Data.Monoid++data Foo = Foo (Sum Int) (Sum Int)++mappend2 :: Foo -> Foo -> Foo+mappend2 (Foo sum sum') (Foo sum2 sum3)+  = Foo (mappend sum sum2) (mappend sum' sum3)+
+ new/test/golden/MetaPointwise.hs view
@@ -0,0 +1,7 @@+import Data.Monoid++data Foo = Foo (Sum Int) (Sum Int)++mappend2 :: Foo -> Foo -> Foo+mappend2 = [wingman| intros f1 f2, destruct_all, ctor Foo; pointwise (use mappend); assumption|]+
+ new/test/golden/MetaTry.expected.hs view
@@ -0,0 +1,2 @@+foo :: a -> (b, a)+foo a = (_w0, a)
+ new/test/golden/MetaTry.hs view
@@ -0,0 +1,2 @@+foo :: a -> (b, a)+foo a = [wingman| split; try (assumption) |]
+ new/test/golden/MetaUseImport.expected.hs view
@@ -0,0 +1,6 @@+import Data.Char+++result :: Char -> Bool+result = isAlpha+
+ new/test/golden/MetaUseImport.hs view
@@ -0,0 +1,6 @@+import Data.Char+++result :: Char -> Bool+result = [wingman| intro c, use isAlpha, assume c |]+
+ new/test/golden/MetaUseLocal.expected.hs view
@@ -0,0 +1,7 @@+test :: Int+test = 0+++resolve :: Int+resolve = test+
+ new/test/golden/MetaUseLocal.hs view
@@ -0,0 +1,7 @@+test :: Int+test = 0+++resolve :: Int+resolve = [wingman| use test |]+
+ new/test/golden/MetaUseMethod.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses #-}++class Test where+  test :: Int++instance Test where+  test = 10+++resolve :: Int+resolve = test+
+ new/test/golden/MetaUseMethod.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE MultiParamTypeClasses #-}++class Test where+  test :: Int++instance Test where+  test = 10+++resolve :: Int+resolve = [wingman| use test |]+
+ new/test/golden/MetaUseSymbol.expected.hs view
@@ -0,0 +1,4 @@+import Data.Monoid++resolve :: Sum Int+resolve = _w0 <> _w1
+ new/test/golden/MetaUseSymbol.hs view
@@ -0,0 +1,4 @@+import Data.Monoid++resolve :: Sum Int+resolve = [wingman| use (<>) |]
+ new/test/golden/MetaWithArg.expected.hs view
@@ -0,0 +1,2 @@+wat :: a -> b+wat a = _w0 a
+ new/test/golden/MetaWithArg.hs view
@@ -0,0 +1,2 @@+wat :: a -> b+wat a = [wingman| with_arg, assumption |]
+ new/test/golden/NewtypeRecord.expected.hs view
@@ -0,0 +1,7 @@+newtype MyRecord a = Record+    { field1 :: a+    }++blah :: (a -> Int) -> a -> MyRecord a+blah _ = Record+
+ new/test/golden/NewtypeRecord.hs view
@@ -0,0 +1,7 @@+newtype MyRecord a = Record+    { field1 :: a+    }++blah :: (a -> Int) -> a -> MyRecord a+blah = _+
+ new/test/golden/ProvideAlreadyDestructed.hs view
@@ -0,0 +1,9 @@+foo :: Bool -> ()+foo x =+  if True+    then+      case x of+        True  -> _+        False -> ()+    else+      _
+ new/test/golden/ProvideLocalHyOnly.hs view
@@ -0,0 +1,2 @@+basilisk :: Monoid Bool => a+basilisk = _
+ new/test/golden/ProviderHomomorphism.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE GADTs      #-}+{-# LANGUAGE LambdaCase #-}++data GADT a where+  B1 :: GADT Bool+  B2 :: GADT Bool+  Int :: GADT Int+  Var :: GADT a+++hasHomo :: GADT Bool -> GADT a+hasHomo g = _++cantHomo :: GADT a -> GADT Int+cantHomo g = _++hasHomoLam :: GADT Bool -> GADT a+hasHomoLam = _++cantHomoLam :: GADT a -> GADT Int+cantHomoLam = _+
+ new/test/golden/PunGADT.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  GADT ::+    { blah :: Int+    , bar :: a+    } -> GADT a+++split :: GADT a -> a+split GADT {blah, bar} = _w0+
+ new/test/golden/PunGADT.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  GADT ::+    { blah :: Int+    , bar :: a+    } -> GADT a+++split :: GADT a -> a+split x = _+
+ new/test/golden/PunMany.expected.hs view
@@ -0,0 +1,8 @@+data Many+  = Hello { world :: String }+  | Goodbye { a :: Int, b :: Bool, c :: Many }++test :: Many -> Many+test Hello {world} = _w0+test Goodbye {a, b, c} = _w1+
+ new/test/golden/PunMany.hs view
@@ -0,0 +1,7 @@+data Many+  = Hello { world :: String }+  | Goodbye { a :: Int, b :: Bool, c :: Many }++test :: Many -> Many+test x = _+
+ new/test/golden/PunManyGADT.expected.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  GADT ::+    { blah :: Int+    , bar :: a+    } -> GADT a+  Bar ::+    { zoo :: Bool+    , baxter :: a+    , another :: a+    } -> GADT Bool+  Baz :: GADT Int+++split :: GADT Bool -> a+split GADT {blah, bar} = _w0+split Bar {zoo, baxter, another} = _w1+
+ new/test/golden/PunManyGADT.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  GADT ::+    { blah :: Int+    , bar :: a+    } -> GADT a+  Bar ::+    { zoo :: Bool+    , baxter :: a+    , another :: a+    } -> GADT Bool+  Baz :: GADT Int+++split :: GADT Bool -> a+split x = _+
+ new/test/golden/PunShadowing.expected.hs view
@@ -0,0 +1,5 @@+data Bar = Bar { ax :: Int, bax :: Bool }++bar :: () -> Bar -> Int+bar ax Bar {ax = n, bax} = _w0+
+ new/test/golden/PunShadowing.hs view
@@ -0,0 +1,5 @@+data Bar = Bar { ax :: Int, bax :: Bool }++bar :: () -> Bar -> Int+bar ax x = _+
+ new/test/golden/PunSimple.expected.hs view
@@ -0,0 +1,5 @@+data Bar = Bar { ax :: Int, bax :: Bool }++bar :: Bar -> Int+bar Bar {ax, bax} = _w0+
+ new/test/golden/PunSimple.hs view
@@ -0,0 +1,5 @@+data Bar = Bar { ax :: Int, bax :: Bool }++bar :: Bar -> Int+bar x = _+
+ new/test/golden/RecordCon.expected.hs view
@@ -0,0 +1,9 @@+data MyRecord a = Record+    { field1 :: a+    , field2 :: Int+    }++blah :: (a -> Int) -> a -> MyRecord a+blah f a = Record {field1 = a, field2 = f a}++
+ new/test/golden/RecordCon.hs view
@@ -0,0 +1,9 @@+data MyRecord a = Record+    { field1 :: a+    , field2 :: Int+    }++blah :: (a -> Int) -> a -> MyRecord a+blah = _++
+ new/test/golden/RefineCon.expected.hs view
@@ -0,0 +1,3 @@+test :: ((), (b, c), d)+test = (_w0, _w1, _w2)+
+ new/test/golden/RefineCon.hs view
@@ -0,0 +1,3 @@+test :: ((), (b, c), d)+test = _+
+ new/test/golden/RefineGADT.expected.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  One :: (b -> Int) -> GADT Int+  Two :: GADT Bool++test :: z -> GADT Int+test z = One _w0+
+ new/test/golden/RefineGADT.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE GADTs #-}++data GADT a where+  One :: (b -> Int) -> GADT Int+  Two :: GADT Bool++test :: z -> GADT Int+test z = _+
+ new/test/golden/RefineIntro.expected.hs view
@@ -0,0 +1,2 @@+test :: a -> Either a b+test a = _w0
+ new/test/golden/RefineIntro.hs view
@@ -0,0 +1,2 @@+test :: a -> Either a b+test = _
+ new/test/golden/RefineIntroWhere.expected.hs view
@@ -0,0 +1,6 @@+test :: Maybe Int -> Int+test = \ m_n -> _w0+  where+    -- Don't delete me!+    blah = undefined+
+ new/test/golden/RefineIntroWhere.hs view
@@ -0,0 +1,6 @@+test :: Maybe Int -> Int+test = _+  where+    -- Don't delete me!+    blah = undefined+
+ new/test/golden/RefineReader.expected.hs view
@@ -0,0 +1,5 @@+newtype Reader r a = Reader (r -> a)++test :: b -> Reader r a+test b = Reader _w0+
+ new/test/golden/RefineReader.hs view
@@ -0,0 +1,5 @@+newtype Reader r a = Reader (r -> a)++test :: b -> Reader r a+test b = _+
+ new/test/golden/SplitPattern.expected.hs view
@@ -0,0 +1,12 @@+data ADT = One | Two Int | Three | Four Bool ADT | Five++case_split :: ADT -> Int+case_split One        = _+case_split (Two i)    = _+case_split Three      = _+case_split (Four b One) = _w0+case_split (Four b (Two n)) = _w1+case_split (Four b Three) = _w2+case_split (Four b (Four b' adt)) = _w3+case_split (Four b Five) = _w4+case_split Five       = _
+ new/test/golden/SplitPattern.hs view
@@ -0,0 +1,8 @@+data ADT = One | Two Int | Three | Four Bool ADT | Five++case_split :: ADT -> Int+case_split One        = _+case_split (Two i)    = _+case_split Three      = _+case_split (Four b a) = _+case_split Five       = _
+ new/test/golden/SubsequentTactics.expected.hs view
@@ -0,0 +1,5 @@+data Dummy a = Dummy a++f :: Dummy Int -> Int+f (Dummy n) = n+
+ new/test/golden/SubsequentTactics.hs view
@@ -0,0 +1,5 @@+data Dummy a = Dummy a++f :: Dummy Int -> Int+f = _+
+ new/test/golden/T1.hs view
@@ -0,0 +1,3 @@+fmapEither :: (a -> b) -> Either c a -> Either c b+fmapEither = _lalala+
+ new/test/golden/T2.hs view
@@ -0,0 +1,12 @@+eitherFmap :: (a -> b) -> Either e a -> Either e b+eitherFmap fa eab = _++global :: Bool+global = True++foo :: Int+foo  = _++dontSuggestLambdaCase :: Either a b -> Int+dontSuggestLambdaCase = _+
+ new/test/golden/T3.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE LambdaCase #-}++suggestHomomorphicLC :: Either a b -> Either a b+suggestHomomorphicLC = _++suggestLC :: Either a b -> Int+suggestLC = _+
+ new/test/golden/UseConLeft.expected.hs view
@@ -0,0 +1,3 @@+test :: Either a b+test = Left _w0+
+ new/test/golden/UseConLeft.hs view
@@ -0,0 +1,3 @@+test :: Either a b+test = _+
+ new/test/golden/UseConPair.expected.hs view
@@ -0,0 +1,2 @@+test :: (a, b)+test = (_w0, _w1)
+ new/test/golden/UseConPair.hs view
@@ -0,0 +1,2 @@+test :: (a, b)+test = _
+ new/test/golden/UseConRight.expected.hs view
@@ -0,0 +1,3 @@+test :: Either a b+test = Right _w0+
+ new/test/golden/UseConRight.hs view
@@ -0,0 +1,3 @@+test :: Either a b+test = _+
+ new/test/golden/hie.yaml view
@@ -0,0 +1,1 @@+cradle: {direct: {arguments: ["T1", "T2", "T3"]}}
+ new/test/golden/test.cabal view
@@ -0,0 +1,17 @@+name:                test+version:             0.1.0.0+-- synopsis:+-- description:+license:             BSD3+author:              Author name here+maintainer:          example@example.com+copyright:           2017 Author name here+category:            Web+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     T1, T2+  build-depends:       base >= 4.7 && < 5+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-unused-imports
+ old/src/Ide/Plugin/Tactic.hs view
@@ -0,0 +1,5 @@+-- | A plugin that uses tactics to synthesize code+module Ide.Plugin.Tactic (descriptor, Log(..)) where++import Wingman.Plugin+
+ old/src/Refinery/Future.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE RankNTypes #-}++------------------------------------------------------------------------------+-- | Things that belong in the future release of refinery v5.+module Refinery.Future+  ( runStreamingTacticT+  , hoistListT+  , consume+  ) where++import Control.Applicative+import Control.Monad (ap, (>=>))+import Control.Monad.State.Lazy (runStateT)+import Control.Monad.Trans+import Data.Either (isRight)+import Data.Functor ((<&>))+import Data.Tuple (swap)+import Refinery.ProofState+import Refinery.Tactic.Internal++++hoistElem :: Functor m => (forall x. m x -> n x) -> Elem m a -> Elem n a+hoistElem _ Done = Done+hoistElem f (Next a lt) = Next a $ hoistListT f lt+++hoistListT :: Functor m => (forall x. m x -> n x) -> ListT m a -> ListT n a+hoistListT f t = ListT $ f $ fmap (hoistElem f) $ unListT t+++consume :: Monad m => ListT m a -> (a -> m ()) -> m ()+consume lt f = unListT lt >>= \case+  Done -> pure ()+  Next a lt' -> f a >> consume lt' f+++newHole :: MonadExtract meta ext err s m => s -> m (s, (meta, ext))+newHole = fmap swap . runStateT hole++runStreamingTacticT :: (MonadExtract meta ext err s m) => TacticT jdg ext err s m () -> jdg -> s -> ListT m (Either err (Proof s meta jdg ext))+runStreamingTacticT t j s = streamProofs s $ fmap snd $ proofState t j++data Elem m a+    = Done+    | Next a (ListT m a)+    deriving stock Functor+++point :: Applicative m => a -> Elem m a+point a = Next a $ ListT $ pure Done++newtype ListT m a = ListT { unListT :: m (Elem m a) }++cons :: (Applicative m) => a -> ListT m a -> ListT m a+cons x xs = ListT $ pure $ Next x xs++instance Functor m => Functor (ListT m) where+    fmap f (ListT xs) = ListT $ xs <&> \case+        Done -> Done+        Next a xs -> Next (f a) (fmap f xs)++instance (Monad m) => Applicative (ListT m) where+    pure = return+    (<*>) = ap++instance (Monad m) => Alternative (ListT m) where+    empty = ListT $ pure Done+    (ListT xs) <|> (ListT ys) =+        ListT $ xs >>= \case+          Done -> ys+          Next x xs -> pure (Next x (xs <|> ListT ys))++instance (Monad m) => Monad (ListT m) where+    return a = cons a empty+    (ListT xs) >>= k =+        ListT $ xs >>= \case+          Done -> pure Done+          Next x xs -> unListT $ k x <|> (xs >>= k)+++instance MonadTrans ListT where+    lift m = ListT $ fmap (\x -> Next x empty) m+++interleaveT :: (Monad m) => Elem m a -> Elem m a -> Elem m a+interleaveT xs ys =+    case xs of+      Done -> ys+      Next x xs -> Next x $ ListT $ fmap (interleaveT ys) $ unListT xs++--         ys <&> \case+--           Done -> Next x xs+--           Next y ys -> Next x (cons y (interleaveT xs ys))++force :: (Monad m) => Elem m a -> m [a]+force = \case+    Done -> pure []+    Next x xs' -> (x:) <$> (unListT xs' >>= force)++ofList :: Monad m => [a] -> Elem m a+ofList [] = Done+ofList (x:xs) = Next x $ ListT $ pure $ ofList xs++streamProofs :: forall ext err s m goal meta. (MonadExtract meta ext err s m) => s -> ProofStateT ext ext err s m goal -> ListT m (Either err (Proof s meta goal ext))+streamProofs s p = ListT $ go s [] pure p+    where+      go :: s -> [(meta, goal)] -> (err -> m err) -> ProofStateT ext ext err s m goal -> m (Elem m (Either err (Proof s meta goal ext)))+      go s goals _ (Subgoal goal k) = do+         (s', (meta, h)) <- newHole s+         -- Note [Handler Reset]:+         -- We reset the handler stack to avoid the handlers leaking across subgoals.+         -- This would happen when we had a handler that wasn't followed by an error call.+         --     pair >> goal >>= \g -> (handler_ $ \_ -> traceM $ "Handling " <> show g) <|> failure "Error"+         -- We would see the "Handling a" message when solving for b.+         go s' (goals ++ [(meta, goal)]) pure $ k h+      go s goals handlers (Effect m) = m >>= go s goals handlers+      go s goals handlers (Stateful f) =+          let (s', p) = f s+          in go s' goals handlers p+      go s goals handlers (Alt p1 p2) =+          unListT $ ListT (go s goals handlers p1) <|> ListT (go s goals handlers p2)+      go s goals handlers (Interleave p1 p2) =+          interleaveT <$> go s goals handlers p1 <*> go s goals handlers p2+      go s goals handlers (Commit p1 p2) = do+          solns <- force =<< go s goals handlers p1+          if any isRight solns then pure $ ofList solns else go s goals handlers p2+      go _ _ _ Empty = pure Done+      go _ _ handlers (Failure err _) = do+          annErr <- handlers err+          pure $ point $ Left annErr+      go s goals handlers (Handle p h) =+          -- Note [Handler ordering]:+          -- If we have multiple handlers in scope, then we want the handlers closer to the error site to+          -- run /first/. This allows the handlers up the stack to add their annotations on top of the+          -- ones lower down, which is the behavior that we desire.+          -- IE: for @handler f >> handler g >> failure err@, @g@ ought to be run before @f@.+          go s goals (h >=> handlers) p+      go s goals _ (Axiom ext) = pure $ point $ Right (Proof ext s goals)+
+ old/src/Wingman/AbstractLSP.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecordWildCards     #-}++{-# LANGUAGE NoMonoLocalBinds    #-}++{-# OPTIONS_GHC -Wno-orphans     #-}++module Wingman.AbstractLSP (installInteractions) where++import           Control.Monad (void)+import           Control.Monad.IO.Class+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import qualified Data.Aeson as A+import           Data.Coerce+import           Data.Foldable (traverse_)+import           Data.Monoid (Last (..))+import qualified Data.Text as T+import           Data.Traversable (for)+import           Data.Tuple.Extra (uncurry3)+import           Development.IDE (IdeState)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.ExactPrint (GetAnnotatedParsedSource(GetAnnotatedParsedSource))+import qualified Ide.Plugin.Config as Plugin+import           Ide.Types+import           Language.LSP.Server (LspM, sendRequest, getClientCapabilities)+import qualified Language.LSP.Types as LSP+import           Language.LSP.Types hiding (CodeLens, CodeAction)+import           Wingman.AbstractLSP.Types+import           Wingman.EmptyCase (fromMaybeT)+import           Wingman.LanguageServer (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams)+import           Wingman.StaticPlugin (enableQuasiQuotes)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are+-- self-contained request/response pairs that abstract over the LSP, and+-- provide a unified interface for doing interesting things, without needing to+-- dive into the underlying API too directly.+installInteractions+    :: [Interaction]+    -> PluginDescriptor IdeState+    -> PluginDescriptor IdeState+installInteractions is desc =+  let plId = pluginId desc+   in desc+        { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is+        , pluginHandlers = pluginHandlers desc <> buildHandlers is+        }+++------------------------------------------------------------------------------+-- | Extract 'PluginHandlers' from 'Interaction's.+buildHandlers+    :: [Interaction]+    -> PluginHandlers IdeState+buildHandlers cs =+  flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) ->+    case c_makeCommand c of+      SynthesizeCodeAction k ->+        mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k+      SynthesizeCodeLens k ->+        mkPluginHandler STextDocumentCodeLens   $ codeLensProvider   @target (c_sort c) k+++------------------------------------------------------------------------------+-- | Extract a 'PluginCommand' from an 'Interaction'.+buildCommand+  :: PluginId+  -> Interaction+  -> PluginCommand IdeState+buildCommand plId (Interaction (c :: Continuation sort target b)) =+  PluginCommand+    { commandId = toCommandId $ c_sort c+    , commandDesc = T.pack ""+    , commandFunc = runContinuation plId c+    }+++------------------------------------------------------------------------------+-- | Boilerplate for running a 'Continuation' as part of an LSP command.+runContinuation+    :: forall sort a b+     . IsTarget a+    => PluginId+    -> Continuation sort a b+    -> CommandFunction IdeState (FileContext, b)+runContinuation plId cont state (fc, b) = do+  fromMaybeT+    (Left $ ResponseError+              { _code = InternalError+              , _message = T.pack "TODO(sandy)"+              , _xdata =  Nothing+              } ) $ do+      env@LspEnv{..} <- buildEnv state plId fc+      nfp <- getNfp $ fc_uri le_fileContext+      let stale a = runStaleIde "runContinuation" state nfp a+      args <- fetchTargetArgs @a env+      res <- c_runCommand cont env args fc b++      -- This block returns a maybe error.+      fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $+        for res $ \case+          ErrorMessages errs -> do+            traverse_ showUserFacingMessage errs+            pure Nothing+          RawEdit edits -> do+            sendEdits edits+            pure Nothing+          GraftEdit gr -> do+            ccs <- lift getClientCapabilities+            TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+            case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of+              Left errs ->+                pure $ Just $ ResponseError+                  { _code    = InternalError+                  , _message = T.pack $ show errs+                  , _xdata   = Nothing+                  }+              Right edits -> do+                sendEdits edits+                pure Nothing+++------------------------------------------------------------------------------+-- | Push a 'WorkspaceEdit' to the client.+sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) ()+sendEdits edits =+  void $ lift $+    sendRequest+      SWorkspaceApplyEdit+      (ApplyWorkspaceEditParams Nothing edits)+      (const $ pure ())+++------------------------------------------------------------------------------+-- | Push a 'UserFacingMessage' to the client.+showUserFacingMessage+    :: UserFacingMessage+    -> MaybeT (LspM Plugin.Config) ()+showUserFacingMessage ufm =+  void $ lift $ showLspMessage $ mkShowMessageParams ufm+++------------------------------------------------------------------------------+-- | Build an 'LspEnv', which contains the majority of things we need to know+-- in a 'Continuation'.+buildEnv+    :: IdeState+    -> PluginId+    -> FileContext+    -> MaybeT (LspM Plugin.Config) LspEnv+buildEnv state plId fc = do+  cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId+  nfp <- getNfp $ fc_uri fc+  dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp+  pure $ LspEnv+    { le_ideState = state+    , le_pluginId = plId+    , le_dflags   = dflags+    , le_config   = cfg+    , le_fileContext = fc+    }+++------------------------------------------------------------------------------+-- | Lift a 'Continuation' into an LSP CodeAction.+codeActionProvider+    :: forall target sort b+     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)+    => sort+    -> ( LspEnv+     -> TargetArgs target+     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]+       )+    -> PluginMethodHandler IdeState TextDocumentCodeAction+codeActionProvider sort k state plId+                   (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do+  fromMaybeT (Right $ List []) $ do+    let fc = FileContext+                { fc_uri   = uri+                , fc_range = Just $ unsafeMkCurrent range+                }+    env <- buildEnv state plId fc+    args <- fetchTargetArgs @target env+    actions <- k env args+    pure+      $ Right+      $ List+      $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions+++------------------------------------------------------------------------------+-- | Lift a 'Continuation' into an LSP CodeLens.+codeLensProvider+    :: forall target sort b+     . (IsContinuationSort sort, A.ToJSON b, IsTarget target)+    => sort+    -> ( LspEnv+     -> TargetArgs target+     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]+      )+    -> PluginMethodHandler IdeState TextDocumentCodeLens+codeLensProvider sort k state plId+                 (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do+      fromMaybeT (Right $ List []) $ do+        let fc = FileContext+                   { fc_uri   = uri+                   , fc_range = Nothing+                   }+        env <- buildEnv state plId fc+        args <- fetchTargetArgs @target env+        actions <- k env args+        pure+          $ Right+          $ List+          $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions+++------------------------------------------------------------------------------+-- | Build a 'LSP.CodeAction'.+makeCodeAction+    :: (A.ToJSON b, IsContinuationSort sort)+    => PluginId+    -> FileContext+    -> sort+    -> Metadata+    -> b+    -> LSP.CodeAction+makeCodeAction plId fc sort (Metadata title kind preferred) b =+  let cmd_id = toCommandId sort+      cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)]+   in LSP.CodeAction+        { _title       = title+        , _kind        = Just kind+        , _diagnostics = Nothing+        , _isPreferred = Just preferred+        , _disabled    = Nothing+        , _edit        = Nothing+        , _command     = Just cmd+        , _xdata       = Nothing+        }+++------------------------------------------------------------------------------+-- | Build a 'LSP.CodeLens'.+makeCodeLens+    :: (A.ToJSON b, IsContinuationSort sort)+    => PluginId+    -> sort+    -> FileContext+    -> Range+    -> Metadata+    -> b+    -> LSP.CodeLens+makeCodeLens plId sort fc range (Metadata title _ _) b =+  let fc' = fc { fc_range = Just $ unsafeMkCurrent range }+      cmd_id = toCommandId sort+      cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)]+   in LSP.CodeLens+        { _range = range+        , _command = Just cmd+        , _xdata = Nothing+        }+
+ old/src/Wingman/AbstractLSP/TacticActions.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE RecordWildCards  #-}++{-# LANGUAGE NoMonoLocalBinds #-}++module Wingman.AbstractLSP.TacticActions where++import           Control.Monad (when)+import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans (lift)+import           Control.Monad.Trans.Maybe (mapMaybeT)+import           Data.Foldable+import           Data.Maybe (listToMaybe)+import           Data.Proxy+import           Development.IDE hiding (rangeToRealSrcSpan)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.ExactPrint+import           Generics.SYB.GHC (mkBindListT, everywhereM')+import           Wingman.AbstractLSP.Types+import           Wingman.CaseSplit+import           Wingman.GHC (liftMaybe, isHole, pattern AMatch)+import           Wingman.Judgements (jNeedsToBindArgs)+import           Wingman.LanguageServer (runStaleIde)+import           Wingman.LanguageServer.TacticProviders+import           Wingman.Machinery (runTactic, scoreSolution)+import           Wingman.Range+import           Wingman.Types+import Development.IDE.Core.Service (getIdeOptionsIO)+import Development.IDE.Types.Options (IdeTesting(IdeTesting), IdeOptions (IdeOptions, optTesting))+++------------------------------------------------------------------------------+-- | An 'Interaction' for a 'TacticCommand'.+makeTacticInteraction+    :: TacticCommand+    -> Interaction+makeTacticInteraction cmd =+  Interaction $ Continuation @_ @HoleTarget cmd+    (SynthesizeCodeAction $ \env hj -> do+      pure $ commandProvider cmd $+            TacticProviderData+              { tpd_lspEnv    = env+              , tpd_jdg       = hj_jdg hj+              , tpd_hole_sort = hj_hole_sort hj+              }+    )+    $ \LspEnv{..} HoleJudgment{..} FileContext{..} var_name -> do+        nfp <- getNfp fc_uri+        let stale a = runStaleIde "tacticCmd" le_ideState nfp a++        let span = fmap (rangeToRealSrcSpan (fromNormalizedFilePath nfp)) hj_range+        TrackedStale _ pmmap <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+        pm_span <- liftMaybe $ mapAgeFrom pmmap span+        IdeOptions{optTesting = IdeTesting isTesting} <-+            liftIO $ getIdeOptionsIO (shakeExtras le_ideState)++        let t = commandTactic cmd var_name+            timeout = if isTesting then maxBound else cfg_timeout_seconds le_config * seconds++        liftIO $ runTactic timeout hj_ctx hj_jdg t >>= \case+          Left err ->+            pure+              $ pure+              $ ErrorMessages+              $ pure+              $ mkUserFacingMessage err+          Right rtr ->+            case rtr_extract rtr of+              L _ (HsVar _ (L _ rdr)) | isHole (occName rdr) ->+                pure+                  $ addTimeoutMessage rtr+                  $ pure+                  $ ErrorMessages+                  $ pure NothingToDo+              _ -> do+                for_ (rtr_other_solns rtr) $ \soln -> do+                  traceMX "other solution" $ syn_val soln+                  traceMX "with score" $ scoreSolution soln (rtr_jdg rtr) []+                traceMX "solution" $ rtr_extract rtr+                pure+                  $ addTimeoutMessage rtr+                  $ pure+                  $ GraftEdit+                  $ graftHole (RealSrcSpan (unTrack pm_span) Nothing) rtr+++addTimeoutMessage :: RunTacticResults -> [ContinuationResult] -> [ContinuationResult]+addTimeoutMessage rtr = mappend+  [ ErrorMessages $ pure TimedOut+  | rtr_timed_out rtr+  ]+++------------------------------------------------------------------------------+-- | The number of microseconds in a second+seconds :: Num a => a+seconds = 1e6+++------------------------------------------------------------------------------+-- | Transform some tactic errors into a 'UserFacingMessage'.+mkUserFacingMessage :: [TacticError] -> UserFacingMessage+mkUserFacingMessage errs+  | elem OutOfGas errs = NotEnoughGas+mkUserFacingMessage [] = NothingToDo+mkUserFacingMessage _ = TacticErrors+++------------------------------------------------------------------------------+-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly+-- deals with top-level holes, in which we might need to fiddle with the+-- 'Match's that bind variables.+graftHole+    :: SrcSpan+    -> RunTacticResults+    -> Graft (Either String) ParsedSource+graftHole span rtr+  | _jIsTopHole (rtr_jdg rtr)+      = genericGraftWithSmallestM+            (Proxy @(Located [LMatch GhcPs (LHsExpr GhcPs)])) span+      $ \dflags matches ->+          everywhereM'+            $ mkBindListT $ \ix ->+              graftDecl dflags span ix $ \name pats ->+              splitToDecl+                (case not $ jNeedsToBindArgs (rtr_jdg rtr) of+                   -- If the user has explicitly bound arguments, use the+                   -- fixity they wrote.+                   True -> matchContextFixity . m_ctxt . unLoc+                             =<< listToMaybe matches+                   -- Otherwise, choose based on the name of the function.+                   False -> Nothing+                )+                (occName name)+            $ iterateSplit+            $ mkFirstAgda pats+            $ unLoc+            $ rtr_extract rtr+graftHole span rtr+  = graft span+  $ rtr_extract rtr+++------------------------------------------------------------------------------+-- | Keep a fixity if one was present in the 'HsMatchContext'.+matchContextFixity :: HsMatchContext p -> Maybe LexicalFixity+matchContextFixity (FunRhs _ l _) = Just l+matchContextFixity _ = Nothing+++------------------------------------------------------------------------------+-- | Helper function to route 'mergeFunBindMatches' into the right place in an+-- AST --- correctly dealing with inserting into instance declarations.+graftDecl+    :: DynFlags+    -> SrcSpan+    -> Int+    -> (RdrName -> [Pat GhcPs] -> LHsDecl GhcPs)+    -> LMatch GhcPs (LHsExpr GhcPs)+    -> TransformT (Either String) [LMatch GhcPs (LHsExpr GhcPs)]+graftDecl dflags dst ix make_decl (L src (AMatch (FunRhs (L _ name) _ _) pats _))+  | dst `isSubspanOf` src = do+      L _ dec <- annotateDecl dflags $ make_decl name pats+      case dec of+        ValD _ FunBind{ fun_matches = MG { mg_alts = L _ alts@(first_match : _)}+                      } -> do+          -- For whatever reason, ExactPrint annotates newlines to the ends of+          -- case matches and type signatures, but only allows us to insert+          -- them at the beginning of those things. Thus, we need want to+          -- insert a preceding newline (done in 'annotateDecl') on all+          -- matches, except for the first one --- since it gets its newline+          -- from the line above.+          when (ix == 0) $+            setPrecedingLinesT first_match 0 0+          pure alts+        _ -> lift $ Left "annotateDecl didn't produce a funbind"+graftDecl _ _ _ _ x = pure $ pure x+
+ old/src/Wingman/AbstractLSP/Types.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Wingman.AbstractLSP.Types where++import           Control.Monad.IO.Class+import           Control.Monad.Trans.Maybe (MaybeT (MaybeT), mapMaybeT)+import qualified Data.Aeson as A+import           Data.Text (Text)+import           Development.IDE (IdeState)+import           Development.IDE.GHC.ExactPrint (Graft)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (Target)+import           GHC.Generics (Generic)+import qualified Ide.Plugin.Config as Plugin+import           Ide.Types hiding (Config)+import           Language.LSP.Server (LspM)+import           Language.LSP.Types hiding (CodeLens, CodeAction)+import           Wingman.LanguageServer (judgementForHole)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | An 'Interaction' is an existential 'Continuation', which handles both+-- sides of the request/response interaction for LSP.+data Interaction where+  Interaction+      :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b)+      => Continuation sort target b+      -> Interaction+++------------------------------------------------------------------------------+-- | Metadata for a command. Used by both code actions and lenses, though for+-- lenses, only 'md_title' is currently used.+data Metadata+  = Metadata+      { md_title     :: Text+      , md_kind      :: CodeActionKind+      , md_preferred :: Bool+      }+  deriving stock (Eq, Show)+++------------------------------------------------------------------------------+-- | Whether we're defining a CodeAction or CodeLens.+data SynthesizeCommand a b+  = SynthesizeCodeAction+      ( LspEnv+     -> TargetArgs a+     -> MaybeT (LspM Plugin.Config) [(Metadata, b)]+      )+  | SynthesizeCodeLens+      ( LspEnv+     -> TargetArgs a+     -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)]+      )+++------------------------------------------------------------------------------+-- | Transform a "continuation sort" into a 'CommandId'.+class IsContinuationSort a where+  toCommandId :: a -> CommandId++instance IsContinuationSort CommandId where+  toCommandId = id++instance IsContinuationSort Text where+  toCommandId = CommandId+++------------------------------------------------------------------------------+-- | Ways a 'Continuation' can resolve.+data ContinuationResult+  = -- | Produce some error messages.+    ErrorMessages [UserFacingMessage]+    -- | Produce an explicit 'WorkspaceEdit'.+  | RawEdit WorkspaceEdit+    -- | Produce a 'Graft', corresponding to a transformation of the current+    -- AST.+  | GraftEdit (Graft (Either String) ParsedSource)+++------------------------------------------------------------------------------+-- | A 'Continuation' is a single object corresponding to an action that users+-- can take via LSP. It generalizes codeactions and codelenses, allowing for+-- a significant amount of code reuse.+--+-- Given @Continuation sort target payload@:+--+-- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions+-- rather than working directly with text. This functionality is driven via+-- 'IsContinuationSort'.+--+-- the @target@ is used to fetch data from LSP on both sides of the+-- request/response barrier. For example, you can use it to resolve what node+-- in the AST the incoming range refers to. This functionality is driven via+-- 'IsTarget'.+--+-- the @payload@ is used for data you'd explicitly like to send from the+-- request to the response. It's like @target@, but only gets computed once.+-- This is beneficial if you can do it, but requires that your data is+-- serializable via JSON.+data Continuation sort target payload = Continuation+  { c_sort :: sort+  , c_makeCommand :: SynthesizeCommand target payload+  , c_runCommand+        :: LspEnv+        -> TargetArgs target+        -> FileContext+        -> payload+        -> MaybeT (LspM Plugin.Config) [ContinuationResult]+  }+++------------------------------------------------------------------------------+-- | What file are we looking at, and what bit of it?+data FileContext = FileContext+  { fc_uri      :: Uri+  , fc_range    :: Maybe (Tracked 'Current Range)+    -- ^ For code actions, this is 'Just'. For code lenses, you'll get+    -- a 'Nothing' in the request, and a 'Just' in the response.+  }+  deriving stock (Eq, Ord, Show, Generic)+  deriving anyclass (A.ToJSON, A.FromJSON)+++------------------------------------------------------------------------------+-- | Everything we need to resolve continuations.+data LspEnv = LspEnv+  { le_ideState    :: IdeState+  , le_pluginId    :: PluginId+  , le_dflags      :: DynFlags+  , le_config      :: Config+  , le_fileContext :: FileContext+  }+++------------------------------------------------------------------------------+-- | Extract some information from LSP, so it can be passed to the requests and+-- responses of a 'Continuation'.+class IsTarget t where+  type TargetArgs t+  fetchTargetArgs+      :: LspEnv+      -> MaybeT (LspM Plugin.Config) (TargetArgs t)++------------------------------------------------------------------------------+-- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given+-- range is an HsExpr hole. It gives continuations access to the resulting+-- tactic judgement.+data HoleTarget = HoleTarget+  deriving stock (Eq, Ord, Show, Enum, Bounded)++getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath+getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri++instance IsTarget HoleTarget where+  type TargetArgs HoleTarget = HoleJudgment+  fetchTargetArgs LspEnv{..} = do+    let FileContext{..} = le_fileContext+    range <- MaybeT $ pure fc_range+    nfp <- getNfp fc_uri+    mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config+
+ old/src/Wingman/Auto.hs view
@@ -0,0 +1,32 @@++module Wingman.Auto where++import           Control.Monad.Reader.Class (asks)+import           Control.Monad.State (gets)+import qualified Data.Set as S+import           Refinery.Tactic+import           Wingman.Judgements+import           Wingman.KnownStrategies+import           Wingman.Machinery (tracing, getCurrentDefinitions)+import           Wingman.Tactics+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Automatically solve a goal.+auto :: TacticsM ()+auto = do+  jdg <- goal+  skolems <- gets ts_skolems+  gas <- asks $ cfg_auto_gas . ctxConfig+  current <- getCurrentDefinitions+  traceMX "goal" jdg+  traceMX "ctx" current+  traceMX "skolems" skolems+  commit knownStrategies+    . tracing "auto"+    . localTactic (auto' gas)+    . disallowing RecursiveCall+    . S.fromList+    $ fmap fst current+
+ old/src/Wingman/CaseSplit.hs view
@@ -0,0 +1,109 @@+module Wingman.CaseSplit+  ( mkFirstAgda+  , iterateSplit+  , splitToDecl+  ) where++import           Data.Bool (bool)+import           Data.Data+import           Data.Generics+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.GHC.Compat+import           GHC.Exts (IsString (fromString))+import           GHC.SourceGen (funBindsWithFixity, match, wildP)+import           Wingman.GHC+import           Wingman.Types++++------------------------------------------------------------------------------+-- | Construct an 'AgdaMatch' from patterns in scope (should be the LHS of the+-- match) and a body.+mkFirstAgda :: [Pat GhcPs] -> HsExpr GhcPs -> AgdaMatch+mkFirstAgda pats (Lambda pats' body) = mkFirstAgda (pats <> pats') body+mkFirstAgda pats body                = AgdaMatch pats body+++------------------------------------------------------------------------------+-- | Transform an 'AgdaMatch' whose body is a case over a bound pattern, by+-- splitting it into multiple matches: one for each alternative of the case.+agdaSplit :: AgdaMatch -> [AgdaMatch]+agdaSplit (AgdaMatch pats (Case (HsVar _ (L _ var)) matches))+  -- Ensure the thing we're destructing is actually a pattern that's been+  -- bound.+  | containsVar var pats+  = do+    (pat, body) <- matches+    -- TODO(sandy): use an at pattern if necessary+    pure $ AgdaMatch (rewriteVarPat var pat pats) $ unLoc body+agdaSplit x = [x]+++------------------------------------------------------------------------------+-- | Replace unused bound patterns with wild patterns.+wildify :: AgdaMatch -> AgdaMatch+wildify (AgdaMatch pats body) =+  let make_wild = bool id (wildifyT (allOccNames body)) $ not $ containsHole body+   in AgdaMatch (make_wild pats) body+++------------------------------------------------------------------------------+-- | Helper function for 'wildify'.+wildifyT :: Data a => Set OccName -> a -> a+wildifyT (S.map occNameString -> used) = everywhere $ mkT $ \case+  VarPat _ (L _ var) | S.notMember (occNameString $ occName var) used -> wildP+  (x :: Pat GhcPs)                                                    -> x+++------------------------------------------------------------------------------+-- | Determine whether the given 'RdrName' exists as a 'VarPat' inside of @a@.+containsVar :: Data a => RdrName -> a -> Bool+containsVar name = everything (||) $+  mkQ False (\case+    VarPat _ (L _ var) -> eqRdrName name var+    (_ :: Pat GhcPs)   -> False+      )+  `extQ` \case+    HsRecField lbl _ True ->  eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl+    (_ :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> False+++------------------------------------------------------------------------------+-- | Replace a 'VarPat' with the given @'Pat' GhcPs@.+rewriteVarPat :: Data a => RdrName -> Pat GhcPs -> a -> a+rewriteVarPat name rep = everywhere $+  mkT (\case+    VarPat _ (L _ var) | eqRdrName name var -> rep+    (x :: Pat GhcPs)                        -> x+      )+  `extT` \case+    HsRecField lbl _ True+      | eqRdrName name $ unLoc $ rdrNameFieldOcc $ unLoc lbl+          -> HsRecField lbl (toPatCompat rep) False+    (x :: HsRecField' (FieldOcc GhcPs) (PatCompat GhcPs)) -> x+++------------------------------------------------------------------------------+-- | Construct an 'HsDecl' from a set of 'AgdaMatch'es.+splitToDecl+    :: Maybe LexicalFixity+    -> OccName  -- ^ The name of the function+    -> [AgdaMatch]+    -> LHsDecl GhcPs+splitToDecl fixity name ams = do+  traceX "fixity" fixity $+    noLoc $+      funBindsWithFixity fixity (fromString . occNameString . occName $ name) $ do+        AgdaMatch pats body <- ams+        pure $ match pats body+++------------------------------------------------------------------------------+-- | Sometimes 'agdaSplit' exposes another opportunity to do 'agdaSplit'. This+-- function runs it a few times, hoping it will find a fixpoint.+iterateSplit :: AgdaMatch -> [AgdaMatch]+iterateSplit am =+  let iterated = iterate (agdaSplit =<<) $ pure am+   in fmap wildify . (!! 5) $ iterated+
+ old/src/Wingman/CodeGen.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedLabels  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++module Wingman.CodeGen+  ( module Wingman.CodeGen+  , module Wingman.CodeGen.Utils+  ) where+++import           Control.Lens ((%~), (<>~), (&))+import           Control.Monad.Except+import           Control.Monad.Reader (ask)+import           Control.Monad.State+import           Data.Bifunctor (second)+import           Data.Bool (bool)+import           Data.Functor ((<&>))+import           Data.Generics.Labels ()+import           Data.List+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat+import           GHC.Exts+import           GHC.SourceGen (occNameToStr)+import           GHC.SourceGen.Binds+import           GHC.SourceGen.Expr+import           GHC.SourceGen.Overloaded+import           GHC.SourceGen.Pat+import           Wingman.CodeGen.Utils+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Judgements.Theta+import           Wingman.Machinery+import           Wingman.Naming+import           Wingman.Types+++destructMatches+    :: Bool+    -> (ConLike -> Judgement -> Rule)+       -- ^ How to construct each match+    -> Maybe OccName+       -- ^ Scrutinee+    -> CType+       -- ^ Type being destructed+    -> Judgement+    -> RuleM (Synthesized [RawMatch])+-- TODO(sandy): In an ideal world, this would be the same codepath as+-- 'destructionFor'. Make sure to change that if you ever change this.+destructMatches use_field_puns f scrut t jdg = do+  let hy = jEntireHypothesis jdg+      g  = jGoal jdg+  case tacticsGetDataCons $ unCType t of+    Nothing -> cut -- throwError $ GoalMismatch "destruct" g+    Just (dcs, apps) ->+      fmap unzipTrace $ for dcs $ \dc -> do+        let con = RealDataCon dc+            ev = concatMap (mkEvidence . scaledThing) $ dataConInstArgTys dc apps+            -- We explicitly do not need to add the method hypothesis to+            -- #syn_scoped+            method_hy = foldMap evidenceToHypothesis ev+            args = conLikeInstOrigArgTys' con apps+        ctx <- ask++        let names_in_scope = hyNamesInScope hy+            names = mkManyGoodNames (hyNamesInScope hy) args+            (names', destructed) =+              mkDestructPat (bool Nothing (Just names_in_scope) use_field_puns) con names++        let hy' = patternHypothesis scrut con jdg+                $ zip names'+                $ coerce args+            j = withNewCoercions (evidenceToCoercions ev)+              $ introduce ctx hy'+              $ introduce ctx method_hy+              $ withNewGoal g jdg+        ext <- f con j+        pure $ ext+          & #syn_trace %~ rose ("match " <> show dc <> " {" <> intercalate ", " (fmap show names') <> "}")+                        . pure+          & #syn_scoped <>~ hy'+          & #syn_val %~ match [destructed] . unLoc+++------------------------------------------------------------------------------+-- | Generate just the 'Match'es for a case split on a specific type.+destructionFor :: Hypothesis a -> Type -> Maybe [LMatch GhcPs (LHsExpr GhcPs)]+-- TODO(sandy): In an ideal world, this would be the same codepath as+-- 'destructMatches'. Make sure to change that if you ever change this.+destructionFor hy t = do+  case tacticsGetDataCons t of+    Nothing -> Nothing+    Just ([], _) -> Nothing+    Just (dcs, apps) -> do+      for dcs $ \dc -> do+        let con   = RealDataCon dc+            args  = conLikeInstOrigArgTys' con apps+            names = mkManyGoodNames (hyNamesInScope hy) args+        pure+          . noLoc+          . Match+              noExtField+              CaseAlt+              [toPatCompat $ snd $ mkDestructPat Nothing con names]+          . GRHSs noExtField (pure $ noLoc $ GRHS noExtField [] $ noLoc $ var "_")+          . noLoc+          $ EmptyLocalBinds noExtField++++------------------------------------------------------------------------------+-- | Produces a pattern for a data con and the names of its fields.+mkDestructPat :: Maybe (S.Set OccName) -> ConLike -> [OccName] -> ([OccName], Pat GhcPs)+mkDestructPat already_in_scope con names+  | RealDataCon dcon <- con+  , isTupleDataCon dcon =+      (names, tuple pat_args)+  | fields@(_:_) <- zip (conLikeFieldLabels con) names+  , Just in_scope <- already_in_scope =+      let (names', rec_fields) =+            unzip $ fields <&> \(label, name) -> do+              let label_occ = mkVarOccFS $ flLabel label+              case S.member label_occ in_scope of+                -- We have a shadow, so use the generated name instead+                True ->+                  (name,) $ noLoc $+                    HsRecField+                      (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)+                      (noLoc $ bvar' name)+                      False+                -- No shadow, safe to use a pun+                False ->+                  (label_occ,) $ noLoc $+                    HsRecField+                      (noLoc $ mkFieldOcc $ noLoc $ Unqual label_occ)+                      (noLoc $ bvar' label_occ)+                      True++        in (names', )+         $ ConPatIn (noLoc $ Unqual $ occName $ conLikeName con)+         $ RecCon+         $ HsRecFields rec_fields Nothing+  | otherwise =+      (names, ) $ infixifyPatIfNecessary con $+        conP+          (coerceName $ conLikeName con)+          pat_args+  where+    pat_args = fmap bvar' names+++infixifyPatIfNecessary :: ConLike -> Pat GhcPs -> Pat GhcPs+infixifyPatIfNecessary dcon x+  | conLikeIsInfix dcon =+      case x of+        ConPatIn op (PrefixCon [lhs, rhs]) ->+          ConPatIn op $ InfixCon lhs rhs+        y -> y+  | otherwise = x++++unzipTrace :: [Synthesized a] -> Synthesized [a]+unzipTrace = sequenceA+++-- | Essentially same as 'dataConInstOrigArgTys' in GHC,+--  but only accepts universally quantified types as the second arguments+--  and automatically introduces existentials.+--+-- NOTE: The behaviour depends on GHC's 'dataConInstOrigArgTys'.+--       We need some tweaks if the compiler changes the implementation.+conLikeInstOrigArgTys'+  :: ConLike+      -- ^ 'DataCon'structor+  -> [Type]+      -- ^ /Universally/ quantified type arguments to a result type.+      --   It /MUST NOT/ contain any dictionaries, coercion and existentials.+      --+      --   For example, for @MkMyGADT :: b -> MyGADT a c@, we+      --   must pass @[a, c]@ as this argument but not @b@, as @b@ is an existential.+  -> [Type]+      -- ^ Types of arguments to the ConLike with returned type is instantiated with the second argument.+conLikeInstOrigArgTys' con uniTys =+  let exvars = conLikeExTys con+   in fmap scaledThing $ conLikeInstOrigArgTys con $+        uniTys ++ fmap mkTyVarTy exvars+      -- Rationale: At least in GHC <= 8.10, 'dataConInstOrigArgTys'+      -- unifies the second argument with DataCon's universals followed by existentials.+      -- If the definition of 'dataConInstOrigArgTys' changes,+      -- this place must be changed accordingly.+++conLikeExTys :: ConLike -> [TyCoVar]+conLikeExTys (RealDataCon d) = dataConExTyCoVars d+conLikeExTys (PatSynCon p) = patSynExTys p++patSynExTys :: PatSyn -> [TyCoVar]+patSynExTys ps = patSynExTyVars ps+++------------------------------------------------------------------------------+-- | Combinator for performing case splitting, and running sub-rules on the+-- resulting matches.++destruct' :: Bool -> (ConLike -> Judgement -> Rule) -> HyInfo CType -> Judgement -> Rule+destruct' use_field_puns f hi jdg = do+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic+  let term = hi_name hi+  ext+      <- destructMatches+           use_field_puns+           f+           (Just term)+           (hi_type hi)+           $ disallowing AlreadyDestructed (S.singleton term) jdg+  pure $ ext+    & #syn_trace     %~ rose ("destruct " <> show term) . pure+    & #syn_val       %~ noLoc . case' (var' term)+++------------------------------------------------------------------------------+-- | Combinator for performing case splitting, and running sub-rules on the+-- resulting matches.+destructLambdaCase' :: Bool -> (ConLike -> Judgement -> Rule) -> Judgement -> Rule+destructLambdaCase' use_field_puns f jdg = do+  when (isDestructBlacklisted jdg) cut -- throwError NoApplicableTactic+  let g  = jGoal jdg+  case splitFunTy_maybe (unCType g) of+#if __GLASGOW_HASKELL__ >= 900+    Just (_multiplicity, arg, _) | isAlgType arg ->+#else+    Just (arg, _) | isAlgType arg ->+#endif+      fmap (fmap noLoc lambdaCase) <$>+        destructMatches use_field_puns f Nothing (CType arg) jdg+    _ -> cut -- throwError $ GoalMismatch "destructLambdaCase'" g+++------------------------------------------------------------------------------+-- | Construct a data con with subgoals for each field.+buildDataCon+    :: Bool       -- Should we blacklist destruct?+    -> Judgement+    -> ConLike            -- ^ The data con to build+    -> [Type]             -- ^ Type arguments for the data con+    -> RuleM (Synthesized (LHsExpr GhcPs))+buildDataCon should_blacklist jdg dc tyapps = do+  args <- case dc of+    RealDataCon dc' -> do+      let (skolems', theta, args) = dataConInstSig dc' tyapps+      modify $ \ts ->+        evidenceToSubst (foldMap mkEvidence theta) ts+          & #ts_skolems <>~ S.fromList skolems'+      pure args+    _ ->+      -- If we have a 'PatSyn', we can't continue, since there is no+      -- 'dataConInstSig' equivalent for 'PatSyn's. I don't think this is+      -- a fundamental problem, but I don't know enough about the GHC internals+      -- to implement it myself.+      --+      -- Fortunately, this isn't an issue in practice, since 'PatSyn's are+      -- never in the hypothesis.+      cut -- throwError $ TacticPanic "Can't build Pattern constructors yet"+  ext+      <- fmap unzipTrace+       $ traverse ( \(arg, n) ->+                    newSubgoal+                  . filterSameTypeFromOtherPositions dc n+                  . bool id blacklistingDestruct should_blacklist+                  . flip withNewGoal jdg+                  $ CType arg+                  ) $ zip args [0..]+  pure $ ext+    & #syn_trace %~ rose (show dc) . pure+    & #syn_val   %~ mkCon dc tyapps+++------------------------------------------------------------------------------+-- | Make a function application, correctly handling the infix case.+mkApply :: OccName -> [HsExpr GhcPs] -> LHsExpr GhcPs+mkApply occ (lhs : rhs : more)+  | isSymOcc occ+  = noLoc $ foldl' (@@) (op lhs (coerceName occ) rhs) more+mkApply occ args = noLoc $ foldl' (@@) (var' occ) args+++------------------------------------------------------------------------------+-- | Run a tactic over each term in the given 'Hypothesis', binding the results+-- of each in a let expression.+letForEach+    :: (OccName -> OccName)           -- ^ How to name bound variables+    -> (HyInfo CType -> TacticsM ())  -- ^ The tactic to run+    -> Hypothesis CType               -- ^ Terms to generate bindings for+    -> Judgement                      -- ^ The goal of original hole+    -> RuleM (Synthesized (LHsExpr GhcPs))+letForEach rename solve (unHypothesis -> hy) jdg = do+  case hy of+    [] -> newSubgoal jdg+    _ -> do+      ctx <- ask+      let g = jGoal jdg+      terms <- fmap sequenceA $ for hy $ \hi -> do+        let name = rename $ hi_name hi+        let generalized_let_ty = CType alphaTy+        res <- tacticToRule (withNewGoal generalized_let_ty jdg) $ solve hi+        pure $ fmap ((name,) . unLoc) res+      let hy' = fmap (g <$) $ syn_val terms+          matches = fmap (fmap (\(occ, expr) -> valBind (occNameToStr occ) expr)) terms+      g <- fmap (fmap unLoc) $ newSubgoal $ introduce ctx (userHypothesis hy') jdg+      pure $ fmap noLoc $ let' <$> matches <*> g+++------------------------------------------------------------------------------+-- | Let-bind the given occname judgement pairs.+nonrecLet+    :: [(OccName, Judgement)]+    -> Judgement+    -> RuleM (Synthesized (LHsExpr GhcPs))+nonrecLet occjdgs jdg = do+  occexts <- traverse newSubgoal $ fmap snd occjdgs+  ctx     <- ask+  ext     <- newSubgoal+           $ introduce ctx (userHypothesis $ fmap (second jGoal) occjdgs) jdg+  pure $ fmap noLoc $+    let'+      <$> traverse+            (\(occ, ext) -> valBind (occNameToStr occ) <$> fmap unLoc ext)+            (zip (fmap fst occjdgs) occexts)+      <*> fmap unLoc ext+++------------------------------------------------------------------------------+-- | Converts a function application into applicative form+idiomize :: LHsExpr GhcPs -> LHsExpr GhcPs+idiomize x = noLoc $ case unLoc x of+  HsApp _ (L _ (HsVar _ (L _ x))) gshgp3 ->+    op (bvar' $ occName x) "<$>" (unLoc gshgp3)+  HsApp _ gsigp gshgp3 ->+    op (unLoc $ idiomize gsigp) "<*>" (unLoc gshgp3)+  RecordCon _ con flds ->+    unLoc $ idiomize $ noLoc $ foldl' (@@) (HsVar noExtField con) $ fmap unLoc flds+  y -> y+
+ old/src/Wingman/CodeGen/Utils.hs view
@@ -0,0 +1,79 @@+module Wingman.CodeGen.Utils where++import Data.String+import Data.List+import Development.IDE.GHC.Compat+import GHC.SourceGen (RdrNameStr (UnqualStr), recordConE, string)+import GHC.SourceGen.Overloaded as SourceGen+import Wingman.GHC (getRecordFields)+++------------------------------------------------------------------------------+-- | Make a data constructor with the given arguments.+mkCon :: ConLike -> [Type] -> [LHsExpr GhcPs] -> LHsExpr GhcPs+mkCon con apps (fmap unLoc -> args)+  | RealDataCon dcon <- con+  , dcon == nilDataCon+  , [ty] <- apps+  , ty `eqType` charTy = noLoc $ string ""++  | RealDataCon dcon <- con+  , isTupleDataCon dcon =+      noLoc $ tuple args++  | RealDataCon dcon <- con+  , dataConIsInfix dcon+  , (lhs : rhs : args') <- args =+      noLoc $ foldl' (@@) (op lhs (coerceName con_name) rhs) args'++  | Just fields <- getRecordFields con+  , length fields >= 2 =  --  record notation is unnatural on single field ctors+      noLoc $ recordConE (coerceName con_name) $ do+        (arg, (field, _)) <- zip args fields+        pure (coerceName field, arg)++  | otherwise =+      noLoc $ foldl' (@@) (bvar' $ occName con_name) args+  where+    con_name = conLikeName con+++coerceName :: HasOccName a => a -> RdrNameStr+coerceName = UnqualStr . fromString . occNameString . occName+++------------------------------------------------------------------------------+-- | Like 'var', but works over standard GHC 'OccName's.+var' :: SourceGen.Var a => OccName -> a+var' = var . fromString . occNameString+++------------------------------------------------------------------------------+-- | Like 'bvar', but works over standard GHC 'OccName's.+bvar' :: BVar a => OccName -> a+bvar' = bvar . fromString . occNameString+++------------------------------------------------------------------------------+-- | Get an HsExpr corresponding to a function name.+mkFunc :: String -> HsExpr GhcPs+mkFunc = var' . mkVarOcc+++------------------------------------------------------------------------------+-- | Get an HsExpr corresponding to a value name.+mkVal :: String -> HsExpr GhcPs+mkVal = var' . mkVarOcc+++------------------------------------------------------------------------------+-- | Like 'op', but easier to call.+infixCall :: String -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+infixCall s = flip op (fromString s)+++------------------------------------------------------------------------------+-- | Like '(@@)', but uses a dollar instead of parentheses.+appDollar :: HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+appDollar = infixCall "$"+
+ old/src/Wingman/Context.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}++module Wingman.Context where++import           Control.Arrow+import           Control.Monad.Reader+import           Data.Coerce (coerce)+import           Data.Foldable.Extra (allM)+import           Data.Maybe (fromMaybe, isJust, mapMaybe)+import qualified Data.Set as S+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           Wingman.GHC (normalizeType)+import           Wingman.Judgements.Theta+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++mkContext+    :: Config+    -> [(OccName, CType)]+    -> TcGblEnv+    -> HscEnv+    -> ExternalPackageState+    -> [Evidence]+    -> Context+mkContext cfg locals tcg hscenv eps ev = fix $ \ctx ->+  Context+    { ctxDefiningFuncs+        = fmap (second $ coerce $ normalizeType ctx) locals+    , ctxModuleFuncs+        = fmap (second (coerce $ normalizeType ctx) . splitId)+        . mappend (locallyDefinedMethods tcg)+        . (getFunBindId =<<)+        . fmap unLoc+        . bagToList+        $ tcg_binds tcg+    , ctxConfig = cfg+    , ctxFamInstEnvs =+        (eps_fam_inst_env eps, tcg_fam_inst_env tcg)+    , ctxInstEnvs =+        InstEnvs+          (eps_inst_env eps)+          (tcg_inst_env tcg)+          (tcVisibleOrphanMods tcg)+    , ctxTheta = evidenceToThetaType ev+    , ctx_hscEnv = hscenv+    , ctx_occEnv = tcg_rdr_env tcg+    , ctx_module = extractModule tcg+    }+++locallyDefinedMethods :: TcGblEnv -> [Id]+locallyDefinedMethods+  = foldMap classMethods+  . mapMaybe tyConClass_maybe+  . tcg_tcs++++splitId :: Id -> (OccName, CType)+splitId = occName &&& CType . idType+++getFunBindId :: HsBindLR GhcTc GhcTc -> [Id]+getFunBindId (AbsBinds _ _ _ abes _ _ _)+  = abes >>= \case+      ABE _ poly _ _ _ -> pure poly+      _                -> []+getFunBindId _ = []+++------------------------------------------------------------------------------+-- | Determine if there is an instance that exists for the given 'Class' at the+-- specified types. Deeply checks contexts to ensure the instance is actually+-- real.+--+-- If so, this returns a 'PredType' that corresponds to the type of the+-- dictionary.+getInstance :: MonadReader Context m => Class -> [Type] -> m (Maybe (Class, PredType))+getInstance cls tys = do+  env <- asks ctxInstEnvs+  let (mres, _, _) = lookupInstEnv False env cls tys+  case mres of+    ((inst, mapps) : _) -> do+      -- Get the instantiated type of the dictionary+      let df = piResultTys (idType $ is_dfun inst) $ zipWith fromMaybe alphaTys mapps+      -- pull off its resulting arguments+      let (theta, df') = tcSplitPhiTy df+      allM hasClassInstance theta >>= \case+        True -> pure $ Just (cls, df')+        False -> pure Nothing+    _ -> pure Nothing+++------------------------------------------------------------------------------+-- | Like 'getInstance', but only returns whether or not it succeeded. Can fail+-- fast, and uses a cached Theta from the context.+hasClassInstance :: MonadReader Context m => PredType -> m Bool+hasClassInstance predty = do+  theta <- asks ctxTheta+  case S.member (CType predty) theta of+    True -> pure True+    False -> do+      let (con, apps) = tcSplitTyConApp predty+      case tyConClass_maybe con of+        Nothing -> pure False+        Just cls -> fmap isJust $ getInstance cls apps+
+ old/src/Wingman/Debug.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE BangPatterns     #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+module Wingman.Debug+  ( unsafeRender+  , unsafeRender'+  , traceM+  , traceShowId+  , trace+  , traceX+  , traceIdX+  , traceMX+  , traceFX+  ) where++import           Control.DeepSeq+import           Control.Exception+import           Data.Either (fromRight)+import qualified Data.Text as T+import qualified Debug.Trace+import           Development.IDE.GHC.Compat (PlainGhcException, Outputable(..), SDoc)+import           Development.IDE.GHC.Util (printOutputable)+import           System.IO.Unsafe  (unsafePerformIO)++------------------------------------------------------------------------------+-- | Print something+unsafeRender :: Outputable a => a -> String+unsafeRender = unsafeRender' . ppr+++unsafeRender' :: SDoc -> String+unsafeRender' sdoc = unsafePerformIO $ do+  let z = T.unpack $ printOutputable sdoc+  -- We might not have unsafeGlobalDynFlags (like during testing), in which+  -- case GHC panics. Instead of crashing, let's just fail to print.+  !res <- try @PlainGhcException $ evaluate $ deepseq z z+  pure $ fromRight "<unsafeRender'>" res+{-# NOINLINE unsafeRender' #-}++traceMX :: (Monad m, Show a) => String -> a -> m ()+traceMX str a = traceM $ mappend ("!!!" <> str <> ": ") $ show a++traceX :: (Show a) => String -> a -> b -> b+traceX str a = trace (mappend ("!!!" <> str <> ": ") $ show a)++traceIdX :: (Show a) => String -> a -> a+traceIdX str a = trace (mappend ("!!!" <> str <> ": ") $ show a) a++traceFX :: String -> (a -> String) -> a -> a+traceFX str f a = trace (mappend ("!!!" <> str <> ": ") $ f a) a++traceM :: Applicative f => String -> f ()+trace :: String -> a -> a+traceShowId :: Show a => a -> a+#ifdef DEBUG+traceM = Debug.Trace.traceM+trace = Debug.Trace.trace+traceShowId = Debug.Trace.traceShowId+#else+traceM _ = pure ()+trace _ = id+traceShowId = id+#endif
+ old/src/Wingman/EmptyCase.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}++{-# LANGUAGE NoMonoLocalBinds  #-}++module Wingman.EmptyCase where++import           Control.Applicative (empty)+import           Control.Monad+import           Control.Monad.Except (runExcept)+import           Control.Monad.Trans+import           Control.Monad.Trans.Maybe+import           Data.Generics.Aliases (mkQ, GenericQ)+import           Data.Generics.Schemes (everything)+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+import           Data.Traversable+import           Development.IDE (hscEnv, realSrcSpanToRange)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty, EmptyCase)+import           Development.IDE.GHC.ExactPrint+import           Development.IDE.Spans.LocalBindings (getLocalScope)+import           Ide.Types+import           Language.LSP.Server+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.AbstractLSP.Types+import           Wingman.CodeGen (destructionFor)+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.LanguageServer+import           Wingman.Types+++data EmptyCaseT = EmptyCaseT++instance IsContinuationSort EmptyCaseT where+  toCommandId _ = CommandId "wingman.emptyCase"++instance IsTarget EmptyCaseT where+  type TargetArgs EmptyCaseT = ()+  fetchTargetArgs _ = pure ()++emptyCaseInteraction :: Interaction+emptyCaseInteraction = Interaction $+  Continuation @EmptyCaseT @EmptyCaseT @WorkspaceEdit EmptyCaseT+    (SynthesizeCodeLens $ \LspEnv{..} _ -> do+      let FileContext{..} = le_fileContext+      nfp <- getNfp fc_uri++      let stale a = runStaleIde "codeLensProvider" le_ideState nfp a++      ccs <- lift getClientCapabilities+      TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource+      TrackedStale binds bind_map <- mapMaybeT liftIO $ stale GetBindings+      holes <- mapMaybeT liftIO $ emptyCaseScrutinees le_ideState nfp++      for holes $ \(ss, ty) -> do+        binds_ss <- liftMaybe $ mapAgeFrom bind_map ss+        let bindings = getLocalScope (unTrack binds) $ unTrack binds_ss+            range = realSrcSpanToRange $ unTrack ss+        matches <-+          liftMaybe $+            destructionFor+              (foldMap (hySingleton . occName . fst) bindings)+              ty+        edits <- liftMaybe $ hush $+              mkWorkspaceEdits le_dflags ccs fc_uri (unTrack pm) $+                graftMatchGroup (RealSrcSpan (unTrack ss) Nothing) $+                  noLoc matches+        pure+          ( range+          , Metadata+              (mkEmptyCaseLensDesc ty)+              (CodeActionUnknown "refactor.wingman.completeEmptyCase")+              False+          , edits+          )+    )+    (\ _ _ _ we -> pure $ pure $ RawEdit we)+++scrutinzedType :: EmptyCaseSort Type -> Maybe Type+scrutinzedType (EmptyCase ty) = pure  ty+scrutinzedType (EmptyLamCase ty) =+  case tacticsSplitFunTy ty of+    (_, _, tys, _) -> listToMaybe $ fmap scaledThing tys+++------------------------------------------------------------------------------+-- | The description for the empty case lens.+mkEmptyCaseLensDesc :: Type -> T.Text+mkEmptyCaseLensDesc ty =+  "Wingman: Complete case constructors (" <> T.pack (unsafeRender ty) <> ")"+++------------------------------------------------------------------------------+-- | Silence an error.+hush :: Either e a -> Maybe a+hush (Left _) = Nothing+hush (Right a) = Just a+++------------------------------------------------------------------------------+-- | Graft a 'RunTacticResults' into the correct place in an AST. Correctly+-- deals with top-level holes, in which we might need to fiddle with the+-- 'Match's that bind variables.+graftMatchGroup+    :: SrcSpan+    -> Located [LMatch GhcPs (LHsExpr GhcPs)]+    -> Graft (Either String) ParsedSource+graftMatchGroup ss l =+  hoistGraft (runExcept . runExceptString) $ graftExprWithM ss $ \case+    L span (HsCase ext scrut mg) -> do+      pure $ Just $ L span $ HsCase ext scrut $ mg { mg_alts = l }+    L span (HsLamCase ext mg) -> do+      pure $ Just $ L span $ HsLamCase ext $ mg { mg_alts = l }+    (_ :: LHsExpr GhcPs) -> pure Nothing+++fromMaybeT :: Functor m => a -> MaybeT m a -> m a+fromMaybeT def = fmap (fromMaybe def) . runMaybeT+++------------------------------------------------------------------------------+-- | Find the last typechecked module, and find the most specific span, as well+-- as the judgement at the given range.+emptyCaseScrutinees+    :: IdeState+    -> NormalizedFilePath+    -> MaybeT IO [(Tracked 'Current RealSrcSpan, Type)]+emptyCaseScrutinees state nfp = do+    let stale a = runStaleIde "emptyCaseScrutinees" state nfp a++    TrackedStale tcg tcg_map <- fmap (fmap tmrTypechecked) $ stale TypeCheck+    let tcg' = unTrack tcg+    hscenv <- stale GhcSessionDeps++    let scrutinees = traverse (emptyCaseQ . tcg_binds) tcg+    fmap catMaybes $ for scrutinees $ \aged@(unTrack -> (ss, scrutinee)) -> do+      ty <- MaybeT+          . fmap (scrutinzedType <=< sequence)+          . traverse (typeCheck (hscEnv $ untrackedStaleValue hscenv) tcg')+          $ scrutinee+      case null $ tacticsGetDataCons ty of+        True -> pure empty+        False ->+          case ss of+            RealSrcSpan r _ -> do+              rss' <- liftMaybe $ mapAgeTo tcg_map $ unsafeCopyAge aged r+              pure $ Just (rss', ty)+            UnhelpfulSpan _ -> empty++data EmptyCaseSort a+  = EmptyCase a+  | EmptyLamCase a+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++------------------------------------------------------------------------------+-- | Get the 'SrcSpan' and scrutinee of every empty case.+emptyCaseQ :: GenericQ [(SrcSpan, EmptyCaseSort (HsExpr GhcTc))]+emptyCaseQ = everything (<>) $ mkQ mempty $ \case+  L new_span (Case scrutinee []) -> pure (new_span, EmptyCase scrutinee)+  L new_span expr@(LamCase []) -> pure (new_span, EmptyLamCase expr)+  (_ :: LHsExpr GhcTc) -> mempty+
+ old/src/Wingman/GHC.hs view
@@ -0,0 +1,369 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module Wingman.GHC where++import           Control.Monad.State+import           Control.Monad.Trans.Maybe (MaybeT(..))+import           Data.Bool (bool)+import           Data.Coerce (coerce)+import           Data.Function (on)+import           Data.Functor ((<&>))+import           Data.List (isPrefixOf)+import qualified Data.Map as M+import           Data.Maybe (isJust)+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util+import           GHC.SourceGen (lambda)+import           Generics.SYB (Data, everything, everywhere, listify, mkQ, mkT)+import           Wingman.StaticPlugin (pattern MetaprogramSyntax)+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++tcTyVar_maybe :: Type -> Maybe Var+tcTyVar_maybe ty | Just ty' <- tcView ty = tcTyVar_maybe ty'+tcTyVar_maybe (CastTy ty _) = tcTyVar_maybe ty  -- look through casts, as+                                                -- this is only used for+                                                -- e.g., FlexibleContexts+tcTyVar_maybe (TyVarTy v)   = Just v+tcTyVar_maybe _             = Nothing+++instantiateType :: Type -> ([TyVar], Type)+instantiateType t = do+  let vs  = tyCoVarsOfTypeList t+      vs' = fmap cloneTyVar vs+      subst = foldr (\(v,t) a -> extendTCvSubst a v $ TyVarTy t) emptyTCvSubst+            $ zip vs vs'+   in (vs', substTy subst t)+++cloneTyVar :: TyVar -> TyVar+cloneTyVar t =+  let uniq = getUnique t+      some_magic_char = 'w' -- 'w' for wingman ;D+   in setVarUnique t $ newTagUnique uniq some_magic_char+++------------------------------------------------------------------------------+-- | Is this a function type?+isFunction :: Type -> Bool+isFunction (tacticsSplitFunTy -> (_, _, [], _)) = False+isFunction _                                    = True+++------------------------------------------------------------------------------+-- | Split a function, also splitting out its quantified variables and theta+-- context.+tacticsSplitFunTy :: Type -> ([TyVar], ThetaType, [Scaled Type], Type)+tacticsSplitFunTy t+  = let (vars, theta, t') = tcSplitNestedSigmaTys t+        (args, res) = tcSplitFunTys t'+     in (vars, theta, args, res)+++------------------------------------------------------------------------------+-- | Rip the theta context out of a regular type.+tacticsThetaTy :: Type -> ThetaType+tacticsThetaTy (tcSplitSigmaTy -> (_, theta,  _)) = theta+++------------------------------------------------------------------------------+-- | Get the data cons of a type, if it has any.+tacticsGetDataCons :: Type -> Maybe ([DataCon], [Type])+tacticsGetDataCons ty+  | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty+  = tacticsGetDataCons ty'+tacticsGetDataCons ty+  | Just _ <- algebraicTyCon ty+  = splitTyConApp_maybe ty <&> \(tc, apps) ->+      ( filter (not . dataConCannotMatch apps) $ tyConDataCons tc+      , apps+      )+tacticsGetDataCons _ = Nothing++------------------------------------------------------------------------------+-- | Instantiate all of the quantified type variables in a type with fresh+-- skolems.+freshTyvars :: MonadState TacticState m => Type -> m Type+freshTyvars t = do+  let (tvs, _, _, _) = tacticsSplitFunTy t+  reps <- fmap M.fromList+        $ for tvs $ \tv -> do+            uniq <- freshUnique+            pure (tv, setTyVarUnique tv uniq)+  pure $+    everywhere+      (mkT $ \tv -> M.findWithDefault tv tv reps+      ) $ snd $ tcSplitForAllTyVars t+++------------------------------------------------------------------------------+-- | Given a datacon, extract its record fields' names and types. Returns+-- nothing if the datacon is not a record.+getRecordFields :: ConLike -> Maybe [(OccName, CType)]+getRecordFields dc =+  case conLikeFieldLabels dc of+    [] -> Nothing+    lbls -> for lbls $ \lbl -> do+      let ty = conLikeFieldType dc $ flLabel lbl+      pure (mkVarOccFS $ flLabel lbl, CType ty)+++------------------------------------------------------------------------------+-- | Is this an algebraic type?+algebraicTyCon :: Type -> Maybe TyCon+algebraicTyCon ty+  | Just (_, ty') <- tcSplitForAllTyVarBinder_maybe ty+  = algebraicTyCon ty'+algebraicTyCon (splitTyConApp_maybe -> Just (tycon, _))+  | tycon == intTyCon    = Nothing+  | tycon == floatTyCon  = Nothing+  | tycon == doubleTyCon = Nothing+  | tycon == charTyCon   = Nothing+  | tycon == funTyCon    = Nothing+  | otherwise = Just tycon+algebraicTyCon _ = Nothing+++------------------------------------------------------------------------------+-- | We can't compare 'RdrName' for equality directly. Instead, sloppily+-- compare them by their 'OccName's.+eqRdrName :: RdrName -> RdrName -> Bool+eqRdrName = (==) `on` occNameString . occName+++------------------------------------------------------------------------------+-- | Compare two 'OccName's for unqualified equality.+sloppyEqOccName :: OccName -> OccName -> Bool+sloppyEqOccName = (==) `on` occNameString+++------------------------------------------------------------------------------+-- | Does this thing contain any references to 'HsVar's with the given+-- 'RdrName'?+containsHsVar :: Data a => RdrName -> a -> Bool+containsHsVar name x = not $ null $ listify (+  \case+    ((HsVar _ (L _ a)) :: HsExpr GhcPs) | eqRdrName a name -> True+    _                                                      -> False+  ) x+++------------------------------------------------------------------------------+-- | Does this thing contain any holes?+containsHole :: Data a => a -> Bool+containsHole x = not $ null $ listify (+  \case+    ((HsVar _ (L _ name)) :: HsExpr GhcPs) -> isHole $ occName name+    MetaprogramSyntax _                    -> True+    _                                      -> False+  ) x+++------------------------------------------------------------------------------+-- | Check if an 'OccName' is a hole+isHole :: OccName -> Bool+-- TODO(sandy): Make this more robust+isHole = isPrefixOf "_" . occNameString+++------------------------------------------------------------------------------+-- | Get all of the referenced occnames.+allOccNames :: Data a => a -> Set OccName+allOccNames = everything (<>) $ mkQ mempty $ \case+    a -> S.singleton a+++------------------------------------------------------------------------------+-- | Unpack the relevant parts of a 'Match'+#if __GLASGOW_HASKELL__ >= 900+pattern AMatch :: HsMatchContext (NoGhcTc GhcPs) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)+#else+pattern AMatch :: HsMatchContext (NameOrRdrName (IdP GhcPs)) -> [Pat GhcPs] -> HsExpr GhcPs -> Match GhcPs (LHsExpr GhcPs)+#endif+pattern AMatch ctx pats body <-+  Match { m_ctxt = ctx+        , m_pats = fmap fromPatCompat -> pats+        , m_grhss = UnguardedRHSs (unLoc -> body)+        }+++pattern SingleLet :: IdP GhcPs -> [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs -> HsExpr GhcPs+pattern SingleLet bind pats val expr <-+  HsLet _+    (HsValBinds _+      (ValBinds _ (bagToList ->+        [L _ (FunBind {fun_id = (L _ bind), fun_matches = (MG _ (L _ [L _ (AMatch _ pats val)]) _)})]) _))+    (L _ expr)+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs+pattern Lambda pats body <-+  HsLam _+    MG {mg_alts = L _ [L _ (AMatch _ pats body) ]}+  where+    -- If there are no patterns to bind, just stick in the body+    Lambda [] body   = body+    Lambda pats body = lambda pats body+++------------------------------------------------------------------------------+-- | A GRHS that contains no guards.+pattern UnguardedRHSs :: LHsExpr p -> GRHSs p (LHsExpr p)+pattern UnguardedRHSs body <-+  GRHSs {grhssGRHSs = [L _ (GRHS _ [] body)]}+++------------------------------------------------------------------------------+-- | A match with a single pattern. Case matches are always 'SinglePatMatch'es.+pattern SinglePatMatch :: PatCompattable p => Pat p -> LHsExpr p -> Match p (LHsExpr p)+pattern SinglePatMatch pat body <-+  Match { m_pats = [fromPatCompat -> pat]+        , m_grhss = UnguardedRHSs body+        }+++------------------------------------------------------------------------------+-- | Helper function for defining the 'Case' pattern.+unpackMatches :: PatCompattable p => [Match p (LHsExpr p)] -> Maybe [(Pat p, LHsExpr p)]+unpackMatches [] = Just []+unpackMatches (SinglePatMatch pat body : matches) =+  ((pat, body):) <$> unpackMatches matches+unpackMatches _ = Nothing+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Case :: PatCompattable p => HsExpr p -> [(Pat p, LHsExpr p)] -> HsExpr p+pattern Case scrutinee matches <-+  HsCase _ (L _ scrutinee)+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}++------------------------------------------------------------------------------+-- | Like 'Case', but for lambda cases.+pattern LamCase :: PatCompattable p => [(Pat p, LHsExpr p)] -> HsExpr p+pattern LamCase matches <-+  HsLamCase _+    MG {mg_alts = L _ (fmap unLoc -> unpackMatches -> Just matches)}+++------------------------------------------------------------------------------+-- | Can ths type be lambda-cased?+--+-- Return: 'Nothing' if no+--         @Just False@ if it can't be homomorphic+--         @Just True@ if it can+lambdaCaseable :: Type -> Maybe Bool+#if __GLASGOW_HASKELL__ >= 900+lambdaCaseable (splitFunTy_maybe -> Just (_multiplicity, arg, res))+#else+lambdaCaseable (splitFunTy_maybe -> Just (arg, res))+#endif+  | isJust (algebraicTyCon arg)+  = Just $ isJust $ algebraicTyCon res+lambdaCaseable _ = Nothing++class PatCompattable p where+  fromPatCompat :: PatCompat p -> Pat p+  toPatCompat :: Pat p -> PatCompat p++instance PatCompattable GhcTc where+  fromPatCompat = unLoc+  toPatCompat = noLoc++instance PatCompattable GhcPs where+  fromPatCompat = unLoc+  toPatCompat = noLoc++type PatCompat pass = LPat pass++------------------------------------------------------------------------------+-- | Should make sure it's a fun bind+pattern TopLevelRHS+    :: OccName+    -> [PatCompat GhcTc]+    -> LHsExpr GhcTc+    -> HsLocalBindsLR GhcTc GhcTc+    -> Match GhcTc (LHsExpr GhcTc)+pattern TopLevelRHS name ps body where_binds <-+  Match _+    (FunRhs (L _ (occName -> name)) _ _)+    ps+    (GRHSs _+      [L _ (GRHS _ [] body)] (L _ where_binds))++liftMaybe :: Monad m => Maybe a -> MaybeT m a+liftMaybe a = MaybeT $ pure a+++------------------------------------------------------------------------------+-- | Get the type of an @HsExpr GhcTc@. This is slow and you should prefer to+-- not use it, but sometimes it can't be helped.+typeCheck :: HscEnv -> TcGblEnv -> HsExpr GhcTc -> IO (Maybe Type)+typeCheck hscenv tcg = fmap snd . initDs hscenv tcg . fmap exprType . dsExpr++------------------------------------------------------------------------------+-- | Expand type and data families+normalizeType :: Context -> Type -> Type+normalizeType ctx ty =+  let ty' = expandTyFam ctx ty+   in case tcSplitTyConApp_maybe ty' of+        Just (tc, tys) ->+          -- try to expand any data families+          case tcLookupDataFamInst_maybe (ctxFamInstEnvs ctx) tc tys of+            Just (dtc, dtys, _) -> mkAppTys (mkTyConTy dtc) dtys+            Nothing -> ty'+        Nothing -> ty'++------------------------------------------------------------------------------+-- | Expand type families+expandTyFam :: Context -> Type -> Type+expandTyFam ctx = snd . normaliseType  (ctxFamInstEnvs ctx) Nominal+++------------------------------------------------------------------------------+-- | Like 'tcUnifyTy', but takes a list of skolems to prevent unification of.+tryUnifyUnivarsButNotSkolems :: Set TyVar -> CType -> CType -> Maybe TCvSubst+tryUnifyUnivarsButNotSkolems skolems goal inst =+  tryUnifyUnivarsButNotSkolemsMany skolems $ coerce [(goal, inst)]++------------------------------------------------------------------------------+-- | Like 'tryUnifyUnivarsButNotSkolems', but takes a list+-- of pairs of types to unify.+tryUnifyUnivarsButNotSkolemsMany :: Set TyVar -> [(Type, Type)] -> Maybe TCvSubst+tryUnifyUnivarsButNotSkolemsMany skolems (unzip -> (goal, inst)) =+  tcUnifyTys+    (bool BindMe Skolem . flip S.member skolems)+    inst+    goal+++updateSubst :: TCvSubst -> TacticState -> TacticState+updateSubst subst s = s { ts_unifier = unionTCvSubst subst (ts_unifier s) }+++------------------------------------------------------------------------------+-- | Get the class methods of a 'PredType', correctly dealing with+-- instantiation of quantified class types.+methodHypothesis :: PredType -> Maybe [HyInfo CType]+methodHypothesis ty = do+  (tc, apps) <- splitTyConApp_maybe ty+  cls <- tyConClass_maybe tc+  let methods = classMethods cls+      tvs     = classTyVars cls+      subst   = zipTvSubst tvs apps+  pure $ methods <&> \method ->+    let (_, _, ty) = tcSplitSigmaTy $ idType method+    in ( HyInfo (occName method) (ClassMethodPrv $ Uniquely cls) $ CType $ substTy subst ty+       )+
+ old/src/Wingman/Judgements.hs view
@@ -0,0 +1,474 @@+module Wingman.Judgements where++import           Control.Arrow+import           Control.Lens hiding (Context)+import           Data.Bool+import           Data.Char+import           Data.Coerce+import           Data.Generics.Product (field)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.Core.UseStale (Tracked, unTrack)+import           Development.IDE.GHC.Compat hiding (isTopLevel)+import           Development.IDE.Spans.LocalBindings+import           Wingman.GHC (algebraicTyCon, normalizeType)+import           Wingman.Judgements.Theta+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Given a 'SrcSpan' and a 'Bindings', create a hypothesis.+hypothesisFromBindings :: Tracked age RealSrcSpan -> Tracked age Bindings -> Hypothesis CType+hypothesisFromBindings (unTrack -> span) (unTrack -> bs) = buildHypothesis $ getLocalScope bs span+++------------------------------------------------------------------------------+-- | Convert a @Set Id@ into a hypothesis.+buildHypothesis :: [(Name, Maybe Type)] -> Hypothesis CType+buildHypothesis+  = Hypothesis+  . mapMaybe go+  where+    go (occName -> occ, t)+      | Just ty <- t+      , (h:_) <- occNameString occ+      , isAlpha h = Just $ HyInfo occ UserPrv $ CType ty+      | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Build a trivial hypothesis containing only a single name. The corresponding+-- HyInfo has no provenance or type.+hySingleton :: OccName -> Hypothesis ()+hySingleton n = Hypothesis . pure $ HyInfo n UserPrv ()+++blacklistingDestruct :: Judgement -> Judgement+blacklistingDestruct =+  field @"_jBlacklistDestruct" .~ True+++unwhitelistingSplit :: Judgement -> Judgement+unwhitelistingSplit =+  field @"_jWhitelistSplit" .~ False+++isDestructBlacklisted :: Judgement -> Bool+isDestructBlacklisted = _jBlacklistDestruct+++isSplitWhitelisted :: Judgement -> Bool+isSplitWhitelisted = _jWhitelistSplit+++withNewGoal :: a -> Judgement' a -> Judgement' a+withNewGoal t = field @"_jGoal" .~ t++------------------------------------------------------------------------------+-- | Like 'withNewGoal' but allows you to modify the goal rather than replacing+-- it.+withModifiedGoal :: (a -> a) -> Judgement' a -> Judgement' a+withModifiedGoal f = field @"_jGoal" %~ f+++------------------------------------------------------------------------------+-- | Add some new type equalities to the local judgement.+withNewCoercions :: [(CType, CType)] -> Judgement -> Judgement+withNewCoercions ev j =+  let subst = allEvidenceToSubst mempty $ coerce ev+   in fmap (CType . substTyAddInScope subst . unCType) j+      & field @"j_coercion" %~ unionTCvSubst subst+++normalizeHypothesis :: Functor f => Context -> f CType -> f CType+normalizeHypothesis = fmap . coerce . normalizeType++normalizeJudgement :: Functor f => Context -> f CType -> f CType+normalizeJudgement = normalizeHypothesis+++introduce :: Context -> Hypothesis CType -> Judgement' CType -> Judgement' CType+-- NOTE(sandy): It's important that we put the new hypothesis terms first,+-- since 'jAcceptableDestructTargets' will never destruct a pattern that occurs+-- after a previously-destructed term.+introduce ctx hy =+  field @"_jHypothesis" %~ mappend (normalizeHypothesis ctx hy)+++------------------------------------------------------------------------------+-- | Helper function for implementing functions which introduce new hypotheses.+introduceHypothesis+    :: (Int -> Int -> Provenance)+        -- ^ A function from the total number of args and position of this arg+        -- to its provenance.+    -> [(OccName, a)]+    -> Hypothesis a+introduceHypothesis f ns =+  Hypothesis $ zip [0..] ns <&> \(pos, (name, ty)) ->+    HyInfo name (f (length ns) pos) ty+++------------------------------------------------------------------------------+-- | Introduce bindings in the context of a lambda.+lambdaHypothesis+    :: Maybe OccName   -- ^ The name of the top level function. For any other+                       -- function, this should be 'Nothing'.+    -> [(OccName, a)]+    -> Hypothesis a+lambdaHypothesis func =+  introduceHypothesis $ \count pos ->+    maybe UserPrv (\x -> TopLevelArgPrv x pos count) func+++------------------------------------------------------------------------------+-- | Introduce a binding in a recursive context.+recursiveHypothesis :: [(OccName, a)] -> Hypothesis a+recursiveHypothesis = introduceHypothesis $ const $ const RecursivePrv+++------------------------------------------------------------------------------+-- | Introduce a binding in a recursive context.+userHypothesis :: [(OccName, a)] -> Hypothesis a+userHypothesis = introduceHypothesis $ const $ const UserPrv+++------------------------------------------------------------------------------+-- | Check whether any of the given occnames are an ancestor of the term.+hasPositionalAncestry+    :: Foldable t+    => t OccName   -- ^ Desired ancestors.+    -> Judgement+    -> OccName     -- ^ Potential child+    -> Maybe Bool  -- ^ Just True if the result is the oldest positional ancestor+                   -- just false if it's a descendent+                   -- otherwise nothing+hasPositionalAncestry ancestors jdg name+  | not $ null ancestors+  = case name `elem` ancestors of+      True  -> Just True+      False ->+        case M.lookup name $ jAncestryMap jdg of+          Just ancestry ->+            bool Nothing (Just False) $ any (flip S.member ancestry) ancestors+          Nothing -> Nothing+  | otherwise = Nothing+++------------------------------------------------------------------------------+-- | Helper function for disallowing hypotheses that have the wrong ancestry.+filterAncestry+    :: Foldable t+    => t OccName+    -> DisallowReason+    -> Judgement+    -> Judgement+filterAncestry ancestry reason jdg =+    disallowing reason (M.keysSet $ M.filterWithKey go $ hyByName $ jHypothesis jdg) jdg+  where+    go name _+      = isNothing+      $ hasPositionalAncestry ancestry jdg name+++------------------------------------------------------------------------------+-- | @filter defn pos@ removes any hypotheses which are bound in @defn@ to+-- a position other than @pos@. Any terms whose ancestry doesn't include @defn@+-- remain.+filterPosition :: OccName -> Int -> Judgement -> Judgement+filterPosition defn pos jdg =+  filterAncestry (findPositionVal jdg defn pos) (WrongBranch pos) jdg+++------------------------------------------------------------------------------+-- | Helper function for determining the ancestry list for 'filterPosition'.+findPositionVal :: Judgement' a -> OccName -> Int -> Maybe OccName+findPositionVal jdg defn pos = listToMaybe $ do+  -- It's important to inspect the entire hypothesis here, as we need to trace+  -- ancestry through potentially disallowed terms in the hypothesis.+  (name, hi) <- M.toList+              $ M.map (overProvenance expandDisallowed)+              $ hyByName+              $ jEntireHypothesis jdg+  case hi_provenance hi of+    TopLevelArgPrv defn' pos' _+      | defn == defn'+      , pos  == pos' -> pure name+    PatternMatchPrv pv+      | pv_scrutinee pv == Just defn+      , pv_position pv  == pos -> pure name+    _ -> []+++------------------------------------------------------------------------------+-- | Helper function for determining the ancestry list for+-- 'filterSameTypeFromOtherPositions'.+findDconPositionVals :: Judgement' a -> ConLike -> Int -> [OccName]+findDconPositionVals jdg dcon pos = do+  (name, hi) <- M.toList $ hyByName $ jHypothesis jdg+  case hi_provenance hi of+    PatternMatchPrv pv+      | pv_datacon  pv == Uniquely dcon+      , pv_position pv == pos -> pure name+    _ -> []+++------------------------------------------------------------------------------+-- | Disallow any hypotheses who have the same type as anything bound by the+-- given position for the datacon. Used to ensure recursive functions like+-- 'fmap' preserve the relative ordering of their arguments by eliminating any+-- other term which might match.+filterSameTypeFromOtherPositions :: ConLike -> Int -> Judgement -> Judgement+filterSameTypeFromOtherPositions dcon pos jdg =+  let hy = hyByName+         . jHypothesis+         $ filterAncestry+             (findDconPositionVals jdg dcon pos)+             (WrongBranch pos)+             jdg+      tys = S.fromList $ hi_type <$> M.elems hy+      to_remove =+        M.filter (flip S.member tys . hi_type) (hyByName $ jHypothesis jdg)+          M.\\ hy+   in disallowing Shadowed (M.keysSet to_remove) jdg+++------------------------------------------------------------------------------+-- | Return the ancestry of a 'PatVal', or 'mempty' otherwise.+getAncestry :: Judgement' a -> OccName -> Set OccName+getAncestry jdg name =+  maybe mempty pv_ancestry . M.lookup name $ jPatHypothesis jdg+++jAncestryMap :: Judgement' a -> Map OccName (Set OccName)+jAncestryMap jdg =+  M.map pv_ancestry (jPatHypothesis jdg)+++provAncestryOf :: Provenance -> Set OccName+provAncestryOf (TopLevelArgPrv o _ _) = S.singleton o+provAncestryOf (PatternMatchPrv (PatVal mo so _ _)) =+  maybe mempty S.singleton mo <> so+provAncestryOf (ClassMethodPrv _) = mempty+provAncestryOf UserPrv = mempty+provAncestryOf RecursivePrv = mempty+provAncestryOf ImportPrv = mempty+provAncestryOf (DisallowedPrv _ p2) = provAncestryOf p2+++------------------------------------------------------------------------------+-- TODO(sandy): THIS THING IS A BIG BIG HACK+--+-- Why? 'ctxDefiningFuncs' is _all_ of the functions currently being defined+-- (eg, we might be in a where block). The head of this list is not guaranteed+-- to be the one we're interested in.+extremelyStupid__definingFunction :: Context -> OccName+extremelyStupid__definingFunction =+  fst . head . ctxDefiningFuncs+++patternHypothesis+    :: Maybe OccName+    -> ConLike+    -> Judgement' a+    -> [(OccName, a)]+    -> Hypothesis a+patternHypothesis scrutinee dc jdg+  = introduceHypothesis $ \_ pos ->+      PatternMatchPrv $+        PatVal+          scrutinee+          (maybe+              mempty+              (\scrut -> S.singleton scrut <> getAncestry jdg scrut)+              scrutinee)+          (Uniquely dc)+          pos+++------------------------------------------------------------------------------+-- | Prevent some occnames from being used in the hypothesis. This will hide+-- them from 'jHypothesis', but not from 'jEntireHypothesis'.+disallowing :: DisallowReason -> S.Set OccName -> Judgement' a -> Judgement' a+disallowing reason ns =+  field @"_jHypothesis" %~ (\z -> Hypothesis . flip fmap (unHypothesis z) $ \hi ->+    case S.member (hi_name hi) ns of+      True  -> overProvenance (DisallowedPrv reason) hi+      False -> hi+                           )+++------------------------------------------------------------------------------+-- | The hypothesis, consisting of local terms and the ambient environment+-- (imports and class methods.) Hides disallowed values.+jHypothesis :: Judgement' a -> Hypothesis a+jHypothesis+  = Hypothesis+  . filter (not . isDisallowed . hi_provenance)+  . unHypothesis+  . jEntireHypothesis+++------------------------------------------------------------------------------+-- | The whole hypothesis, including things disallowed.+jEntireHypothesis :: Judgement' a -> Hypothesis a+jEntireHypothesis = _jHypothesis+++------------------------------------------------------------------------------+-- | Just the local hypothesis.+jLocalHypothesis :: Judgement' a -> Hypothesis a+jLocalHypothesis+  = Hypothesis+  . filter (isLocalHypothesis . hi_provenance)+  . unHypothesis+  . jHypothesis+++------------------------------------------------------------------------------+-- | Filter elements from the hypothesis+hyFilter :: (HyInfo a -> Bool) -> Hypothesis a -> Hypothesis a+hyFilter f  = Hypothesis . filter f . unHypothesis+++------------------------------------------------------------------------------+-- | Given a judgment, return the hypotheses that are acceptable to destruct.+--+-- We use the ordering of the hypothesis for this purpose. Since new bindings+-- are always inserted at the beginning, we can impose a canonical ordering on+-- which order to try destructs by what order they are introduced --- stopping+-- at the first one we've already destructed.+jAcceptableDestructTargets :: Judgement' CType -> [HyInfo CType]+jAcceptableDestructTargets+  = filter (isJust . algebraicTyCon . unCType . hi_type)+  . takeWhile (not . isAlreadyDestructed . hi_provenance)+  . unHypothesis+  . jEntireHypothesis+++------------------------------------------------------------------------------+-- | If we're in a top hole, the name of the defining function.+isTopHole :: Context -> Judgement' a -> Maybe OccName+isTopHole ctx =+  bool Nothing (Just $ extremelyStupid__definingFunction ctx) . _jIsTopHole+++unsetIsTopHole :: Judgement' a -> Judgement' a+unsetIsTopHole = field @"_jIsTopHole" .~ False+++------------------------------------------------------------------------------+-- | What names are currently in scope in the hypothesis?+hyNamesInScope :: Hypothesis a -> Set OccName+hyNamesInScope = M.keysSet . hyByName+++------------------------------------------------------------------------------+-- | Are there any top-level function argument bindings in this judgement?+jHasBoundArgs :: Judgement' a -> Bool+jHasBoundArgs+  = any (isTopLevel . hi_provenance)+  . unHypothesis+  . jLocalHypothesis+++jNeedsToBindArgs :: Judgement' CType -> Bool+jNeedsToBindArgs = isFunTy . unCType . jGoal+++------------------------------------------------------------------------------+-- | Fold a hypothesis into a single mapping from name to info. This+-- unavoidably will cause duplicate names (things like methods) to shadow one+-- another.+hyByName :: Hypothesis a -> Map OccName (HyInfo a)+hyByName+  = M.fromList+  . fmap (hi_name &&& id)+  . unHypothesis+++------------------------------------------------------------------------------+-- | Only the hypothesis members which are pattern vals+jPatHypothesis :: Judgement' a -> Map OccName PatVal+jPatHypothesis+  = M.mapMaybe (getPatVal . hi_provenance)+  . hyByName+  . jHypothesis+++getPatVal :: Provenance-> Maybe PatVal+getPatVal prov =+  case prov of+    PatternMatchPrv pv -> Just pv+    _                  -> Nothing+++jGoal :: Judgement' a -> a+jGoal = _jGoal+++substJdg :: TCvSubst -> Judgement -> Judgement+substJdg subst = fmap $ coerce . substTy subst . coerce+++mkFirstJudgement+    :: Context+    -> Hypothesis CType+    -> Bool  -- ^ are we in the top level rhs hole?+    -> Type+    -> Judgement' CType+mkFirstJudgement ctx hy top goal =+  normalizeJudgement ctx $+    Judgement+      { _jHypothesis        = hy+      , _jBlacklistDestruct = False+      , _jWhitelistSplit    = True+      , _jIsTopHole         = top+      , _jGoal              = CType goal+      , j_coercion          = emptyTCvSubst+      }+++------------------------------------------------------------------------------+-- | Is this a top level function binding?+isTopLevel :: Provenance -> Bool+isTopLevel TopLevelArgPrv{} = True+isTopLevel _                = False+++------------------------------------------------------------------------------+-- | Is this a local function argument, pattern match or user val?+isLocalHypothesis :: Provenance -> Bool+isLocalHypothesis UserPrv{}         = True+isLocalHypothesis PatternMatchPrv{} = True+isLocalHypothesis TopLevelArgPrv{}  = True+isLocalHypothesis _                 = False+++------------------------------------------------------------------------------+-- | Is this a pattern match?+isPatternMatch :: Provenance -> Bool+isPatternMatch PatternMatchPrv{} = True+isPatternMatch _                 = False+++------------------------------------------------------------------------------+-- | Was this term ever disallowed?+isDisallowed :: Provenance -> Bool+isDisallowed DisallowedPrv{} = True+isDisallowed _               = False++------------------------------------------------------------------------------+-- | Has this term already been disallowed?+isAlreadyDestructed :: Provenance -> Bool+isAlreadyDestructed (DisallowedPrv AlreadyDestructed _) = True+isAlreadyDestructed _ = False+++------------------------------------------------------------------------------+-- | Eliminates 'DisallowedPrv' provenances.+expandDisallowed :: Provenance -> Provenance+expandDisallowed (DisallowedPrv _ prv) = expandDisallowed prv+expandDisallowed prv                   = prv
+ old/src/Wingman/Judgements/SYB.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RankNTypes          #-}++-- | Custom SYB traversals+module Wingman.Judgements.SYB where++import           Data.Foldable (foldl')+import           Data.Generics hiding (typeRep)+import qualified Data.Text as T+import           Development.IDE.GHC.Compat+import           Development.IDE.GHC.Compat.Util (unpackFS)+import           GHC.Exts (Any)+import           Type.Reflection+import           Unsafe.Coerce (unsafeCoerce)+import           Wingman.StaticPlugin (pattern WingmanMetaprogram)+++------------------------------------------------------------------------------+-- | Like 'everything', but only looks inside 'Located' terms that contain the+-- given 'SrcSpan'.+everythingContaining+    :: forall r+     . Monoid r+    => SrcSpan+    -> GenericQ r+    -> GenericQ r+everythingContaining dst f = go+  where+    go :: GenericQ r+    go x =+      case genericIsSubspan dst x of+        Just False -> mempty+        _ -> foldl' (<>) (f x) (gmapQ go x)+++------------------------------------------------------------------------------+-- | Helper function for implementing 'everythingWithin'+--+-- NOTE(sandy): Subtly broken. In an ideal world, this function should return+-- @Just False@ for nodes of /any type/ which do not contain the span. But if+-- this functionality exists anywhere within the SYB machinery, I have yet to+-- find it.+genericIsSubspan+    :: SrcSpan+    -> GenericQ (Maybe Bool)+genericIsSubspan dst = mkQ1 (L noSrcSpan ()) Nothing $ \case+  L span _ -> Just $ dst `isSubspanOf` span+++------------------------------------------------------------------------------+-- | Like 'mkQ', but allows for polymorphic instantiation of its specific case.+-- This instantiation matches whenever the dynamic value has the same+-- constructor as the proxy @f ()@ value.+mkQ1 :: forall a r f+      . (Data a, Data (f ()))+     => f ()                  -- ^ Polymorphic constructor to match on+     -> r                     -- ^ Default value+     -> (forall b. f b -> r)  -- ^ Polymorphic match+     -> a+     -> r+mkQ1 proxy r br a =+    case l_con == a_con && sameTypeModuloLastApp @a @(f ()) of+      -- We have proven that the two values share the same constructor, and+      -- that they have the same type if you ignore the final application.+      -- Therefore, it is safe to coerce @a@ to @f b@, since @br@ is universal+      -- over @b@ and can't inspect it.+      True  -> br $ unsafeCoerce @_ @(f Any) a+      False -> r+  where+    l_con = toConstr proxy+    a_con = toConstr a+++------------------------------------------------------------------------------+-- | Given @a ~ f1 a1@ and @b ~ f2 b2@, returns true if @f1 ~ f2@.+sameTypeModuloLastApp :: forall a b. (Typeable a, Typeable b) => Bool+sameTypeModuloLastApp =+  let tyrep1 = typeRep @a+      tyrep2 = typeRep @b+   in case (tyrep1 , tyrep2) of+        (App a _, App b _) ->+          case eqTypeRep a b of+            Just HRefl -> True+            Nothing    -> False+        _ -> False+++metaprogramAtQ :: SrcSpan -> GenericQ [(SrcSpan, T.Text)]+metaprogramAtQ ss = everythingContaining ss $ mkQ mempty $ \case+  L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program)+  (_ :: LHsExpr GhcTc) -> mempty+++metaprogramQ :: GenericQ [(SrcSpan, T.Text)]+metaprogramQ = everything (<>) $ mkQ mempty $ \case+  L new_span (WingmanMetaprogram program) -> pure (new_span, T.pack $ unpackFS program)+  (_ :: LHsExpr GhcTc) -> mempty+
+ old/src/Wingman/Judgements/Theta.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++module Wingman.Judgements.Theta+  ( Evidence+  , getEvidenceAtHole+  , mkEvidence+  , evidenceToCoercions+  , evidenceToSubst+  , evidenceToHypothesis+  , evidenceToThetaType+  , allEvidenceToSubst+  ) where++import           Control.Applicative (empty)+import           Control.Lens (preview)+import           Data.Coerce (coerce)+import           Data.Maybe (fromMaybe, mapMaybe, maybeToList)+import           Data.Generics.Sum (_Ctor)+import           Data.Set (Set)+import qualified Data.Set as S+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Generics.SYB hiding (tyConName, empty, Generic)+import           GHC.Generics+import           Wingman.GHC+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++------------------------------------------------------------------------------+-- | Something we've learned about the type environment.+data Evidence+    -- | The two types are equal, via a @a ~ b@ relationship+  = EqualityOfTypes Type Type+    -- | We have an instance in scope+  | HasInstance PredType+  deriving (Show, Generic)+++------------------------------------------------------------------------------+-- | Given a 'PredType', pull an 'Evidence' out of it.+mkEvidence :: PredType -> [Evidence]+mkEvidence (getEqualityTheta -> Just (a, b))+  = pure $ EqualityOfTypes a b+mkEvidence inst@(tcTyConAppTyCon_maybe -> Just (tyConClass_maybe -> Just cls)) = do+  (_, apps) <- maybeToList $ splitTyConApp_maybe inst+  let tvs     = classTyVars cls+      subst   = zipTvSubst tvs apps+  sc_ev <- traverse (mkEvidence . substTy subst) $ classSCTheta cls+  HasInstance inst : sc_ev+mkEvidence _ = empty+++------------------------------------------------------------------------------+-- | Build a set of 'PredType's from the evidence.+evidenceToThetaType :: [Evidence] -> Set CType+evidenceToThetaType evs = S.fromList $ do+  HasInstance t <- evs+  pure $ CType t+++------------------------------------------------------------------------------+-- | Compute all the 'Evidence' implicitly bound at the given 'SrcSpan'.+getEvidenceAtHole :: Tracked age SrcSpan -> Tracked age (LHsBinds GhcTc) -> [Evidence]+getEvidenceAtHole (unTrack -> dst)+  = concatMap mkEvidence+  . (everything (<>) $+        mkQ mempty (absBinds dst) `extQ` wrapperBinds dst `extQ` matchBinds dst)+  . unTrack+++mkSubst :: Set TyVar -> Type -> Type -> TCvSubst+mkSubst skolems a b =+  let tyvars = S.fromList $ mapMaybe getTyVar_maybe [a, b]+      -- If we can unify our skolems, at least one is no longer a skolem.+      -- Removing them from this set ensures we can get a substitution between+      -- the two. But it's okay to leave them in 'ts_skolems' in general, since+      -- they won't exist after running this substitution.+      skolems' = skolems S.\\ tyvars+   in+  case tryUnifyUnivarsButNotSkolems skolems' (CType a) (CType b) of+    Just subst -> subst+    Nothing -> emptyTCvSubst+++substPair :: TCvSubst -> (Type, Type) -> (Type, Type)+substPair subst (ty, ty') = (substTy subst ty, substTy subst ty')+++------------------------------------------------------------------------------+-- | Construct a substitution given a list of types that are equal to one+-- another. This is more subtle than it seems, since there might be several+-- equalities for the same type. We must be careful to push the accumulating+-- substitution through each pair of types before adding their equalities.+allEvidenceToSubst :: Set TyVar -> [(Type, Type)] -> TCvSubst+allEvidenceToSubst _ [] = emptyTCvSubst+allEvidenceToSubst skolems ((a, b) : evs) =+  let subst = mkSubst skolems a b+   in unionTCvSubst subst+    $ allEvidenceToSubst skolems+    $ fmap (substPair subst) evs++------------------------------------------------------------------------------+-- | Given some 'Evidence', get a list of which types are now equal.+evidenceToCoercions :: [Evidence] -> [(CType, CType)]+evidenceToCoercions = coerce . mapMaybe (preview $ _Ctor @"EqualityOfTypes")++------------------------------------------------------------------------------+-- | Update our knowledge of which types are equal.+evidenceToSubst :: [Evidence] -> TacticState -> TacticState+evidenceToSubst evs ts =+  updateSubst+    (allEvidenceToSubst (ts_skolems ts) . coerce $ evidenceToCoercions evs)+    ts+++------------------------------------------------------------------------------+-- | Get all of the methods that are in scope from this piece of 'Evidence'.+evidenceToHypothesis :: Evidence -> Hypothesis CType+evidenceToHypothesis EqualityOfTypes{} = mempty+evidenceToHypothesis (HasInstance t) =+  Hypothesis . excludeForbiddenMethods . fromMaybe [] $ methodHypothesis t+++------------------------------------------------------------------------------+-- | Given @a ~ b@ or @a ~# b@, returns @Just (a, b)@, otherwise @Nothing@.+getEqualityTheta :: PredType -> Maybe (Type, Type)+getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k, a, b]))+#if __GLASGOW_HASKELL__ > 806+  | tc == eqTyCon+#else+  | nameRdrName (tyConName tc) == eqTyCon_RDR+#endif+  = Just (a, b)+getEqualityTheta (splitTyConApp_maybe -> Just (tc, [_k1, _k2, a, b]))+  | tc == eqPrimTyCon = Just (a, b)+getEqualityTheta _ = Nothing+++------------------------------------------------------------------------------+-- | Many operations are defined in typeclasses for performance reasons, rather+-- than being a true part of the class. This function filters out those, in+-- order to keep our hypothesis space small.+excludeForbiddenMethods :: [HyInfo a] -> [HyInfo a]+excludeForbiddenMethods = filter (not . flip S.member forbiddenMethods . hi_name)+  where+    forbiddenMethods :: Set OccName+    forbiddenMethods = S.map mkVarOcc $ S.fromList+      [ -- monadfail+        "fail"+        -- show+      , "showsPrec", "showList"+        -- functor+      , "<$"+        -- applicative+      , "liftA2", "<*", "*>"+        -- monad+      , "return", ">>"+        -- alternative+      , "some", "many"+        -- foldable+      , "foldr1", "foldl1", "elem", "maximum", "minimum", "sum", "product"+        -- traversable+      , "sequenceA", "mapM", "sequence"+        -- semigroup+      , "sconcat", "stimes"+        -- monoid+      , "mconcat"+      ]+++------------------------------------------------------------------------------+-- | Extract evidence from 'AbsBinds' in scope.+absBinds ::  SrcSpan -> LHsBindLR GhcTc GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+absBinds dst (L src (FunBind w _ _ _))+  | dst `isSubspanOf` src+  = wrapper w+absBinds dst (L src (AbsBinds _ _ h _ _ z _))+#else+absBinds dst (L src (AbsBinds _ _ h _ _ _ _))+#endif+  | dst `isSubspanOf` src+  = fmap idType h+#if __GLASGOW_HASKELL__ >= 900+    <> foldMap (absBinds dst) z+#endif+absBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from 'HsWrapper's in scope+wrapperBinds ::  SrcSpan -> LHsExpr GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+wrapperBinds dst (L src (XExpr (WrapExpr (HsWrap h _))))+#else+wrapperBinds dst (L src (HsWrap _ h _))+#endif+  | dst `isSubspanOf` src+  = wrapper h+wrapperBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from the 'ConPatOut's bound in this 'Match'.+matchBinds :: SrcSpan -> LMatch GhcTc (LHsExpr GhcTc) -> [PredType]+matchBinds dst (L src (Match _ _ pats _))+  | dst `isSubspanOf` src+  = everything (<>) (mkQ mempty patBinds) pats+matchBinds _ _ = []+++------------------------------------------------------------------------------+-- | Extract evidence from a 'ConPatOut'.+patBinds ::  Pat GhcTc -> [PredType]+#if __GLASGOW_HASKELL__ >= 900+patBinds (ConPat{ pat_con_ext = ConPatTc { cpt_dicts = dicts }})+#else+patBinds (ConPatOut { pat_dicts = dicts })+#endif+  = fmap idType dicts+patBinds _ = []+++------------------------------------------------------------------------------+-- | Extract the types of the evidence bindings in scope.+wrapper ::  HsWrapper -> [PredType]+wrapper (WpCompose h h2) = wrapper h <> wrapper h2+wrapper (WpEvLam v) = [idType v]+wrapper _ = []+
+ old/src/Wingman/KnownStrategies.hs view
@@ -0,0 +1,82 @@+module Wingman.KnownStrategies where++import Data.Foldable (for_)+import Development.IDE.GHC.Compat.Core+import Refinery.Tactic+import Wingman.Judgements (jGoal)+import Wingman.KnownStrategies.QuickCheck (deriveArbitrary)+import Wingman.Machinery (tracing, getKnownInstance, getCurrentDefinitions)+import Wingman.Tactics+import Wingman.Types+++knownStrategies :: TacticsM ()+knownStrategies = choice+  [ known "fmap" deriveFmap+  , known "mempty" deriveMempty+  , known "arbitrary" deriveArbitrary+  , known "<>" deriveMappend+  , known "mappend" deriveMappend+  ]+++known :: String -> TacticsM () -> TacticsM ()+known name t = do+  getCurrentDefinitions >>= \case+    [(def, _)] | def == mkVarOcc name ->+      tracing ("known " <> name) t+    _ -> failure NoApplicableTactic+++deriveFmap :: TacticsM ()+deriveFmap = do+  try intros+  overAlgebraicTerms homo+  choice+    [ overFunctions (apply Saturated) >> auto' 2+    , assumption+    , recursion+    ]+++------------------------------------------------------------------------------+-- | We derive mappend by binding the arguments, introducing the constructor,+-- and then calling mappend recursively. At each recursive call, we filter away+-- any binding that isn't in an analogous position.+--+-- The recursive call first attempts to use an instance in scope. If that fails,+-- it falls back to trying a theta method from the hypothesis with the correct+-- name.+deriveMappend :: TacticsM ()+deriveMappend = do+  try intros+  destructAll+  split+  g <- goal+  minst <- getKnownInstance (mkClsOcc "Semigroup")+         . pure+         . unCType+         $ jGoal g+  for_ minst $ \(cls, df) -> do+    restrictPositionForApplication+      (applyMethod cls df $ mkVarOcc "<>")+      assumption+  try $+    restrictPositionForApplication+      (applyByName $ mkVarOcc "<>")+      assumption+++------------------------------------------------------------------------------+-- | We derive mempty by introducing the constructor, and then trying to+-- 'mempty' everywhere. This smaller 'mempty' might come from an instance in+-- scope, or it might come from the hypothesis theta.+deriveMempty :: TacticsM ()+deriveMempty = do+  split+  g <- goal+  minst <- getKnownInstance (mkClsOcc "Monoid") [unCType $ jGoal g]+  for_ minst $ \(cls, df) -> do+    applyMethod cls df $ mkVarOcc "mempty"+  try assumption+
+ old/src/Wingman/KnownStrategies/QuickCheck.hs view
@@ -0,0 +1,109 @@+module Wingman.KnownStrategies.QuickCheck where++import Data.Bool (bool)+import Data.Generics (everything, mkQ)+import Data.List (partition)+import Development.IDE.GHC.Compat+import GHC.Exts (IsString (fromString))+import GHC.List (foldl')+import GHC.SourceGen (int)+import GHC.SourceGen.Binds (match, valBind)+import GHC.SourceGen.Expr (case', lambda, let')+import GHC.SourceGen.Overloaded (App ((@@)), HasList (list))+import GHC.SourceGen.Pat (conP)+import Refinery.Tactic (goal, rule, failure)+import Wingman.CodeGen+import Wingman.Judgements (jGoal)+import Wingman.Machinery (tracePrim)+import Wingman.Types+++------------------------------------------------------------------------------+-- | Known tactic for deriving @arbitrary :: Gen a@. This tactic splits the+-- type's data cons into terminal and inductive cases, and generates code that+-- produces a terminal if the QuickCheck size parameter is <=1, or any data con+-- otherwise. It correctly scales recursive parameters, ensuring termination.+deriveArbitrary :: TacticsM ()+deriveArbitrary = do+  ty <- jGoal <$> goal+  case splitTyConApp_maybe $ unCType ty of+    Just (gen_tc, [splitTyConApp_maybe -> Just (tc, apps)])+        | occNameString (occName $ tyConName gen_tc) == "Gen" -> do+      rule $ \_ -> do+        let dcs = tyConDataCons tc+            (terminal, big) = partition ((== 0) . genRecursiveCount)+                        $ fmap (mkGenerator tc apps) dcs+            terminal_expr = mkVal "terminal"+            oneof_expr = mkVal "oneof"+        pure+          $ Synthesized (tracePrim "deriveArbitrary")+              -- TODO(sandy): This thing is not actually empty! We produced+              -- a bespoke binding "terminal", and a not-so-bespoke "n".+              -- But maybe it's fine for known rules?+              mempty+              mempty+              mempty+          $ noLoc $ case terminal of+            [onlyCon] -> genExpr onlyCon -- See #1879+            _ -> let' [valBind (fromString "terminal") $ list $ fmap genExpr terminal] $+                appDollar (mkFunc "sized") $ lambda [bvar' (mkVarOcc "n")] $+                  case' (infixCall "<=" (mkVal "n") (int 1))+                    [ match [conP (fromString "True") []] $+                        oneof_expr @@ terminal_expr+                    , match [conP (fromString "False") []] $+                        appDollar oneof_expr $+                          infixCall "<>"+                            (list $ fmap genExpr big)+                            terminal_expr+                    ]+    _ -> failure $ GoalMismatch "deriveArbitrary" ty+++------------------------------------------------------------------------------+-- | Helper data type for the generator of a specific data con.+data Generator = Generator+  { genRecursiveCount :: Integer+  , genExpr           :: HsExpr GhcPs+  }+++------------------------------------------------------------------------------+-- | Make a 'Generator' for a given tycon instantiated with the given @[Type]@.+mkGenerator :: TyCon -> [Type] -> DataCon -> Generator+mkGenerator tc apps dc = do+  let dc_expr   = var' $ occName $ dataConName dc+      args = conLikeInstOrigArgTys' (RealDataCon dc) apps+      num_recursive_calls = sum $ fmap (bool 0 1 . doesTypeContain tc) args+      mkArbitrary = mkArbitraryCall tc num_recursive_calls+  Generator num_recursive_calls $ case args of+    []  -> mkFunc "pure" @@ dc_expr+    (a : as) ->+      foldl'+        (infixCall "<*>")+        (infixCall "<$>" dc_expr $ mkArbitrary a)+        (fmap mkArbitrary as)+++------------------------------------------------------------------------------+-- | Check if the given 'TyCon' exists anywhere in the 'Type'.+doesTypeContain :: TyCon -> Type -> Bool+doesTypeContain recursive_tc =+  everything (||) $ mkQ False (== recursive_tc)+++------------------------------------------------------------------------------+-- | Generate the correct sort of call to @arbitrary@. For recursive calls, we+-- need to scale down the size parameter, either by a constant factor of 1 if+-- it's the only recursive parameter, or by @`div` n@ where n is the number of+-- recursive parameters. For all other types, just call @arbitrary@ directly.+mkArbitraryCall :: TyCon -> Integer -> Type -> HsExpr GhcPs+mkArbitraryCall recursive_tc n ty =+  let arbitrary = mkFunc "arbitrary"+   in case doesTypeContain recursive_tc ty of+        True ->+          mkFunc "scale"+            @@ bool (mkFunc "flip" @@ mkFunc "div" @@ int n)+                    (mkFunc "subtract" @@ int 1)+                    (n == 1)+            @@ arbitrary+        False -> arbitrary
+ old/src/Wingman/LanguageServer.hs view
@@ -0,0 +1,660 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}++{-# LANGUAGE NoMonoLocalBinds  #-}++module Wingman.LanguageServer where++import           Control.Arrow ((***))+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.RWS+import           Control.Monad.State (State, evalState)+import           Control.Monad.Trans.Maybe+import           Data.Bifunctor (first)+import           Data.Coerce+import           Data.Functor ((<&>))+import           Data.Functor.Identity (runIdentity)+import qualified Data.HashMap.Strict as Map+import           Data.IORef (readIORef)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Text as T+import           Data.Traversable+import           Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction)+import           Development.IDE.Core.PositionMapping (idDelta)+import           Development.IDE.Core.RuleTypes+import           Development.IDE.Core.Rules (usePropertyAction)+import           Development.IDE.Core.Service (runAction)+import           Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule)+import qualified Development.IDE.Core.Shake as IDE+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Development.IDE.GHC.Compat.ExactPrint+import qualified Development.IDE.GHC.Compat.Util as FastString+import           Development.IDE.GHC.Error (realSrcSpanToRange)+import           Development.IDE.GHC.ExactPrint hiding (LogShake, Log)+import           Development.IDE.Graph (Action, RuleResult, Rules, action)+import           Development.IDE.Graph.Classes (Hashable, NFData)+import           Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings)+import           GHC.Generics (Generic)+import           Generics.SYB hiding (Generic)+import           Ide.Plugin.Properties+import           Ide.Types (PluginId)+import           Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty)+import           Language.LSP.Server (MonadLsp, sendNotification)+import           Language.LSP.Types              hiding+                                                 (SemanticTokenAbsolute (length, line),+                                                  SemanticTokenRelative (length),+                                                  SemanticTokensEdit (_start))+import           Language.LSP.Types.Capabilities+import           Prelude hiding (span)+import           Retrie (transformA)+import           Wingman.Context+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ)+import           Wingman.Judgements.Theta+import           Wingman.Range+import           Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax)+import           Wingman.Types+import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))+import qualified Development.IDE.Core.Shake as Shake+++newtype Log+  = LogShake Shake.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogShake shakeLog -> pretty shakeLog++tacticDesc :: T.Text -> T.Text+tacticDesc name = "fill the hole using the " <> name <> " tactic"+++------------------------------------------------------------------------------+-- | The name of the command for the LS.+tcCommandName :: TacticCommand -> T.Text+tcCommandName = T.pack . show+++runIde :: String -> String -> IdeState -> Action a -> IO a+runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state++runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a+runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state)+++runCurrentIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO (Tracked 'Current r)+runCurrentIde herald state nfp a =+  MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp+++runStaleIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO (TrackedStale r)+runStaleIde herald state nfp a =+  MaybeT $ runIde herald (show a) state $ useWithStale a nfp+++unsafeRunStaleIde+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO r+unsafeRunStaleIde herald state nfp a = do+  (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp+  pure r++unsafeRunStaleIdeFast+    :: forall a r+     . ( r ~ RuleResult a+       , Eq a , Hashable a , Show a , Typeable a , NFData a+       , Show r, Typeable r, NFData r+       )+    => String+    -> IdeState+    -> NormalizedFilePath+    -> a+    -> MaybeT IO r+unsafeRunStaleIdeFast herald state nfp a = do+  (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp+  pure r+++------------------------------------------------------------------------------++properties :: Properties+  '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity))+   , 'PropertyKey "max_use_ctor_actions" 'TInteger+   , 'PropertyKey "timeout_duration" 'TInteger+   , 'PropertyKey "auto_gas" 'TInteger+   , 'PropertyKey "proofstate_styling" 'TBoolean+   ]+properties = emptyProperties+  & defineBooleanProperty #proofstate_styling+    "Should Wingman emit styling markup when showing metaprogram proof states?" True+  & defineIntegerProperty #auto_gas+    "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4+  & defineIntegerProperty #timeout_duration+    "The timeout for Wingman actions, in seconds" 2+  & defineIntegerProperty #max_use_ctor_actions+    "Maximum number of `Use constructor <x>` code actions that can appear" 5+  & defineEnumProperty #hole_severity+    "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities."+    [ (Just DsError,   "error")+    , (Just DsWarning, "warning")+    , (Just DsInfo,    "info")+    , (Just DsHint,    "hint")+    , (Nothing,        "none")+    ]+    Nothing+++-- | Get the the plugin config+getTacticConfigAction :: PluginId -> Action Config+getTacticConfigAction pId =+  Config+    <$> usePropertyAction #max_use_ctor_actions pId properties+    <*> usePropertyAction #timeout_duration pId properties+    <*> usePropertyAction #auto_gas pId properties+    <*> usePropertyAction #proofstate_styling pId properties+++getIdeDynflags+    :: IdeState+    -> NormalizedFilePath+    -> MaybeT IO DynFlags+getIdeDynflags state nfp = do+  -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags'+  -- which don't change very often.+  msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps+  pure $ ms_hspp_opts $ msrModSummary msr++getAllMetaprograms :: Data a => a -> [String]+getAllMetaprograms = everything (<>) $ mkQ mempty $ \case+  WingmanMetaprogram fs -> [ FastString.unpackFS fs ]+  (_ :: HsExpr GhcTc)  -> mempty+++------------------------------------------------------------------------------+-- | Find the last typechecked module, and find the most specific span, as well+-- as the judgement at the given range.+judgementForHole+    :: IdeState+    -> NormalizedFilePath+    -> Tracked 'Current Range+    -> Config+    -> MaybeT IO HoleJudgment+judgementForHole state nfp range cfg = do+  let stale a = runStaleIde "judgementForHole" state nfp a++  TrackedStale asts amapping  <- stale GetHieAst+  case unTrack asts of+    HAR _ _  _ _ (HieFromDisk _) -> fail "Need a fresh hie file"+    HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do+      range' <- liftMaybe $ mapAgeFrom amapping range+      binds <- stale GetBindings+      tcg@(TrackedStale tcg_t tcg_map)+          <- fmap (fmap tmrTypechecked)+           $ stale TypeCheck++      hscenv <- stale GhcSessionDeps++      (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf++      new_rss <- liftMaybe $ mapAgeTo amapping rss+      tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss++      -- KnownThings is just the instances in scope. There are no ranges+      -- involved, so it's not crucial to track ages.+      let henv = untrackedStaleValue hscenv+      eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv++      (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps+      let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t++      dflags <- getIdeDynflags state nfp+      pure $ HoleJudgment+        { hj_range = fmap realSrcSpanToRange new_rss+        , hj_jdg = jdg+        , hj_ctx = ctx+        , hj_dflags = dflags+        , hj_hole_sort = holeSortFor mp+        }+++holeSortFor :: Maybe T.Text -> HoleSort+holeSortFor = maybe Hole Metaprogram+++mkJudgementAndContext+    :: Config+    -> Type+    -> TrackedStale Bindings+    -> Tracked 'Current RealSrcSpan+    -> TrackedStale TcGblEnv+    -> HscEnv+    -> ExternalPackageState+    -> Maybe (Judgement, Context)+mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do+  binds_rss <- mapAgeFrom bmap rss+  tcg_rss <- mapAgeFrom tcgmap rss++  let tcs = fmap tcg_binds tcg+      ctx = mkContext cfg+              (mapMaybe (sequenceA . (occName *** coerce))+                $ unTrack+                $ getDefiningBindings <$> binds <*> binds_rss)+              (unTrack tcg)+              hscenv+              eps+              evidence+      top_provs = getRhsPosVals tcg_rss tcs+      already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs+      local_hy = spliceProvenance top_provs+               $ hypothesisFromBindings binds_rss binds+      evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs+      cls_hy = foldMap evidenceToHypothesis evidence+      subst = ts_unifier $ evidenceToSubst evidence defaultTacticState+  pure+    ( disallowing AlreadyDestructed already_destructed+    $ fmap (CType . substTyAddInScope subst . unCType) $+        mkFirstJudgement+          ctx+          (local_hy <> cls_hy)+          (isRhsHoleWithoutWhere tcg_rss tcs)+          g+    , ctx+    )+++------------------------------------------------------------------------------+-- | Determine which bindings have already been destructed by the location of+-- the hole.+getAlreadyDestructed+    :: Tracked age SrcSpan+    -> Tracked age (LHsBinds GhcTc)+    -> Set OccName+getAlreadyDestructed (unTrack -> span) (unTrack -> binds) =+  everythingContaining span+    (mkQ mempty $ \case+      Case (HsVar _ (L _ (occName -> var))) _ ->+        S.singleton var+      (_ :: HsExpr GhcTc) -> mempty+    ) binds+++getSpanAndTypeAtHole+    :: Tracked age Range+    -> Tracked age (HieASTs Type)+    -> Maybe (Tracked age RealSrcSpan, Type)+getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do+  join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->+    case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of+      Nothing -> Nothing+      Just ast' -> do+        let info = nodeInfo ast'+        ty <- listToMaybe $ nodeType info+        guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info+        -- Ensure we're actually looking at a hole here+        occ <- (either (const Nothing) (Just . occName) =<<)+             . listToMaybe+             . S.toList+             . M.keysSet+             $ nodeIdentifiers info+        guard $ isHole occ+        pure (unsafeCopyAge r $ nodeSpan ast', ty)++++------------------------------------------------------------------------------+-- | Combine two (possibly-overlapping) hypotheses; using the provenance from+-- the first hypothesis if the bindings overlap.+spliceProvenance+    :: Hypothesis a  -- ^ Bindings to keep+    -> Hypothesis a  -- ^ Bindings to keep if they don't overlap with the first set+    -> Hypothesis a+spliceProvenance top x =+  let bound = S.fromList $ fmap hi_name $ unHypothesis top+   in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x+++------------------------------------------------------------------------------+-- | Compute top-level position vals of a function+getRhsPosVals+    :: Tracked age RealSrcSpan+    -> Tracked age TypecheckedSource+    -> Hypothesis CType+getRhsPosVals (unTrack -> rss) (unTrack -> tcs)+  = everything (<>) (mkQ mempty $ \case+      TopLevelRHS name ps+          (L (RealSrcSpan span _)  -- body with no guards and a single defn+            (HsVar _ (L _ hole)))+          _+        | containsSpan rss span  -- which contains our span+        , isHole $ occName hole  -- and the span is a hole+        -> flip evalState 0 $ buildTopLevelHypothesis name ps+      _ -> mempty+  ) tcs+++------------------------------------------------------------------------------+-- | Construct a hypothesis given the patterns from the left side of a HsMatch.+-- These correspond to things that the user put in scope before running+-- tactics.+buildTopLevelHypothesis+    :: OccName  -- ^ Function name+    -> [PatCompat GhcTc]+    -> State Int (Hypothesis CType)+buildTopLevelHypothesis name ps = do+  fmap mconcat $+    for (zip [0..] ps) $ \(ix, p) ->+      buildPatHy (TopLevelArgPrv name ix $ length ps) p+++------------------------------------------------------------------------------+-- | Construct a hypothesis for a single pattern, including building+-- sub-hypotheses for constructor pattern matches.+buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType)+buildPatHy prov (fromPatCompat -> p0) =+  case p0 of+    VarPat  _ x   -> pure $ mkIdHypothesis (unLoc x) prov+    LazyPat _ p   -> buildPatHy prov p+    AsPat   _ x p -> do+      hy' <- buildPatHy prov p+      pure $ mkIdHypothesis (unLoc x) prov <> hy'+    ParPat  _ p   -> buildPatHy prov p+    BangPat _ p   -> buildPatHy prov p+    ViewPat _ _ p -> buildPatHy prov p+    -- Desugar lists into cons+    ListPat _ [] -> pure mempty+    ListPat x@(ListPatTc ty _) (p : ps) ->+      mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty]+        [ (0, p)+        , (1, toPatCompat $ ListPat x ps)+        ]+    -- Desugar tuples into an explicit constructor+    TuplePat tys pats boxity ->+      mkDerivedConHypothesis+        prov+        (RealDataCon $ tupleDataCon boxity $ length pats)+        tys+          $ zip [0.. ] pats+#if __GLASGOW_HASKELL__ >= 900+    ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} ->+#else+    ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} ->+#endif+      case f of+        PrefixCon l_pgt ->+          mkDerivedConHypothesis prov con args $ zip [0..] l_pgt+        InfixCon pgt pgt5 ->+          mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5]+        RecCon r ->+          mkDerivedRecordHypothesis prov con args r+    SigPat  _ p _ -> buildPatHy prov p+    _             -> pure mempty+++------------------------------------------------------------------------------+-- | Like 'mkDerivedConHypothesis', but for record patterns.+mkDerivedRecordHypothesis+    :: Provenance+    -> ConLike  -- ^ Destructing constructor+    -> [Type]   -- ^ Applied type variables+    -> HsRecFields GhcTc (PatCompat GhcTc)+    -> State Int (Hypothesis CType)+mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _)+  | Just rec_fields <- getRecordFields dc+  = do+    let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..]+    mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) ->+      ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ)+      , p+      )+mkDerivedRecordHypothesis _ _ _ _ =+  error "impossible! using record pattern on something that isn't a record"+++------------------------------------------------------------------------------+-- | Construct a fake variable name. Used to track the provenance of top-level+-- pattern matches which otherwise wouldn't have anything to attach their+-- 'TopLevelArgPrv' to.+mkFakeVar :: State Int OccName+mkFakeVar = do+  i <- get+  put $ i + 1+  pure $ mkVarOcc $ "_" <> show i+++------------------------------------------------------------------------------+-- | Construct a fake variable to attach the current 'Provenance' to, and then+-- build a sub-hypothesis for the pattern match.+mkDerivedConHypothesis+    :: Provenance+    -> ConLike                   -- ^ Destructing constructor+    -> [Type]                    -- ^ Applied type variables+    -> [(Int, PatCompat GhcTc)]  -- ^ Patterns, and their order in the data con+    -> State Int (Hypothesis CType)+mkDerivedConHypothesis prov dc args ps = do+  var <- mkFakeVar+  hy' <- fmap mconcat $+    for ps $ \(ix, p) -> do+      let prov' = PatternMatchPrv+               $ PatVal (Just var)+                        (S.singleton var <> provAncestryOf prov)+                        (Uniquely dc)+                        ix+      buildPatHy prov' p+  pure+    $ mappend hy'+    $ Hypothesis+    $ pure+    $ HyInfo var (DisallowedPrv AlreadyDestructed prov)+    $ CType+    -- TODO(sandy): This is the completely wrong type, but we don't have a good+    -- way to get the real one. It's probably OK though, since we're generating+    -- this term with a disallowed provenance, and it doesn't actually exist+    -- anyway.+    $ conLikeResTy dc args+++------------------------------------------------------------------------------+-- | Build a 'Hypothesis' given an 'Id'.+mkIdHypothesis :: Id -> Provenance -> Hypothesis CType+mkIdHypothesis (splitId -> (name, ty)) prov =+  Hypothesis $ pure $ HyInfo name prov ty+++------------------------------------------------------------------------------+-- | Is this hole immediately to the right of an equals sign --- and is there+-- no where clause attached to it?+--+-- It's important that there is no where clause because otherwise it gets+-- clobbered. See #2183 for an example.+--+-- This isn't a perfect check, and produces some ugly code. But it's much much+-- better than the alternative, which is to destructively modify the user's+-- AST.+isRhsHoleWithoutWhere+    :: Tracked age RealSrcSpan+    -> Tracked age TypecheckedSource+    -> Bool+isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) =+  everything (||) (mkQ False $ \case+      TopLevelRHS _ _+          (L (RealSrcSpan span _) _)+          (EmptyLocalBinds _) -> containsSpan rss span+      _                       -> False+    ) tcs+++ufmSeverity :: UserFacingMessage -> MessageType+ufmSeverity NotEnoughGas            = MtInfo+ufmSeverity TacticErrors            = MtError+ufmSeverity TimedOut                = MtInfo+ufmSeverity NothingToDo             = MtInfo+ufmSeverity (InfrastructureError _) = MtError+++mkShowMessageParams :: UserFacingMessage -> ShowMessageParams+mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm+++showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m ()+showLspMessage = sendNotification SWindowShowMessage+++-- This rule only exists for generating file diagnostics+-- so the RuleResult is empty+data WriteDiagnostics = WriteDiagnostics+    deriving (Eq, Show, Typeable, Generic)++instance Hashable WriteDiagnostics+instance NFData   WriteDiagnostics++type instance RuleResult WriteDiagnostics = ()++data GetMetaprograms = GetMetaprograms+    deriving (Eq, Show, Typeable, Generic)++instance Hashable GetMetaprograms+instance NFData   GetMetaprograms++type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)]++wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules ()+wingmanRules recorder plId = do+  define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp ->+    usePropertyAction #hole_severity plId properties >>= \case+      Nothing -> pure (mempty, Just ())+      Just severity ->+        use GetParsedModule nfp >>= \case+          Nothing ->+            pure ([], Nothing)+          Just pm -> do+            let holes :: [Range]+                holes =+                  everything (<>)+                    (mkQ mempty $ \case+                      L span (HsVar _ (L _ name))+                        | isHole (occName name) ->+                            maybeToList $ srcSpanToRange span+#if __GLASGOW_HASKELL__ >= 900+                      L span (HsUnboundVar _ occ)+#else+                      L span (HsUnboundVar _ (TrueExprHole occ))+#endif+                        | isHole occ ->+                            maybeToList $ srcSpanToRange span+                      (_ :: LHsExpr GhcPs) -> mempty+                    ) $ pm_parsed_source pm+            pure+              ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes+              , Just ()+              )++  defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do+    TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp+    let scrutinees = traverse (metaprogramQ . tcg_binds) tcg+    return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do+      case ss of+        RealSrcSpan r _ -> do+          rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r+          pure (rss', program)+        UnhelpfulSpan _ -> Nothing++  -- This persistent rule helps to avoid blocking HLS hover providers at startup+  -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other+  -- hover providers from being used to produce a response+  addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing)++  action $ do+    files <- getFilesOfInterestUntracked+    void $ uses WriteDiagnostics $ Map.keys files+++mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic+mkDiagnostic severity r =+  Diagnostic r+    (Just severity)+    (Just $ InR "hole")+    (Just "wingman")+    "Hole"+    (Just $ List [DtUnnecessary])+    Nothing+++------------------------------------------------------------------------------+-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'.+mkWorkspaceEdits+    :: DynFlags+    -> ClientCapabilities+    -> Uri+    -> Annotated ParsedSource+    -> Graft (Either String) ParsedSource+    -> Either UserFacingMessage WorkspaceEdit+mkWorkspaceEdits dflags ccs uri pm g = do+  let pm' = runIdentity $ transformA pm annotateMetaprograms+  let response = transform dflags ccs uri g pm'+   in first (InfrastructureError . T.pack) response+++------------------------------------------------------------------------------+-- | Add ExactPrint annotations to every metaprogram in the source tree.+-- Usually the ExactPrint module can do this for us, but we've enabled+-- QuasiQuotes, so the round-trip print/parse journey will crash.+annotateMetaprograms :: Data a => a -> Transform a+annotateMetaprograms = everywhereM $ mkM $ \case+  L ss (WingmanMetaprogram mp) -> do+    let x = L ss $ MetaprogramSyntax mp+    let anns = addAnnotationsForPretty [] x mempty+    modifyAnnsT $ mappend anns+    pure x+  (x :: LHsExpr GhcPs) -> pure x+++------------------------------------------------------------------------------+-- | Find the source of a tactic metaprogram at the given span.+getMetaprogramAtSpan+    :: Tracked age SrcSpan+    -> Tracked age TcGblEnv+    -> Maybe T.Text+getMetaprogramAtSpan (unTrack -> ss)+  = fmap snd+  . listToMaybe+  . metaprogramAtQ ss+  . tcg_binds+  . unTrack+
+ old/src/Wingman/LanguageServer/Metaprogram.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}++{-# LANGUAGE NoMonoLocalBinds  #-}+{-# LANGUAGE RankNTypes #-}++module Wingman.LanguageServer.Metaprogram+  ( hoverProvider+  ) where++import           Control.Applicative (empty)+import           Control.Monad+import           Control.Monad.Trans+import           Control.Monad.Trans.Maybe+import           Data.List (find)+import           Data.Maybe+import qualified Data.Text as T+import           Development.IDE (positionToRealSrcLoc, realSrcSpanToRange)+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (empty)+import           Ide.Types+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.LanguageServer+import           Wingman.Metaprogramming.Parser (attempt_it)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Provide the "empty case completion" code lens+hoverProvider :: PluginMethodHandler IdeState TextDocumentHover+hoverProvider state plId (HoverParams (TextDocumentIdentifier uri) (unsafeMkCurrent -> pos) _)+  | Just nfp <- uriToNormalizedFilePath $ toNormalizedUri uri = do+      let loc = fmap (realSrcLocSpan . positionToRealSrcLoc nfp) pos+          stale = unsafeRunStaleIdeFast "hoverProvider" state nfp++      cfg <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId)+      liftIO $ fromMaybeT (Right Nothing) $ do+        holes <- stale GetMetaprograms++        fmap (Right . Just) $+          case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of+            Just (trss, program) -> do+              let tr_range = fmap realSrcSpanToRange trss+                  rsl = realSrcSpanStart $ unTrack trss+              HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg+              z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program+              pure $ Hover+                { _contents = HoverContents+                            $ MarkupContent MkMarkdown+                            $ either T.pack T.pack z+                , _range = Just $ unTrack tr_range+                }+            Nothing -> empty+hoverProvider _ _ _ = pure $ Right Nothing++fromMaybeT :: Functor m => a -> MaybeT m a -> m a+fromMaybeT def = fmap (fromMaybe def) . runMaybeT
+ old/src/Wingman/LanguageServer/TacticProviders.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Wingman.LanguageServer.TacticProviders+  ( commandProvider+  , commandTactic+  , TacticProviderData (..)+  ) where++import           Control.Monad+import           Data.Bool (bool)+import           Data.Coerce+import           Data.Maybe+import           Data.Monoid+import qualified Data.Set as S+import qualified Data.Text as T+import           Development.IDE.GHC.Compat+import           Ide.Types hiding (Config)+import           Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..))+import           Prelude hiding (span)+import           Wingman.AbstractLSP.Types+import           Wingman.Auto+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons)+import           Wingman.Metaprogramming.Parser (parseMetaprogram)+import           Wingman.Tactics+import           Wingman.Types+++------------------------------------------------------------------------------+-- | A mapping from tactic commands to actual tactics for refinery.+commandTactic :: TacticCommand -> T.Text -> TacticsM ()+commandTactic Auto                   = const auto+commandTactic Intros                 = const intros+commandTactic IntroAndDestruct       = const introAndDestruct+commandTactic Destruct               = useNameFromHypothesis destruct . mkVarOcc . T.unpack+commandTactic DestructPun            = useNameFromHypothesis destructPun . mkVarOcc . T.unpack+commandTactic Homomorphism           = useNameFromHypothesis homo . mkVarOcc . T.unpack+commandTactic DestructLambdaCase     = const destructLambdaCase+commandTactic HomomorphismLambdaCase = const homoLambdaCase+commandTactic DestructAll            = const destructAll+commandTactic UseDataCon             = userSplit . mkVarOcc . T.unpack+commandTactic Refine                 = const refine+commandTactic BeginMetaprogram       = const metaprogram+commandTactic RunMetaprogram         = parseMetaprogram+++------------------------------------------------------------------------------+-- | The LSP kind+tacticKind :: TacticCommand -> T.Text+tacticKind Auto                   = "fillHole"+tacticKind Intros                 = "introduceLambda"+tacticKind IntroAndDestruct       = "introduceAndDestruct"+tacticKind Destruct               = "caseSplit"+tacticKind DestructPun            = "caseSplitPun"+tacticKind Homomorphism           = "homomorphicCaseSplit"+tacticKind DestructLambdaCase     = "lambdaCase"+tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase"+tacticKind DestructAll            = "splitFuncArgs"+tacticKind UseDataCon             = "useConstructor"+tacticKind Refine                 = "refine"+tacticKind BeginMetaprogram       = "beginMetaprogram"+tacticKind RunMetaprogram         = "runMetaprogram"+++------------------------------------------------------------------------------+-- | Whether or not this code action is preferred -- ostensibly refers to+-- whether or not we can bind it to a key in vs code?+tacticPreferred :: TacticCommand -> Bool+tacticPreferred Auto                   = True+tacticPreferred Intros                 = True+tacticPreferred IntroAndDestruct       = True+tacticPreferred Destruct               = True+tacticPreferred DestructPun            = False+tacticPreferred Homomorphism           = True+tacticPreferred DestructLambdaCase     = False+tacticPreferred HomomorphismLambdaCase = False+tacticPreferred DestructAll            = True+tacticPreferred UseDataCon             = True+tacticPreferred Refine                 = True+tacticPreferred BeginMetaprogram       = False+tacticPreferred RunMetaprogram         = True+++mkTacticKind :: TacticCommand -> CodeActionKind+mkTacticKind =+  CodeActionUnknown . mappend "refactor.wingman." . tacticKind+++------------------------------------------------------------------------------+-- | Mapping from tactic commands to their contextual providers. See 'provide',+-- 'filterGoalType' and 'filterBindingType' for the nitty gritty.+commandProvider :: TacticCommand -> TacticProvider+commandProvider Auto  =+  requireHoleSort (== Hole) $+  provide Auto ""+commandProvider Intros =+  requireHoleSort (== Hole) $+  filterGoalType isFunction $+    provide Intros ""+commandProvider IntroAndDestruct =+  requireHoleSort (== Hole) $+  filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $+    provide IntroAndDestruct ""+commandProvider Destruct =+  requireHoleSort (== Hole) $+  filterBindingType destructFilter $ \occ _ ->+    provide Destruct $ T.pack $ occNameString occ+commandProvider DestructPun =+  requireHoleSort (== Hole) $+    filterBindingType destructPunFilter $ \occ _ ->+      provide DestructPun $ T.pack $ occNameString occ+commandProvider Homomorphism =+  requireHoleSort (== Hole) $+  filterBindingType homoFilter $ \occ _ ->+    provide Homomorphism $ T.pack $ occNameString occ+commandProvider DestructLambdaCase =+  requireHoleSort (== Hole) $+  requireExtension LambdaCase $+    filterGoalType (isJust . lambdaCaseable) $+      provide DestructLambdaCase ""+commandProvider HomomorphismLambdaCase =+  requireHoleSort (== Hole) $+  requireExtension LambdaCase $+    filterGoalType (liftLambdaCase False homoFilter) $+      provide HomomorphismLambdaCase ""+commandProvider DestructAll =+  requireHoleSort (== Hole) $+    withJudgement $ \jdg ->+      case _jIsTopHole jdg && jHasBoundArgs jdg of+        True  -> provide DestructAll ""+        False -> mempty+commandProvider UseDataCon =+  requireHoleSort (== Hole) $+  withConfig $ \cfg ->+    filterTypeProjection+        ( guardLength (<= cfg_max_use_ctor_actions cfg)+        . maybe [] fst+        . tacticsGetDataCons+        ) $ \dcon ->+      provide UseDataCon+        . T.pack+        . occNameString+        . occName+        $ dataConName dcon+commandProvider Refine =+  requireHoleSort (== Hole) $+    provide Refine ""+commandProvider BeginMetaprogram =+  requireHoleSort (== Hole) $+    provide BeginMetaprogram ""+commandProvider RunMetaprogram =+  withMetaprogram $ \mp ->+    provide RunMetaprogram mp+++------------------------------------------------------------------------------+-- | Return an empty list if the given predicate doesn't hold over the length+guardLength :: (Int -> Bool) -> [a] -> [a]+guardLength f as = bool [] as $ f $ length as+++------------------------------------------------------------------------------+-- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS+-- UI.+type TacticProvider+     = TacticProviderData+    -> [(Metadata, T.Text)]+++data TacticProviderData = TacticProviderData+  { tpd_lspEnv :: LspEnv+  , tpd_jdg    :: Judgement+  , tpd_hole_sort :: HoleSort+  }+++requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider+requireHoleSort p tp tpd =+  case p $ tpd_hole_sort tpd of+    True  -> tp tpd+    False -> []++withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider+withMetaprogram tp tpd =+  case tpd_hole_sort tpd of+    Metaprogram mp -> tp mp tpd+    _ -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+requireExtension :: Extension -> TacticProvider -> TacticProvider+requireExtension ext tp tpd =+  case xopt ext $ le_dflags $ tpd_lspEnv tpd of+    True  -> tp tpd+    False -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider+filterGoalType p tp tpd =+  case p $ unCType $ jGoal $ tpd_jdg tpd of+    True  -> tp tpd+    False -> []+++------------------------------------------------------------------------------+-- | Restrict a 'TacticProvider', making sure it appears only when the given+-- predicate holds for the goal.+withJudgement :: (Judgement -> TacticProvider) -> TacticProvider+withJudgement tp tpd = tp (tpd_jdg tpd) tpd+++------------------------------------------------------------------------------+-- | Multiply a 'TacticProvider' for each binding, making sure it appears only+-- when the given predicate holds over the goal and binding types.+filterBindingType+    :: (Type -> Type -> Bool)  -- ^ Goal and then binding types.+    -> (OccName -> Type -> TacticProvider)+    -> TacticProvider+filterBindingType p tp tpd =+  let jdg = tpd_jdg tpd+      hy  = jLocalHypothesis jdg+      g   = jGoal jdg+   in unHypothesis hy >>= \hi ->+        let ty = unCType $ hi_type hi+         in case p (unCType g) ty of+              True  -> tp (hi_name hi) ty tpd+              False -> []+++------------------------------------------------------------------------------+-- | Multiply a 'TacticProvider' by some feature projection out of the goal+-- type. Used e.g. to crete a code action for every data constructor.+filterTypeProjection+    :: (Type -> [a])  -- ^ Features of the goal to look into further+    -> (a -> TacticProvider)+    -> TacticProvider+filterTypeProjection p tp tpd =+  (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a ->+      tp a tpd+++------------------------------------------------------------------------------+-- | Get access to the 'Config' when building a 'TacticProvider'.+withConfig :: (Config -> TacticProvider) -> TacticProvider+withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd+++------------------------------------------------------------------------------+-- | Terminal constructor for providing context-sensitive tactics. Tactics+-- given by 'provide' are always available.+provide :: TacticCommand -> T.Text -> TacticProvider+provide tc name _ =+  pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name)+++------------------------------------------------------------------------------+-- | Construct a 'CommandId'+tcCommandId :: TacticCommand -> CommandId+tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command"+++------------------------------------------------------------------------------+-- | We should show homos only when the goal type is the same as the binding+-- type, and that both are usual algebraic types.+homoFilter :: Type -> Type -> Bool+homoFilter codomain domain =+  case uncoveredDataCons domain codomain of+    Just s -> S.null s+    _ -> False+++------------------------------------------------------------------------------+-- | Lift a function of (codomain, domain) over a lambda case.+liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r+liftLambdaCase nil f t =+  case tacticsSplitFunTy t of+    (_, _, arg : _, res) -> f res $ scaledThing arg+    _ -> nil++++------------------------------------------------------------------------------+-- | We should show destruct for bindings only when those bindings have usual+-- algebraic types.+destructFilter :: Type -> Type -> Bool+destructFilter _ (algebraicTyCon -> Just _) = True+destructFilter _ _ = False+++------------------------------------------------------------------------------+-- | We should show destruct punning for bindings only when those bindings have+-- usual algebraic types, and when any of their data constructors are records.+destructPunFilter :: Type -> Type -> Bool+destructPunFilter _ (algebraicTyCon -> Just tc) =+  not . all (null . dataConFieldLabels) $ tyConDataCons tc+destructPunFilter _ _ = False+++instance IsContinuationSort TacticCommand where+  toCommandId = tcCommandId+
+ old/src/Wingman/Machinery.hs view
@@ -0,0 +1,450 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE TupleSections #-}++module Wingman.Machinery where++import           Control.Applicative (empty)+import           Control.Concurrent.Chan.Unagi.NoBlocking (newChan, writeChan, OutChan, tryRead, tryReadChan)+import           Control.Lens ((<>~))+import           Control.Monad.Reader+import           Control.Monad.State.Class (gets, modify, MonadState)+import           Control.Monad.State.Strict (StateT (..), execStateT)+import           Control.Monad.Trans.Maybe+import           Data.Coerce+import           Data.Foldable+import           Data.Functor ((<&>))+import           Data.Generics (everything, gcount, mkQ)+import           Data.Generics.Product (field')+import           Data.List (sortBy)+import qualified Data.Map as M+import           Data.Maybe (mapMaybe, isNothing)+import           Data.Monoid (getSum)+import           Data.Ord (Down (..), comparing)+import qualified Data.Set as S+import           Data.Traversable (for)+import           Development.IDE.Core.Compile (lookupName)+import           Development.IDE.GHC.Compat hiding (isTopLevel, empty)+import           Refinery.Future+import           Refinery.ProofState+import           Refinery.Tactic+import           Refinery.Tactic.Internal+import           System.Timeout (timeout)+import           Wingman.Context (getInstance)+import           Wingman.GHC (tryUnifyUnivarsButNotSkolems, updateSubst, tacticsGetDataCons, freshTyvars, tryUnifyUnivarsButNotSkolemsMany)+import           Wingman.Judgements+import           Wingman.Simplify (simplify)+import           Wingman.Types++#if __GLASGOW_HASKELL__ < 900+import FunDeps (fd_eqs, improveFromInstEnv)+import Pair (unPair)+#else+import GHC.Tc.Instance.FunDeps (fd_eqs, improveFromInstEnv)+import GHC.Data.Pair (unPair)+#endif+++substCTy :: TCvSubst -> CType -> CType+substCTy subst = coerce . substTy subst . coerce+++getSubstForJudgement+    :: MonadState TacticState m+    => Judgement+    -> m TCvSubst+getSubstForJudgement j = do+  -- NOTE(sandy): It's OK to use mempty here, because coercions _can_ give us+  -- substitutions for skolems.+  let coercions = j_coercion j+  unifier <- gets ts_unifier+  pure $ unionTCvSubst unifier coercions++------------------------------------------------------------------------------+-- | Produce a subgoal that must be solved before we can solve the original+-- goal.+newSubgoal+    :: Judgement+    -> Rule+newSubgoal j = do+  ctx <- ask+  unifier <- getSubstForJudgement j+  subgoal+    $ normalizeJudgement ctx+    $ substJdg unifier+    $ unsetIsTopHole+    $ normalizeJudgement ctx j+++tacticToRule :: Judgement -> TacticsM () -> Rule+tacticToRule jdg (TacticT tt) = RuleT $ execStateT tt jdg >>= flip Subgoal Axiom+++consumeChan :: OutChan (Maybe a) -> IO [a]+consumeChan chan = do+  tryReadChan chan >>= tryRead >>= \case+    Nothing -> pure []+    Just (Just a) -> (a:) <$> consumeChan chan+    Just Nothing -> pure []+++------------------------------------------------------------------------------+-- | Attempt to generate a term of the right type using in-scope bindings, and+-- a given tactic.+runTactic+    :: Int          -- ^ Timeout+    -> Context+    -> Judgement+    -> TacticsM ()  -- ^ Tactic to use+    -> IO (Either [TacticError] RunTacticResults)+runTactic duration ctx jdg t = do+    let skolems = S.fromList+                $ foldMap (tyCoVarsOfTypeWellScoped . unCType)+                $ (:) (jGoal jdg)+                $ fmap hi_type+                $ toList+                $ hyByName+                $ jHypothesis jdg+        tacticState =+          defaultTacticState+            { ts_skolems = skolems+            }++    let stream = hoistListT (flip runReaderT ctx . unExtractM)+               $ runStreamingTacticT t jdg tacticState+    (in_proofs, out_proofs) <- newChan+    (in_errs, out_errs) <- newChan+    timed_out <-+      fmap isNothing $ timeout duration $ consume stream $ \case+        Left err -> writeChan in_errs $ Just err+        Right proof -> writeChan in_proofs $ Just proof+    writeChan in_proofs Nothing++    solns <- consumeChan out_proofs+    let sorted =+          flip sortBy solns $ comparing $ \(Proof ext _ holes) ->+            Down $ scoreSolution ext jdg $ fmap snd holes+    case sorted of+      ((Proof syn _ subgoals) : _) ->+        pure $ Right $+          RunTacticResults+            { rtr_trace    = syn_trace syn+            , rtr_extract  = simplify $ syn_val syn+            , rtr_subgoals = fmap snd subgoals+            , rtr_other_solns = reverse . fmap pf_extract $ sorted+            , rtr_jdg = jdg+            , rtr_ctx = ctx+            , rtr_timed_out = timed_out+            }+      _ -> fmap Left $ consumeChan out_errs+++tracePrim :: String -> Trace+tracePrim = flip rose []+++------------------------------------------------------------------------------+-- | Mark that a tactic used the given string in its extract derivation. Mainly+-- used for debugging the search when things go terribly wrong.+tracing+    :: Functor m+    => String+    -> TacticT jdg (Synthesized ext) err s m a+    -> TacticT jdg (Synthesized ext) err s m a+tracing s = mappingExtract (mapTrace $ rose s . pure)+++------------------------------------------------------------------------------+-- | Mark that a tactic performed recursion. Doing so incurs a small penalty in+-- the score.+markRecursion+    :: Functor m+    => TacticT jdg (Synthesized ext) err s m a+    -> TacticT jdg (Synthesized ext) err s m a+markRecursion = mappingExtract (field' @"syn_recursion_count" <>~ 1)+++------------------------------------------------------------------------------+-- | Map a function over the extract created by a tactic.+mappingExtract+    :: Functor m+    => (ext -> ext)+    -> TacticT jdg ext err s m a+    -> TacticT jdg ext err s m a+mappingExtract f (TacticT m)+  = TacticT $ StateT $ \jdg ->+      mapExtract id f $ runStateT m jdg+++------------------------------------------------------------------------------+-- | Given the results of running a tactic, score the solutions by+-- desirability.+--+-- NOTE: This function is completely unprincipled and was just hacked together+-- to produce the right test results.+scoreSolution+    :: Synthesized (LHsExpr GhcPs)+    -> Judgement+    -> [Judgement]+    -> ( Penalize Int  -- number of holes+       , Reward Bool   -- all bindings used+       , Penalize Int  -- unused top-level bindings+       , Penalize Int  -- number of introduced bindings+       , Reward Int    -- number used bindings+       , Penalize Int  -- number of recursive calls+       , Penalize Int  -- size of extract+       )+scoreSolution ext goal holes+  = ( Penalize $ length holes+    , Reward   $ S.null $ intro_vals S.\\ used_vals+    , Penalize $ S.size unused_top_vals+    , Penalize $ S.size intro_vals+    , Reward   $ S.size used_vals + length used_user_vals+    , Penalize $ getSum $ syn_recursion_count ext+    , Penalize $ solutionSize $ syn_val ext+    )+  where+    initial_scope = hyByName $ jEntireHypothesis goal+    intro_vals = M.keysSet $ hyByName $ syn_scoped ext+    used_vals = S.intersection intro_vals $ syn_used_vals ext+    used_user_vals = filter (isLocalHypothesis . hi_provenance)+                   $ mapMaybe (flip M.lookup initial_scope)+                   $ S.toList+                   $ syn_used_vals ext+    top_vals = S.fromList+             . fmap hi_name+             . filter (isTopLevel . hi_provenance)+             . unHypothesis+             $ syn_scoped ext+    unused_top_vals = top_vals S.\\ used_vals+++------------------------------------------------------------------------------+-- | Compute the number of 'LHsExpr' nodes; used as a rough metric for code+-- size.+solutionSize :: LHsExpr GhcPs -> Int+solutionSize = everything (+) $ gcount $ mkQ False $ \case+  (_ :: LHsExpr GhcPs) -> True+++newtype Penalize a = Penalize a+  deriving (Eq, Ord, Show) via (Down a)++newtype Reward a = Reward a+  deriving (Eq, Ord, Show) via a+++------------------------------------------------------------------------------+-- | Generate a unique unification variable.+newUnivar :: MonadState TacticState m => m Type+newUnivar = do+  freshTyvars $+    mkInfForAllTys [alphaTyVar] alphaTy+++------------------------------------------------------------------------------+-- | Attempt to unify two types.+unify :: CType -- ^ The goal type+      -> CType -- ^ The type we are trying unify the goal type with+      -> RuleM ()+unify goal inst = do+  skolems <- gets ts_skolems+  case tryUnifyUnivarsButNotSkolems skolems goal inst of+    Just subst ->+      modify $ updateSubst subst+    Nothing -> cut++------------------------------------------------------------------------------+-- | Get a substitution out of a theta's fundeps+learnFromFundeps+    :: ThetaType+    -> RuleM ()+learnFromFundeps theta = do+  inst_envs <- asks ctxInstEnvs+  skolems <- gets ts_skolems+  subst <- gets ts_unifier+  let theta' = substTheta subst theta+      fundeps = foldMap (foldMap fd_eqs . improveFromInstEnv inst_envs (\_ _ -> ())) theta'+  case tryUnifyUnivarsButNotSkolemsMany skolems $ fmap unPair fundeps of+    Just subst ->+      modify $ updateSubst subst+    Nothing -> cut+++cut :: RuleT jdg ext err s m a+cut = RuleT Empty+++------------------------------------------------------------------------------+-- | Attempt to unify two types.+canUnify+    :: MonadState TacticState m+    => CType -- ^ The goal type+    -> CType -- ^ The type we are trying unify the goal type with+    -> m Bool+canUnify goal inst = do+  skolems <- gets ts_skolems+  case tryUnifyUnivarsButNotSkolems skolems goal inst of+    Just _ -> pure True+    Nothing -> pure False+++------------------------------------------------------------------------------+-- | Prefer the first tactic to the second, if the bool is true. Otherwise, just run the second tactic.+--+-- This is useful when you have a clever pruning solution that isn't always+-- applicable.+attemptWhen :: TacticsM a -> TacticsM a -> Bool -> TacticsM a+attemptWhen _  t2 False = t2+attemptWhen t1 t2 True  = commit t1 t2+++------------------------------------------------------------------------------+-- | Run the given tactic iff the current hole contains no univars. Skolems and+-- already decided univars are OK though.+requireConcreteHole :: TacticsM a -> TacticsM a+requireConcreteHole m = do+  jdg     <- goal+  skolems <- gets ts_skolems+  let vars = S.fromList $ tyCoVarsOfTypeWellScoped $ unCType $ jGoal jdg+  case S.size $ vars S.\\ skolems of+    0 -> m+    _ -> failure TooPolymorphic+++------------------------------------------------------------------------------+-- | The 'try' that comes in refinery 0.3 causes unnecessary backtracking and+-- balloons the search space. This thing just tries it, but doesn't backtrack+-- if it fails.+--+-- NOTE(sandy): But there's a bug! Or at least, something not understood here.+-- Using this everywhere breaks te tests, and neither I nor TOTBWF are sure+-- why.  Prefer 'try' if you can, and only try this as a last resort.+--+-- TODO(sandy): Remove this when we upgrade to 0.4+try'+    :: Functor m+    => TacticT jdg ext err s m ()+    -> TacticT jdg ext err s m ()+try' t = commit t $ pure ()+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+exact :: HsExpr GhcPs -> TacticsM ()+exact = rule . const . pure . pure . noLoc++------------------------------------------------------------------------------+-- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to+-- look it up in the hypothesis.+useNameFromHypothesis :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a+useNameFromHypothesis f name = do+  hy <- jHypothesis <$> goal+  case M.lookup name $ hyByName hy of+    Just hi -> f hi+    Nothing -> failure $ NotInScope name++------------------------------------------------------------------------------+-- | Lift a function over 'HyInfo's to one that takes an 'OccName' and tries to+-- look it up in the hypothesis.+useNameFromContext :: (HyInfo CType -> TacticsM a) -> OccName -> TacticsM a+useNameFromContext f name = do+  lookupNameInContext name >>= \case+    Just ty -> f $ createImportedHyInfo name ty+    Nothing -> failure $ NotInScope name+++------------------------------------------------------------------------------+-- | Find the type of an 'OccName' that is defined in the current module.+lookupNameInContext :: MonadReader Context m => OccName -> m (Maybe CType)+lookupNameInContext name = do+  ctx <- asks ctxModuleFuncs+  pure $ case find ((== name) . fst) ctx of+    Just (_, ty) -> pure ty+    Nothing      -> empty+++getDefiningType+    :: TacticsM CType+getDefiningType = do+  calling_fun_name <- asks (fst . head . ctxDefiningFuncs)+  maybe+    (failure $ NotInScope calling_fun_name)+    pure+      =<< lookupNameInContext calling_fun_name+++------------------------------------------------------------------------------+-- | Build a 'HyInfo' for an imported term.+createImportedHyInfo :: OccName -> CType -> HyInfo CType+createImportedHyInfo on ty = HyInfo+  { hi_name = on+  , hi_provenance = ImportPrv+  , hi_type = ty+  }+++getTyThing+    :: OccName+    -> TacticsM (Maybe TyThing)+getTyThing occ = do+  ctx <- ask+  case lookupOccEnv (ctx_occEnv ctx) occ of+    Just (elt : _) -> do+      mvar <- lift+            $ ExtractM+            $ lift+            $ lookupName (ctx_hscEnv ctx)+            $ gre_name elt+      pure mvar+    _ -> pure Nothing+++------------------------------------------------------------------------------+-- | Like 'getTyThing' but specialized to classes.+knownClass :: OccName -> TacticsM (Maybe Class)+knownClass occ =+  getTyThing occ <&> \case+    Just (ATyCon tc) -> tyConClass_maybe tc+    _                -> Nothing+++------------------------------------------------------------------------------+-- | Like 'getInstance', but uses a class that it just looked up.+getKnownInstance :: OccName -> [Type] -> TacticsM (Maybe (Class, PredType))+getKnownInstance f tys = runMaybeT $ do+  cls <- MaybeT $ knownClass f+  MaybeT $ getInstance cls tys+++------------------------------------------------------------------------------+-- | Lookup the type of any 'OccName' that was imported. Necessarily done in+-- IO, so we only expose this functionality to the parser. Internal Haskell+-- code that wants to lookup terms should do it via 'KnownThings'.+getOccNameType+    :: OccName+    -> TacticsM Type+getOccNameType occ = do+  getTyThing occ >>= \case+    Just (AnId v) -> pure $ varType v+    _ -> failure $ NotInScope occ+++getCurrentDefinitions :: TacticsM [(OccName, CType)]+getCurrentDefinitions = do+  ctx_funcs <- asks ctxDefiningFuncs+  for ctx_funcs $ \res@(occ, _) ->+    pure . maybe res (occ,) =<< lookupNameInContext occ+++------------------------------------------------------------------------------+-- | Given two types, see if we can construct a homomorphism by mapping every+-- data constructor in the domain to the same in the codomain. This function+-- returns 'Just' when all the lookups succeeded, and a non-empty value if the+-- homomorphism *is not* possible.+uncoveredDataCons :: Type -> Type -> Maybe (S.Set (Uniquely DataCon))+uncoveredDataCons domain codomain = do+  (g_dcs, _) <- tacticsGetDataCons codomain+  (hi_dcs, _) <- tacticsGetDataCons domain+  pure $ S.fromList (coerce hi_dcs) S.\\ S.fromList (coerce g_dcs)+
+ old/src/Wingman/Metaprogramming/Lexer.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module Wingman.Metaprogramming.Lexer where++import           Control.Applicative+import           Control.Monad+import           Data.Foldable (asum)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Void+import           Development.IDE.GHC.Compat.Core (OccName, mkVarOcc)+import qualified Text.Megaparsec as P+import qualified Text.Megaparsec.Char as P+import qualified Text.Megaparsec.Char.Lexer as L++type Parser = P.Parsec Void Text++++lineComment :: Parser ()+lineComment = L.skipLineComment "--"++blockComment :: Parser ()+blockComment = L.skipBlockComment "{-" "-}"++sc :: Parser ()+sc = L.space P.space1 lineComment blockComment++ichar :: Parser Char+ichar = P.alphaNumChar <|> P.char '_' <|> P.char '\''++symchar :: Parser Char+symchar = asum+  [ P.symbolChar+  , P.char '!'+  , P.char '#'+  , P.char '$'+  , P.char '%'+  , P.char '^'+  , P.char '&'+  , P.char '*'+  , P.char '-'+  , P.char '='+  , P.char '+'+  , P.char ':'+  , P.char '<'+  , P.char '>'+  , P.char ','+  , P.char '.'+  , P.char '/'+  , P.char '?'+  , P.char '~'+  , P.char '|'+  , P.char '\\'+  ]++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++symbol :: Text -> Parser Text+symbol = L.symbol sc++symbol_ :: Text -> Parser ()+symbol_ = void . symbol++brackets :: Parser a -> Parser a+brackets = P.between (symbol "[") (symbol "]")++braces :: Parser a -> Parser a+braces = P.between (symbol "{") (symbol "}")++parens :: Parser a -> Parser a+parens = P.between (symbol "(") (symbol ")")++identifier :: Text -> Parser ()+identifier i = lexeme (P.string i *> P.notFollowedBy ichar)++variable :: Parser OccName+variable = lexeme $ do+    c <- P.alphaNumChar <|> P.char '('+    fmap mkVarOcc $ case c of+      '(' -> do+        cs <- P.many symchar+        void $ P.char ')'+        pure cs+      _ -> do+        cs <- P.many ichar+        pure $ c : cs++name :: Parser Text+name = lexeme $ do+    c <- P.alphaNumChar+    cs <- P.many (ichar <|> P.char '-')+    pure $ T.pack (c:cs)++keyword :: Text -> Parser ()+keyword = identifier+
+ old/src/Wingman/Metaprogramming/Parser.hs view
@@ -0,0 +1,501 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module Wingman.Metaprogramming.Parser where++import qualified Control.Monad.Combinators.Expr as P+import           Data.Either (fromRight)+import           Data.Functor+import           Data.Maybe (listToMaybe)+import qualified Data.Text as T+import           Development.IDE.GHC.Compat (RealSrcLoc, srcLocLine, srcLocCol, srcLocFile)+import           Development.IDE.GHC.Compat.Util (unpackFS)+import           Refinery.Tactic (failure)+import qualified Refinery.Tactic as R+import qualified Text.Megaparsec as P+import           Wingman.Auto+import           Wingman.Machinery (useNameFromHypothesis, useNameFromContext, getCurrentDefinitions)+import           Wingman.Metaprogramming.Lexer+import           Wingman.Metaprogramming.Parser.Documentation+import           Wingman.Metaprogramming.ProofState (proofState, layout)+import           Wingman.Tactics+import           Wingman.Types+++nullary :: T.Text -> TacticsM () -> Parser (TacticsM ())+nullary name tac = identifier name $> tac+++unary_occ :: T.Text -> (OccName -> TacticsM ()) -> Parser (TacticsM ())+unary_occ name tac = tac <$> (identifier name *> variable)+++------------------------------------------------------------------------------+-- | Like 'unary_occ', but runs directly in the 'Parser' monad.+unary_occM :: T.Text -> (OccName -> Parser (TacticsM ())) -> Parser (TacticsM ())+unary_occM name tac = tac =<< (identifier name *> variable)+++variadic_occ :: T.Text -> ([OccName] -> TacticsM ()) -> Parser (TacticsM ())+variadic_occ name tac = tac <$> (identifier name *> P.many variable)+++commands :: [SomeMetaprogramCommand]+commands =+  [ command "assumption" Nondeterministic Nullary+      "Use any term in the hypothesis that can unify with the current goal."+      (pure assumption)+      [ Example+          Nothing+          []+          [EHI "some_a_val" "a"]+          (Just "a")+          "some_a_val"+      ]++  , command "assume" Deterministic (Ref One)+      "Use the given term from the hypothesis, unifying it with the current goal"+      (pure . assume)+      [ Example+          Nothing+          ["some_a_val"]+          [EHI "some_a_val" "a"]+          (Just "a")+          "some_a_val"+      ]++  , command "intros" Deterministic (Bind Many)+      ( mconcat+          [ "Construct a lambda expression, using the specific names if given, "+          , "generating unique names otherwise. When no arguments are given, "+          , "all of the function arguments will be bound; otherwise, this "+          , "tactic will bind only enough to saturate the given names. Extra "+          , "names are ignored."+          ])+      (pure . \case+        []    -> intros+        names -> intros' $ IntroduceOnlyNamed names+      )+      [ Example+          Nothing+          []+          []+          (Just "a -> b -> c -> d")+          "\\a b c -> (_ :: d)"+      , Example+          Nothing+          ["aye"]+          []+          (Just "a -> b -> c -> d")+          "\\aye -> (_ :: b -> c -> d)"+      , Example+          Nothing+          ["x", "y", "z", "w"]+          []+          (Just "a -> b -> c -> d")+          "\\x y z -> (_ :: d)"+      ]++  , command "idiom" Deterministic Tactic+      "Lift a tactic into idiom brackets."+      (pure . idiom)+      [ Example+          Nothing+          ["(apply f)"]+          [EHI "f" "a -> b -> Int"]+          (Just "Maybe Int")+          "f <$> (_ :: Maybe a) <*> (_ :: Maybe b)"+      ]++  , command "intro" Deterministic (Bind One)+      "Construct a lambda expression, binding an argument with the given name."+      (pure . intros' . IntroduceOnlyNamed . pure)+      [ Example+          Nothing+          ["aye"]+          []+          (Just "a -> b -> c -> d")+          "\\aye -> (_ :: b -> c -> d)"+      ]++  , command "destruct_all" Deterministic Nullary+      "Pattern match on every function paramater, in original binding order."+      (pure destructAll)+      [ Example+          (Just "Assume `a` and `b` were bound via `f a b = _`.")+          []+          [EHI "a" "Bool", EHI "b" "Maybe Int"]+          Nothing $+          T.pack $ init $ unlines+            [ "case a of"+            , "  False -> case b of"+            , "    Nothing -> _"+            , "    Just i -> _"+            , "  True -> case b of"+            , "    Nothing -> _"+            , "    Just i -> _"+            ]+      ]++  , command "destruct" Deterministic (Ref One)+      "Pattern match on the argument."+      (pure . useNameFromHypothesis destruct)+      [ Example+          Nothing+          ["a"]+          [EHI "a" "Bool"]+          Nothing $+          T.pack $ init $ unlines+            [ "case a of"+            , "  False -> _"+            , "  True -> _"+            ]+      ]++  , command "homo" Deterministic (Ref One)+      ( mconcat+        [ "Pattern match on the argument, and fill the resulting hole in with "+        , "the same data constructor."+        ])+      (pure . useNameFromHypothesis homo)+      [ Example+          (Just $ mconcat+            [ "Only applicable when the type constructor of the argument is "+            , "the same as that of the hole."+            ])+          ["e"]+          [EHI "e" "Either a b"]+          (Just "Either x y") $+          T.pack $ init $ unlines+            [ "case e of"+            , "  Left a -> Left (_ :: x)"+            , "  Right b -> Right (_ :: y)"+            ]+      ]++  , command "application" Nondeterministic Nullary+      "Apply any function in the hypothesis that returns the correct type."+      (pure application)+      [ Example+          Nothing+          []+          [EHI "f" "a -> b"]+          (Just "b")+          "f (_ :: a)"+      ]++  , command "pointwise" Deterministic Tactic+      "Restrict the hypothesis in the holes of the given tactic to align up with the top-level bindings. This will ensure, eg, that the first hole can see only terms that came from the first position in any terms destructed from the top-level bindings."+      (pure . flip restrictPositionForApplication (pure ()))+      [ Example+          (Just "In the context of `f (a1, b1) (a2, b2) = _`. The resulting first hole can see only 'a1' and 'a2', and the second, only 'b1' and 'b2'.")+          ["(use mappend)"]+          []+          Nothing+          "mappend _ _"+      ]++  , command "apply" Deterministic (Ref One)+      "Apply the given function from *local* scope."+      (pure . useNameFromHypothesis (apply Saturated))+      [ Example+          Nothing+          ["f"]+          [EHI "f" "a -> b"]+          (Just "b")+          "f (_ :: a)"+      ]++  , command "split" Nondeterministic Nullary+      "Produce a data constructor for the current goal."+      (pure split)+      [ Example+          Nothing+          []+          []+          (Just "Either a b")+          "Right (_ :: b)"+      ]++  , command "ctor" Deterministic (Ref One)+      "Use the given data cosntructor."+      (pure . userSplit)+      [ Example+          Nothing+          ["Just"]+          []+          (Just "Maybe a")+          "Just (_ :: a)"+      ]++  , command "obvious" Nondeterministic Nullary+      "Produce a nullary data constructor for the current goal."+      (pure obvious)+      [ Example+          Nothing+          []+          []+          (Just "[a]")+          "[]"+      ]++  , command "auto" Nondeterministic Nullary+      ( mconcat+          [ "Repeatedly attempt to split, destruct, apply functions, and "+          , "recurse in an attempt to fill the hole."+          ])+      (pure auto)+      [ Example+          Nothing+          []+          [EHI "f" "a -> b", EHI "g" "b -> c"]+          (Just "a -> c")+          "g . f"+      ]++  , command "sorry" Deterministic Nullary+      "\"Solve\" the goal by leaving a hole."+      (pure sorry)+      [ Example+          Nothing+          []+          []+          (Just "b")+          "_ :: b"+      ]++  , command "unary" Deterministic Nullary+      ( mconcat+        [ "Produce a hole for a single-parameter function, as well as a hole for "+        , "its argument. The argument holes are completely unconstrained, and "+        , "will be solved before the function."+        ])+      (pure $ nary 1)+      [ Example+          (Just $ mconcat+            [ "In the example below, the variable `a` is free, and will unify "+            , "to the resulting extract from any subsequent tactic."+            ])+          []+          []+          (Just "Int")+          "(_2 :: a -> Int) (_1 :: a)"+      ]++  , command "binary" Deterministic Nullary+      ( mconcat+        [ "Produce a hole for a two-parameter function, as well as holes for "+        , "its arguments. The argument holes have the same type but are "+        , "otherwise unconstrained, and will be solved before the function."+        ])+      (pure $ nary 2)+      [ Example+          (Just $ mconcat+            [ "In the example below, the variable `a` is free, and will unify "+            , "to the resulting extract from any subsequent tactic."+            ])+          []+          []+          (Just "Int")+          "(_3 :: a -> a -> Int) (_1 :: a) (_2 :: a)"+      ]++  , command "recursion" Deterministic Nullary+      "Fill the current hole with a call to the defining function."+      ( pure $+          fmap listToMaybe getCurrentDefinitions >>= \case+            Just (self, _) -> useNameFromContext (apply Saturated) self+            Nothing -> failure $ TacticPanic "no defining function"+      )+      [ Example+          (Just "In the context of `foo (a :: Int) (b :: b) = _`:")+          []+          []+          Nothing+          "foo (_ :: Int) (_ :: b)"+      ]++  , command "use" Deterministic (Ref One)+      "Apply the given function from *module* scope."+      (pure . use Saturated)+      [ Example+          (Just "`import Data.Char (isSpace)`")+          ["isSpace"]+          []+          (Just "Bool")+          "isSpace (_ :: Char)"+      ]++  , command "cata" Deterministic (Ref One)+      "Destruct the given term, recursing on every resulting binding."+      (pure . useNameFromHypothesis cata)+      [ Example+          (Just "Assume we're called in the context of a function `f.`")+          ["x"]+          [EHI "x" "(a, a)"]+          Nothing $+          T.pack $ init $ unlines+            [ "case x of"+            , "  (a1, a2) ->"+            , "    let a1_c = f a1"+            , "        a2_c = f a2"+            , "     in _"+            ]+      ]++  , command "collapse" Deterministic Nullary+      "Collapse every term in scope with the same type as the goal."+      (pure collapse)+      [ Example+          Nothing+          []+          [ EHI "a1" "a"+          , EHI "a2" "a"+          , EHI "a3" "a"+          ]+          (Just "a")+          "(_ :: a -> a -> a -> a) a1 a2 a3"+      ]++  , command "let" Deterministic (Bind Many)+      "Create let-bindings for each binder given to this tactic."+      (pure . letBind)+      [ Example+          Nothing+          ["a", "b", "c"]+          [ ]+          (Just "x")+          $ T.pack $ unlines+            [ "let a = _1 :: a"+            , "    b = _2 :: b"+            , "    c = _3 :: c"+            , " in (_4 :: x)"+            ]+      ]++  , command "try" Nondeterministic Tactic+      "Simultaneously run and do not run a tactic. Subsequent tactics will bind on both states."+      (pure . R.try)+      [ Example+          Nothing+          ["(apply f)"]+          [ EHI "f" "a -> b"+          ]+          (Just "b")+          $ T.pack $ unlines+            [ "-- BOTH of:\n"+            , "f (_ :: a)"+            , "\n-- and\n"+            , "_ :: b"+            ]+      ]++  , command "nested" Nondeterministic (Ref One)+      "Nest the given function (in module scope) with itself arbitrarily many times. NOTE: The resulting function is necessarily unsaturated, so you will likely need `with_arg` to use this tactic in a saturated context."+      (pure . nested)+      [ Example+          Nothing+          ["fmap"]+          []+          (Just "[(Int, Either Bool a)] -> [(Int, Either Bool b)]")+          "fmap (fmap (fmap _))"+      ]++  , command "with_arg" Deterministic Nullary+      "Fill the current goal with a function application. This can be useful when you'd like to fill in the argument before the function, or when you'd like to use a non-saturated function in a saturated context."+      (pure with_arg)+      [ Example+          (Just "Where `a` is a new unifiable type variable.")+          []+          []+          (Just "r")+          "(_2 :: a -> r) (_1 :: a)"+      ]+  ]++++oneTactic :: Parser (TacticsM ())+oneTactic =+  P.choice+    [ parens tactic+    , makeParser commands+    ]+++tactic :: Parser (TacticsM ())+tactic = P.makeExprParser oneTactic operators++operators :: [[P.Operator Parser (TacticsM ())]]+operators =+    [ [ P.InfixR (symbol "|"   $> (R.<%>) )]+    , [ P.InfixL (symbol ";"   $> (>>))+      , P.InfixL (symbol ","   $> bindOne)+      ]+    ]+++tacticProgram :: Parser (TacticsM ())+tacticProgram = do+  sc+  r <- tactic P.<|> pure (pure ())+  P.eof+  pure r+++wrapError :: String -> String+wrapError err = "```\n" <> err <> "\n```\n"+++fixErrorOffset :: RealSrcLoc -> P.ParseErrorBundle a b -> P.ParseErrorBundle a b+fixErrorOffset rsl (P.ParseErrorBundle ne (P.PosState a n (P.SourcePos _ line col) pos s))+  = P.ParseErrorBundle ne+  $ P.PosState a n+      (P.SourcePos+        (unpackFS $ srcLocFile rsl)+        ((<>) line $ P.mkPos $ srcLocLine rsl - 1)+        ((<>) col  $ P.mkPos $ srcLocCol  rsl - 1 + length @[] "[wingman|")+      )+      pos+      s++------------------------------------------------------------------------------+-- | Attempt to run a metaprogram tactic, returning the proof state, or the+-- errors.+attempt_it+    :: RealSrcLoc+    -> Context+    -> Judgement+    -> String+    -> IO (Either String String)+attempt_it rsl ctx jdg program =+  case P.runParser tacticProgram "<splice>" (T.pack program) of+    Left peb -> pure $ Left $ wrapError $ P.errorBundlePretty $ fixErrorOffset rsl peb+    Right tt -> do+      res <- runTactic 2e6 ctx jdg tt+      pure $ case res of+          Left tes -> Left $ wrapError $ show tes+          Right rtr -> Right+                     $ layout (cfg_proofstate_styling $ ctxConfig ctx)+                     $ proofState rtr+++parseMetaprogram :: T.Text -> TacticsM ()+parseMetaprogram+    = fromRight (pure ())+    . P.runParser tacticProgram "<splice>"+++------------------------------------------------------------------------------+-- | Automatically generate the metaprogram command reference.+writeDocumentation :: IO ()+writeDocumentation =+  writeFile "COMMANDS.md" $+    unlines+      [ "# Wingman Metaprogram Command Reference"+      , ""+      , prettyReadme commands+      ]+
+ old/src/Wingman/Metaprogramming/Parser.hs-boot view
@@ -0,0 +1,7 @@+module Wingman.Metaprogramming.Parser where++import Wingman.Metaprogramming.Lexer+import Wingman.Types++tactic :: Parser (TacticsM ())+
+ old/src/Wingman/Metaprogramming/Parser/Documentation.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++module Wingman.Metaprogramming.Parser.Documentation where++import           Data.Functor ((<&>))+import           Data.List (sortOn)+import           Data.String (IsString)+import           Data.Text (Text)+import           Data.Text.Prettyprint.Doc hiding (parens)+import           Data.Text.Prettyprint.Doc.Render.String (renderString)+import           Development.IDE.GHC.Compat (OccName)+import qualified Text.Megaparsec as P+import           Wingman.Metaprogramming.Lexer (Parser, identifier, variable, parens)+import           Wingman.Types (TacticsM)++import {-# SOURCE #-} Wingman.Metaprogramming.Parser (tactic)+++------------------------------------------------------------------------------+-- | Is a tactic deterministic or not?+data Determinism+  = Deterministic+  | Nondeterministic++prettyDeterminism :: Determinism -> Doc b+prettyDeterminism Deterministic = "deterministic"+prettyDeterminism Nondeterministic = "non-deterministic"+++------------------------------------------------------------------------------+-- | How many arguments does the tactic take?+data Count a where+  One  :: Count OccName+  Many :: Count [OccName]++prettyCount :: Count a -> Doc b+prettyCount One  = "single"+prettyCount Many = "variadic"+++------------------------------------------------------------------------------+-- | What sorts of arguments does the tactic take? Currently there is no+-- distinction between 'Ref' and 'Bind', other than documentation.+--+-- The type index here is used for the shape of the function the parser should+-- take.+data Syntax a where+  Nullary :: Syntax (Parser (TacticsM ()))+  Ref     :: Count a -> Syntax (a -> Parser (TacticsM ()))+  Bind    :: Count a -> Syntax (a -> Parser (TacticsM ()))+  Tactic  :: Syntax (TacticsM () -> Parser (TacticsM ()))++prettySyntax :: Syntax a -> Doc b+prettySyntax Nullary   = "none"+prettySyntax (Ref co)  = prettyCount co <+> "reference"+prettySyntax (Bind co) = prettyCount co <+> "binding"+prettySyntax Tactic    = "tactic"+++------------------------------------------------------------------------------+-- | An example for the documentation.+data Example = Example+  { ex_ctx    :: Maybe Text         -- ^ Specific context information about when the tactic is applicable+  , ex_args   :: [Var]              -- ^ Arguments the tactic was called with+  , ex_hyp    :: [ExampleHyInfo]    -- ^ The hypothesis+  , ex_goal   :: Maybe ExampleType  -- ^ Current goal. Nothing indicates it's uninteresting.+  , ex_result :: Text               -- ^ Resulting extract.+  }+++------------------------------------------------------------------------------+-- | An example 'HyInfo'.+data ExampleHyInfo = EHI+  { ehi_name :: Var          -- ^ Name of the variable+  , ehi_type :: ExampleType  -- ^ Type of the variable+  }+++------------------------------------------------------------------------------+-- | A variable+newtype Var = Var+  { getVar :: Text+  }+  deriving newtype (IsString, Pretty)+++------------------------------------------------------------------------------+-- | A type+newtype ExampleType = ExampleType+  { getExampleType :: Text+  }+  deriving newtype (IsString, Pretty)+++------------------------------------------------------------------------------+-- | A command to expose to the parser+data MetaprogramCommand a = MC+  { mpc_name        :: Text         -- ^ Name of the command. This is the token necessary to run the command.+  , mpc_syntax      :: Syntax a     -- ^ The command's arguments+  , mpc_det         :: Determinism  -- ^ Determinism of the command+  , mpc_description :: Text         -- ^ User-facing description+  , mpc_tactic      :: a            -- ^ Tactic to run+  , mpc_examples    :: [Example]    -- ^ Collection of documentation examples+  }++------------------------------------------------------------------------------+-- | Existentialize the pain away+data SomeMetaprogramCommand where+  SMC :: MetaprogramCommand a -> SomeMetaprogramCommand+++------------------------------------------------------------------------------+-- | Run the 'Parser' of a 'MetaprogramCommand'+makeMPParser :: MetaprogramCommand a -> Parser (TacticsM ())+makeMPParser (MC name Nullary _ _ t _) = do+  identifier name+  t+makeMPParser (MC name (Ref One) _ _ t _) = do+  identifier name+  variable >>= t+makeMPParser (MC name (Ref Many) _ _ t _) = do+  identifier name+  P.many variable >>= t+makeMPParser (MC name (Bind One) _ _ t _) = do+  identifier name+  variable >>= t+makeMPParser (MC name (Bind Many) _ _ t _) = do+  identifier name+  P.many variable >>= t+makeMPParser (MC name Tactic _ _ t _) = do+  identifier name+  parens tactic >>= t+++------------------------------------------------------------------------------+-- | Compile a collection of metaprogram commands into a parser.+makeParser :: [SomeMetaprogramCommand] -> Parser (TacticsM ())+makeParser ps = P.choice $ ps <&> \(SMC mp) -> makeMPParser mp+++------------------------------------------------------------------------------+-- | Pretty print a command.+prettyCommand :: MetaprogramCommand a -> Doc b+prettyCommand (MC name syn det desc _ exs) = vsep+  [ "##" <+> pretty name+  , mempty+  , "arguments:" <+> prettySyntax syn <> ".  "+  , prettyDeterminism det <> "."+  , mempty+  , ">" <+> align (pretty desc)+  , mempty+  , vsep $ fmap (prettyExample name) exs+  , mempty+  ]+++------------------------------------------------------------------------------+-- | Pretty print a hypothesis.+prettyHyInfo :: ExampleHyInfo -> Doc a+prettyHyInfo hi = pretty (ehi_name hi) <+> "::" <+> pretty (ehi_type hi)+++------------------------------------------------------------------------------+-- | Append the given term only if the first argument has elements.+mappendIfNotNull :: [a] -> a -> [a]+mappendIfNotNull [] _ = []+mappendIfNotNull as a = as <> [a]+++------------------------------------------------------------------------------+-- | Pretty print an example.+prettyExample :: Text -> Example -> Doc a+prettyExample name (Example m_txt args hys goal res) =+  align $ vsep+    [ mempty+    , "### Example"+    , maybe mempty ((line <>) . (<> line) . (">" <+>) . align . pretty) m_txt+    , "Given:"+    , mempty+    , codeFence $ vsep+        $ mappendIfNotNull (fmap prettyHyInfo hys) mempty+           <> [ "_" <+> maybe mempty (("::" <+>). pretty) goal+              ]+    , mempty+    , hsep+        [ "running "+        , enclose "`" "`" $ pretty name <> hsep (mempty : fmap pretty args)+        , "will produce:"+        ]+    , mempty+    , codeFence $ align $ pretty res+    ]+++------------------------------------------------------------------------------+-- | Make a haskell code fence.+codeFence :: Doc a -> Doc a+codeFence d = align $ vsep+  [ "```haskell"+  , d+  , "```"+  ]+++------------------------------------------------------------------------------+-- | Render all of the commands.+prettyReadme :: [SomeMetaprogramCommand] -> String+prettyReadme+  = renderString+  . layoutPretty defaultLayoutOptions+  . vsep+  . fmap (\case SMC c -> prettyCommand c)+  . sortOn (\case SMC c -> mpc_name c)++++------------------------------------------------------------------------------+-- | Helper function to build a 'SomeMetaprogramCommand'.+command+    :: Text+    -> Determinism+    -> Syntax a+    -> Text+    -> a+    -> [Example]+    -> SomeMetaprogramCommand+command txt det syn txt' a exs = SMC $+  MC+    { mpc_name        = txt+    , mpc_det         = det+    , mpc_syntax      = syn+    , mpc_description = txt'+    , mpc_tactic      = a+    , mpc_examples    = exs+    }+
+ old/src/Wingman/Metaprogramming/ProofState.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NamedFieldPuns    #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++module Wingman.Metaprogramming.ProofState where++import           Data.Bool (bool)+import           Data.Functor ((<&>))+import qualified Data.Text as T+import           Data.Text.Prettyprint.Doc+import           Data.Text.Prettyprint.Doc.Render.Util.Panic+import           Language.LSP.Types (sectionSeparator)+import           Wingman.Judgements (jHypothesis)+import           Wingman.Types++renderSimplyDecorated+    :: Monoid out+    => (T.Text -> out) -- ^ Render plain 'Text'+    -> (ann -> out)  -- ^ How to render an annotation+    -> (ann -> out)  -- ^ How to render the removed annotation+    -> SimpleDocStream ann+    -> out+renderSimplyDecorated text push pop = go []+  where+    go _        SFail               = panicUncaughtFail+    go []       SEmpty              = mempty+    go (_:_)    SEmpty              = panicInputNotFullyConsumed+    go st       (SChar c rest)      = text (T.singleton c) <> go st rest+    go st       (SText _l t rest)   = text t <> go st rest+    go st       (SLine i rest)      =+      text (T.singleton '\n') <> text (textSpaces i) <> go st rest+    go st       (SAnnPush ann rest) = push ann <> go (ann : st) rest+    go (ann:st) (SAnnPop rest)      = pop ann <> go st rest+    go []       SAnnPop{}           = panicUnpairedPop+{-# INLINE renderSimplyDecorated #-}+++data Ann+  = Goal+  | Hypoth+  | Status+  deriving (Eq, Ord, Show, Enum, Bounded)++forceMarkdownNewlines :: String -> String+forceMarkdownNewlines = unlines . fmap (<> "  ") . lines++layout :: Bool -> Doc Ann -> String+layout use_styling+  = forceMarkdownNewlines+  . T.unpack+  . renderSimplyDecorated id+    (renderAnn use_styling)+    (renderUnann use_styling)+  . layoutPretty (LayoutOptions $ AvailablePerLine 80 0.6)++renderAnn :: Bool -> Ann -> T.Text+renderAnn False _ = ""+renderAnn _ Goal = "<span style='color:#ef4026;'>"+renderAnn _ Hypoth = "```haskell\n"+renderAnn _ Status = "<span style='color:#6495ED;'>"++renderUnann :: Bool -> Ann -> T.Text+renderUnann False _ = ""+renderUnann _ Goal = "</span>"+renderUnann _ Hypoth = "\n```\n"+renderUnann _ Status = "</span>"++proofState :: RunTacticResults -> Doc Ann+proofState RunTacticResults{rtr_subgoals} =+  vsep+    $ ( annotate Status+      . countFinished "goals accomplished 🎉" "goal"+      $ length rtr_subgoals+      )+    : pretty sectionSeparator+    : fmap prettySubgoal rtr_subgoals+++prettySubgoal :: Judgement -> Doc Ann+prettySubgoal jdg =+  vsep $+    [ mempty | has_hy] <>+    [ annotate Hypoth $ prettyHypothesis hy | has_hy] <>+    [ "⊢" <+> annotate Goal (prettyType (_jGoal jdg))+    , pretty sectionSeparator+    ]+  where+    hy = jHypothesis jdg+    has_hy = not $ null $ unHypothesis hy+++prettyHypothesis :: Hypothesis CType -> Doc Ann+prettyHypothesis hy =+  vsep $ unHypothesis hy <&> \hi ->+    prettyHyInfo hi++prettyHyInfo :: HyInfo CType -> Doc Ann+prettyHyInfo hi = viaShow (hi_name hi) <+> "::" <+> prettyType (hi_type hi)+++prettyType :: CType -> Doc Ann+prettyType (CType ty) = viaShow ty+++countFinished :: Doc Ann -> Doc Ann -> Int -> Doc Ann+countFinished finished _ 0 = finished+countFinished _ thing n    = count thing n++count :: Doc Ann -> Int -> Doc Ann+count thing n =+  pretty n <+> thing <> bool "" "s" (n /= 1)++textSpaces :: Int -> T.Text+textSpaces n = T.replicate n $ T.singleton ' '++
+ old/src/Wingman/Naming.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE CPP #-}++module Wingman.Naming where++import           Control.Arrow+import           Control.Monad.State.Strict+import           Data.Aeson (camelTo2)+import           Data.Bool (bool)+import           Data.Char+import           Data.List (isPrefixOf)+import           Data.List.Extra (split)+import           Data.Map (Map)+import qualified Data.Map as M+import           Data.Maybe (listToMaybe, fromMaybe)+import           Data.Monoid+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable+import           Development.IDE.GHC.Compat.Core hiding (IsFunction)+import           Text.Hyphenation (hyphenate, english_US)+import           Wingman.GHC (tcTyVar_maybe)++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType+#endif+++------------------------------------------------------------------------------+-- | A classification of a variable, for which we have specific naming rules.+-- A variable can have multiple purposes simultaneously.+data Purpose+  = Function [Type] Type+  | Predicate+  | Continuation+  | Integral+  | Number+  | String+  | List Type+  | Maybe Type+  | TyConned TyCon [Type]+    -- ^ Something of the form @TC a b c@+  | TyVarred TyVar [Type]+    -- ^ Something of the form @m a b c@++pattern IsPredicate :: Type+pattern IsPredicate <-+  (tcSplitFunTys -> ([isFunTy . scaledThing -> False], isBoolTy -> True))++pattern IsFunction :: [Type] -> Type -> Type+pattern IsFunction args res <-+  (first (map scaledThing) . tcSplitFunTys -> (args@(_:_), res))++pattern IsString :: Type+pattern IsString <-+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [eqType charTy -> True]))++pattern IsMaybe :: Type -> Type+pattern IsMaybe a <-+  (splitTyConApp_maybe -> Just ((== maybeTyCon) -> True, [a]))++pattern IsList :: Type -> Type+pattern IsList a <-+  (splitTyConApp_maybe -> Just ((== listTyCon) -> True, [a]))++pattern IsTyConned :: TyCon -> [Type] -> Type+pattern IsTyConned tc args <-+  (splitTyConApp_maybe -> Just (id &&& isSymOcc . getOccName -> (tc, False), args))++pattern IsTyVarred :: TyVar -> [Type] -> Type+pattern IsTyVarred v args <-+  (tcSplitAppTys -> (tcTyVar_maybe -> Just v, args))+++------------------------------------------------------------------------------+-- | Get the 'Purpose's of a type. A type can have multiple purposes+-- simultaneously, so the order of purposes in this function corresponds to the+-- precedence of that naming rule. Which means, eg, that if a type is both+-- a 'Predicate' and a 'Function', we should prefer to use the predicate naming+-- rules, since they come first.+getPurposes :: Type -> [Purpose]+getPurposes ty = mconcat+  [ [ Predicate         | IsPredicate         <- [ty] ]+  , [ Function args res | IsFunction args res <- [ty] ]+  , with (isIntegerTy ty) [ Integral, Number          ]+  , with (isIntTy ty)     [ Integral, Number          ]+  , [ Number            | isFloatingTy ty             ]+  , [ String            | isStringTy ty               ]+  , [ Maybe a           | IsMaybe a           <- [ty] ]+  , [ List a            | IsList a            <- [ty] ]+  , [ TyVarred v args   | IsTyVarred v args   <- [ty] ]+  , [ TyConned tc args  | IsTyConned tc args  <- [ty]+                        , not (isTupleTyCon tc)+                        , tc /= listTyCon             ]+  ]+++------------------------------------------------------------------------------+-- | Return 'mempty' if the give bool is false.+with :: Monoid a => Bool -> a -> a+with False _ = mempty+with True a = a+++------------------------------------------------------------------------------+-- | Names we can give functions+functionNames :: [String]+functionNames = ["f", "g", "h"]+++------------------------------------------------------------------------------+-- | Get a ranked ordering of names for a given purpose.+purposeToName :: Purpose -> [String]+purposeToName (Function args res)+  | Just tv_args <- traverse tcTyVar_maybe $ args <> pure res+  = fmap (<> foldMap (occNameString . occName) tv_args) functionNames+purposeToName (Function _ _) = functionNames+purposeToName Predicate = pure "p"+purposeToName Continuation = pure "k"+purposeToName Integral = ["n", "i", "j"]+purposeToName Number = ["x", "y", "z", "w"]+purposeToName String = ["s", "str"]+purposeToName (List t) = fmap (<> "s") $ purposeToName =<< getPurposes t+purposeToName (Maybe t) = fmap ("m_" <>) $ purposeToName =<< getPurposes t+purposeToName (TyVarred tv args)+  | Just tv_args <- traverse tcTyVar_maybe args+  = pure $ foldMap (occNameString . occName) $ tv : tv_args+purposeToName (TyVarred tv _) = pure $ occNameString $ occName tv+purposeToName (TyConned tc args@(_:_))+  | Just tv_args <- traverse tcTyVar_maybe args+  = [ mkTyConName tc+      -- We insert primes to everything later, but it gets the lowest+      -- precedence. Here we'd like to prefer it over the more specific type+      -- name.+    , mkTyConName tc <> "'"+    , mconcat+      [ mkTyConName tc+      , bool mempty "_" $ length (mkTyConName tc) > 1+      , foldMap (occNameString . occName) tv_args+      ]+    ]+purposeToName (TyConned tc _)+  = pure+  $ mkTyConName tc+++mkTyName :: Type -> [String]+mkTyName = purposeToName <=< getPurposes+++------------------------------------------------------------------------------+-- | Get a good name for a type constructor.+mkTyConName :: TyCon -> String+mkTyConName tc+  | tc == unitTyCon = "u"+  | isSymOcc occ+      = take 1+      . fmap toLower+      . filterReplace isSymbol      's'+      . filterReplace isPunctuation 'p'+      $ name+  | camels@(_:_:_) <- camelTerms name+      = foldMap (fmap toLower . take 1) camels+  | otherwise+      = getStem+      $ fmap toLower name+  where+    occ = getOccName tc+    name = occNameString occ+++------------------------------------------------------------------------------+-- | Split a string into its camel case components.+camelTerms :: String -> [String]+camelTerms = split (== '@') . camelTo2 '@'+++------------------------------------------------------------------------------+-- | A stem of a string is either a special-case shortened form, or a shortened+-- first syllable. If the string is one syllable, we take the full word if it's+-- short, or just the first two characters if it's long. Otherwise, just take+-- the first syllable.+--+-- NOTE: There's no rhyme or reason here, I just experimented until I got+-- results that were reasonably consistent with the names I would give things.+getStem :: String -> String+getStem str =+  let s = stem str+   in case (s == str, length str) of+        (False, _)             -> s+        (True, (<= 3) -> True) -> str+        _                      -> take 2 str++------------------------------------------------------------------------------+-- | Get a special-case stem, or, failing that, give back the first syllable.+stem :: String -> String+stem "char" = "c"+stem "function" = "func"+stem "bool" = "b"+stem "either" = "e"+stem "text" = "txt"+stem s = join $ take 1 $ hyphenate english_US s+++------------------------------------------------------------------------------+-- | Maybe replace an element in the list if the predicate matches+filterReplace :: (a -> Bool) -> a -> [a] -> [a]+filterReplace f r = fmap (\a -> bool a r $ f a)+++------------------------------------------------------------------------------+-- | Produce a unique, good name for a type.+mkGoodName+    :: Set OccName  -- ^ Bindings in scope; used to ensure we don't shadow anything+    -> Type       -- ^ The type to produce a name for+    -> OccName+mkGoodName in_scope (mkTyName -> tn)+  = mkVarOcc+  . fromMaybe (mkNumericSuffix in_scope $ fromMaybe "x" $ listToMaybe tn)+  . getFirst+  . foldMap (\n -> bool (pure n) mempty $ check n)+  $ tn <> fmap (<> "'") tn+  where+    check n = S.member (mkVarOcc n) $ illegalNames <> in_scope+++illegalNames :: Set OccName+illegalNames = S.fromList $ fmap mkVarOcc+  [ "case"+  , "of"+  , "class"+  , "data"+  , "do"+  , "type"+  , "if"+  , "then"+  , "else"+  , "let"+  , "in"+  , "mdo"+  , "newtype"+  , "proc"+  , "rec"+  , "where"+  ]++++------------------------------------------------------------------------------+-- | Given a desired name, compute a new name for it based on how many names in+-- scope conflict with it. Eg, if we want to name something @x@, but already+-- have @x@, @x'@ and @x2@ in scope, we will give back @x3@.+mkNumericSuffix :: Set OccName -> String -> String+mkNumericSuffix s nm =+  mappend nm . show . length . filter (isPrefixOf nm . occNameString) $ S.toList s+++------------------------------------------------------------------------------+-- | Like 'mkGoodName' but creates several apart names.+mkManyGoodNames+  :: (Traversable t)+  => Set OccName+  -> t Type+  -> t OccName+mkManyGoodNames in_scope args =+  flip evalState in_scope $ for args $ \at -> do+    in_scope <- get+    let n = mkGoodName in_scope at+    modify $ S.insert n+    pure n+++------------------------------------------------------------------------------+-- | Which names are in scope?+getInScope :: Map OccName a -> [OccName]+getInScope = M.keys+
+ old/src/Wingman/Plugin.hs view
@@ -0,0 +1,46 @@+-- | A plugin that uses tactics to synthesize code+module Wingman.Plugin where++import           Control.Monad+import           Development.IDE.Core.Shake (IdeState (..))+import           Development.IDE.Plugin.CodeAction+import qualified Development.IDE.GHC.ExactPrint                   as E+import           Ide.Types+import           Language.LSP.Types+import           Prelude hiding (span)+import           Wingman.AbstractLSP+import           Wingman.AbstractLSP.TacticActions (makeTacticInteraction)+import           Wingman.EmptyCase+import           Wingman.LanguageServer hiding (Log)+import qualified Wingman.LanguageServer as WingmanLanguageServer+import           Wingman.LanguageServer.Metaprogram (hoverProvider)+import           Wingman.StaticPlugin+import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty))++data Log+  = LogWingmanLanguageServer WingmanLanguageServer.Log +  | LogExactPrint E.Log+  deriving Show++instance Pretty Log where+  pretty = \case+    LogWingmanLanguageServer log -> pretty log+    LogExactPrint exactPrintLog -> pretty exactPrintLog++descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState+descriptor recorder plId+  = mkExactprintPluginDescriptor (cmapWithPrio LogExactPrint recorder)+  $ installInteractions+      ( emptyCaseInteraction+      : fmap makeTacticInteraction [minBound .. maxBound]+      )+  $ (defaultPluginDescriptor plId)+      { pluginHandlers = mkPluginHandler STextDocumentHover hoverProvider+      , pluginRules = wingmanRules (cmapWithPrio LogWingmanLanguageServer recorder) plId+      , pluginConfigDescriptor =+          defaultConfigDescriptor+            { configCustomConfig = mkCustomConfig properties+            }+      , pluginModifyDynflags = staticPlugin+      }+
+ old/src/Wingman/Range.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}++module Wingman.Range where++import           Development.IDE hiding (rangeToRealSrcSpan, rangeToSrcSpan)+import           Development.IDE.GHC.Compat.Core+import           Development.IDE.GHC.Compat.Util as FS++++------------------------------------------------------------------------------+-- | Convert a DAML compiler Range to a GHC SrcSpan+-- TODO(sandy): this doesn't belong here+rangeToSrcSpan :: String -> Range -> SrcSpan+rangeToSrcSpan file range = RealSrcSpan (rangeToRealSrcSpan file range) Nothing+++rangeToRealSrcSpan :: String -> Range -> RealSrcSpan+rangeToRealSrcSpan file (Range (Position startLn startCh) (Position endLn endCh)) =+  mkRealSrcSpan+    (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ startLn + 1) (fromIntegral $ startCh + 1))+    (mkRealSrcLoc (FS.fsLit file) (fromIntegral $ endLn + 1) (fromIntegral $ endCh + 1))
+ old/src/Wingman/Simplify.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}++module Wingman.Simplify+  ( simplify+  ) where++import Data.Generics (GenericT, everywhere, mkT)+import Data.List.Extra (unsnoc)+import Data.Monoid (Endo (..))+import Development.IDE.GHC.Compat+import GHC.SourceGen (var)+import GHC.SourceGen.Expr (lambda)+import Wingman.CodeGen.Utils+import Wingman.GHC (containsHsVar, fromPatCompat, pattern SingleLet)+++------------------------------------------------------------------------------+-- | A pattern over the otherwise (extremely) messy AST for lambdas.+pattern Lambda :: [Pat GhcPs] -> HsExpr GhcPs -> HsExpr GhcPs+pattern Lambda pats body <-+  HsLam _+    MG {mg_alts = L _ [L _+      Match { m_pats = fmap fromPatCompat -> pats+            , m_grhss = GRHSs {grhssGRHSs = [L _ (+                 GRHS _ [] (L _ body))]}+            }]+        }+  where+    -- If there are no patterns to bind, just stick in the body+    Lambda [] body   = body+    Lambda pats body = lambda pats body++++------------------------------------------------------------------------------+-- | Simplify an expression.+simplify :: LHsExpr GhcPs -> LHsExpr GhcPs+simplify+  = (!!3) -- Do three passes; this should be good enough for the limited+          -- amount of gas we give to auto+  . iterate (everywhere $ foldEndo+    [ simplifyEtaReduce+    , simplifyRemoveParens+    , simplifyCompose+    , simplifySingleLet+    ])+++------------------------------------------------------------------------------+-- | Like 'foldMap' but for endomorphisms.+foldEndo :: Foldable t => t (a -> a) -> a -> a+foldEndo = appEndo . foldMap Endo+++------------------------------------------------------------------------------+-- | Perform an eta reduction. For example, transforms @\x -> (f g) x@ into+-- @f g@.+simplifyEtaReduce :: GenericT+simplifyEtaReduce = mkT $ \case+  Lambda+      [VarPat _ (L _ pat)]+      (HsVar _ (L _ a)) | pat == a ->+    var "id"+  Lambda+      (unsnoc -> Just (pats, VarPat _ (L _ pat)))+      (HsApp _ (L _ f) (L _ (HsVar _ (L _ a))))+      | pat == a+        -- We can only perform this simplification if @pat@ is otherwise unused.+      , not (containsHsVar pat f) ->+    Lambda pats f+  x -> x++------------------------------------------------------------------------------+-- | Eliminates the unnecessary binding in @let a = b in a@+simplifySingleLet :: GenericT+simplifySingleLet = mkT $ \case+  SingleLet bind [] val (HsVar _ (L _ a)) | a == bind -> val+  x -> x+++------------------------------------------------------------------------------+-- | Perform an eta-reducing function composition. For example, transforms+-- @\x -> f (g (h x))@ into @f . g . h@.+simplifyCompose :: GenericT+simplifyCompose = mkT $ \case+  Lambda+      (unsnoc -> Just (pats, VarPat _ (L _ pat)))+      (unroll -> (fs@(_:_), HsVar _ (L _ a)))+      | pat == a+        -- We can only perform this simplification if @pat@ is otherwise unused.+      , not (containsHsVar pat fs) ->+    Lambda pats (foldr1 (infixCall ".") fs)+  x -> x+++------------------------------------------------------------------------------+-- | Removes unnecessary parentheses on any token that doesn't need them.+simplifyRemoveParens :: GenericT+simplifyRemoveParens = mkT $ \case+  HsPar _ (L _ x) | isAtomicHsExpr x -> x+  (x :: HsExpr GhcPs)                -> x+++------------------------------------------------------------------------------+-- | Unrolls a right-associative function application of the form+-- @HsApp f (HsApp g (HsApp h x))@ into @([f, g, h], x)@.+unroll :: HsExpr GhcPs -> ([HsExpr GhcPs], HsExpr GhcPs)+unroll (HsPar _ (L _ x)) = unroll x+unroll (HsApp _ (L _ f) (L _ a)) =+  let (fs, r) = unroll a+   in (f : fs, r)+unroll x = ([], x)+
+ old/src/Wingman/StaticPlugin.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}++module Wingman.StaticPlugin+  ( staticPlugin+  , metaprogramHoleName+  , enableQuasiQuotes+  , pattern WingmanMetaprogram+  , pattern MetaprogramSyntax+  ) where++import Development.IDE.GHC.Compat+import Development.IDE.GHC.Compat.Util++import Ide.Types++import Data.Data+import Generics.SYB+#if __GLASGOW_HASKELL__ >= 900+import GHC.Driver.Plugins (purePlugin)+#else+import Plugins (purePlugin)+#endif++staticPlugin :: DynFlagsModifications+staticPlugin = mempty+  { dynFlagsModifyGlobal =+      \df -> allowEmptyCaseButWithWarning+           $ flip gopt_unset Opt_SortBySubsumHoleFits+           $ flip gopt_unset Opt_ShowValidHoleFits+           $ df+             { refLevelHoleFits = Just 0+             , maxRefHoleFits   = Just 0+             , maxValidHoleFits = Just 0+             , staticPlugins = staticPlugins df <> [metaprogrammingPlugin]+             }+  , dynFlagsModifyParser = enableQuasiQuotes+  }+++pattern MetaprogramSourceText :: SourceText+pattern MetaprogramSourceText = SourceText "wingman-meta-program"+++pattern WingmanMetaprogram :: FastString -> HsExpr p+pattern WingmanMetaprogram mp <-+#if __GLASGOW_HASKELL__ >= 900+  HsPragE _ (HsPragSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp))+      (L _ ( HsVar _ _))+#else+  HsSCC _ MetaprogramSourceText (StringLiteral NoSourceText mp)+      (L _ ( HsVar _ _))+#endif+++enableQuasiQuotes :: DynFlags -> DynFlags+enableQuasiQuotes = flip xopt_set QuasiQuotes+++-- | Wingman wants to support destructing of empty cases, but these are a parse+-- error by default. So we want to enable 'EmptyCase', but then that leads to+-- silent errors without 'Opt_WarnIncompletePatterns'.+allowEmptyCaseButWithWarning :: DynFlags -> DynFlags+allowEmptyCaseButWithWarning =+  flip xopt_set EmptyCase . flip wopt_set Opt_WarnIncompletePatterns+++metaprogrammingPlugin :: StaticPlugin+metaprogrammingPlugin =+    StaticPlugin $ PluginWithArgs pluginDefinition  []+  where+    pluginDefinition = defaultPlugin+        { parsedResultAction = worker+        , pluginRecompile = purePlugin+        }+    worker :: Monad m => [CommandLineOption] -> ModSummary -> HsParsedModule -> m HsParsedModule+    worker _ _ pm = pure $ pm { hpm_module = addMetaprogrammingSyntax $ hpm_module pm }++mkMetaprogram :: SrcSpan -> FastString -> HsExpr GhcPs+mkMetaprogram ss mp =+#if __GLASGOW_HASKELL__ >= 900+  HsPragE noExtField (HsPragSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp))+#else+  HsSCC noExtField MetaprogramSourceText (StringLiteral NoSourceText mp)+#endif+    $ L ss+    $ HsVar noExtField+    $ L ss+    $ mkRdrUnqual metaprogramHoleName++addMetaprogrammingSyntax :: Data a => a -> a+addMetaprogrammingSyntax =+  everywhere $ mkT $ \case+    L ss (MetaprogramSyntax mp) ->+      L ss $ mkMetaprogram ss mp+    (x :: LHsExpr GhcPs) -> x++metaprogramHoleName :: OccName+metaprogramHoleName = mkVarOcc "_$metaprogram"++pattern MetaprogramSyntax :: FastString -> HsExpr GhcPs+pattern MetaprogramSyntax mp <-+    HsSpliceE _ (HsQuasiQuote _ _ (occNameString . rdrNameOcc -> "wingman") _ mp)+  where+    MetaprogramSyntax mp =+      HsSpliceE noExtField $+        HsQuasiQuote+          noExtField+          (mkRdrUnqual $ mkVarOcc "splice")+          (mkRdrUnqual $ mkVarOcc "wingman")+          noSrcSpan+          mp
+ old/src/Wingman/Tactics.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Wingman.Tactics+  ( module Wingman.Tactics+  , runTactic+  ) where++import           Control.Applicative (Alternative(empty), (<|>))+import           Control.Lens ((&), (%~), (<>~))+import           Control.Monad (filterM, unless)+import           Control.Monad (when)+import           Control.Monad.Extra (anyM)+import           Control.Monad.Reader.Class (MonadReader (ask))+import           Control.Monad.State.Strict (StateT(..), runStateT, execStateT)+import           Data.Bool (bool)+import           Data.Foldable+import           Data.Functor ((<&>))+import           Data.Generics.Labels ()+import           Data.List+import           Data.List.Extra (dropEnd, takeEnd)+import qualified Data.Map as M+import           Data.Maybe+import           Data.Set (Set)+import qualified Data.Set as S+import           Data.Traversable (for)+import           Development.IDE.GHC.Compat hiding (empty)+import           GHC.Exts+import           GHC.SourceGen ((@@))+import           GHC.SourceGen.Expr+import           Refinery.Tactic+import           Refinery.Tactic.Internal+import           Wingman.CodeGen+import           Wingman.GHC+import           Wingman.Judgements+import           Wingman.Machinery+import           Wingman.Naming+import           Wingman.StaticPlugin (pattern MetaprogramSyntax)+import           Wingman.Types+++------------------------------------------------------------------------------+-- | Use something in the hypothesis to fill the hole.+assumption :: TacticsM ()+assumption = attemptOn (S.toList . allNames) assume+++------------------------------------------------------------------------------+-- | Use something named in the hypothesis to fill the hole.+assume :: OccName -> TacticsM ()+assume name = rule $ \jdg -> do+  case M.lookup name $ hyByName $ jHypothesis jdg of+    Just (hi_type -> ty) -> do+      unify ty $ jGoal jdg+      pure $+        -- This slightly terrible construct is producing a mostly-empty+        -- 'Synthesized'; but there is no monoid instance to do something more+        -- reasonable for a default value.+        (pure (noLoc $ var' name))+          { syn_trace = tracePrim $ "assume " <> occNameString name+          , syn_used_vals = S.singleton name <> getAncestry jdg name+          }+    Nothing -> cut+++------------------------------------------------------------------------------+-- | Like 'apply', but uses an 'OccName' available in the context+-- or the module+use :: Saturation -> OccName -> TacticsM ()+use sat occ = do+  ctx <- ask+  ty <- case lookupNameInContext occ ctx of+    Just ty -> pure ty+    Nothing -> CType <$> getOccNameType occ+  apply sat $ createImportedHyInfo occ ty+++recursion :: TacticsM ()+-- TODO(sandy): This tactic doesn't fire for the @AutoThetaFix@ golden test,+-- presumably due to running afoul of 'requireConcreteHole'. Look into this!+recursion = requireConcreteHole $ tracing "recursion" $ do+  defs <- getCurrentDefinitions+  attemptOn (const defs) $ \(name, ty) -> markRecursion $ do+    jdg <- goal+    -- Peek allows us to look at the extract produced by this block.+    peek+      ( do+          let hy' = recursiveHypothesis defs+          ctx <- ask+          localTactic (apply Saturated $ HyInfo name RecursivePrv ty) (introduce ctx hy')+            <@> fmap (localTactic assumption . filterPosition name) [0..]+      ) $ \ext -> do+        let pat_vals = jPatHypothesis jdg+        -- Make sure that the recursive call contains at least one already-bound+        -- pattern value. This ensures it is structurally smaller, and thus+        -- suggests termination.+        case any (flip M.member pat_vals) $ syn_used_vals ext of+          True -> Nothing+          False -> Just UnhelpfulRecursion+++restrictPositionForApplication :: TacticsM () -> TacticsM () -> TacticsM ()+restrictPositionForApplication f app = do+  -- NOTE(sandy): Safe use of head; context is guaranteed to have a defining+  -- binding+  name <- head . fmap fst <$> getCurrentDefinitions+  f <@>+    fmap+      (localTactic app . filterPosition name) [0..]+++------------------------------------------------------------------------------+-- | Introduce a lambda binding every variable.+intros :: TacticsM ()+intros = intros' IntroduceAllUnnamed+++data IntroParams+  = IntroduceAllUnnamed+  | IntroduceOnlyNamed [OccName]+  | IntroduceOnlyUnnamed Int+  deriving stock (Eq, Ord, Show)+++------------------------------------------------------------------------------+-- | Introduce a lambda binding every variable.+intros'+    :: IntroParams+    -> TacticsM ()+intros' params = rule $ \jdg -> do+  let g  = jGoal jdg+  case tacticsSplitFunTy $ unCType g of+    (_, _, [], _) -> cut -- failure $ GoalMismatch "intros" g+    (_, _, scaledArgs, res) -> do+      let args = fmap scaledThing scaledArgs+      ctx <- ask+      let gen_names = mkManyGoodNames (hyNamesInScope $ jEntireHypothesis jdg) args+          occs = case params of+            IntroduceAllUnnamed -> gen_names+            IntroduceOnlyNamed names -> names+            IntroduceOnlyUnnamed n -> take n gen_names+          num_occs = length occs+          top_hole = isTopHole ctx jdg+          bindings = zip occs $ coerce args+          bound_occs = fmap fst bindings+          hy' = lambdaHypothesis top_hole bindings+          jdg' = introduce ctx hy'+               $ withNewGoal (CType $ mkVisFunTys (drop num_occs scaledArgs) res) jdg+      ext <- newSubgoal jdg'+      pure $+        ext+          & #syn_trace %~ rose ("intros {" <> intercalate ", " (fmap show bound_occs) <> "}")+                        . pure+          & #syn_scoped <>~ hy'+          & #syn_val   %~ noLoc . lambda (fmap bvar' bound_occs) . unLoc+++------------------------------------------------------------------------------+-- | Introduce a single lambda argument, and immediately destruct it.+introAndDestruct :: TacticsM ()+introAndDestruct = do+  hy <- fmap unHypothesis $ hyDiff $ intros' $ IntroduceOnlyUnnamed 1+  -- This case should never happen, but I'm validating instead of parsing.+  -- Adding a log to be reminded if the invariant ever goes false.+  --+  -- But note that this isn't a game-ending bug. In the worst case, we'll+  -- accidentally bind too many variables, and incorrectly unify between them.+  -- Which means some GADT cases that should be eliminated won't be --- not the+  -- end of the world.+  unless (length hy == 1) $+    traceMX "BUG: Introduced too many variables for introAndDestruct! Please report me if you see this! " hy++  for_ hy destruct+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches.+destructAuto :: HyInfo CType -> TacticsM ()+destructAuto hi = requireConcreteHole $ tracing "destruct(auto)" $ do+  jdg <- goal+  let subtactic = destructOrHomoAuto hi+  case isPatternMatch $ hi_provenance hi of+    True ->+      pruning subtactic $ \jdgs ->+        let getHyTypes = S.fromList . fmap hi_type . unHypothesis . jHypothesis+            new_hy = foldMap getHyTypes jdgs+            old_hy = getHyTypes jdg+        in case S.null $ new_hy S.\\ old_hy of+              True  -> Just $ UnhelpfulDestruct $ hi_name hi+              False -> Nothing+    False -> subtactic+++------------------------------------------------------------------------------+-- | When running auto, in order to prune the auto search tree, we try+-- a homomorphic destruct whenever possible. If that produces any results, we+-- can probably just prune the other side.+destructOrHomoAuto :: HyInfo CType -> TacticsM ()+destructOrHomoAuto hi = tracing "destructOrHomoAuto" $ do+  jdg <- goal+  let g  = unCType $ jGoal jdg+      ty = unCType $ hi_type hi++  attemptWhen+      (rule $ destruct' False (\dc jdg ->+        buildDataCon False jdg dc $ snd $ splitAppTys g) hi)+      (rule $ destruct' False (const newSubgoal) hi)+    $ case (splitTyConApp_maybe g, splitTyConApp_maybe ty) of+        (Just (gtc, _), Just (tytc, _)) -> gtc == tytc+        _ -> False+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches.+destruct :: HyInfo CType -> TacticsM ()+destruct hi = requireConcreteHole $ tracing "destruct(user)" $+  rule $ destruct' False (const newSubgoal) hi+++------------------------------------------------------------------------------+-- | Case split, and leave holes in the matches. Performs record punning.+destructPun :: HyInfo CType -> TacticsM ()+destructPun hi = requireConcreteHole $ tracing "destructPun(user)" $+  rule $ destruct' True (const newSubgoal) hi+++------------------------------------------------------------------------------+-- | Case split, using the same data constructor in the matches.+homo :: HyInfo CType -> TacticsM ()+homo hi = requireConcreteHole . tracing "homo" $ do+  jdg <- goal+  let g = jGoal jdg++  -- Ensure that every data constructor in the domain type is covered in the+  -- codomain; otherwise 'homo' will produce an ill-typed program.+  case uncoveredDataCons (coerce $ hi_type hi) (coerce g) of+    Just uncovered_dcs ->+      unless (S.null uncovered_dcs) $+        failure  $ TacticPanic "Can't cover every datacon in domain"+    _ -> failure $ TacticPanic "Unable to fetch datacons"++  rule+    $ destruct'+        False+        (\dc jdg -> buildDataCon False jdg dc $ snd $ splitAppTys $ unCType $ jGoal jdg)+        hi+++------------------------------------------------------------------------------+-- | LambdaCase split, and leave holes in the matches.+destructLambdaCase :: TacticsM ()+destructLambdaCase =+  tracing "destructLambdaCase" $ rule $ destructLambdaCase' False (const newSubgoal)+++------------------------------------------------------------------------------+-- | LambdaCase split, using the same data constructor in the matches.+homoLambdaCase :: TacticsM ()+homoLambdaCase =+  tracing "homoLambdaCase" $+    rule $ destructLambdaCase' False $ \dc jdg ->+      buildDataCon False jdg dc+        . snd+        . splitAppTys+        . unCType+        $ jGoal jdg+++newtype Saturation = Unsaturated Int+  deriving (Eq, Ord, Show)++pattern Saturated :: Saturation+pattern Saturated = Unsaturated 0+++apply :: Saturation -> HyInfo CType -> TacticsM ()+apply (Unsaturated n) hi = tracing ("apply' " <> show (hi_name hi)) $ do+  jdg <- goal+  let g  = jGoal jdg+      ty = unCType $ hi_type hi+      func = hi_name hi+  ty' <- freshTyvars ty+  let (_, theta, all_args, ret) = tacticsSplitFunTy ty'+      saturated_args = dropEnd n all_args+      unsaturated_args = takeEnd n all_args+  rule $ \jdg -> do+    unify g (CType $ mkVisFunTys unsaturated_args ret)+    learnFromFundeps theta+    ext+        <- fmap unzipTrace+        $ traverse ( newSubgoal+                    . blacklistingDestruct+                    . flip withNewGoal jdg+                    . CType+                    . scaledThing+                    ) saturated_args+    pure $+      ext+        & #syn_used_vals %~ (\x -> S.insert func x <> getAncestry jdg func)+        & #syn_val       %~ mkApply func . fmap unLoc++application :: TacticsM ()+application = overFunctions $ apply Saturated+++------------------------------------------------------------------------------+-- | Choose between each of the goal's data constructors.+split :: TacticsM ()+split = tracing "split(user)" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Nothing -> failure $ GoalMismatch "split" g+    Just (dcs, _) -> choice $ fmap splitDataCon dcs+++------------------------------------------------------------------------------+-- | Choose between each of the goal's data constructors. Different than+-- 'split' because it won't split a data con if it doesn't result in any new+-- goals.+splitAuto :: TacticsM ()+splitAuto = requireConcreteHole $ tracing "split(auto)" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Nothing -> failure $ GoalMismatch "split" g+    Just (dcs, _) -> do+      case isSplitWhitelisted jdg of+        True -> choice $ fmap splitDataCon dcs+        False -> do+          choice $ flip fmap dcs $ \dc -> requireNewHoles $+            splitDataCon dc+++------------------------------------------------------------------------------+-- | Like 'split', but only works if there is a single matching data+-- constructor for the goal.+splitSingle :: TacticsM ()+splitSingle = tracing "splitSingle" $ do+  jdg <- goal+  let g = jGoal jdg+  case tacticsGetDataCons $ unCType g of+    Just ([dc], _) -> do+      splitDataCon dc+    _ -> failure $ GoalMismatch "splitSingle" g++------------------------------------------------------------------------------+-- | Like 'split', but prunes any data constructors which have holes.+obvious :: TacticsM ()+obvious = tracing "obvious" $ do+  pruning split $ bool (Just NoProgress) Nothing . null+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+sorry :: TacticsM ()+sorry = exact $ var' $ mkVarOcc "_"+++------------------------------------------------------------------------------+-- | Sorry leaves a hole in its extract+metaprogram :: TacticsM ()+metaprogram = exact $ MetaprogramSyntax ""+++------------------------------------------------------------------------------+-- | Allow the given tactic to proceed if and only if it introduces holes that+-- have a different goal than current goal.+requireNewHoles :: TacticsM () -> TacticsM ()+requireNewHoles m = do+  jdg <- goal+  pruning m $ \jdgs ->+    case null jdgs || any (/= jGoal jdg) (fmap jGoal jdgs) of+      True  -> Nothing+      False -> Just NoProgress+++------------------------------------------------------------------------------+-- | Attempt to instantiate the given ConLike to solve the goal.+--+-- INVARIANT: Assumes the given ConLike is appropriate to construct the type+-- with.+splitConLike :: ConLike -> TacticsM ()+splitConLike dc =+  requireConcreteHole $ tracing ("splitDataCon:" <> show dc) $ rule $ \jdg -> do+    let g = jGoal jdg+    case splitTyConApp_maybe $ unCType g of+      Just (_, apps) -> do+        buildDataCon True (unwhitelistingSplit jdg) dc apps+      Nothing -> cut -- failure $ GoalMismatch "splitDataCon" g++------------------------------------------------------------------------------+-- | Attempt to instantiate the given data constructor to solve the goal.+--+-- INVARIANT: Assumes the given datacon is appropriate to construct the type+-- with.+splitDataCon :: DataCon -> TacticsM ()+splitDataCon = splitConLike . RealDataCon+++------------------------------------------------------------------------------+-- | Perform a case split on each top-level argument. Used to implement the+-- "Destruct all function arguments" action.+destructAll :: TacticsM ()+destructAll = do+  jdg <- goal+  let args = fmap fst+           $ sortOn snd+           $ mapMaybe (\(hi, prov) ->+              case prov of+                TopLevelArgPrv _ idx _ -> pure (hi, idx)+                _ -> Nothing+                )+           $ fmap (\hi -> (hi, hi_provenance hi))+           $ filter (isAlgType . unCType . hi_type)+           $ unHypothesis+           $ jHypothesis jdg+  for_ args $ \arg -> do+    subst <- getSubstForJudgement =<< goal+    destruct $ fmap (coerce substTy subst) arg++--------------------------------------------------------------------------------+-- | User-facing tactic to implement "Use constructor <x>"+userSplit :: OccName -> TacticsM ()+userSplit occ = do+  jdg <- goal+  let g = jGoal jdg+  -- TODO(sandy): It's smelly that we need to find the datacon to generate the+  -- code action, send it as a string, and then look it up again. Can we push+  -- this over LSP somehow instead?+  case splitTyConApp_maybe $ unCType g of+    Just (tc, _) -> do+      case find (sloppyEqOccName occ . occName . dataConName)+             $ tyConDataCons tc of+        Just dc -> splitDataCon dc+        Nothing -> failure $ NotInScope occ+    Nothing -> failure $ NotInScope occ+++------------------------------------------------------------------------------+-- | @matching f@ takes a function from a judgement to a @Tactic@, and+-- then applies the resulting @Tactic@.+matching :: (Judgement -> TacticsM ()) -> TacticsM ()+matching f = TacticT $ StateT $ \s -> runStateT (unTacticT $ f s) s+++attemptOn :: (Judgement -> [a]) -> (a -> TacticsM ()) -> TacticsM ()+attemptOn getNames tac = matching (choice . fmap tac . getNames)+++localTactic :: TacticsM a -> (Judgement -> Judgement) -> TacticsM a+localTactic t f = do+  TacticT $ StateT $ \jdg ->+    runStateT (unTacticT t) $ f jdg+++refine :: TacticsM ()+refine = intros <%> splitSingle+++auto' :: Int -> TacticsM ()+auto' 0 = failure OutOfGas+auto' n = do+  let loop = auto' (n - 1)+  try intros+  assumption <|>+    choice+      [ overFunctions $ \fname -> do+          requireConcreteHole $ apply Saturated fname+          loop+      , overAlgebraicTerms $ \aname -> do+          destructAuto aname+          loop+      , splitAuto >> loop+      , recursion+      ]++overFunctions :: (HyInfo CType -> TacticsM ()) -> TacticsM ()+overFunctions =+  attemptOn $ filter (isFunction . unCType . hi_type)+           . unHypothesis+           . jHypothesis++overAlgebraicTerms :: (HyInfo CType -> TacticsM ()) -> TacticsM ()+overAlgebraicTerms =+  attemptOn jAcceptableDestructTargets+++allNames :: Judgement -> Set OccName+allNames = hyNamesInScope . jHypothesis+++applyMethod :: Class -> PredType -> OccName -> TacticsM ()+applyMethod cls df method_name = do+  case find ((== method_name) . occName) $ classMethods cls of+    Just method -> do+      let (_, apps) = splitAppTys df+      let ty = piResultTys (idType method) apps+      apply Saturated $ HyInfo method_name (ClassMethodPrv $ Uniquely cls) $ CType ty+    Nothing -> failure $ NotInScope method_name+++applyByName :: OccName -> TacticsM ()+applyByName name = do+  g <- goal+  choice $ unHypothesis (jHypothesis g) <&> \hi ->+    case hi_name hi == name of+      True  -> apply Saturated hi+      False -> empty+++------------------------------------------------------------------------------+-- | Make a function application where the function being applied itself is+-- a hole.+applyByType :: Type -> TacticsM ()+applyByType ty = tracing ("applyByType " <> show ty) $ do+  jdg <- goal+  let g  = jGoal jdg+  ty' <- freshTyvars ty+  let (_, _, args, ret) = tacticsSplitFunTy ty'+  rule $ \jdg -> do+    unify g (CType ret)+    ext+        <- fmap unzipTrace+        $ traverse ( newSubgoal+                    . blacklistingDestruct+                    . flip withNewGoal jdg+                    . CType+                    . scaledThing+                    ) args+    app <- newSubgoal . blacklistingDestruct $ withNewGoal (CType ty) jdg+    pure $+      fmap noLoc $+        foldl' (@@)+          <$> fmap unLoc app+          <*> fmap (fmap unLoc) ext+++------------------------------------------------------------------------------+-- | Make an n-ary function call of the form+-- @(_ :: forall a b. a -> a -> b) _ _@.+nary :: Int -> TacticsM ()+nary n = do+  a <- newUnivar+  b <- newUnivar+  applyByType $ mkVisFunTys (replicate n $ unrestricted a) b+++self :: TacticsM ()+self =+  fmap listToMaybe getCurrentDefinitions >>= \case+    Just (self, _) -> useNameFromContext (apply Saturated) self+    Nothing -> failure $ TacticPanic "no defining function"+++------------------------------------------------------------------------------+-- | Perform a catamorphism when destructing the given 'HyInfo'. This will+-- result in let binding, making values that call the defining function on each+-- destructed value.+cata :: HyInfo CType -> TacticsM ()+cata hi = do+  (_, _, calling_args, _)+      <- tacticsSplitFunTy . unCType <$> getDefiningType+  freshened_args <- traverse (freshTyvars . scaledThing) calling_args+  diff <- hyDiff $ destruct hi++  -- For for every destructed term, check to see if it can unify with any of+  -- the arguments to the calling function. If it doesn't, we don't try to+  -- perform a cata on it.+  unifiable_diff <- flip filterM (unHypothesis diff) $ \hi ->+    flip anyM freshened_args $ \ty ->+      canUnify (hi_type hi) $ CType ty++  rule $+    letForEach+      (mkVarOcc . flip mappend "_c" . occNameString)+      (\hi -> self >> commit (assume $ hi_name hi) assumption)+      $ Hypothesis unifiable_diff+++letBind :: [OccName] -> TacticsM ()+letBind occs = do+  jdg <- goal+  occ_tys <- for occs+           $ \occ+          -> fmap (occ, )+           $ fmap (<$ jdg)+           $ fmap CType newUnivar+  rule $ nonrecLet occ_tys+++------------------------------------------------------------------------------+-- | Deeply nest an unsaturated function onto itself+nested :: OccName -> TacticsM ()+nested = deepening . use (Unsaturated 1)+++------------------------------------------------------------------------------+-- | Repeatedly bind a tactic on its first hole+deep :: Int -> TacticsM () -> TacticsM ()+deep 0 _ = pure ()+deep n t = foldr1 bindOne $ replicate n t+++------------------------------------------------------------------------------+-- | Try 'deep' for arbitrary depths.+deepening :: TacticsM () -> TacticsM ()+deepening t =+  asum $ fmap (flip deep t) [0 .. 100]+++bindOne :: TacticsM a -> TacticsM a -> TacticsM a+bindOne t t1 = t <@> [t1]+++collapse :: TacticsM ()+collapse = do+  g <- goal+  let terms = unHypothesis $ hyFilter ((jGoal g ==) . hi_type) $ jLocalHypothesis g+  case terms of+    [hi] -> assume $ hi_name hi+    _    -> nary (length terms) <@> fmap (assume . hi_name) terms+++with_arg :: TacticsM ()+with_arg = rule $ \jdg -> do+  let g = jGoal jdg+  fresh_ty <- newUnivar+  a <- newSubgoal $ withNewGoal (CType fresh_ty) jdg+  f <- newSubgoal $ withNewGoal (coerce mkVisFunTys [unrestricted fresh_ty] g) jdg+  pure $ fmap noLoc $ (@@) <$> fmap unLoc f <*> fmap unLoc a+++------------------------------------------------------------------------------+-- | Determine the difference in hypothesis due to running a tactic. Also, it+-- runs the tactic.+hyDiff :: TacticsM () -> TacticsM (Hypothesis CType)+hyDiff m = do+  g <- unHypothesis . jEntireHypothesis <$> goal+  let g_len = length g+  m+  g' <- unHypothesis . jEntireHypothesis <$> goal+  pure $ Hypothesis $ take (length g' - g_len) g'+++------------------------------------------------------------------------------+-- | Attempt to run the given tactic in "idiom bracket" mode. For example, if+-- the current goal is+--+--    (_ :: [r])+--+-- then @idiom apply@ will remove the applicative context, resulting in a hole:+--+--    (_ :: r)+--+-- and then use @apply@ to solve it. Let's say this results in:+--+--    (f (_ :: a) (_ :: b))+--+-- Finally, @idiom@ lifts this back into the original applicative:+--+--    (f <$> (_ :: [a]) <*> (_ :: [b]))+--+-- Idiom will fail fast if the current goal doesn't have an applicative+-- instance.+idiom :: TacticsM () -> TacticsM ()+idiom m = do+  jdg <- goal+  let hole = unCType $ jGoal jdg+  when (isFunction hole) $+    failure $ GoalMismatch "idiom" $ jGoal jdg+  case splitAppTy_maybe hole of+    Just (applic, ty) -> do+      minst <- getKnownInstance (mkClsOcc "Applicative")+            . pure+            $ applic+      case minst of+        Nothing -> failure $ GoalMismatch "idiom" $ CType applic+        Just (_, _) -> do+          rule $ \jdg -> do+            expr <- subgoalWith (withNewGoal (CType ty) jdg) m+            case unLoc $ syn_val expr of+              HsApp{}     -> pure $ fmap idiomize expr+              RecordCon{} -> pure $ fmap idiomize expr+              _       -> unsolvable $ GoalMismatch "idiom" $ jGoal jdg+          rule $ newSubgoal . withModifiedGoal (CType . mkAppTy applic . unCType)+    Nothing ->+      failure $ GoalMismatch "idiom" $ jGoal jdg++subgoalWith :: Judgement -> TacticsM () -> RuleM (Synthesized (LHsExpr GhcPs))+subgoalWith jdg t = RuleT $ flip execStateT jdg $ unTacticT t+
+ old/src/Wingman/Types.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Wingman.Types+  ( module Wingman.Types+  , module Wingman.Debug+  , OccName+  , Name+  , Type+  , TyVar+  , Span+  ) where++import           Control.Lens hiding (Context)+import           Control.Monad.Reader+import           Control.Monad.State+import qualified Control.Monad.State.Strict as Strict+import           Data.Coerce+import           Data.Function+import           Data.Generics (mkM, everywhereM, Data, Typeable)+import           Data.Generics.Labels ()+import           Data.Generics.Product (field)+import           Data.List.NonEmpty (NonEmpty (..))+import           Data.Semigroup+import           Data.Set (Set)+import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Tree+import           Development.IDE (Range)+import           Development.IDE.Core.UseStale+import           Development.IDE.GHC.Compat hiding (Node)+import qualified Development.IDE.GHC.Compat.Util as Util+import           Development.IDE.GHC.Orphans ()+import           GHC.Exts (fromString)+import           GHC.Generics+import           GHC.SourceGen (var)+import           Refinery.ProofState+import           Refinery.Tactic.Internal (TacticT(TacticT), RuleT (RuleT))+import           System.IO.Unsafe (unsafePerformIO)+import           Wingman.Debug+import           Data.IORef+++------------------------------------------------------------------------------+-- | The list of tactics exposed to the outside world. These are attached to+-- actual tactics via 'commandTactic' and are contextually provided to the+-- editor via 'commandProvider'.+data TacticCommand+  = Auto+  | Intros+  | IntroAndDestruct+  | Destruct+  | DestructPun+  | Homomorphism+  | DestructLambdaCase+  | HomomorphismLambdaCase+  | DestructAll+  | UseDataCon+  | Refine+  | BeginMetaprogram+  | RunMetaprogram+  deriving (Eq, Ord, Show, Enum, Bounded)++-- | Generate a title for the command.+tacticTitle :: TacticCommand -> T.Text -> T.Text+tacticTitle = (mappend "Wingman: " .) . go+  where+    go Auto _                   = "Attempt to fill hole"+    go Intros _                 = "Introduce lambda"+    go IntroAndDestruct _       = "Introduce and destruct term"+    go Destruct var             = "Case split on " <> var+    go DestructPun var          = "Split on " <> var <> " with NamedFieldPuns"+    go Homomorphism var         = "Homomorphic case split on " <> var+    go DestructLambdaCase _     = "Lambda case split"+    go HomomorphismLambdaCase _ = "Homomorphic lambda case split"+    go DestructAll _            = "Split all function arguments"+    go UseDataCon dcon          = "Use constructor " <> dcon+    go Refine _                 = "Refine hole"+    go BeginMetaprogram _       = "Use custom tactic block"+    go RunMetaprogram _         = "Run custom tactic"+++------------------------------------------------------------------------------+-- | Plugin configuration for tactics+data Config = Config+  { cfg_max_use_ctor_actions :: Int+  , cfg_timeout_seconds      :: Int+  , cfg_auto_gas             :: Int+  , cfg_proofstate_styling   :: Bool+  }+  deriving (Eq, Ord, Show)++emptyConfig :: Config+emptyConfig = Config+  { cfg_max_use_ctor_actions = 5+  , cfg_timeout_seconds = 2+  , cfg_auto_gas = 4+  , cfg_proofstate_styling = True+  }++------------------------------------------------------------------------------+-- | A wrapper around 'Type' which supports equality and ordering.+newtype CType = CType { unCType :: Type }+  deriving stock (Data, Typeable)++instance Eq CType where+  (==) = eqType `on` unCType++instance Ord CType where+  compare = nonDetCmpType `on` unCType++instance Show CType where+  show  = unsafeRender . unCType++instance Show Name where+  show  = unsafeRender++instance Show Type where+  show  = unsafeRender++instance Show Var where+  show  = unsafeRender++instance Show TCvSubst where+  show  = unsafeRender++instance Show DataCon where+  show  = unsafeRender++instance Show Class where+  show  = unsafeRender++instance Show (HsExpr GhcPs) where+  show  = unsafeRender++instance Show (HsExpr GhcTc) where+  show  = unsafeRender++instance Show (HsDecl GhcPs) where+  show  = unsafeRender++instance Show (Pat GhcPs) where+  show  = unsafeRender++instance Show (LHsSigType GhcPs) where+  show  = unsafeRender++instance Show TyCon where+  show  = unsafeRender++instance Show ConLike where+  show  = unsafeRender++instance Show LexicalFixity where+  show  = unsafeRender+++------------------------------------------------------------------------------+-- | The state that should be shared between subgoals. Extracts move towards+-- the root, judgments move towards the leaves, and the state moves *sideways*.+data TacticState = TacticState+    { ts_skolems         :: !(Set TyVar)+      -- ^ The known skolems.+    , ts_unifier         :: !TCvSubst+    , ts_unique_gen :: !UniqSupply+    } deriving stock (Show, Generic)++instance Show UniqSupply where+  show _ = "<uniqsupply>"+++------------------------------------------------------------------------------+-- | A 'UniqSupply' to use in 'defaultTacticState'+unsafeDefaultUniqueSupply :: UniqSupply+unsafeDefaultUniqueSupply =+  unsafePerformIO $ mkSplitUniqSupply 'w'+{-# NOINLINE unsafeDefaultUniqueSupply #-}+++defaultTacticState :: TacticState+defaultTacticState =+  TacticState+    { ts_skolems         = mempty+    , ts_unifier         = emptyTCvSubst+    , ts_unique_gen      = unsafeDefaultUniqueSupply+    }+++------------------------------------------------------------------------------+-- | Generate a new 'Unique'+freshUnique :: MonadState TacticState m => m Util.Unique+freshUnique = do+  (uniq, supply) <- gets $ takeUniqFromSupply . ts_unique_gen+  modify' $! field @"ts_unique_gen" .~ supply+  pure uniq+++------------------------------------------------------------------------------+-- | Describes where hypotheses came from. Used extensively to prune stupid+-- solutions from the search space.+data Provenance+  = -- | An argument given to the topmost function that contains the current+    -- hole. Recursive calls are restricted to values whose provenance lines up+    -- with the same argument.+    TopLevelArgPrv+      OccName   -- ^ Binding function+      Int       -- ^ Argument Position+      Int       -- ^ of how many arguments total?+    -- | A binding created in a pattern match.+  | PatternMatchPrv PatVal+    -- | A class method from the given context.+  | ClassMethodPrv+      (Uniquely Class)     -- ^ Class+    -- | A binding explicitly written by the user.+  | UserPrv+    -- | A binding explicitly imported by the user.+  | ImportPrv+    -- | The recursive hypothesis. Present only in the context of the recursion+    -- tactic.+  | RecursivePrv+    -- | A hypothesis which has been disallowed for some reason. It's important+    -- to keep these in the hypothesis set, rather than filtering it, in order+    -- to continue tracking downstream provenance.+  | DisallowedPrv DisallowReason Provenance+  deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Why was a hypothesis disallowed?+data DisallowReason+  = WrongBranch Int+  | Shadowed+  | RecursiveCall+  | AlreadyDestructed+  deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Provenance of a pattern value.+data PatVal = PatVal+  { pv_scrutinee :: Maybe OccName+    -- ^ Original scrutinee which created this PatVal. Nothing, for lambda+    -- case.+  , pv_ancestry  :: Set OccName+    -- ^ The set of values which had to be destructed to discover this term.+    -- Always contains the scrutinee.+  , pv_datacon   :: Uniquely ConLike+    -- ^ The datacon which introduced this term.+  , pv_position  :: Int+    -- ^ The position of this binding in the datacon's arguments.+  } deriving stock (Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | A wrapper which uses a 'Uniquable' constraint for providing 'Eq' and 'Ord'+-- instances.+newtype Uniquely a = Uniquely { getViaUnique :: a }+  deriving Show via a+  deriving stock (Data, Typeable)++instance Util.Uniquable a => Eq (Uniquely a) where+  (==) = (==) `on` Util.getUnique . getViaUnique++instance Util.Uniquable a => Ord (Uniquely a) where+  compare = Util.nonDetCmpUnique `on` Util.getUnique . getViaUnique+++-- NOTE(sandy): The usage of list here is mostly for convenience, but if it's+-- ever changed, make sure to correspondingly update+-- 'jAcceptableDestructTargets' so that it correctly identifies newly+-- introduced terms.+newtype Hypothesis a = Hypothesis+  { unHypothesis :: [HyInfo a]+  }+  deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable)+  deriving newtype (Semigroup, Monoid)+++------------------------------------------------------------------------------+-- | The provenance and type of a hypothesis term.+data HyInfo a = HyInfo+  { hi_name       :: OccName+  , hi_provenance :: Provenance+  , hi_type       :: a+  }+  deriving stock (Functor, Eq, Show, Generic, Ord, Data, Typeable)+++------------------------------------------------------------------------------+-- | Map a function over the provenance.+overProvenance :: (Provenance -> Provenance) -> HyInfo a -> HyInfo a+overProvenance f (HyInfo name prv ty) = HyInfo name (f prv) ty+++------------------------------------------------------------------------------+-- | The current bindings and goal for a hole to be filled by refinery.+data Judgement' a = Judgement+  { _jHypothesis        :: !(Hypothesis a)+  , _jBlacklistDestruct :: !Bool+  , _jWhitelistSplit    :: !Bool+  , _jIsTopHole         :: !Bool+  , _jGoal              :: !a+  , j_coercion          :: TCvSubst+  }+  deriving stock (Generic, Functor, Show)++type Judgement = Judgement' CType+++newtype ExtractM a = ExtractM { unExtractM :: ReaderT Context IO a }+    deriving newtype (Functor, Applicative, Monad, MonadReader Context)++------------------------------------------------------------------------------+-- | Used to ensure hole names are unique across invocations of runTactic+globalHoleRef :: IORef Int+globalHoleRef = unsafePerformIO $ newIORef 10+{-# NOINLINE globalHoleRef #-}++instance MonadExtract Int (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM where+  hole = do+    u <- lift $ ExtractM $ lift $+          readIORef globalHoleRef <* modifyIORef' globalHoleRef (+ 1)+    pure+      ( u+      , pure . noLoc $ var $ fromString $ occNameString $ occName $ mkMetaHoleName u+      )++  unsolvableHole _ = hole+++instance MonadReader r m => MonadReader r (TacticT jdg ext err s m) where+  ask = TacticT $ lift $ Effect $ asks pure+  local f (TacticT m) = TacticT $ Strict.StateT $ \jdg ->+    Effect $ local f $ pure $ Strict.runStateT m jdg++instance MonadReader r m => MonadReader r (RuleT jdg ext err s m) where+  ask = RuleT $ Effect $ asks Axiom+  local f (RuleT m) = RuleT $ Effect $ local f $ pure m++mkMetaHoleName :: Int -> RdrName+mkMetaHoleName u = mkRdrUnqual $ mkVarOcc $ "_" <> show (Util.mkUnique 'w' u)++instance MetaSubst Int (Synthesized (LHsExpr GhcPs)) where+  -- TODO(sandy): This join is to combine the synthesizeds+  substMeta u val a =  join $ a <&>+    everywhereM (mkM $ \case+      (L _ (HsVar _ (L _ name)))+        | name == mkMetaHoleName u -> val+      (t :: LHsExpr GhcPs) -> pure t)+++------------------------------------------------------------------------------+-- | Reasons a tactic might fail.+data TacticError+  = OutOfGas+  | GoalMismatch String CType+  | NoProgress+  | NoApplicableTactic+  | UnhelpfulRecursion+  | UnhelpfulDestruct OccName+  | TooPolymorphic+  | NotInScope OccName+  | TacticPanic String+  deriving (Eq)++instance Show TacticError where+    show OutOfGas = "Auto ran out of gas"+    show (GoalMismatch tac (CType typ)) =+      mconcat+        [ "The tactic "+        , tac+        , " doesn't apply to goal type "+        , unsafeRender typ+        ]+    show NoProgress =+      "Unable to make progress"+    show NoApplicableTactic =+      "No tactic could be applied"+    show UnhelpfulRecursion =+      "Recursion wasn't productive"+    show (UnhelpfulDestruct n) =+      "Destructing patval " <> show n <> " leads to no new types"+    show TooPolymorphic =+      "The tactic isn't applicable because the goal is too polymorphic"+    show (NotInScope name) =+      "Tried to do something with the out of scope name " <> show name+    show (TacticPanic err) =+      "Tactic panic: " <> err+++------------------------------------------------------------------------------+type TacticsM  = TacticT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM+type RuleM     = RuleT Judgement (Synthesized (LHsExpr GhcPs)) TacticError TacticState ExtractM+type Rule      = RuleM (Synthesized (LHsExpr GhcPs))++type Trace = Rose String++------------------------------------------------------------------------------+-- | The extract for refinery. Represents a "synthesized attribute" in the+-- context of attribute grammars. In essence, 'Synthesized' describes+-- information we'd like to pass from leaves of the tactics search upwards.+-- This includes the actual AST we've generated (in 'syn_val').+data Synthesized a = Synthesized+  { syn_trace  :: Trace+    -- ^ A tree describing which tactics were used produce the 'syn_val'.+    -- Mainly for debugging when you get the wrong answer, to see the other+    -- things it tried.+  , syn_scoped :: Hypothesis CType+    -- ^ All of the bindings created to produce the 'syn_val'.+  , syn_used_vals :: Set OccName+    -- ^ The values used when synthesizing the 'syn_val'.+  , syn_recursion_count :: Sum Int+    -- ^ The number of recursive calls+  , syn_val    :: a+  }+  deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)++instance Monad Synthesized where+  return = pure+  Synthesized tr1 sc1 uv1 rc1 a >>= f =+    case f a of+      Synthesized tr2 sc2 uv2 rc2 b ->+        Synthesized+          { syn_trace = tr1 <> tr2+          , syn_scoped = sc1 <> sc2+          , syn_used_vals = uv1 <> uv2+          , syn_recursion_count = rc1 <> rc2+          , syn_val = b+          }++mapTrace :: (Trace -> Trace) -> Synthesized a -> Synthesized a+mapTrace f (Synthesized tr sc uv rc a) = Synthesized (f tr) sc uv rc a+++------------------------------------------------------------------------------+-- | This might not be lawful, due to the semigroup on 'Trace' maybe not being+-- lawful. But that's only for debug output, so it's not anything I'm concerned+-- about.+instance Applicative Synthesized where+  pure = Synthesized mempty mempty mempty mempty+  Synthesized tr1 sc1 uv1 rc1 f <*> Synthesized tr2 sc2 uv2 rc2 a =+    Synthesized (tr1 <> tr2) (sc1 <> sc2) (uv1 <> uv2) (rc1 <> rc2) $ f a+++------------------------------------------------------------------------------+-- | The Reader context of tactics and rules+data Context = Context+  { ctxDefiningFuncs :: [(OccName, CType)]+    -- ^ The functions currently being defined+  , ctxModuleFuncs   :: [(OccName, CType)]+    -- ^ Everything defined in the current module+  , ctxConfig        :: Config+  , ctxInstEnvs      :: InstEnvs+  , ctxFamInstEnvs   :: FamInstEnvs+  , ctxTheta         :: Set CType+  , ctx_hscEnv       :: HscEnv+  , ctx_occEnv       :: OccEnv [GlobalRdrElt]+  , ctx_module       :: Module+  }++instance Show Context where+  show Context{..} = mconcat+    [ "Context "+    , showsPrec 10 ctxDefiningFuncs ""+    , showsPrec 10 ctxModuleFuncs ""+    , showsPrec 10 ctxConfig ""+    , showsPrec 10 ctxTheta ""+    ]+++------------------------------------------------------------------------------+-- | An empty context+emptyContext :: Context+emptyContext+  = Context+      { ctxDefiningFuncs = mempty+      , ctxModuleFuncs = mempty+      , ctxConfig = emptyConfig+      , ctxFamInstEnvs = mempty+      , ctxInstEnvs = InstEnvs mempty mempty mempty+      , ctxTheta = mempty+      , ctx_hscEnv = error "empty hsc env from emptyContext"+      , ctx_occEnv = emptyOccEnv+      , ctx_module = error "empty module from emptyContext"+      }+++newtype Rose a = Rose (Tree a)+  deriving stock (Eq, Functor, Generic, Data, Typeable)++instance Show (Rose String) where+  show = unlines . dropEveryOther . lines . drawTree . coerce++dropEveryOther :: [a] -> [a]+dropEveryOther []           = []+dropEveryOther [a]          = [a]+dropEveryOther (a : _ : as) = a : dropEveryOther as++------------------------------------------------------------------------------+-- | This might not be lawful! I didn't check, and it feels sketchy.+instance (Eq a, Monoid a) => Semigroup (Rose a) where+  Rose (Node a as) <> Rose (Node b bs) = Rose $ Node (a <> b) (as <> bs)+  sconcat (a :| as) = rose mempty $ a : as++instance (Eq a, Monoid a) => Monoid (Rose a) where+  mempty = Rose $ Node mempty mempty++rose :: (Eq a, Monoid a) => a -> [Rose a] -> Rose a+rose a [Rose (Node a' rs)] | a' == mempty = Rose $ Node a rs+rose a rs = Rose $ Node a $ coerce rs+++------------------------------------------------------------------------------+-- | The results of 'Wingman.Machinery.runTactic'+data RunTacticResults = RunTacticResults+  { rtr_trace       :: Trace+  , rtr_extract     :: LHsExpr GhcPs+  , rtr_subgoals    :: [Judgement]+  , rtr_other_solns :: [Synthesized (LHsExpr GhcPs)]+  , rtr_jdg         :: Judgement+  , rtr_ctx         :: Context+  , rtr_timed_out   :: Bool+  } deriving Show+++data AgdaMatch = AgdaMatch+  { amPats :: [Pat GhcPs]+  , amBody :: HsExpr GhcPs+  }+  deriving (Show)+++data UserFacingMessage+  = NotEnoughGas+  | TacticErrors+  | TimedOut+  | NothingToDo+  | InfrastructureError Text+  deriving Eq++instance Show UserFacingMessage where+  show NotEnoughGas = "Wingman ran out of gas when trying to find a solution.  \nTry increasing the `auto_gas` setting."+  show TacticErrors = "Wingman couldn't find a solution"+  show TimedOut     = "Wingman timed out while finding a solution.  \nYou might get a better result if you increase the timeout duration."+  show NothingToDo  = "Nothing to do"+  show (InfrastructureError t) = "Internal error: " <> T.unpack t+++data HoleSort = Hole | Metaprogram T.Text+  deriving (Eq, Ord, Show)++data HoleJudgment = HoleJudgment+  { hj_range     :: Tracked 'Current Range+  , hj_jdg       :: Judgement+  , hj_ctx       :: Context+  , hj_dflags    :: DynFlags+  , hj_hole_sort :: HoleSort+  }+
+ old/test/AutoTupleSpec.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NumDecimals #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module AutoTupleSpec where++import Control.Monad (replicateM)+import Control.Monad.State (evalState)+import Data.Either (isRight)+import Development.IDE.GHC.Compat.Core ( mkVarOcc, mkBoxedTupleTy )+import System.IO.Unsafe+import Test.Hspec+import Test.QuickCheck+import Wingman.Judgements (mkFirstJudgement)+import Wingman.Machinery+import Wingman.Tactics (auto')+import Wingman.Types+++spec :: Spec+spec = describe "auto for tuple" $ do+  it "should always be able to discover an auto solution" $ do+    property $ do+      -- Pick some number of variables+      n <- choose (1, 7)+      let vars = flip evalState defaultTacticState+               $ replicateM n newUnivar+      -- Pick a random ordering+      in_vars  <- shuffle vars+      -- Randomly associate them into tuple types+      in_type  <- mkBoxedTupleTy+                . fmap mkBoxedTupleTy+              <$> randomGroups in_vars+      out_type <- mkBoxedTupleTy+                . fmap mkBoxedTupleTy+              <$> randomGroups vars+      pure $+          -- We should always be able to find a solution+          unsafePerformIO+            (runTactic+              2e6+              emptyContext+              (mkFirstJudgement+                emptyContext+                (Hypothesis $ pure $ HyInfo (mkVarOcc "x") UserPrv $ CType in_type)+                True+                out_type)+              (auto' $ n * 2)) `shouldSatisfy` isRight+++randomGroups :: [a] -> Gen [[a]]+randomGroups [] = pure []+randomGroups as = do+  n <- choose (1, length as)+  (:) <$> pure (take n as)+      <*> randomGroups (drop n as)+
+ old/test/CodeAction/AutoSpec.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.AutoSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let autoTest = goldenTest Auto ""+      autoTestNoWhitespace = goldenTestNoWhitespace Auto ""++  describe "golden" $ do+    autoTest 11  8 "AutoSplitGADT"+    autoTest  2 11 "GoldenEitherAuto"+    autoTest  4 12 "GoldenJoinCont"+    autoTest  3 11 "GoldenIdentityFunctor"+    autoTest  7 11 "GoldenIdTypeFam"+    autoTest  2 15 "GoldenEitherHomomorphic"+    autoTest  2  8 "GoldenNote"+    autoTest  2 12 "GoldenPureList"+    autoTest  2 12 "GoldenListFmap"+    autoTest  2 13 "GoldenFromMaybe"+    autoTest  2 10 "GoldenFoldr"+    autoTest  2  8 "GoldenSwap"+    autoTest  4 11 "GoldenFmapTree"+    autoTest  7 13 "GoldenGADTAuto"+    autoTest  2 12 "GoldenSwapMany"+    autoTest  4 12 "GoldenBigTuple"+    autoTest  2 10 "GoldenShow"+    autoTest  2 15 "GoldenShowCompose"+    autoTest  2  8 "GoldenShowMapChar"+    autoTest  7  8 "GoldenSuperclass"+    autoTest  2 12 "GoldenSafeHead"+    autoTest  2 12 "FmapBoth"+    autoTest  7  8 "RecordCon"+    autoTest  6  8 "NewtypeRecord"+    autoTest  2 14 "FmapJoin"+    autoTest  2  9 "Fgmap"+    autoTest  4 19 "FmapJoinInLet"+    autoTest  9 12 "AutoEndo"+    autoTest  2 16 "AutoEmptyString"+    autoTest  7 35 "AutoPatSynUse"+    autoTest  2 28 "AutoZip"+    autoTest  2 17 "AutoInfixApply"+    autoTest  2 19 "AutoInfixApplyMany"+    autoTest  2 25 "AutoInfixInfix"+    autoTest 19 12 "AutoTypeLevel"+    autoTest 11  9 "AutoForallClassMethod"+    autoTest  2  8 "AutoUnusedPatternMatch"++    failing "flaky in CI" $+      autoTest 2 11 "GoldenApplicativeThen"++    failing "not enough auto gas" $+      autoTest 5 18 "GoldenFish"++  describe "theta" $ do+    autoTest 12 10 "AutoThetaFix"+    autoTest  7 27 "AutoThetaRankN"+    autoTest  6 10 "AutoThetaGADT"+    autoTest  6  8 "AutoThetaGADTDestruct"+    autoTest  4  8 "AutoThetaEqCtx"+    autoTest  6 10 "AutoThetaEqGADT"+    autoTest  6  8 "AutoThetaEqGADTDestruct"+    autoTest  6 10 "AutoThetaRefl"+    autoTest  6  8 "AutoThetaReflDestruct"+    autoTest 19 30 "AutoThetaMultipleUnification"+    autoTest 16  9 "AutoThetaSplitUnification"++  describe "known" $ do+    autoTest 25 13 "GoldenArbitrary"+    autoTest  6 13 "GoldenArbitrarySingleConstructor"+    autoTestNoWhitespace+              6 10 "KnownBigSemigroup"+    autoTest  4 10 "KnownThetaSemigroup"+    autoTest  6 10 "KnownCounterfactualSemigroup"+    autoTest 10 10 "KnownModuleInstanceSemigroup"+    autoTest  4 22 "KnownDestructedSemigroup"+    autoTest  4 10 "KnownMissingSemigroup"+    autoTest  7 12 "KnownMonoid"+    autoTest  7 12 "KnownPolyMonoid"+    autoTest  7 12 "KnownMissingMonoid"+++  describe "messages" $ do+    mkShowMessageTest Auto ""  2 8 "MessageForallA"      TacticErrors+    mkShowMessageTest Auto ""  7 8 "MessageCantUnify"    TacticErrors+    mkShowMessageTest Auto "" 12 8 "MessageNotEnoughGas" NotEnoughGas+
+ old/test/CodeAction/DestructAllSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructAllSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructAllTest = goldenTest DestructAll ""+  describe "provider" $ do+    mkTest+      "Requires args on lhs of ="+      "DestructAllProvider" 3 21+      [ (not, DestructAll, "")+      ]+    mkTest+      "Can't be a non-top-hole"+      "DestructAllProvider" 8 19+      [ (not, DestructAll, "")+      , (id, Destruct, "a")+      , (id, Destruct, "b")+      ]+    mkTest+      "Provides a destruct all otherwise"+      "DestructAllProvider" 12 22+      [ (id, DestructAll, "")+      ]++  describe "golden" $ do+    destructAllTest 2 11 "DestructAllAnd"+    destructAllTest 4 23 "DestructAllMany"+    destructAllTest 2 18 "DestructAllNonVarTopMatch"+    destructAllTest 2 18 "DestructAllFunc"+    destructAllTest 19 18 "DestructAllGADTEvidence"+
+ old/test/CodeAction/DestructPunSpec.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructPunSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructTest = goldenTest DestructPun++  describe "golden" $ do+    destructTest "x"  4  9 "PunSimple"+    destructTest "x"  6 10 "PunMany"+    destructTest "x" 11 11 "PunGADT"+    destructTest "x" 17 11 "PunManyGADT"+    destructTest "x"  4 12 "PunShadowing"+
+ old/test/CodeAction/DestructSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.DestructSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let destructTest = goldenTest Destruct++  describe "golden" $ do+    destructTest "gadt"  7 17 "GoldenGADTDestruct"+    destructTest "gadt"  8 17 "GoldenGADTDestructCoercion"+    destructTest "a"     7 25 "SplitPattern"+    destructTest "a"     6 18 "DestructPun"+    destructTest "fp"   31 14 "DestructCthulhu"+    destructTest "b"     7 10 "DestructTyFam"+    destructTest "b"     7 10 "DestructDataFam"+    destructTest "b"    17 10 "DestructTyToDataFam"+    destructTest "t"     6 10 "DestructInt"++  describe "layout" $ do+    destructTest "b"  4  3 "LayoutBind"+    destructTest "b"  2 15 "LayoutDollarApp"+    destructTest "b"  2 18 "LayoutOpApp"+    destructTest "b"  2 14 "LayoutLam"+    destructTest "x" 11 15 "LayoutSplitWhere"+    destructTest "x"  3 12 "LayoutSplitClass"+    destructTest "b"  3  9 "LayoutSplitGuard"+    destructTest "b"  4 13 "LayoutSplitLet"+    destructTest "a"  4  7 "LayoutSplitIn"+    destructTest "a"  4 31 "LayoutSplitViewPat"+    destructTest "a"  7 17 "LayoutSplitPattern"+    destructTest "a"  8 26 "LayoutSplitPatSyn"++  describe "providers" $ do+    mkTest+      "Produces destruct and homomorphism code actions"+      "T2" 2 21+      [ (id, Destruct, "eab")+      , (id, Homomorphism, "eab")+      , (not, DestructPun, "eab")+      ]++    mkTest+      "Won't suggest homomorphism on the wrong type"+      "T2" 8 8+      [ (not, Homomorphism, "global")+      ]++    mkTest+      "Produces (homomorphic) lambdacase code actions"+      "T3" 4 24+      [ (id, HomomorphismLambdaCase, "")+      , (id, DestructLambdaCase, "")+      ]++    mkTest+      "Produces lambdacase code actions"+      "T3" 7 13+      [ (id, DestructLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest lambdacase without -XLambdaCase"+      "T2" 11 25+      [ (not, DestructLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest destruct if already destructed"+      "ProvideAlreadyDestructed" 6 18+      [ (not, Destruct, "x")+      ]++    mkTest+      "...but does suggest destruct if destructed in a different branch"+      "ProvideAlreadyDestructed" 9 7+      [ (id, Destruct, "x")+      ]++    mkTest+      "Doesn't suggest destruct on class methods"+      "ProvideLocalHyOnly" 2 12+      [ (not, Destruct, "mempty")+      ]++    mkTest+      "Suggests homomorphism if the domain is bigger than the codomain"+      "ProviderHomomorphism" 12 13+      [ (id, Homomorphism, "g")+      ]++    mkTest+      "Doesn't suggest homomorphism if the domain is smaller than the codomain"+      "ProviderHomomorphism" 15 14+      [ (not, Homomorphism, "g")+      , (id, Destruct, "g")+      ]++    mkTest+      "Suggests lambda homomorphism if the domain is bigger than the codomain"+      "ProviderHomomorphism" 18 14+      [ (id, HomomorphismLambdaCase, "")+      ]++    mkTest+      "Doesn't suggest lambda homomorphism if the domain is smaller than the codomain"+      "ProviderHomomorphism" 21 15+      [ (not, HomomorphismLambdaCase, "")+      , (id, DestructLambdaCase, "")+      ]++    -- test layouts that maintain user-written fixities+    destructTest "b"  3 13 "LayoutInfixKeep"+    destructTest "b"  2 12 "LayoutPrefixKeep"+
+ old/test/CodeAction/IntroDestructSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.IntroDestructSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let test l c = goldenTest IntroAndDestruct "" l c+               . mappend "IntroDestruct"++  describe "golden" $ do+    test 4  5 "One"+    test 2  5 "Many"+    test 4 11 "LetBinding"++  describe "provider" $ do+    mkTest+      "Can intro and destruct an algebraic ty"+      "IntroDestructProvider" 2 12+      [ (id, IntroAndDestruct, "")+      ]+    mkTest+      "Won't intro and destruct a non-algebraic ty"+      "IntroDestructProvider" 5 12+      [ (not, IntroAndDestruct, "")+      ]+    mkTest+      "Can't intro, so no option"+      "IntroDestructProvider" 8 17+      [ (not, IntroAndDestruct, "")+      ]+
+ old/test/CodeAction/IntrosSpec.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.IntrosSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let introsTest = goldenTest Intros ""++  describe "golden" $ do+    introsTest 2 8 "GoldenIntros"++  describe "layout" $ do+    introsTest 4 24 "LayoutRec"+
+ old/test/CodeAction/RefineSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.RefineSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let refineTest = goldenTest Refine ""++  describe "golden" $ do+    refineTest  2  8 "RefineIntro"+    refineTest  2  8 "RefineCon"+    refineTest  4 10 "RefineReader"+    refineTest  8 10 "RefineGADT"+    refineTest  2  8 "RefineIntroWhere"++  describe "messages" $ do+    mkShowMessageTest Refine "" 2 8 "MessageForallA" TacticErrors+
+ old/test/CodeAction/RunMetaprogramSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.RunMetaprogramSpec where++import  Utils+import  Test.Hspec+import  Wingman.Types+++spec :: Spec+spec = do+  let metaTest l c f =+        goldenTest RunMetaprogram "" l c f++  describe "beginMetaprogram" $ do+    goldenTest BeginMetaprogram ""  1  7 "MetaBegin"+    goldenTest BeginMetaprogram ""  1  9 "MetaBeginNoWildify"++  describe "golden" $ do+    metaTest  6 11 "MetaMaybeAp"+    metaTest  2 32 "MetaBindOne"+    metaTest  2 32 "MetaBindAll"+    metaTest  2 13 "MetaTry"+    metaTest  2 74 "MetaChoice"+    metaTest  5 40 "MetaUseImport"+    metaTest  6 31 "MetaUseLocal"+    metaTest 11 11 "MetaUseMethod"+    metaTest  9 38 "MetaCataCollapse"+    metaTest  7 16 "MetaCataCollapseUnary"+    metaTest 10 32 "MetaCataAST"+    metaTest  6 46 "MetaPointwise"+    metaTest  4 28 "MetaUseSymbol"+    metaTest  7 53 "MetaDeepOf"+    metaTest  2 34 "MetaWithArg"+    metaTest  2 18 "MetaLetSimple"+    metaTest  5  9 "MetaIdiom"+    metaTest  7  9 "MetaIdiomRecord"++    metaTest 14 10 "MetaFundeps"++    metaTest  2 12 "IntrosTooMany"+
+ old/test/CodeAction/UseDataConSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeAction.UseDataConSpec where++import qualified Data.Text as T+import           Wingman.Types+import           Test.Hspec+import           Utils+++spec :: Spec+spec = do+  let useTest = goldenTest UseDataCon++  describe "provider" $ do+    mkTest+      "Suggests all data cons for Either"+      "ConProviders" 5 6+      [ (id, UseDataCon, "Left")+      , (id, UseDataCon, "Right")+      , (not, UseDataCon, ":")+      , (not, UseDataCon, "[]")+      , (not, UseDataCon, "C1")+      ]+    mkTest+      "Suggests no data cons for big types"+      "ConProviders" 11 17 $ do+        c <- [1 :: Int .. 10]+        pure $ (not, UseDataCon, T.pack $ show c)+    mkTest+      "Suggests only matching data cons for GADT"+      "ConProviders" 20 12+      [ (id, UseDataCon, "IntGADT")+      , (id, UseDataCon, "VarGADT")+      , (not, UseDataCon, "BoolGADT")+      ]++  describe "golden" $ do+    useTest "(,)"   2 8 "UseConPair"+    useTest "Left"  2 8 "UseConLeft"+    useTest "Right" 2 8 "UseConRight"+
+ old/test/CodeLens/EmptyCaseSpec.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}++module CodeLens.EmptyCaseSpec where++import Test.Hspec+import Utils+++spec :: Spec+spec = do+  let test = mkCodeLensTest+      noTest = mkNoCodeLensTest++  describe "golden" $ do+    test "EmptyCaseADT"+    test "EmptyCaseShadow"+    test "EmptyCaseParens"+    test "EmptyCaseNested"+    test "EmptyCaseApply"+    test "EmptyCaseGADT"+    test "EmptyCaseLamCase"++  describe "no code lenses" $ do+    noTest "EmptyCaseSpuriousGADT"+
+ old/test/ProviderSpec.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++module ProviderSpec where++import Wingman.Types+import Test.Hspec+import Utils+++spec :: Spec+spec = do+  mkTest+    "Produces intros code action"+    "T1" 2 14+    [ (id, Intros, "")+    ]++  mkTest+    "Won't suggest intros on the wrong type"+    "T2" 8 8+    [ (not, Intros, "")+    ]++  goldenTestMany "SubsequentTactics"+    [ InvokeTactic Intros   ""   4  5+    , InvokeTactic Destruct "du" 4  8+    , InvokeTactic Auto     ""   4 15+    ]
+ old/test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ old/test/UnificationSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module UnificationSpec where++import           Control.Arrow+import           Control.Monad (replicateM, join)+import           Control.Monad.State (evalState)+import           Data.Bool (bool)+import           Data.Functor ((<&>))+import           Data.Maybe (mapMaybe)+import qualified Data.Set as S+import           Data.Traversable+import           Data.Tuple (swap)+import           Development.IDE.GHC.Compat.Core (substTy, mkBoxedTupleTy)+import           Test.Hspec+import           Test.QuickCheck+import           Wingman.GHC+import           Wingman.Machinery (newUnivar)+import           Wingman.Types++#if __GLASGOW_HASKELL__ >= 900+import GHC.Tc.Utils.TcType (tcGetTyVar_maybe)+#else+import TcType  (tcGetTyVar_maybe)+#endif+++spec :: Spec+spec = describe "unification" $ do+  it "should be able to unify univars with skolems on either side of the equality" $ do+    property $ do+      -- Pick some number of unification vars and skolem+      n <- choose (1, 20)+      let (skolems, take n -> univars)+            = splitAt n+            $ flip evalState defaultTacticState+            $ replicateM (n * 2) newUnivar+      -- Randomly pair them+      skolem_uni_pairs <-+        for (zip skolems univars) randomSwap+      let (lhs, rhs)+            = mkBoxedTupleTy *** mkBoxedTupleTy+            $ unzip skolem_uni_pairs+      pure $+        counterexample (show skolems) $+        counterexample (show lhs) $+        counterexample (show rhs) $+          case tryUnifyUnivarsButNotSkolems+                 (S.fromList $ mapMaybe tcGetTyVar_maybe skolems)+                 (CType lhs)+                 (CType rhs) of+            Just subst ->+              conjoin $ join $+                [ -- For each pair, running the unification over the univar should+                  -- result in the skolem+                  zip univars skolems <&> \(uni, skolem) ->+                    let substd = substTy subst uni+                    in counterexample (show substd) $+                        counterexample (show skolem) $+                          CType substd === CType skolem++                  -- And also, no two univars should equal to one another+                  -- before or after substitution.+                , zip univars (tail univars) <&> \(uni1, uni2) ->+                    let uni1_sub = substTy subst uni1+                        uni2_sub = substTy subst uni2+                    in counterexample (show uni1) $+                        counterexample (show uni2) $+                          CType uni1 =/= CType uni2 .&&.+                          CType uni1_sub =/= CType uni2_sub+                ]+            Nothing -> True === False+++randomSwap :: (a, a) -> Gen (a, a)+randomSwap ab = do+  which <- arbitrary+  pure $ bool swap id which ab++
+ old/test/Utils.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE RecordWildCards #-}++module Utils where++import           Control.DeepSeq (deepseq)+import qualified Control.Exception as E+import           Control.Lens hiding (List, failing, (<.>), (.=))+import           Control.Monad (unless, void)+import           Control.Monad.IO.Class+import           Data.Aeson+import           Data.Foldable+import           Data.Function (on)+import           Data.IORef (writeIORef)+import           Data.Maybe+import           Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Ide.Plugin.Tactic as Tactic+import           Language.LSP.Types+import           Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title)+import qualified Language.LSP.Types.Lens as J+import           System.Directory (doesFileExist)+import           System.FilePath+import           Test.Hls+import           Test.Hspec+import           Test.Hspec.Formatters (FailureReason(ExpectedButGot))+import           Wingman.LanguageServer (mkShowMessageParams)+import           Wingman.Types+++plugin :: PluginTestDescriptor Log+plugin = mkPluginTestDescriptor Tactic.descriptor "tactics"++------------------------------------------------------------------------------+-- | Get a range at the given line and column corresponding to having nothing+-- selected.+--+-- NB: These coordinates are in "file space", ie, 1-indexed.+pointRange :: Int -> Int -> Range+pointRange+  (subtract 1 -> fromIntegral -> line)+  (subtract 1 -> fromIntegral -> col) =+    Range (Position line col) (Position line $ col + 1)+++------------------------------------------------------------------------------+-- | Get the title of a code action.+codeActionTitle :: (Command |? CodeAction) -> Maybe Text+codeActionTitle InL{}                               = Nothing+codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title+++resetGlobalHoleRef :: IO ()+resetGlobalHoleRef = writeIORef globalHoleRef 0+++runSessionForTactics :: Session a -> IO a+runSessionForTactics act = do+  recorder <- pluginTestRecorder+  runSessionWithServer'+    [plugin recorder]+    def+    (def { messageTimeout = 20 } )+    fullCaps+    tacticPath+    act++------------------------------------------------------------------------------+-- | Make a tactic unit test.+mkTest+    :: Foldable t+    => String  -- ^ The test name+    -> FilePath  -- ^ The file name stem (without extension) to load+    -> Int  -- ^ Cursor line+    -> Int  -- ^ Cursor column+    -> t ( Bool -> Bool   -- Use 'not' for actions that shouldn't be present+         , TacticCommand  -- An expected command ...+         , Text           -- ... for this variable+         ) -- ^ A collection of (un)expected code actions.+    -> SpecWith (Arg Bool)+mkTest name fp line col ts = it name $ do+  resetGlobalHoleRef+  runSessionForTactics $ do+    doc <- openDoc (fp <.> "hs") "haskell"+    -- wait for diagnostics to start coming+    void waitForDiagnostics+    -- wait for the entire build to finish, so that Tactics code actions that+    -- use stale data will get uptodate stuff+    void $ waitForTypecheck doc+    actions <- getCodeActions doc $ pointRange line col+    let titles = mapMaybe codeActionTitle actions+    for_ ts $ \(f, tc, var) -> do+      let title = tacticTitle tc var+      liftIO $+        (title `elem` titles) `shouldSatisfy` f++data InvokeTactic = InvokeTactic+  { it_command :: TacticCommand+  , it_argument :: Text+  , it_line :: Int+  , it_col :: Int+  }++invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session ()+invokeTactic doc InvokeTactic{..} = do+    -- wait for the entire build to finish, so that Tactics code actions that+    -- use stale data will get uptodate stuff+    void waitForDiagnostics+    void $ waitForTypecheck doc+    actions <- getCodeActions doc $ pointRange it_line it_col+    case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of+      Just (InR CodeAction {_command = Just c}) -> do+          executeCommand c+          void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit+      _ -> error $ show actions+++mkGoldenTest+    :: (Text -> Text -> Assertion)+    -> [InvokeTactic]+    -> FilePath+    -> SpecWith ()+mkGoldenTest eq invocations input =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      traverse_ (invokeTactic doc) invocations+      edited <- documentContents doc+      let expected_name = input <.> "expected" <.> "hs"+      -- Write golden tests if they don't already exist+      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do+          T.writeFile expected_name edited+      expected <- liftIO $ T.readFile expected_name+      liftIO $ edited `eq` expected+++mkCodeLensTest+    :: FilePath+    -> SpecWith ()+mkCodeLensTest input =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForDiagnostics+      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc+      for_ lenses $ \(CodeLens _ (Just cmd) _) ->+        executeCommand cmd+      _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit)+      edited <- documentContents doc+      let expected_name = input <.> "expected" <.> "hs"+      -- Write golden tests if they don't already exist+      liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do+        T.writeFile expected_name edited+      expected <- liftIO $ T.readFile expected_name+      liftIO $ edited `shouldBe` expected+++------------------------------------------------------------------------------+-- | A test that no code lenses can be run in the file+mkNoCodeLensTest+    :: FilePath+    -> SpecWith ()+mkNoCodeLensTest input =+  it (input <> " (no code lenses)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForBuildQueue+      lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc+      liftIO $ lenses `shouldBe` []++++isWingmanLens :: CodeLens -> Bool+isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _)+    = T.isInfixOf ":tactics:" cmd+isWingmanLens _ = False+++mkShowMessageTest+    :: TacticCommand+    -> Text+    -> Int+    -> Int+    -> FilePath+    -> UserFacingMessage+    -> SpecWith ()+mkShowMessageTest tc occ line col input ufm =+  it (input <> " (golden)") $ do+    resetGlobalHoleRef+    runSessionForTactics $ do+      doc <- openDoc (input <.> "hs") "haskell"+      _ <- waitForDiagnostics+      actions <- getCodeActions doc $ pointRange line col+      Just (InR CodeAction {_command = Just c})+        <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions+      executeCommand c+      NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage)+      liftIO $ err `shouldBe` mkShowMessageParams ufm+++goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()+goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col]++goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith ()+goldenTestMany = flip $ mkGoldenTest shouldBe++goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith ()+goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col]+++shouldBeIgnoringSpaces :: Text -> Text -> Assertion+shouldBeIgnoringSpaces = assertFun f ""+  where+    f = (==) `on` T.unwords . T.words+++assertFun+    :: Show a+    => (a -> a -> Bool)+    -> String -- ^ The message prefix+    -> a      -- ^ The expected value+    -> a      -- ^ The actual value+    -> Assertion+assertFun eq preface expected actual =+  unless (eq actual expected) $ do+    (prefaceMsg+      `deepseq` expectedMsg+      `deepseq` actualMsg+      `deepseq`+        E.throwIO+          (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg))+  where+    prefaceMsg+      | null preface = Nothing+      | otherwise = Just preface+    expectedMsg = show expected+    actualMsg = show actual++++------------------------------------------------------------------------------+-- | Don't run a test.+failing :: Applicative m => String -> b -> m ()+failing _ _ = pure ()+++tacticPath :: FilePath+tacticPath = "old/test/golden"+++executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand)+executeCommandWithResp cmd = do+  let args = decode $ encode $ fromJust $ cmd ^. arguments+      execParams = ExecuteCommandParams Nothing (cmd ^. command) args+  request SWorkspaceExecuteCommand execParams+
+ old/test/golden/AutoEmptyString.expected.hs view
@@ -0,0 +1,2 @@+empty_string :: String+empty_string = ""
+ old/test/golden/AutoEmptyString.hs view
@@ -0,0 +1,2 @@+empty_string :: String+empty_string = _
+ old/test/golden/AutoEndo.expected.hs view
@@ -0,0 +1,11 @@+data Synthesized b a = Synthesized+  { syn_trace :: b+  , syn_val   :: a+  }+  deriving (Eq, Show)+++mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a+mapTrace fbb (Synthesized b a)+  = Synthesized {syn_trace = fbb b, syn_val = a}+
+ old/test/golden/AutoEndo.hs view
@@ -0,0 +1,10 @@+data Synthesized b a = Synthesized+  { syn_trace :: b+  , syn_val   :: a+  }+  deriving (Eq, Show)+++mapTrace :: (b -> b) -> Synthesized b a -> Synthesized b a+mapTrace = _+
+ old/test/golden/AutoForallClassMethod.expected.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Data.Functor.Contravariant++class Semigroupal cat t1 t2 to f where+  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))++comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d)+comux = case combine of { (Op f) -> f }+
+ old/test/golden/AutoForallClassMethod.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE ExplicitForAll        #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++import Data.Functor.Contravariant++class Semigroupal cat t1 t2 to f where+  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))++comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d)+comux = _+
+ old/test/golden/AutoInfixApply.expected.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> c) -> a -> (a -> b) -> c+test (/:) a f = a /: f a+
+ old/test/golden/AutoInfixApply.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> c) -> a -> (a -> b) -> c+test (/:) a f = _+
+ old/test/golden/AutoInfixApplyMany.expected.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c+test (/:) a f x = (a /: f a) x+
+ old/test/golden/AutoInfixApplyMany.hs view
@@ -0,0 +1,3 @@+test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c+test (/:) a f x = _+
+ old/test/golden/AutoInfixInfix.expected.hs view
@@ -0,0 +1,2 @@+test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e+test (/:) (-->) a f x = (a /: f a) --> x
+ old/test/golden/AutoInfixInfix.hs view
@@ -0,0 +1,2 @@+test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e+test (/:) (-->) a f x = _
+ old/test/golden/AutoPatSynUse.expected.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PatternSynonyms #-}++pattern JustSingleton :: a -> Maybe [a]+pattern JustSingleton a <- Just [a]++amIASingleton :: Maybe [a] -> Maybe a+amIASingleton (JustSingleton a) = Just a+
+ old/test/golden/AutoPatSynUse.hs view

file too large to diff

+ old/test/golden/AutoSplitGADT.expected.hs view

file too large to diff

+ old/test/golden/AutoSplitGADT.hs view

file too large to diff

+ old/test/golden/AutoThetaEqCtx.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaEqCtx.hs view

file too large to diff

+ old/test/golden/AutoThetaEqGADT.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaEqGADT.hs view

file too large to diff

+ old/test/golden/AutoThetaEqGADTDestruct.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaEqGADTDestruct.hs view

file too large to diff

+ old/test/golden/AutoThetaFix.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaFix.hs view

file too large to diff

+ old/test/golden/AutoThetaGADT.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaGADT.hs view

file too large to diff

+ old/test/golden/AutoThetaGADTDestruct.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaGADTDestruct.hs view

file too large to diff

+ old/test/golden/AutoThetaMultipleUnification.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaMultipleUnification.hs view

file too large to diff

+ old/test/golden/AutoThetaRankN.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaRankN.hs view

file too large to diff

+ old/test/golden/AutoThetaRefl.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaRefl.hs view

file too large to diff

+ old/test/golden/AutoThetaReflDestruct.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaReflDestruct.hs view

file too large to diff

+ old/test/golden/AutoThetaSplitUnification.expected.hs view

file too large to diff

+ old/test/golden/AutoThetaSplitUnification.hs view

file too large to diff

+ old/test/golden/AutoTypeLevel.expected.hs view

file too large to diff

+ old/test/golden/AutoTypeLevel.hs view

file too large to diff

+ old/test/golden/AutoUnusedPatternMatch.expected.hs view

file too large to diff

+ old/test/golden/AutoUnusedPatternMatch.hs view

file too large to diff

+ old/test/golden/AutoZip.expected.hs view

file too large to diff

+ old/test/golden/AutoZip.hs view

file too large to diff

+ old/test/golden/ConProviders.hs view

file too large to diff

+ old/test/golden/DestructAllAnd.expected.hs view

file too large to diff

+ old/test/golden/DestructAllAnd.hs view

file too large to diff

+ old/test/golden/DestructAllFunc.expected.hs view

file too large to diff

+ old/test/golden/DestructAllFunc.hs view

file too large to diff

+ old/test/golden/DestructAllGADTEvidence.expected.hs view

file too large to diff

+ old/test/golden/DestructAllGADTEvidence.hs view

file too large to diff

+ old/test/golden/DestructAllMany.expected.hs view

file too large to diff

+ old/test/golden/DestructAllMany.hs view

file too large to diff

+ old/test/golden/DestructAllNonVarTopMatch.expected.hs view

file too large to diff

+ old/test/golden/DestructAllNonVarTopMatch.hs view

file too large to diff

+ old/test/golden/DestructAllProvider.hs view

file too large to diff

+ old/test/golden/DestructCthulhu.expected.hs view

file too large to diff

+ old/test/golden/DestructCthulhu.hs view

file too large to diff

+ old/test/golden/DestructDataFam.expected.hs view

file too large to diff

+ old/test/golden/DestructDataFam.hs view

file too large to diff

+ old/test/golden/DestructInt.expected.hs view

file too large to diff

+ old/test/golden/DestructInt.hs view

file too large to diff

+ old/test/golden/DestructPun.expected.hs view

file too large to diff

+ old/test/golden/DestructPun.hs view

file too large to diff

+ old/test/golden/DestructTyFam.expected.hs view

file too large to diff

+ old/test/golden/DestructTyFam.hs view

file too large to diff

+ old/test/golden/DestructTyToDataFam.expected.hs view

file too large to diff

+ old/test/golden/DestructTyToDataFam.hs view

file too large to diff

+ old/test/golden/EmptyCaseADT.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseADT.hs view

file too large to diff

+ old/test/golden/EmptyCaseApply.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseApply.hs view

file too large to diff

+ old/test/golden/EmptyCaseGADT.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseGADT.hs view

file too large to diff

+ old/test/golden/EmptyCaseLamCase.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseLamCase.hs view

file too large to diff

+ old/test/golden/EmptyCaseNested.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseNested.hs view

file too large to diff

+ old/test/golden/EmptyCaseParens.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseParens.hs view

file too large to diff

+ old/test/golden/EmptyCaseShadow.expected.hs view

file too large to diff

+ old/test/golden/EmptyCaseShadow.hs view

file too large to diff

+ old/test/golden/EmptyCaseSpuriousGADT.hs view

file too large to diff

+ old/test/golden/Fgmap.expected.hs view

file too large to diff

+ old/test/golden/Fgmap.hs view

file too large to diff

+ old/test/golden/FmapBoth.expected.hs view

file too large to diff

+ old/test/golden/FmapBoth.hs view

file too large to diff

+ old/test/golden/FmapJoin.expected.hs view

file too large to diff

+ old/test/golden/FmapJoin.hs view

file too large to diff

+ old/test/golden/FmapJoinInLet.expected.hs view

file too large to diff

+ old/test/golden/FmapJoinInLet.hs view

file too large to diff

+ old/test/golden/GoldenApplicativeThen.hs view

file too large to diff

+ old/test/golden/GoldenArbitrary.expected.hs view

file too large to diff

+ old/test/golden/GoldenArbitrary.hs view

file too large to diff

+ old/test/golden/GoldenArbitrarySingleConstructor.expected.hs view

file too large to diff

+ old/test/golden/GoldenArbitrarySingleConstructor.hs view

file too large to diff

+ old/test/golden/GoldenBigTuple.expected.hs view

file too large to diff

+ old/test/golden/GoldenBigTuple.hs view

file too large to diff

+ old/test/golden/GoldenEitherAuto.expected.hs view

file too large to diff

+ old/test/golden/GoldenEitherAuto.hs view

file too large to diff

+ old/test/golden/GoldenEitherHomomorphic.expected.hs view

file too large to diff

+ old/test/golden/GoldenEitherHomomorphic.hs view

file too large to diff

+ old/test/golden/GoldenFish.hs view

file too large to diff

+ old/test/golden/GoldenFmapTree.expected.hs view

file too large to diff

+ old/test/golden/GoldenFmapTree.hs view

file too large to diff

+ old/test/golden/GoldenFoldr.expected.hs view

file too large to diff

+ old/test/golden/GoldenFoldr.hs view

file too large to diff

+ old/test/golden/GoldenFromMaybe.expected.hs view

file too large to diff

+ old/test/golden/GoldenFromMaybe.hs view

file too large to diff

+ old/test/golden/GoldenGADTAuto.expected.hs view

file too large to diff

+ old/test/golden/GoldenGADTAuto.hs view

file too large to diff

+ old/test/golden/GoldenGADTDestruct.expected.hs view

file too large to diff

+ old/test/golden/GoldenGADTDestruct.hs view

file too large to diff

+ old/test/golden/GoldenGADTDestructCoercion.expected.hs view

file too large to diff

+ old/test/golden/GoldenGADTDestructCoercion.hs view

file too large to diff

+ old/test/golden/GoldenIdTypeFam.expected.hs view

file too large to diff

+ old/test/golden/GoldenIdTypeFam.hs view

file too large to diff

+ old/test/golden/GoldenIdentityFunctor.expected.hs view

file too large to diff

+ old/test/golden/GoldenIdentityFunctor.hs view

file too large to diff

+ old/test/golden/GoldenIntros.expected.hs view

file too large to diff

+ old/test/golden/GoldenIntros.hs view

file too large to diff

+ old/test/golden/GoldenJoinCont.expected.hs view

file too large to diff

+ old/test/golden/GoldenJoinCont.hs view

file too large to diff

+ old/test/golden/GoldenListFmap.expected.hs view

file too large to diff

+ old/test/golden/GoldenListFmap.hs view

file too large to diff

+ old/test/golden/GoldenNote.expected.hs view

file too large to diff

+ old/test/golden/GoldenNote.hs view

file too large to diff

+ old/test/golden/GoldenPureList.expected.hs view

file too large to diff

+ old/test/golden/GoldenPureList.hs view

file too large to diff

+ old/test/golden/GoldenSafeHead.expected.hs view

file too large to diff

+ old/test/golden/GoldenSafeHead.hs view

file too large to diff

+ old/test/golden/GoldenShow.expected.hs view

file too large to diff

+ old/test/golden/GoldenShow.hs view

file too large to diff

+ old/test/golden/GoldenShowCompose.expected.hs view

file too large to diff

+ old/test/golden/GoldenShowCompose.hs view

file too large to diff

+ old/test/golden/GoldenShowMapChar.expected.hs view

file too large to diff

+ old/test/golden/GoldenShowMapChar.hs view

file too large to diff

+ old/test/golden/GoldenSuperclass.expected.hs view

file too large to diff

+ old/test/golden/GoldenSuperclass.hs view

file too large to diff

+ old/test/golden/GoldenSwap.expected.hs view

file too large to diff

+ old/test/golden/GoldenSwap.hs view

file too large to diff

+ old/test/golden/GoldenSwapMany.expected.hs view

file too large to diff

+ old/test/golden/GoldenSwapMany.hs view

file too large to diff

+ old/test/golden/IntroDestructLetBinding.expected.hs view

file too large to diff

+ old/test/golden/IntroDestructLetBinding.hs view

file too large to diff

+ old/test/golden/IntroDestructMany.expected.hs view

file too large to diff

+ old/test/golden/IntroDestructMany.hs view

file too large to diff

+ old/test/golden/IntroDestructOne.expected.hs view

file too large to diff

+ old/test/golden/IntroDestructOne.hs view

file too large to diff

+ old/test/golden/IntroDestructProvider.hs view

file too large to diff

+ old/test/golden/IntrosTooMany.expected.hs view

file too large to diff

+ old/test/golden/IntrosTooMany.hs view

file too large to diff

+ old/test/golden/KnownBigSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownBigSemigroup.hs view

file too large to diff

+ old/test/golden/KnownCounterfactualSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownCounterfactualSemigroup.hs view

file too large to diff

+ old/test/golden/KnownDestructedSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownDestructedSemigroup.hs view

file too large to diff

+ old/test/golden/KnownMissingMonoid.expected.hs view

file too large to diff

+ old/test/golden/KnownMissingMonoid.hs view

file too large to diff

+ old/test/golden/KnownMissingSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownMissingSemigroup.hs view

file too large to diff

+ old/test/golden/KnownModuleInstanceSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownModuleInstanceSemigroup.hs view

file too large to diff

+ old/test/golden/KnownMonoid.expected.hs view

file too large to diff

+ old/test/golden/KnownMonoid.hs view

file too large to diff

+ old/test/golden/KnownPolyMonoid.expected.hs view

file too large to diff

+ old/test/golden/KnownPolyMonoid.hs view

file too large to diff

+ old/test/golden/KnownThetaSemigroup.expected.hs view

file too large to diff

+ old/test/golden/KnownThetaSemigroup.hs view

file too large to diff

+ old/test/golden/LayoutBind.expected.hs view

file too large to diff

+ old/test/golden/LayoutBind.hs view

file too large to diff

+ old/test/golden/LayoutDollarApp.expected.hs view

file too large to diff

+ old/test/golden/LayoutDollarApp.hs view

file too large to diff

+ old/test/golden/LayoutInfixKeep.expected.hs view

file too large to diff

+ old/test/golden/LayoutInfixKeep.hs view

file too large to diff

+ old/test/golden/LayoutLam.expected.hs view

file too large to diff

+ old/test/golden/LayoutLam.hs view

file too large to diff

+ old/test/golden/LayoutOpApp.expected.hs view

file too large to diff

+ old/test/golden/LayoutOpApp.hs view

file too large to diff

+ old/test/golden/LayoutPrefixKeep.expected.hs view

file too large to diff

+ old/test/golden/LayoutPrefixKeep.hs view

file too large to diff

+ old/test/golden/LayoutRec.expected.hs view

file too large to diff

+ old/test/golden/LayoutRec.hs view

file too large to diff

+ old/test/golden/LayoutSplitClass.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitClass.hs view

file too large to diff

+ old/test/golden/LayoutSplitGuard.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitGuard.hs view

file too large to diff

+ old/test/golden/LayoutSplitIn.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitIn.hs view

file too large to diff

+ old/test/golden/LayoutSplitLet.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitLet.hs view

file too large to diff

+ old/test/golden/LayoutSplitPatSyn.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitPatSyn.hs view

file too large to diff

+ old/test/golden/LayoutSplitPattern.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitPattern.hs view

file too large to diff

+ old/test/golden/LayoutSplitViewPat.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitViewPat.hs view

file too large to diff

+ old/test/golden/LayoutSplitWhere.expected.hs view

file too large to diff

+ old/test/golden/LayoutSplitWhere.hs view

file too large to diff

+ old/test/golden/MessageCantUnify.hs view

file too large to diff

+ old/test/golden/MessageForallA.hs view

file too large to diff

+ old/test/golden/MessageNotEnoughGas.hs view

file too large to diff

+ old/test/golden/MetaBegin.expected.hs view

file too large to diff

+ old/test/golden/MetaBegin.hs view

file too large to diff

+ old/test/golden/MetaBeginNoWildify.expected.hs view

file too large to diff

+ old/test/golden/MetaBeginNoWildify.hs view

file too large to diff

+ old/test/golden/MetaBindAll.expected.hs view

file too large to diff

+ old/test/golden/MetaBindAll.hs view

file too large to diff

+ old/test/golden/MetaBindOne.expected.hs view

file too large to diff

+ old/test/golden/MetaBindOne.hs view

file too large to diff

+ old/test/golden/MetaCataAST.expected.hs view

file too large to diff

+ old/test/golden/MetaCataAST.hs view

file too large to diff

+ old/test/golden/MetaCataCollapse.expected.hs view

file too large to diff

+ old/test/golden/MetaCataCollapse.hs view

file too large to diff

+ old/test/golden/MetaCataCollapseUnary.expected.hs view

file too large to diff

+ old/test/golden/MetaCataCollapseUnary.hs view

file too large to diff

+ old/test/golden/MetaChoice.expected.hs view

file too large to diff

+ old/test/golden/MetaChoice.hs view

file too large to diff

+ old/test/golden/MetaDeepOf.expected.hs view

file too large to diff

+ old/test/golden/MetaDeepOf.hs view

file too large to diff

+ old/test/golden/MetaFundeps.expected.hs view

file too large to diff

+ old/test/golden/MetaFundeps.hs view

file too large to diff

+ old/test/golden/MetaIdiom.expected.hs view

file too large to diff

+ old/test/golden/MetaIdiom.hs view

file too large to diff

+ old/test/golden/MetaIdiomRecord.expected.hs view

file too large to diff

+ old/test/golden/MetaIdiomRecord.hs view

file too large to diff

+ old/test/golden/MetaLetSimple.expected.hs view

file too large to diff

+ old/test/golden/MetaLetSimple.hs view

file too large to diff

+ old/test/golden/MetaMaybeAp.expected.hs view

file too large to diff

+ old/test/golden/MetaMaybeAp.hs view

file too large to diff

+ old/test/golden/MetaPointwise.expected.hs view

file too large to diff

+ old/test/golden/MetaPointwise.hs view

file too large to diff

+ old/test/golden/MetaTry.expected.hs view

file too large to diff

+ old/test/golden/MetaTry.hs view

file too large to diff

+ old/test/golden/MetaUseImport.expected.hs view

file too large to diff

+ old/test/golden/MetaUseImport.hs view

file too large to diff

+ old/test/golden/MetaUseLocal.expected.hs view

file too large to diff

+ old/test/golden/MetaUseLocal.hs view

file too large to diff

+ old/test/golden/MetaUseMethod.expected.hs view

file too large to diff

+ old/test/golden/MetaUseMethod.hs view

file too large to diff

+ old/test/golden/MetaUseSymbol.expected.hs view

file too large to diff

+ old/test/golden/MetaUseSymbol.hs view

file too large to diff

+ old/test/golden/MetaWithArg.expected.hs view

file too large to diff

+ old/test/golden/MetaWithArg.hs view

file too large to diff

+ old/test/golden/NewtypeRecord.expected.hs view

file too large to diff

+ old/test/golden/NewtypeRecord.hs view

file too large to diff

+ old/test/golden/ProvideAlreadyDestructed.hs view

file too large to diff

+ old/test/golden/ProvideLocalHyOnly.hs view

file too large to diff

+ old/test/golden/ProviderHomomorphism.hs view

file too large to diff

+ old/test/golden/PunGADT.expected.hs view

file too large to diff

+ old/test/golden/PunGADT.hs view

file too large to diff

+ old/test/golden/PunMany.expected.hs view

file too large to diff

+ old/test/golden/PunMany.hs view

file too large to diff

+ old/test/golden/PunManyGADT.expected.hs view

file too large to diff

+ old/test/golden/PunManyGADT.hs view

file too large to diff

+ old/test/golden/PunShadowing.expected.hs view

file too large to diff

+ old/test/golden/PunShadowing.hs view

file too large to diff

+ old/test/golden/PunSimple.expected.hs view

file too large to diff

+ old/test/golden/PunSimple.hs view

file too large to diff

+ old/test/golden/RecordCon.expected.hs view

file too large to diff

+ old/test/golden/RecordCon.hs view

file too large to diff

+ old/test/golden/RefineCon.expected.hs view

file too large to diff

+ old/test/golden/RefineCon.hs view

file too large to diff

+ old/test/golden/RefineGADT.expected.hs view

file too large to diff

+ old/test/golden/RefineGADT.hs view

file too large to diff

+ old/test/golden/RefineIntro.expected.hs view

file too large to diff

+ old/test/golden/RefineIntro.hs view

file too large to diff

+ old/test/golden/RefineIntroWhere.expected.hs view

file too large to diff

+ old/test/golden/RefineIntroWhere.hs view

file too large to diff

+ old/test/golden/RefineReader.expected.hs view

file too large to diff

+ old/test/golden/RefineReader.hs view

file too large to diff

+ old/test/golden/SplitPattern.expected.hs view

file too large to diff

+ old/test/golden/SplitPattern.hs view

file too large to diff

+ old/test/golden/SubsequentTactics.expected.hs view

file too large to diff

+ old/test/golden/SubsequentTactics.hs view

file too large to diff

+ old/test/golden/T1.hs view

file too large to diff

+ old/test/golden/T2.hs view

file too large to diff

+ old/test/golden/T3.hs view

file too large to diff

+ old/test/golden/UseConLeft.expected.hs view

file too large to diff

+ old/test/golden/UseConLeft.hs view

file too large to diff

+ old/test/golden/UseConPair.expected.hs view

file too large to diff

+ old/test/golden/UseConPair.hs view

file too large to diff

+ old/test/golden/UseConRight.expected.hs view

file too large to diff

+ old/test/golden/UseConRight.hs view

file too large to diff

+ old/test/golden/hie.yaml view

file too large to diff

+ old/test/golden/test.cabal view

file too large to diff

− src/Ide/Plugin/Tactic.hs

file too large to diff

− src/Refinery/Future.hs

file too large to diff

− src/Wingman/AbstractLSP.hs

file too large to diff

− src/Wingman/AbstractLSP/TacticActions.hs

file too large to diff

− src/Wingman/AbstractLSP/Types.hs

file too large to diff

− src/Wingman/Auto.hs

file too large to diff

− src/Wingman/CaseSplit.hs

file too large to diff

− src/Wingman/CodeGen.hs

file too large to diff

− src/Wingman/CodeGen/Utils.hs

file too large to diff

− src/Wingman/Context.hs

file too large to diff

− src/Wingman/Debug.hs

file too large to diff

− src/Wingman/EmptyCase.hs

file too large to diff

− src/Wingman/GHC.hs

file too large to diff

− src/Wingman/Judgements.hs

file too large to diff

− src/Wingman/Judgements/SYB.hs

file too large to diff

− src/Wingman/Judgements/Theta.hs

file too large to diff

− src/Wingman/KnownStrategies.hs

file too large to diff

− src/Wingman/KnownStrategies/QuickCheck.hs

file too large to diff

− src/Wingman/LanguageServer.hs

file too large to diff

− src/Wingman/LanguageServer/Metaprogram.hs

file too large to diff

− src/Wingman/LanguageServer/TacticProviders.hs

file too large to diff

− src/Wingman/Machinery.hs

file too large to diff

− src/Wingman/Metaprogramming/Lexer.hs

file too large to diff

− src/Wingman/Metaprogramming/Parser.hs

file too large to diff

− src/Wingman/Metaprogramming/Parser.hs-boot

file too large to diff

− src/Wingman/Metaprogramming/Parser/Documentation.hs

file too large to diff

− src/Wingman/Metaprogramming/ProofState.hs

file too large to diff

− src/Wingman/Naming.hs

file too large to diff

− src/Wingman/Plugin.hs

file too large to diff

− src/Wingman/Range.hs

file too large to diff

− src/Wingman/Simplify.hs

file too large to diff

− src/Wingman/StaticPlugin.hs

file too large to diff

− src/Wingman/Tactics.hs

file too large to diff

− src/Wingman/Types.hs

file too large to diff

− test/AutoTupleSpec.hs

file too large to diff

− test/CodeAction/AutoSpec.hs

file too large to diff

− test/CodeAction/DestructAllSpec.hs

file too large to diff

− test/CodeAction/DestructPunSpec.hs

file too large to diff

− test/CodeAction/DestructSpec.hs

file too large to diff

− test/CodeAction/IntroDestructSpec.hs

file too large to diff

− test/CodeAction/IntrosSpec.hs

file too large to diff

− test/CodeAction/RefineSpec.hs

file too large to diff

− test/CodeAction/RunMetaprogramSpec.hs

file too large to diff

− test/CodeAction/UseDataConSpec.hs

file too large to diff

− test/CodeLens/EmptyCaseSpec.hs

file too large to diff

− test/Main.hs

file too large to diff

− test/ProviderSpec.hs

file too large to diff

− test/Spec.hs

file too large to diff

− test/UnificationSpec.hs

file too large to diff

− test/Utils.hs

file too large to diff

− test/golden/AutoEmptyString.expected.hs

file too large to diff

− test/golden/AutoEmptyString.hs

file too large to diff

− test/golden/AutoEndo.expected.hs

file too large to diff

− test/golden/AutoEndo.hs

file too large to diff

− test/golden/AutoForallClassMethod.expected.hs

file too large to diff

− test/golden/AutoForallClassMethod.hs

file too large to diff

− test/golden/AutoInfixApply.expected.hs

file too large to diff

− test/golden/AutoInfixApply.hs

file too large to diff

− test/golden/AutoInfixApplyMany.expected.hs

file too large to diff

− test/golden/AutoInfixApplyMany.hs

file too large to diff

− test/golden/AutoInfixInfix.expected.hs

file too large to diff

− test/golden/AutoInfixInfix.hs

file too large to diff

− test/golden/AutoPatSynUse.expected.hs

file too large to diff

− test/golden/AutoPatSynUse.hs

file too large to diff

− test/golden/AutoSplitGADT.expected.hs

file too large to diff

− test/golden/AutoSplitGADT.hs

file too large to diff

− test/golden/AutoThetaEqCtx.expected.hs

file too large to diff

− test/golden/AutoThetaEqCtx.hs

file too large to diff

− test/golden/AutoThetaEqGADT.expected.hs

file too large to diff

− test/golden/AutoThetaEqGADT.hs

file too large to diff

− test/golden/AutoThetaEqGADTDestruct.expected.hs

file too large to diff

− test/golden/AutoThetaEqGADTDestruct.hs

file too large to diff

− test/golden/AutoThetaFix.expected.hs

file too large to diff

− test/golden/AutoThetaFix.hs

file too large to diff

− test/golden/AutoThetaGADT.expected.hs

file too large to diff

− test/golden/AutoThetaGADT.hs

file too large to diff

− test/golden/AutoThetaGADTDestruct.expected.hs

file too large to diff

− test/golden/AutoThetaGADTDestruct.hs

file too large to diff

− test/golden/AutoThetaMultipleUnification.expected.hs

file too large to diff

− test/golden/AutoThetaMultipleUnification.hs

file too large to diff

− test/golden/AutoThetaRankN.expected.hs

file too large to diff

− test/golden/AutoThetaRankN.hs

file too large to diff

− test/golden/AutoThetaRefl.expected.hs

file too large to diff

− test/golden/AutoThetaRefl.hs

file too large to diff

− test/golden/AutoThetaReflDestruct.expected.hs

file too large to diff

− test/golden/AutoThetaReflDestruct.hs

file too large to diff

− test/golden/AutoThetaSplitUnification.expected.hs

file too large to diff

− test/golden/AutoThetaSplitUnification.hs

file too large to diff

− test/golden/AutoTypeLevel.expected.hs

file too large to diff

− test/golden/AutoTypeLevel.hs

file too large to diff

− test/golden/AutoUnusedPatternMatch.expected.hs

file too large to diff

− test/golden/AutoUnusedPatternMatch.hs

file too large to diff

− test/golden/AutoZip.expected.hs

file too large to diff

− test/golden/AutoZip.hs

file too large to diff

− test/golden/ConProviders.hs

file too large to diff

− test/golden/DestructAllAnd.expected.hs

file too large to diff

− test/golden/DestructAllAnd.hs

file too large to diff

− test/golden/DestructAllFunc.expected.hs

file too large to diff

− test/golden/DestructAllFunc.hs

file too large to diff

− test/golden/DestructAllGADTEvidence.expected.hs

file too large to diff

− test/golden/DestructAllGADTEvidence.hs

file too large to diff

− test/golden/DestructAllMany.expected.hs

file too large to diff

− test/golden/DestructAllMany.hs

file too large to diff

− test/golden/DestructAllNonVarTopMatch.expected.hs

file too large to diff

− test/golden/DestructAllNonVarTopMatch.hs

file too large to diff

− test/golden/DestructAllProvider.hs

file too large to diff

− test/golden/DestructCthulhu.expected.hs

file too large to diff

− test/golden/DestructCthulhu.hs

file too large to diff

− test/golden/DestructDataFam.expected.hs

file too large to diff

− test/golden/DestructDataFam.hs

file too large to diff

− test/golden/DestructInt.expected.hs

file too large to diff

− test/golden/DestructInt.hs

file too large to diff

− test/golden/DestructPun.expected.hs

file too large to diff

− test/golden/DestructPun.hs

file too large to diff

− test/golden/DestructTyFam.expected.hs

file too large to diff

− test/golden/DestructTyFam.hs

file too large to diff

− test/golden/DestructTyToDataFam.expected.hs

file too large to diff

− test/golden/DestructTyToDataFam.hs

file too large to diff

− test/golden/EmptyCaseADT.expected.hs

file too large to diff

− test/golden/EmptyCaseADT.hs

file too large to diff

− test/golden/EmptyCaseApply.expected.hs

file too large to diff

− test/golden/EmptyCaseApply.hs

file too large to diff

− test/golden/EmptyCaseGADT.expected.hs

file too large to diff

− test/golden/EmptyCaseGADT.hs

file too large to diff

− test/golden/EmptyCaseLamCase.expected.hs

file too large to diff

− test/golden/EmptyCaseLamCase.hs

file too large to diff

− test/golden/EmptyCaseNested.expected.hs

file too large to diff

− test/golden/EmptyCaseNested.hs

file too large to diff

− test/golden/EmptyCaseParens.expected.hs

file too large to diff

− test/golden/EmptyCaseParens.hs

file too large to diff

− test/golden/EmptyCaseShadow.expected.hs

file too large to diff

− test/golden/EmptyCaseShadow.hs

file too large to diff

− test/golden/EmptyCaseSpuriousGADT.hs

file too large to diff

− test/golden/Fgmap.expected.hs

file too large to diff

− test/golden/Fgmap.hs

file too large to diff

− test/golden/FmapBoth.expected.hs

file too large to diff

− test/golden/FmapBoth.hs

file too large to diff

− test/golden/FmapJoin.expected.hs

file too large to diff

− test/golden/FmapJoin.hs

file too large to diff

− test/golden/FmapJoinInLet.expected.hs

file too large to diff

− test/golden/FmapJoinInLet.hs

file too large to diff

− test/golden/GoldenApplicativeThen.hs

file too large to diff

− test/golden/GoldenArbitrary.expected.hs

file too large to diff

− test/golden/GoldenArbitrary.hs

file too large to diff

− test/golden/GoldenArbitrarySingleConstructor.expected.hs

file too large to diff

− test/golden/GoldenArbitrarySingleConstructor.hs

file too large to diff

− test/golden/GoldenBigTuple.expected.hs

file too large to diff

− test/golden/GoldenBigTuple.hs

file too large to diff

− test/golden/GoldenEitherAuto.expected.hs

file too large to diff

− test/golden/GoldenEitherAuto.hs

file too large to diff

− test/golden/GoldenEitherHomomorphic.expected.hs

file too large to diff

− test/golden/GoldenEitherHomomorphic.hs

file too large to diff

− test/golden/GoldenFish.hs

file too large to diff

− test/golden/GoldenFmapTree.expected.hs

file too large to diff

− test/golden/GoldenFmapTree.hs

file too large to diff

− test/golden/GoldenFoldr.expected.hs

file too large to diff

− test/golden/GoldenFoldr.hs

file too large to diff

− test/golden/GoldenFromMaybe.expected.hs

file too large to diff

− test/golden/GoldenFromMaybe.hs

file too large to diff

− test/golden/GoldenGADTAuto.expected.hs

file too large to diff

− test/golden/GoldenGADTAuto.hs

file too large to diff

− test/golden/GoldenGADTDestruct.expected.hs

file too large to diff

− test/golden/GoldenGADTDestruct.hs

file too large to diff

− test/golden/GoldenGADTDestructCoercion.expected.hs

file too large to diff

− test/golden/GoldenGADTDestructCoercion.hs

file too large to diff

− test/golden/GoldenIdTypeFam.expected.hs

file too large to diff

− test/golden/GoldenIdTypeFam.hs

file too large to diff

− test/golden/GoldenIdentityFunctor.expected.hs

file too large to diff

− test/golden/GoldenIdentityFunctor.hs

file too large to diff

− test/golden/GoldenIntros.expected.hs

file too large to diff

− test/golden/GoldenIntros.hs

file too large to diff

− test/golden/GoldenJoinCont.expected.hs

file too large to diff

− test/golden/GoldenJoinCont.hs

file too large to diff

− test/golden/GoldenListFmap.expected.hs

file too large to diff

− test/golden/GoldenListFmap.hs

file too large to diff

− test/golden/GoldenNote.expected.hs

file too large to diff

− test/golden/GoldenNote.hs

file too large to diff

− test/golden/GoldenPureList.expected.hs

file too large to diff

− test/golden/GoldenPureList.hs

file too large to diff

− test/golden/GoldenSafeHead.expected.hs

file too large to diff

− test/golden/GoldenSafeHead.hs

file too large to diff

− test/golden/GoldenShow.expected.hs

file too large to diff

− test/golden/GoldenShow.hs

file too large to diff

− test/golden/GoldenShowCompose.expected.hs

file too large to diff

− test/golden/GoldenShowCompose.hs

file too large to diff

− test/golden/GoldenShowMapChar.expected.hs

file too large to diff

− test/golden/GoldenShowMapChar.hs

file too large to diff

− test/golden/GoldenSuperclass.expected.hs

file too large to diff

− test/golden/GoldenSuperclass.hs

file too large to diff

− test/golden/GoldenSwap.expected.hs

file too large to diff

− test/golden/GoldenSwap.hs

file too large to diff

− test/golden/GoldenSwapMany.expected.hs

file too large to diff

− test/golden/GoldenSwapMany.hs

file too large to diff

− test/golden/IntroDestructLetBinding.expected.hs

file too large to diff

− test/golden/IntroDestructLetBinding.hs

file too large to diff

− test/golden/IntroDestructMany.expected.hs

file too large to diff

− test/golden/IntroDestructMany.hs

file too large to diff

− test/golden/IntroDestructOne.expected.hs

file too large to diff

− test/golden/IntroDestructOne.hs

file too large to diff

− test/golden/IntroDestructProvider.hs

file too large to diff

− test/golden/IntrosTooMany.expected.hs

file too large to diff

− test/golden/IntrosTooMany.hs

file too large to diff

− test/golden/KnownBigSemigroup.expected.hs

file too large to diff

− test/golden/KnownBigSemigroup.hs

file too large to diff

− test/golden/KnownCounterfactualSemigroup.expected.hs

file too large to diff

− test/golden/KnownCounterfactualSemigroup.hs

file too large to diff

− test/golden/KnownDestructedSemigroup.expected.hs

file too large to diff

− test/golden/KnownDestructedSemigroup.hs

file too large to diff

− test/golden/KnownMissingMonoid.expected.hs

file too large to diff

− test/golden/KnownMissingMonoid.hs

file too large to diff

− test/golden/KnownMissingSemigroup.expected.hs

file too large to diff

− test/golden/KnownMissingSemigroup.hs

file too large to diff

− test/golden/KnownModuleInstanceSemigroup.expected.hs

file too large to diff

− test/golden/KnownModuleInstanceSemigroup.hs

file too large to diff

− test/golden/KnownMonoid.expected.hs

file too large to diff

− test/golden/KnownMonoid.hs

file too large to diff

− test/golden/KnownPolyMonoid.expected.hs

file too large to diff

− test/golden/KnownPolyMonoid.hs

file too large to diff

− test/golden/KnownThetaSemigroup.expected.hs

file too large to diff

− test/golden/KnownThetaSemigroup.hs

file too large to diff

− test/golden/LayoutBind.expected.hs

file too large to diff

− test/golden/LayoutBind.hs

file too large to diff

− test/golden/LayoutDollarApp.expected.hs

file too large to diff

− test/golden/LayoutDollarApp.hs

file too large to diff

− test/golden/LayoutInfixKeep.expected.hs

file too large to diff

− test/golden/LayoutInfixKeep.hs

file too large to diff

− test/golden/LayoutLam.expected.hs

file too large to diff

− test/golden/LayoutLam.hs

file too large to diff

− test/golden/LayoutOpApp.expected.hs

file too large to diff

− test/golden/LayoutOpApp.hs

file too large to diff

− test/golden/LayoutPrefixKeep.expected.hs

file too large to diff

− test/golden/LayoutPrefixKeep.hs

file too large to diff

− test/golden/LayoutRec.expected.hs

file too large to diff

− test/golden/LayoutRec.hs

file too large to diff

− test/golden/LayoutSplitClass.expected.hs

file too large to diff

− test/golden/LayoutSplitClass.hs

file too large to diff

− test/golden/LayoutSplitGuard.expected.hs

file too large to diff

− test/golden/LayoutSplitGuard.hs

file too large to diff

− test/golden/LayoutSplitIn.expected.hs

file too large to diff

− test/golden/LayoutSplitIn.hs

file too large to diff

− test/golden/LayoutSplitLet.expected.hs

file too large to diff

− test/golden/LayoutSplitLet.hs

file too large to diff

− test/golden/LayoutSplitPatSyn.expected.hs

file too large to diff

− test/golden/LayoutSplitPatSyn.hs

file too large to diff

− test/golden/LayoutSplitPattern.expected.hs

file too large to diff

− test/golden/LayoutSplitPattern.hs

file too large to diff

− test/golden/LayoutSplitViewPat.expected.hs

file too large to diff

− test/golden/LayoutSplitViewPat.hs

file too large to diff

− test/golden/LayoutSplitWhere.expected.hs

file too large to diff

− test/golden/LayoutSplitWhere.hs

file too large to diff

− test/golden/MessageCantUnify.hs

file too large to diff

− test/golden/MessageForallA.hs

file too large to diff

− test/golden/MessageNotEnoughGas.hs

file too large to diff

− test/golden/MetaBegin.expected.hs

file too large to diff

− test/golden/MetaBegin.hs

file too large to diff

− test/golden/MetaBeginNoWildify.expected.hs

file too large to diff

− test/golden/MetaBeginNoWildify.hs

file too large to diff

− test/golden/MetaBindAll.expected.hs

file too large to diff

− test/golden/MetaBindAll.hs

file too large to diff

− test/golden/MetaBindOne.expected.hs

file too large to diff

− test/golden/MetaBindOne.hs

file too large to diff

− test/golden/MetaCataAST.expected.hs

file too large to diff

− test/golden/MetaCataAST.hs

file too large to diff

− test/golden/MetaCataCollapse.expected.hs

file too large to diff

− test/golden/MetaCataCollapse.hs

file too large to diff

− test/golden/MetaCataCollapseUnary.expected.hs

file too large to diff

− test/golden/MetaCataCollapseUnary.hs

file too large to diff

− test/golden/MetaChoice.expected.hs

file too large to diff

− test/golden/MetaChoice.hs

file too large to diff

− test/golden/MetaDeepOf.expected.hs

file too large to diff

− test/golden/MetaDeepOf.hs

file too large to diff

− test/golden/MetaFundeps.expected.hs

file too large to diff

− test/golden/MetaFundeps.hs

file too large to diff

− test/golden/MetaIdiom.expected.hs

file too large to diff

− test/golden/MetaIdiom.hs

file too large to diff

− test/golden/MetaIdiomRecord.expected.hs

file too large to diff

− test/golden/MetaIdiomRecord.hs

file too large to diff

− test/golden/MetaLetSimple.expected.hs

file too large to diff

− test/golden/MetaLetSimple.hs

file too large to diff

− test/golden/MetaMaybeAp.expected.hs

file too large to diff

− test/golden/MetaMaybeAp.hs

file too large to diff

− test/golden/MetaPointwise.expected.hs

file too large to diff

− test/golden/MetaPointwise.hs

file too large to diff

− test/golden/MetaTry.expected.hs

file too large to diff

− test/golden/MetaTry.hs

file too large to diff

− test/golden/MetaUseImport.expected.hs

file too large to diff

− test/golden/MetaUseImport.hs

file too large to diff

− test/golden/MetaUseLocal.expected.hs

file too large to diff

− test/golden/MetaUseLocal.hs

file too large to diff

− test/golden/MetaUseMethod.expected.hs

file too large to diff

− test/golden/MetaUseMethod.hs

file too large to diff

− test/golden/MetaUseSymbol.expected.hs

file too large to diff

− test/golden/MetaUseSymbol.hs

file too large to diff

− test/golden/MetaWithArg.expected.hs

file too large to diff

− test/golden/MetaWithArg.hs

file too large to diff

− test/golden/NewtypeRecord.expected.hs

file too large to diff

− test/golden/NewtypeRecord.hs

file too large to diff

− test/golden/ProvideAlreadyDestructed.hs

file too large to diff

− test/golden/ProvideLocalHyOnly.hs

file too large to diff

− test/golden/ProviderHomomorphism.hs

file too large to diff

− test/golden/PunGADT.expected.hs

file too large to diff

− test/golden/PunGADT.hs

file too large to diff

− test/golden/PunMany.expected.hs

file too large to diff

− test/golden/PunMany.hs

file too large to diff

− test/golden/PunManyGADT.expected.hs

file too large to diff

− test/golden/PunManyGADT.hs

file too large to diff

− test/golden/PunShadowing.expected.hs

file too large to diff

− test/golden/PunShadowing.hs

file too large to diff

− test/golden/PunSimple.expected.hs

file too large to diff

− test/golden/PunSimple.hs

file too large to diff

− test/golden/RecordCon.expected.hs

file too large to diff

− test/golden/RecordCon.hs

file too large to diff

− test/golden/RefineCon.expected.hs

file too large to diff

− test/golden/RefineCon.hs

file too large to diff

− test/golden/RefineGADT.expected.hs

file too large to diff

− test/golden/RefineGADT.hs

file too large to diff

− test/golden/RefineIntro.expected.hs

file too large to diff

− test/golden/RefineIntro.hs

file too large to diff

− test/golden/RefineIntroWhere.expected.hs

file too large to diff

− test/golden/RefineIntroWhere.hs

file too large to diff

− test/golden/RefineReader.expected.hs

file too large to diff

− test/golden/RefineReader.hs

file too large to diff

− test/golden/SplitPattern.expected.hs

file too large to diff

− test/golden/SplitPattern.hs

file too large to diff

− test/golden/SubsequentTactics.expected.hs

file too large to diff

− test/golden/SubsequentTactics.hs

file too large to diff

− test/golden/T1.hs

file too large to diff

− test/golden/T2.hs

file too large to diff

− test/golden/T3.hs

file too large to diff

− test/golden/UseConLeft.expected.hs

file too large to diff

− test/golden/UseConLeft.hs

file too large to diff

− test/golden/UseConPair.expected.hs

file too large to diff

− test/golden/UseConPair.hs

file too large to diff

− test/golden/UseConRight.expected.hs

file too large to diff

− test/golden/UseConRight.hs

file too large to diff

− test/golden/hie.yaml

file too large to diff

− test/golden/test.cabal

file too large to diff