diff --git a/hls-tactics-plugin.cabal b/hls-tactics-plugin.cabal --- a/hls-tactics-plugin.cabal +++ b/hls-tactics-plugin.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 category: Development name: hls-tactics-plugin -version: 1.7.0.0 +version: 1.8.0.0 synopsis: Wingman plugin for Haskell Language Server description: Please see the README on GitHub at @@ -15,21 +15,34 @@ build-type: Simple extra-source-files: README.md - test/golden/*.cabal - test/golden/*.hs - test/golden/*.yaml + new/src/**/*.hs-boot + old/src/**/*.hs-boot + new/test/golden/*.cabal + new/test/golden/*.hs + new/test/golden/*.yaml + old/test/golden/*.cabal + old/test/golden/*.hs + old/test/golden/*.yaml +source-repository head + type: git + location: https://github.com/haskell/haskell-language-server.git + flag pedantic description: Enable -Werror default: False manual: True library - if impl(ghc >= 9.3) + if impl(ghc >= 9.2.1) buildable: False else buildable: True - hs-source-dirs: src + + if impl(ghc >= 9.2.1) + hs-source-dirs: new/src + else + hs-source-dirs: old/src exposed-modules: Ide.Plugin.Tactic Refinery.Future @@ -86,9 +99,9 @@ , ghc-boot-th , ghc-exactprint , ghc-source-gen ^>=0.4.1 - , ghcide ^>= 1.8 + , ghcide ^>= 1.9 , hls-graph - , hls-plugin-api ^>=1.5 + , hls-plugin-api ^>=1.6 , hls-refactor-plugin , hyphenation , lens @@ -131,7 +144,7 @@ ViewPatterns test-suite tests - if impl(ghc >= 9.3) + if impl(ghc >= 9.2.1) buildable: False else buildable: True @@ -154,7 +167,10 @@ UnificationSpec Utils - hs-source-dirs: test + if impl(ghc >= 9.2.1) + hs-source-dirs: new/test + else + hs-source-dirs: old/test ghc-options: -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N @@ -169,7 +185,7 @@ , ghcide , hls-plugin-api , hls-tactics-plugin - , hls-test-utils ^>=1.4 + , hls-test-utils ^>=1.5 , hspec , hspec-expectations , lens diff --git a/new/src/Ide/Plugin/Tactic.hs b/new/src/Ide/Plugin/Tactic.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Refinery/Future.hs b/new/src/Refinery/Future.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/AbstractLSP.hs b/new/src/Wingman/AbstractLSP.hs new file mode 100644 --- /dev/null +++ b/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 (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) +import Wingman.StaticPlugin (enableQuasiQuotes) +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are +-- self-contained request/response pairs that abstract over the LSP, and +-- provide a unified interface for doing interesting things, without needing to +-- dive into the underlying API too directly. +installInteractions + :: [Interaction] + -> PluginDescriptor IdeState + -> PluginDescriptor IdeState +installInteractions is desc = + let plId = pluginId desc + in desc + { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is + , pluginHandlers = pluginHandlers desc <> buildHandlers is + } + + +------------------------------------------------------------------------------ +-- | Extract 'PluginHandlers' from 'Interaction's. +buildHandlers + :: [Interaction] + -> PluginHandlers IdeState +buildHandlers cs = + flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> + case c_makeCommand c of + SynthesizeCodeAction k -> + mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k + SynthesizeCodeLens k -> + mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k + + +------------------------------------------------------------------------------ +-- | Extract a 'PluginCommand' from an 'Interaction'. +buildCommand + :: PluginId + -> Interaction + -> PluginCommand IdeState +buildCommand plId (Interaction (c :: Continuation sort target b)) = + PluginCommand + { commandId = toCommandId $ c_sort c + , commandDesc = T.pack "" + , commandFunc = runContinuation plId c + } + + +------------------------------------------------------------------------------ +-- | Boilerplate for running a 'Continuation' as part of an LSP command. +runContinuation + :: forall sort a b + . IsTarget a + => PluginId + -> Continuation sort a b + -> CommandFunction IdeState (FileContext, b) +runContinuation plId cont state (fc, b) = do + fromMaybeT + (Left $ ResponseError + { _code = InternalError + , _message = T.pack "TODO(sandy)" + , _xdata = Nothing + } ) $ do + env@LspEnv{..} <- buildEnv state plId fc + nfp <- getNfp $ fc_uri le_fileContext + let stale a = runStaleIde "runContinuation" state nfp a + args <- fetchTargetArgs @a env + res <- c_runCommand cont env args fc b + + -- This block returns a maybe error. + fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $ + for res $ \case + ErrorMessages errs -> do + traverse_ showUserFacingMessage errs + pure Nothing + RawEdit edits -> do + sendEdits edits + pure Nothing + GraftEdit gr -> do + ccs <- lift getClientCapabilities + TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource + case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of + Left errs -> + pure $ Just $ ResponseError + { _code = InternalError + , _message = T.pack $ show errs + , _xdata = Nothing + } + Right edits -> do + sendEdits edits + pure Nothing + + +------------------------------------------------------------------------------ +-- | Push a 'WorkspaceEdit' to the client. +sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () +sendEdits edits = + void $ lift $ + sendRequest + SWorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing edits) + (const $ pure ()) + + +------------------------------------------------------------------------------ +-- | Push a 'UserFacingMessage' to the client. +showUserFacingMessage + :: UserFacingMessage + -> MaybeT (LspM Plugin.Config) () +showUserFacingMessage ufm = + void $ lift $ showLspMessage $ mkShowMessageParams ufm + + +------------------------------------------------------------------------------ +-- | Build an 'LspEnv', which contains the majority of things we need to know +-- in a 'Continuation'. +buildEnv + :: IdeState + -> PluginId + -> FileContext + -> MaybeT (LspM Plugin.Config) LspEnv +buildEnv state plId fc = do + cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId + nfp <- getNfp $ fc_uri fc + dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp + pure $ LspEnv + { le_ideState = state + , le_pluginId = plId + , le_dflags = dflags + , le_config = cfg + , le_fileContext = fc + } + + +------------------------------------------------------------------------------ +-- | Lift a 'Continuation' into an LSP CodeAction. +codeActionProvider + :: forall target sort b + . (IsContinuationSort sort, A.ToJSON b, IsTarget target) + => sort + -> ( LspEnv + -> TargetArgs target + -> MaybeT (LspM Plugin.Config) [(Metadata, b)] + ) + -> PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider sort k state plId + (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do + fromMaybeT (Right $ List []) $ do + let fc = FileContext + { fc_uri = uri + , fc_range = Just $ unsafeMkCurrent range + } + env <- buildEnv state plId fc + args <- fetchTargetArgs @target env + actions <- k env args + pure + $ Right + $ List + $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions + + +------------------------------------------------------------------------------ +-- | Lift a 'Continuation' into an LSP CodeLens. +codeLensProvider + :: forall target sort b + . (IsContinuationSort sort, A.ToJSON b, IsTarget target) + => sort + -> ( LspEnv + -> TargetArgs target + -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] + ) + -> PluginMethodHandler IdeState TextDocumentCodeLens +codeLensProvider sort k state plId + (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do + fromMaybeT (Right $ List []) $ do + let fc = FileContext + { fc_uri = uri + , fc_range = Nothing + } + env <- buildEnv state plId fc + args <- fetchTargetArgs @target env + actions <- k env args + pure + $ Right + $ List + $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions + + +------------------------------------------------------------------------------ +-- | Build a 'LSP.CodeAction'. +makeCodeAction + :: (A.ToJSON b, IsContinuationSort sort) + => PluginId + -> FileContext + -> sort + -> Metadata + -> b + -> LSP.CodeAction +makeCodeAction plId fc sort (Metadata title kind preferred) b = + let cmd_id = toCommandId sort + cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)] + in LSP.CodeAction + { _title = title + , _kind = Just kind + , _diagnostics = Nothing + , _isPreferred = Just preferred + , _disabled = Nothing + , _edit = Nothing + , _command = Just cmd + , _xdata = Nothing + } + + +------------------------------------------------------------------------------ +-- | Build a 'LSP.CodeLens'. +makeCodeLens + :: (A.ToJSON b, IsContinuationSort sort) + => PluginId + -> sort + -> FileContext + -> Range + -> Metadata + -> b + -> LSP.CodeLens +makeCodeLens plId sort fc range (Metadata title _ _) b = + let fc' = fc { fc_range = Just $ unsafeMkCurrent range } + cmd_id = toCommandId sort + cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)] + in LSP.CodeLens + { _range = range + , _command = Just cmd + , _xdata = Nothing + } + diff --git a/new/src/Wingman/AbstractLSP/TacticActions.hs b/new/src/Wingman/AbstractLSP/TacticActions.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/AbstractLSP/Types.hs b/new/src/Wingman/AbstractLSP/Types.hs new file mode 100644 --- /dev/null +++ b/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 hiding (Config) +import Language.LSP.Server (LspM) +import Language.LSP.Types hiding (CodeLens, CodeAction) +import Wingman.LanguageServer (judgementForHole) +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | An 'Interaction' is an existential 'Continuation', which handles both +-- sides of the request/response interaction for LSP. +data Interaction where + Interaction + :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b) + => Continuation sort target b + -> Interaction + + +------------------------------------------------------------------------------ +-- | Metadata for a command. Used by both code actions and lenses, though for +-- lenses, only 'md_title' is currently used. +data Metadata + = Metadata + { md_title :: Text + , md_kind :: CodeActionKind + , md_preferred :: Bool + } + deriving stock (Eq, Show) + + +------------------------------------------------------------------------------ +-- | Whether we're defining a CodeAction or CodeLens. +data SynthesizeCommand a b + = SynthesizeCodeAction + ( LspEnv + -> TargetArgs a + -> MaybeT (LspM Plugin.Config) [(Metadata, b)] + ) + | SynthesizeCodeLens + ( LspEnv + -> TargetArgs a + -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] + ) + + +------------------------------------------------------------------------------ +-- | Transform a "continuation sort" into a 'CommandId'. +class IsContinuationSort a where + toCommandId :: a -> CommandId + +instance IsContinuationSort CommandId where + toCommandId = id + +instance IsContinuationSort Text where + toCommandId = CommandId + + +------------------------------------------------------------------------------ +-- | Ways a 'Continuation' can resolve. +data ContinuationResult + = -- | Produce some error messages. + ErrorMessages [UserFacingMessage] + -- | Produce an explicit 'WorkspaceEdit'. + | RawEdit WorkspaceEdit + -- | Produce a 'Graft', corresponding to a transformation of the current + -- AST. + | GraftEdit (Graft (Either String) ParsedSource) + + +------------------------------------------------------------------------------ +-- | A 'Continuation' is a single object corresponding to an action that users +-- can take via LSP. It generalizes codeactions and codelenses, allowing for +-- a significant amount of code reuse. +-- +-- Given @Continuation sort target payload@: +-- +-- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions +-- rather than working directly with text. This functionality is driven via +-- 'IsContinuationSort'. +-- +-- the @target@ is used to fetch data from LSP on both sides of the +-- request/response barrier. For example, you can use it to resolve what node +-- in the AST the incoming range refers to. This functionality is driven via +-- 'IsTarget'. +-- +-- the @payload@ is used for data you'd explicitly like to send from the +-- request to the response. It's like @target@, but only gets computed once. +-- This is beneficial if you can do it, but requires that your data is +-- serializable via JSON. +data Continuation sort target payload = Continuation + { c_sort :: sort + , c_makeCommand :: SynthesizeCommand target payload + , c_runCommand + :: LspEnv + -> TargetArgs target + -> FileContext + -> payload + -> MaybeT (LspM Plugin.Config) [ContinuationResult] + } + + +------------------------------------------------------------------------------ +-- | What file are we looking at, and what bit of it? +data FileContext = FileContext + { fc_uri :: Uri + , fc_range :: Maybe (Tracked 'Current Range) + -- ^ For code actions, this is 'Just'. For code lenses, you'll get + -- a 'Nothing' in the request, and a 'Just' in the response. + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (A.ToJSON, A.FromJSON) + + +------------------------------------------------------------------------------ +-- | Everything we need to resolve continuations. +data LspEnv = LspEnv + { le_ideState :: IdeState + , le_pluginId :: PluginId + , le_dflags :: DynFlags + , le_config :: Config + , le_fileContext :: FileContext + } + + +------------------------------------------------------------------------------ +-- | Extract some information from LSP, so it can be passed to the requests and +-- responses of a 'Continuation'. +class IsTarget t where + type TargetArgs t + fetchTargetArgs + :: LspEnv + -> MaybeT (LspM Plugin.Config) (TargetArgs t) + +------------------------------------------------------------------------------ +-- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given +-- range is an HsExpr hole. It gives continuations access to the resulting +-- tactic judgement. +data HoleTarget = HoleTarget + deriving stock (Eq, Ord, Show, Enum, Bounded) + +getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath +getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri + +instance IsTarget HoleTarget where + type TargetArgs HoleTarget = HoleJudgment + fetchTargetArgs LspEnv{..} = do + let FileContext{..} = le_fileContext + range <- MaybeT $ pure fc_range + nfp <- getNfp fc_uri + mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config + diff --git a/new/src/Wingman/Auto.hs b/new/src/Wingman/Auto.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/CaseSplit.hs b/new/src/Wingman/CaseSplit.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/CodeGen.hs b/new/src/Wingman/CodeGen.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/CodeGen/Utils.hs b/new/src/Wingman/CodeGen/Utils.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Context.hs b/new/src/Wingman/Context.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Debug.hs b/new/src/Wingman/Debug.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/EmptyCase.hs b/new/src/Wingman/EmptyCase.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/GHC.hs b/new/src/Wingman/GHC.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Judgements.hs b/new/src/Wingman/Judgements.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Judgements/SYB.hs b/new/src/Wingman/Judgements/SYB.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Judgements/Theta.hs b/new/src/Wingman/Judgements/Theta.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/KnownStrategies.hs b/new/src/Wingman/KnownStrategies.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/KnownStrategies/QuickCheck.hs b/new/src/Wingman/KnownStrategies/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/LanguageServer.hs b/new/src/Wingman/LanguageServer.hs new file mode 100644 --- /dev/null +++ b/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 +getTacticConfigAction :: PluginId -> Action Config +getTacticConfigAction pId = + Config + <$> usePropertyAction #max_use_ctor_actions pId properties + <*> usePropertyAction #timeout_duration pId properties + <*> usePropertyAction #auto_gas pId properties + <*> usePropertyAction #proofstate_styling pId properties + + +getIdeDynflags + :: IdeState + -> NormalizedFilePath + -> MaybeT IO DynFlags +getIdeDynflags state nfp = do + -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' + -- which don't change very often. + msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps + pure $ ms_hspp_opts $ msrModSummary msr + +getAllMetaprograms :: Data a => a -> [String] +getAllMetaprograms = everything (<>) $ mkQ mempty $ \case + WingmanMetaprogram fs -> [ FastString.unpackFS fs ] + (_ :: HsExpr GhcTc) -> mempty + + +------------------------------------------------------------------------------ +-- | Find the last typechecked module, and find the most specific span, as well +-- as the judgement at the given range. +judgementForHole + :: IdeState + -> NormalizedFilePath + -> Tracked 'Current Range + -> Config + -> MaybeT IO HoleJudgment +judgementForHole state nfp range cfg = do + let stale a = runStaleIde "judgementForHole" state nfp a + + TrackedStale asts amapping <- stale GetHieAst + case unTrack asts of + HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" + HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do + range' <- liftMaybe $ mapAgeFrom amapping range + binds <- stale GetBindings + tcg@(TrackedStale tcg_t tcg_map) + <- fmap (fmap tmrTypechecked) + $ stale TypeCheck + + hscenv <- stale GhcSessionDeps + + (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf + + new_rss <- liftMaybe $ mapAgeTo amapping rss + tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss + + -- KnownThings is just the instances in scope. There are no ranges + -- involved, so it's not crucial to track ages. + let henv = untrackedStaleValue hscenv + eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv + + (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps + let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t + + dflags <- getIdeDynflags state nfp + pure $ HoleJudgment + { hj_range = fmap realSrcSpanToRange new_rss + , hj_jdg = jdg + , hj_ctx = ctx + , hj_dflags = dflags + , hj_hole_sort = holeSortFor mp + } + + +holeSortFor :: Maybe T.Text -> HoleSort +holeSortFor = maybe Hole Metaprogram + + +mkJudgementAndContext + :: Config + -> Type + -> TrackedStale Bindings + -> Tracked 'Current RealSrcSpan + -> TrackedStale TcGblEnv + -> HscEnv + -> ExternalPackageState + -> Maybe (Judgement, Context) +mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do + binds_rss <- mapAgeFrom bmap rss + tcg_rss <- mapAgeFrom tcgmap rss + + let tcs = fmap tcg_binds tcg + ctx = mkContext cfg + (mapMaybe (sequenceA . (occName *** coerce)) + $ unTrack + $ getDefiningBindings <$> binds <*> binds_rss) + (unTrack tcg) + hscenv + eps + evidence + top_provs = getRhsPosVals tcg_rss tcs + already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs + local_hy = spliceProvenance top_provs + $ hypothesisFromBindings binds_rss binds + evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs + cls_hy = foldMap evidenceToHypothesis evidence + subst = ts_unifier $ evidenceToSubst evidence defaultTacticState + pure + ( disallowing AlreadyDestructed already_destructed + $ fmap (CType . substTyAddInScope subst . unCType) $ + mkFirstJudgement + ctx + (local_hy <> cls_hy) + (isRhsHoleWithoutWhere tcg_rss tcs) + g + , ctx + ) + + +------------------------------------------------------------------------------ +-- | Determine which bindings have already been destructed by the location of +-- the hole. +getAlreadyDestructed + :: Tracked age SrcSpan + -> Tracked age (LHsBinds GhcTc) + -> Set OccName +getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = + everythingContaining span + (mkQ mempty $ \case + Case (HsVar _ (L _ (occName -> var))) _ -> + S.singleton var + (_ :: HsExpr GhcTc) -> mempty + ) binds + + +getSpanAndTypeAtHole + :: Tracked age Range + -> Tracked age (HieASTs Type) + -> Maybe (Tracked age RealSrcSpan, Type) +getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do + join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of + Nothing -> Nothing + Just ast' -> do + let info = nodeInfo ast' + ty <- listToMaybe $ nodeType info + guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info + -- Ensure we're actually looking at a hole here + occ <- (either (const Nothing) (Just . occName) =<<) + . listToMaybe + . S.toList + . M.keysSet + $ nodeIdentifiers info + guard $ isHole occ + pure (unsafeCopyAge r $ nodeSpan ast', ty) + + + +------------------------------------------------------------------------------ +-- | Combine two (possibly-overlapping) hypotheses; using the provenance from +-- the first hypothesis if the bindings overlap. +spliceProvenance + :: Hypothesis a -- ^ Bindings to keep + -> Hypothesis a -- ^ Bindings to keep if they don't overlap with the first set + -> Hypothesis a +spliceProvenance top x = + let bound = S.fromList $ fmap hi_name $ unHypothesis top + in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x + + +------------------------------------------------------------------------------ +-- | Compute top-level position vals of a function +getRhsPosVals + :: Tracked age RealSrcSpan + -> Tracked age TypecheckedSource + -> Hypothesis CType +getRhsPosVals (unTrack -> rss) (unTrack -> tcs) + = everything (<>) (mkQ mempty $ \case + TopLevelRHS name ps + (L (RealSrcSpan span _) -- body with no guards and a single defn + (HsVar _ (L _ hole))) + _ + | containsSpan rss span -- which contains our span + , isHole $ occName hole -- and the span is a hole + -> flip evalState 0 $ buildTopLevelHypothesis name ps + _ -> mempty + ) tcs + + +------------------------------------------------------------------------------ +-- | Construct a hypothesis given the patterns from the left side of a HsMatch. +-- These correspond to things that the user put in scope before running +-- tactics. +buildTopLevelHypothesis + :: OccName -- ^ Function name + -> [PatCompat GhcTc] + -> State Int (Hypothesis CType) +buildTopLevelHypothesis name ps = do + fmap mconcat $ + for (zip [0..] ps) $ \(ix, p) -> + buildPatHy (TopLevelArgPrv name ix $ length ps) p + + +------------------------------------------------------------------------------ +-- | Construct a hypothesis for a single pattern, including building +-- sub-hypotheses for constructor pattern matches. +buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType) +buildPatHy prov (fromPatCompat -> p0) = + case p0 of + VarPat _ x -> pure $ mkIdHypothesis (unLoc x) prov + LazyPat _ p -> buildPatHy prov p + AsPat _ x p -> do + hy' <- buildPatHy prov p + pure $ mkIdHypothesis (unLoc x) prov <> hy' + ParPat _ p -> buildPatHy prov p + BangPat _ p -> buildPatHy prov p + ViewPat _ _ p -> buildPatHy prov p + -- Desugar lists into cons + ListPat _ [] -> pure mempty + ListPat x@(ListPatTc ty _) (p : ps) -> + mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] + [ (0, p) + , (1, toPatCompat $ ListPat x ps) + ] + -- Desugar tuples into an explicit constructor + TuplePat tys pats boxity -> + mkDerivedConHypothesis + prov + (RealDataCon $ tupleDataCon boxity $ length pats) + tys + $ zip [0.. ] pats +#if __GLASGOW_HASKELL__ >= 900 + ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} -> +#else + ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} -> +#endif + case f of + PrefixCon l_pgt -> + mkDerivedConHypothesis prov con args $ zip [0..] l_pgt + InfixCon pgt pgt5 -> + mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] + RecCon r -> + mkDerivedRecordHypothesis prov con args r + SigPat _ p _ -> buildPatHy prov p + _ -> pure mempty + + +------------------------------------------------------------------------------ +-- | Like 'mkDerivedConHypothesis', but for record patterns. +mkDerivedRecordHypothesis + :: Provenance + -> ConLike -- ^ Destructing constructor + -> [Type] -- ^ Applied type variables + -> HsRecFields GhcTc (PatCompat GhcTc) + -> State Int (Hypothesis CType) +mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _) + | Just rec_fields <- getRecordFields dc + = do + let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..] + mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) -> + ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ) + , p + ) +mkDerivedRecordHypothesis _ _ _ _ = + error "impossible! using record pattern on something that isn't a record" + + +------------------------------------------------------------------------------ +-- | Construct a fake variable name. Used to track the provenance of top-level +-- pattern matches which otherwise wouldn't have anything to attach their +-- 'TopLevelArgPrv' to. +mkFakeVar :: State Int OccName +mkFakeVar = do + i <- get + put $ i + 1 + pure $ mkVarOcc $ "_" <> show i + + +------------------------------------------------------------------------------ +-- | Construct a fake variable to attach the current 'Provenance' to, and then +-- build a sub-hypothesis for the pattern match. +mkDerivedConHypothesis + :: Provenance + -> ConLike -- ^ Destructing constructor + -> [Type] -- ^ Applied type variables + -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con + -> State Int (Hypothesis CType) +mkDerivedConHypothesis prov dc args ps = do + var <- mkFakeVar + hy' <- fmap mconcat $ + for ps $ \(ix, p) -> do + let prov' = PatternMatchPrv + $ PatVal (Just var) + (S.singleton var <> provAncestryOf prov) + (Uniquely dc) + ix + buildPatHy prov' p + pure + $ mappend hy' + $ Hypothesis + $ pure + $ HyInfo var (DisallowedPrv AlreadyDestructed prov) + $ CType + -- TODO(sandy): This is the completely wrong type, but we don't have a good + -- way to get the real one. It's probably OK though, since we're generating + -- this term with a disallowed provenance, and it doesn't actually exist + -- anyway. + $ conLikeResTy dc args + + +------------------------------------------------------------------------------ +-- | Build a 'Hypothesis' given an 'Id'. +mkIdHypothesis :: Id -> Provenance -> Hypothesis CType +mkIdHypothesis (splitId -> (name, ty)) prov = + Hypothesis $ pure $ HyInfo name prov ty + + +------------------------------------------------------------------------------ +-- | Is this hole immediately to the right of an equals sign --- and is there +-- no where clause attached to it? +-- +-- It's important that there is no where clause because otherwise it gets +-- clobbered. See #2183 for an example. +-- +-- This isn't a perfect check, and produces some ugly code. But it's much much +-- better than the alternative, which is to destructively modify the user's +-- AST. +isRhsHoleWithoutWhere + :: Tracked age RealSrcSpan + -> Tracked age TypecheckedSource + -> Bool +isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = + everything (||) (mkQ False $ \case + TopLevelRHS _ _ + (L (RealSrcSpan span _) _) + (EmptyLocalBinds _) -> containsSpan rss span + _ -> False + ) tcs + + +ufmSeverity :: UserFacingMessage -> MessageType +ufmSeverity NotEnoughGas = MtInfo +ufmSeverity TacticErrors = MtError +ufmSeverity TimedOut = MtInfo +ufmSeverity NothingToDo = MtInfo +ufmSeverity (InfrastructureError _) = MtError + + +mkShowMessageParams :: UserFacingMessage -> ShowMessageParams +mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm + + +showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () +showLspMessage = sendNotification SWindowShowMessage + + +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty +data WriteDiagnostics = WriteDiagnostics + deriving (Eq, Show, Typeable, Generic) + +instance Hashable WriteDiagnostics +instance NFData WriteDiagnostics + +type instance RuleResult WriteDiagnostics = () + +data GetMetaprograms = GetMetaprograms + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetMetaprograms +instance NFData GetMetaprograms + +type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] + +wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +wingmanRules recorder plId = do + define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> + usePropertyAction #hole_severity plId properties >>= \case + Nothing -> pure (mempty, Just ()) + Just severity -> + use GetParsedModule nfp >>= \case + Nothing -> + pure ([], Nothing) + Just pm -> do + let holes :: [Range] + holes = + everything (<>) + (mkQ mempty $ \case + L span (HsVar _ (L _ name)) + | isHole (occName name) -> + maybeToList $ srcSpanToRange span +#if __GLASGOW_HASKELL__ >= 900 + L span (HsUnboundVar _ occ) +#else + L span (HsUnboundVar _ (TrueExprHole occ)) +#endif + | isHole occ -> + maybeToList $ srcSpanToRange span + (_ :: LHsExpr GhcPs) -> mempty + ) $ pm_parsed_source pm + pure + ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes + , Just () + ) + + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do + TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp + let scrutinees = traverse (metaprogramQ . tcg_binds) tcg + return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do + case ss of + RealSrcSpan r _ -> do + rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r + pure (rss', program) + UnhelpfulSpan _ -> Nothing + + -- This persistent rule helps to avoid blocking HLS hover providers at startup + -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other + -- hover providers from being used to produce a response + addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing) + + action $ do + files <- getFilesOfInterestUntracked + void $ uses WriteDiagnostics $ Map.keys files + + +mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic +mkDiagnostic severity r = + Diagnostic r + (Just severity) + (Just $ InR "hole") + (Just "wingman") + "Hole" + (Just $ List [DtUnnecessary]) + Nothing + + +------------------------------------------------------------------------------ +-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. +mkWorkspaceEdits + :: DynFlags + -> ClientCapabilities + -> Uri + -> Annotated ParsedSource + -> Graft (Either String) ParsedSource + -> Either UserFacingMessage WorkspaceEdit +mkWorkspaceEdits dflags ccs uri pm g = do + let pm' = runIdentity $ transformA pm annotateMetaprograms + let response = transform dflags ccs uri g pm' + in first (InfrastructureError . T.pack) response + + +------------------------------------------------------------------------------ +-- | Add ExactPrint annotations to every metaprogram in the source tree. +-- Usually the ExactPrint module can do this for us, but we've enabled +-- QuasiQuotes, so the round-trip print/parse journey will crash. +annotateMetaprograms :: Data a => a -> Transform a +annotateMetaprograms = everywhereM $ mkM $ \case + L ss (WingmanMetaprogram mp) -> do + let x = L ss $ MetaprogramSyntax mp + let anns = addAnnotationsForPretty [] x mempty + modifyAnnsT $ mappend anns + pure x + (x :: LHsExpr GhcPs) -> pure x + + +------------------------------------------------------------------------------ +-- | Find the source of a tactic metaprogram at the given span. +getMetaprogramAtSpan + :: Tracked age SrcSpan + -> Tracked age TcGblEnv + -> Maybe T.Text +getMetaprogramAtSpan (unTrack -> ss) + = fmap snd + . listToMaybe + . metaprogramAtQ ss + . tcg_binds + . unTrack + diff --git a/new/src/Wingman/LanguageServer/Metaprogram.hs b/new/src/Wingman/LanguageServer/Metaprogram.hs new file mode 100644 --- /dev/null +++ b/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 <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) + liftIO $ fromMaybeT (Right Nothing) $ do + holes <- stale GetMetaprograms + + fmap (Right . Just) $ + case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of + Just (trss, program) -> do + let tr_range = fmap realSrcSpanToRange trss + rsl = realSrcSpanStart $ unTrack trss + HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg + z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program + pure $ Hover + { _contents = HoverContents + $ MarkupContent MkMarkdown + $ either T.pack T.pack z + , _range = Just $ unTrack tr_range + } + Nothing -> empty +hoverProvider _ _ _ = pure $ Right Nothing + +fromMaybeT :: Functor m => a -> MaybeT m a -> m a +fromMaybeT def = fmap (fromMaybe def) . runMaybeT diff --git a/new/src/Wingman/LanguageServer/TacticProviders.hs b/new/src/Wingman/LanguageServer/TacticProviders.hs new file mode 100644 --- /dev/null +++ b/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 hiding (Config) +import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) +import Prelude hiding (span) +import Wingman.AbstractLSP.Types +import Wingman.Auto +import Wingman.GHC +import Wingman.Judgements +import Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons) +import Wingman.Metaprogramming.Parser (parseMetaprogram) +import Wingman.Tactics +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | A mapping from tactic commands to actual tactics for refinery. +commandTactic :: TacticCommand -> T.Text -> TacticsM () +commandTactic Auto = const auto +commandTactic Intros = const intros +commandTactic IntroAndDestruct = const introAndDestruct +commandTactic Destruct = useNameFromHypothesis destruct . mkVarOcc . T.unpack +commandTactic DestructPun = useNameFromHypothesis destructPun . mkVarOcc . T.unpack +commandTactic Homomorphism = useNameFromHypothesis homo . mkVarOcc . T.unpack +commandTactic DestructLambdaCase = const destructLambdaCase +commandTactic HomomorphismLambdaCase = const homoLambdaCase +commandTactic DestructAll = const destructAll +commandTactic UseDataCon = userSplit . mkVarOcc . T.unpack +commandTactic Refine = const refine +commandTactic BeginMetaprogram = const metaprogram +commandTactic RunMetaprogram = parseMetaprogram + + +------------------------------------------------------------------------------ +-- | The LSP kind +tacticKind :: TacticCommand -> T.Text +tacticKind Auto = "fillHole" +tacticKind Intros = "introduceLambda" +tacticKind IntroAndDestruct = "introduceAndDestruct" +tacticKind Destruct = "caseSplit" +tacticKind DestructPun = "caseSplitPun" +tacticKind Homomorphism = "homomorphicCaseSplit" +tacticKind DestructLambdaCase = "lambdaCase" +tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase" +tacticKind DestructAll = "splitFuncArgs" +tacticKind UseDataCon = "useConstructor" +tacticKind Refine = "refine" +tacticKind BeginMetaprogram = "beginMetaprogram" +tacticKind RunMetaprogram = "runMetaprogram" + + +------------------------------------------------------------------------------ +-- | Whether or not this code action is preferred -- ostensibly refers to +-- whether or not we can bind it to a key in vs code? +tacticPreferred :: TacticCommand -> Bool +tacticPreferred Auto = True +tacticPreferred Intros = True +tacticPreferred IntroAndDestruct = True +tacticPreferred Destruct = True +tacticPreferred DestructPun = False +tacticPreferred Homomorphism = True +tacticPreferred DestructLambdaCase = False +tacticPreferred HomomorphismLambdaCase = False +tacticPreferred DestructAll = True +tacticPreferred UseDataCon = True +tacticPreferred Refine = True +tacticPreferred BeginMetaprogram = False +tacticPreferred RunMetaprogram = True + + +mkTacticKind :: TacticCommand -> CodeActionKind +mkTacticKind = + CodeActionUnknown . mappend "refactor.wingman." . tacticKind + + +------------------------------------------------------------------------------ +-- | Mapping from tactic commands to their contextual providers. See 'provide', +-- 'filterGoalType' and 'filterBindingType' for the nitty gritty. +commandProvider :: TacticCommand -> TacticProvider +commandProvider Auto = + requireHoleSort (== Hole) $ + provide Auto "" +commandProvider Intros = + requireHoleSort (== Hole) $ + filterGoalType isFunction $ + provide Intros "" +commandProvider IntroAndDestruct = + requireHoleSort (== Hole) $ + filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $ + provide IntroAndDestruct "" +commandProvider Destruct = + requireHoleSort (== Hole) $ + filterBindingType destructFilter $ \occ _ -> + provide Destruct $ T.pack $ occNameString occ +commandProvider DestructPun = + requireHoleSort (== Hole) $ + filterBindingType destructPunFilter $ \occ _ -> + provide DestructPun $ T.pack $ occNameString occ +commandProvider Homomorphism = + requireHoleSort (== Hole) $ + filterBindingType homoFilter $ \occ _ -> + provide Homomorphism $ T.pack $ occNameString occ +commandProvider DestructLambdaCase = + requireHoleSort (== Hole) $ + requireExtension LambdaCase $ + filterGoalType (isJust . lambdaCaseable) $ + provide DestructLambdaCase "" +commandProvider HomomorphismLambdaCase = + requireHoleSort (== Hole) $ + requireExtension LambdaCase $ + filterGoalType (liftLambdaCase False homoFilter) $ + provide HomomorphismLambdaCase "" +commandProvider DestructAll = + requireHoleSort (== Hole) $ + withJudgement $ \jdg -> + case _jIsTopHole jdg && jHasBoundArgs jdg of + True -> provide DestructAll "" + False -> mempty +commandProvider UseDataCon = + requireHoleSort (== Hole) $ + withConfig $ \cfg -> + filterTypeProjection + ( guardLength (<= cfg_max_use_ctor_actions cfg) + . maybe [] fst + . tacticsGetDataCons + ) $ \dcon -> + provide UseDataCon + . T.pack + . occNameString + . occName + $ dataConName dcon +commandProvider Refine = + requireHoleSort (== Hole) $ + provide Refine "" +commandProvider BeginMetaprogram = + requireHoleSort (== Hole) $ + provide BeginMetaprogram "" +commandProvider RunMetaprogram = + withMetaprogram $ \mp -> + provide RunMetaprogram mp + + +------------------------------------------------------------------------------ +-- | Return an empty list if the given predicate doesn't hold over the length +guardLength :: (Int -> Bool) -> [a] -> [a] +guardLength f as = bool [] as $ f $ length as + + +------------------------------------------------------------------------------ +-- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS +-- UI. +type TacticProvider + = TacticProviderData + -> [(Metadata, T.Text)] + + +data TacticProviderData = TacticProviderData + { tpd_lspEnv :: LspEnv + , tpd_jdg :: Judgement + , tpd_hole_sort :: HoleSort + } + + +requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider +requireHoleSort p tp tpd = + case p $ tpd_hole_sort tpd of + True -> tp tpd + False -> [] + +withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider +withMetaprogram tp tpd = + case tpd_hole_sort tpd of + Metaprogram mp -> tp mp tpd + _ -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +requireExtension :: Extension -> TacticProvider -> TacticProvider +requireExtension ext tp tpd = + case xopt ext $ le_dflags $ tpd_lspEnv tpd of + True -> tp tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider +filterGoalType p tp tpd = + case p $ unCType $ jGoal $ tpd_jdg tpd of + True -> tp tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +withJudgement :: (Judgement -> TacticProvider) -> TacticProvider +withJudgement tp tpd = tp (tpd_jdg tpd) tpd + + +------------------------------------------------------------------------------ +-- | Multiply a 'TacticProvider' for each binding, making sure it appears only +-- when the given predicate holds over the goal and binding types. +filterBindingType + :: (Type -> Type -> Bool) -- ^ Goal and then binding types. + -> (OccName -> Type -> TacticProvider) + -> TacticProvider +filterBindingType p tp tpd = + let jdg = tpd_jdg tpd + hy = jLocalHypothesis jdg + g = jGoal jdg + in unHypothesis hy >>= \hi -> + let ty = unCType $ hi_type hi + in case p (unCType g) ty of + True -> tp (hi_name hi) ty tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Multiply a 'TacticProvider' by some feature projection out of the goal +-- type. Used e.g. to crete a code action for every data constructor. +filterTypeProjection + :: (Type -> [a]) -- ^ Features of the goal to look into further + -> (a -> TacticProvider) + -> TacticProvider +filterTypeProjection p tp tpd = + (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a -> + tp a tpd + + +------------------------------------------------------------------------------ +-- | Get access to the 'Config' when building a 'TacticProvider'. +withConfig :: (Config -> TacticProvider) -> TacticProvider +withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd + + +------------------------------------------------------------------------------ +-- | Terminal constructor for providing context-sensitive tactics. Tactics +-- given by 'provide' are always available. +provide :: TacticCommand -> T.Text -> TacticProvider +provide tc name _ = + pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name) + + +------------------------------------------------------------------------------ +-- | Construct a 'CommandId' +tcCommandId :: TacticCommand -> CommandId +tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command" + + +------------------------------------------------------------------------------ +-- | We should show homos only when the goal type is the same as the binding +-- type, and that both are usual algebraic types. +homoFilter :: Type -> Type -> Bool +homoFilter codomain domain = + case uncoveredDataCons domain codomain of + Just s -> S.null s + _ -> False + + +------------------------------------------------------------------------------ +-- | Lift a function of (codomain, domain) over a lambda case. +liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r +liftLambdaCase nil f t = + case tacticsSplitFunTy t of + (_, _, arg : _, res) -> f res $ scaledThing arg + _ -> nil + + + +------------------------------------------------------------------------------ +-- | We should show destruct for bindings only when those bindings have usual +-- algebraic types. +destructFilter :: Type -> Type -> Bool +destructFilter _ (algebraicTyCon -> Just _) = True +destructFilter _ _ = False + + +------------------------------------------------------------------------------ +-- | We should show destruct punning for bindings only when those bindings have +-- usual algebraic types, and when any of their data constructors are records. +destructPunFilter :: Type -> Type -> Bool +destructPunFilter _ (algebraicTyCon -> Just tc) = + not . all (null . dataConFieldLabels) $ tyConDataCons tc +destructPunFilter _ _ = False + + +instance IsContinuationSort TacticCommand where + toCommandId = tcCommandId + diff --git a/new/src/Wingman/Machinery.hs b/new/src/Wingman/Machinery.hs new file mode 100644 --- /dev/null +++ b/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) + $ 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/new/src/Wingman/Metaprogramming/Lexer.hs b/new/src/Wingman/Metaprogramming/Lexer.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Metaprogramming/Parser.hs b/new/src/Wingman/Metaprogramming/Parser.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Metaprogramming/Parser.hs-boot b/new/src/Wingman/Metaprogramming/Parser.hs-boot new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Metaprogramming/Parser/Documentation.hs b/new/src/Wingman/Metaprogramming/Parser/Documentation.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Metaprogramming/ProofState.hs b/new/src/Wingman/Metaprogramming/ProofState.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Naming.hs b/new/src/Wingman/Naming.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Plugin.hs b/new/src/Wingman/Plugin.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Range.hs b/new/src/Wingman/Range.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Simplify.hs b/new/src/Wingman/Simplify.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/StaticPlugin.hs b/new/src/Wingman/StaticPlugin.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Tactics.hs b/new/src/Wingman/Tactics.hs new file mode 100644 --- /dev/null +++ b/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/new/src/Wingman/Types.hs b/new/src/Wingman/Types.hs new file mode 100644 --- /dev/null +++ b/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/new/test/AutoTupleSpec.hs b/new/test/AutoTupleSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/AutoSpec.hs b/new/test/CodeAction/AutoSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/DestructAllSpec.hs b/new/test/CodeAction/DestructAllSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/DestructPunSpec.hs b/new/test/CodeAction/DestructPunSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/DestructSpec.hs b/new/test/CodeAction/DestructSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/IntroDestructSpec.hs b/new/test/CodeAction/IntroDestructSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/IntrosSpec.hs b/new/test/CodeAction/IntrosSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/RefineSpec.hs b/new/test/CodeAction/RefineSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/RunMetaprogramSpec.hs b/new/test/CodeAction/RunMetaprogramSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeAction/UseDataConSpec.hs b/new/test/CodeAction/UseDataConSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/CodeLens/EmptyCaseSpec.hs b/new/test/CodeLens/EmptyCaseSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/Main.hs b/new/test/Main.hs new file mode 100644 --- /dev/null +++ b/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/new/test/ProviderSpec.hs b/new/test/ProviderSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/Spec.hs b/new/test/Spec.hs new file mode 100644 --- /dev/null +++ b/new/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/new/test/UnificationSpec.hs b/new/test/UnificationSpec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/Utils.hs b/new/test/Utils.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoEmptyString.expected.hs b/new/test/golden/AutoEmptyString.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoEmptyString.expected.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = "" diff --git a/new/test/golden/AutoEmptyString.hs b/new/test/golden/AutoEmptyString.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoEmptyString.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = _ diff --git a/new/test/golden/AutoEndo.expected.hs b/new/test/golden/AutoEndo.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoEndo.hs b/new/test/golden/AutoEndo.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoForallClassMethod.expected.hs b/new/test/golden/AutoForallClassMethod.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoForallClassMethod.hs b/new/test/golden/AutoForallClassMethod.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoInfixApply.expected.hs b/new/test/golden/AutoInfixApply.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoInfixApply.hs b/new/test/golden/AutoInfixApply.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoInfixApply.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = _ + diff --git a/new/test/golden/AutoInfixApplyMany.expected.hs b/new/test/golden/AutoInfixApplyMany.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoInfixApplyMany.hs b/new/test/golden/AutoInfixApplyMany.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoInfixInfix.expected.hs b/new/test/golden/AutoInfixInfix.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoInfixInfix.hs b/new/test/golden/AutoInfixInfix.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoPatSynUse.expected.hs b/new/test/golden/AutoPatSynUse.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoPatSynUse.hs b/new/test/golden/AutoPatSynUse.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoSplitGADT.expected.hs b/new/test/golden/AutoSplitGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoSplitGADT.hs b/new/test/golden/AutoSplitGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaEqCtx.expected.hs b/new/test/golden/AutoThetaEqCtx.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoThetaEqCtx.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = id -- id + diff --git a/new/test/golden/AutoThetaEqCtx.hs b/new/test/golden/AutoThetaEqCtx.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoThetaEqCtx.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = _ -- id + diff --git a/new/test/golden/AutoThetaEqGADT.expected.hs b/new/test/golden/AutoThetaEqGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaEqGADT.hs b/new/test/golden/AutoThetaEqGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaEqGADTDestruct.expected.hs b/new/test/golden/AutoThetaEqGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaEqGADTDestruct.hs b/new/test/golden/AutoThetaEqGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaFix.expected.hs b/new/test/golden/AutoThetaFix.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaFix.hs b/new/test/golden/AutoThetaFix.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaGADT.expected.hs b/new/test/golden/AutoThetaGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaGADT.hs b/new/test/golden/AutoThetaGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaGADTDestruct.expected.hs b/new/test/golden/AutoThetaGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaGADTDestruct.hs b/new/test/golden/AutoThetaGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaMultipleUnification.expected.hs b/new/test/golden/AutoThetaMultipleUnification.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaMultipleUnification.hs b/new/test/golden/AutoThetaMultipleUnification.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaRankN.expected.hs b/new/test/golden/AutoThetaRankN.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaRankN.hs b/new/test/golden/AutoThetaRankN.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaRefl.expected.hs b/new/test/golden/AutoThetaRefl.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaRefl.hs b/new/test/golden/AutoThetaRefl.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaReflDestruct.expected.hs b/new/test/golden/AutoThetaReflDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaReflDestruct.hs b/new/test/golden/AutoThetaReflDestruct.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaSplitUnification.expected.hs b/new/test/golden/AutoThetaSplitUnification.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoThetaSplitUnification.hs b/new/test/golden/AutoThetaSplitUnification.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoTypeLevel.expected.hs b/new/test/golden/AutoTypeLevel.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoTypeLevel.hs b/new/test/golden/AutoTypeLevel.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoUnusedPatternMatch.expected.hs b/new/test/golden/AutoUnusedPatternMatch.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoUnusedPatternMatch.expected.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test _ = () diff --git a/new/test/golden/AutoUnusedPatternMatch.hs b/new/test/golden/AutoUnusedPatternMatch.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/AutoUnusedPatternMatch.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test = _ diff --git a/new/test/golden/AutoZip.expected.hs b/new/test/golden/AutoZip.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/AutoZip.hs b/new/test/golden/AutoZip.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/ConProviders.hs b/new/test/golden/ConProviders.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllAnd.expected.hs b/new/test/golden/DestructAllAnd.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllAnd.hs b/new/test/golden/DestructAllAnd.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/DestructAllAnd.hs @@ -0,0 +1,2 @@ +and :: Bool -> Bool -> Bool +and x y = _ diff --git a/new/test/golden/DestructAllFunc.expected.hs b/new/test/golden/DestructAllFunc.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllFunc.hs b/new/test/golden/DestructAllFunc.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/DestructAllFunc.hs @@ -0,0 +1,3 @@ +has_a_func :: Bool -> (a -> b) -> Bool +has_a_func x y = _ + diff --git a/new/test/golden/DestructAllGADTEvidence.expected.hs b/new/test/golden/DestructAllGADTEvidence.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllGADTEvidence.hs b/new/test/golden/DestructAllGADTEvidence.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllMany.expected.hs b/new/test/golden/DestructAllMany.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllMany.hs b/new/test/golden/DestructAllMany.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllNonVarTopMatch.expected.hs b/new/test/golden/DestructAllNonVarTopMatch.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructAllNonVarTopMatch.hs b/new/test/golden/DestructAllNonVarTopMatch.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/DestructAllNonVarTopMatch.hs @@ -0,0 +1,3 @@ +and :: (a, b) -> Bool -> Bool -> Bool +and (a, b) x y = _ + diff --git a/new/test/golden/DestructAllProvider.hs b/new/test/golden/DestructAllProvider.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructCthulhu.expected.hs b/new/test/golden/DestructCthulhu.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructCthulhu.hs b/new/test/golden/DestructCthulhu.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructDataFam.expected.hs b/new/test/golden/DestructDataFam.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructDataFam.hs b/new/test/golden/DestructDataFam.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructInt.expected.hs b/new/test/golden/DestructInt.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructInt.hs b/new/test/golden/DestructInt.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/DestructInt.hs @@ -0,0 +1,7 @@ +import Data.Int + +data Test = Test Int32 + +test :: Test -> Int32 +test t = _ + diff --git a/new/test/golden/DestructPun.expected.hs b/new/test/golden/DestructPun.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructPun.hs b/new/test/golden/DestructPun.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructTyFam.expected.hs b/new/test/golden/DestructTyFam.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructTyFam.hs b/new/test/golden/DestructTyFam.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructTyToDataFam.expected.hs b/new/test/golden/DestructTyToDataFam.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/DestructTyToDataFam.hs b/new/test/golden/DestructTyToDataFam.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseADT.expected.hs b/new/test/golden/EmptyCaseADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseADT.hs b/new/test/golden/EmptyCaseADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseApply.expected.hs b/new/test/golden/EmptyCaseApply.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseApply.expected.hs @@ -0,0 +1,3 @@ +blah = case show 5 of + [] -> _ + c : s -> _ diff --git a/new/test/golden/EmptyCaseApply.hs b/new/test/golden/EmptyCaseApply.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseApply.hs @@ -0,0 +1,1 @@ +blah = case show 5 of diff --git a/new/test/golden/EmptyCaseGADT.expected.hs b/new/test/golden/EmptyCaseGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseGADT.hs b/new/test/golden/EmptyCaseGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseLamCase.expected.hs b/new/test/golden/EmptyCaseLamCase.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseLamCase.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case + False -> _ + True -> _ diff --git a/new/test/golden/EmptyCaseLamCase.hs b/new/test/golden/EmptyCaseLamCase.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseLamCase.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case diff --git a/new/test/golden/EmptyCaseNested.expected.hs b/new/test/golden/EmptyCaseNested.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseNested.expected.hs @@ -0,0 +1,5 @@ +test = + case (case (Just "") of + Nothing -> _ + Just s -> _) of + True -> _ diff --git a/new/test/golden/EmptyCaseNested.hs b/new/test/golden/EmptyCaseNested.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseNested.hs @@ -0,0 +1,3 @@ +test = + case (case (Just "") of) of + True -> _ diff --git a/new/test/golden/EmptyCaseParens.expected.hs b/new/test/golden/EmptyCaseParens.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseParens.expected.hs @@ -0,0 +1,3 @@ +test = True && (case True of + False -> _ + True -> _) diff --git a/new/test/golden/EmptyCaseParens.hs b/new/test/golden/EmptyCaseParens.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/EmptyCaseParens.hs @@ -0,0 +1,1 @@ +test = True && case True of diff --git a/new/test/golden/EmptyCaseShadow.expected.hs b/new/test/golden/EmptyCaseShadow.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseShadow.hs b/new/test/golden/EmptyCaseShadow.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/EmptyCaseSpuriousGADT.hs b/new/test/golden/EmptyCaseSpuriousGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/Fgmap.expected.hs b/new/test/golden/Fgmap.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/Fgmap.hs b/new/test/golden/Fgmap.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapBoth.expected.hs b/new/test/golden/FmapBoth.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapBoth.hs b/new/test/golden/FmapBoth.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapJoin.expected.hs b/new/test/golden/FmapJoin.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapJoin.hs b/new/test/golden/FmapJoin.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapJoinInLet.expected.hs b/new/test/golden/FmapJoinInLet.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/FmapJoinInLet.hs b/new/test/golden/FmapJoinInLet.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenApplicativeThen.hs b/new/test/golden/GoldenApplicativeThen.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenApplicativeThen.hs @@ -0,0 +1,2 @@ +useThen :: Applicative f => f Int -> f a -> f a +useThen = _ diff --git a/new/test/golden/GoldenArbitrary.expected.hs b/new/test/golden/GoldenArbitrary.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenArbitrary.hs b/new/test/golden/GoldenArbitrary.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/new/test/golden/GoldenArbitrarySingleConstructor.expected.hs new file mode 100644 --- /dev/null +++ b/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 diff --git a/new/test/golden/GoldenArbitrarySingleConstructor.hs b/new/test/golden/GoldenArbitrarySingleConstructor.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenArbitrarySingleConstructor.hs @@ -0,0 +1,6 @@ +data Gen a + +data Obj = Obj Int Bool Char String + +arbitrary :: Gen Obj +arbitrary = _ diff --git a/new/test/golden/GoldenBigTuple.expected.hs b/new/test/golden/GoldenBigTuple.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenBigTuple.hs b/new/test/golden/GoldenBigTuple.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenEitherAuto.expected.hs b/new/test/golden/GoldenEitherAuto.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenEitherAuto.hs b/new/test/golden/GoldenEitherAuto.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenEitherAuto.hs @@ -0,0 +1,2 @@ +either' :: (a -> c) -> (b -> c) -> Either a b -> c +either' = _ diff --git a/new/test/golden/GoldenEitherHomomorphic.expected.hs b/new/test/golden/GoldenEitherHomomorphic.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenEitherHomomorphic.hs b/new/test/golden/GoldenEitherHomomorphic.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenEitherHomomorphic.hs @@ -0,0 +1,2 @@ +eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c +eitherSplit = _ diff --git a/new/test/golden/GoldenFish.hs b/new/test/golden/GoldenFish.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenFmapTree.expected.hs b/new/test/golden/GoldenFmapTree.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenFmapTree.hs b/new/test/golden/GoldenFmapTree.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenFoldr.expected.hs b/new/test/golden/GoldenFoldr.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenFoldr.hs b/new/test/golden/GoldenFoldr.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenFoldr.hs @@ -0,0 +1,2 @@ +foldr2 :: (a -> b -> b) -> b -> [a] -> b +foldr2 = _ diff --git a/new/test/golden/GoldenFromMaybe.expected.hs b/new/test/golden/GoldenFromMaybe.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenFromMaybe.hs b/new/test/golden/GoldenFromMaybe.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenFromMaybe.hs @@ -0,0 +1,2 @@ +fromMaybe :: a -> Maybe a -> a +fromMaybe = _ diff --git a/new/test/golden/GoldenGADTAuto.expected.hs b/new/test/golden/GoldenGADTAuto.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenGADTAuto.hs b/new/test/golden/GoldenGADTAuto.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenGADTDestruct.expected.hs b/new/test/golden/GoldenGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenGADTDestruct.hs b/new/test/golden/GoldenGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenGADTDestructCoercion.expected.hs b/new/test/golden/GoldenGADTDestructCoercion.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenGADTDestructCoercion.hs b/new/test/golden/GoldenGADTDestructCoercion.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenIdTypeFam.expected.hs b/new/test/golden/GoldenIdTypeFam.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenIdTypeFam.hs b/new/test/golden/GoldenIdTypeFam.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenIdentityFunctor.expected.hs b/new/test/golden/GoldenIdentityFunctor.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenIdentityFunctor.hs b/new/test/golden/GoldenIdentityFunctor.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenIdentityFunctor.hs @@ -0,0 +1,3 @@ +data Ident a = Ident a +instance Functor Ident where + fmap = _ diff --git a/new/test/golden/GoldenIntros.expected.hs b/new/test/golden/GoldenIntros.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenIntros.hs b/new/test/golden/GoldenIntros.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenIntros.hs @@ -0,0 +1,2 @@ +blah :: Int -> Bool -> (a -> b) -> String -> Int +blah = _ diff --git a/new/test/golden/GoldenJoinCont.expected.hs b/new/test/golden/GoldenJoinCont.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenJoinCont.hs b/new/test/golden/GoldenJoinCont.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenListFmap.expected.hs b/new/test/golden/GoldenListFmap.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenListFmap.hs b/new/test/golden/GoldenListFmap.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenListFmap.hs @@ -0,0 +1,2 @@ +fmapList :: (a -> b) -> [a] -> [b] +fmapList = _ diff --git a/new/test/golden/GoldenNote.expected.hs b/new/test/golden/GoldenNote.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenNote.hs b/new/test/golden/GoldenNote.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenNote.hs @@ -0,0 +1,2 @@ +note :: e -> Maybe a -> Either e a +note = _ diff --git a/new/test/golden/GoldenPureList.expected.hs b/new/test/golden/GoldenPureList.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenPureList.expected.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList a = a : [] diff --git a/new/test/golden/GoldenPureList.hs b/new/test/golden/GoldenPureList.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenPureList.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList = _ diff --git a/new/test/golden/GoldenSafeHead.expected.hs b/new/test/golden/GoldenSafeHead.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenSafeHead.expected.hs @@ -0,0 +1,3 @@ +safeHead :: [x] -> Maybe x +safeHead [] = Nothing +safeHead (x : _) = Just x diff --git a/new/test/golden/GoldenSafeHead.hs b/new/test/golden/GoldenSafeHead.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenSafeHead.hs @@ -0,0 +1,2 @@ +safeHead :: [x] -> Maybe x +safeHead = _ diff --git a/new/test/golden/GoldenShow.expected.hs b/new/test/golden/GoldenShow.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenShow.expected.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = show diff --git a/new/test/golden/GoldenShow.hs b/new/test/golden/GoldenShow.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenShow.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = _ diff --git a/new/test/golden/GoldenShowCompose.expected.hs b/new/test/golden/GoldenShowCompose.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenShowCompose.expected.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose fba = show . fba diff --git a/new/test/golden/GoldenShowCompose.hs b/new/test/golden/GoldenShowCompose.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenShowCompose.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose = _ diff --git a/new/test/golden/GoldenShowMapChar.expected.hs b/new/test/golden/GoldenShowMapChar.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenShowMapChar.hs b/new/test/golden/GoldenShowMapChar.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenShowMapChar.hs @@ -0,0 +1,2 @@ +test :: Show a => a -> (String -> b) -> b +test = _ diff --git a/new/test/golden/GoldenSuperclass.expected.hs b/new/test/golden/GoldenSuperclass.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenSuperclass.hs b/new/test/golden/GoldenSuperclass.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenSwap.expected.hs b/new/test/golden/GoldenSwap.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenSwap.expected.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) diff --git a/new/test/golden/GoldenSwap.hs b/new/test/golden/GoldenSwap.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenSwap.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap = _ diff --git a/new/test/golden/GoldenSwapMany.expected.hs b/new/test/golden/GoldenSwapMany.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/GoldenSwapMany.hs b/new/test/golden/GoldenSwapMany.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/GoldenSwapMany.hs @@ -0,0 +1,2 @@ +swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) +swapMany = _ diff --git a/new/test/golden/IntroDestructLetBinding.expected.hs b/new/test/golden/IntroDestructLetBinding.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/IntroDestructLetBinding.hs b/new/test/golden/IntroDestructLetBinding.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/IntroDestructLetBinding.hs @@ -0,0 +1,5 @@ +test :: IO () +test = do + let x :: Bool -> Int + x = _ + pure () diff --git a/new/test/golden/IntroDestructMany.expected.hs b/new/test/golden/IntroDestructMany.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/IntroDestructMany.hs b/new/test/golden/IntroDestructMany.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/IntroDestructMany.hs @@ -0,0 +1,3 @@ +x :: Bool -> Maybe Int -> String -> Int +x = _ + diff --git a/new/test/golden/IntroDestructOne.expected.hs b/new/test/golden/IntroDestructOne.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/IntroDestructOne.hs b/new/test/golden/IntroDestructOne.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/IntroDestructOne.hs @@ -0,0 +1,5 @@ +module Test where + +x :: Bool -> Int +x = _ + diff --git a/new/test/golden/IntroDestructProvider.hs b/new/test/golden/IntroDestructProvider.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/IntrosTooMany.expected.hs b/new/test/golden/IntrosTooMany.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/IntrosTooMany.expected.hs @@ -0,0 +1,2 @@ +too_many :: a -> b -> c +too_many a b = _w0 diff --git a/new/test/golden/IntrosTooMany.hs b/new/test/golden/IntrosTooMany.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownBigSemigroup.expected.hs b/new/test/golden/KnownBigSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownBigSemigroup.hs b/new/test/golden/KnownBigSemigroup.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownCounterfactualSemigroup.expected.hs b/new/test/golden/KnownCounterfactualSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownCounterfactualSemigroup.hs b/new/test/golden/KnownCounterfactualSemigroup.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownDestructedSemigroup.expected.hs b/new/test/golden/KnownDestructedSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownDestructedSemigroup.hs b/new/test/golden/KnownDestructedSemigroup.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMissingMonoid.expected.hs b/new/test/golden/KnownMissingMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMissingMonoid.hs b/new/test/golden/KnownMissingMonoid.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMissingSemigroup.expected.hs b/new/test/golden/KnownMissingSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMissingSemigroup.hs b/new/test/golden/KnownMissingSemigroup.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/KnownMissingSemigroup.hs @@ -0,0 +1,5 @@ +data Semi = Semi [String] Int + +instance Semigroup Semi where + (<>) = _ + diff --git a/new/test/golden/KnownModuleInstanceSemigroup.expected.hs b/new/test/golden/KnownModuleInstanceSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownModuleInstanceSemigroup.hs b/new/test/golden/KnownModuleInstanceSemigroup.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMonoid.expected.hs b/new/test/golden/KnownMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownMonoid.hs b/new/test/golden/KnownMonoid.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownPolyMonoid.expected.hs b/new/test/golden/KnownPolyMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownPolyMonoid.hs b/new/test/golden/KnownPolyMonoid.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownThetaSemigroup.expected.hs b/new/test/golden/KnownThetaSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/KnownThetaSemigroup.hs b/new/test/golden/KnownThetaSemigroup.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/KnownThetaSemigroup.hs @@ -0,0 +1,5 @@ +data Semi a = Semi a + +instance Semigroup a => Semigroup (Semi a) where + (<>) = _ + diff --git a/new/test/golden/LayoutBind.expected.hs b/new/test/golden/LayoutBind.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutBind.hs b/new/test/golden/LayoutBind.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutBind.hs @@ -0,0 +1,6 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + _ + pure () + diff --git a/new/test/golden/LayoutDollarApp.expected.hs b/new/test/golden/LayoutDollarApp.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutDollarApp.hs b/new/test/golden/LayoutDollarApp.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutDollarApp.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test b = id $ _ + diff --git a/new/test/golden/LayoutInfixKeep.expected.hs b/new/test/golden/LayoutInfixKeep.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutInfixKeep.hs b/new/test/golden/LayoutInfixKeep.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutLam.expected.hs b/new/test/golden/LayoutLam.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutLam.hs b/new/test/golden/LayoutLam.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutLam.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test = \b -> _ + diff --git a/new/test/golden/LayoutOpApp.expected.hs b/new/test/golden/LayoutOpApp.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutOpApp.hs b/new/test/golden/LayoutOpApp.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutOpApp.hs @@ -0,0 +1,2 @@ +test :: Bool -> Bool +test b = True && _ diff --git a/new/test/golden/LayoutPrefixKeep.expected.hs b/new/test/golden/LayoutPrefixKeep.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutPrefixKeep.expected.hs @@ -0,0 +1,4 @@ +(-/) :: Bool -> a -> a +(-/) False a = _w0 +(-/) True a = _w1 + diff --git a/new/test/golden/LayoutPrefixKeep.hs b/new/test/golden/LayoutPrefixKeep.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutPrefixKeep.hs @@ -0,0 +1,3 @@ +(-/) :: Bool -> a -> a +(-/) b a = _ + diff --git a/new/test/golden/LayoutRec.expected.hs b/new/test/golden/LayoutRec.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutRec.hs b/new/test/golden/LayoutRec.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitClass.expected.hs b/new/test/golden/LayoutSplitClass.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitClass.hs b/new/test/golden/LayoutSplitClass.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutSplitClass.hs @@ -0,0 +1,4 @@ +class Test a where + test :: Bool -> a + test x = _ + diff --git a/new/test/golden/LayoutSplitGuard.expected.hs b/new/test/golden/LayoutSplitGuard.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitGuard.hs b/new/test/golden/LayoutSplitGuard.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutSplitGuard.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool -> Bool +test a b + | a = _ diff --git a/new/test/golden/LayoutSplitIn.expected.hs b/new/test/golden/LayoutSplitIn.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitIn.hs b/new/test/golden/LayoutSplitIn.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutSplitIn.hs @@ -0,0 +1,5 @@ +test :: a +test = + let a = (1,"bbb") + in _ + diff --git a/new/test/golden/LayoutSplitLet.expected.hs b/new/test/golden/LayoutSplitLet.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitLet.hs b/new/test/golden/LayoutSplitLet.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutSplitLet.hs @@ -0,0 +1,6 @@ +test :: a +test = + let t :: Bool -> a + t b = _ + in _ + diff --git a/new/test/golden/LayoutSplitPatSyn.expected.hs b/new/test/golden/LayoutSplitPatSyn.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitPatSyn.hs b/new/test/golden/LayoutSplitPatSyn.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitPattern.expected.hs b/new/test/golden/LayoutSplitPattern.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitPattern.hs b/new/test/golden/LayoutSplitPattern.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitViewPat.expected.hs b/new/test/golden/LayoutSplitViewPat.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitViewPat.hs b/new/test/golden/LayoutSplitViewPat.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/LayoutSplitViewPat.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + +splitLookup :: [(Int, String)] -> String +splitLookup (lookup 5 -> a) = _ + diff --git a/new/test/golden/LayoutSplitWhere.expected.hs b/new/test/golden/LayoutSplitWhere.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/LayoutSplitWhere.hs b/new/test/golden/LayoutSplitWhere.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MessageCantUnify.hs b/new/test/golden/MessageCantUnify.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MessageForallA.hs b/new/test/golden/MessageForallA.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MessageForallA.hs @@ -0,0 +1,2 @@ +test :: a +test = _ diff --git a/new/test/golden/MessageNotEnoughGas.hs b/new/test/golden/MessageNotEnoughGas.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaBegin.expected.hs b/new/test/golden/MetaBegin.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBegin.expected.hs @@ -0,0 +1,1 @@ +foo = [wingman||] diff --git a/new/test/golden/MetaBegin.hs b/new/test/golden/MetaBegin.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBegin.hs @@ -0,0 +1,1 @@ +foo = _ diff --git a/new/test/golden/MetaBeginNoWildify.expected.hs b/new/test/golden/MetaBeginNoWildify.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBeginNoWildify.expected.hs @@ -0,0 +1,2 @@ +foo v = [wingman||] + diff --git a/new/test/golden/MetaBeginNoWildify.hs b/new/test/golden/MetaBeginNoWildify.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBeginNoWildify.hs @@ -0,0 +1,2 @@ +foo v = _ + diff --git a/new/test/golden/MetaBindAll.expected.hs b/new/test/golden/MetaBindAll.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBindAll.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, a) diff --git a/new/test/golden/MetaBindAll.hs b/new/test/golden/MetaBindAll.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBindAll.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split; assumption |] diff --git a/new/test/golden/MetaBindOne.expected.hs b/new/test/golden/MetaBindOne.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBindOne.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, _w0) diff --git a/new/test/golden/MetaBindOne.hs b/new/test/golden/MetaBindOne.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaBindOne.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split, assumption |] diff --git a/new/test/golden/MetaCataAST.expected.hs b/new/test/golden/MetaCataAST.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaCataAST.hs b/new/test/golden/MetaCataAST.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaCataCollapse.expected.hs b/new/test/golden/MetaCataCollapse.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaCataCollapse.hs b/new/test/golden/MetaCataCollapse.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaCataCollapseUnary.expected.hs b/new/test/golden/MetaCataCollapseUnary.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaCataCollapseUnary.hs b/new/test/golden/MetaCataCollapseUnary.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaChoice.expected.hs b/new/test/golden/MetaChoice.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaChoice.hs b/new/test/golden/MetaChoice.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaDeepOf.expected.hs b/new/test/golden/MetaDeepOf.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaDeepOf.hs b/new/test/golden/MetaDeepOf.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaFundeps.expected.hs b/new/test/golden/MetaFundeps.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaFundeps.hs b/new/test/golden/MetaFundeps.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaIdiom.expected.hs b/new/test/golden/MetaIdiom.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaIdiom.hs b/new/test/golden/MetaIdiom.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaIdiomRecord.expected.hs b/new/test/golden/MetaIdiomRecord.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaIdiomRecord.hs b/new/test/golden/MetaIdiomRecord.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaLetSimple.expected.hs b/new/test/golden/MetaLetSimple.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaLetSimple.hs b/new/test/golden/MetaLetSimple.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaLetSimple.hs @@ -0,0 +1,2 @@ +test :: Int +test = [wingman| let a b c |] diff --git a/new/test/golden/MetaMaybeAp.expected.hs b/new/test/golden/MetaMaybeAp.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaMaybeAp.hs b/new/test/golden/MetaMaybeAp.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaPointwise.expected.hs b/new/test/golden/MetaPointwise.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaPointwise.hs b/new/test/golden/MetaPointwise.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaTry.expected.hs b/new/test/golden/MetaTry.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaTry.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = (_w0, a) diff --git a/new/test/golden/MetaTry.hs b/new/test/golden/MetaTry.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaTry.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = [wingman| split; try (assumption) |] diff --git a/new/test/golden/MetaUseImport.expected.hs b/new/test/golden/MetaUseImport.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaUseImport.expected.hs @@ -0,0 +1,6 @@ +import Data.Char + + +result :: Char -> Bool +result = isAlpha + diff --git a/new/test/golden/MetaUseImport.hs b/new/test/golden/MetaUseImport.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaUseLocal.expected.hs b/new/test/golden/MetaUseLocal.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaUseLocal.expected.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = test + diff --git a/new/test/golden/MetaUseLocal.hs b/new/test/golden/MetaUseLocal.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaUseLocal.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = [wingman| use test |] + diff --git a/new/test/golden/MetaUseMethod.expected.hs b/new/test/golden/MetaUseMethod.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaUseMethod.hs b/new/test/golden/MetaUseMethod.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/MetaUseSymbol.expected.hs b/new/test/golden/MetaUseSymbol.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaUseSymbol.expected.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = _w0 <> _w1 diff --git a/new/test/golden/MetaUseSymbol.hs b/new/test/golden/MetaUseSymbol.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaUseSymbol.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = [wingman| use (<>) |] diff --git a/new/test/golden/MetaWithArg.expected.hs b/new/test/golden/MetaWithArg.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaWithArg.expected.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = _w0 a diff --git a/new/test/golden/MetaWithArg.hs b/new/test/golden/MetaWithArg.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/MetaWithArg.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = [wingman| with_arg, assumption |] diff --git a/new/test/golden/NewtypeRecord.expected.hs b/new/test/golden/NewtypeRecord.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/NewtypeRecord.hs b/new/test/golden/NewtypeRecord.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/ProvideAlreadyDestructed.hs b/new/test/golden/ProvideAlreadyDestructed.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/ProvideLocalHyOnly.hs b/new/test/golden/ProvideLocalHyOnly.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/ProvideLocalHyOnly.hs @@ -0,0 +1,2 @@ +basilisk :: Monoid Bool => a +basilisk = _ diff --git a/new/test/golden/ProviderHomomorphism.hs b/new/test/golden/ProviderHomomorphism.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunGADT.expected.hs b/new/test/golden/PunGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunGADT.hs b/new/test/golden/PunGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunMany.expected.hs b/new/test/golden/PunMany.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunMany.hs b/new/test/golden/PunMany.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunManyGADT.expected.hs b/new/test/golden/PunManyGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunManyGADT.hs b/new/test/golden/PunManyGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunShadowing.expected.hs b/new/test/golden/PunShadowing.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunShadowing.hs b/new/test/golden/PunShadowing.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunSimple.expected.hs b/new/test/golden/PunSimple.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/PunSimple.hs b/new/test/golden/PunSimple.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/PunSimple.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: Bar -> Int +bar x = _ + diff --git a/new/test/golden/RecordCon.expected.hs b/new/test/golden/RecordCon.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RecordCon.hs b/new/test/golden/RecordCon.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RefineCon.expected.hs b/new/test/golden/RefineCon.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/RefineCon.expected.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = (_w0, _w1, _w2) + diff --git a/new/test/golden/RefineCon.hs b/new/test/golden/RefineCon.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/RefineCon.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = _ + diff --git a/new/test/golden/RefineGADT.expected.hs b/new/test/golden/RefineGADT.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RefineGADT.hs b/new/test/golden/RefineGADT.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RefineIntro.expected.hs b/new/test/golden/RefineIntro.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/RefineIntro.expected.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test a = _w0 diff --git a/new/test/golden/RefineIntro.hs b/new/test/golden/RefineIntro.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/RefineIntro.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test = _ diff --git a/new/test/golden/RefineIntroWhere.expected.hs b/new/test/golden/RefineIntroWhere.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RefineIntroWhere.hs b/new/test/golden/RefineIntroWhere.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/RefineIntroWhere.hs @@ -0,0 +1,6 @@ +test :: Maybe Int -> Int +test = _ + where + -- Don't delete me! + blah = undefined + diff --git a/new/test/golden/RefineReader.expected.hs b/new/test/golden/RefineReader.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/RefineReader.hs b/new/test/golden/RefineReader.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/SplitPattern.expected.hs b/new/test/golden/SplitPattern.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/SplitPattern.hs b/new/test/golden/SplitPattern.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/SubsequentTactics.expected.hs b/new/test/golden/SubsequentTactics.expected.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/SubsequentTactics.hs b/new/test/golden/SubsequentTactics.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/SubsequentTactics.hs @@ -0,0 +1,5 @@ +data Dummy a = Dummy a + +f :: Dummy Int -> Int +f = _ + diff --git a/new/test/golden/T1.hs b/new/test/golden/T1.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/T1.hs @@ -0,0 +1,3 @@ +fmapEither :: (a -> b) -> Either c a -> Either c b +fmapEither = _lalala + diff --git a/new/test/golden/T2.hs b/new/test/golden/T2.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/T3.hs b/new/test/golden/T3.hs new file mode 100644 --- /dev/null +++ b/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/new/test/golden/UseConLeft.expected.hs b/new/test/golden/UseConLeft.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConLeft.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Left _w0 + diff --git a/new/test/golden/UseConLeft.hs b/new/test/golden/UseConLeft.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConLeft.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/new/test/golden/UseConPair.expected.hs b/new/test/golden/UseConPair.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConPair.expected.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = (_w0, _w1) diff --git a/new/test/golden/UseConPair.hs b/new/test/golden/UseConPair.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConPair.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = _ diff --git a/new/test/golden/UseConRight.expected.hs b/new/test/golden/UseConRight.expected.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConRight.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Right _w0 + diff --git a/new/test/golden/UseConRight.hs b/new/test/golden/UseConRight.hs new file mode 100644 --- /dev/null +++ b/new/test/golden/UseConRight.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/new/test/golden/hie.yaml b/new/test/golden/hie.yaml new file mode 100644 --- /dev/null +++ b/new/test/golden/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/new/test/golden/test.cabal b/new/test/golden/test.cabal new file mode 100644 --- /dev/null +++ b/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 diff --git a/old/src/Ide/Plugin/Tactic.hs b/old/src/Ide/Plugin/Tactic.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Refinery/Future.hs b/old/src/Refinery/Future.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/AbstractLSP.hs b/old/src/Wingman/AbstractLSP.hs new file mode 100644 --- /dev/null +++ b/old/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 (runIde, getTacticConfigAction, getIdeDynflags, mkWorkspaceEdits, runStaleIde, showLspMessage, mkShowMessageParams) +import Wingman.StaticPlugin (enableQuasiQuotes) +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | Attach the 'Interaction's to a 'PluginDescriptor'. Interactions are +-- self-contained request/response pairs that abstract over the LSP, and +-- provide a unified interface for doing interesting things, without needing to +-- dive into the underlying API too directly. +installInteractions + :: [Interaction] + -> PluginDescriptor IdeState + -> PluginDescriptor IdeState +installInteractions is desc = + let plId = pluginId desc + in desc + { pluginCommands = pluginCommands desc <> fmap (buildCommand plId) is + , pluginHandlers = pluginHandlers desc <> buildHandlers is + } + + +------------------------------------------------------------------------------ +-- | Extract 'PluginHandlers' from 'Interaction's. +buildHandlers + :: [Interaction] + -> PluginHandlers IdeState +buildHandlers cs = + flip foldMap cs $ \(Interaction (c :: Continuation sort target b)) -> + case c_makeCommand c of + SynthesizeCodeAction k -> + mkPluginHandler STextDocumentCodeAction $ codeActionProvider @target (c_sort c) k + SynthesizeCodeLens k -> + mkPluginHandler STextDocumentCodeLens $ codeLensProvider @target (c_sort c) k + + +------------------------------------------------------------------------------ +-- | Extract a 'PluginCommand' from an 'Interaction'. +buildCommand + :: PluginId + -> Interaction + -> PluginCommand IdeState +buildCommand plId (Interaction (c :: Continuation sort target b)) = + PluginCommand + { commandId = toCommandId $ c_sort c + , commandDesc = T.pack "" + , commandFunc = runContinuation plId c + } + + +------------------------------------------------------------------------------ +-- | Boilerplate for running a 'Continuation' as part of an LSP command. +runContinuation + :: forall sort a b + . IsTarget a + => PluginId + -> Continuation sort a b + -> CommandFunction IdeState (FileContext, b) +runContinuation plId cont state (fc, b) = do + fromMaybeT + (Left $ ResponseError + { _code = InternalError + , _message = T.pack "TODO(sandy)" + , _xdata = Nothing + } ) $ do + env@LspEnv{..} <- buildEnv state plId fc + nfp <- getNfp $ fc_uri le_fileContext + let stale a = runStaleIde "runContinuation" state nfp a + args <- fetchTargetArgs @a env + res <- c_runCommand cont env args fc b + + -- This block returns a maybe error. + fmap (maybe (Right A.Null) Left . coerce . foldMap Last) $ + for res $ \case + ErrorMessages errs -> do + traverse_ showUserFacingMessage errs + pure Nothing + RawEdit edits -> do + sendEdits edits + pure Nothing + GraftEdit gr -> do + ccs <- lift getClientCapabilities + TrackedStale pm _ <- mapMaybeT liftIO $ stale GetAnnotatedParsedSource + case mkWorkspaceEdits (enableQuasiQuotes le_dflags) ccs (fc_uri le_fileContext) (unTrack pm) gr of + Left errs -> + pure $ Just $ ResponseError + { _code = InternalError + , _message = T.pack $ show errs + , _xdata = Nothing + } + Right edits -> do + sendEdits edits + pure Nothing + + +------------------------------------------------------------------------------ +-- | Push a 'WorkspaceEdit' to the client. +sendEdits :: WorkspaceEdit -> MaybeT (LspM Plugin.Config) () +sendEdits edits = + void $ lift $ + sendRequest + SWorkspaceApplyEdit + (ApplyWorkspaceEditParams Nothing edits) + (const $ pure ()) + + +------------------------------------------------------------------------------ +-- | Push a 'UserFacingMessage' to the client. +showUserFacingMessage + :: UserFacingMessage + -> MaybeT (LspM Plugin.Config) () +showUserFacingMessage ufm = + void $ lift $ showLspMessage $ mkShowMessageParams ufm + + +------------------------------------------------------------------------------ +-- | Build an 'LspEnv', which contains the majority of things we need to know +-- in a 'Continuation'. +buildEnv + :: IdeState + -> PluginId + -> FileContext + -> MaybeT (LspM Plugin.Config) LspEnv +buildEnv state plId fc = do + cfg <- liftIO $ runIde "plugin" "config" state $ getTacticConfigAction plId + nfp <- getNfp $ fc_uri fc + dflags <- mapMaybeT liftIO $ getIdeDynflags state nfp + pure $ LspEnv + { le_ideState = state + , le_pluginId = plId + , le_dflags = dflags + , le_config = cfg + , le_fileContext = fc + } + + +------------------------------------------------------------------------------ +-- | Lift a 'Continuation' into an LSP CodeAction. +codeActionProvider + :: forall target sort b + . (IsContinuationSort sort, A.ToJSON b, IsTarget target) + => sort + -> ( LspEnv + -> TargetArgs target + -> MaybeT (LspM Plugin.Config) [(Metadata, b)] + ) + -> PluginMethodHandler IdeState TextDocumentCodeAction +codeActionProvider sort k state plId + (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do + fromMaybeT (Right $ List []) $ do + let fc = FileContext + { fc_uri = uri + , fc_range = Just $ unsafeMkCurrent range + } + env <- buildEnv state plId fc + args <- fetchTargetArgs @target env + actions <- k env args + pure + $ Right + $ List + $ fmap (InR . uncurry (makeCodeAction plId fc sort)) actions + + +------------------------------------------------------------------------------ +-- | Lift a 'Continuation' into an LSP CodeLens. +codeLensProvider + :: forall target sort b + . (IsContinuationSort sort, A.ToJSON b, IsTarget target) + => sort + -> ( LspEnv + -> TargetArgs target + -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] + ) + -> PluginMethodHandler IdeState TextDocumentCodeLens +codeLensProvider sort k state plId + (CodeLensParams _ _ (TextDocumentIdentifier uri)) = do + fromMaybeT (Right $ List []) $ do + let fc = FileContext + { fc_uri = uri + , fc_range = Nothing + } + env <- buildEnv state plId fc + args <- fetchTargetArgs @target env + actions <- k env args + pure + $ Right + $ List + $ fmap (uncurry3 $ makeCodeLens plId sort fc) actions + + +------------------------------------------------------------------------------ +-- | Build a 'LSP.CodeAction'. +makeCodeAction + :: (A.ToJSON b, IsContinuationSort sort) + => PluginId + -> FileContext + -> sort + -> Metadata + -> b + -> LSP.CodeAction +makeCodeAction plId fc sort (Metadata title kind preferred) b = + let cmd_id = toCommandId sort + cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc, b)] + in LSP.CodeAction + { _title = title + , _kind = Just kind + , _diagnostics = Nothing + , _isPreferred = Just preferred + , _disabled = Nothing + , _edit = Nothing + , _command = Just cmd + , _xdata = Nothing + } + + +------------------------------------------------------------------------------ +-- | Build a 'LSP.CodeLens'. +makeCodeLens + :: (A.ToJSON b, IsContinuationSort sort) + => PluginId + -> sort + -> FileContext + -> Range + -> Metadata + -> b + -> LSP.CodeLens +makeCodeLens plId sort fc range (Metadata title _ _) b = + let fc' = fc { fc_range = Just $ unsafeMkCurrent range } + cmd_id = toCommandId sort + cmd = mkLspCommand plId cmd_id title $ Just [A.toJSON (fc', b)] + in LSP.CodeLens + { _range = range + , _command = Just cmd + , _xdata = Nothing + } + diff --git a/old/src/Wingman/AbstractLSP/TacticActions.hs b/old/src/Wingman/AbstractLSP/TacticActions.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/AbstractLSP/Types.hs b/old/src/Wingman/AbstractLSP/Types.hs new file mode 100644 --- /dev/null +++ b/old/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 hiding (Config) +import Language.LSP.Server (LspM) +import Language.LSP.Types hiding (CodeLens, CodeAction) +import Wingman.LanguageServer (judgementForHole) +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | An 'Interaction' is an existential 'Continuation', which handles both +-- sides of the request/response interaction for LSP. +data Interaction where + Interaction + :: (IsTarget target, IsContinuationSort sort, A.ToJSON b, A.FromJSON b) + => Continuation sort target b + -> Interaction + + +------------------------------------------------------------------------------ +-- | Metadata for a command. Used by both code actions and lenses, though for +-- lenses, only 'md_title' is currently used. +data Metadata + = Metadata + { md_title :: Text + , md_kind :: CodeActionKind + , md_preferred :: Bool + } + deriving stock (Eq, Show) + + +------------------------------------------------------------------------------ +-- | Whether we're defining a CodeAction or CodeLens. +data SynthesizeCommand a b + = SynthesizeCodeAction + ( LspEnv + -> TargetArgs a + -> MaybeT (LspM Plugin.Config) [(Metadata, b)] + ) + | SynthesizeCodeLens + ( LspEnv + -> TargetArgs a + -> MaybeT (LspM Plugin.Config) [(Range, Metadata, b)] + ) + + +------------------------------------------------------------------------------ +-- | Transform a "continuation sort" into a 'CommandId'. +class IsContinuationSort a where + toCommandId :: a -> CommandId + +instance IsContinuationSort CommandId where + toCommandId = id + +instance IsContinuationSort Text where + toCommandId = CommandId + + +------------------------------------------------------------------------------ +-- | Ways a 'Continuation' can resolve. +data ContinuationResult + = -- | Produce some error messages. + ErrorMessages [UserFacingMessage] + -- | Produce an explicit 'WorkspaceEdit'. + | RawEdit WorkspaceEdit + -- | Produce a 'Graft', corresponding to a transformation of the current + -- AST. + | GraftEdit (Graft (Either String) ParsedSource) + + +------------------------------------------------------------------------------ +-- | A 'Continuation' is a single object corresponding to an action that users +-- can take via LSP. It generalizes codeactions and codelenses, allowing for +-- a significant amount of code reuse. +-- +-- Given @Continuation sort target payload@: +-- +-- the @sort@ corresponds to a 'CommandId', allowing you to namespace actions +-- rather than working directly with text. This functionality is driven via +-- 'IsContinuationSort'. +-- +-- the @target@ is used to fetch data from LSP on both sides of the +-- request/response barrier. For example, you can use it to resolve what node +-- in the AST the incoming range refers to. This functionality is driven via +-- 'IsTarget'. +-- +-- the @payload@ is used for data you'd explicitly like to send from the +-- request to the response. It's like @target@, but only gets computed once. +-- This is beneficial if you can do it, but requires that your data is +-- serializable via JSON. +data Continuation sort target payload = Continuation + { c_sort :: sort + , c_makeCommand :: SynthesizeCommand target payload + , c_runCommand + :: LspEnv + -> TargetArgs target + -> FileContext + -> payload + -> MaybeT (LspM Plugin.Config) [ContinuationResult] + } + + +------------------------------------------------------------------------------ +-- | What file are we looking at, and what bit of it? +data FileContext = FileContext + { fc_uri :: Uri + , fc_range :: Maybe (Tracked 'Current Range) + -- ^ For code actions, this is 'Just'. For code lenses, you'll get + -- a 'Nothing' in the request, and a 'Just' in the response. + } + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (A.ToJSON, A.FromJSON) + + +------------------------------------------------------------------------------ +-- | Everything we need to resolve continuations. +data LspEnv = LspEnv + { le_ideState :: IdeState + , le_pluginId :: PluginId + , le_dflags :: DynFlags + , le_config :: Config + , le_fileContext :: FileContext + } + + +------------------------------------------------------------------------------ +-- | Extract some information from LSP, so it can be passed to the requests and +-- responses of a 'Continuation'. +class IsTarget t where + type TargetArgs t + fetchTargetArgs + :: LspEnv + -> MaybeT (LspM Plugin.Config) (TargetArgs t) + +------------------------------------------------------------------------------ +-- | A 'HoleTarget' is a target (see 'IsTarget') which succeeds if the given +-- range is an HsExpr hole. It gives continuations access to the resulting +-- tactic judgement. +data HoleTarget = HoleTarget + deriving stock (Eq, Ord, Show, Enum, Bounded) + +getNfp :: Applicative m => Uri -> MaybeT m NormalizedFilePath +getNfp = MaybeT . pure . uriToNormalizedFilePath . toNormalizedUri + +instance IsTarget HoleTarget where + type TargetArgs HoleTarget = HoleJudgment + fetchTargetArgs LspEnv{..} = do + let FileContext{..} = le_fileContext + range <- MaybeT $ pure fc_range + nfp <- getNfp fc_uri + mapMaybeT liftIO $ judgementForHole le_ideState nfp range le_config + diff --git a/old/src/Wingman/Auto.hs b/old/src/Wingman/Auto.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/CaseSplit.hs b/old/src/Wingman/CaseSplit.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/CodeGen.hs b/old/src/Wingman/CodeGen.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/CodeGen/Utils.hs b/old/src/Wingman/CodeGen/Utils.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Context.hs b/old/src/Wingman/Context.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Debug.hs b/old/src/Wingman/Debug.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/EmptyCase.hs b/old/src/Wingman/EmptyCase.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/GHC.hs b/old/src/Wingman/GHC.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Judgements.hs b/old/src/Wingman/Judgements.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Judgements/SYB.hs b/old/src/Wingman/Judgements/SYB.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Judgements/Theta.hs b/old/src/Wingman/Judgements/Theta.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/KnownStrategies.hs b/old/src/Wingman/KnownStrategies.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/KnownStrategies/QuickCheck.hs b/old/src/Wingman/KnownStrategies/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/LanguageServer.hs b/old/src/Wingman/LanguageServer.hs new file mode 100644 --- /dev/null +++ b/old/src/Wingman/LanguageServer.hs @@ -0,0 +1,660 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE NoMonoLocalBinds #-} + +module Wingman.LanguageServer where + +import Control.Arrow ((***)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.RWS +import Control.Monad.State (State, evalState) +import Control.Monad.Trans.Maybe +import Data.Bifunctor (first) +import Data.Coerce +import Data.Functor ((<&>)) +import Data.Functor.Identity (runIdentity) +import qualified Data.HashMap.Strict as Map +import Data.IORef (readIORef) +import qualified Data.Map as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Traversable +import Development.IDE (hscEnv, getFilesOfInterestUntracked, ShowDiagnostic (ShowDiag), srcSpanToRange, defineNoDiagnostics, IdeAction) +import Development.IDE.Core.PositionMapping (idDelta) +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules (usePropertyAction) +import Development.IDE.Core.Service (runAction) +import Development.IDE.Core.Shake (IdeState (..), uses, define, use, addPersistentRule) +import qualified Development.IDE.Core.Shake as IDE +import Development.IDE.Core.UseStale +import Development.IDE.GHC.Compat hiding (empty) +import Development.IDE.GHC.Compat.ExactPrint +import qualified Development.IDE.GHC.Compat.Util as FastString +import Development.IDE.GHC.Error (realSrcSpanToRange) +import Development.IDE.GHC.ExactPrint hiding (LogShake, Log) +import Development.IDE.Graph (Action, RuleResult, Rules, action) +import Development.IDE.Graph.Classes (Hashable, NFData) +import Development.IDE.Spans.LocalBindings (Bindings, getDefiningBindings) +import GHC.Generics (Generic) +import Generics.SYB hiding (Generic) +import Ide.Plugin.Properties +import Ide.Types (PluginId) +import Language.Haskell.GHC.ExactPrint (Transform, modifyAnnsT, addAnnotationsForPretty) +import Language.LSP.Server (MonadLsp, sendNotification) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import Language.LSP.Types.Capabilities +import Prelude hiding (span) +import Retrie (transformA) +import Wingman.Context +import Wingman.GHC +import Wingman.Judgements +import Wingman.Judgements.SYB (everythingContaining, metaprogramQ, metaprogramAtQ) +import Wingman.Judgements.Theta +import Wingman.Range +import Wingman.StaticPlugin (pattern WingmanMetaprogram, pattern MetaprogramSyntax) +import Wingman.Types +import Development.IDE.Types.Logger (Recorder, cmapWithPrio, WithPriority, Pretty (pretty)) +import qualified Development.IDE.Core.Shake as Shake + + +newtype Log + = LogShake Shake.Log + deriving Show + +instance Pretty Log where + pretty = \case + LogShake shakeLog -> pretty shakeLog + +tacticDesc :: T.Text -> T.Text +tacticDesc name = "fill the hole using the " <> name <> " tactic" + + +------------------------------------------------------------------------------ +-- | The name of the command for the LS. +tcCommandName :: TacticCommand -> T.Text +tcCommandName = T.pack . show + + +runIde :: String -> String -> IdeState -> Action a -> IO a +runIde herald action state = runAction ("Wingman." <> herald <> "." <> action) state + +runIdeAction :: String -> String -> IdeState -> IdeAction a -> IO a +runIdeAction herald action state = IDE.runIdeAction ("Wingman." <> herald <> "." <> action) (shakeExtras state) + + +runCurrentIde + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => String + -> IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO (Tracked 'Current r) +runCurrentIde herald state nfp a = + MaybeT $ fmap (fmap unsafeMkCurrent) $ runIde herald (show a) state $ use a nfp + + +runStaleIde + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => String + -> IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO (TrackedStale r) +runStaleIde herald state nfp a = + MaybeT $ runIde herald (show a) state $ useWithStale a nfp + + +unsafeRunStaleIde + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => String + -> IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO r +unsafeRunStaleIde herald state nfp a = do + (r, _) <- MaybeT $ runIde herald (show a) state $ IDE.useWithStale a nfp + pure r + +unsafeRunStaleIdeFast + :: forall a r + . ( r ~ RuleResult a + , Eq a , Hashable a , Show a , Typeable a , NFData a + , Show r, Typeable r, NFData r + ) + => String + -> IdeState + -> NormalizedFilePath + -> a + -> MaybeT IO r +unsafeRunStaleIdeFast herald state nfp a = do + (r, _) <- MaybeT $ runIdeAction herald (show a) state $ IDE.useWithStaleFast a nfp + pure r + + +------------------------------------------------------------------------------ + +properties :: Properties + '[ 'PropertyKey "hole_severity" ('TEnum (Maybe DiagnosticSeverity)) + , 'PropertyKey "max_use_ctor_actions" 'TInteger + , 'PropertyKey "timeout_duration" 'TInteger + , 'PropertyKey "auto_gas" 'TInteger + , 'PropertyKey "proofstate_styling" 'TBoolean + ] +properties = emptyProperties + & defineBooleanProperty #proofstate_styling + "Should Wingman emit styling markup when showing metaprogram proof states?" True + & defineIntegerProperty #auto_gas + "The depth of the search tree when performing \"Attempt to fill hole\". Bigger values will be able to derive more solutions, but will take exponentially more time." 4 + & defineIntegerProperty #timeout_duration + "The timeout for Wingman actions, in seconds" 2 + & defineIntegerProperty #max_use_ctor_actions + "Maximum number of `Use constructor ` code actions that can appear" 5 + & defineEnumProperty #hole_severity + "The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities." + [ (Just DsError, "error") + , (Just DsWarning, "warning") + , (Just DsInfo, "info") + , (Just DsHint, "hint") + , (Nothing, "none") + ] + Nothing + + +-- | Get the the plugin config +getTacticConfigAction :: PluginId -> Action Config +getTacticConfigAction pId = + Config + <$> usePropertyAction #max_use_ctor_actions pId properties + <*> usePropertyAction #timeout_duration pId properties + <*> usePropertyAction #auto_gas pId properties + <*> usePropertyAction #proofstate_styling pId properties + + +getIdeDynflags + :: IdeState + -> NormalizedFilePath + -> MaybeT IO DynFlags +getIdeDynflags state nfp = do + -- Ok to use the stale 'ModIface', since all we need is its 'DynFlags' + -- which don't change very often. + msr <- unsafeRunStaleIde "getIdeDynflags" state nfp GetModSummaryWithoutTimestamps + pure $ ms_hspp_opts $ msrModSummary msr + +getAllMetaprograms :: Data a => a -> [String] +getAllMetaprograms = everything (<>) $ mkQ mempty $ \case + WingmanMetaprogram fs -> [ FastString.unpackFS fs ] + (_ :: HsExpr GhcTc) -> mempty + + +------------------------------------------------------------------------------ +-- | Find the last typechecked module, and find the most specific span, as well +-- as the judgement at the given range. +judgementForHole + :: IdeState + -> NormalizedFilePath + -> Tracked 'Current Range + -> Config + -> MaybeT IO HoleJudgment +judgementForHole state nfp range cfg = do + let stale a = runStaleIde "judgementForHole" state nfp a + + TrackedStale asts amapping <- stale GetHieAst + case unTrack asts of + HAR _ _ _ _ (HieFromDisk _) -> fail "Need a fresh hie file" + HAR _ (unsafeCopyAge asts -> hf) _ _ HieFresh -> do + range' <- liftMaybe $ mapAgeFrom amapping range + binds <- stale GetBindings + tcg@(TrackedStale tcg_t tcg_map) + <- fmap (fmap tmrTypechecked) + $ stale TypeCheck + + hscenv <- stale GhcSessionDeps + + (rss, g) <- liftMaybe $ getSpanAndTypeAtHole range' hf + + new_rss <- liftMaybe $ mapAgeTo amapping rss + tcg_rss <- liftMaybe $ mapAgeFrom tcg_map new_rss + + -- KnownThings is just the instances in scope. There are no ranges + -- involved, so it's not crucial to track ages. + let henv = untrackedStaleValue hscenv + eps <- liftIO $ readIORef $ hsc_EPS $ hscEnv henv + + (jdg, ctx) <- liftMaybe $ mkJudgementAndContext cfg g binds new_rss tcg (hscEnv henv) eps + let mp = getMetaprogramAtSpan (fmap (`RealSrcSpan` Nothing) tcg_rss) tcg_t + + dflags <- getIdeDynflags state nfp + pure $ HoleJudgment + { hj_range = fmap realSrcSpanToRange new_rss + , hj_jdg = jdg + , hj_ctx = ctx + , hj_dflags = dflags + , hj_hole_sort = holeSortFor mp + } + + +holeSortFor :: Maybe T.Text -> HoleSort +holeSortFor = maybe Hole Metaprogram + + +mkJudgementAndContext + :: Config + -> Type + -> TrackedStale Bindings + -> Tracked 'Current RealSrcSpan + -> TrackedStale TcGblEnv + -> HscEnv + -> ExternalPackageState + -> Maybe (Judgement, Context) +mkJudgementAndContext cfg g (TrackedStale binds bmap) rss (TrackedStale tcg tcgmap) hscenv eps = do + binds_rss <- mapAgeFrom bmap rss + tcg_rss <- mapAgeFrom tcgmap rss + + let tcs = fmap tcg_binds tcg + ctx = mkContext cfg + (mapMaybe (sequenceA . (occName *** coerce)) + $ unTrack + $ getDefiningBindings <$> binds <*> binds_rss) + (unTrack tcg) + hscenv + eps + evidence + top_provs = getRhsPosVals tcg_rss tcs + already_destructed = getAlreadyDestructed (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs + local_hy = spliceProvenance top_provs + $ hypothesisFromBindings binds_rss binds + evidence = getEvidenceAtHole (fmap (`RealSrcSpan` Nothing) tcg_rss) tcs + cls_hy = foldMap evidenceToHypothesis evidence + subst = ts_unifier $ evidenceToSubst evidence defaultTacticState + pure + ( disallowing AlreadyDestructed already_destructed + $ fmap (CType . substTyAddInScope subst . unCType) $ + mkFirstJudgement + ctx + (local_hy <> cls_hy) + (isRhsHoleWithoutWhere tcg_rss tcs) + g + , ctx + ) + + +------------------------------------------------------------------------------ +-- | Determine which bindings have already been destructed by the location of +-- the hole. +getAlreadyDestructed + :: Tracked age SrcSpan + -> Tracked age (LHsBinds GhcTc) + -> Set OccName +getAlreadyDestructed (unTrack -> span) (unTrack -> binds) = + everythingContaining span + (mkQ mempty $ \case + Case (HsVar _ (L _ (occName -> var))) _ -> + S.singleton var + (_ :: HsExpr GhcTc) -> mempty + ) binds + + +getSpanAndTypeAtHole + :: Tracked age Range + -> Tracked age (HieASTs Type) + -> Maybe (Tracked age RealSrcSpan, Type) +getSpanAndTypeAtHole r@(unTrack -> range) (unTrack -> hf) = do + join $ listToMaybe $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast -> + case selectSmallestContaining (rangeToRealSrcSpan (FastString.unpackFS fs) range) ast of + Nothing -> Nothing + Just ast' -> do + let info = nodeInfo ast' + ty <- listToMaybe $ nodeType info + guard $ ("HsUnboundVar","HsExpr") `S.member` nodeAnnotations info + -- Ensure we're actually looking at a hole here + occ <- (either (const Nothing) (Just . occName) =<<) + . listToMaybe + . S.toList + . M.keysSet + $ nodeIdentifiers info + guard $ isHole occ + pure (unsafeCopyAge r $ nodeSpan ast', ty) + + + +------------------------------------------------------------------------------ +-- | Combine two (possibly-overlapping) hypotheses; using the provenance from +-- the first hypothesis if the bindings overlap. +spliceProvenance + :: Hypothesis a -- ^ Bindings to keep + -> Hypothesis a -- ^ Bindings to keep if they don't overlap with the first set + -> Hypothesis a +spliceProvenance top x = + let bound = S.fromList $ fmap hi_name $ unHypothesis top + in mappend top $ Hypothesis . filter (flip S.notMember bound . hi_name) $ unHypothesis x + + +------------------------------------------------------------------------------ +-- | Compute top-level position vals of a function +getRhsPosVals + :: Tracked age RealSrcSpan + -> Tracked age TypecheckedSource + -> Hypothesis CType +getRhsPosVals (unTrack -> rss) (unTrack -> tcs) + = everything (<>) (mkQ mempty $ \case + TopLevelRHS name ps + (L (RealSrcSpan span _) -- body with no guards and a single defn + (HsVar _ (L _ hole))) + _ + | containsSpan rss span -- which contains our span + , isHole $ occName hole -- and the span is a hole + -> flip evalState 0 $ buildTopLevelHypothesis name ps + _ -> mempty + ) tcs + + +------------------------------------------------------------------------------ +-- | Construct a hypothesis given the patterns from the left side of a HsMatch. +-- These correspond to things that the user put in scope before running +-- tactics. +buildTopLevelHypothesis + :: OccName -- ^ Function name + -> [PatCompat GhcTc] + -> State Int (Hypothesis CType) +buildTopLevelHypothesis name ps = do + fmap mconcat $ + for (zip [0..] ps) $ \(ix, p) -> + buildPatHy (TopLevelArgPrv name ix $ length ps) p + + +------------------------------------------------------------------------------ +-- | Construct a hypothesis for a single pattern, including building +-- sub-hypotheses for constructor pattern matches. +buildPatHy :: Provenance -> PatCompat GhcTc -> State Int (Hypothesis CType) +buildPatHy prov (fromPatCompat -> p0) = + case p0 of + VarPat _ x -> pure $ mkIdHypothesis (unLoc x) prov + LazyPat _ p -> buildPatHy prov p + AsPat _ x p -> do + hy' <- buildPatHy prov p + pure $ mkIdHypothesis (unLoc x) prov <> hy' + ParPat _ p -> buildPatHy prov p + BangPat _ p -> buildPatHy prov p + ViewPat _ _ p -> buildPatHy prov p + -- Desugar lists into cons + ListPat _ [] -> pure mempty + ListPat x@(ListPatTc ty _) (p : ps) -> + mkDerivedConHypothesis prov (RealDataCon consDataCon) [ty] + [ (0, p) + , (1, toPatCompat $ ListPat x ps) + ] + -- Desugar tuples into an explicit constructor + TuplePat tys pats boxity -> + mkDerivedConHypothesis + prov + (RealDataCon $ tupleDataCon boxity $ length pats) + tys + $ zip [0.. ] pats +#if __GLASGOW_HASKELL__ >= 900 + ConPat {pat_con = (L _ con), pat_con_ext = ConPatTc {cpt_arg_tys = args}, pat_args = f} -> +#else + ConPatOut {pat_con = (L _ con), pat_arg_tys = args, pat_args = f} -> +#endif + case f of + PrefixCon l_pgt -> + mkDerivedConHypothesis prov con args $ zip [0..] l_pgt + InfixCon pgt pgt5 -> + mkDerivedConHypothesis prov con args $ zip [0..] [pgt, pgt5] + RecCon r -> + mkDerivedRecordHypothesis prov con args r + SigPat _ p _ -> buildPatHy prov p + _ -> pure mempty + + +------------------------------------------------------------------------------ +-- | Like 'mkDerivedConHypothesis', but for record patterns. +mkDerivedRecordHypothesis + :: Provenance + -> ConLike -- ^ Destructing constructor + -> [Type] -- ^ Applied type variables + -> HsRecFields GhcTc (PatCompat GhcTc) + -> State Int (Hypothesis CType) +mkDerivedRecordHypothesis prov dc args (HsRecFields (fmap unLoc -> fs) _) + | Just rec_fields <- getRecordFields dc + = do + let field_lookup = M.fromList $ zip (fmap (occNameFS . fst) rec_fields) [0..] + mkDerivedConHypothesis prov dc args $ fs <&> \(HsRecField (L _ rec_occ) p _) -> + ( field_lookup M.! (occNameFS $ occName $ unLoc $ rdrNameFieldOcc rec_occ) + , p + ) +mkDerivedRecordHypothesis _ _ _ _ = + error "impossible! using record pattern on something that isn't a record" + + +------------------------------------------------------------------------------ +-- | Construct a fake variable name. Used to track the provenance of top-level +-- pattern matches which otherwise wouldn't have anything to attach their +-- 'TopLevelArgPrv' to. +mkFakeVar :: State Int OccName +mkFakeVar = do + i <- get + put $ i + 1 + pure $ mkVarOcc $ "_" <> show i + + +------------------------------------------------------------------------------ +-- | Construct a fake variable to attach the current 'Provenance' to, and then +-- build a sub-hypothesis for the pattern match. +mkDerivedConHypothesis + :: Provenance + -> ConLike -- ^ Destructing constructor + -> [Type] -- ^ Applied type variables + -> [(Int, PatCompat GhcTc)] -- ^ Patterns, and their order in the data con + -> State Int (Hypothesis CType) +mkDerivedConHypothesis prov dc args ps = do + var <- mkFakeVar + hy' <- fmap mconcat $ + for ps $ \(ix, p) -> do + let prov' = PatternMatchPrv + $ PatVal (Just var) + (S.singleton var <> provAncestryOf prov) + (Uniquely dc) + ix + buildPatHy prov' p + pure + $ mappend hy' + $ Hypothesis + $ pure + $ HyInfo var (DisallowedPrv AlreadyDestructed prov) + $ CType + -- TODO(sandy): This is the completely wrong type, but we don't have a good + -- way to get the real one. It's probably OK though, since we're generating + -- this term with a disallowed provenance, and it doesn't actually exist + -- anyway. + $ conLikeResTy dc args + + +------------------------------------------------------------------------------ +-- | Build a 'Hypothesis' given an 'Id'. +mkIdHypothesis :: Id -> Provenance -> Hypothesis CType +mkIdHypothesis (splitId -> (name, ty)) prov = + Hypothesis $ pure $ HyInfo name prov ty + + +------------------------------------------------------------------------------ +-- | Is this hole immediately to the right of an equals sign --- and is there +-- no where clause attached to it? +-- +-- It's important that there is no where clause because otherwise it gets +-- clobbered. See #2183 for an example. +-- +-- This isn't a perfect check, and produces some ugly code. But it's much much +-- better than the alternative, which is to destructively modify the user's +-- AST. +isRhsHoleWithoutWhere + :: Tracked age RealSrcSpan + -> Tracked age TypecheckedSource + -> Bool +isRhsHoleWithoutWhere (unTrack -> rss) (unTrack -> tcs) = + everything (||) (mkQ False $ \case + TopLevelRHS _ _ + (L (RealSrcSpan span _) _) + (EmptyLocalBinds _) -> containsSpan rss span + _ -> False + ) tcs + + +ufmSeverity :: UserFacingMessage -> MessageType +ufmSeverity NotEnoughGas = MtInfo +ufmSeverity TacticErrors = MtError +ufmSeverity TimedOut = MtInfo +ufmSeverity NothingToDo = MtInfo +ufmSeverity (InfrastructureError _) = MtError + + +mkShowMessageParams :: UserFacingMessage -> ShowMessageParams +mkShowMessageParams ufm = ShowMessageParams (ufmSeverity ufm) $ T.pack $ show ufm + + +showLspMessage :: MonadLsp cfg m => ShowMessageParams -> m () +showLspMessage = sendNotification SWindowShowMessage + + +-- This rule only exists for generating file diagnostics +-- so the RuleResult is empty +data WriteDiagnostics = WriteDiagnostics + deriving (Eq, Show, Typeable, Generic) + +instance Hashable WriteDiagnostics +instance NFData WriteDiagnostics + +type instance RuleResult WriteDiagnostics = () + +data GetMetaprograms = GetMetaprograms + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetMetaprograms +instance NFData GetMetaprograms + +type instance RuleResult GetMetaprograms = [(Tracked 'Current RealSrcSpan, T.Text)] + +wingmanRules :: Recorder (WithPriority Log) -> PluginId -> Rules () +wingmanRules recorder plId = do + define (cmapWithPrio LogShake recorder) $ \WriteDiagnostics nfp -> + usePropertyAction #hole_severity plId properties >>= \case + Nothing -> pure (mempty, Just ()) + Just severity -> + use GetParsedModule nfp >>= \case + Nothing -> + pure ([], Nothing) + Just pm -> do + let holes :: [Range] + holes = + everything (<>) + (mkQ mempty $ \case + L span (HsVar _ (L _ name)) + | isHole (occName name) -> + maybeToList $ srcSpanToRange span +#if __GLASGOW_HASKELL__ >= 900 + L span (HsUnboundVar _ occ) +#else + L span (HsUnboundVar _ (TrueExprHole occ)) +#endif + | isHole occ -> + maybeToList $ srcSpanToRange span + (_ :: LHsExpr GhcPs) -> mempty + ) $ pm_parsed_source pm + pure + ( fmap (\r -> (nfp, ShowDiag, mkDiagnostic severity r)) holes + , Just () + ) + + defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetMetaprograms nfp -> do + TrackedStale tcg tcg_map <- fmap tmrTypechecked <$> useWithStale_ TypeCheck nfp + let scrutinees = traverse (metaprogramQ . tcg_binds) tcg + return $ Just $ flip mapMaybe scrutinees $ \aged@(unTrack -> (ss, program)) -> do + case ss of + RealSrcSpan r _ -> do + rss' <- mapAgeTo tcg_map $ unsafeCopyAge aged r + pure (rss', program) + UnhelpfulSpan _ -> Nothing + + -- This persistent rule helps to avoid blocking HLS hover providers at startup + -- Without it, the GetMetaprograms rule blocks on typecheck and prevents other + -- hover providers from being used to produce a response + addPersistentRule GetMetaprograms $ \_ -> return $ Just ([], idDelta, Nothing) + + action $ do + files <- getFilesOfInterestUntracked + void $ uses WriteDiagnostics $ Map.keys files + + +mkDiagnostic :: DiagnosticSeverity -> Range -> Diagnostic +mkDiagnostic severity r = + Diagnostic r + (Just severity) + (Just $ InR "hole") + (Just "wingman") + "Hole" + (Just $ List [DtUnnecessary]) + Nothing + + +------------------------------------------------------------------------------ +-- | Transform a 'Graft' over the AST into a 'WorkspaceEdit'. +mkWorkspaceEdits + :: DynFlags + -> ClientCapabilities + -> Uri + -> Annotated ParsedSource + -> Graft (Either String) ParsedSource + -> Either UserFacingMessage WorkspaceEdit +mkWorkspaceEdits dflags ccs uri pm g = do + let pm' = runIdentity $ transformA pm annotateMetaprograms + let response = transform dflags ccs uri g pm' + in first (InfrastructureError . T.pack) response + + +------------------------------------------------------------------------------ +-- | Add ExactPrint annotations to every metaprogram in the source tree. +-- Usually the ExactPrint module can do this for us, but we've enabled +-- QuasiQuotes, so the round-trip print/parse journey will crash. +annotateMetaprograms :: Data a => a -> Transform a +annotateMetaprograms = everywhereM $ mkM $ \case + L ss (WingmanMetaprogram mp) -> do + let x = L ss $ MetaprogramSyntax mp + let anns = addAnnotationsForPretty [] x mempty + modifyAnnsT $ mappend anns + pure x + (x :: LHsExpr GhcPs) -> pure x + + +------------------------------------------------------------------------------ +-- | Find the source of a tactic metaprogram at the given span. +getMetaprogramAtSpan + :: Tracked age SrcSpan + -> Tracked age TcGblEnv + -> Maybe T.Text +getMetaprogramAtSpan (unTrack -> ss) + = fmap snd + . listToMaybe + . metaprogramAtQ ss + . tcg_binds + . unTrack + diff --git a/old/src/Wingman/LanguageServer/Metaprogram.hs b/old/src/Wingman/LanguageServer/Metaprogram.hs new file mode 100644 --- /dev/null +++ b/old/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 <- liftIO $ runIde "plugin" "config" state (getTacticConfigAction plId) + liftIO $ fromMaybeT (Right Nothing) $ do + holes <- stale GetMetaprograms + + fmap (Right . Just) $ + case find (flip containsSpan (unTrack loc) . unTrack . fst) holes of + Just (trss, program) -> do + let tr_range = fmap realSrcSpanToRange trss + rsl = realSrcSpanStart $ unTrack trss + HoleJudgment{hj_jdg=jdg, hj_ctx=ctx} <- judgementForHole state nfp tr_range cfg + z <- liftIO $ attempt_it rsl ctx jdg $ T.unpack program + pure $ Hover + { _contents = HoverContents + $ MarkupContent MkMarkdown + $ either T.pack T.pack z + , _range = Just $ unTrack tr_range + } + Nothing -> empty +hoverProvider _ _ _ = pure $ Right Nothing + +fromMaybeT :: Functor m => a -> MaybeT m a -> m a +fromMaybeT def = fmap (fromMaybe def) . runMaybeT diff --git a/old/src/Wingman/LanguageServer/TacticProviders.hs b/old/src/Wingman/LanguageServer/TacticProviders.hs new file mode 100644 --- /dev/null +++ b/old/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 hiding (Config) +import Language.LSP.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..)) +import Prelude hiding (span) +import Wingman.AbstractLSP.Types +import Wingman.Auto +import Wingman.GHC +import Wingman.Judgements +import Wingman.Machinery (useNameFromHypothesis, uncoveredDataCons) +import Wingman.Metaprogramming.Parser (parseMetaprogram) +import Wingman.Tactics +import Wingman.Types + + +------------------------------------------------------------------------------ +-- | A mapping from tactic commands to actual tactics for refinery. +commandTactic :: TacticCommand -> T.Text -> TacticsM () +commandTactic Auto = const auto +commandTactic Intros = const intros +commandTactic IntroAndDestruct = const introAndDestruct +commandTactic Destruct = useNameFromHypothesis destruct . mkVarOcc . T.unpack +commandTactic DestructPun = useNameFromHypothesis destructPun . mkVarOcc . T.unpack +commandTactic Homomorphism = useNameFromHypothesis homo . mkVarOcc . T.unpack +commandTactic DestructLambdaCase = const destructLambdaCase +commandTactic HomomorphismLambdaCase = const homoLambdaCase +commandTactic DestructAll = const destructAll +commandTactic UseDataCon = userSplit . mkVarOcc . T.unpack +commandTactic Refine = const refine +commandTactic BeginMetaprogram = const metaprogram +commandTactic RunMetaprogram = parseMetaprogram + + +------------------------------------------------------------------------------ +-- | The LSP kind +tacticKind :: TacticCommand -> T.Text +tacticKind Auto = "fillHole" +tacticKind Intros = "introduceLambda" +tacticKind IntroAndDestruct = "introduceAndDestruct" +tacticKind Destruct = "caseSplit" +tacticKind DestructPun = "caseSplitPun" +tacticKind Homomorphism = "homomorphicCaseSplit" +tacticKind DestructLambdaCase = "lambdaCase" +tacticKind HomomorphismLambdaCase = "homomorphicLambdaCase" +tacticKind DestructAll = "splitFuncArgs" +tacticKind UseDataCon = "useConstructor" +tacticKind Refine = "refine" +tacticKind BeginMetaprogram = "beginMetaprogram" +tacticKind RunMetaprogram = "runMetaprogram" + + +------------------------------------------------------------------------------ +-- | Whether or not this code action is preferred -- ostensibly refers to +-- whether or not we can bind it to a key in vs code? +tacticPreferred :: TacticCommand -> Bool +tacticPreferred Auto = True +tacticPreferred Intros = True +tacticPreferred IntroAndDestruct = True +tacticPreferred Destruct = True +tacticPreferred DestructPun = False +tacticPreferred Homomorphism = True +tacticPreferred DestructLambdaCase = False +tacticPreferred HomomorphismLambdaCase = False +tacticPreferred DestructAll = True +tacticPreferred UseDataCon = True +tacticPreferred Refine = True +tacticPreferred BeginMetaprogram = False +tacticPreferred RunMetaprogram = True + + +mkTacticKind :: TacticCommand -> CodeActionKind +mkTacticKind = + CodeActionUnknown . mappend "refactor.wingman." . tacticKind + + +------------------------------------------------------------------------------ +-- | Mapping from tactic commands to their contextual providers. See 'provide', +-- 'filterGoalType' and 'filterBindingType' for the nitty gritty. +commandProvider :: TacticCommand -> TacticProvider +commandProvider Auto = + requireHoleSort (== Hole) $ + provide Auto "" +commandProvider Intros = + requireHoleSort (== Hole) $ + filterGoalType isFunction $ + provide Intros "" +commandProvider IntroAndDestruct = + requireHoleSort (== Hole) $ + filterGoalType (liftLambdaCase False (\_ -> isJust . algebraicTyCon)) $ + provide IntroAndDestruct "" +commandProvider Destruct = + requireHoleSort (== Hole) $ + filterBindingType destructFilter $ \occ _ -> + provide Destruct $ T.pack $ occNameString occ +commandProvider DestructPun = + requireHoleSort (== Hole) $ + filterBindingType destructPunFilter $ \occ _ -> + provide DestructPun $ T.pack $ occNameString occ +commandProvider Homomorphism = + requireHoleSort (== Hole) $ + filterBindingType homoFilter $ \occ _ -> + provide Homomorphism $ T.pack $ occNameString occ +commandProvider DestructLambdaCase = + requireHoleSort (== Hole) $ + requireExtension LambdaCase $ + filterGoalType (isJust . lambdaCaseable) $ + provide DestructLambdaCase "" +commandProvider HomomorphismLambdaCase = + requireHoleSort (== Hole) $ + requireExtension LambdaCase $ + filterGoalType (liftLambdaCase False homoFilter) $ + provide HomomorphismLambdaCase "" +commandProvider DestructAll = + requireHoleSort (== Hole) $ + withJudgement $ \jdg -> + case _jIsTopHole jdg && jHasBoundArgs jdg of + True -> provide DestructAll "" + False -> mempty +commandProvider UseDataCon = + requireHoleSort (== Hole) $ + withConfig $ \cfg -> + filterTypeProjection + ( guardLength (<= cfg_max_use_ctor_actions cfg) + . maybe [] fst + . tacticsGetDataCons + ) $ \dcon -> + provide UseDataCon + . T.pack + . occNameString + . occName + $ dataConName dcon +commandProvider Refine = + requireHoleSort (== Hole) $ + provide Refine "" +commandProvider BeginMetaprogram = + requireHoleSort (== Hole) $ + provide BeginMetaprogram "" +commandProvider RunMetaprogram = + withMetaprogram $ \mp -> + provide RunMetaprogram mp + + +------------------------------------------------------------------------------ +-- | Return an empty list if the given predicate doesn't hold over the length +guardLength :: (Int -> Bool) -> [a] -> [a] +guardLength f as = bool [] as $ f $ length as + + +------------------------------------------------------------------------------ +-- | A 'TacticProvider' is a way of giving context-sensitive actions to the LS +-- UI. +type TacticProvider + = TacticProviderData + -> [(Metadata, T.Text)] + + +data TacticProviderData = TacticProviderData + { tpd_lspEnv :: LspEnv + , tpd_jdg :: Judgement + , tpd_hole_sort :: HoleSort + } + + +requireHoleSort :: (HoleSort -> Bool) -> TacticProvider -> TacticProvider +requireHoleSort p tp tpd = + case p $ tpd_hole_sort tpd of + True -> tp tpd + False -> [] + +withMetaprogram :: (T.Text -> TacticProvider) -> TacticProvider +withMetaprogram tp tpd = + case tpd_hole_sort tpd of + Metaprogram mp -> tp mp tpd + _ -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +requireExtension :: Extension -> TacticProvider -> TacticProvider +requireExtension ext tp tpd = + case xopt ext $ le_dflags $ tpd_lspEnv tpd of + True -> tp tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +filterGoalType :: (Type -> Bool) -> TacticProvider -> TacticProvider +filterGoalType p tp tpd = + case p $ unCType $ jGoal $ tpd_jdg tpd of + True -> tp tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Restrict a 'TacticProvider', making sure it appears only when the given +-- predicate holds for the goal. +withJudgement :: (Judgement -> TacticProvider) -> TacticProvider +withJudgement tp tpd = tp (tpd_jdg tpd) tpd + + +------------------------------------------------------------------------------ +-- | Multiply a 'TacticProvider' for each binding, making sure it appears only +-- when the given predicate holds over the goal and binding types. +filterBindingType + :: (Type -> Type -> Bool) -- ^ Goal and then binding types. + -> (OccName -> Type -> TacticProvider) + -> TacticProvider +filterBindingType p tp tpd = + let jdg = tpd_jdg tpd + hy = jLocalHypothesis jdg + g = jGoal jdg + in unHypothesis hy >>= \hi -> + let ty = unCType $ hi_type hi + in case p (unCType g) ty of + True -> tp (hi_name hi) ty tpd + False -> [] + + +------------------------------------------------------------------------------ +-- | Multiply a 'TacticProvider' by some feature projection out of the goal +-- type. Used e.g. to crete a code action for every data constructor. +filterTypeProjection + :: (Type -> [a]) -- ^ Features of the goal to look into further + -> (a -> TacticProvider) + -> TacticProvider +filterTypeProjection p tp tpd = + (p $ unCType $ jGoal $ tpd_jdg tpd) >>= \a -> + tp a tpd + + +------------------------------------------------------------------------------ +-- | Get access to the 'Config' when building a 'TacticProvider'. +withConfig :: (Config -> TacticProvider) -> TacticProvider +withConfig tp tpd = tp (le_config $ tpd_lspEnv tpd) tpd + + +------------------------------------------------------------------------------ +-- | Terminal constructor for providing context-sensitive tactics. Tactics +-- given by 'provide' are always available. +provide :: TacticCommand -> T.Text -> TacticProvider +provide tc name _ = + pure (Metadata (tacticTitle tc name) (mkTacticKind tc) (tacticPreferred tc), name) + + +------------------------------------------------------------------------------ +-- | Construct a 'CommandId' +tcCommandId :: TacticCommand -> CommandId +tcCommandId c = coerce $ T.pack $ "tactics" <> show c <> "Command" + + +------------------------------------------------------------------------------ +-- | We should show homos only when the goal type is the same as the binding +-- type, and that both are usual algebraic types. +homoFilter :: Type -> Type -> Bool +homoFilter codomain domain = + case uncoveredDataCons domain codomain of + Just s -> S.null s + _ -> False + + +------------------------------------------------------------------------------ +-- | Lift a function of (codomain, domain) over a lambda case. +liftLambdaCase :: r -> (Type -> Type -> r) -> Type -> r +liftLambdaCase nil f t = + case tacticsSplitFunTy t of + (_, _, arg : _, res) -> f res $ scaledThing arg + _ -> nil + + + +------------------------------------------------------------------------------ +-- | We should show destruct for bindings only when those bindings have usual +-- algebraic types. +destructFilter :: Type -> Type -> Bool +destructFilter _ (algebraicTyCon -> Just _) = True +destructFilter _ _ = False + + +------------------------------------------------------------------------------ +-- | We should show destruct punning for bindings only when those bindings have +-- usual algebraic types, and when any of their data constructors are records. +destructPunFilter :: Type -> Type -> Bool +destructPunFilter _ (algebraicTyCon -> Just tc) = + not . all (null . dataConFieldLabels) $ tyConDataCons tc +destructPunFilter _ _ = False + + +instance IsContinuationSort TacticCommand where + toCommandId = tcCommandId + diff --git a/old/src/Wingman/Machinery.hs b/old/src/Wingman/Machinery.hs new file mode 100644 --- /dev/null +++ b/old/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) + $ 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/old/src/Wingman/Metaprogramming/Lexer.hs b/old/src/Wingman/Metaprogramming/Lexer.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Metaprogramming/Parser.hs b/old/src/Wingman/Metaprogramming/Parser.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Metaprogramming/Parser.hs-boot b/old/src/Wingman/Metaprogramming/Parser.hs-boot new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Metaprogramming/Parser/Documentation.hs b/old/src/Wingman/Metaprogramming/Parser/Documentation.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Metaprogramming/ProofState.hs b/old/src/Wingman/Metaprogramming/ProofState.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Naming.hs b/old/src/Wingman/Naming.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Plugin.hs b/old/src/Wingman/Plugin.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Range.hs b/old/src/Wingman/Range.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Simplify.hs b/old/src/Wingman/Simplify.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/StaticPlugin.hs b/old/src/Wingman/StaticPlugin.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Tactics.hs b/old/src/Wingman/Tactics.hs new file mode 100644 --- /dev/null +++ b/old/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/old/src/Wingman/Types.hs b/old/src/Wingman/Types.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/AutoTupleSpec.hs b/old/test/AutoTupleSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/AutoSpec.hs b/old/test/CodeAction/AutoSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/DestructAllSpec.hs b/old/test/CodeAction/DestructAllSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/DestructPunSpec.hs b/old/test/CodeAction/DestructPunSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/DestructSpec.hs b/old/test/CodeAction/DestructSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/IntroDestructSpec.hs b/old/test/CodeAction/IntroDestructSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/IntrosSpec.hs b/old/test/CodeAction/IntrosSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/RefineSpec.hs b/old/test/CodeAction/RefineSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/RunMetaprogramSpec.hs b/old/test/CodeAction/RunMetaprogramSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeAction/UseDataConSpec.hs b/old/test/CodeAction/UseDataConSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/CodeLens/EmptyCaseSpec.hs b/old/test/CodeLens/EmptyCaseSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/ProviderSpec.hs b/old/test/ProviderSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/Spec.hs b/old/test/Spec.hs new file mode 100644 --- /dev/null +++ b/old/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/old/test/UnificationSpec.hs b/old/test/UnificationSpec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/Utils.hs b/old/test/Utils.hs new file mode 100644 --- /dev/null +++ b/old/test/Utils.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +module Utils where + +import Control.DeepSeq (deepseq) +import qualified Control.Exception as E +import Control.Lens hiding (List, failing, (<.>), (.=)) +import Control.Monad (unless, void) +import Control.Monad.IO.Class +import Data.Aeson +import Data.Foldable +import Data.Function (on) +import Data.IORef (writeIORef) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Ide.Plugin.Tactic as Tactic +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (actions, applyEdit, capabilities, executeCommand, id, line, message, name, rename, title) +import qualified Language.LSP.Types.Lens as J +import System.Directory (doesFileExist) +import System.FilePath +import Test.Hls +import Test.Hspec +import Test.Hspec.Formatters (FailureReason(ExpectedButGot)) +import Wingman.LanguageServer (mkShowMessageParams) +import Wingman.Types + + +plugin :: PluginTestDescriptor Log +plugin = mkPluginTestDescriptor Tactic.descriptor "tactics" + +------------------------------------------------------------------------------ +-- | Get a range at the given line and column corresponding to having nothing +-- selected. +-- +-- NB: These coordinates are in "file space", ie, 1-indexed. +pointRange :: Int -> Int -> Range +pointRange + (subtract 1 -> fromIntegral -> line) + (subtract 1 -> fromIntegral -> col) = + Range (Position line col) (Position line $ col + 1) + + +------------------------------------------------------------------------------ +-- | Get the title of a code action. +codeActionTitle :: (Command |? CodeAction) -> Maybe Text +codeActionTitle InL{} = Nothing +codeActionTitle (InR(CodeAction title _ _ _ _ _ _ _)) = Just title + + +resetGlobalHoleRef :: IO () +resetGlobalHoleRef = writeIORef globalHoleRef 0 + + +runSessionForTactics :: Session a -> IO a +runSessionForTactics act = do + recorder <- pluginTestRecorder + runSessionWithServer' + [plugin recorder] + def + (def { messageTimeout = 20 } ) + fullCaps + tacticPath + act + +------------------------------------------------------------------------------ +-- | Make a tactic unit test. +mkTest + :: Foldable t + => String -- ^ The test name + -> FilePath -- ^ The file name stem (without extension) to load + -> Int -- ^ Cursor line + -> Int -- ^ Cursor column + -> t ( Bool -> Bool -- Use 'not' for actions that shouldn't be present + , TacticCommand -- An expected command ... + , Text -- ... for this variable + ) -- ^ A collection of (un)expected code actions. + -> SpecWith (Arg Bool) +mkTest name fp line col ts = it name $ do + resetGlobalHoleRef + runSessionForTactics $ do + doc <- openDoc (fp <.> "hs") "haskell" + -- wait for diagnostics to start coming + void waitForDiagnostics + -- wait for the entire build to finish, so that Tactics code actions that + -- use stale data will get uptodate stuff + void $ waitForTypecheck doc + actions <- getCodeActions doc $ pointRange line col + let titles = mapMaybe codeActionTitle actions + for_ ts $ \(f, tc, var) -> do + let title = tacticTitle tc var + liftIO $ + (title `elem` titles) `shouldSatisfy` f + +data InvokeTactic = InvokeTactic + { it_command :: TacticCommand + , it_argument :: Text + , it_line :: Int + , it_col :: Int + } + +invokeTactic :: TextDocumentIdentifier -> InvokeTactic -> Session () +invokeTactic doc InvokeTactic{..} = do + -- wait for the entire build to finish, so that Tactics code actions that + -- use stale data will get uptodate stuff + void waitForDiagnostics + void $ waitForTypecheck doc + actions <- getCodeActions doc $ pointRange it_line it_col + case find ((== Just (tacticTitle it_command it_argument)) . codeActionTitle) actions of + Just (InR CodeAction {_command = Just c}) -> do + executeCommand c + void $ skipManyTill anyMessage $ message SWorkspaceApplyEdit + _ -> error $ show actions + + +mkGoldenTest + :: (Text -> Text -> Assertion) + -> [InvokeTactic] + -> FilePath + -> SpecWith () +mkGoldenTest eq invocations input = + it (input <> " (golden)") $ do + resetGlobalHoleRef + runSessionForTactics $ do + doc <- openDoc (input <.> "hs") "haskell" + traverse_ (invokeTactic doc) invocations + edited <- documentContents doc + let expected_name = input <.> "expected" <.> "hs" + -- Write golden tests if they don't already exist + liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited `eq` expected + + +mkCodeLensTest + :: FilePath + -> SpecWith () +mkCodeLensTest input = + it (input <> " (golden)") $ do + resetGlobalHoleRef + runSessionForTactics $ do + doc <- openDoc (input <.> "hs") "haskell" + _ <- waitForDiagnostics + lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc + for_ lenses $ \(CodeLens _ (Just cmd) _) -> + executeCommand cmd + _resp <- skipManyTill anyMessage (message SWorkspaceApplyEdit) + edited <- documentContents doc + let expected_name = input <.> "expected" <.> "hs" + -- Write golden tests if they don't already exist + liftIO $ (doesFileExist expected_name >>=) $ flip unless $ do + T.writeFile expected_name edited + expected <- liftIO $ T.readFile expected_name + liftIO $ edited `shouldBe` expected + + +------------------------------------------------------------------------------ +-- | A test that no code lenses can be run in the file +mkNoCodeLensTest + :: FilePath + -> SpecWith () +mkNoCodeLensTest input = + it (input <> " (no code lenses)") $ do + resetGlobalHoleRef + runSessionForTactics $ do + doc <- openDoc (input <.> "hs") "haskell" + _ <- waitForBuildQueue + lenses <- fmap (reverse . filter isWingmanLens) $ getCodeLenses doc + liftIO $ lenses `shouldBe` [] + + + +isWingmanLens :: CodeLens -> Bool +isWingmanLens (CodeLens _ (Just (Command _ cmd _)) _) + = T.isInfixOf ":tactics:" cmd +isWingmanLens _ = False + + +mkShowMessageTest + :: TacticCommand + -> Text + -> Int + -> Int + -> FilePath + -> UserFacingMessage + -> SpecWith () +mkShowMessageTest tc occ line col input ufm = + it (input <> " (golden)") $ do + resetGlobalHoleRef + runSessionForTactics $ do + doc <- openDoc (input <.> "hs") "haskell" + _ <- waitForDiagnostics + actions <- getCodeActions doc $ pointRange line col + Just (InR CodeAction {_command = Just c}) + <- pure $ find ((== Just (tacticTitle tc occ)) . codeActionTitle) actions + executeCommand c + NotificationMessage _ _ err <- skipManyTill anyMessage (message SWindowShowMessage) + liftIO $ err `shouldBe` mkShowMessageParams ufm + + +goldenTest :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () +goldenTest tc occ line col = mkGoldenTest shouldBe [InvokeTactic tc occ line col] + +goldenTestMany :: FilePath -> [InvokeTactic] -> SpecWith () +goldenTestMany = flip $ mkGoldenTest shouldBe + +goldenTestNoWhitespace :: TacticCommand -> Text -> Int -> Int -> FilePath -> SpecWith () +goldenTestNoWhitespace tc occ line col = mkGoldenTest shouldBeIgnoringSpaces [InvokeTactic tc occ line col] + + +shouldBeIgnoringSpaces :: Text -> Text -> Assertion +shouldBeIgnoringSpaces = assertFun f "" + where + f = (==) `on` T.unwords . T.words + + +assertFun + :: Show a + => (a -> a -> Bool) + -> String -- ^ The message prefix + -> a -- ^ The expected value + -> a -- ^ The actual value + -> Assertion +assertFun eq preface expected actual = + unless (eq actual expected) $ do + (prefaceMsg + `deepseq` expectedMsg + `deepseq` actualMsg + `deepseq` + E.throwIO + (HUnitFailure Nothing $ show $ ExpectedButGot prefaceMsg expectedMsg actualMsg)) + where + prefaceMsg + | null preface = Nothing + | otherwise = Just preface + expectedMsg = show expected + actualMsg = show actual + + + +------------------------------------------------------------------------------ +-- | Don't run a test. +failing :: Applicative m => String -> b -> m () +failing _ _ = pure () + + +tacticPath :: FilePath +tacticPath = "old/test/golden" + + +executeCommandWithResp :: Command -> Session (ResponseMessage 'WorkspaceExecuteCommand) +executeCommandWithResp cmd = do + let args = decode $ encode $ fromJust $ cmd ^. arguments + execParams = ExecuteCommandParams Nothing (cmd ^. command) args + request SWorkspaceExecuteCommand execParams + diff --git a/old/test/golden/AutoEmptyString.expected.hs b/old/test/golden/AutoEmptyString.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoEmptyString.expected.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = "" diff --git a/old/test/golden/AutoEmptyString.hs b/old/test/golden/AutoEmptyString.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoEmptyString.hs @@ -0,0 +1,2 @@ +empty_string :: String +empty_string = _ diff --git a/old/test/golden/AutoEndo.expected.hs b/old/test/golden/AutoEndo.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoEndo.hs b/old/test/golden/AutoEndo.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoForallClassMethod.expected.hs b/old/test/golden/AutoForallClassMethod.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoForallClassMethod.hs b/old/test/golden/AutoForallClassMethod.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoInfixApply.expected.hs b/old/test/golden/AutoInfixApply.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoInfixApply.hs b/old/test/golden/AutoInfixApply.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoInfixApply.hs @@ -0,0 +1,3 @@ +test :: (a -> b -> c) -> a -> (a -> b) -> c +test (/:) a f = _ + diff --git a/old/test/golden/AutoInfixApplyMany.expected.hs b/old/test/golden/AutoInfixApplyMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoInfixApplyMany.hs b/old/test/golden/AutoInfixApplyMany.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoInfixInfix.expected.hs b/old/test/golden/AutoInfixInfix.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoInfixInfix.hs b/old/test/golden/AutoInfixInfix.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoPatSynUse.expected.hs b/old/test/golden/AutoPatSynUse.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoPatSynUse.hs b/old/test/golden/AutoPatSynUse.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoSplitGADT.expected.hs b/old/test/golden/AutoSplitGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoSplitGADT.hs b/old/test/golden/AutoSplitGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaEqCtx.expected.hs b/old/test/golden/AutoThetaEqCtx.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoThetaEqCtx.expected.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = id -- id + diff --git a/old/test/golden/AutoThetaEqCtx.hs b/old/test/golden/AutoThetaEqCtx.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoThetaEqCtx.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} + +fun2 :: (a ~ b) => a -> b +fun2 = _ -- id + diff --git a/old/test/golden/AutoThetaEqGADT.expected.hs b/old/test/golden/AutoThetaEqGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaEqGADT.hs b/old/test/golden/AutoThetaEqGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaEqGADTDestruct.expected.hs b/old/test/golden/AutoThetaEqGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaEqGADTDestruct.hs b/old/test/golden/AutoThetaEqGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaFix.expected.hs b/old/test/golden/AutoThetaFix.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaFix.hs b/old/test/golden/AutoThetaFix.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaGADT.expected.hs b/old/test/golden/AutoThetaGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaGADT.hs b/old/test/golden/AutoThetaGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaGADTDestruct.expected.hs b/old/test/golden/AutoThetaGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaGADTDestruct.hs b/old/test/golden/AutoThetaGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaMultipleUnification.expected.hs b/old/test/golden/AutoThetaMultipleUnification.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaMultipleUnification.hs b/old/test/golden/AutoThetaMultipleUnification.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaRankN.expected.hs b/old/test/golden/AutoThetaRankN.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaRankN.hs b/old/test/golden/AutoThetaRankN.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaRefl.expected.hs b/old/test/golden/AutoThetaRefl.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaRefl.hs b/old/test/golden/AutoThetaRefl.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaReflDestruct.expected.hs b/old/test/golden/AutoThetaReflDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaReflDestruct.hs b/old/test/golden/AutoThetaReflDestruct.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaSplitUnification.expected.hs b/old/test/golden/AutoThetaSplitUnification.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoThetaSplitUnification.hs b/old/test/golden/AutoThetaSplitUnification.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoTypeLevel.expected.hs b/old/test/golden/AutoTypeLevel.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoTypeLevel.hs b/old/test/golden/AutoTypeLevel.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoUnusedPatternMatch.expected.hs b/old/test/golden/AutoUnusedPatternMatch.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoUnusedPatternMatch.expected.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test _ = () diff --git a/old/test/golden/AutoUnusedPatternMatch.hs b/old/test/golden/AutoUnusedPatternMatch.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/AutoUnusedPatternMatch.hs @@ -0,0 +1,2 @@ +test :: Bool -> () +test = _ diff --git a/old/test/golden/AutoZip.expected.hs b/old/test/golden/AutoZip.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/AutoZip.hs b/old/test/golden/AutoZip.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/ConProviders.hs b/old/test/golden/ConProviders.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllAnd.expected.hs b/old/test/golden/DestructAllAnd.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllAnd.hs b/old/test/golden/DestructAllAnd.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructAllAnd.hs @@ -0,0 +1,2 @@ +and :: Bool -> Bool -> Bool +and x y = _ diff --git a/old/test/golden/DestructAllFunc.expected.hs b/old/test/golden/DestructAllFunc.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllFunc.hs b/old/test/golden/DestructAllFunc.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructAllFunc.hs @@ -0,0 +1,3 @@ +has_a_func :: Bool -> (a -> b) -> Bool +has_a_func x y = _ + diff --git a/old/test/golden/DestructAllGADTEvidence.expected.hs b/old/test/golden/DestructAllGADTEvidence.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllGADTEvidence.hs b/old/test/golden/DestructAllGADTEvidence.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllMany.expected.hs b/old/test/golden/DestructAllMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllMany.hs b/old/test/golden/DestructAllMany.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllNonVarTopMatch.expected.hs b/old/test/golden/DestructAllNonVarTopMatch.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructAllNonVarTopMatch.hs b/old/test/golden/DestructAllNonVarTopMatch.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructAllNonVarTopMatch.hs @@ -0,0 +1,3 @@ +and :: (a, b) -> Bool -> Bool -> Bool +and (a, b) x y = _ + diff --git a/old/test/golden/DestructAllProvider.hs b/old/test/golden/DestructAllProvider.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructCthulhu.expected.hs b/old/test/golden/DestructCthulhu.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructCthulhu.hs b/old/test/golden/DestructCthulhu.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructDataFam.expected.hs b/old/test/golden/DestructDataFam.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructDataFam.hs b/old/test/golden/DestructDataFam.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructInt.expected.hs b/old/test/golden/DestructInt.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructInt.hs b/old/test/golden/DestructInt.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructInt.hs @@ -0,0 +1,7 @@ +import Data.Int + +data Test = Test Int32 + +test :: Test -> Int32 +test t = _ + diff --git a/old/test/golden/DestructPun.expected.hs b/old/test/golden/DestructPun.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructPun.hs b/old/test/golden/DestructPun.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructPun.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE NamedFieldPuns #-} + + +data Foo = Foo { a :: Bool, b :: Bool } + +foo Foo {a, b} = _ + diff --git a/old/test/golden/DestructTyFam.expected.hs b/old/test/golden/DestructTyFam.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructTyFam.hs b/old/test/golden/DestructTyFam.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/DestructTyFam.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} + +type family Yo where + Yo = Bool + +test :: Yo -> Int +test b = _ + diff --git a/old/test/golden/DestructTyToDataFam.expected.hs b/old/test/golden/DestructTyToDataFam.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/DestructTyToDataFam.hs b/old/test/golden/DestructTyToDataFam.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseADT.expected.hs b/old/test/golden/EmptyCaseADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseADT.hs b/old/test/golden/EmptyCaseADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseApply.expected.hs b/old/test/golden/EmptyCaseApply.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseApply.expected.hs @@ -0,0 +1,3 @@ +blah = case show 5 of + [] -> _ + c : s -> _ diff --git a/old/test/golden/EmptyCaseApply.hs b/old/test/golden/EmptyCaseApply.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseApply.hs @@ -0,0 +1,1 @@ +blah = case show 5 of diff --git a/old/test/golden/EmptyCaseGADT.expected.hs b/old/test/golden/EmptyCaseGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseGADT.hs b/old/test/golden/EmptyCaseGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseLamCase.expected.hs b/old/test/golden/EmptyCaseLamCase.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseLamCase.expected.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case + False -> _ + True -> _ diff --git a/old/test/golden/EmptyCaseLamCase.hs b/old/test/golden/EmptyCaseLamCase.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseLamCase.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE LambdaCase #-} + +test :: Bool -> Bool +test = \case diff --git a/old/test/golden/EmptyCaseNested.expected.hs b/old/test/golden/EmptyCaseNested.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseNested.expected.hs @@ -0,0 +1,5 @@ +test = + case (case (Just "") of + Nothing -> _ + Just s -> _) of + True -> _ diff --git a/old/test/golden/EmptyCaseNested.hs b/old/test/golden/EmptyCaseNested.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseNested.hs @@ -0,0 +1,3 @@ +test = + case (case (Just "") of) of + True -> _ diff --git a/old/test/golden/EmptyCaseParens.expected.hs b/old/test/golden/EmptyCaseParens.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseParens.expected.hs @@ -0,0 +1,3 @@ +test = True && (case True of + False -> _ + True -> _) diff --git a/old/test/golden/EmptyCaseParens.hs b/old/test/golden/EmptyCaseParens.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/EmptyCaseParens.hs @@ -0,0 +1,1 @@ +test = True && case True of diff --git a/old/test/golden/EmptyCaseShadow.expected.hs b/old/test/golden/EmptyCaseShadow.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseShadow.hs b/old/test/golden/EmptyCaseShadow.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/EmptyCaseSpuriousGADT.hs b/old/test/golden/EmptyCaseSpuriousGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/Fgmap.expected.hs b/old/test/golden/Fgmap.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/Fgmap.hs b/old/test/golden/Fgmap.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapBoth.expected.hs b/old/test/golden/FmapBoth.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapBoth.hs b/old/test/golden/FmapBoth.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapJoin.expected.hs b/old/test/golden/FmapJoin.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapJoin.hs b/old/test/golden/FmapJoin.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapJoinInLet.expected.hs b/old/test/golden/FmapJoinInLet.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/FmapJoinInLet.hs b/old/test/golden/FmapJoinInLet.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenApplicativeThen.hs b/old/test/golden/GoldenApplicativeThen.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenApplicativeThen.hs @@ -0,0 +1,2 @@ +useThen :: Applicative f => f Int -> f a -> f a +useThen = _ diff --git a/old/test/golden/GoldenArbitrary.expected.hs b/old/test/golden/GoldenArbitrary.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenArbitrary.hs b/old/test/golden/GoldenArbitrary.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/old/test/golden/GoldenArbitrarySingleConstructor.expected.hs new file mode 100644 --- /dev/null +++ b/old/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 diff --git a/old/test/golden/GoldenArbitrarySingleConstructor.hs b/old/test/golden/GoldenArbitrarySingleConstructor.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenArbitrarySingleConstructor.hs @@ -0,0 +1,6 @@ +data Gen a + +data Obj = Obj Int Bool Char String + +arbitrary :: Gen Obj +arbitrary = _ diff --git a/old/test/golden/GoldenBigTuple.expected.hs b/old/test/golden/GoldenBigTuple.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenBigTuple.hs b/old/test/golden/GoldenBigTuple.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenEitherAuto.expected.hs b/old/test/golden/GoldenEitherAuto.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenEitherAuto.hs b/old/test/golden/GoldenEitherAuto.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenEitherAuto.hs @@ -0,0 +1,2 @@ +either' :: (a -> c) -> (b -> c) -> Either a b -> c +either' = _ diff --git a/old/test/golden/GoldenEitherHomomorphic.expected.hs b/old/test/golden/GoldenEitherHomomorphic.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenEitherHomomorphic.hs b/old/test/golden/GoldenEitherHomomorphic.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenEitherHomomorphic.hs @@ -0,0 +1,2 @@ +eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c +eitherSplit = _ diff --git a/old/test/golden/GoldenFish.hs b/old/test/golden/GoldenFish.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenFmapTree.expected.hs b/old/test/golden/GoldenFmapTree.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenFmapTree.hs b/old/test/golden/GoldenFmapTree.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenFoldr.expected.hs b/old/test/golden/GoldenFoldr.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenFoldr.hs b/old/test/golden/GoldenFoldr.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenFoldr.hs @@ -0,0 +1,2 @@ +foldr2 :: (a -> b -> b) -> b -> [a] -> b +foldr2 = _ diff --git a/old/test/golden/GoldenFromMaybe.expected.hs b/old/test/golden/GoldenFromMaybe.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenFromMaybe.hs b/old/test/golden/GoldenFromMaybe.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenFromMaybe.hs @@ -0,0 +1,2 @@ +fromMaybe :: a -> Maybe a -> a +fromMaybe = _ diff --git a/old/test/golden/GoldenGADTAuto.expected.hs b/old/test/golden/GoldenGADTAuto.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenGADTAuto.hs b/old/test/golden/GoldenGADTAuto.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenGADTDestruct.expected.hs b/old/test/golden/GoldenGADTDestruct.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenGADTDestruct.hs b/old/test/golden/GoldenGADTDestruct.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenGADTDestructCoercion.expected.hs b/old/test/golden/GoldenGADTDestructCoercion.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenGADTDestructCoercion.hs b/old/test/golden/GoldenGADTDestructCoercion.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenIdTypeFam.expected.hs b/old/test/golden/GoldenIdTypeFam.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenIdTypeFam.hs b/old/test/golden/GoldenIdTypeFam.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenIdTypeFam.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeFamilies #-} + +type family TyFam +type instance TyFam = Int + +tyblah' :: TyFam -> Int +tyblah' = _ diff --git a/old/test/golden/GoldenIdentityFunctor.expected.hs b/old/test/golden/GoldenIdentityFunctor.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenIdentityFunctor.hs b/old/test/golden/GoldenIdentityFunctor.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenIdentityFunctor.hs @@ -0,0 +1,3 @@ +data Ident a = Ident a +instance Functor Ident where + fmap = _ diff --git a/old/test/golden/GoldenIntros.expected.hs b/old/test/golden/GoldenIntros.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenIntros.hs b/old/test/golden/GoldenIntros.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenIntros.hs @@ -0,0 +1,2 @@ +blah :: Int -> Bool -> (a -> b) -> String -> Int +blah = _ diff --git a/old/test/golden/GoldenJoinCont.expected.hs b/old/test/golden/GoldenJoinCont.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenJoinCont.hs b/old/test/golden/GoldenJoinCont.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenListFmap.expected.hs b/old/test/golden/GoldenListFmap.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenListFmap.hs b/old/test/golden/GoldenListFmap.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenListFmap.hs @@ -0,0 +1,2 @@ +fmapList :: (a -> b) -> [a] -> [b] +fmapList = _ diff --git a/old/test/golden/GoldenNote.expected.hs b/old/test/golden/GoldenNote.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenNote.hs b/old/test/golden/GoldenNote.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenNote.hs @@ -0,0 +1,2 @@ +note :: e -> Maybe a -> Either e a +note = _ diff --git a/old/test/golden/GoldenPureList.expected.hs b/old/test/golden/GoldenPureList.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenPureList.expected.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList a = a : [] diff --git a/old/test/golden/GoldenPureList.hs b/old/test/golden/GoldenPureList.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenPureList.hs @@ -0,0 +1,2 @@ +pureList :: a -> [a] +pureList = _ diff --git a/old/test/golden/GoldenSafeHead.expected.hs b/old/test/golden/GoldenSafeHead.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenSafeHead.expected.hs @@ -0,0 +1,3 @@ +safeHead :: [x] -> Maybe x +safeHead [] = Nothing +safeHead (x : _) = Just x diff --git a/old/test/golden/GoldenSafeHead.hs b/old/test/golden/GoldenSafeHead.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenSafeHead.hs @@ -0,0 +1,2 @@ +safeHead :: [x] -> Maybe x +safeHead = _ diff --git a/old/test/golden/GoldenShow.expected.hs b/old/test/golden/GoldenShow.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenShow.expected.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = show diff --git a/old/test/golden/GoldenShow.hs b/old/test/golden/GoldenShow.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenShow.hs @@ -0,0 +1,2 @@ +showMe :: Show a => a -> String +showMe = _ diff --git a/old/test/golden/GoldenShowCompose.expected.hs b/old/test/golden/GoldenShowCompose.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenShowCompose.expected.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose fba = show . fba diff --git a/old/test/golden/GoldenShowCompose.hs b/old/test/golden/GoldenShowCompose.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenShowCompose.hs @@ -0,0 +1,2 @@ +showCompose :: Show a => (b -> a) -> b -> String +showCompose = _ diff --git a/old/test/golden/GoldenShowMapChar.expected.hs b/old/test/golden/GoldenShowMapChar.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenShowMapChar.hs b/old/test/golden/GoldenShowMapChar.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenShowMapChar.hs @@ -0,0 +1,2 @@ +test :: Show a => a -> (String -> b) -> b +test = _ diff --git a/old/test/golden/GoldenSuperclass.expected.hs b/old/test/golden/GoldenSuperclass.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenSuperclass.hs b/old/test/golden/GoldenSuperclass.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenSwap.expected.hs b/old/test/golden/GoldenSwap.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenSwap.expected.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) diff --git a/old/test/golden/GoldenSwap.hs b/old/test/golden/GoldenSwap.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenSwap.hs @@ -0,0 +1,2 @@ +swap :: (a, b) -> (b, a) +swap = _ diff --git a/old/test/golden/GoldenSwapMany.expected.hs b/old/test/golden/GoldenSwapMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/GoldenSwapMany.hs b/old/test/golden/GoldenSwapMany.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/GoldenSwapMany.hs @@ -0,0 +1,2 @@ +swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) +swapMany = _ diff --git a/old/test/golden/IntroDestructLetBinding.expected.hs b/old/test/golden/IntroDestructLetBinding.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/IntroDestructLetBinding.hs b/old/test/golden/IntroDestructLetBinding.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntroDestructLetBinding.hs @@ -0,0 +1,5 @@ +test :: IO () +test = do + let x :: Bool -> Int + x = _ + pure () diff --git a/old/test/golden/IntroDestructMany.expected.hs b/old/test/golden/IntroDestructMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntroDestructMany.expected.hs @@ -0,0 +1,4 @@ +x :: Bool -> Maybe Int -> String -> Int +x False = _w0 +x True = _w1 + diff --git a/old/test/golden/IntroDestructMany.hs b/old/test/golden/IntroDestructMany.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntroDestructMany.hs @@ -0,0 +1,3 @@ +x :: Bool -> Maybe Int -> String -> Int +x = _ + diff --git a/old/test/golden/IntroDestructOne.expected.hs b/old/test/golden/IntroDestructOne.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntroDestructOne.expected.hs @@ -0,0 +1,6 @@ +module Test where + +x :: Bool -> Int +x False = _w0 +x True = _w1 + diff --git a/old/test/golden/IntroDestructOne.hs b/old/test/golden/IntroDestructOne.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntroDestructOne.hs @@ -0,0 +1,5 @@ +module Test where + +x :: Bool -> Int +x = _ + diff --git a/old/test/golden/IntroDestructProvider.hs b/old/test/golden/IntroDestructProvider.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/IntrosTooMany.expected.hs b/old/test/golden/IntrosTooMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/IntrosTooMany.expected.hs @@ -0,0 +1,2 @@ +too_many :: a -> b -> c +too_many a b = _w0 diff --git a/old/test/golden/IntrosTooMany.hs b/old/test/golden/IntrosTooMany.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownBigSemigroup.expected.hs b/old/test/golden/KnownBigSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownBigSemigroup.hs b/old/test/golden/KnownBigSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownCounterfactualSemigroup.expected.hs b/old/test/golden/KnownCounterfactualSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownCounterfactualSemigroup.hs b/old/test/golden/KnownCounterfactualSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/KnownCounterfactualSemigroup.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE UndecidableInstances #-} + +data Semi = Semi [String] Int + +instance Semigroup Int => Semigroup Semi where + (<>) = _ + diff --git a/old/test/golden/KnownDestructedSemigroup.expected.hs b/old/test/golden/KnownDestructedSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownDestructedSemigroup.hs b/old/test/golden/KnownDestructedSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMissingMonoid.expected.hs b/old/test/golden/KnownMissingMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMissingMonoid.hs b/old/test/golden/KnownMissingMonoid.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMissingSemigroup.expected.hs b/old/test/golden/KnownMissingSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMissingSemigroup.hs b/old/test/golden/KnownMissingSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/KnownMissingSemigroup.hs @@ -0,0 +1,5 @@ +data Semi = Semi [String] Int + +instance Semigroup Semi where + (<>) = _ + diff --git a/old/test/golden/KnownModuleInstanceSemigroup.expected.hs b/old/test/golden/KnownModuleInstanceSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownModuleInstanceSemigroup.hs b/old/test/golden/KnownModuleInstanceSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMonoid.expected.hs b/old/test/golden/KnownMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownMonoid.hs b/old/test/golden/KnownMonoid.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownPolyMonoid.expected.hs b/old/test/golden/KnownPolyMonoid.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownPolyMonoid.hs b/old/test/golden/KnownPolyMonoid.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownThetaSemigroup.expected.hs b/old/test/golden/KnownThetaSemigroup.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/KnownThetaSemigroup.hs b/old/test/golden/KnownThetaSemigroup.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/KnownThetaSemigroup.hs @@ -0,0 +1,5 @@ +data Semi a = Semi a + +instance Semigroup a => Semigroup (Semi a) where + (<>) = _ + diff --git a/old/test/golden/LayoutBind.expected.hs b/old/test/golden/LayoutBind.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutBind.hs b/old/test/golden/LayoutBind.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutBind.hs @@ -0,0 +1,6 @@ +test :: Bool -> IO () +test b = do + putStrLn "hello" + _ + pure () + diff --git a/old/test/golden/LayoutDollarApp.expected.hs b/old/test/golden/LayoutDollarApp.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutDollarApp.hs b/old/test/golden/LayoutDollarApp.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutDollarApp.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test b = id $ _ + diff --git a/old/test/golden/LayoutInfixKeep.expected.hs b/old/test/golden/LayoutInfixKeep.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutInfixKeep.hs b/old/test/golden/LayoutInfixKeep.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutLam.expected.hs b/old/test/golden/LayoutLam.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutLam.expected.hs @@ -0,0 +1,5 @@ +test :: Bool -> Bool +test = \b -> case b of + False -> _w0 + True -> _w1 + diff --git a/old/test/golden/LayoutLam.hs b/old/test/golden/LayoutLam.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutLam.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool +test = \b -> _ + diff --git a/old/test/golden/LayoutOpApp.expected.hs b/old/test/golden/LayoutOpApp.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutOpApp.hs b/old/test/golden/LayoutOpApp.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutOpApp.hs @@ -0,0 +1,2 @@ +test :: Bool -> Bool +test b = True && _ diff --git a/old/test/golden/LayoutPrefixKeep.expected.hs b/old/test/golden/LayoutPrefixKeep.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutPrefixKeep.expected.hs @@ -0,0 +1,4 @@ +(-/) :: Bool -> a -> a +(-/) False a = _w0 +(-/) True a = _w1 + diff --git a/old/test/golden/LayoutPrefixKeep.hs b/old/test/golden/LayoutPrefixKeep.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutPrefixKeep.hs @@ -0,0 +1,3 @@ +(-/) :: Bool -> a -> a +(-/) b a = _ + diff --git a/old/test/golden/LayoutRec.expected.hs b/old/test/golden/LayoutRec.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutRec.hs b/old/test/golden/LayoutRec.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitClass.expected.hs b/old/test/golden/LayoutSplitClass.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitClass.hs b/old/test/golden/LayoutSplitClass.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutSplitClass.hs @@ -0,0 +1,4 @@ +class Test a where + test :: Bool -> a + test x = _ + diff --git a/old/test/golden/LayoutSplitGuard.expected.hs b/old/test/golden/LayoutSplitGuard.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitGuard.hs b/old/test/golden/LayoutSplitGuard.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutSplitGuard.hs @@ -0,0 +1,3 @@ +test :: Bool -> Bool -> Bool +test a b + | a = _ diff --git a/old/test/golden/LayoutSplitIn.expected.hs b/old/test/golden/LayoutSplitIn.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitIn.hs b/old/test/golden/LayoutSplitIn.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutSplitIn.hs @@ -0,0 +1,5 @@ +test :: a +test = + let a = (1,"bbb") + in _ + diff --git a/old/test/golden/LayoutSplitLet.expected.hs b/old/test/golden/LayoutSplitLet.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitLet.hs b/old/test/golden/LayoutSplitLet.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutSplitLet.hs @@ -0,0 +1,6 @@ +test :: a +test = + let t :: Bool -> a + t b = _ + in _ + diff --git a/old/test/golden/LayoutSplitPatSyn.expected.hs b/old/test/golden/LayoutSplitPatSyn.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitPatSyn.hs b/old/test/golden/LayoutSplitPatSyn.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitPattern.expected.hs b/old/test/golden/LayoutSplitPattern.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitPattern.hs b/old/test/golden/LayoutSplitPattern.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitViewPat.expected.hs b/old/test/golden/LayoutSplitViewPat.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitViewPat.hs b/old/test/golden/LayoutSplitViewPat.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/LayoutSplitViewPat.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ViewPatterns #-} + +splitLookup :: [(Int, String)] -> String +splitLookup (lookup 5 -> a) = _ + diff --git a/old/test/golden/LayoutSplitWhere.expected.hs b/old/test/golden/LayoutSplitWhere.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/LayoutSplitWhere.hs b/old/test/golden/LayoutSplitWhere.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MessageCantUnify.hs b/old/test/golden/MessageCantUnify.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MessageForallA.hs b/old/test/golden/MessageForallA.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MessageForallA.hs @@ -0,0 +1,2 @@ +test :: a +test = _ diff --git a/old/test/golden/MessageNotEnoughGas.hs b/old/test/golden/MessageNotEnoughGas.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaBegin.expected.hs b/old/test/golden/MetaBegin.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBegin.expected.hs @@ -0,0 +1,1 @@ +foo = [wingman||] diff --git a/old/test/golden/MetaBegin.hs b/old/test/golden/MetaBegin.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBegin.hs @@ -0,0 +1,1 @@ +foo = _ diff --git a/old/test/golden/MetaBeginNoWildify.expected.hs b/old/test/golden/MetaBeginNoWildify.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBeginNoWildify.expected.hs @@ -0,0 +1,2 @@ +foo v = [wingman||] + diff --git a/old/test/golden/MetaBeginNoWildify.hs b/old/test/golden/MetaBeginNoWildify.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBeginNoWildify.hs @@ -0,0 +1,2 @@ +foo v = _ + diff --git a/old/test/golden/MetaBindAll.expected.hs b/old/test/golden/MetaBindAll.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBindAll.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, a) diff --git a/old/test/golden/MetaBindAll.hs b/old/test/golden/MetaBindAll.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBindAll.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split; assumption |] diff --git a/old/test/golden/MetaBindOne.expected.hs b/old/test/golden/MetaBindOne.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBindOne.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = (a, _w0) diff --git a/old/test/golden/MetaBindOne.hs b/old/test/golden/MetaBindOne.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaBindOne.hs @@ -0,0 +1,2 @@ +foo :: a -> (a, a) +foo a = [wingman| split, assumption |] diff --git a/old/test/golden/MetaCataAST.expected.hs b/old/test/golden/MetaCataAST.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaCataAST.hs b/old/test/golden/MetaCataAST.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaCataCollapse.expected.hs b/old/test/golden/MetaCataCollapse.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaCataCollapse.hs b/old/test/golden/MetaCataCollapse.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaCataCollapseUnary.expected.hs b/old/test/golden/MetaCataCollapseUnary.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaCataCollapseUnary.hs b/old/test/golden/MetaCataCollapseUnary.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaChoice.expected.hs b/old/test/golden/MetaChoice.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaChoice.hs b/old/test/golden/MetaChoice.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaDeepOf.expected.hs b/old/test/golden/MetaDeepOf.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaDeepOf.hs b/old/test/golden/MetaDeepOf.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaFundeps.expected.hs b/old/test/golden/MetaFundeps.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaFundeps.hs b/old/test/golden/MetaFundeps.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaIdiom.expected.hs b/old/test/golden/MetaIdiom.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaIdiom.hs b/old/test/golden/MetaIdiom.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaIdiomRecord.expected.hs b/old/test/golden/MetaIdiomRecord.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaIdiomRecord.hs b/old/test/golden/MetaIdiomRecord.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaLetSimple.expected.hs b/old/test/golden/MetaLetSimple.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaLetSimple.expected.hs @@ -0,0 +1,7 @@ +test :: Int +test + = let + a = _w0 + b = _w1 + c = _w2 + in _w3 diff --git a/old/test/golden/MetaLetSimple.hs b/old/test/golden/MetaLetSimple.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaLetSimple.hs @@ -0,0 +1,2 @@ +test :: Int +test = [wingman| let a b c |] diff --git a/old/test/golden/MetaMaybeAp.expected.hs b/old/test/golden/MetaMaybeAp.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaMaybeAp.hs b/old/test/golden/MetaMaybeAp.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaPointwise.expected.hs b/old/test/golden/MetaPointwise.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaPointwise.hs b/old/test/golden/MetaPointwise.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaTry.expected.hs b/old/test/golden/MetaTry.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaTry.expected.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = (_w0, a) diff --git a/old/test/golden/MetaTry.hs b/old/test/golden/MetaTry.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaTry.hs @@ -0,0 +1,2 @@ +foo :: a -> (b, a) +foo a = [wingman| split; try (assumption) |] diff --git a/old/test/golden/MetaUseImport.expected.hs b/old/test/golden/MetaUseImport.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaUseImport.expected.hs @@ -0,0 +1,6 @@ +import Data.Char + + +result :: Char -> Bool +result = isAlpha + diff --git a/old/test/golden/MetaUseImport.hs b/old/test/golden/MetaUseImport.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaUseLocal.expected.hs b/old/test/golden/MetaUseLocal.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaUseLocal.expected.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = test + diff --git a/old/test/golden/MetaUseLocal.hs b/old/test/golden/MetaUseLocal.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaUseLocal.hs @@ -0,0 +1,7 @@ +test :: Int +test = 0 + + +resolve :: Int +resolve = [wingman| use test |] + diff --git a/old/test/golden/MetaUseMethod.expected.hs b/old/test/golden/MetaUseMethod.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaUseMethod.hs b/old/test/golden/MetaUseMethod.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/MetaUseSymbol.expected.hs b/old/test/golden/MetaUseSymbol.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaUseSymbol.expected.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = _w0 <> _w1 diff --git a/old/test/golden/MetaUseSymbol.hs b/old/test/golden/MetaUseSymbol.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaUseSymbol.hs @@ -0,0 +1,4 @@ +import Data.Monoid + +resolve :: Sum Int +resolve = [wingman| use (<>) |] diff --git a/old/test/golden/MetaWithArg.expected.hs b/old/test/golden/MetaWithArg.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaWithArg.expected.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = _w0 a diff --git a/old/test/golden/MetaWithArg.hs b/old/test/golden/MetaWithArg.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/MetaWithArg.hs @@ -0,0 +1,2 @@ +wat :: a -> b +wat a = [wingman| with_arg, assumption |] diff --git a/old/test/golden/NewtypeRecord.expected.hs b/old/test/golden/NewtypeRecord.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/NewtypeRecord.hs b/old/test/golden/NewtypeRecord.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/NewtypeRecord.hs @@ -0,0 +1,7 @@ +newtype MyRecord a = Record + { field1 :: a + } + +blah :: (a -> Int) -> a -> MyRecord a +blah = _ + diff --git a/old/test/golden/ProvideAlreadyDestructed.hs b/old/test/golden/ProvideAlreadyDestructed.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/ProvideAlreadyDestructed.hs @@ -0,0 +1,9 @@ +foo :: Bool -> () +foo x = + if True + then + case x of + True -> _ + False -> () + else + _ diff --git a/old/test/golden/ProvideLocalHyOnly.hs b/old/test/golden/ProvideLocalHyOnly.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/ProvideLocalHyOnly.hs @@ -0,0 +1,2 @@ +basilisk :: Monoid Bool => a +basilisk = _ diff --git a/old/test/golden/ProviderHomomorphism.hs b/old/test/golden/ProviderHomomorphism.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunGADT.expected.hs b/old/test/golden/PunGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunGADT.hs b/old/test/golden/PunGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunMany.expected.hs b/old/test/golden/PunMany.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunMany.hs b/old/test/golden/PunMany.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunManyGADT.expected.hs b/old/test/golden/PunManyGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunManyGADT.hs b/old/test/golden/PunManyGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunShadowing.expected.hs b/old/test/golden/PunShadowing.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunShadowing.hs b/old/test/golden/PunShadowing.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/PunShadowing.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: () -> Bar -> Int +bar ax x = _ + diff --git a/old/test/golden/PunSimple.expected.hs b/old/test/golden/PunSimple.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/PunSimple.hs b/old/test/golden/PunSimple.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/PunSimple.hs @@ -0,0 +1,5 @@ +data Bar = Bar { ax :: Int, bax :: Bool } + +bar :: Bar -> Int +bar x = _ + diff --git a/old/test/golden/RecordCon.expected.hs b/old/test/golden/RecordCon.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RecordCon.hs b/old/test/golden/RecordCon.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RefineCon.expected.hs b/old/test/golden/RefineCon.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/RefineCon.expected.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = (_w0, _w1, _w2) + diff --git a/old/test/golden/RefineCon.hs b/old/test/golden/RefineCon.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/RefineCon.hs @@ -0,0 +1,3 @@ +test :: ((), (b, c), d) +test = _ + diff --git a/old/test/golden/RefineGADT.expected.hs b/old/test/golden/RefineGADT.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RefineGADT.hs b/old/test/golden/RefineGADT.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RefineIntro.expected.hs b/old/test/golden/RefineIntro.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/RefineIntro.expected.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test a = _w0 diff --git a/old/test/golden/RefineIntro.hs b/old/test/golden/RefineIntro.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/RefineIntro.hs @@ -0,0 +1,2 @@ +test :: a -> Either a b +test = _ diff --git a/old/test/golden/RefineIntroWhere.expected.hs b/old/test/golden/RefineIntroWhere.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RefineIntroWhere.hs b/old/test/golden/RefineIntroWhere.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/RefineIntroWhere.hs @@ -0,0 +1,6 @@ +test :: Maybe Int -> Int +test = _ + where + -- Don't delete me! + blah = undefined + diff --git a/old/test/golden/RefineReader.expected.hs b/old/test/golden/RefineReader.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/RefineReader.hs b/old/test/golden/RefineReader.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/SplitPattern.expected.hs b/old/test/golden/SplitPattern.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/SplitPattern.hs b/old/test/golden/SplitPattern.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/SubsequentTactics.expected.hs b/old/test/golden/SubsequentTactics.expected.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/SubsequentTactics.hs b/old/test/golden/SubsequentTactics.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/SubsequentTactics.hs @@ -0,0 +1,5 @@ +data Dummy a = Dummy a + +f :: Dummy Int -> Int +f = _ + diff --git a/old/test/golden/T1.hs b/old/test/golden/T1.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/T1.hs @@ -0,0 +1,3 @@ +fmapEither :: (a -> b) -> Either c a -> Either c b +fmapEither = _lalala + diff --git a/old/test/golden/T2.hs b/old/test/golden/T2.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/T3.hs b/old/test/golden/T3.hs new file mode 100644 --- /dev/null +++ b/old/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/old/test/golden/UseConLeft.expected.hs b/old/test/golden/UseConLeft.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConLeft.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Left _w0 + diff --git a/old/test/golden/UseConLeft.hs b/old/test/golden/UseConLeft.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConLeft.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/old/test/golden/UseConPair.expected.hs b/old/test/golden/UseConPair.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConPair.expected.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = (_w0, _w1) diff --git a/old/test/golden/UseConPair.hs b/old/test/golden/UseConPair.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConPair.hs @@ -0,0 +1,2 @@ +test :: (a, b) +test = _ diff --git a/old/test/golden/UseConRight.expected.hs b/old/test/golden/UseConRight.expected.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConRight.expected.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = Right _w0 + diff --git a/old/test/golden/UseConRight.hs b/old/test/golden/UseConRight.hs new file mode 100644 --- /dev/null +++ b/old/test/golden/UseConRight.hs @@ -0,0 +1,3 @@ +test :: Either a b +test = _ + diff --git a/old/test/golden/hie.yaml b/old/test/golden/hie.yaml new file mode 100644 --- /dev/null +++ b/old/test/golden/hie.yaml @@ -0,0 +1,1 @@ +cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/old/test/golden/test.cabal b/old/test/golden/test.cabal new file mode 100644 --- /dev/null +++ b/old/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 diff --git a/src/Ide/Plugin/Tactic.hs b/src/Ide/Plugin/Tactic.hs deleted file mode 100644 --- a/src/Ide/Plugin/Tactic.hs +++ /dev/null @@ -1,5 +0,0 @@ --- | A plugin that uses tactics to synthesize code -module Ide.Plugin.Tactic (descriptor, Log(..)) where - -import Wingman.Plugin - diff --git a/src/Refinery/Future.hs b/src/Refinery/Future.hs deleted file mode 100644 --- a/src/Refinery/Future.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# 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/src/Wingman/AbstractLSP.hs b/src/Wingman/AbstractLSP.hs deleted file mode 100644 --- a/src/Wingman/AbstractLSP.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# 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 - - ------------------------------------------------------------------------------- --- | Attact 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/src/Wingman/AbstractLSP/TacticActions.hs b/src/Wingman/AbstractLSP/TacticActions.hs deleted file mode 100644 --- a/src/Wingman/AbstractLSP/TacticActions.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# 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, unXPat) -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 (fmap unXPat 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 preceeding 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/src/Wingman/AbstractLSP/Types.hs b/src/Wingman/AbstractLSP/Types.hs deleted file mode 100644 --- a/src/Wingman/AbstractLSP/Types.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# 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/src/Wingman/Auto.hs b/src/Wingman/Auto.hs deleted file mode 100644 --- a/src/Wingman/Auto.hs +++ /dev/null @@ -1,32 +0,0 @@ - -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/src/Wingman/CaseSplit.hs b/src/Wingman/CaseSplit.hs deleted file mode 100644 --- a/src/Wingman/CaseSplit.hs +++ /dev/null @@ -1,109 +0,0 @@ -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/src/Wingman/CodeGen.hs b/src/Wingman/CodeGen.hs deleted file mode 100644 --- a/src/Wingman/CodeGen.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# 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 performign 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/src/Wingman/CodeGen/Utils.hs b/src/Wingman/CodeGen/Utils.hs deleted file mode 100644 --- a/src/Wingman/CodeGen/Utils.hs +++ /dev/null @@ -1,79 +0,0 @@ -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/src/Wingman/Context.hs b/src/Wingman/Context.hs deleted file mode 100644 --- a/src/Wingman/Context.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# 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/src/Wingman/Debug.hs b/src/Wingman/Debug.hs deleted file mode 100644 --- a/src/Wingman/Debug.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# 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/src/Wingman/EmptyCase.hs b/src/Wingman/EmptyCase.hs deleted file mode 100644 --- a/src/Wingman/EmptyCase.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# 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) -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/src/Wingman/GHC.hs b/src/Wingman/GHC.hs deleted file mode 100644 --- a/src/Wingman/GHC.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# 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 caontains 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 - -#if __GLASGOW_HASKELL__ == 808 -instance PatCompattable GhcTc where - fromPatCompat = id - toPatCompat = id - -instance PatCompattable GhcPs where - fromPatCompat = id - toPatCompat = id - -type PatCompat pass = Pat pass -#else -instance PatCompattable GhcTc where - fromPatCompat = unLoc - toPatCompat = noLoc - -instance PatCompattable GhcPs where - fromPatCompat = unLoc - toPatCompat = noLoc - -type PatCompat pass = LPat pass -#endif - ------------------------------------------------------------------------------- --- | 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)) - ------------------------------------------------------------------------------- --- | In GHC 8.8, sometimes patterns are wrapped in 'XPat'. --- The nitty gritty details are explained at --- https://blog.shaynefletcher.org/2020/03/ghc-haskell-pats-and-lpats.html --- --- We need to remove these in order to succesfull find patterns. -unXPat :: Pat GhcPs -> Pat GhcPs -#if __GLASGOW_HASKELL__ == 808 -unXPat (XPat (L _ pat)) = unXPat pat -#endif -unXPat pat = pat - - -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/src/Wingman/Judgements.hs b/src/Wingman/Judgements.hs deleted file mode 100644 --- a/src/Wingman/Judgements.hs +++ /dev/null @@ -1,474 +0,0 @@ -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 lamba. -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 - -- ancstry 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 beind 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 --- (impors 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/src/Wingman/Judgements/SYB.hs b/src/Wingman/Judgements/SYB.hs deleted file mode 100644 --- a/src/Wingman/Judgements/SYB.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# 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 shuld 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 instantation 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/src/Wingman/Judgements/Theta.hs b/src/Wingman/Judgements/Theta.hs deleted file mode 100644 --- a/src/Wingman/Judgements/Theta.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# 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 subtitution 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/src/Wingman/KnownStrategies.hs b/src/Wingman/KnownStrategies.hs deleted file mode 100644 --- a/src/Wingman/KnownStrategies.hs +++ /dev/null @@ -1,82 +0,0 @@ -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 instace in scope. If that fails, --- it fals 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/src/Wingman/KnownStrategies/QuickCheck.hs b/src/Wingman/KnownStrategies/QuickCheck.hs deleted file mode 100644 --- a/src/Wingman/KnownStrategies/QuickCheck.hs +++ /dev/null @@ -1,109 +0,0 @@ -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/src/Wingman/LanguageServer.hs b/src/Wingman/LanguageServer.hs deleted file mode 100644 --- a/src/Wingman/LanguageServer.hs +++ /dev/null @@ -1,671 +0,0 @@ -{-# 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 -#if __GLASGOW_HASKELL__ >= 808 - SigPat _ p _ -> buildPatHy prov p -#endif -#if __GLASGOW_HASKELL__ == 808 - XPat p -> buildPatHy prov $ unLoc p -#endif - _ -> 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 varible 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 -#if __GLASGOW_HASKELL__ <= 808 - L span (EWildPat _) -> - maybeToList $ srcSpanToRange span -#endif - (_ :: 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/src/Wingman/LanguageServer/Metaprogram.hs b/src/Wingman/LanguageServer/Metaprogram.hs deleted file mode 100644 --- a/src/Wingman/LanguageServer/Metaprogram.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# 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/src/Wingman/LanguageServer/TacticProviders.hs b/src/Wingman/LanguageServer/TacticProviders.hs deleted file mode 100644 --- a/src/Wingman/LanguageServer/TacticProviders.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# 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 GHC.LanguageExtensions.Type (Extension (LambdaCase)) -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 = - requireGHC88OrHigher $ - requireHoleSort (== Hole) $ - provide BeginMetaprogram "" -commandProvider RunMetaprogram = - requireGHC88OrHigher $ - withMetaprogram $ \mp -> - provide RunMetaprogram mp - - -requireGHC88OrHigher :: TacticProvider -> TacticProvider -#if __GLASGOW_HASKELL__ >= 808 -requireGHC88OrHigher tp tpd = - tp tpd -#else -requireGHC88OrHigher _ _= - mempty -#endif - - ------------------------------------------------------------------------------- --- | 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/src/Wingman/Machinery.hs b/src/Wingman/Machinery.hs deleted file mode 100644 --- a/src/Wingman/Machinery.hs +++ /dev/null @@ -1,450 +0,0 @@ -{-# 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 substition 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/src/Wingman/Metaprogramming/Lexer.hs b/src/Wingman/Metaprogramming/Lexer.hs deleted file mode 100644 --- a/src/Wingman/Metaprogramming/Lexer.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# 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/src/Wingman/Metaprogramming/Parser.hs b/src/Wingman/Metaprogramming/Parser.hs deleted file mode 100644 --- a/src/Wingman/Metaprogramming/Parser.hs +++ /dev/null @@ -1,501 +0,0 @@ -{-# 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/src/Wingman/Metaprogramming/Parser.hs-boot b/src/Wingman/Metaprogramming/Parser.hs-boot deleted file mode 100644 --- a/src/Wingman/Metaprogramming/Parser.hs-boot +++ /dev/null @@ -1,7 +0,0 @@ -module Wingman.Metaprogramming.Parser where - -import Wingman.Metaprogramming.Lexer -import Wingman.Types - -tactic :: Parser (TacticsM ()) - diff --git a/src/Wingman/Metaprogramming/Parser/Documentation.hs b/src/Wingman/Metaprogramming/Parser/Documentation.hs deleted file mode 100644 --- a/src/Wingman/Metaprogramming/Parser/Documentation.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# 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 = "varadic" - - ------------------------------------------------------------------------------- --- | What sorts of arguments does the tactic take? Currently there is no --- distincion 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/src/Wingman/Metaprogramming/ProofState.hs b/src/Wingman/Metaprogramming/ProofState.hs deleted file mode 100644 --- a/src/Wingman/Metaprogramming/ProofState.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# 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/src/Wingman/Naming.hs b/src/Wingman/Naming.hs deleted file mode 100644 --- a/src/Wingman/Naming.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# 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/src/Wingman/Plugin.hs b/src/Wingman/Plugin.hs deleted file mode 100644 --- a/src/Wingman/Plugin.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | 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/src/Wingman/Range.hs b/src/Wingman/Range.hs deleted file mode 100644 --- a/src/Wingman/Range.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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/src/Wingman/Simplify.hs b/src/Wingman/Simplify.hs deleted file mode 100644 --- a/src/Wingman/Simplify.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# 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 - - - ------------------------------------------------------------------------------- --- | Simlify 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 simplifiation 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 simplifiation 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/src/Wingman/StaticPlugin.hs b/src/Wingman/StaticPlugin.hs deleted file mode 100644 --- a/src/Wingman/StaticPlugin.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# 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 GHC.LanguageExtensions.Type (Extension(EmptyCase, QuasiQuotes)) - -import Ide.Types - -#if __GLASGOW_HASKELL__ >= 808 -import Data.Data -import Generics.SYB -#if __GLASGOW_HASKELL__ >= 900 -import GHC.Driver.Plugins (purePlugin) -#else -import Plugins (purePlugin) -#endif -#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 -#if __GLASGOW_HASKELL__ >= 808 - , staticPlugins = staticPlugins df <> [metaprogrammingPlugin] -#endif - } -#if __GLASGOW_HASKELL__ >= 808 - , dynFlagsModifyParser = enableQuasiQuotes -#endif - } - - -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 - - -#if __GLASGOW_HASKELL__ >= 808 -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 -#endif - -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/src/Wingman/Tactics.hs b/src/Wingman/Tactics.hs deleted file mode 100644 --- a/src/Wingman/Tactics.hs +++ /dev/null @@ -1,692 +0,0 @@ -{-# 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/src/Wingman/Types.hs b/src/Wingman/Types.hs deleted file mode 100644 --- a/src/Wingman/Types.hs +++ /dev/null @@ -1,562 +0,0 @@ -{-# 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/test/AutoTupleSpec.hs b/test/AutoTupleSpec.hs deleted file mode 100644 --- a/test/AutoTupleSpec.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# 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/test/CodeAction/AutoSpec.hs b/test/CodeAction/AutoSpec.hs deleted file mode 100644 --- a/test/CodeAction/AutoSpec.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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/test/CodeAction/DestructAllSpec.hs b/test/CodeAction/DestructAllSpec.hs deleted file mode 100644 --- a/test/CodeAction/DestructAllSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# 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/test/CodeAction/DestructPunSpec.hs b/test/CodeAction/DestructPunSpec.hs deleted file mode 100644 --- a/test/CodeAction/DestructPunSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# 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/test/CodeAction/DestructSpec.hs b/test/CodeAction/DestructSpec.hs deleted file mode 100644 --- a/test/CodeAction/DestructSpec.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# 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/test/CodeAction/IntroDestructSpec.hs b/test/CodeAction/IntroDestructSpec.hs deleted file mode 100644 --- a/test/CodeAction/IntroDestructSpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# 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/test/CodeAction/IntrosSpec.hs b/test/CodeAction/IntrosSpec.hs deleted file mode 100644 --- a/test/CodeAction/IntrosSpec.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# 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/test/CodeAction/RefineSpec.hs b/test/CodeAction/RefineSpec.hs deleted file mode 100644 --- a/test/CodeAction/RefineSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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/test/CodeAction/RunMetaprogramSpec.hs b/test/CodeAction/RunMetaprogramSpec.hs deleted file mode 100644 --- a/test/CodeAction/RunMetaprogramSpec.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# 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 = -#if __GLASGOW_HASKELL__ >= 808 - goldenTest RunMetaprogram "" l c f -#else - pure () -#endif - -#if __GLASGOW_HASKELL__ >= 808 - describe "beginMetaprogram" $ do - goldenTest BeginMetaprogram "" 1 7 "MetaBegin" - goldenTest BeginMetaprogram "" 1 9 "MetaBeginNoWildify" -#endif - - 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/test/CodeAction/UseDataConSpec.hs b/test/CodeAction/UseDataConSpec.hs deleted file mode 100644 --- a/test/CodeAction/UseDataConSpec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# 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/test/CodeLens/EmptyCaseSpec.hs b/test/CodeLens/EmptyCaseSpec.hs deleted file mode 100644 --- a/test/CodeLens/EmptyCaseSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# 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/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/ProviderSpec.hs b/test/ProviderSpec.hs deleted file mode 100644 --- a/test/ProviderSpec.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/test/UnificationSpec.hs b/test/UnificationSpec.hs deleted file mode 100644 --- a/test/UnificationSpec.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# 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/test/Utils.hs b/test/Utils.hs deleted file mode 100644 --- a/test/Utils.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# 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 columnn - -> t ( Bool -> Bool -- Use 'not' for actions that shouldnt 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 = "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/test/golden/AutoEmptyString.expected.hs b/test/golden/AutoEmptyString.expected.hs deleted file mode 100644 --- a/test/golden/AutoEmptyString.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = "" diff --git a/test/golden/AutoEmptyString.hs b/test/golden/AutoEmptyString.hs deleted file mode 100644 --- a/test/golden/AutoEmptyString.hs +++ /dev/null @@ -1,2 +0,0 @@ -empty_string :: String -empty_string = _ diff --git a/test/golden/AutoEndo.expected.hs b/test/golden/AutoEndo.expected.hs deleted file mode 100644 --- a/test/golden/AutoEndo.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -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/test/golden/AutoEndo.hs b/test/golden/AutoEndo.hs deleted file mode 100644 --- a/test/golden/AutoEndo.hs +++ /dev/null @@ -1,10 +0,0 @@ -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/test/golden/AutoForallClassMethod.expected.hs b/test/golden/AutoForallClassMethod.expected.hs deleted file mode 100644 --- a/test/golden/AutoForallClassMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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/test/golden/AutoForallClassMethod.hs b/test/golden/AutoForallClassMethod.hs deleted file mode 100644 --- a/test/golden/AutoForallClassMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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/test/golden/AutoInfixApply.expected.hs b/test/golden/AutoInfixApply.expected.hs deleted file mode 100644 --- a/test/golden/AutoInfixApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = a /: f a - diff --git a/test/golden/AutoInfixApply.hs b/test/golden/AutoInfixApply.hs deleted file mode 100644 --- a/test/golden/AutoInfixApply.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> c) -> a -> (a -> b) -> c -test (/:) a f = _ - diff --git a/test/golden/AutoInfixApplyMany.expected.hs b/test/golden/AutoInfixApplyMany.expected.hs deleted file mode 100644 --- a/test/golden/AutoInfixApplyMany.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = (a /: f a) x - diff --git a/test/golden/AutoInfixApplyMany.hs b/test/golden/AutoInfixApplyMany.hs deleted file mode 100644 --- a/test/golden/AutoInfixApplyMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: (a -> b -> x -> c) -> a -> (a -> b) -> x -> c -test (/:) a f x = _ - diff --git a/test/golden/AutoInfixInfix.expected.hs b/test/golden/AutoInfixInfix.expected.hs deleted file mode 100644 --- a/test/golden/AutoInfixInfix.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = (a /: f a) --> x diff --git a/test/golden/AutoInfixInfix.hs b/test/golden/AutoInfixInfix.hs deleted file mode 100644 --- a/test/golden/AutoInfixInfix.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a -> b -> c) -> (c -> d -> e) -> a -> (a -> b) -> d -> e -test (/:) (-->) a f x = _ diff --git a/test/golden/AutoPatSynUse.expected.hs b/test/golden/AutoPatSynUse.expected.hs deleted file mode 100644 --- a/test/golden/AutoPatSynUse.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/test/golden/AutoPatSynUse.hs b/test/golden/AutoPatSynUse.hs deleted file mode 100644 --- a/test/golden/AutoPatSynUse.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - -amIASingleton :: Maybe [a] -> Maybe a -amIASingleton (JustSingleton a) = _ - diff --git a/test/golden/AutoSplitGADT.expected.hs b/test/golden/AutoSplitGADT.expected.hs deleted file mode 100644 --- a/test/golden/AutoSplitGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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/test/golden/AutoSplitGADT.hs b/test/golden/AutoSplitGADT.hs deleted file mode 100644 --- a/test/golden/AutoSplitGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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/test/golden/AutoThetaEqCtx.expected.hs b/test/golden/AutoThetaEqCtx.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqCtx.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = id -- id - diff --git a/test/golden/AutoThetaEqCtx.hs b/test/golden/AutoThetaEqCtx.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqCtx.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE GADTs #-} - -fun2 :: (a ~ b) => a -> b -fun2 = _ -- id - diff --git a/test/golden/AutoThetaEqGADT.expected.hs b/test/golden/AutoThetaEqGADT.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = id - diff --git a/test/golden/AutoThetaEqGADT.hs b/test/golden/AutoThetaEqGADT.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y = _ - diff --git a/test/golden/AutoThetaEqGADTDestruct.expected.hs b/test/golden/AutoThetaEqGADTDestruct.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqGADTDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 Y a = a - - diff --git a/test/golden/AutoThetaEqGADTDestruct.hs b/test/golden/AutoThetaEqGADTDestruct.hs deleted file mode 100644 --- a/test/golden/AutoThetaEqGADTDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Y a b = a ~ b => Y - -fun3 :: Y a b -> a -> b -fun3 = _ - - diff --git a/test/golden/AutoThetaFix.expected.hs b/test/golden/AutoThetaFix.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaFix.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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/test/golden/AutoThetaFix.hs b/test/golden/AutoThetaFix.hs deleted file mode 100644 --- a/test/golden/AutoThetaFix.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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/test/golden/AutoThetaGADT.expected.hs b/test/golden/AutoThetaGADT.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaGADT.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = pure - diff --git a/test/golden/AutoThetaGADT.hs b/test/golden/AutoThetaGADT.hs deleted file mode 100644 --- a/test/golden/AutoThetaGADT.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X = _ - diff --git a/test/golden/AutoThetaGADTDestruct.expected.hs b/test/golden/AutoThetaGADTDestruct.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 X a = pure a - diff --git a/test/golden/AutoThetaGADTDestruct.hs b/test/golden/AutoThetaGADTDestruct.hs deleted file mode 100644 --- a/test/golden/AutoThetaGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data X f = Monad f => X - -fun1 :: X f -> a -> f a -fun1 = _ - diff --git a/test/golden/AutoThetaMultipleUnification.expected.hs b/test/golden/AutoThetaMultipleUnification.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaMultipleUnification.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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/test/golden/AutoThetaMultipleUnification.hs b/test/golden/AutoThetaMultipleUnification.hs deleted file mode 100644 --- a/test/golden/AutoThetaMultipleUnification.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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/test/golden/AutoThetaRankN.expected.hs b/test/golden/AutoThetaRankN.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaRankN.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/test/golden/AutoThetaRankN.hs b/test/golden/AutoThetaRankN.hs deleted file mode 100644 --- a/test/golden/AutoThetaRankN.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -showMe :: (forall x. Show x => x -> String) -> Int -> String -showMe f = f - -showedYou :: Int -> String -showedYou = showMe (\x -> _) - diff --git a/test/golden/AutoThetaRefl.expected.hs b/test/golden/AutoThetaRefl.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaRefl.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = id -- id - diff --git a/test/golden/AutoThetaRefl.hs b/test/golden/AutoThetaRefl.hs deleted file mode 100644 --- a/test/golden/AutoThetaRefl.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 Z = _ -- id - diff --git a/test/golden/AutoThetaReflDestruct.expected.hs b/test/golden/AutoThetaReflDestruct.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaReflDestruct.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/test/golden/AutoThetaReflDestruct.hs b/test/golden/AutoThetaReflDestruct.hs deleted file mode 100644 --- a/test/golden/AutoThetaReflDestruct.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Z a b where Z :: Z a a - -fun4 :: Z a b -> a -> b -fun4 = _ -- id - - diff --git a/test/golden/AutoThetaSplitUnification.expected.hs b/test/golden/AutoThetaSplitUnification.expected.hs deleted file mode 100644 --- a/test/golden/AutoThetaSplitUnification.expected.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# 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/test/golden/AutoThetaSplitUnification.hs b/test/golden/AutoThetaSplitUnification.hs deleted file mode 100644 --- a/test/golden/AutoThetaSplitUnification.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# 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/test/golden/AutoTypeLevel.expected.hs b/test/golden/AutoTypeLevel.expected.hs deleted file mode 100644 --- a/test/golden/AutoTypeLevel.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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/test/golden/AutoTypeLevel.hs b/test/golden/AutoTypeLevel.hs deleted file mode 100644 --- a/test/golden/AutoTypeLevel.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# 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/test/golden/AutoUnusedPatternMatch.expected.hs b/test/golden/AutoUnusedPatternMatch.expected.hs deleted file mode 100644 --- a/test/golden/AutoUnusedPatternMatch.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test _ = () diff --git a/test/golden/AutoUnusedPatternMatch.hs b/test/golden/AutoUnusedPatternMatch.hs deleted file mode 100644 --- a/test/golden/AutoUnusedPatternMatch.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> () -test = _ diff --git a/test/golden/AutoZip.expected.hs b/test/golden/AutoZip.expected.hs deleted file mode 100644 --- a/test/golden/AutoZip.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -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/test/golden/AutoZip.hs b/test/golden/AutoZip.hs deleted file mode 100644 --- a/test/golden/AutoZip.hs +++ /dev/null @@ -1,3 +0,0 @@ -zip_it_up_and_zip_it_out :: [a] -> [b] -> [(a, b)] -zip_it_up_and_zip_it_out = _ - diff --git a/test/golden/ConProviders.hs b/test/golden/ConProviders.hs deleted file mode 100644 --- a/test/golden/ConProviders.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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/test/golden/DestructAllAnd.expected.hs b/test/golden/DestructAllAnd.expected.hs deleted file mode 100644 --- a/test/golden/DestructAllAnd.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -and :: Bool -> Bool -> Bool -and False False = _w0 -and False True = _w1 -and True False = _w2 -and True True = _w3 diff --git a/test/golden/DestructAllAnd.hs b/test/golden/DestructAllAnd.hs deleted file mode 100644 --- a/test/golden/DestructAllAnd.hs +++ /dev/null @@ -1,2 +0,0 @@ -and :: Bool -> Bool -> Bool -and x y = _ diff --git a/test/golden/DestructAllFunc.expected.hs b/test/golden/DestructAllFunc.expected.hs deleted file mode 100644 --- a/test/golden/DestructAllFunc.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func False y = _w0 -has_a_func True y = _w1 - diff --git a/test/golden/DestructAllFunc.hs b/test/golden/DestructAllFunc.hs deleted file mode 100644 --- a/test/golden/DestructAllFunc.hs +++ /dev/null @@ -1,3 +0,0 @@ -has_a_func :: Bool -> (a -> b) -> Bool -has_a_func x y = _ - diff --git a/test/golden/DestructAllGADTEvidence.expected.hs b/test/golden/DestructAllGADTEvidence.expected.hs deleted file mode 100644 --- a/test/golden/DestructAllGADTEvidence.expected.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# 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/test/golden/DestructAllGADTEvidence.hs b/test/golden/DestructAllGADTEvidence.hs deleted file mode 100644 --- a/test/golden/DestructAllGADTEvidence.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# 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/test/golden/DestructAllMany.expected.hs b/test/golden/DestructAllMany.expected.hs deleted file mode 100644 --- a/test/golden/DestructAllMany.expected.hs +++ /dev/null @@ -1,27 +0,0 @@ -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/test/golden/DestructAllMany.hs b/test/golden/DestructAllMany.hs deleted file mode 100644 --- a/test/golden/DestructAllMany.hs +++ /dev/null @@ -1,4 +0,0 @@ -data ABC = A | B | C - -many :: () -> Either a b -> Bool -> Maybe ABC -> ABC -> () -many u e b mabc abc = _ diff --git a/test/golden/DestructAllNonVarTopMatch.expected.hs b/test/golden/DestructAllNonVarTopMatch.expected.hs deleted file mode 100644 --- a/test/golden/DestructAllNonVarTopMatch.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -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/test/golden/DestructAllNonVarTopMatch.hs b/test/golden/DestructAllNonVarTopMatch.hs deleted file mode 100644 --- a/test/golden/DestructAllNonVarTopMatch.hs +++ /dev/null @@ -1,3 +0,0 @@ -and :: (a, b) -> Bool -> Bool -> Bool -and (a, b) x y = _ - diff --git a/test/golden/DestructAllProvider.hs b/test/golden/DestructAllProvider.hs deleted file mode 100644 --- a/test/golden/DestructAllProvider.hs +++ /dev/null @@ -1,12 +0,0 @@ --- 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/test/golden/DestructCthulhu.expected.hs b/test/golden/DestructCthulhu.expected.hs deleted file mode 100644 --- a/test/golden/DestructCthulhu.expected.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# 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/test/golden/DestructCthulhu.hs b/test/golden/DestructCthulhu.hs deleted file mode 100644 --- a/test/golden/DestructCthulhu.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# 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/test/golden/DestructDataFam.expected.hs b/test/golden/DestructDataFam.expected.hs deleted file mode 100644 --- a/test/golden/DestructDataFam.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test (Heya n) = _w0 - diff --git a/test/golden/DestructDataFam.hs b/test/golden/DestructDataFam.hs deleted file mode 100644 --- a/test/golden/DestructDataFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -data family Yo -data instance Yo = Heya Int - -test :: Yo -> Int -test b = _ - diff --git a/test/golden/DestructInt.expected.hs b/test/golden/DestructInt.expected.hs deleted file mode 100644 --- a/test/golden/DestructInt.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test (Test in') = _w0 - diff --git a/test/golden/DestructInt.hs b/test/golden/DestructInt.hs deleted file mode 100644 --- a/test/golden/DestructInt.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Int - -data Test = Test Int32 - -test :: Test -> Int32 -test t = _ - diff --git a/test/golden/DestructPun.expected.hs b/test/golden/DestructPun.expected.hs deleted file mode 100644 --- a/test/golden/DestructPun.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a = False, b} = _w0 -foo Foo {a = True, b} = _w1 - diff --git a/test/golden/DestructPun.hs b/test/golden/DestructPun.hs deleted file mode 100644 --- a/test/golden/DestructPun.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} - - -data Foo = Foo { a :: Bool, b :: Bool } - -foo Foo {a, b} = _ - diff --git a/test/golden/DestructTyFam.expected.hs b/test/golden/DestructTyFam.expected.hs deleted file mode 100644 --- a/test/golden/DestructTyFam.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test False = _w0 -test True = _w1 - diff --git a/test/golden/DestructTyFam.hs b/test/golden/DestructTyFam.hs deleted file mode 100644 --- a/test/golden/DestructTyFam.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family Yo where - Yo = Bool - -test :: Yo -> Int -test b = _ - diff --git a/test/golden/DestructTyToDataFam.expected.hs b/test/golden/DestructTyToDataFam.expected.hs deleted file mode 100644 --- a/test/golden/DestructTyToDataFam.expected.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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/test/golden/DestructTyToDataFam.hs b/test/golden/DestructTyToDataFam.hs deleted file mode 100644 --- a/test/golden/DestructTyToDataFam.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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/test/golden/EmptyCaseADT.expected.hs b/test/golden/EmptyCaseADT.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseADT.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - A n -> _ - B b -> _ - C -> _ - diff --git a/test/golden/EmptyCaseADT.hs b/test/golden/EmptyCaseADT.hs deleted file mode 100644 --- a/test/golden/EmptyCaseADT.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Foo = A Int | B Bool | C - -foo :: Foo -> () -foo x = case x of - diff --git a/test/golden/EmptyCaseApply.expected.hs b/test/golden/EmptyCaseApply.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseApply.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -blah = case show 5 of - [] -> _ - c : s -> _ diff --git a/test/golden/EmptyCaseApply.hs b/test/golden/EmptyCaseApply.hs deleted file mode 100644 --- a/test/golden/EmptyCaseApply.hs +++ /dev/null @@ -1,1 +0,0 @@ -blah = case show 5 of diff --git a/test/golden/EmptyCaseGADT.expected.hs b/test/golden/EmptyCaseGADT.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseGADT.expected.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# 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/test/golden/EmptyCaseGADT.hs b/test/golden/EmptyCaseGADT.hs deleted file mode 100644 --- a/test/golden/EmptyCaseGADT.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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/test/golden/EmptyCaseLamCase.expected.hs b/test/golden/EmptyCaseLamCase.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseLamCase.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case - False -> _ - True -> _ diff --git a/test/golden/EmptyCaseLamCase.hs b/test/golden/EmptyCaseLamCase.hs deleted file mode 100644 --- a/test/golden/EmptyCaseLamCase.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -test :: Bool -> Bool -test = \case diff --git a/test/golden/EmptyCaseNested.expected.hs b/test/golden/EmptyCaseNested.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseNested.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test = - case (case (Just "") of - Nothing -> _ - Just s -> _) of - True -> _ diff --git a/test/golden/EmptyCaseNested.hs b/test/golden/EmptyCaseNested.hs deleted file mode 100644 --- a/test/golden/EmptyCaseNested.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = - case (case (Just "") of) of - True -> _ diff --git a/test/golden/EmptyCaseParens.expected.hs b/test/golden/EmptyCaseParens.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseParens.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test = True && (case True of - False -> _ - True -> _) diff --git a/test/golden/EmptyCaseParens.hs b/test/golden/EmptyCaseParens.hs deleted file mode 100644 --- a/test/golden/EmptyCaseParens.hs +++ /dev/null @@ -1,1 +0,0 @@ -test = True && case True of diff --git a/test/golden/EmptyCaseShadow.expected.hs b/test/golden/EmptyCaseShadow.expected.hs deleted file mode 100644 --- a/test/golden/EmptyCaseShadow.expected.hs +++ /dev/null @@ -1,10 +0,0 @@ -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/test/golden/EmptyCaseShadow.hs b/test/golden/EmptyCaseShadow.hs deleted file mode 100644 --- a/test/golden/EmptyCaseShadow.hs +++ /dev/null @@ -1,7 +0,0 @@ -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/test/golden/EmptyCaseSpuriousGADT.hs b/test/golden/EmptyCaseSpuriousGADT.hs deleted file mode 100644 --- a/test/golden/EmptyCaseSpuriousGADT.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data Foo a where - Foo :: Foo Int - -foo :: Foo Bool -> () -foo x = case x of - diff --git a/test/golden/Fgmap.expected.hs b/test/golden/Fgmap.expected.hs deleted file mode 100644 --- a/test/golden/Fgmap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = fmap . fmap diff --git a/test/golden/Fgmap.hs b/test/golden/Fgmap.hs deleted file mode 100644 --- a/test/golden/Fgmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fgmap :: (Functor f, Functor g) => (a -> b) -> (f (g a) -> f (g b)) -fgmap = _ diff --git a/test/golden/FmapBoth.expected.hs b/test/golden/FmapBoth.expected.hs deleted file mode 100644 --- a/test/golden/FmapBoth.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -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/test/golden/FmapBoth.hs b/test/golden/FmapBoth.hs deleted file mode 100644 --- a/test/golden/FmapBoth.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapBoth :: (Functor f, Functor g) => (a -> b) -> (f a, g a) -> (f b, g b) -fmapBoth = _ - diff --git a/test/golden/FmapJoin.expected.hs b/test/golden/FmapJoin.expected.hs deleted file mode 100644 --- a/test/golden/FmapJoin.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap (\ m -> m >>= id) diff --git a/test/golden/FmapJoin.hs b/test/golden/FmapJoin.hs deleted file mode 100644 --- a/test/golden/FmapJoin.hs +++ /dev/null @@ -1,2 +0,0 @@ -fJoin :: (Monad m, Monad f) => f (m (m a)) -> f (m a) -fJoin = fmap _ diff --git a/test/golden/FmapJoinInLet.expected.hs b/test/golden/FmapJoinInLet.expected.hs deleted file mode 100644 --- a/test/golden/FmapJoinInLet.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# 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/test/golden/FmapJoinInLet.hs b/test/golden/FmapJoinInLet.hs deleted file mode 100644 --- a/test/golden/FmapJoinInLet.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# 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/test/golden/GoldenApplicativeThen.hs b/test/golden/GoldenApplicativeThen.hs deleted file mode 100644 --- a/test/golden/GoldenApplicativeThen.hs +++ /dev/null @@ -1,2 +0,0 @@ -useThen :: Applicative f => f Int -> f a -> f a -useThen = _ diff --git a/test/golden/GoldenArbitrary.expected.hs b/test/golden/GoldenArbitrary.expected.hs deleted file mode 100644 --- a/test/golden/GoldenArbitrary.expected.hs +++ /dev/null @@ -1,53 +0,0 @@ --- 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/test/golden/GoldenArbitrary.hs b/test/golden/GoldenArbitrary.hs deleted file mode 100644 --- a/test/golden/GoldenArbitrary.hs +++ /dev/null @@ -1,26 +0,0 @@ --- 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/test/golden/GoldenArbitrarySingleConstructor.expected.hs b/test/golden/GoldenArbitrarySingleConstructor.expected.hs deleted file mode 100644 --- a/test/golden/GoldenArbitrarySingleConstructor.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary - = (((Obj <$> arbitrary) <*> arbitrary) <*> arbitrary) <*> arbitrary diff --git a/test/golden/GoldenArbitrarySingleConstructor.hs b/test/golden/GoldenArbitrarySingleConstructor.hs deleted file mode 100644 --- a/test/golden/GoldenArbitrarySingleConstructor.hs +++ /dev/null @@ -1,6 +0,0 @@ -data Gen a - -data Obj = Obj Int Bool Char String - -arbitrary :: Gen Obj -arbitrary = _ diff --git a/test/golden/GoldenBigTuple.expected.hs b/test/golden/GoldenBigTuple.expected.hs deleted file mode 100644 --- a/test/golden/GoldenBigTuple.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ --- 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/test/golden/GoldenBigTuple.hs b/test/golden/GoldenBigTuple.hs deleted file mode 100644 --- a/test/golden/GoldenBigTuple.hs +++ /dev/null @@ -1,4 +0,0 @@ --- 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/test/golden/GoldenEitherAuto.expected.hs b/test/golden/GoldenEitherAuto.expected.hs deleted file mode 100644 --- a/test/golden/GoldenEitherAuto.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' fac _ (Left a) = fac a -either' _ fbc (Right b) = fbc b diff --git a/test/golden/GoldenEitherAuto.hs b/test/golden/GoldenEitherAuto.hs deleted file mode 100644 --- a/test/golden/GoldenEitherAuto.hs +++ /dev/null @@ -1,2 +0,0 @@ -either' :: (a -> c) -> (b -> c) -> Either a b -> c -either' = _ diff --git a/test/golden/GoldenEitherHomomorphic.expected.hs b/test/golden/GoldenEitherHomomorphic.expected.hs deleted file mode 100644 --- a/test/golden/GoldenEitherHomomorphic.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -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/test/golden/GoldenEitherHomomorphic.hs b/test/golden/GoldenEitherHomomorphic.hs deleted file mode 100644 --- a/test/golden/GoldenEitherHomomorphic.hs +++ /dev/null @@ -1,2 +0,0 @@ -eitherSplit :: a -> Either (a -> b) (a -> c) -> Either b c -eitherSplit = _ diff --git a/test/golden/GoldenFish.hs b/test/golden/GoldenFish.hs deleted file mode 100644 --- a/test/golden/GoldenFish.hs +++ /dev/null @@ -1,5 +0,0 @@ --- 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/test/golden/GoldenFmapTree.expected.hs b/test/golden/GoldenFmapTree.expected.hs deleted file mode 100644 --- a/test/golden/GoldenFmapTree.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -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/test/golden/GoldenFmapTree.hs b/test/golden/GoldenFmapTree.hs deleted file mode 100644 --- a/test/golden/GoldenFmapTree.hs +++ /dev/null @@ -1,4 +0,0 @@ -data Tree a = Leaf a | Branch (Tree a) (Tree a) - -instance Functor Tree where - fmap = _ diff --git a/test/golden/GoldenFoldr.expected.hs b/test/golden/GoldenFoldr.expected.hs deleted file mode 100644 --- a/test/golden/GoldenFoldr.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 _ b [] = b -foldr2 fabb b (a : as') = fabb a (foldr2 fabb b as') diff --git a/test/golden/GoldenFoldr.hs b/test/golden/GoldenFoldr.hs deleted file mode 100644 --- a/test/golden/GoldenFoldr.hs +++ /dev/null @@ -1,2 +0,0 @@ -foldr2 :: (a -> b -> b) -> b -> [a] -> b -foldr2 = _ diff --git a/test/golden/GoldenFromMaybe.expected.hs b/test/golden/GoldenFromMaybe.expected.hs deleted file mode 100644 --- a/test/golden/GoldenFromMaybe.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe a Nothing = a -fromMaybe _ (Just a') = a' diff --git a/test/golden/GoldenFromMaybe.hs b/test/golden/GoldenFromMaybe.hs deleted file mode 100644 --- a/test/golden/GoldenFromMaybe.hs +++ /dev/null @@ -1,2 +0,0 @@ -fromMaybe :: a -> Maybe a -> a -fromMaybe = _ diff --git a/test/golden/GoldenGADTAuto.expected.hs b/test/golden/GoldenGADTAuto.expected.hs deleted file mode 100644 --- a/test/golden/GoldenGADTAuto.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = MkCtxGADT () diff --git a/test/golden/GoldenGADTAuto.hs b/test/golden/GoldenGADTAuto.hs deleted file mode 100644 --- a/test/golden/GoldenGADTAuto.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTAuto where -data CtxGADT a where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT a - -ctxGADT :: CtxGADT () -ctxGADT = _auto diff --git a/test/golden/GoldenGADTDestruct.expected.hs b/test/golden/GoldenGADTDestruct.expected.hs deleted file mode 100644 --- a/test/golden/GoldenGADTDestruct.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# 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/test/golden/GoldenGADTDestruct.hs b/test/golden/GoldenGADTDestruct.hs deleted file mode 100644 --- a/test/golden/GoldenGADTDestruct.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE GADTs #-} -module GoldenGADTDestruct where -data CtxGADT where - MkCtxGADT :: (Show a, Eq a) => a -> CtxGADT - -ctxGADT :: CtxGADT -> String -ctxGADT gadt = _decons diff --git a/test/golden/GoldenGADTDestructCoercion.expected.hs b/test/golden/GoldenGADTDestructCoercion.expected.hs deleted file mode 100644 --- a/test/golden/GoldenGADTDestructCoercion.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/test/golden/GoldenGADTDestructCoercion.hs b/test/golden/GoldenGADTDestructCoercion.hs deleted file mode 100644 --- a/test/golden/GoldenGADTDestructCoercion.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# 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/test/golden/GoldenIdTypeFam.expected.hs b/test/golden/GoldenIdTypeFam.expected.hs deleted file mode 100644 --- a/test/golden/GoldenIdTypeFam.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = id diff --git a/test/golden/GoldenIdTypeFam.hs b/test/golden/GoldenIdTypeFam.hs deleted file mode 100644 --- a/test/golden/GoldenIdTypeFam.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -type family TyFam -type instance TyFam = Int - -tyblah' :: TyFam -> Int -tyblah' = _ diff --git a/test/golden/GoldenIdentityFunctor.expected.hs b/test/golden/GoldenIdentityFunctor.expected.hs deleted file mode 100644 --- a/test/golden/GoldenIdentityFunctor.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap fab (Ident a) = Ident (fab a) diff --git a/test/golden/GoldenIdentityFunctor.hs b/test/golden/GoldenIdentityFunctor.hs deleted file mode 100644 --- a/test/golden/GoldenIdentityFunctor.hs +++ /dev/null @@ -1,3 +0,0 @@ -data Ident a = Ident a -instance Functor Ident where - fmap = _ diff --git a/test/golden/GoldenIntros.expected.hs b/test/golden/GoldenIntros.expected.hs deleted file mode 100644 --- a/test/golden/GoldenIntros.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah n b fab s = _w0 diff --git a/test/golden/GoldenIntros.hs b/test/golden/GoldenIntros.hs deleted file mode 100644 --- a/test/golden/GoldenIntros.hs +++ /dev/null @@ -1,2 +0,0 @@ -blah :: Int -> Bool -> (a -> b) -> String -> Int -blah = _ diff --git a/test/golden/GoldenJoinCont.expected.hs b/test/golden/GoldenJoinCont.expected.hs deleted file mode 100644 --- a/test/golden/GoldenJoinCont.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -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/test/golden/GoldenJoinCont.hs b/test/golden/GoldenJoinCont.hs deleted file mode 100644 --- a/test/golden/GoldenJoinCont.hs +++ /dev/null @@ -1,4 +0,0 @@ -type Cont r a = ((a -> r) -> r) - -joinCont :: Cont r (Cont r a) -> Cont r a -joinCont = _ diff --git a/test/golden/GoldenListFmap.expected.hs b/test/golden/GoldenListFmap.expected.hs deleted file mode 100644 --- a/test/golden/GoldenListFmap.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList _ [] = [] -fmapList fab (a : as') = fab a : fmapList fab as' diff --git a/test/golden/GoldenListFmap.hs b/test/golden/GoldenListFmap.hs deleted file mode 100644 --- a/test/golden/GoldenListFmap.hs +++ /dev/null @@ -1,2 +0,0 @@ -fmapList :: (a -> b) -> [a] -> [b] -fmapList = _ diff --git a/test/golden/GoldenNote.expected.hs b/test/golden/GoldenNote.expected.hs deleted file mode 100644 --- a/test/golden/GoldenNote.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -note :: e -> Maybe a -> Either e a -note e Nothing = Left e -note _ (Just a) = Right a diff --git a/test/golden/GoldenNote.hs b/test/golden/GoldenNote.hs deleted file mode 100644 --- a/test/golden/GoldenNote.hs +++ /dev/null @@ -1,2 +0,0 @@ -note :: e -> Maybe a -> Either e a -note = _ diff --git a/test/golden/GoldenPureList.expected.hs b/test/golden/GoldenPureList.expected.hs deleted file mode 100644 --- a/test/golden/GoldenPureList.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList a = a : [] diff --git a/test/golden/GoldenPureList.hs b/test/golden/GoldenPureList.hs deleted file mode 100644 --- a/test/golden/GoldenPureList.hs +++ /dev/null @@ -1,2 +0,0 @@ -pureList :: a -> [a] -pureList = _ diff --git a/test/golden/GoldenSafeHead.expected.hs b/test/golden/GoldenSafeHead.expected.hs deleted file mode 100644 --- a/test/golden/GoldenSafeHead.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead [] = Nothing -safeHead (x : _) = Just x diff --git a/test/golden/GoldenSafeHead.hs b/test/golden/GoldenSafeHead.hs deleted file mode 100644 --- a/test/golden/GoldenSafeHead.hs +++ /dev/null @@ -1,2 +0,0 @@ -safeHead :: [x] -> Maybe x -safeHead = _ diff --git a/test/golden/GoldenShow.expected.hs b/test/golden/GoldenShow.expected.hs deleted file mode 100644 --- a/test/golden/GoldenShow.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = show diff --git a/test/golden/GoldenShow.hs b/test/golden/GoldenShow.hs deleted file mode 100644 --- a/test/golden/GoldenShow.hs +++ /dev/null @@ -1,2 +0,0 @@ -showMe :: Show a => a -> String -showMe = _ diff --git a/test/golden/GoldenShowCompose.expected.hs b/test/golden/GoldenShowCompose.expected.hs deleted file mode 100644 --- a/test/golden/GoldenShowCompose.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose fba = show . fba diff --git a/test/golden/GoldenShowCompose.hs b/test/golden/GoldenShowCompose.hs deleted file mode 100644 --- a/test/golden/GoldenShowCompose.hs +++ /dev/null @@ -1,2 +0,0 @@ -showCompose :: Show a => (b -> a) -> b -> String -showCompose = _ diff --git a/test/golden/GoldenShowMapChar.expected.hs b/test/golden/GoldenShowMapChar.expected.hs deleted file mode 100644 --- a/test/golden/GoldenShowMapChar.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test a f = f (show a) diff --git a/test/golden/GoldenShowMapChar.hs b/test/golden/GoldenShowMapChar.hs deleted file mode 100644 --- a/test/golden/GoldenShowMapChar.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Show a => a -> (String -> b) -> b -test = _ diff --git a/test/golden/GoldenSuperclass.expected.hs b/test/golden/GoldenSuperclass.expected.hs deleted file mode 100644 --- a/test/golden/GoldenSuperclass.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = super - diff --git a/test/golden/GoldenSuperclass.hs b/test/golden/GoldenSuperclass.hs deleted file mode 100644 --- a/test/golden/GoldenSuperclass.hs +++ /dev/null @@ -1,8 +0,0 @@ -class Super a where - super :: a - -class Super a => Sub a - -blah :: Sub a => a -blah = _ - diff --git a/test/golden/GoldenSwap.expected.hs b/test/golden/GoldenSwap.expected.hs deleted file mode 100644 --- a/test/golden/GoldenSwap.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap (a, b) = (b, a) diff --git a/test/golden/GoldenSwap.hs b/test/golden/GoldenSwap.hs deleted file mode 100644 --- a/test/golden/GoldenSwap.hs +++ /dev/null @@ -1,2 +0,0 @@ -swap :: (a, b) -> (b, a) -swap = _ diff --git a/test/golden/GoldenSwapMany.expected.hs b/test/golden/GoldenSwapMany.expected.hs deleted file mode 100644 --- a/test/golden/GoldenSwapMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -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/test/golden/GoldenSwapMany.hs b/test/golden/GoldenSwapMany.hs deleted file mode 100644 --- a/test/golden/GoldenSwapMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -swapMany :: (a, b, c, d, e) -> (e, d, c, b, a) -swapMany = _ diff --git a/test/golden/IntroDestructLetBinding.expected.hs b/test/golden/IntroDestructLetBinding.expected.hs deleted file mode 100644 --- a/test/golden/IntroDestructLetBinding.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x False = _w0 - x True = _w1 - pure () diff --git a/test/golden/IntroDestructLetBinding.hs b/test/golden/IntroDestructLetBinding.hs deleted file mode 100644 --- a/test/golden/IntroDestructLetBinding.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: IO () -test = do - let x :: Bool -> Int - x = _ - pure () diff --git a/test/golden/IntroDestructMany.expected.hs b/test/golden/IntroDestructMany.expected.hs deleted file mode 100644 --- a/test/golden/IntroDestructMany.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x False = _w0 -x True = _w1 - diff --git a/test/golden/IntroDestructMany.hs b/test/golden/IntroDestructMany.hs deleted file mode 100644 --- a/test/golden/IntroDestructMany.hs +++ /dev/null @@ -1,3 +0,0 @@ -x :: Bool -> Maybe Int -> String -> Int -x = _ - diff --git a/test/golden/IntroDestructOne.expected.hs b/test/golden/IntroDestructOne.expected.hs deleted file mode 100644 --- a/test/golden/IntroDestructOne.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Test where - -x :: Bool -> Int -x False = _w0 -x True = _w1 - diff --git a/test/golden/IntroDestructOne.hs b/test/golden/IntroDestructOne.hs deleted file mode 100644 --- a/test/golden/IntroDestructOne.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Test where - -x :: Bool -> Int -x = _ - diff --git a/test/golden/IntroDestructProvider.hs b/test/golden/IntroDestructProvider.hs deleted file mode 100644 --- a/test/golden/IntroDestructProvider.hs +++ /dev/null @@ -1,9 +0,0 @@ -hasAlgTy :: Maybe Int -> Int -hasAlgTy = _ - -hasFunTy :: (Int -> Int) -> Int -hasFunTy = _ - -isSaturated :: Bool -> Int -isSaturated b = _ - diff --git a/test/golden/IntrosTooMany.expected.hs b/test/golden/IntrosTooMany.expected.hs deleted file mode 100644 --- a/test/golden/IntrosTooMany.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -too_many :: a -> b -> c -too_many a b = _w0 diff --git a/test/golden/IntrosTooMany.hs b/test/golden/IntrosTooMany.hs deleted file mode 100644 --- a/test/golden/IntrosTooMany.hs +++ /dev/null @@ -1,2 +0,0 @@ -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/test/golden/KnownBigSemigroup.expected.hs b/test/golden/KnownBigSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownBigSemigroup.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -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/test/golden/KnownBigSemigroup.hs b/test/golden/KnownBigSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownBigSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -import Data.Monoid - -data Big a = Big [Bool] (Sum Int) String (Endo a) Any - -instance Semigroup (Big a) where - (<>) = _ - diff --git a/test/golden/KnownCounterfactualSemigroup.expected.hs b/test/golden/KnownCounterfactualSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownCounterfactualSemigroup.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# 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/test/golden/KnownCounterfactualSemigroup.hs b/test/golden/KnownCounterfactualSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownCounterfactualSemigroup.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} - -data Semi = Semi [String] Int - -instance Semigroup Int => Semigroup Semi where - (<>) = _ - diff --git a/test/golden/KnownDestructedSemigroup.expected.hs b/test/golden/KnownDestructedSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownDestructedSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - (Test a) <> (Test c) = Test (a <> c) - diff --git a/test/golden/KnownDestructedSemigroup.hs b/test/golden/KnownDestructedSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownDestructedSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Test a = Test [a] - -instance Semigroup (Test a) where - Test a <> Test c = _ - diff --git a/test/golden/KnownMissingMonoid.expected.hs b/test/golden/KnownMissingMonoid.expected.hs deleted file mode 100644 --- a/test/golden/KnownMissingMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = Monoid mempty _w0 - diff --git a/test/golden/KnownMissingMonoid.hs b/test/golden/KnownMissingMonoid.hs deleted file mode 100644 --- a/test/golden/KnownMissingMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid (Mono a) where - mempty = _ - diff --git a/test/golden/KnownMissingSemigroup.expected.hs b/test/golden/KnownMissingSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownMissingSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (Semi ss n) <> (Semi strs i) = Semi (ss <> strs) _w0 - diff --git a/test/golden/KnownMissingSemigroup.hs b/test/golden/KnownMissingSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownMissingSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi = Semi [String] Int - -instance Semigroup Semi where - (<>) = _ - diff --git a/test/golden/KnownModuleInstanceSemigroup.expected.hs b/test/golden/KnownModuleInstanceSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownModuleInstanceSemigroup.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/test/golden/KnownModuleInstanceSemigroup.hs b/test/golden/KnownModuleInstanceSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownModuleInstanceSemigroup.hs +++ /dev/null @@ -1,11 +0,0 @@ -data Foo = Foo - -instance Semigroup Foo where - (<>) _ _ = Foo - - -data Bar = Bar Foo Foo - -instance Semigroup Bar where - (<>) = _ - diff --git a/test/golden/KnownMonoid.expected.hs b/test/golden/KnownMonoid.expected.hs deleted file mode 100644 --- a/test/golden/KnownMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = Monoid mempty - diff --git a/test/golden/KnownMonoid.hs b/test/golden/KnownMonoid.hs deleted file mode 100644 --- a/test/golden/KnownMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono = Monoid [String] - -instance Semigroup Mono where - (<>) = undefined - -instance Monoid Mono where - mempty = _ - diff --git a/test/golden/KnownPolyMonoid.expected.hs b/test/golden/KnownPolyMonoid.expected.hs deleted file mode 100644 --- a/test/golden/KnownPolyMonoid.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/KnownPolyMonoid.hs b/test/golden/KnownPolyMonoid.hs deleted file mode 100644 --- a/test/golden/KnownPolyMonoid.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Mono a = Monoid [String] a - -instance Semigroup (Mono a) where - (<>) = undefined - -instance Monoid a => Monoid (Mono a) where - mempty = _ - diff --git a/test/golden/KnownThetaSemigroup.expected.hs b/test/golden/KnownThetaSemigroup.expected.hs deleted file mode 100644 --- a/test/golden/KnownThetaSemigroup.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (Semi a) <> (Semi a') = Semi (a <> a') - diff --git a/test/golden/KnownThetaSemigroup.hs b/test/golden/KnownThetaSemigroup.hs deleted file mode 100644 --- a/test/golden/KnownThetaSemigroup.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Semi a = Semi a - -instance Semigroup a => Semigroup (Semi a) where - (<>) = _ - diff --git a/test/golden/LayoutBind.expected.hs b/test/golden/LayoutBind.expected.hs deleted file mode 100644 --- a/test/golden/LayoutBind.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - case b of - False -> _w0 - True -> _w1 - pure () - diff --git a/test/golden/LayoutBind.hs b/test/golden/LayoutBind.hs deleted file mode 100644 --- a/test/golden/LayoutBind.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Bool -> IO () -test b = do - putStrLn "hello" - _ - pure () - diff --git a/test/golden/LayoutDollarApp.expected.hs b/test/golden/LayoutDollarApp.expected.hs deleted file mode 100644 --- a/test/golden/LayoutDollarApp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test b = id $ (case b of - False -> _w0 - True -> _w1) - diff --git a/test/golden/LayoutDollarApp.hs b/test/golden/LayoutDollarApp.hs deleted file mode 100644 --- a/test/golden/LayoutDollarApp.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test b = id $ _ - diff --git a/test/golden/LayoutInfixKeep.expected.hs b/test/golden/LayoutInfixKeep.expected.hs deleted file mode 100644 --- a/test/golden/LayoutInfixKeep.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ --- 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/test/golden/LayoutInfixKeep.hs b/test/golden/LayoutInfixKeep.hs deleted file mode 100644 --- a/test/golden/LayoutInfixKeep.hs +++ /dev/null @@ -1,4 +0,0 @@ --- keep layout that was written by the user in infix -foo :: Bool -> a -> a -b `foo` a = _ - diff --git a/test/golden/LayoutLam.expected.hs b/test/golden/LayoutLam.expected.hs deleted file mode 100644 --- a/test/golden/LayoutLam.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -test = \b -> case b of - False -> _w0 - True -> _w1 - diff --git a/test/golden/LayoutLam.hs b/test/golden/LayoutLam.hs deleted file mode 100644 --- a/test/golden/LayoutLam.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -test = \b -> _ - diff --git a/test/golden/LayoutOpApp.expected.hs b/test/golden/LayoutOpApp.expected.hs deleted file mode 100644 --- a/test/golden/LayoutOpApp.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -test :: Bool -> Bool -test b = True && (case b of - False -> _w0 - True -> _w1) diff --git a/test/golden/LayoutOpApp.hs b/test/golden/LayoutOpApp.hs deleted file mode 100644 --- a/test/golden/LayoutOpApp.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Bool -> Bool -test b = True && _ diff --git a/test/golden/LayoutPrefixKeep.expected.hs b/test/golden/LayoutPrefixKeep.expected.hs deleted file mode 100644 --- a/test/golden/LayoutPrefixKeep.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) False a = _w0 -(-/) True a = _w1 - diff --git a/test/golden/LayoutPrefixKeep.hs b/test/golden/LayoutPrefixKeep.hs deleted file mode 100644 --- a/test/golden/LayoutPrefixKeep.hs +++ /dev/null @@ -1,3 +0,0 @@ -(-/) :: Bool -> a -> a -(-/) b a = _ - diff --git a/test/golden/LayoutRec.expected.hs b/test/golden/LayoutRec.expected.hs deleted file mode 100644 --- a/test/golden/LayoutRec.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -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/test/golden/LayoutRec.hs b/test/golden/LayoutRec.hs deleted file mode 100644 --- a/test/golden/LayoutRec.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Pair a b = Pair {pa :: a, pb :: b} - -p :: Pair (a -> a) (a -> b -> c -> b) -p = Pair {pa = _, pb = _} - diff --git a/test/golden/LayoutSplitClass.expected.hs b/test/golden/LayoutSplitClass.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitClass.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -class Test a where - test :: Bool -> a - test False = _w0 - test True = _w1 - diff --git a/test/golden/LayoutSplitClass.hs b/test/golden/LayoutSplitClass.hs deleted file mode 100644 --- a/test/golden/LayoutSplitClass.hs +++ /dev/null @@ -1,4 +0,0 @@ -class Test a where - test :: Bool -> a - test x = _ - diff --git a/test/golden/LayoutSplitGuard.expected.hs b/test/golden/LayoutSplitGuard.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitGuard.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = case b of - False -> _w0 - True -> _w1 diff --git a/test/golden/LayoutSplitGuard.hs b/test/golden/LayoutSplitGuard.hs deleted file mode 100644 --- a/test/golden/LayoutSplitGuard.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Bool -> Bool -> Bool -test a b - | a = _ diff --git a/test/golden/LayoutSplitIn.expected.hs b/test/golden/LayoutSplitIn.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitIn.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in case a of { (n, s) -> _w0 } - diff --git a/test/golden/LayoutSplitIn.hs b/test/golden/LayoutSplitIn.hs deleted file mode 100644 --- a/test/golden/LayoutSplitIn.hs +++ /dev/null @@ -1,5 +0,0 @@ -test :: a -test = - let a = (1,"bbb") - in _ - diff --git a/test/golden/LayoutSplitLet.expected.hs b/test/golden/LayoutSplitLet.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitLet.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t False = _w0 - t True = _w1 - in _ - diff --git a/test/golden/LayoutSplitLet.hs b/test/golden/LayoutSplitLet.hs deleted file mode 100644 --- a/test/golden/LayoutSplitLet.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: a -test = - let t :: Bool -> a - t b = _ - in _ - diff --git a/test/golden/LayoutSplitPatSyn.expected.hs b/test/golden/LayoutSplitPatSyn.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitPatSyn.expected.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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/test/golden/LayoutSplitPatSyn.hs b/test/golden/LayoutSplitPatSyn.hs deleted file mode 100644 --- a/test/golden/LayoutSplitPatSyn.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern JustSingleton :: a -> Maybe [a] -pattern JustSingleton a <- Just [a] - - -test :: Maybe [Bool] -> Maybe Bool -test (JustSingleton a) = _ - - diff --git a/test/golden/LayoutSplitPattern.expected.hs b/test/golden/LayoutSplitPattern.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitPattern.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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/test/golden/LayoutSplitPattern.hs b/test/golden/LayoutSplitPattern.hs deleted file mode 100644 --- a/test/golden/LayoutSplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -pattern Blah :: a -> Maybe a -pattern Blah a = Just a - -test :: Maybe Bool -> a -test (Blah a) = _ - diff --git a/test/golden/LayoutSplitViewPat.expected.hs b/test/golden/LayoutSplitViewPat.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitViewPat.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> Nothing) = _w0 -splitLookup (lookup 5 -> (Just s)) = _w1 - diff --git a/test/golden/LayoutSplitViewPat.hs b/test/golden/LayoutSplitViewPat.hs deleted file mode 100644 --- a/test/golden/LayoutSplitViewPat.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -splitLookup :: [(Int, String)] -> String -splitLookup (lookup 5 -> a) = _ - diff --git a/test/golden/LayoutSplitWhere.expected.hs b/test/golden/LayoutSplitWhere.expected.hs deleted file mode 100644 --- a/test/golden/LayoutSplitWhere.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -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/test/golden/LayoutSplitWhere.hs b/test/golden/LayoutSplitWhere.hs deleted file mode 100644 --- a/test/golden/LayoutSplitWhere.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/test/golden/MessageCantUnify.hs b/test/golden/MessageCantUnify.hs deleted file mode 100644 --- a/test/golden/MessageCantUnify.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE DataKinds, GADTs #-} - -data Z ab where - Z :: (a -> b) -> Z '(a, b) - -test :: Z ab -test = _ - diff --git a/test/golden/MessageForallA.hs b/test/golden/MessageForallA.hs deleted file mode 100644 --- a/test/golden/MessageForallA.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -test = _ diff --git a/test/golden/MessageNotEnoughGas.hs b/test/golden/MessageNotEnoughGas.hs deleted file mode 100644 --- a/test/golden/MessageNotEnoughGas.hs +++ /dev/null @@ -1,13 +0,0 @@ -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/test/golden/MetaBegin.expected.hs b/test/golden/MetaBegin.expected.hs deleted file mode 100644 --- a/test/golden/MetaBegin.expected.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo = [wingman||] diff --git a/test/golden/MetaBegin.hs b/test/golden/MetaBegin.hs deleted file mode 100644 --- a/test/golden/MetaBegin.hs +++ /dev/null @@ -1,1 +0,0 @@ -foo = _ diff --git a/test/golden/MetaBeginNoWildify.expected.hs b/test/golden/MetaBeginNoWildify.expected.hs deleted file mode 100644 --- a/test/golden/MetaBeginNoWildify.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = [wingman||] - diff --git a/test/golden/MetaBeginNoWildify.hs b/test/golden/MetaBeginNoWildify.hs deleted file mode 100644 --- a/test/golden/MetaBeginNoWildify.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo v = _ - diff --git a/test/golden/MetaBindAll.expected.hs b/test/golden/MetaBindAll.expected.hs deleted file mode 100644 --- a/test/golden/MetaBindAll.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, a) diff --git a/test/golden/MetaBindAll.hs b/test/golden/MetaBindAll.hs deleted file mode 100644 --- a/test/golden/MetaBindAll.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split; assumption |] diff --git a/test/golden/MetaBindOne.expected.hs b/test/golden/MetaBindOne.expected.hs deleted file mode 100644 --- a/test/golden/MetaBindOne.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = (a, _w0) diff --git a/test/golden/MetaBindOne.hs b/test/golden/MetaBindOne.hs deleted file mode 100644 --- a/test/golden/MetaBindOne.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (a, a) -foo a = [wingman| split, assumption |] diff --git a/test/golden/MetaCataAST.expected.hs b/test/golden/MetaCataAST.expected.hs deleted file mode 100644 --- a/test/golden/MetaCataAST.expected.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# 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/test/golden/MetaCataAST.hs b/test/golden/MetaCataAST.hs deleted file mode 100644 --- a/test/golden/MetaCataAST.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# 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/test/golden/MetaCataCollapse.expected.hs b/test/golden/MetaCataCollapse.expected.hs deleted file mode 100644 --- a/test/golden/MetaCataCollapse.expected.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# 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/test/golden/MetaCataCollapse.hs b/test/golden/MetaCataCollapse.hs deleted file mode 100644 --- a/test/golden/MetaCataCollapse.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# 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/test/golden/MetaCataCollapseUnary.expected.hs b/test/golden/MetaCataCollapseUnary.expected.hs deleted file mode 100644 --- a/test/golden/MetaCataCollapseUnary.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/MetaCataCollapseUnary.hs b/test/golden/MetaCataCollapseUnary.hs deleted file mode 100644 --- a/test/golden/MetaCataCollapseUnary.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/MetaChoice.expected.hs b/test/golden/MetaChoice.expected.hs deleted file mode 100644 --- a/test/golden/MetaChoice.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = ((a, b), c) diff --git a/test/golden/MetaChoice.hs b/test/golden/MetaChoice.hs deleted file mode 100644 --- a/test/golden/MetaChoice.hs +++ /dev/null @@ -1,2 +0,0 @@ -reassoc :: (a, (b, c)) -> ((a, b), c) -reassoc (a, (b, c)) = [wingman| split; split | assume c; assume a | assume b |] diff --git a/test/golden/MetaDeepOf.expected.hs b/test/golden/MetaDeepOf.expected.hs deleted file mode 100644 --- a/test/golden/MetaDeepOf.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/MetaDeepOf.hs b/test/golden/MetaDeepOf.hs deleted file mode 100644 --- a/test/golden/MetaDeepOf.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/MetaFundeps.expected.hs b/test/golden/MetaFundeps.expected.hs deleted file mode 100644 --- a/test/golden/MetaFundeps.expected.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# 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/test/golden/MetaFundeps.hs b/test/golden/MetaFundeps.hs deleted file mode 100644 --- a/test/golden/MetaFundeps.hs +++ /dev/null @@ -1,16 +0,0 @@ -{-# 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/test/golden/MetaIdiom.expected.hs b/test/golden/MetaIdiom.expected.hs deleted file mode 100644 --- a/test/golden/MetaIdiom.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = (foo <$> _w0) <*> _w1 - diff --git a/test/golden/MetaIdiom.hs b/test/golden/MetaIdiom.hs deleted file mode 100644 --- a/test/golden/MetaIdiom.hs +++ /dev/null @@ -1,6 +0,0 @@ -foo :: Int -> Int -> Int -foo = undefined - -test :: Maybe Int -test = [wingman| idiom (use foo) |] - diff --git a/test/golden/MetaIdiomRecord.expected.hs b/test/golden/MetaIdiomRecord.expected.hs deleted file mode 100644 --- a/test/golden/MetaIdiomRecord.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = (Rec <$> _w0) <*> _w1 - diff --git a/test/golden/MetaIdiomRecord.hs b/test/golden/MetaIdiomRecord.hs deleted file mode 100644 --- a/test/golden/MetaIdiomRecord.hs +++ /dev/null @@ -1,8 +0,0 @@ -data Rec = Rec - { a :: Int - , b :: Bool - } - -test :: Maybe Rec -test = [wingman| idiom (ctor Rec) |] - diff --git a/test/golden/MetaLetSimple.expected.hs b/test/golden/MetaLetSimple.expected.hs deleted file mode 100644 --- a/test/golden/MetaLetSimple.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test - = let - a = _w0 - b = _w1 - c = _w2 - in _w3 diff --git a/test/golden/MetaLetSimple.hs b/test/golden/MetaLetSimple.hs deleted file mode 100644 --- a/test/golden/MetaLetSimple.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: Int -test = [wingman| let a b c |] diff --git a/test/golden/MetaMaybeAp.expected.hs b/test/golden/MetaMaybeAp.expected.hs deleted file mode 100644 --- a/test/golden/MetaMaybeAp.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -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/test/golden/MetaMaybeAp.hs b/test/golden/MetaMaybeAp.hs deleted file mode 100644 --- a/test/golden/MetaMaybeAp.hs +++ /dev/null @@ -1,11 +0,0 @@ -maybeAp :: Maybe (a -> b) -> Maybe a -> Maybe b -maybeAp = [wingman| - intros, - destruct_all, - obvious, - obvious, - obvious, - ctor Just, - application, - assumption - |] diff --git a/test/golden/MetaPointwise.expected.hs b/test/golden/MetaPointwise.expected.hs deleted file mode 100644 --- a/test/golden/MetaPointwise.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/MetaPointwise.hs b/test/golden/MetaPointwise.hs deleted file mode 100644 --- a/test/golden/MetaPointwise.hs +++ /dev/null @@ -1,7 +0,0 @@ -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/test/golden/MetaTry.expected.hs b/test/golden/MetaTry.expected.hs deleted file mode 100644 --- a/test/golden/MetaTry.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = (_w0, a) diff --git a/test/golden/MetaTry.hs b/test/golden/MetaTry.hs deleted file mode 100644 --- a/test/golden/MetaTry.hs +++ /dev/null @@ -1,2 +0,0 @@ -foo :: a -> (b, a) -foo a = [wingman| split; try (assumption) |] diff --git a/test/golden/MetaUseImport.expected.hs b/test/golden/MetaUseImport.expected.hs deleted file mode 100644 --- a/test/golden/MetaUseImport.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = isAlpha - diff --git a/test/golden/MetaUseImport.hs b/test/golden/MetaUseImport.hs deleted file mode 100644 --- a/test/golden/MetaUseImport.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Data.Char - - -result :: Char -> Bool -result = [wingman| intro c, use isAlpha, assume c |] - diff --git a/test/golden/MetaUseLocal.expected.hs b/test/golden/MetaUseLocal.expected.hs deleted file mode 100644 --- a/test/golden/MetaUseLocal.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = test - diff --git a/test/golden/MetaUseLocal.hs b/test/golden/MetaUseLocal.hs deleted file mode 100644 --- a/test/golden/MetaUseLocal.hs +++ /dev/null @@ -1,7 +0,0 @@ -test :: Int -test = 0 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/test/golden/MetaUseMethod.expected.hs b/test/golden/MetaUseMethod.expected.hs deleted file mode 100644 --- a/test/golden/MetaUseMethod.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = test - diff --git a/test/golden/MetaUseMethod.hs b/test/golden/MetaUseMethod.hs deleted file mode 100644 --- a/test/golden/MetaUseMethod.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -class Test where - test :: Int - -instance Test where - test = 10 - - -resolve :: Int -resolve = [wingman| use test |] - diff --git a/test/golden/MetaUseSymbol.expected.hs b/test/golden/MetaUseSymbol.expected.hs deleted file mode 100644 --- a/test/golden/MetaUseSymbol.expected.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = _w0 <> _w1 diff --git a/test/golden/MetaUseSymbol.hs b/test/golden/MetaUseSymbol.hs deleted file mode 100644 --- a/test/golden/MetaUseSymbol.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Data.Monoid - -resolve :: Sum Int -resolve = [wingman| use (<>) |] diff --git a/test/golden/MetaWithArg.expected.hs b/test/golden/MetaWithArg.expected.hs deleted file mode 100644 --- a/test/golden/MetaWithArg.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = _w0 a diff --git a/test/golden/MetaWithArg.hs b/test/golden/MetaWithArg.hs deleted file mode 100644 --- a/test/golden/MetaWithArg.hs +++ /dev/null @@ -1,2 +0,0 @@ -wat :: a -> b -wat a = [wingman| with_arg, assumption |] diff --git a/test/golden/NewtypeRecord.expected.hs b/test/golden/NewtypeRecord.expected.hs deleted file mode 100644 --- a/test/golden/NewtypeRecord.expected.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah _ = Record - diff --git a/test/golden/NewtypeRecord.hs b/test/golden/NewtypeRecord.hs deleted file mode 100644 --- a/test/golden/NewtypeRecord.hs +++ /dev/null @@ -1,7 +0,0 @@ -newtype MyRecord a = Record - { field1 :: a - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - diff --git a/test/golden/ProvideAlreadyDestructed.hs b/test/golden/ProvideAlreadyDestructed.hs deleted file mode 100644 --- a/test/golden/ProvideAlreadyDestructed.hs +++ /dev/null @@ -1,9 +0,0 @@ -foo :: Bool -> () -foo x = - if True - then - case x of - True -> _ - False -> () - else - _ diff --git a/test/golden/ProvideLocalHyOnly.hs b/test/golden/ProvideLocalHyOnly.hs deleted file mode 100644 --- a/test/golden/ProvideLocalHyOnly.hs +++ /dev/null @@ -1,2 +0,0 @@ -basilisk :: Monoid Bool => a -basilisk = _ diff --git a/test/golden/ProviderHomomorphism.hs b/test/golden/ProviderHomomorphism.hs deleted file mode 100644 --- a/test/golden/ProviderHomomorphism.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# 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/test/golden/PunGADT.expected.hs b/test/golden/PunGADT.expected.hs deleted file mode 100644 --- a/test/golden/PunGADT.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# 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/test/golden/PunGADT.hs b/test/golden/PunGADT.hs deleted file mode 100644 --- a/test/golden/PunGADT.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - GADT :: - { blah :: Int - , bar :: a - } -> GADT a - - -split :: GADT a -> a -split x = _ - diff --git a/test/golden/PunMany.expected.hs b/test/golden/PunMany.expected.hs deleted file mode 100644 --- a/test/golden/PunMany.expected.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/PunMany.hs b/test/golden/PunMany.hs deleted file mode 100644 --- a/test/golden/PunMany.hs +++ /dev/null @@ -1,7 +0,0 @@ -data Many - = Hello { world :: String } - | Goodbye { a :: Int, b :: Bool, c :: Many } - -test :: Many -> Many -test x = _ - diff --git a/test/golden/PunManyGADT.expected.hs b/test/golden/PunManyGADT.expected.hs deleted file mode 100644 --- a/test/golden/PunManyGADT.expected.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# 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/test/golden/PunManyGADT.hs b/test/golden/PunManyGADT.hs deleted file mode 100644 --- a/test/golden/PunManyGADT.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# 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/test/golden/PunShadowing.expected.hs b/test/golden/PunShadowing.expected.hs deleted file mode 100644 --- a/test/golden/PunShadowing.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax Bar {ax = n, bax} = _w0 - diff --git a/test/golden/PunShadowing.hs b/test/golden/PunShadowing.hs deleted file mode 100644 --- a/test/golden/PunShadowing.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: () -> Bar -> Int -bar ax x = _ - diff --git a/test/golden/PunSimple.expected.hs b/test/golden/PunSimple.expected.hs deleted file mode 100644 --- a/test/golden/PunSimple.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar Bar {ax, bax} = _w0 - diff --git a/test/golden/PunSimple.hs b/test/golden/PunSimple.hs deleted file mode 100644 --- a/test/golden/PunSimple.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Bar = Bar { ax :: Int, bax :: Bool } - -bar :: Bar -> Int -bar x = _ - diff --git a/test/golden/RecordCon.expected.hs b/test/golden/RecordCon.expected.hs deleted file mode 100644 --- a/test/golden/RecordCon.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -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/test/golden/RecordCon.hs b/test/golden/RecordCon.hs deleted file mode 100644 --- a/test/golden/RecordCon.hs +++ /dev/null @@ -1,9 +0,0 @@ -data MyRecord a = Record - { field1 :: a - , field2 :: Int - } - -blah :: (a -> Int) -> a -> MyRecord a -blah = _ - - diff --git a/test/golden/RefineCon.expected.hs b/test/golden/RefineCon.expected.hs deleted file mode 100644 --- a/test/golden/RefineCon.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = (_w0, _w1, _w2) - diff --git a/test/golden/RefineCon.hs b/test/golden/RefineCon.hs deleted file mode 100644 --- a/test/golden/RefineCon.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: ((), (b, c), d) -test = _ - diff --git a/test/golden/RefineGADT.expected.hs b/test/golden/RefineGADT.expected.hs deleted file mode 100644 --- a/test/golden/RefineGADT.expected.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# 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/test/golden/RefineGADT.hs b/test/golden/RefineGADT.hs deleted file mode 100644 --- a/test/golden/RefineGADT.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE GADTs #-} - -data GADT a where - One :: (b -> Int) -> GADT Int - Two :: GADT Bool - -test :: z -> GADT Int -test z = _ - diff --git a/test/golden/RefineIntro.expected.hs b/test/golden/RefineIntro.expected.hs deleted file mode 100644 --- a/test/golden/RefineIntro.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test a = _w0 diff --git a/test/golden/RefineIntro.hs b/test/golden/RefineIntro.hs deleted file mode 100644 --- a/test/golden/RefineIntro.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: a -> Either a b -test = _ diff --git a/test/golden/RefineIntroWhere.expected.hs b/test/golden/RefineIntroWhere.expected.hs deleted file mode 100644 --- a/test/golden/RefineIntroWhere.expected.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = \ m_n -> _w0 - where - -- Don't delete me! - blah = undefined - diff --git a/test/golden/RefineIntroWhere.hs b/test/golden/RefineIntroWhere.hs deleted file mode 100644 --- a/test/golden/RefineIntroWhere.hs +++ /dev/null @@ -1,6 +0,0 @@ -test :: Maybe Int -> Int -test = _ - where - -- Don't delete me! - blah = undefined - diff --git a/test/golden/RefineReader.expected.hs b/test/golden/RefineReader.expected.hs deleted file mode 100644 --- a/test/golden/RefineReader.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = Reader _w0 - diff --git a/test/golden/RefineReader.hs b/test/golden/RefineReader.hs deleted file mode 100644 --- a/test/golden/RefineReader.hs +++ /dev/null @@ -1,5 +0,0 @@ -newtype Reader r a = Reader (r -> a) - -test :: b -> Reader r a -test b = _ - diff --git a/test/golden/SplitPattern.expected.hs b/test/golden/SplitPattern.expected.hs deleted file mode 100644 --- a/test/golden/SplitPattern.expected.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/test/golden/SplitPattern.hs b/test/golden/SplitPattern.hs deleted file mode 100644 --- a/test/golden/SplitPattern.hs +++ /dev/null @@ -1,8 +0,0 @@ -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/test/golden/SubsequentTactics.expected.hs b/test/golden/SubsequentTactics.expected.hs deleted file mode 100644 --- a/test/golden/SubsequentTactics.expected.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f (Dummy n) = n - diff --git a/test/golden/SubsequentTactics.hs b/test/golden/SubsequentTactics.hs deleted file mode 100644 --- a/test/golden/SubsequentTactics.hs +++ /dev/null @@ -1,5 +0,0 @@ -data Dummy a = Dummy a - -f :: Dummy Int -> Int -f = _ - diff --git a/test/golden/T1.hs b/test/golden/T1.hs deleted file mode 100644 --- a/test/golden/T1.hs +++ /dev/null @@ -1,3 +0,0 @@ -fmapEither :: (a -> b) -> Either c a -> Either c b -fmapEither = _lalala - diff --git a/test/golden/T2.hs b/test/golden/T2.hs deleted file mode 100644 --- a/test/golden/T2.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/test/golden/T3.hs b/test/golden/T3.hs deleted file mode 100644 --- a/test/golden/T3.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -suggestHomomorphicLC :: Either a b -> Either a b -suggestHomomorphicLC = _ - -suggestLC :: Either a b -> Int -suggestLC = _ - diff --git a/test/golden/UseConLeft.expected.hs b/test/golden/UseConLeft.expected.hs deleted file mode 100644 --- a/test/golden/UseConLeft.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Left _w0 - diff --git a/test/golden/UseConLeft.hs b/test/golden/UseConLeft.hs deleted file mode 100644 --- a/test/golden/UseConLeft.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/test/golden/UseConPair.expected.hs b/test/golden/UseConPair.expected.hs deleted file mode 100644 --- a/test/golden/UseConPair.expected.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = (_w0, _w1) diff --git a/test/golden/UseConPair.hs b/test/golden/UseConPair.hs deleted file mode 100644 --- a/test/golden/UseConPair.hs +++ /dev/null @@ -1,2 +0,0 @@ -test :: (a, b) -test = _ diff --git a/test/golden/UseConRight.expected.hs b/test/golden/UseConRight.expected.hs deleted file mode 100644 --- a/test/golden/UseConRight.expected.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = Right _w0 - diff --git a/test/golden/UseConRight.hs b/test/golden/UseConRight.hs deleted file mode 100644 --- a/test/golden/UseConRight.hs +++ /dev/null @@ -1,3 +0,0 @@ -test :: Either a b -test = _ - diff --git a/test/golden/hie.yaml b/test/golden/hie.yaml deleted file mode 100644 --- a/test/golden/hie.yaml +++ /dev/null @@ -1,1 +0,0 @@ -cradle: {direct: {arguments: ["T1", "T2", "T3"]}} diff --git a/test/golden/test.cabal b/test/golden/test.cabal deleted file mode 100644 --- a/test/golden/test.cabal +++ /dev/null @@ -1,17 +0,0 @@ -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