diff --git a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal index 225b132f47..2ad0a7365e 100644 --- a/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal +++ b/plugins/hls-tactics-plugin/hls-tactics-plugin.cabal @@ -15,6 +15,11 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md + 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 @@ -29,11 +34,15 @@ flag pedantic manual: True library - if impl(ghc >= 9.3) + if impl(ghc >= 9.2.1) buildable: False else buildable: True - hs-source-dirs: old/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 @@ -135,7 +144,7 @@ library ViewPatterns test-suite tests - if impl(ghc >= 9.3) + if impl(ghc >= 9.2.1) buildable: False else buildable: True @@ -158,7 +167,10 @@ test-suite tests UnificationSpec Utils - hs-source-dirs: old/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 diff --git a/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs b/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs new file mode 100644 index 0000000000..cf326ee653 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Ide/Plugin/Tactic.hs @@ -0,0 +1,5 @@ +-- | A plugin that uses tactics to synthesize code +module Ide.Plugin.Tactic (descriptor, Log(..)) where + +import Wingman.Plugin + diff --git a/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs b/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs new file mode 100644 index 0000000000..e829672831 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Refinery/Future.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs new file mode 100644 index 0000000000..da1e068ba6 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP.hs @@ -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 (getTacticConfig, 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 <- lift $ getTacticConfig 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 + } + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs new file mode 100644 index 0000000000..bb30f27b02 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/TacticActions.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs new file mode 100644 index 0000000000..18d38c6eca --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/AbstractLSP/Types.hs @@ -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 +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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs new file mode 100644 index 0000000000..3748af1e5b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Auto.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs new file mode 100644 index 0000000000..373fc9b23b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/CaseSplit.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs new file mode 100644 index 0000000000..322a6f5b8c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs new file mode 100644 index 0000000000..d683db9ffd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/CodeGen/Utils.hs @@ -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 "$" + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs new file mode 100644 index 0000000000..3c1b40ba1f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Context.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs new file mode 100644 index 0000000000..e637779824 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Debug.hs @@ -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 "" 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 diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs b/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs new file mode 100644 index 0000000000..a13d7c1a65 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/EmptyCase.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs b/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs new file mode 100644 index 0000000000..13562a6ef8 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/GHC.hs @@ -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 + ) + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs new file mode 100644 index 0000000000..0ff03e60ee --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs new file mode 100644 index 0000000000..8cd6130eb3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/SYB.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs new file mode 100644 index 0000000000..25bf5a3a21 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Judgements/Theta.hs @@ -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 _ = [] + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs new file mode 100644 index 0000000000..e898358c49 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs new file mode 100644 index 0000000000..b14e4b8348 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/KnownStrategies/QuickCheck.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs new file mode 100644 index 0000000000..c0bba854ff --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer.hs @@ -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 ` 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 +getTacticConfig :: MonadLsp Plugin.Config m => PluginId -> m Config +getTacticConfig pId = + Config + <$> usePropertyLsp #max_use_ctor_actions pId properties + <*> usePropertyLsp #timeout_duration pId properties + <*> usePropertyLsp #auto_gas pId properties + <*> usePropertyLsp #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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs new file mode 100644 index 0000000000..e853831a32 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/Metaprogram.hs @@ -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 <- getTacticConfig 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 diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs new file mode 100644 index 0000000000..b5a6521b7e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/LanguageServer/TacticProviders.hs @@ -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 +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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs new file mode 100644 index 0000000000..ca082ec65e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Machinery.hs @@ -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) (ctx_module 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) + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs new file mode 100644 index 0000000000..fed7e91bbd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Lexer.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs new file mode 100644 index 0000000000..a1d4eca4d4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs @@ -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 "" (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 "" + + +------------------------------------------------------------------------------ +-- | Automatically generate the metaprogram command reference. +writeDocumentation :: IO () +writeDocumentation = + writeFile "COMMANDS.md" $ + unlines + [ "# Wingman Metaprogram Command Reference" + , "" + , prettyReadme commands + ] + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot new file mode 100644 index 0000000000..607db0e6f3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser.hs-boot @@ -0,0 +1,7 @@ +module Wingman.Metaprogramming.Parser where + +import Wingman.Metaprogramming.Lexer +import Wingman.Types + +tactic :: Parser (TacticsM ()) + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs new file mode 100644 index 0000000000..44071a5ae7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/Parser/Documentation.hs @@ -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 + } + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs new file mode 100644 index 0000000000..02e203a1d3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Metaprogramming/ProofState.hs @@ -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 = "" +renderAnn _ Hypoth = "```haskell\n" +renderAnn _ Status = "" + +renderUnann :: Bool -> Ann -> T.Text +renderUnann False _ = "" +renderUnann _ Goal = "" +renderUnann _ Hypoth = "\n```\n" +renderUnann _ Status = "" + +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 ' ' + + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs new file mode 100644 index 0000000000..832fa117e1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Naming.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs new file mode 100644 index 0000000000..b55ee31ae3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Plugin.hs @@ -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 + } + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs new file mode 100644 index 0000000000..ec61efc27f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Range.hs @@ -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)) diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs new file mode 100644 index 0000000000..10eaae97c7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Simplify.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs b/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs new file mode 100644 index 0000000000..42065aa289 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/StaticPlugin.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs new file mode 100644 index 0000000000..10d87722cd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Tactics.hs @@ -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 " +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 + diff --git a/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs new file mode 100644 index 0000000000..621cc9752e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/src/Wingman/Types.hs @@ -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 _ = "" + + +------------------------------------------------------------------------------ +-- | 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 + } + diff --git a/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs b/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs new file mode 100644 index 0000000000..11ba11e2ae --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/AutoTupleSpec.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs new file mode 100644 index 0000000000..4075183ee6 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/AutoSpec.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs new file mode 100644 index 0000000000..488fb3ebad --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructAllSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs new file mode 100644 index 0000000000..7d17aa1d2c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructPunSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs new file mode 100644 index 0000000000..2251abfeb2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/DestructSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs new file mode 100644 index 0000000000..5c3b809c1d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/IntroDestructSpec.hs @@ -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, "") + ] + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs new file mode 100644 index 0000000000..da2aaaa273 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/IntrosSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs new file mode 100644 index 0000000000..205054c652 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/RefineSpec.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs new file mode 100644 index 0000000000..e366c34efe --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/RunMetaprogramSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs new file mode 100644 index 0000000000..94a1d17550 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeAction/UseDataConSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs b/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs new file mode 100644 index 0000000000..9ebf7d5043 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/CodeLens/EmptyCaseSpec.hs @@ -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" + diff --git a/plugins/hls-tactics-plugin/new/test/Main.hs b/plugins/hls-tactics-plugin/new/test/Main.hs new file mode 100644 index 0000000000..00a71905e1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/Main.hs @@ -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" diff --git a/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs b/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs new file mode 100644 index 0000000000..4eea30f5b3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/ProviderSpec.hs @@ -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 + ] diff --git a/plugins/hls-tactics-plugin/new/test/Spec.hs b/plugins/hls-tactics-plugin/new/test/Spec.hs new file mode 100644 index 0000000000..5416ef6a86 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs b/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs new file mode 100644 index 0000000000..148a40eaaa --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/UnificationSpec.hs @@ -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 + + diff --git a/plugins/hls-tactics-plugin/new/test/Utils.hs b/plugins/hls-tactics-plugin/new/test/Utils.hs new file mode 100644 index 0000000000..db31d910cf --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/Utils.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs new file mode 100644 index 0000000000..8ccb9f083d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.expected.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = "" diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs new file mode 100644 index 0000000000..f04451e24c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoEmptyString.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs new file mode 100644 index 0000000000..4b50c6c074 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.expected.hs @@ -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} + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs new file mode 100644 index 0000000000..c92e6adb5b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoEndo.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs new file mode 100644 index 0000000000..5846428ee7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.expected.hs @@ -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 } + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs new file mode 100644 index 0000000000..9ee00c9255 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoForallClassMethod.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs new file mode 100644 index 0000000000..367f6e54d9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.expected.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = a /: f a + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs new file mode 100644 index 0000000000..4675331aea --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApply.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs new file mode 100644 index 0000000000..ce40bf0cd6 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.expected.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c +test (/:) a f x = (a /: f a) x + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs new file mode 100644 index 0000000000..55a706ab9b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixApplyMany.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c +test (/:) a f x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs new file mode 100644 index 0000000000..7adea169d1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.expected.hs @@ -0,0 +1,2 @@ +test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e +test (/:) (-->) a f x = (a /: f a) --> x diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs new file mode 100644 index 0000000000..729e1a2227 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoInfixInfix.hs @@ -0,0 +1,2 @@ +test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e +test (/:) (-->) a f x = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs new file mode 100644 index 0000000000..8addba654f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs new file mode 100644 index 0000000000..25a44666e7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoPatSynUse.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + +amIASingleton :: Maybe [a] -> Maybe a +amIASingleton (JustSingleton a) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs new file mode 100644 index 0000000000..2521b651eb --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs new file mode 100644 index 0000000000..b15621e091 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoSplitGADT.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs new file mode 100644 index 0000000000..cdb8506d01 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = id -- id + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs new file mode 100644 index 0000000000..448a7f5de5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqCtx.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = _ -- id + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs new file mode 100644 index 0000000000..cea9517794 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data Y a b = a ~ b => Y + +fun3 :: Y a b -> a -> b +fun3 Y = id + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs new file mode 100644 index 0000000000..eae2246722 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data Y a b = a ~ b => Y + +fun3 :: Y a b -> a -> b +fun3 Y = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs new file mode 100644 index 0000000000..9f2b954867 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +data Y a b = a ~ b => Y + +fun3 :: Y a b -> a -> b +fun3 Y a = a + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs new file mode 100644 index 0000000000..2292a3972f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaEqGADTDestruct.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +data Y a b = a ~ b => Y + +fun3 :: Y a b -> a -> b +fun3 = _ + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs new file mode 100644 index 0000000000..ba8df349e4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs new file mode 100644 index 0000000000..014e6441da --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaFix.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs new file mode 100644 index 0000000000..e74f2aba40 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data X f = Monad f => X + +fun1 :: X f -> a -> f a +fun1 X = pure + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs new file mode 100644 index 0000000000..e1b20a4b3b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADT.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data X f = Monad f => X + +fun1 :: X f -> a -> f a +fun1 X = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs new file mode 100644 index 0000000000..4d4b1f9579 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data X f = Monad f => X + +fun1 :: X f -> a -> f a +fun1 X a = pure a + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs new file mode 100644 index 0000000000..d92d0bd97d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaGADTDestruct.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data X f = Monad f => X + +fun1 :: X f -> a -> f a +fun1 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs new file mode 100644 index 0000000000..446a4d73b3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.expected.hs @@ -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') = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs new file mode 100644 index 0000000000..b0b520347d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaMultipleUnification.hs @@ -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') = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs new file mode 100644 index 0000000000..23d96223f3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs new file mode 100644 index 0000000000..0e92ac35f3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRankN.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes #-} + +showMe :: (forall x. Show x => x -> String) -> Int -> String +showMe f = f + +showedYou :: Int -> String +showedYou = showMe (\x -> _) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs new file mode 100644 index 0000000000..9e42bc946e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs new file mode 100644 index 0000000000..df15580ad2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaRefl.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GADTs #-} + +data Z a b where Z :: Z a a + +fun4 :: Z a b -> a -> b +fun4 Z = _ -- id + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs new file mode 100644 index 0000000000..36aed1af65 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.expected.hs @@ -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 + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs new file mode 100644 index 0000000000..3beccba7a5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaReflDestruct.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +data Z a b where Z :: Z a a + +fun4 :: Z a b -> a -> b +fun4 = _ -- id + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs new file mode 100644 index 0000000000..e680f0265c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs new file mode 100644 index 0000000000..e6ceeb1bcd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoThetaSplitUnification.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs new file mode 100644 index 0000000000..3668830620 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.expected.hs @@ -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' + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs new file mode 100644 index 0000000000..40226739db --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoTypeLevel.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs new file mode 100644 index 0000000000..2885a1ca05 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.expected.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test _ = () diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs new file mode 100644 index 0000000000..5345192969 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoUnusedPatternMatch.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs new file mode 100644 index 0000000000..997bc09a33 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.expected.hs @@ -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' + diff --git a/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs new file mode 100644 index 0000000000..98d6335988 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/AutoZip.hs @@ -0,0 +1,3 @@ +zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] +zip_it_up_and_zip_it_out = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs b/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs new file mode 100644 index 0000000000..19dbc3c6e5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/ConProviders.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs new file mode 100644 index 0000000000..392bd9d2cd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.expected.hs @@ -0,0 +1,5 @@ +and :: Bool -> Bool -> Bool +and False False = _w0 +and False True = _w1 +and True False = _w2 +and True True = _w3 diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs new file mode 100644 index 0000000000..892eab679c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllAnd.hs @@ -0,0 +1,2 @@ +and :: Bool -> Bool -> Bool +and x y = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs new file mode 100644 index 0000000000..536d15b107 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.expected.hs @@ -0,0 +1,4 @@ +has_a_func :: Bool -> (a -> b) -> Bool +has_a_func False y = _w0 +has_a_func True y = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs new file mode 100644 index 0000000000..6996698400 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllFunc.hs @@ -0,0 +1,3 @@ +has_a_func :: Bool -> (a -> b) -> Bool +has_a_func x y = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs new file mode 100644 index 0000000000..0e4c0985fa --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs new file mode 100644 index 0000000000..3ac66d5444 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllGADTEvidence.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs new file mode 100644 index 0000000000..366a3eac70 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs new file mode 100644 index 0000000000..ab0a4dccb9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllMany.hs @@ -0,0 +1,4 @@ +data ABC = A | B | C + +many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () +many u e b mabc abc = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs new file mode 100644 index 0000000000..dc1ea66c51 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs new file mode 100644 index 0000000000..358223ae67 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllNonVarTopMatch.hs @@ -0,0 +1,3 @@ +and :: (a, b) -> Bool -> Bool -> Bool +and (a, b) x y = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs new file mode 100644 index 0000000000..8d115e828d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructAllProvider.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs new file mode 100644 index 0000000000..e885b489a1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs new file mode 100644 index 0000000000..a2d04bb6a2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructCthulhu.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs new file mode 100644 index 0000000000..e463935583 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.expected.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +data family Yo +data instance Yo = Heya Int + +test :: Yo -> Int +test (Heya n) = _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs new file mode 100644 index 0000000000..a93e1974fb --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructDataFam.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +data family Yo +data instance Yo = Heya Int + +test :: Yo -> Int +test b = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs new file mode 100644 index 0000000000..0f14deef83 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.expected.hs @@ -0,0 +1,7 @@ +import Data.Int + +data Test = Test Int32 + +test :: Test -> Int32 +test (Test in') = _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs new file mode 100644 index 0000000000..432a6d4074 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructInt.hs @@ -0,0 +1,7 @@ +import Data.Int + +data Test = Test Int32 + +test :: Test -> Int32 +test t = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs new file mode 100644 index 0000000000..bfd8d09074 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs new file mode 100644 index 0000000000..c7b410c5e3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructPun.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} + + +data Foo = Foo { a :: Bool, b :: Bool } + +foo Foo {a, b} = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs new file mode 100644 index 0000000000..eee4cbd587 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.expected.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} + +type family Yo where + Yo = Bool + +test :: Yo -> Int +test False = _w0 +test True = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs new file mode 100644 index 0000000000..30a9d884b7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructTyFam.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +type family Yo where + Yo = Bool + +test :: Yo -> Int +test b = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs new file mode 100644 index 0000000000..3016c4ef4e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs new file mode 100644 index 0000000000..191fa7b044 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/DestructTyToDataFam.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs new file mode 100644 index 0000000000..84d2b80d0e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.expected.hs @@ -0,0 +1,8 @@ +data Foo = A Int | B Bool | C + +foo :: Foo -> () +foo x = case x of + A n -> _ + B b -> _ + C -> _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs new file mode 100644 index 0000000000..37d3b6c357 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseADT.hs @@ -0,0 +1,5 @@ +data Foo = A Int | B Bool | C + +foo :: Foo -> () +foo x = case x of + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs new file mode 100644 index 0000000000..1895dd6256 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.expected.hs @@ -0,0 +1,3 @@ +blah = case show 5 of + [] -> _ + c : s -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs new file mode 100644 index 0000000000..29647e2cda --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseApply.hs @@ -0,0 +1 @@ +blah = case show 5 of diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs new file mode 100644 index 0000000000..409be2aa03 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.expected.hs @@ -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 -> _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs new file mode 100644 index 0000000000..ba08ddae54 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseGADT.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs new file mode 100644 index 0000000000..048f437368 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case + False -> _ + True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs new file mode 100644 index 0000000000..ef490eb751 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseLamCase.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs new file mode 100644 index 0000000000..ef873a7c41 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.expected.hs @@ -0,0 +1,5 @@ +test = + case (case (Just "") of + Nothing -> _ + Just s -> _) of + True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs new file mode 100644 index 0000000000..a72781a7c6 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseNested.hs @@ -0,0 +1,3 @@ +test = + case (case (Just "") of) of + True -> _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs new file mode 100644 index 0000000000..18aacf2ae2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.expected.hs @@ -0,0 +1,3 @@ +test = True && (case True of + False -> _ + True -> _) diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs new file mode 100644 index 0000000000..2ac71b042e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseParens.hs @@ -0,0 +1 @@ +test = True && case True of diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs new file mode 100644 index 0000000000..2c5158b856 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.expected.hs @@ -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 -> _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs new file mode 100644 index 0000000000..c57af5b849 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseShadow.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs new file mode 100644 index 0000000000..25906fe536 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/EmptyCaseSpuriousGADT.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} + +data Foo a where + Foo :: Foo Int + +foo :: Foo Bool -> () +foo x = case x of + diff --git a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs new file mode 100644 index 0000000000..4f4921fa05 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.expected.hs @@ -0,0 +1,2 @@ +fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) +fgmap = fmap . fmap diff --git a/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs new file mode 100644 index 0000000000..de1968474e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/Fgmap.hs @@ -0,0 +1,2 @@ +fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) +fgmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs new file mode 100644 index 0000000000..825b00ebea --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs new file mode 100644 index 0000000000..29d8ea62b2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapBoth.hs @@ -0,0 +1,3 @@ +fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) +fmapBoth = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs new file mode 100644 index 0000000000..5dc5026f8b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.expected.hs @@ -0,0 +1,2 @@ +fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) +fJoin = fmap (\ m -> m >>= id) diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs new file mode 100644 index 0000000000..98a40133ea --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapJoin.hs @@ -0,0 +1,2 @@ +fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) +fJoin = fmap _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs new file mode 100644 index 0000000000..ac4b54ae9d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs new file mode 100644 index 0000000000..e6fe6cbd0d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/FmapJoinInLet.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs new file mode 100644 index 0000000000..29ce9f5132 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenApplicativeThen.hs @@ -0,0 +1,2 @@ +useThen :: Applicative f => f Int -> f a -> f a +useThen = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs new file mode 100644 index 0000000000..6f7af5c3fd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.expected.hs @@ -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)) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs new file mode 100644 index 0000000000..f45d2d1fea --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrary.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs new file mode 100644 index 0000000000..786e381ca8 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs @@ -0,0 +1,7 @@ +data Gen a + +data Obj = Obj Int Bool Char String + +arbitrary :: Gen Obj +arbitrary + = (((Obj <$> arbitrary) <*> arbitrary) <*> arbitrary) <*> arbitrary \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs new file mode 100644 index 0000000000..a6a7d171a3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenArbitrarySingleConstructor.hs @@ -0,0 +1,6 @@ +data Gen a + +data Obj = Obj Int Bool Char String + +arbitrary :: Gen Obj +arbitrary = _ \ No newline at end of file diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs new file mode 100644 index 0000000000..1e7ccecde4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.expected.hs @@ -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)) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs new file mode 100644 index 0000000000..1ede521a5f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenBigTuple.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs new file mode 100644 index 0000000000..f7756898e0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs new file mode 100644 index 0000000000..eb34cd8209 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherAuto.hs @@ -0,0 +1,2 @@ +either' :: (a -> c) -> (b -> c) -> Either a b -> c +either' = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs new file mode 100644 index 0000000000..c18f2ec476 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.expected.hs @@ -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) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs new file mode 100644 index 0000000000..dee865d1a2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenEitherHomomorphic.hs @@ -0,0 +1,2 @@ +eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c +eitherSplit = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs new file mode 100644 index 0000000000..ce38700b58 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFish.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs new file mode 100644 index 0000000000..2b32b3a9cd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.expected.hs @@ -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) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs new file mode 100644 index 0000000000..679e7902df --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFmapTree.hs @@ -0,0 +1,4 @@ +data Tree a = Leaf a | Branch (Tree a) (Tree a) + +instance Functor Tree where + fmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs new file mode 100644 index 0000000000..89db0adb76 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.expected.hs @@ -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') diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs new file mode 100644 index 0000000000..bade9c1e7a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFoldr.hs @@ -0,0 +1,2 @@ +foldr2 :: (a -> b -> b) -> b -> [a] -> b +foldr2 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs new file mode 100644 index 0000000000..5b39ea5a4b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.expected.hs @@ -0,0 +1,3 @@ +fromMaybe :: a -> Maybe a -> a +fromMaybe a Nothing = a +fromMaybe _ (Just a') = a' diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs new file mode 100644 index 0000000000..e3046a29c3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenFromMaybe.hs @@ -0,0 +1,2 @@ +fromMaybe :: a -> Maybe a -> a +fromMaybe = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs new file mode 100644 index 0000000000..88f33dd2da --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.expected.hs @@ -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 () diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs new file mode 100644 index 0000000000..1c47dd0e07 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTAuto.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs new file mode 100644 index 0000000000..3f5f4fa157 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs new file mode 100644 index 0000000000..588cf362a2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestruct.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs new file mode 100644 index 0000000000..4f4b2d3a4a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.expected.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs new file mode 100644 index 0000000000..9eca759e85 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenGADTDestructCoercion.hs @@ -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 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs new file mode 100644 index 0000000000..7b3d1beda0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.expected.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +type family TyFam +type instance TyFam = Int + +tyblah' :: TyFam -> Int +tyblah' = id diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs new file mode 100644 index 0000000000..be8903fec0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdTypeFam.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +type family TyFam +type instance TyFam = Int + +tyblah' :: TyFam -> Int +tyblah' = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs new file mode 100644 index 0000000000..5c509d6507 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.expected.hs @@ -0,0 +1,3 @@ +data Ident a = Ident a +instance Functor Ident where + fmap fab (Ident a) = Ident (fab a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs new file mode 100644 index 0000000000..6d1de50992 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIdentityFunctor.hs @@ -0,0 +1,3 @@ +data Ident a = Ident a +instance Functor Ident where + fmap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs new file mode 100644 index 0000000000..0ae8c4bbac --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.expected.hs @@ -0,0 +1,2 @@ +blah :: Int -> Bool -> (a -> b) -> String -> Int +blah n b fab s = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs new file mode 100644 index 0000000000..5b4e6e241f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenIntros.hs @@ -0,0 +1,2 @@ +blah :: Int -> Bool -> (a -> b) -> String -> Int +blah = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs new file mode 100644 index 0000000000..e941214796 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.expected.hs @@ -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) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs new file mode 100644 index 0000000000..f2c63714da --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenJoinCont.hs @@ -0,0 +1,4 @@ +type Cont r a = ((a -> r) -> r) + +joinCont :: Cont r (Cont r a) -> Cont r a +joinCont = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs new file mode 100644 index 0000000000..ec44241736 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.expected.hs @@ -0,0 +1,3 @@ +fmapList :: (a -> b) -> [a] -> [b] +fmapList _ [] = [] +fmapList fab (a : as') = fab a : fmapList fab as' diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs new file mode 100644 index 0000000000..85293daaf4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenListFmap.hs @@ -0,0 +1,2 @@ +fmapList :: (a -> b) -> [a] -> [b] +fmapList = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs new file mode 100644 index 0000000000..99bc0cd6d0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.expected.hs @@ -0,0 +1,3 @@ +note :: e -> Maybe a -> Either e a +note e Nothing = Left e +note _ (Just a) = Right a diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs new file mode 100644 index 0000000000..c9e0c820e4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenNote.hs @@ -0,0 +1,2 @@ +note :: e -> Maybe a -> Either e a +note = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs new file mode 100644 index 0000000000..8f2bc80ea7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.expected.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList a = a : [] diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs new file mode 100644 index 0000000000..3a3293b4ec --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenPureList.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs new file mode 100644 index 0000000000..7f8f73e5b7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.expected.hs @@ -0,0 +1,3 @@ +safeHead :: [x] -> Maybe x +safeHead [] = Nothing +safeHead (x : _) = Just x diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs new file mode 100644 index 0000000000..6a5d27c0d1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSafeHead.hs @@ -0,0 +1,2 @@ +safeHead :: [x] -> Maybe x +safeHead = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs new file mode 100644 index 0000000000..05ba83e9fe --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.expected.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = show diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs new file mode 100644 index 0000000000..9ec5e27bcf --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShow.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs new file mode 100644 index 0000000000..d8a78b3017 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.expected.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose fba = show . fba diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs new file mode 100644 index 0000000000..c99768e4e5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowCompose.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs new file mode 100644 index 0000000000..c32357d1a9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.expected.hs @@ -0,0 +1,2 @@ +test :: Show a => a -> (String -> b) -> b +test a f = f (show a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs new file mode 100644 index 0000000000..8e6e5eae6b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenShowMapChar.hs @@ -0,0 +1,2 @@ +test :: Show a => a -> (String -> b) -> b +test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs new file mode 100644 index 0000000000..e0a5dbb565 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.expected.hs @@ -0,0 +1,8 @@ +class Super a where + super :: a + +class Super a => Sub a + +blah :: Sub a => a +blah = super + diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs new file mode 100644 index 0000000000..86a9fed7bc --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSuperclass.hs @@ -0,0 +1,8 @@ +class Super a where + super :: a + +class Super a => Sub a + +blah :: Sub a => a +blah = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs new file mode 100644 index 0000000000..e09cb3800a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.expected.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs new file mode 100644 index 0000000000..9243955c54 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwap.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs new file mode 100644 index 0000000000..1d2bc0a605 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.expected.hs @@ -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) diff --git a/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs new file mode 100644 index 0000000000..b1f6c0fb2a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/GoldenSwapMany.hs @@ -0,0 +1,2 @@ +swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) +swapMany = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs new file mode 100644 index 0000000000..0039ab768e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.expected.hs @@ -0,0 +1,6 @@ +test :: IO () +test = do + let x :: Bool -> Int + x False = _w0 + x True = _w1 + pure () diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs new file mode 100644 index 0000000000..bf12200131 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructLetBinding.hs @@ -0,0 +1,5 @@ +test :: IO () +test = do + let x :: Bool -> Int + x = _ + pure () diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs new file mode 100644 index 0000000000..462e5edf99 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.expected.hs @@ -0,0 +1,4 @@ +x :: Bool -> Maybe Int -> String -> Int +x False = _w0 +x True = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs new file mode 100644 index 0000000000..98a4bd552c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructMany.hs @@ -0,0 +1,3 @@ +x :: Bool -> Maybe Int -> String -> Int +x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs new file mode 100644 index 0000000000..4ba80e2455 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.expected.hs @@ -0,0 +1,6 @@ +module Test where + +x :: Bool -> Int +x False = _w0 +x True = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs new file mode 100644 index 0000000000..2afdc50ca5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructOne.hs @@ -0,0 +1,5 @@ +module Test where + +x :: Bool -> Int +x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs new file mode 100644 index 0000000000..f0d127dd50 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntroDestructProvider.hs @@ -0,0 +1,9 @@ +hasAlgTy :: Maybe Int -> Int +hasAlgTy = _ + +hasFunTy :: (Int -> Int) -> Int +hasFunTy = _ + +isSaturated :: Bool -> Int +isSaturated b = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs new file mode 100644 index 0000000000..97668d8c90 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.expected.hs @@ -0,0 +1,2 @@ +too_many :: a -> b -> c +too_many a b = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs new file mode 100644 index 0000000000..066f123a47 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/IntrosTooMany.hs @@ -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 |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs new file mode 100644 index 0000000000..c97ba98a6a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.expected.hs @@ -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') + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs new file mode 100644 index 0000000000..49ea10b8b4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownBigSemigroup.hs @@ -0,0 +1,7 @@ +import Data.Monoid + +data Big a = Big [Bool] (Sum Int) String (Endo a) Any + +instance Semigroup (Big a) where + (<>) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs new file mode 100644 index 0000000000..8bef710c69 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs new file mode 100644 index 0000000000..11e53f4191 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownCounterfactualSemigroup.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UndecidableInstances #-} + +data Semi = Semi [String] Int + +instance Semigroup Int => Semigroup Semi where + (<>) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs new file mode 100644 index 0000000000..179937cb6a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.expected.hs @@ -0,0 +1,5 @@ +data Test a = Test [a] + +instance Semigroup (Test a) where + (Test a) <> (Test c) = Test (a <> c) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs new file mode 100644 index 0000000000..ed4182c6d9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownDestructedSemigroup.hs @@ -0,0 +1,5 @@ +data Test a = Test [a] + +instance Semigroup (Test a) where + Test a <> Test c = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs new file mode 100644 index 0000000000..f64222977b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs new file mode 100644 index 0000000000..7c6bfc5ccd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingMonoid.hs @@ -0,0 +1,8 @@ +data Mono a = Monoid [String] a + +instance Semigroup (Mono a) where + (<>) = undefined + +instance Monoid (Mono a) where + mempty = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs new file mode 100644 index 0000000000..3f18919e80 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.expected.hs @@ -0,0 +1,5 @@ +data Semi = Semi [String] Int + +instance Semigroup Semi where + (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs new file mode 100644 index 0000000000..1193c14a3b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMissingSemigroup.hs @@ -0,0 +1,5 @@ +data Semi = Semi [String] Int + +instance Semigroup Semi where + (<>) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs new file mode 100644 index 0000000000..627217b285 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs new file mode 100644 index 0000000000..8a03a029af --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownModuleInstanceSemigroup.hs @@ -0,0 +1,11 @@ +data Foo = Foo + +instance Semigroup Foo where + (<>) _ _ = Foo + + +data Bar = Bar Foo Foo + +instance Semigroup Bar where + (<>) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs new file mode 100644 index 0000000000..6ad1e2bf92 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.expected.hs @@ -0,0 +1,8 @@ +data Mono = Monoid [String] + +instance Semigroup Mono where + (<>) = undefined + +instance Monoid Mono where + mempty = Monoid mempty + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs new file mode 100644 index 0000000000..0667bee28c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownMonoid.hs @@ -0,0 +1,8 @@ +data Mono = Monoid [String] + +instance Semigroup Mono where + (<>) = undefined + +instance Monoid Mono where + mempty = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs new file mode 100644 index 0000000000..317f2e770b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs new file mode 100644 index 0000000000..8ba7bc6d98 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownPolyMonoid.hs @@ -0,0 +1,8 @@ +data Mono a = Monoid [String] a + +instance Semigroup (Mono a) where + (<>) = undefined + +instance Monoid a => Monoid (Mono a) where + mempty = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs new file mode 100644 index 0000000000..3711af103a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.expected.hs @@ -0,0 +1,5 @@ +data Semi a = Semi a + +instance Semigroup a => Semigroup (Semi a) where + (Semi a) <> (Semi a') = Semi (a <> a') + diff --git a/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs new file mode 100644 index 0000000000..f5e38276fe --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/KnownThetaSemigroup.hs @@ -0,0 +1,5 @@ +data Semi a = Semi a + +instance Semigroup a => Semigroup (Semi a) where + (<>) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs new file mode 100644 index 0000000000..c65b7d07d0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.expected.hs @@ -0,0 +1,8 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + case b of + False -> _w0 + True -> _w1 + pure () + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs new file mode 100644 index 0000000000..4598f0eba1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutBind.hs @@ -0,0 +1,6 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + _ + pure () + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs new file mode 100644 index 0000000000..32e08c94a8 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.expected.hs @@ -0,0 +1,5 @@ +test :: Bool -> Bool +test b = id $ (case b of + False -> _w0 + True -> _w1) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs new file mode 100644 index 0000000000..83a3e4785b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutDollarApp.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test b = id $ _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs new file mode 100644 index 0000000000..b4d3ee6a0e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs new file mode 100644 index 0000000000..60d198e5da --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutInfixKeep.hs @@ -0,0 +1,4 @@ +-- keep layout that was written by the user in infix +foo :: Bool -> a -> a +b `foo` a = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs new file mode 100644 index 0000000000..d8b34c8939 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.expected.hs @@ -0,0 +1,5 @@ +test :: Bool -> Bool +test = \b -> case b of + False -> _w0 + True -> _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs new file mode 100644 index 0000000000..3fead2a25d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutLam.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test = \b -> _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs new file mode 100644 index 0000000000..e8bc6ccc87 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.expected.hs @@ -0,0 +1,4 @@ +test :: Bool -> Bool +test b = True && (case b of + False -> _w0 + True -> _w1) diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs new file mode 100644 index 0000000000..a4c05b7539 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutOpApp.hs @@ -0,0 +1,2 @@ +test :: Bool -> Bool +test b = True && _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs new file mode 100644 index 0000000000..bffe1b6852 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.expected.hs @@ -0,0 +1,4 @@ +(-/) :: Bool -> a -> a +(-/) False a = _w0 +(-/) True a = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs new file mode 100644 index 0000000000..bfe7bdafb3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutPrefixKeep.hs @@ -0,0 +1,3 @@ +(-/) :: Bool -> a -> a +(-/) b a = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs new file mode 100644 index 0000000000..ef639a9839 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.expected.hs @@ -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} + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs new file mode 100644 index 0000000000..47a9895c2e --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutRec.hs @@ -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 = _} + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs new file mode 100644 index 0000000000..9bcb21c9e7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.expected.hs @@ -0,0 +1,5 @@ +class Test a where + test :: Bool -> a + test False = _w0 + test True = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs new file mode 100644 index 0000000000..c082169c7b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitClass.hs @@ -0,0 +1,4 @@ +class Test a where + test :: Bool -> a + test x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs new file mode 100644 index 0000000000..6b73dfb0ec --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.expected.hs @@ -0,0 +1,5 @@ +test :: Bool -> Bool -> Bool +test a b + | a = case b of + False -> _w0 + True -> _w1 diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs new file mode 100644 index 0000000000..be2d0d30f5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitGuard.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool -> Bool +test a b + | a = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs new file mode 100644 index 0000000000..8095217673 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.expected.hs @@ -0,0 +1,5 @@ +test :: a +test = + let a = (1,"bbb") + in case a of { (n, s) -> _w0 } + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs new file mode 100644 index 0000000000..ce6e0341c4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitIn.hs @@ -0,0 +1,5 @@ +test :: a +test = + let a = (1,"bbb") + in _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs new file mode 100644 index 0000000000..ba63836df3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.expected.hs @@ -0,0 +1,7 @@ +test :: a +test = + let t :: Bool -> a + t False = _w0 + t True = _w1 + in _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs new file mode 100644 index 0000000000..71529d7dd3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitLet.hs @@ -0,0 +1,6 @@ +test :: a +test = + let t :: Bool -> a + t b = _ + in _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs new file mode 100644 index 0000000000..0f7ee4e388 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.expected.hs @@ -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 + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs new file mode 100644 index 0000000000..0497bb7244 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPatSyn.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern JustSingleton :: a -> Maybe [a] +pattern JustSingleton a <- Just [a] + + +test :: Maybe [Bool] -> Maybe Bool +test (JustSingleton a) = _ + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs new file mode 100644 index 0000000000..b92544f622 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs new file mode 100644 index 0000000000..3cabb3c64b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitPattern.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} + +pattern Blah :: a -> Maybe a +pattern Blah a = Just a + +test :: Maybe Bool -> a +test (Blah a) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs new file mode 100644 index 0000000000..d123c652d7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ViewPatterns #-} + +splitLookup :: [(Int, String)] -> String +splitLookup (lookup 5 -> Nothing) = _w0 +splitLookup (lookup 5 -> (Just s)) = _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs new file mode 100644 index 0000000000..6baed55abd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitViewPat.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + +splitLookup :: [(Int, String)] -> String +splitLookup (lookup 5 -> a) = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs new file mode 100644 index 0000000000..28ad669007 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs new file mode 100644 index 0000000000..5035df1b0c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/LayoutSplitWhere.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs new file mode 100644 index 0000000000..713f686338 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MessageCantUnify.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE DataKinds, GADTs #-} + +data Z ab where + Z :: (a -> b) -> Z '(a, b) + +test :: Z ab +test = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs new file mode 100644 index 0000000000..1498dfd8e4 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MessageForallA.hs @@ -0,0 +1,2 @@ +test :: a +test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs b/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs new file mode 100644 index 0000000000..9156cc0053 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MessageNotEnoughGas.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs new file mode 100644 index 0000000000..3c56bdbee9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.expected.hs @@ -0,0 +1 @@ +foo = [wingman||] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs new file mode 100644 index 0000000000..fdfbd7289d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBegin.hs @@ -0,0 +1 @@ +foo = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs new file mode 100644 index 0000000000..c8aa76e837 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.expected.hs @@ -0,0 +1,2 @@ +foo v = [wingman||] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs new file mode 100644 index 0000000000..2aa2d1caa3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBeginNoWildify.hs @@ -0,0 +1,2 @@ +foo v = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs new file mode 100644 index 0000000000..00421ee479 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs new file mode 100644 index 0000000000..d25670bca1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBindAll.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split; assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs new file mode 100644 index 0000000000..05f86c9963 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, _w0) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs new file mode 100644 index 0000000000..fe6c118829 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaBindOne.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split, assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs new file mode 100644 index 0000000000..aac10101ec --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs new file mode 100644 index 0000000000..26e3a03cec --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataAST.hs @@ -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 |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs new file mode 100644 index 0000000000..58b4fb4ffc --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs new file mode 100644 index 0000000000..14dc163f4d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapse.hs @@ -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 |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs new file mode 100644 index 0000000000..e9cef291a3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs new file mode 100644 index 0000000000..c1abb0acf2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaCataCollapseUnary.hs @@ -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 |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs new file mode 100644 index 0000000000..c9d2f0cff9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.expected.hs @@ -0,0 +1,2 @@ +reassoc :: (a, (b, c)) -> ((a, b), c) +reassoc (a, (b, c)) = ((a, b), c) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs new file mode 100644 index 0000000000..97e5b424ba --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaChoice.hs @@ -0,0 +1,2 @@ +reassoc :: (a, (b, c)) -> ((a, b), c) +reassoc (a, (b, c)) = [wingman| split; split | assume c; assume a | assume b |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs new file mode 100644 index 0000000000..90216da0a2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.expected.hs @@ -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)))) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs new file mode 100644 index 0000000000..3afcdcc4e1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaDeepOf.hs @@ -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 |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs new file mode 100644 index 0000000000..f589d989f7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.expected.hs @@ -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 + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs new file mode 100644 index 0000000000..36d0d4bf73 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaFundeps.hs @@ -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 |] + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs new file mode 100644 index 0000000000..21569c7c19 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.expected.hs @@ -0,0 +1,6 @@ +foo :: Int -> Int -> Int +foo = undefined + +test :: Maybe Int +test = (foo <$> _w0) <*> _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs new file mode 100644 index 0000000000..f9506cb03b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiom.hs @@ -0,0 +1,6 @@ +foo :: Int -> Int -> Int +foo = undefined + +test :: Maybe Int +test = [wingman| idiom (use foo) |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs new file mode 100644 index 0000000000..e39e9a9fab --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.expected.hs @@ -0,0 +1,8 @@ +data Rec = Rec + { a :: Int + , b :: Bool + } + +test :: Maybe Rec +test = (Rec <$> _w0) <*> _w1 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs new file mode 100644 index 0000000000..87397da160 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaIdiomRecord.hs @@ -0,0 +1,8 @@ +data Rec = Rec + { a :: Int + , b :: Bool + } + +test :: Maybe Rec +test = [wingman| idiom (ctor Rec) |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs new file mode 100644 index 0000000000..54c3678c21 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.expected.hs @@ -0,0 +1,7 @@ +test :: Int +test + = let + a = _w0 + b = _w1 + c = _w2 + in _w3 diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs new file mode 100644 index 0000000000..ae570bae7b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaLetSimple.hs @@ -0,0 +1,2 @@ +test :: Int +test = [wingman| let a b c |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs new file mode 100644 index 0000000000..e0b60b74fa --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.expected.hs @@ -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) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs new file mode 100644 index 0000000000..6159db4ecd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaMaybeAp.hs @@ -0,0 +1,11 @@ +maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b +maybeAp = [wingman| + intros, + destruct_all, + obvious, + obvious, + obvious, + ctor Just, + application, + assumption + |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs new file mode 100644 index 0000000000..f92e7d40af --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.expected.hs @@ -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) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs new file mode 100644 index 0000000000..77572569ff --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaPointwise.hs @@ -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|] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs new file mode 100644 index 0000000000..0940f9ea21 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = (_w0, a) diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs new file mode 100644 index 0000000000..582189bcbc --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaTry.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = [wingman| split; try (assumption) |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs new file mode 100644 index 0000000000..c72f18589c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.expected.hs @@ -0,0 +1,6 @@ +import Data.Char + + +result :: Char -> Bool +result = isAlpha + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs new file mode 100644 index 0000000000..87ac26bbcb --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseImport.hs @@ -0,0 +1,6 @@ +import Data.Char + + +result :: Char -> Bool +result = [wingman| intro c, use isAlpha, assume c |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs new file mode 100644 index 0000000000..1afee3471a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.expected.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = test + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs new file mode 100644 index 0000000000..0f791818d1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseLocal.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = [wingman| use test |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs new file mode 100644 index 0000000000..acf46a75a0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.expected.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +class Test where + test :: Int + +instance Test where + test = 10 + + +resolve :: Int +resolve = test + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs new file mode 100644 index 0000000000..4723befd10 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseMethod.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +class Test where + test :: Int + +instance Test where + test = 10 + + +resolve :: Int +resolve = [wingman| use test |] + diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs new file mode 100644 index 0000000000..85012d7aaf --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.expected.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = _w0 <> _w1 diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs new file mode 100644 index 0000000000..4afe5f572d --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaUseSymbol.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = [wingman| use (<>) |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs new file mode 100644 index 0000000000..895e9333c0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.expected.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = _w0 a diff --git a/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs new file mode 100644 index 0000000000..75c6ab0445 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/MetaWithArg.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = [wingman| with_arg, assumption |] diff --git a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs new file mode 100644 index 0000000000..4bbd4d283a --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.expected.hs @@ -0,0 +1,7 @@ +newtype MyRecord a = Record + { field1 :: a + } + +blah :: (a -> Int) -> a -> MyRecord a +blah _ = Record + diff --git a/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs new file mode 100644 index 0000000000..82b994b936 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/NewtypeRecord.hs @@ -0,0 +1,7 @@ +newtype MyRecord a = Record + { field1 :: a + } + +blah :: (a -> Int) -> a -> MyRecord a +blah = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs b/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs new file mode 100644 index 0000000000..2da53afbf5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/ProvideAlreadyDestructed.hs @@ -0,0 +1,9 @@ +foo :: Bool -> () +foo x = + if True + then + case x of + True -> _ + False -> () + else + _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs b/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs new file mode 100644 index 0000000000..6a15b198dd --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/ProvideLocalHyOnly.hs @@ -0,0 +1,2 @@ +basilisk :: Monoid Bool => a +basilisk = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs b/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs new file mode 100644 index 0000000000..dc096f38f1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/ProviderHomomorphism.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs new file mode 100644 index 0000000000..9bdcd61516 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs new file mode 100644 index 0000000000..250479e758 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunGADT.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE GADTs #-} + +data GADT a where + GADT :: + { blah :: Int + , bar :: a + } -> GADT a + + +split :: GADT a -> a +split x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs new file mode 100644 index 0000000000..7b661c2ee5 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunMany.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs b/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs new file mode 100644 index 0000000000..77234a7359 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunMany.hs @@ -0,0 +1,7 @@ +data Many + = Hello { world :: String } + | Goodbye { a :: Int, b :: Bool, c :: Many } + +test :: Many -> Many +test x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs new file mode 100644 index 0000000000..5b3eaf2559 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs new file mode 100644 index 0000000000..70badb7ae2 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunManyGADT.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs new file mode 100644 index 0000000000..d3cc689a04 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.expected.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: () -> Bar -> Int +bar ax Bar {ax = n, bax} = _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs new file mode 100644 index 0000000000..f2cce07cbc --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunShadowing.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: () -> Bar -> Int +bar ax x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs new file mode 100644 index 0000000000..65bc2d28d0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.expected.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: Bar -> Int +bar Bar {ax, bax} = _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs new file mode 100644 index 0000000000..6707399c28 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/PunSimple.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: Bar -> Int +bar x = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs new file mode 100644 index 0000000000..cfc2235bfb --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.expected.hs @@ -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} + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs new file mode 100644 index 0000000000..651983e8a3 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RecordCon.hs @@ -0,0 +1,9 @@ +data MyRecord a = Record + { field1 :: a + , field2 :: Int + } + +blah :: (a -> Int) -> a -> MyRecord a +blah = _ + + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs new file mode 100644 index 0000000000..7110f637da --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.expected.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = (_w0, _w1, _w2) + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs new file mode 100644 index 0000000000..dc611f6e93 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineCon.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs new file mode 100644 index 0000000000..605f5e0a5c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.expected.hs @@ -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 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs new file mode 100644 index 0000000000..6ac2853173 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineGADT.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTs #-} + +data GADT a where + One :: (b -> Int) -> GADT Int + Two :: GADT Bool + +test :: z -> GADT Int +test z = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs new file mode 100644 index 0000000000..5c99dfc3a1 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.expected.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test a = _w0 diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs new file mode 100644 index 0000000000..afe7524957 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineIntro.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs new file mode 100644 index 0000000000..2d72de4c9b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.expected.hs @@ -0,0 +1,6 @@ +test :: Maybe Int -> Int +test = \ m_n -> _w0 + where + -- Don't delete me! + blah = undefined + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs new file mode 100644 index 0000000000..a9e4ca1db7 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineIntroWhere.hs @@ -0,0 +1,6 @@ +test :: Maybe Int -> Int +test = _ + where + -- Don't delete me! + blah = undefined + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs new file mode 100644 index 0000000000..267e6b8015 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.expected.hs @@ -0,0 +1,5 @@ +newtype Reader r a = Reader (r -> a) + +test :: b -> Reader r a +test b = Reader _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs new file mode 100644 index 0000000000..9e68e115e9 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/RefineReader.hs @@ -0,0 +1,5 @@ +newtype Reader r a = Reader (r -> a) + +test :: b -> Reader r a +test b = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs new file mode 100644 index 0000000000..c76acc0d31 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.expected.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs new file mode 100644 index 0000000000..ba66257007 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/SplitPattern.hs @@ -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 = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs new file mode 100644 index 0000000000..e638fa311c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.expected.hs @@ -0,0 +1,5 @@ +data Dummy a = Dummy a + +f :: Dummy Int -> Int +f (Dummy n) = n + diff --git a/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs new file mode 100644 index 0000000000..7487adf038 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/SubsequentTactics.hs @@ -0,0 +1,5 @@ +data Dummy a = Dummy a + +f :: Dummy Int -> Int +f = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/T1.hs b/plugins/hls-tactics-plugin/new/test/golden/T1.hs new file mode 100644 index 0000000000..7ab382d69f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/T1.hs @@ -0,0 +1,3 @@ +fmapEither :: (a -> b) -> Either c a -> Either c b +fmapEither = _lalala + diff --git a/plugins/hls-tactics-plugin/new/test/golden/T2.hs b/plugins/hls-tactics-plugin/new/test/golden/T2.hs new file mode 100644 index 0000000000..20b1644a8f --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/T2.hs @@ -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 = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/T3.hs b/plugins/hls-tactics-plugin/new/test/golden/T3.hs new file mode 100644 index 0000000000..1bb42a9b02 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/T3.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE LambdaCase #-} + +suggestHomomorphicLC :: Either a b -> Either a b +suggestHomomorphicLC = _ + +suggestLC :: Either a b -> Int +suggestLC = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs new file mode 100644 index 0000000000..26d6d77b8b --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Left _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs new file mode 100644 index 0000000000..59d03ae7d0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConLeft.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs new file mode 100644 index 0000000000..1a5caad890 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.expected.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = (_w0, _w1) diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs new file mode 100644 index 0000000000..2d15fe3500 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConPair.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = _ diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs new file mode 100644 index 0000000000..f36809804c --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Right _w0 + diff --git a/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs new file mode 100644 index 0000000000..59d03ae7d0 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/UseConRight.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/plugins/hls-tactics-plugin/new/test/golden/hie.yaml b/plugins/hls-tactics-plugin/new/test/golden/hie.yaml new file mode 100644 index 0000000000..7aa4f9e0ad --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/plugins/hls-tactics-plugin/new/test/golden/test.cabal b/plugins/hls-tactics-plugin/new/test/golden/test.cabal new file mode 100644 index 0000000000..845edafa26 --- /dev/null +++ b/plugins/hls-tactics-plugin/new/test/golden/test.cabal @@ -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