diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,15 @@ -2026-09-22 v1.12.1.0 - * Fix space leak in the EP monad: use CPS RWST and a chunked writer (#152, @xich) +Unreleased +2026-10-06 v1.14.3.0 + * Constructing GADT decls using hand-crafted + different line deltas will be printed at a different column. (#156, @simonhorlick) + * Take `appendMissingPats` over from HLS (#148, @Aster89) +2026-09-21 v1.14.2.0 + * Fix space leak in the EP monad: use CPS RWST and a chunked writer (#150, @xich) +2026-08-06 v1.14.1.0 + * Add layout processing for HsLam + * Establish a layout offset for class and instance bodies (@simonhorlick) +2025-10-14 v1.14.0.0 + * Support GHC 9.14.1 2025-01-21 v1.12.0.0 * Harmonise layout processing so we do not have a special case for the top level This is a breaking change, in that the hand-crafted diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,12 +1,12 @@ cabal-version: 2.4 name: ghc-exactprint -version: 1.12.1.0 +version: 1.14.3.0 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 9.2.1, this library provides a means to round trip any code that can be compiled by GHC, currently excluding lhs files. . - Note: requires GHC 9.12.*. For earlier GHC + Note: requires GHC 9.14.*. For earlier GHC versions see lower version numbers. . @@ -16,12 +16,13 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.12.1 +tested-with: GHC == 9.14.1 extra-doc-files: ChangeLog extra-source-files: tests/examples/failing/*.hs tests/examples/failing/*.hs.bad tests/examples/ghc910/*.hs tests/examples/ghc912/*.hs + tests/examples/ghc914/*.hs tests/examples/pre-ghc910/*.hs tests/examples/pre-ghc910/*.hs-boot tests/examples/transform/*.hs @@ -55,10 +56,11 @@ , Language.Haskell.GHC.ExactPrint.Utils hs-source-dirs: src - build-depends: base >=4.21 && <4.22 - , containers >= 0.5 && < 0.8 - , ghc >= 9.12 && < 9.13 - , ghc-boot >= 9.12 && < 9.13 + build-depends: base >=4.22 && <4.23 + , containers >= 0.5 && < 0.9 + , extra + , ghc >= 9.14 && < 9.15 + , ghc-boot >= 9.14 && < 9.15 , mtl >= 2.3 && < 2.5 , syb >= 0.5 && < 0.8 @@ -82,25 +84,23 @@ , Test.Transform GHC-Options: -threaded Default-language: Haskell2010 - Build-depends: base < 4.22 + Build-depends: base < 4.23 , HUnit >= 1.2 , containers >= 0.5 , Diff , directory >= 1.2 - , extra , filepath >= 1.4 - , ghc >= 9.12 + , ghc >= 9.14 , ghc-paths >= 0.1 , syb >= 0.5 , silently >= 1.2 , ghc-boot - -- , os-string >= 2.0.2 if flag (dev) build-depends: mtl >= 2.2.1 else build-depends: ghc-exactprint - if impl (ghc < 9.12) + if impl (ghc < 9.14) buildable: False executable roundtrip @@ -110,18 +110,18 @@ other-modules: Test.Common Test.CommonUtils default-language: Haskell2010 - if impl (ghc >= 9.12) && flag (roundtrip) + if impl (ghc >= 9.14) && flag (roundtrip) build-depends: HUnit < 1.7 - , base < 4.22 - , containers < 0.8 + , base < 4.23 + , containers < 0.9 , directory < 1.4 - , extra < 1.8 + , extra < 1.9 , filepath < 1.6 - , ghc >= 9.12 && < 9.13 + , ghc >= 9.14 && < 9.15 , ghc-exactprint , ghc-paths < 0.2 - , time < 1.13 + , time < 1.16 , ghc-boot buildable: True else @@ -135,12 +135,12 @@ other-modules: Test.CommonUtils default-language: Haskell2010 if flag (roundtrip) - build-depends: base < 4.22 + build-depends: base < 4.23 , directory < 1.4 - , extra < 1.8 + , extra < 1.9 , filepath < 1.6 - , ghc >= 9.12 && < 9.13 - , Diff < 0.6 + , ghc >= 9.14 && < 9.15 + , Diff < 1.1 buildable: True else buildable: False diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -1,6 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -56,7 +56,6 @@ import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Utils.Panic - import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad (forM, when, unless) @@ -338,10 +337,6 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing (Maybe EpAnnUnboundVar) where - trailing _ = [] - setTrailing a _ = a - instance HasTrailing GrhsAnn where trailing _ = [] setTrailing a _ = a @@ -350,7 +345,7 @@ trailing _ = [] setTrailing a _ = a -instance HasTrailing HsRuleAnn where +instance HasTrailing HsRuleBndrsAnn where trailing _ = [] setTrailing a _ = a @@ -567,7 +562,6 @@ else return [] !trailing' <- markTrailing trailing_anns addCommentsA following - debugM $ "enterAnn:done:(anchor,priorCs,postCs) =" ++ show (showAst anchor', priorCs, postCs) -- Update original anchor, comments based on the printing process -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan @@ -827,10 +821,8 @@ c' <- markEpUniToken c return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) --- ------------------------------------- --- markEpTokenM :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) --- => Maybe (EpToken tok) -> EP w m (Maybe (EpToken tok)) +-- ------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => EpToken tok -> EP w m (EpToken tok) @@ -857,25 +849,6 @@ -- --------------------------------------------------------------------- -markArrow :: (Monad m, Monoid w, ExactPrint a) => HsArrowOf a GhcPs -> EP w m (HsArrowOf a GhcPs) -markArrow (HsUnrestrictedArrow arr) = do - arr' <- markEpUniToken arr - return (HsUnrestrictedArrow arr') -markArrow (HsLinearArrow (EpPct1 pct1 arr)) = do - pct1' <- markEpToken pct1 - arr' <- markEpUniToken arr - return (HsLinearArrow (EpPct1 pct1' arr')) -markArrow (HsLinearArrow (EpLolly arr)) = do - arr' <- markEpToken arr - return (HsLinearArrow (EpLolly arr')) -markArrow (HsExplicitMult (pct, arr) t) = do - pct' <- markEpToken pct - t' <- markAnnotated t - arr' <- markEpUniToken arr - return (HsExplicitMult (pct', arr') t') - --- --------------------------------------------------------------------- - markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt @@ -984,6 +957,7 @@ -- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword -- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively -- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword -- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword -- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) -- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword @@ -1001,6 +975,10 @@ limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) (k (importDeclAnnSafe annImp)) +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) (k (importDeclAnnQualified annImp)) @@ -1161,17 +1139,15 @@ -- --------------------------------------------------------------------- --- data HsRuleAnn --- = HsRuleAnn --- { ra_tyanns :: Maybe (TokForall, EpToken ".") --- , ra_tmanns :: Maybe (TokForall, EpToken ".") --- , ra_equal :: EpToken "=" --- , ra_rest :: ActivationAnn --- } deriving (Data, Eq) +-- data HsRuleBndrsAnn +-- = HsRuleBndrsAnn +-- { rb_tyanns :: Maybe (TokForall, EpToken ".") +-- , rb_tmanns :: Maybe (TokForall, EpToken ".") +-- } -lra_tyanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) -lra_tyanns k parent = fmap (\new -> parent { ra_tyanns = new }) - (k (ra_tyanns parent)) +lrb_tyanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tyanns k parent = fmap (\new -> parent { rb_tyanns = new }) + (k (rb_tyanns parent)) ff :: Maybe (a,b) -> (Maybe a,Maybe b) ff Nothing = (Nothing, Nothing) @@ -1188,30 +1164,21 @@ (k (ff parent)) -- (.) :: Lens' a b -> Lens' b c -> Lens' a c -lra_tyanns_fst :: Lens HsRuleAnn (Maybe TokForall) -lra_tyanns_fst = lra_tyanns . lff . lfst - -lra_tyanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) -lra_tyanns_snd = lra_tyanns . lff . lsnd - -lra_tmanns :: Lens HsRuleAnn (Maybe (TokForall, EpToken ".")) -lra_tmanns k parent = fmap (\new -> parent { ra_tmanns = new }) - (k (ra_tmanns parent)) - -lra_tmanns_fst :: Lens HsRuleAnn (Maybe TokForall) -lra_tmanns_fst = lra_tmanns . lff . lfst +lrb_tyanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tyanns_fst = lrb_tyanns . lff . lfst -lra_tmanns_snd :: Lens HsRuleAnn (Maybe (EpToken ".")) -lra_tmanns_snd = lra_tmanns . lff . lsnd +lrb_tyanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tyanns_snd = lrb_tyanns . lff . lsnd -lra_equal :: Lens HsRuleAnn (EpToken "=") -lra_equal k parent = fmap (\new -> parent { ra_equal = new }) - (k (ra_equal parent)) +lrb_tmanns :: Lens HsRuleBndrsAnn (Maybe (TokForall, EpToken ".")) +lrb_tmanns k parent = fmap (\new -> parent { rb_tmanns = new }) + (k (rb_tmanns parent)) -lra_rest :: Lens HsRuleAnn ActivationAnn -lra_rest k parent = fmap (\new -> parent { ra_rest = new }) - (k (ra_rest parent)) +lrb_tmanns_fst :: Lens HsRuleBndrsAnn (Maybe TokForall) +lrb_tmanns_fst = lrb_tmanns . lff . lfst +lrb_tmanns_snd :: Lens HsRuleBndrsAnn (Maybe (EpToken ".")) +lrb_tmanns_snd = lrb_tmanns . lff . lsnd -- --------------------------------------------------------------------- -- data GrhsAnn @@ -1467,6 +1434,11 @@ markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a +markLamMatches :: (Monad m, Monoid w, ExactPrint ast) => HsLamVariant -> ast -> EP w m ast +markLamMatches LamSingle = markAnnotated +markLamMatches LamCase = markAnnotatedWithLayout +markLamMatches LamCases = markAnnotatedWithLayout + -- --------------------------------------------------------------------- -- End of utility functions -- --------------------------------------------------------------------- @@ -1518,6 +1490,11 @@ setAnnotationAnchor ma _ _ _ = ma exact ma = mapM markAnnotated ma +instance (ExactPrint a) => ExactPrint (NonEmpty a) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor ls _ _ _ = ls + exact ls = mapM markAnnotated ls + -- --------------------------------------------------------------------- -- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' @@ -1658,7 +1635,7 @@ = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc ts cs} } exact (ImportDecl (XImportDeclPass ann msrc impl) - modname mpkg src safeflag qualFlag mAs hiding) = do + modname mpkg src st safeflag qualFlag mAs hiding) = do ann0 <- markLensFun' ann limportDeclAnnImport markEpToken let (EpAnn _anc an _cs) = ann0 @@ -1678,9 +1655,15 @@ printStringAtLsDelta (SameLine 1) "#-}" return Nothing NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + ann1 <- if safeflag - then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) - else return ann0 + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' ann2 <- case qualFlag of QualifiedPre -- 'qualified' appears in prepositive position. @@ -1693,11 +1676,16 @@ _ -> return ann2 modname' <- markAnnotated modname + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + ann4 <- case qualFlag of QualifiedPost -- 'qualified' appears in postpositive position. - -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) - _ -> return ann3 + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' (importDeclAnnAs', mAs') <- case mAs of @@ -1720,8 +1708,11 @@ } return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) - modname' mpkg src safeflag qualFlag mAs' hiding') + modname' mpkg src st safeflag qualFlag mAs' hiding') +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok -- --------------------------------------------------------------------- @@ -2032,33 +2023,14 @@ getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do + exact (HsRule ((ann_act, ann_eq),nsrc) (L ln n) act bndrs lhs rhs) = do (L ln' _) <- markAnnotated (L ln (nsrc, n)) - an0 <- markActivationL an lra_rest act - (an1, mtybndrs') <- - case mtybndrs of - Nothing -> return (an0, Nothing) - Just bndrs -> do - an1 <- markLensFun an0 lra_tyanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall - bndrs' <- mapM markAnnotated bndrs - an2 <- markLensFun an1 lra_tyanns_snd (\mt -> mapM markEpToken mt) -- AnnDot - return (an2, Just bndrs') - - an2 <- markLensFun an1 lra_tmanns_fst (\mt -> mapM markEpUniToken mt) -- AnnForall - termbndrs' <- mapM markAnnotated termbndrs - an3 <- markLensFun an2 lra_tmanns_snd (\mt -> mapM markEpToken mt) -- AnnDot - + ann_act' <- markActivation ann_act act + bndrs' <- markAnnotated bndrs lhs' <- markAnnotated lhs - an4 <- markLensFun an3 lra_equal markEpToken + ann_eq' <- markEpToken ann_eq rhs' <- markAnnotated rhs - return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') - - -markActivationL :: (Monad m, Monoid w) - => a -> Lens a ActivationAnn -> Activation -> EP w m a -markActivationL a l act = do - new <- markActivation (view l a) act - return (set l new a) + return (HsRule ((ann_act', ann_eq'),nsrc) (L ln' n) act bndrs' lhs' rhs') markActivation :: (Monad m, Monoid w) => ActivationAnn -> Activation -> EP w m ActivationAnn @@ -2129,6 +2101,26 @@ -- --------------------------------------------------------------------- +instance ExactPrint (RuleBndrs GhcPs) where + getAnnotationEntry = const NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact (RuleBndrs an0 mtybndrs termbndrs) = do + (an2, mtybndrs') <- + case mtybndrs of + Nothing -> return (an0, Nothing) + Just bndrs -> do + an1 <- markLensFun an0 lrb_tyanns_fst (traverse markEpUniToken) -- AnnForall + bndrs' <- mapM markAnnotated bndrs + an2 <- markLensFun an1 lrb_tyanns_snd (traverse markEpToken) -- AnnDot + return (an2, Just bndrs') + + an3 <- markLensFun an2 lrb_tmanns_fst (traverse markEpUniToken) -- AnnForall + termbndrs' <- mapM markAnnotated termbndrs + an4 <- markLensFun an3 lrb_tmanns_snd (traverse markEpToken) -- AnnDot + return (RuleBndrs an4 mtybndrs' termbndrs') + +-- --------------------------------------------------------------------- + instance ExactPrint (RuleBndr GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a @@ -2246,7 +2238,7 @@ (mbWarn', i', w', mbOverlap', inst_ty') <- top_matter oc' <- markEpToken oc semis' <- mapM markEpToken semis - (sortKey', ds) <- withSortKey sortKey + (sortKey', ds) <- setLayoutBoth $ withSortKey sortKey [(ClsAtTag, prepareListAnnotationA ats), (ClsAtdTag, prepareListAnnotationF adts), (ClsMethodTag, prepareListAnnotationA binds), @@ -2339,8 +2331,7 @@ return (FunBind x fun_id' matches') exact (PatBind x pat q grhss) = do - q' <- markAnnotated q - pat' <- markAnnotated pat + (q', pat') <- markMultAnnOf q (markAnnotated pat) grhss' <- markAnnotated grhss return (PatBind x pat' q' grhss') exact (PatSynBind x bind) = do @@ -2349,19 +2340,6 @@ exact x = error $ "HsBind: exact for " ++ showAst x -instance ExactPrint (HsMultAnn GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - - exact (HsNoMultAnn x) = return (HsNoMultAnn x) - exact (HsPct1Ann tok) = do - tok' <- markEpToken tok - return (HsPct1Ann tok') - exact (HsMultAnn tok ty) = do - tok' <- markEpToken tok - ty' <- markAnnotated ty - return (HsMultAnn tok' ty') - -- --------------------------------------------------------------------- instance ExactPrint (PatSynBind GhcPs GhcPs) where @@ -2380,11 +2358,10 @@ psyn' <- markAnnotated psyn v2' <- markAnnotated v2 return (ao, ac, psyn',InfixCon v1' v2') - PrefixCon tvs vs -> do + PrefixCon vs -> do psyn' <- markAnnotated psyn - tvs' <- markAnnotated tvs vs' <- markAnnotated vs - return (ao, ac, psyn', PrefixCon tvs' vs') + return (ao, ac, psyn', PrefixCon vs') RecCon vs -> do psyn' <- markAnnotated psyn ao' <- mapM markEpToken ao @@ -2693,11 +2670,19 @@ o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE act' <- markActivation act (inl_act inl) ln' <- markAnnotated ln - dc' <- markEpUniToken dc + dc' <- traverse markEpUniToken dc typs' <- markAnnotated typs c' <- markEpToken c return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) + exact (SpecSigE (AnnSpecSig o c dc act) bndrs expr inl) = do + o' <- markAnnOpen'' o (inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE + act' <- markActivation act (inl_act inl) + bndrs' <- markAnnotated bndrs + expr' <- markAnnotated expr + c' <- markEpToken c + return (SpecSigE (AnnSpecSig o' c' dc act') bndrs' expr' inl) + exact (SpecInstSig ((o,i,c),src) typ) = do o' <- markAnnOpen'' o src "{-# SPECIALISE" i' <- markEpToken i @@ -2776,8 +2761,8 @@ exact (DefaultDecl (d,op,cp) cl tys) = do d' <- markEpToken d - op' <- markEpToken op cl' <- markAnnotated cl + op' <- markEpToken op tys' <- markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') cl' tys') @@ -2809,7 +2794,7 @@ -- --------------------------------------------------------------------- -instance ExactPrint (BF.BooleanFormula (LocatedN RdrName)) where +instance ExactPrint (BF.BooleanFormula GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a @@ -2881,16 +2866,14 @@ then markAnnotated n else return n return (HsVar x n') - exact (HsUnboundVar an n) = do - case an of - Just (EpAnnUnboundVar (ob,cb) l) -> do - ob' <- markEpToken ob - l' <- markEpToken l - cb' <- markEpToken cb - return (HsUnboundVar (Just (EpAnnUnboundVar (ob',cb') l')) n) - _ -> do - printStringAdvanceA "_" >> return () - return (HsUnboundVar an n) + exact (HsHole (HoleVar n)) = do + let pun_RDR = "pun-right-hand-side" + n' <- if (showPprUnsafe n /= pun_RDR) + then markAnnotated n + else return n + return (HsHole (HoleVar n')) + -- TODO: Adapt 'HoleError' to include the 'SourceText': + exact (HsHole HoleError) = error "Cannot exact print HoleError" exact x@(HsOverLabel src l) = do printStringAdvanceA "#" >> return () case src of @@ -2921,7 +2904,7 @@ LamSingle -> return an0 LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) - mg' <- markAnnotated mg + mg' <- markLamMatches lam_variant mg return (HsLam an1 lam_variant mg') exact (HsApp an e1 e2) = do @@ -2987,7 +2970,7 @@ an0 <- markLensFun an lhsCaseAnnCase markEpToken e' <- markAnnotated e an1 <- markLensFun an0 lhsCaseAnnOf markEpToken - alts' <- setLayoutBoth $ markAnnotated alts + alts' <- markAnnotatedWithLayout alts return (HsCase an1 e' alts') exact (HsIf an e1 e2 e3) = do @@ -3004,14 +2987,14 @@ exact (HsMultiIf (i,o,c) mg) = do i0 <- markEpToken i o0 <- markEpToken o - mg' <- markAnnotated mg + mg' <- markAnnotatedWithLayout mg c0 <- markEpToken c return (HsMultiIf (i0,o0,c0) mg') exact (HsLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too tkLet' <- markEpToken tkLet - binds' <- setLayoutBoth $ markAnnotated binds + binds' <- markAnnotatedWithLayout binds tkIn' <- markEpToken tkIn e' <- markAnnotated e return (HsLet (tkLet',tkIn') binds' e') @@ -3109,7 +3092,10 @@ exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do o' <- markEpToken o oc' <- markEpToken oc - e' <- markAnnotated e + -- explicit braces don't open a layout context + e' <- case oc of + NoEpTok -> markAnnotatedWithLayout e + EpTok{} -> markAnnotated e cc' <- markEpToken cc c' <- markEpUniToken c return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e')) @@ -3133,9 +3119,8 @@ return (HsUntypedBracket a (VarBr an0 b e')) exact (HsTypedSplice an s) = do - an0 <- markEpToken an s' <- markAnnotated s - return (HsTypedSplice an0 s') + return (HsTypedSplice an s') exact (HsUntypedSplice an s) = do s' <- markAnnotated s @@ -3165,8 +3150,7 @@ return (HsEmbTy toktype' t') exact (HsFunArr _ mult arg res) = do - arg' <- markAnnotated arg - mult' <- markArrow mult + (mult', arg') <- markMultAnnOf mult (markAnnotated arg) res' <- markAnnotated res return (HsFunArr noExtField mult' arg' res') @@ -3230,7 +3214,17 @@ c' <- markEpToken c return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) +instance ExactPrint (HsTypedSplice GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + + exact (HsTypedSpliceExpr an e) = do + an0 <- markEpToken an + e' <- markAnnotated e + return (HsTypedSpliceExpr an0 e') + + -- --------------------------------------------------------------------- instance ExactPrint (HsUntypedSplice GhcPs) where @@ -3445,7 +3439,7 @@ LamSingle -> return an0 LamCase -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "case") ml) LamCases -> markLensFun an0 lepl_case (\ml -> mapM (\l -> printStringAtAA l "cases") ml) - matches' <- markAnnotated matches + matches' <- markLamMatches lam_variant matches return (HsCmdLam an1 lam_variant matches') exact (HsCmdPar (lpar, rpar) e) = do @@ -3458,7 +3452,7 @@ an0 <- markLensFun an lhsCaseAnnCase markEpToken e' <- markAnnotated e an1 <- markLensFun an0 lhsCaseAnnOf markEpToken - alts' <- markAnnotated alts + alts' <- markAnnotatedWithLayout alts return (HsCmdCase an1 e' alts') exact (HsCmdIf an a e1 e2 e3) = do @@ -3475,16 +3469,15 @@ exact (HsCmdLet (tkLet, tkIn) binds e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too tkLet' <- markEpToken tkLet - binds' <- setLayoutBoth $ markAnnotated binds + binds' <- markAnnotatedWithLayout binds tkIn' <- markEpToken tkIn e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') exact (HsCmdDo an es) = do debugM $ "HsCmdDo" - an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") - es' <- markAnnotated es - return (HsCmdDo an0 es') + (an', es') <- markAnnListA' an $ \a -> exactDo a (DoExpr Nothing) es + return (HsCmdDo an' es') -- --------------------------------------------------------------------- @@ -3534,7 +3527,7 @@ exact (RecStmt an stmts a b c d e) = do debugM $ "RecStmt" an0 <- markLensFun an lal_rest markEpToken - (an1, stmts') <- markAnnList' an0 (markAnnotated stmts) + (an1, stmts') <- markAnnList' an0 (markAnnotatedWithLayout stmts) return (RecStmt an1 stmts' a b c d e) -- --------------------------------------------------------------------- @@ -3636,7 +3629,7 @@ (c', w', vb', fds', lclas', tyvars',context') <- top_matter oc' <- markEpToken oc semis' <- mapM markEpToken semis - (sortKey', ds) <- withSortKey sortKey + (sortKey', ds) <- setLayoutBoth $ withSortKey sortKey [(ClsSigTag, prepareListAnnotationA sigs), (ClsMethodTag, prepareListAnnotationA methods), (ClsAtTag, prepareListAnnotationA ats), @@ -3723,7 +3716,7 @@ dd' <- markEpToken dd return (dd', mb_eqns) Just eqns -> do - eqns' <- markAnnotated eqns + eqns' <- markAnnotatedWithLayout eqns return (dd, Just eqns') cc' <- markEpToken cc return (w',oc',dd',cc', ClosedTypeFamily mb_eqns') @@ -3974,8 +3967,7 @@ ki' <- markAnnotated ki return (HsAppKindTy at' ty' ki') exact (HsFunTy an mult ty1 ty2) = do - ty1' <- markAnnotated ty1 - mult' <- markArrow mult + (mult', ty1') <- markMultAnnOf mult (markAnnotated ty1) ty2' <- markAnnotated ty2 return (HsFunTy an mult' ty1' ty2') exact (HsListTy an tys) = do @@ -4024,22 +4016,10 @@ exact (HsDocTy an ty doc) = do ty' <- markAnnotated ty return (HsDocTy an ty' doc) - exact (HsBangTy ((o,c,tk), mt) (HsBang up str) ty) = do - (o',c') <- - case mt of - NoSourceText -> return (o,c) - SourceText src -> do - debugM $ "HsBangTy: src=" ++ showAst src - o' <- printStringAtAA o (unpackFS src) - c' <- markEpToken c - return (o',c') - tk' <- - case str of - SrcLazy -> printStringAtAA tk "~" - SrcStrict -> printStringAtAA tk "!" - NoSrcStrict -> return tk + exact (XHsType (HsBangTy ann (HsSrcBang mt up str) ty)) = do + (ann', mt') <- exactBang (ann, mt) str ty' <- markAnnotated ty - return (HsBangTy ((o',c',tk'), mt) (HsBang up str) ty') + return (XHsType (HsBangTy ann' (HsSrcBang mt' up str) ty')) exact (HsExplicitListTy (sq,o,c) prom tys) = do sq' <- if (isPromoted prom) then markEpToken sq @@ -4278,7 +4258,7 @@ exact_condecls eq cs | gadt_syntax -- In GADT syntax = do - cs' <- mapM markAnnotated cs + cs' <- markAnnotatedWithLayout cs return (eq, cs') | otherwise -- In H98 syntax = do @@ -4334,11 +4314,10 @@ con' <- markAnnotated con t2' <- markAnnotated t2 return (con', InfixCon t1' t2') - exact_details (PrefixCon tyargs tys) = do + exact_details (PrefixCon tys) = do con' <- markAnnotated con - tyargs' <- markAnnotated tyargs tys' <- markAnnotated tys - return (con', PrefixCon tyargs' tys') + return (con', PrefixCon tys') exact_details (RecCon fields) = do con' <- markAnnotated con fields' <- markAnnotated fields @@ -4348,7 +4327,8 @@ exact (ConDeclGADT { con_g_ext = AnnConDeclGADT ops cps dcol , con_names = cons - , con_bndrs = bndrs + , con_outer_bndrs = outer_bndrs + , con_inner_bndrs = inner_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = do cons' <- mapM markAnnotated cons @@ -4357,10 +4337,12 @@ epTokensToComments ")" cps -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 - bndrs' <- case bndrs of - L _ (HsOuterImplicit _) -> return bndrs - _ -> markAnnotated bndrs + outer_bndrs' <- case outer_bndrs of + L _ (HsOuterImplicit _) -> return outer_bndrs + _ -> markAnnotated outer_bndrs + inner_bndrs' <- mapM markAnnotated inner_bndrs + mcxt' <- mapM markAnnotated mcxt args' <- case args of @@ -4374,7 +4356,8 @@ res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' - , con_bndrs = bndrs' + , con_outer_bndrs = outer_bndrs' + , con_inner_bndrs = inner_bndrs' , con_mb_cxt = mcxt', con_g_args = args' , con_res_ty = res_ty', con_doc = doc }) @@ -4403,15 +4386,14 @@ -- --------------------------------------------------------------------- -instance ExactPrint (ConDeclField GhcPs) where +instance ExactPrint (HsConDeclRecField GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (ConDeclField td names ftype mdoc) = do + exact (HsConDeclRecField _ names ftype) = do names' <- markAnnotated names - td' <- markEpUniToken td ftype' <- markAnnotated ftype - return (ConDeclField td' names' ftype' mdoc) + return (HsConDeclRecField noExtField names' ftype') -- --------------------------------------------------------------------- @@ -4424,14 +4406,61 @@ -- --------------------------------------------------------------------- -instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where +instance ExactPrint (HsConDeclField GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsScaled arr t) = do - t' <- markAnnotated t - arr' <- markArrow arr - return (HsScaled arr' t') + exact cdf@(CDF { cdf_ext, cdf_bang, cdf_multiplicity, cdf_type }) = do + (mult, (an, t)) <- markMultAnnOf cdf_multiplicity ((,) <$> exactBang cdf_ext cdf_bang <*> markAnnotated cdf_type) + return (cdf { cdf_ext = an, cdf_multiplicity = mult, cdf_type = t }) +markMultAnnOf :: (Monad m, Monoid w, ExactPrint a) => HsMultAnnOf a GhcPs -> EP w m b -> EP w m (HsMultAnnOf a GhcPs, b) +markMultAnnOf (HsUnannotated arrOrCol) tyM = do + ((), arrOrCol', ty') <- markArrOrCol (pure ()) arrOrCol tyM + return (HsUnannotated arrOrCol', ty') +markMultAnnOf (HsLinearAnn (EpPct1 pct1 arrOrCol)) tyM = do + (pct1', arrOrCol', ty') <- markArrOrCol (markEpToken pct1) arrOrCol tyM + return (HsLinearAnn (EpPct1 pct1' arrOrCol'), ty') +markMultAnnOf (HsLinearAnn (EpLolly arr)) tyM = do + ty' <- tyM + arr' <- markEpToken arr + return (HsLinearAnn (EpLolly arr'), ty') +markMultAnnOf (HsExplicitMult (pct, arrOrCol) t) tyM = do + ((pct', t'), arrOrCol', ty') <- markArrOrCol ((,) <$> markEpToken pct <*> markAnnotated t) arrOrCol tyM + return (HsExplicitMult (pct', arrOrCol') t', ty') + +markArrOrCol :: (Monad m, Monoid w) => EP w m a -> EpArrowOrColon -> EP w m b -> EP w m (a, EpArrowOrColon, b) +markArrOrCol multM (EpArrow arr) tyM = do + ty' <- tyM + mult' <- multM + arr' <- markEpUniToken arr + return (mult', EpArrow arr', ty') +markArrOrCol multM (EpColon col) tyM = do + mult' <- multM + col' <- markEpUniToken col + ty' <- tyM + return (mult', EpColon col', ty') +markArrOrCol multM EpPatBind patM = do + mult' <- multM + pat' <- patM + return (mult', EpPatBind, pat') + +exactBang :: (Monoid w, Monad m) => XConDeclField GhcPs -> SrcStrictness -> EP w m (XConDeclField GhcPs) +exactBang ((o,c,tk), mt) str = do + (o',c') <- + case mt of + NoSourceText -> return (o,c) + SourceText src -> do + debugM $ "HsBangTy: src=" ++ showAst src + o' <- printStringAtAA o (unpackFS src) + c' <- markEpToken c + return (o',c') + tk' <- + case str of + SrcLazy -> printStringAtAA tk "~" + SrcStrict -> printStringAtAA tk "!" + NoSrcStrict -> return tk + return ((o',c',tk'), mt) + -- --------------------------------------------------------------------- instance ExactPrint (LocatedP CType) where @@ -4493,7 +4522,11 @@ an0 <- markLensFun' an lal_rest markEpToken an1 <- markLensBracketsO an0 lal_brackets an2 <- markEpAnnAllLT an1 lal_semis - a' <- markAnnotated a + -- in an explicitly bidirectional pattern synonym, a match list introduced + -- by its own 'where', is a layout block + a' <- case al_rest (anns an) of + EpTok{} -> markAnnotatedWithLayout a + NoEpTok -> markAnnotated a an3 <- markLensBracketsC an2 lal_brackets return (L an3 a') @@ -4518,20 +4551,18 @@ setAnnotationAnchor = setAnchorAn exact (L ann es) = do debugM $ "LocatedL [CmdLStmt" - an0 <- markLensBracketsO ann lal_brackets - es' <- mapM markAnnotated es - an1 <- markLensBracketsC an0 lal_brackets - return (L an1 es') + (an', es') <- markAnnList ann (mapM markAnnotated es) + return (L an' es') -instance ExactPrint (LocatedL [LocatedA (ConDeclField GhcPs)]) where +instance ExactPrint (LocatedL [LocatedA (HsConDeclRecField GhcPs)]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an fs) = do - debugM $ "LocatedL [LConDeclField" + debugM $ "LocatedL [LHsConDeclRecField" (an', fs') <- markAnnList an (markAnnotated fs) return (L an' fs') -instance ExactPrint (LocatedL (BF.BooleanFormula (LocatedN RdrName))) where +instance ExactPrint (LocatedL (BF.BooleanFormula GhcPs)) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an bf) = do @@ -4622,6 +4653,10 @@ r' <- markEpToken r n' <- markAnnotated n return (IEType r' n') + exact (IEData r n) = do + r' <- markEpToken r + n' <- markAnnotated n + return (IEData r' n') -- --------------------------------------------------------------------- @@ -4784,8 +4819,6 @@ HsWord16Prim src v -> toSourceTextWithSuffix src v "" HsWord32Prim src v -> toSourceTextWithSuffix src v "" HsWord64Prim src v -> toSourceTextWithSuffix src v "" - HsInteger src v _ -> toSourceTextWithSuffix src v "" - HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" @@ -4814,20 +4847,11 @@ close' <- mapM markEpToken close return ((open', close'), c', details') -instance ExactPrint (HsConPatTyArg GhcPs) where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ _ = a - exact (HsConPatTyArg at tyarg) = do - at' <- markEpToken at - tyarg' <- markAnnotated tyarg - return (HsConPatTyArg at' tyarg') - exactConArgs :: (Monad m, Monoid w) => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) -exactConArgs (PrefixCon tyargs pats) = do - tyargs' <- markAnnotated tyargs +exactConArgs (PrefixCon pats) = do pats' <- markAnnotated pats - return (PrefixCon tyargs' pats') + return (PrefixCon pats') exactConArgs (InfixCon p1 p2) = do p1' <- markAnnotated p1 p2' <- markAnnotated p2 @@ -4889,15 +4913,14 @@ setLayoutBoth k = do oldLHS <- getLayoutOffsetD oldAnchorOffset <- getLayoutOffsetP + EPState{dMarkLayout = dPending, pMarkLayout = pPending} <- get debugM $ "setLayoutBoth: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) modify' (\a -> a { dMarkLayout = True , pMarkLayout = True } ) let reset = do debugM $ "setLayoutBoth:reset: (oldLHS,oldAnchorOffset)=" ++ show (oldLHS,oldAnchorOffset) - modify' (\a -> a { dMarkLayout = False - , dLHS = oldLHS - , pMarkLayout = False - , pLHS = oldAnchorOffset} ) + unless dPending $ modify' (\a -> a { dMarkLayout = False, dLHS = oldLHS }) + unless pPending $ modify' (\a -> a { pMarkLayout = False, pLHS = oldAnchorOffset }) k <* reset ------------------------------------------------------------------------ diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -348,12 +348,14 @@ -- Based on GHC backpack driver doBackPack dflags0 <- GHC.getSessionDynFlags let parser_opts0 = GHC.initParserOpts dflags0 - (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts + logger <- GHC.getLogger + (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 (GHC.supportedLanguagePragmas dflags0) file + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 @@ -375,13 +377,15 @@ -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags + logger <- GHC.getLogger let parser_opts0 = GHC.initParserOpts dflags0 - let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp - (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo + let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.supportedLanguagePragmas dflags0) (GHC.stringToStringBuffer $ s) fp + (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine + logger dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -83,6 +86,11 @@ , transferEntryDP' , wrapSig, wrapDecl , decl2Sig, decl2Bind + + -- * Appending patterns to case expressions + , appendMissingPats + , Matches(..) + , MatchLayout(..) ) where import Language.Haskell.GHC.ExactPrint.Types @@ -96,10 +104,17 @@ import GHC.Types.SrcLoc import Data.Data -import Data.Maybe +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty.Extra ((|:)) +import Data.Function (on, (&)) +import Data.Functor.Identity import Data.Generics +import Data.List.Extra (chunksOf, dropEnd, takeEnd) +import Data.Maybe +import Data.Semigroup (sconcat) -import Data.Functor.Identity +import Control.Applicative (ZipList(ZipList), getZipList) import Control.Monad.State ------------------------------------------------------------------------------ @@ -259,7 +274,7 @@ where -- I suspect we should assume the comments are already in the -- right place, and just set the entry DP for this case. This - -- avoids suprises from the caller. + -- avoids surprises from the caller. (d', csd', cs') = case cs of EpaComments (h:t) -> let @@ -473,9 +488,8 @@ move = map snd move' stay = map snd stay' (l'', grhss', binds', _logInfo) - = case reverse grhss of - [] -> (l, [], binds, (EpaComments [], noSrcSpanA)) - (L lg (GRHS ag grs rhs):gs) -> + = case NE.reverse grhss of + L lg (GRHS ag grs rhs):|gs -> let anc1' = setFollowingComments anc1 stay an1' = setCommentsEpAnn l anc1' @@ -490,7 +504,7 @@ then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) - in (an1', (reverse $ (L lg (GRHS ag' grs rhs):gs)), bindsm, (anc1',an1')) + in (an1', (NE.reverse $ L lg (GRHS ag' grs rhs):|gs), bindsm, (anc1',an1')) pushTrailingComments :: WithWhere -> EpAnnComments -> HsLocalBinds GhcPs -> (Bool, HsLocalBinds GhcPs) pushTrailingComments _ _cs b@EmptyLocalBinds{} = (False, b) @@ -698,9 +712,8 @@ = (L la' (Match anm mctxt pats (GRHSs x grhss' lb))) where simpleBreak n (r,_) = r > n - (la',grhss', _logInfo) = case reverse grhss of - [] -> (la,grhss,[]) - (L lg (GRHS ga gs rhs):grs) -> (la'',reverse $ (L lg (GRHS ga' gs rhs)):grs,[(gac,(csp,csf))]) + (la',grhss', _logInfo) = case NE.reverse grhss of + L lg (GRHS ga gs rhs):|grs -> (la'',NE.reverse $ L lg (GRHS ga' gs rhs):|grs,[(gac,(csp,csf))]) where anc1 = comments la (EpAnn anc an _) = ga :: EpAnn GrhsAnn @@ -771,7 +784,6 @@ oldDecls = hsDecls t oldDeclsb = balanceCommentsList oldDecls oldDecls' = oldDeclsb - `debug` ("insertAt: oldDeclsb:" ++ showAst oldDeclsb) -- |Insert a declaration at the beginning or end of the subdecls of the given -- AST item @@ -1182,3 +1194,248 @@ let decls = hsDecls t decls' <- action decls return $ replaceDecls t decls' + +-- | Isomorphic to @'Maybe' 'Matches'@, this type encodes whether a @case@-like +-- expression has braces; if it does, the type also records whether there are +-- pre-existing matches. +data MatchLayout = NonBraced | Braced Matches + +-- | Isomorphic to @Maybe Int@, this type encodes whether there are +-- pre-existing matches in a @case@-like expression **with braces**, and - if +-- there are - what's the indentation of the first of them. +-- +-- Note: it could also model the same concept for the non-braced case, but that's +-- not needed (see also 'MatchLayout'). +data Matches = NoMatches | SomeMatches !Int + +-- | Given a 'MatchGroup' and a 'NonEmpty' list of 'LMatch'es, this function +-- inserts the latter matches in the former group, honor the existing +-- 'MatchLayout', returning the new 'MatchGroup'. +-- +-- For the meaning of the first argument of type @Maybe Int@, see +-- 'getIndentation'. +-- +-- Honoring the existing layout means two things: +-- +-- 1. producing valid code, which means: +-- +-- - adding semicolons wherever they are needed, i.e. +-- +-- - if matches are braced, for every matches, +-- +-- - otherwise, for all but the last matches for groups of matches +-- that are not aligned vertically, e.g. +-- +-- - matches shown on the same line, which this plugin can produce, +-- +-- - matches shown on different lines but in a "staircase" way, +-- which this plugin never produces). +-- +-- - using the correct indentation when matches are not braced (when +-- matches are braced, the code will stay valid irrespective of the +-- indentation of the alternatives). +-- +-- 2. such valid code tries to adhere to the existing layout, which means: +-- +-- - don't alter position of existing matches nor of the opening @{@; +-- +-- - when matches are not braced, we align the first match we insert +-- with the pre-existing previous match +-- +-- - we have to make some arbitrary decision +-- +-- - when matches are not braced and no previous match exists, +-- we indent by @indentation def@ with respect to whatever layout +-- context is the current one; +-- +-- - as regards the number of matches to print per line, we inspect the +-- last group of matches appearing on one line, to determine how many +-- matches per line we insert. +-- +-- - when matches are braced, we also align them vertically (it would +-- not be necessary, in principle). +-- +-- +-- Refer to test cases to see practical examples. +appendMissingPats :: MatchGroup GhcPs (LHsExpr GhcPs) + -> NonEmpty (LMatch GhcPs (LHsExpr GhcPs)) + -> MatchLayout + -> MatchGroup GhcPs (LHsExpr GhcPs) +appendMissingPats mg@(MG { mg_alts = L altsLoc existingMatches }) missingMatches matchLayout + = let -- Choose how many patterns per line we are emitting: + chunkSize = case existingMatches of + [] -> 1 -- trivially 1 if there's no existing matches, + -- otherwise, set the size equal to the length + -- of the last group of @existingMatches@ that + -- are on the same line: + _ -> NE.length + $ NE.last + $ NE.groupBy1 startSameLine (NE.fromList existingMatches) + + -- Chunkify the matches to be inserted: + missingGroup :| missingGroups = prettyChunksOf chunkSize missingMatches + + -- Detect if the list of alternatives is between @{@ and @}@: + isBraced = isJust $ getOpeningBraceCol altsLoc + + -- Finally, lay out the missing matches: + missingMatchesEP = -- indent the first group and the following ones (see discussion above) + mapFirst indentHead missingGroup :| map (mapFirst indentTail) missingGroups + -- add a semicolon to the end of each group only if the alternatives are braced + & (if isBraced then addSemicols else id) + -- put each group on its own line + & NE.map (mapFirst putOnNewLine) + -- concatenate the groups + & sconcat + -- turn into an ordinary list + & NE.toList + where + -- add semicolons: + addSemicols = NE.zipWith ($) + -- for each one-line group of matches, + (replicate (length missingGroups) + -- only to the last match of the group, + (mapLast addSemiCol) + -- except for the last group + |: id) + + -- Indentation is complicated. + -- + -- For a non-braced @case@-like expression, the first match **of the + -- whole expression** (I mean, not the first match **to be inserted**) + -- has some anchor that depends on the surrounding code, while the + -- following matches all use their own predecessor as the anchor. + -- + -- Otherwise (i.e. for a braced @case@-like expression), all matches + -- including the first one have the same anchor that depends on the + -- surrounding code. + -- + -- Therefore, here's how we set the DeltaPos for the first and + -- following matches: + (setDPCol -> indentHead, setDPCol -> indentTail) + = case matchLayout of + NonBraced | null existingMatches -> (indentation def, 0) + NonBraced -> (0, 0) + Braced (SomeMatches indent) -> (indent, indent) + Braced NoMatches -> let indent = indentation def + in (indent, indent) + + -- Only if there's braces do we need to make sure the last of the + -- existing matches ends with @;@: + existingMatchesEP = if isBraced + then dropEnd 1 existingMatches <> (addSemiCol <$> takeEnd 1 existingMatches) + else existingMatches + + in mg { mg_alts = L altsLoc (existingMatchesEP <> missingMatchesEP) } + +-- | Accepts a @NonEmpty (LocatedA a)@ and chunkifies it by the given 'size', +-- putting all matches of each chunk on the same line, leaving 1 space in between, and +-- keeping the code valid by adding semicolons to all but the last match of each chunk. +prettyChunksOf :: Int -> NonEmpty (LocatedA a) -> NonEmpty (NonEmpty (LocatedA a)) +prettyChunksOf size allMatches = do + -- For each chunk + chunk <- chunksOf1 size allMatches + pure $ fromZipList + $ do -- of all the matches of chunk + match <- toZipList chunk + -- from the second match onwards, they go the same line, one space apart + putBeside <- toZipList $ id :| repeat (setDP 0 1) + -- all but the last match get a semicolon + addSemicols <- toZipList $ replicate (length chunk - 1) addSemiCol |: id + -- apply + pure $ addSemicols $ putBeside match + where + toZipList = ZipList . NE.toList + fromZipList = NE.fromList . getZipList + +-- Other things that we could store here are: +-- +-- - the maximum number of alternatives on one line +-- - whether or not to put the @;@ for the last alternative +data Default = Default { + -- | Max number of underscores to show for the constructor of an alternative. + -- Beyond this, the record syntax with empty braces is used. + maxUnderscores :: Int + -- | Indentation used when there's no existing alternatives to refer to. + -- Such indentation is with respect to the current layout context. +, indentation :: Int +} + +def :: Default +def = Default { maxUnderscores = 3 + , indentation = 2 } + +-- | Predicate telling if two located annotations are (actually, start) on the +-- same line. +startSameLine :: LocatedAn ann e -> LocatedAn ann e -> Bool +startSameLine = (==) `on` getStartLine + where + -- | Get the starting line of an 'HasSrcSpan'. + getStartLine :: GHC.LocatedAn ann e -> Int + getStartLine = srcSpanStartLine . realSrcSpan . getHasLoc + + +-- | Given an @EpAnn (AnnList a)@ return the starting column of +-- its opening brace, if any, otherwise 'Nothing'. +getOpeningBraceCol :: EpAnn (AnnList a) -> Maybe Int +getOpeningBraceCol (EpAnn _ (AnnList _ (ListBraces (EpTok col) _) _ _ _) _) = Just $ getStartCol $ getHasLoc col +getOpeningBraceCol _ = Nothing + +-- | Get the starting column of an 'HasSrcSpan'. +getStartCol :: SrcSpan -> Int +getStartCol = srcSpanStartCol . realSrcSpan . getHasLoc + +-- | Set the DeltaPos for the given annotation. +setDP :: Int -> Int -> LocatedAn t a -> LocatedAn t a +setDP deltaLine deltaColumn lann = setEntryDP lann $ deltaPos deltaLine deltaColumn + +-- | Set the deltaColumn for the given annotation. +setDPCol :: Int -> LocatedAn t a -> LocatedAn t a +setDPCol deltaColumn lann = setEntryDP lann + $ (\d -> deltaPos (getDeltaLine d) deltaColumn) + $ getEntryDP lann + +-- | Set the deltaLine for the given annotation. +setDPLine :: Int -> LocatedAn t a -> LocatedAn t a +setDPLine deltaLine lann = setEntryDP lann + $ (\d -> deltaPos deltaLine (deltaColumn d)) + $ getEntryDP lann + +-- | Useful helper. +putOnNewLine :: LocatedAn t a -> LocatedAn t a +putOnNewLine = setDPLine 1 + +-- | Add semicolon, unless one is already present. +addSemiCol :: LocatedA a -> LocatedA a +addSemiCol (L l@(EpAnn _ ls _) e) + | none isSemiCol (lann_trailing ls) + = L (addTrailingAnnToA (AddSemiAnn (EpTok d0)) emptyComments l) e + where + isSemiCol :: TrailingAnn -> Bool + isSemiCol (AddSemiAnn _) = True + isSemiCol _ = False +addSemiCol l = l + +-- | Version of 'Data.List.Extra.chunksOf' (**not** to be confused with +-- 'Data.List.Split.chunksOf') for a 'NonEmpty' lists. +chunksOf1 :: Int -> NonEmpty a -> NonEmpty (NonEmpty a) +chunksOf1 n xs + | n >= 1 + , (b:before, after) <- NE.splitAt n xs + = (b :| before) :| case after of + [] -> [] + _ -> map NE.fromList $ chunksOf n after + | otherwise = error "chunksOf1: the `Int` argument should be ≥ 1" + +-- | Maps a function @f@ over the first element of a 'NonEmpty' list. +mapFirst :: (a -> a) -> NonEmpty a -> NonEmpty a +mapFirst f (a :| as) = f a :| as + +-- | Maps a function @f@ over the last element of a 'NonEmpty' list. +mapLast :: (a -> a) -> NonEmpty a -> NonEmpty a +mapLast f (a :| []) = f a :| [] +mapLast f (a :| b : cs) = a :| NE.toList (mapLast f $ b :| cs) + +-- | Convenient negation of 'any'. +none :: Foldable t => (a -> Bool) -> t a -> Bool +none p xs = not $ any p xs diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,26 +28,26 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC910 - | GHC912 +data GHCVersion = GHC912 + | GHC914 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,12,0) -ghcVersion = GHC912 +#if MIN_VERSION_ghc(9,14,0) +ghcVersion = GHC914 #else -ghcVersion = GHC910 +ghcVersion = GHC912 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC910 -> ["pre-ghc910", "ghc910"] GHC912 -> ["pre-ghc910", "ghc910", "ghc912"] - -- GHC912 -> ["ghc912"] - -- GHC912 -> ["ghc912-copied"] - -- GHC912 -> ["ghc912", "ghc912-copied"] + GHC914 -> ["pre-ghc910", "ghc910", "ghc912", "ghc914"] + -- GHC914 -> ["ghc914"] + -- GHC914 -> ["ghc914-copied"] + -- GHC914 -> ["ghc914", "ghc914-copied"] -- --------------------------------------------------------------------- @@ -214,9 +214,12 @@ -- mkParserTest libdir "ghc912" "tests.hs" -- mkParserTestMD libdir "ghc912" "Fff.hs" -- mkParserTestMD libdir "transform" "AddLocalDecl5.hs" - mkParserTestBC libdir "transform" "AddLocalDecl5.hs" + -- mkParserTestBC libdir "transform" "AddLocalDecl5.hs" -- mkParserTestMD libdir "ghc912" "Module.hs" -- mkParserTestMD libdir "ghc912" "Operator.hs" + + -- mkParserTest libdir "pre-ghc910" "AnnPackageName.hs" + mkParserTestMD libdir "pre-ghc910" "AnnPackageName.hs" -- Needs GHC changes diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -129,7 +129,7 @@ case res of Left m -> return . Left $ ParseFailure (showErrorMessages m) - Right (injectedComments, dflags, pmod) -> do + Right (!injectedComments, !dflags, !pmod) -> do (printed', pmod') <- GHC.liftIO (runRoundTrip libdir f pmod injectedComments) let useCpp = GHC.xopt LangExt.Cpp dflags printed = trimPrinted printed' @@ -186,7 +186,7 @@ -- putStrLn $ "comments:" ++ showAst cs let !parsedOrigWithComments = insertCppComments parsedOrig cs -- putStrLn $ "parsedOrigWithComments:" ++ showAst parsedOrigWithComments - pmod <- f libdir parsedOrigWithComments + !pmod <- f libdir parsedOrigWithComments let !printed = exactPrint pmod return (printed, pmod) diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -22,7 +22,7 @@ ) where import Control.Monad -import Control.Monad.Extra +import GHC.Utils.Monad import Data.List hiding (find) import qualified GHC.Data.StringBuffer as GHC import System.Directory diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -12,7 +12,7 @@ import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Utils -import GHC as GHC +import GHC as GHC hiding (parseExpr) import GHC.Data.FastString as GHC import GHC.Types.Name.Occurrence as GHC import GHC.Types.Name.Reader as GHC @@ -21,6 +21,7 @@ import System.FilePath import Data.List +import qualified Data.List.NonEmpty as NE import Test.Common @@ -29,7 +30,11 @@ transformTestsTT :: LibDir -> Test transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList [ - mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + -- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" + mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses1.hs" + , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 1))) "AddCaseClauses2.hs" + , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses3.hs" + , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 0))) "AddCaseClauses4.hs" ] transformTests :: LibDir -> Test @@ -62,6 +67,17 @@ , mkTestModChange libdir changeLocalDecls2 "LocalDecls2.hs" , mkTestModChange libdir changeWhereIn3a "WhereIn3a.hs" , mkTestModChange libdir changeWhereIn3b "WhereIn3b.hs" + , mkTestModChange libdir changeGraft "InstanceGraft.hs" + , mkTestModChange libdir changeGraft "MultiwayIfGraft.hs" + , mkTestModChange libdir changeGraft "RecGraft.hs" + , mkTestModChange libdir changeGraft "ArrowGraft.hs" + , mkTestModChange libdir changeGraft "LetFirstGraft.hs" + , mkTestModChange libdir changeGraft "PatSynGraft.hs" + , mkTestModChange libdir changeGraft "DecBracketGraft.hs" + , mkTestModChange libdir changeGraft "DecBracketBracesGraft.hs" + , mkTestModChange libdir changeGadtRename "GadtRename.hs" + , mkTestModChange libdir changeTypeFamilyRename "TypeFamilyRename.hs" + , mkTestModChange libdir changeLambdaRename "LambdaRename.hs" -- , mkTestModChange changeCifToCase "C.hs" "C" ] @@ -102,6 +118,21 @@ -- --------------------------------------------------------------------- +-- | Replace instances of @graft@ with an expression that spans two lines. This +-- tests what indentation the printer uses (and whether the correct layout is +-- followed). +changeGraft :: Changer +changeGraft libdir top = do + Right parsed <- withDynFlags libdir (\df -> parseExpr df "graft" "a\n + b") + let graft = makeDeltaAst parsed + replace :: LHsExpr GhcPs -> LHsExpr GhcPs + replace x@(L _ (HsVar _ (L _ n))) + | occNameString (rdrNameOcc n) == "graft" = transferEntryDP x graft + replace x = x + return (everywhere (mkT replace) (makeDeltaAst top)) + +-- --------------------------------------------------------------------- + changeWhereIn3b :: Changer changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p @@ -200,6 +231,15 @@ changeRenameCase2 :: Changer changeRenameCase2 _libdir parsed = return (rename "fooLonger" [((3,1),(3,4))] parsed) +changeGadtRename :: Changer +changeGadtRename _libdir parsed = return (rename "Tlonger" [((4,6),(4,7)),((4,21),(4,22)),((5,21),(5,22))] parsed) + +changeTypeFamilyRename :: Changer +changeTypeFamilyRename _libdir parsed = return (rename "Flonger" [((4,13),(4,14)),((4,23),(4,24)),((5,23),(5,24))] parsed) + +changeLambdaRename :: Changer +changeLambdaRename _libdir parsed = return (rename "l" [((7,14),(7,24)),((12,30),(12,40))] parsed) + changeLayoutLet2 :: Changer changeLayoutLet2 _libdir parsed = return (rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed) @@ -303,6 +343,14 @@ , mkTestModChange libdir addHiding2 "AddHiding2.hs" , mkTestModChange libdir cloneDecl1 "CloneDecl1.hs" + + -- TODO: I should add some test also for: + -- without braces, no existing patterns + -- with braces, no existing patterns + , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses1.hs" + , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 1))) "AddCaseClauses2.hs" + , mkTestModChange libdir (addCaseClauses NonBraced) "AddCaseClauses3.hs" + , mkTestModChange libdir (addCaseClauses (Braced (SomeMatches 0))) "AddCaseClauses4.hs" ] -- --------------------------------------------------------------------- @@ -648,5 +696,39 @@ let lp' = doChange return lp' + +-- --------------------------------------------------------------------- + +addCaseClauses :: MatchLayout -> Changer +addCaseClauses layout _libdir lp = do + pure $ case lp of + -- TODO Probably the following can improve using lenses + L a hsmod@HsModule { hsmodDecls = [L b (SpliceD c (SpliceDecl d (L e (HsUntypedSpliceExpr f (L g (HsCase h i mg)))) j))] } + -> let m' = case mg of + -- for the test where there's 1 existing match + MG { mg_alts = L _ [L _ m] } -> m + -- for the test where there's no existing matches + MG { mg_alts = L _ [] } -> underscoreToUnderscore + _ -> error "Unexpected input code and/or AST structure" + + -- Apply the 'appendMissingPats' function to be tested: + mg' = appendMissingPats mg (NE.singleton (L noAnn m')) layout + + in L a hsmod{ hsmodDecls = [L b (SpliceD c (SpliceDecl d (L e (HsUntypedSpliceExpr f (L g (HsCase h i mg')))) j))] } + _ -> error "Unexpected input code and/or AST structure" + where + underscoreToUnderscore + = Match { m_ext = NoExtField + , m_ctxt = CaseAlt + , m_pats = L noSrcSpanA [nlWildPat] + , m_grhss = GRHSs emptyComments + (NE.singleton $ L noSrcSpanA $ GRHS (EpAnn noSrcSpanA + (GrhsAnn{ ga_vbar = Nothing + , ga_sep = Right $ EpUniTok d1 NormalSyntax }) + emptyComments) + [] + $ L noSrcSpanA $ HsHole $ HoleVar $ L noAnnSrcSpanDP1 $ unnamedHoleRdrName) + (EmptyLocalBinds NoExtField) + } -- --------------------------------------------------------------------- diff --git a/tests/examples/ghc914/A.8.hs b/tests/examples/ghc914/A.8.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/A.8.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module A ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + diff --git a/tests/examples/ghc914/ArrowDoSemi.hs b/tests/examples/ghc914/ArrowDoSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/ArrowDoSemi.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Arrows #-} +module ArrowDoSemi where + +import Control.Arrow + +f :: Arrow k => k Int Int +f = proc x -> do { ; y <- returnA -< x ; returnA -< y } + +g :: ArrowLoop k => k Int Int +g = proc x -> do { ; y <- returnA -< x + ; rec { ; z <- returnA -< y } + ; returnA -< z } diff --git a/tests/examples/ghc914/SI01.hs b/tests/examples/ghc914/SI01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI01.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE TemplateHaskell #-} +module SI01 where + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) + diff --git a/tests/examples/ghc914/SI26.hs b/tests/examples/ghc914/SI26.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc914/SI26.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module SI26 where + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") + diff --git a/tests/examples/transform/AddCaseClauses1.hs b/tests/examples/transform/AddCaseClauses1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses1.hs @@ -0,0 +1,2 @@ +case a of + b -> c diff --git a/tests/examples/transform/AddCaseClauses1.hs.expected b/tests/examples/transform/AddCaseClauses1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses1.hs.expected @@ -0,0 +1,3 @@ +case a of + b -> c + b -> c diff --git a/tests/examples/transform/AddCaseClauses2.hs b/tests/examples/transform/AddCaseClauses2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses2.hs @@ -0,0 +1,2 @@ +case a of { b -> c + } diff --git a/tests/examples/transform/AddCaseClauses2.hs.expected b/tests/examples/transform/AddCaseClauses2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses2.hs.expected @@ -0,0 +1,3 @@ +case a of { b -> c; + b -> c + } diff --git a/tests/examples/transform/AddCaseClauses3.hs b/tests/examples/transform/AddCaseClauses3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses3.hs @@ -0,0 +1,1 @@ +case a of diff --git a/tests/examples/transform/AddCaseClauses3.hs.expected b/tests/examples/transform/AddCaseClauses3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses3.hs.expected @@ -0,0 +1,2 @@ +case a of + _ -> _ diff --git a/tests/examples/transform/AddCaseClauses4.hs b/tests/examples/transform/AddCaseClauses4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses4.hs @@ -0,0 +1,2 @@ +case a of + {} diff --git a/tests/examples/transform/AddCaseClauses4.hs.expected b/tests/examples/transform/AddCaseClauses4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/AddCaseClauses4.hs.expected @@ -0,0 +1,3 @@ +case a of + { + _ -> _} diff --git a/tests/examples/transform/ArrowGraft.hs b/tests/examples/transform/ArrowGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/ArrowGraft.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} +module ArrowGraft where + +import Control.Arrow + +f :: Arrow k => k (Int, Int) Int +f = proc (a, b) -> do + returnA -< graft + +g :: ArrowChoice k => k (Bool, Int, Int) Int +g = proc (x, a, b) -> case x of + True -> returnA -< graft + +h :: ArrowChoice k => k (Bool, Int, Int) Int +h = proc (x, a, b) -> (\case + True -> returnA -< graft) x diff --git a/tests/examples/transform/ArrowGraft.hs.expected b/tests/examples/transform/ArrowGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/ArrowGraft.hs.expected @@ -0,0 +1,20 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE LambdaCase #-} +module ArrowGraft where + +import Control.Arrow + +f :: Arrow k => k (Int, Int) Int +f = proc (a, b) -> do + returnA -< a + + b + +g :: ArrowChoice k => k (Bool, Int, Int) Int +g = proc (x, a, b) -> case x of + True -> returnA -< a + + b + +h :: ArrowChoice k => k (Bool, Int, Int) Int +h = proc (x, a, b) -> (\case + True -> returnA -< a + + b) x diff --git a/tests/examples/transform/DecBracketBracesGraft.hs b/tests/examples/transform/DecBracketBracesGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketBracesGraft.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketBracesGraft where + +ds = graft [d| { f = x + where + x = 1 + ; g = 2 } |] diff --git a/tests/examples/transform/DecBracketBracesGraft.hs.expected b/tests/examples/transform/DecBracketBracesGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketBracesGraft.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketBracesGraft where + +ds = a + + b [d| { f = x + where + x = 1 + ; g = 2 } |] diff --git a/tests/examples/transform/DecBracketGraft.hs b/tests/examples/transform/DecBracketGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketGraft.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketGraft where + +ds = [d| + f a b = graft + g = 1 + |] diff --git a/tests/examples/transform/DecBracketGraft.hs.expected b/tests/examples/transform/DecBracketGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/DecBracketGraft.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module DecBracketGraft where + +ds = [d| + f a b = a + + b + g = 1 + |] diff --git a/tests/examples/transform/GadtRename.hs b/tests/examples/transform/GadtRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/GadtRename.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module GadtRename where + +data T where MkA :: T + MkB :: T diff --git a/tests/examples/transform/GadtRename.hs.expected b/tests/examples/transform/GadtRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/GadtRename.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE GADTs #-} +module GadtRename where + +data Tlonger where MkA :: Tlonger + MkB :: Tlonger diff --git a/tests/examples/transform/InstanceGraft.hs b/tests/examples/transform/InstanceGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/InstanceGraft.hs @@ -0,0 +1,8 @@ +module InstanceGraft where + +class C t where + go :: t -> Int + go n = graft + +instance C Int where + go n = graft diff --git a/tests/examples/transform/InstanceGraft.hs.expected b/tests/examples/transform/InstanceGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/InstanceGraft.hs.expected @@ -0,0 +1,10 @@ +module InstanceGraft where + +class C t where + go :: t -> Int + go n = a + + b + +instance C Int where + go n = a + + b diff --git a/tests/examples/transform/LambdaRename.hs b/tests/examples/transform/LambdaRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LambdaRename.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE Arrows #-} +module LambdaRename where + +import Control.Arrow + +f :: IO Int +f = return 1 `longname` \y -> + do + return y + +g :: Arrow k => k Int Int +g = proc x -> (returnA -< x) `longname` \y -> + do + returnA -< y diff --git a/tests/examples/transform/LambdaRename.hs.expected b/tests/examples/transform/LambdaRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LambdaRename.hs.expected @@ -0,0 +1,14 @@ +{-# LANGUAGE Arrows #-} +module LambdaRename where + +import Control.Arrow + +f :: IO Int +f = return 1 `l` \y -> + do + return y + +g :: Arrow k => k Int Int +g = proc x -> (returnA -< x) `l` \y -> + do + returnA -< y diff --git a/tests/examples/transform/LetFirstGraft.hs b/tests/examples/transform/LetFirstGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetFirstGraft.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RecursiveDo #-} +module LetFirstGraft where + +import Control.Arrow + +f :: Int -> Int -> IO Int +f a b = do + let z = a in return z + return (graft) + +g :: Int -> Int -> IO Int +g a b = do + rec let z = a in return z + x <- return (graft) + return x + +h :: Arrow k => k (Int, Int) Int +h = proc (a, b) -> do + let c = a in returnA -< c + returnA -< graft diff --git a/tests/examples/transform/LetFirstGraft.hs.expected b/tests/examples/transform/LetFirstGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/LetFirstGraft.hs.expected @@ -0,0 +1,24 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RecursiveDo #-} +module LetFirstGraft where + +import Control.Arrow + +f :: Int -> Int -> IO Int +f a b = do + let z = a in return z + return (a + + b) + +g :: Int -> Int -> IO Int +g a b = do + rec let z = a in return z + x <- return (a + + b) + return x + +h :: Arrow k => k (Int, Int) Int +h = proc (a, b) -> do + let c = a in returnA -< c + returnA -< a + + b diff --git a/tests/examples/transform/MultiwayIfGraft.hs b/tests/examples/transform/MultiwayIfGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/MultiwayIfGraft.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiwayIfGraft where + +checkNumber :: Int -> String +checkNumber x = + if | x > 0 -> "Positive" + | graft < 0 -> "Negative" + | otherwise -> "Zero" diff --git a/tests/examples/transform/MultiwayIfGraft.hs.expected b/tests/examples/transform/MultiwayIfGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/MultiwayIfGraft.hs.expected @@ -0,0 +1,9 @@ +{-# LANGUAGE MultiWayIf #-} +module MultiwayIfGraft where + +checkNumber :: Int -> String +checkNumber x = + if | x > 0 -> "Positive" + | a + + b < 0 -> "Negative" + | otherwise -> "Zero" diff --git a/tests/examples/transform/PatSynGraft.hs b/tests/examples/transform/PatSynGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/PatSynGraft.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module PatSynGraft where + +pattern P :: Int -> Int +pattern P x <- (subtract 1 -> x) where + P a = graft diff --git a/tests/examples/transform/PatSynGraft.hs.expected b/tests/examples/transform/PatSynGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/PatSynGraft.hs.expected @@ -0,0 +1,8 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module PatSynGraft where + +pattern P :: Int -> Int +pattern P x <- (subtract 1 -> x) where + P a = a + + b diff --git a/tests/examples/transform/RecGraft.hs b/tests/examples/transform/RecGraft.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RecGraft.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RecursiveDo #-} +module RecGraft where + +g :: Int -> Int -> IO Int +g a b = do + rec x <- return (graft) + y <- return x + return y diff --git a/tests/examples/transform/RecGraft.hs.expected b/tests/examples/transform/RecGraft.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/RecGraft.hs.expected @@ -0,0 +1,9 @@ +{-# LANGUAGE RecursiveDo #-} +module RecGraft where + +g :: Int -> Int -> IO Int +g a b = do + rec x <- return (a + + b) + y <- return x + return y diff --git a/tests/examples/transform/TypeFamilyRename.hs b/tests/examples/transform/TypeFamilyRename.hs new file mode 100644 --- /dev/null +++ b/tests/examples/transform/TypeFamilyRename.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyRename where + +type family F a where F Int = Bool + F a = a diff --git a/tests/examples/transform/TypeFamilyRename.hs.expected b/tests/examples/transform/TypeFamilyRename.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/transform/TypeFamilyRename.hs.expected @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} +module TypeFamilyRename where + +type family Flonger a where Flonger Int = Bool + Flonger a = a