diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2022-12-19 v1.8.0.0 + * Support GHC 9.8.1 2022-12-19 v1.7.1.0 * Add CI for GHC 9.6.3 * Reinstate MonadTrans on TransFormT (via @Vekhir) diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,11 +1,11 @@ name: ghc-exactprint -version: 1.7.1.0 +version: 1.8.0.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.6.*. For earlier GHC + Note: requires GHC 9.8.*. For earlier GHC versions see lower version numbers. . @@ -15,9 +15,7 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.6.1, - GHC == 9.6.2, - GHC == 9.6.3 +tested-with: GHC == 9.8.1 extra-source-files: ChangeLog tests/examples/failing/*.hs tests/examples/ghc710-only/*.hs @@ -32,6 +30,7 @@ tests/examples/ghc92/*.hs tests/examples/ghc94/*.hs tests/examples/ghc96/*.hs + tests/examples/ghc98/*.hs tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs tests/examples/pre-ghc90/*.hs @@ -75,23 +74,22 @@ -- other-extensions: GHC-Options: -Wall -Wredundant-constraints -- GHC-Options: -Weverything - build-depends: base >=4.18 && <4.19 + build-depends: base >=4.19 && <4.20 , bytestring >= 0.10.6 , containers >= 0.5 , ordered-containers , data-default , directory >= 1.2 , filepath >= 1.4 - , ghc >= 9.4.1 + , ghc >= 9.8.1 , mtl >= 2.2.1 , syb >= 0.5 , free >= 4.12 - , fail >= 4.9 && <4.10 , ghc-boot default-language: Haskell2010 - if impl (ghc < 9.6) + if impl (ghc < 9.8) buildable: False Test-Suite test @@ -110,7 +108,7 @@ GHC-Options: -threaded -Wall -Wredundant-constraints Default-language: Haskell2010 Build-depends: HUnit >= 1.2 - , base < 4.19 + , base < 4.20 , bytestring , containers >= 0.5 , ordered-containers @@ -119,20 +117,18 @@ , directory >= 1.2 , extra , filepath >= 1.4 - , ghc >= 9.4.1 + , ghc >= 9.8.1 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 , silently >= 1.2 - -- for the lib only - , fail >= 4.9 && <4.10 , ghc-boot , Cabal-syntax if flag (dev) build-depends: free else build-depends: ghc-exactprint - if impl (ghc < 9.4) + if impl (ghc < 9.8) buildable: False executable roundtrip @@ -142,12 +138,13 @@ Test.CommonUtils -- Test.Consistency default-language: Haskell2010 - if impl (ghc >= 9.4) && flag (roundtrip) + if impl (ghc >= 9.8) && flag (roundtrip) build-depends: HUnit , base , containers , directory + , extra , filemanip , filepath , ghc @@ -169,6 +166,7 @@ if flag (roundtrip) build-depends: base , directory + , extra , filemanip , filepath , ghc @@ -187,9 +185,10 @@ build-depends: base , containers , directory + , extra , filemanip , filepath - , ghc >= 9.4.1 + , ghc >= 9.8.1 , HUnit , text >= 1.2.2 , turtle >= 1.3.0 diff --git a/src/Language/Haskell/GHC/ExactPrint/Dump.hs b/src/Language/Haskell/GHC/ExactPrint/Dump.hs --- a/src/Language/Haskell/GHC/ExactPrint/Dump.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Dump.hs @@ -34,7 +34,6 @@ import qualified Data.ByteString as B import Data.Generics (extQ, ext1Q, ext2Q) -import Language.Haskell.GHC.ExactPrint.Utils data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan deriving (Eq,Show) @@ -63,6 +62,7 @@ `extQ` annotationAnnParen `extQ` annotationTrailingAnn `extQ` annotationEpaLocation + `extQ` annotationNoEpAnns `extQ` addEpAnn `extQ` lit `extQ` litr `extQ` litt `extQ` sourceText @@ -133,12 +133,12 @@ sourceText :: SourceText -> SDoc sourceText NoSourceText = parens $ text "NoSourceText" sourceText (SourceText src) = case bs of - NoBlankSrcSpan -> parens $ text "SourceText" <+> text src - BlankSrcSpanFile -> parens $ text "SourceText" <+> text src + NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src + BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src _ -> parens $ text "SourceText" <+> text "blanked" epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r epaAnchor (EpaDelta d cs) = case ba of NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" @@ -152,7 +152,7 @@ occName n = braces $ text "OccName:" - <+> text (occNameString n) + <+> ftext (occNameFS n) moduleName :: ModuleName -> SDoc moduleName m = braces $ text "ModuleName:" <+> ppr m @@ -161,10 +161,12 @@ srcSpan ss = case bs of BlankSrcSpan -> text "{ ss }" NoBlankSrcSpan -> braces $ char ' ' <> - (hang (pprSrcSpanWithAnchor ss) 1 + (hang (ppr ss) 1 + -- TODO: show annotations here (text "")) BlankSrcSpanFile -> braces $ char ' ' <> (hang (pprUserSpan False ss) 1 + -- TODO: show annotations here (text "")) realSrcSpan :: RealSrcSpan -> SDoc @@ -172,9 +174,11 @@ BlankSrcSpan -> text "{ ss }" NoBlankSrcSpan -> braces $ char ' ' <> (hang (ppr ss) 1 + -- TODO: show annotations here (text "")) BlankSrcSpanFile -> braces $ char ' ' <> (hang (pprUserRealSpan False ss) 1 + -- TODO: show annotations here (text "")) @@ -253,6 +257,9 @@ annotationEpaLocation :: EpAnn EpaLocation -> SDoc annotationEpaLocation = annotation' (text "EpAnn EpaLocation") + annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc + annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") + annotation' :: forall a .(Data a) => SDoc -> EpAnn a -> SDoc annotation' tag anns = case ba of @@ -296,7 +303,3 @@ normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs normalize_newlines (x:xs) = x:normalize_newlines xs normalize_newlines [] = [] - -pprSrcSpanWithAnchor :: SrcSpan -> SDoc -pprSrcSpanWithAnchor ss@(UnhelpfulSpan _) = ppr ss -pprSrcSpanWithAnchor ss = ppr ss <+> parens (ppr (hackSrcSpanToAnchor ss)) 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 @@ -51,7 +51,6 @@ import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic -import qualified GHC.Data.Strict as Strict import GHC.Base (NonEmpty(..)) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) @@ -133,6 +132,7 @@ , uExtraDP = Nothing , epComments = [] , epCommentsApplied = [] + , epEof = Nothing } @@ -207,6 +207,7 @@ -- Shared , epComments :: ![Comment] , epCommentsApplied :: ![[Comment]] + , epEof :: !(Maybe (RealSrcSpan, RealSrcSpan)) } -- --------------------------------------------------------------------- @@ -257,11 +258,7 @@ fromAnn' :: (HasEntry a) => a -> Entry fromAnn' an = case fromAnn an of NoEntryVal -> NoEntryVal - Entry a c _ u -> Entry a c' FlushComments u - where - c' = case c of - EpaComments cs -> EpaCommentsBalanced (filterEofComment False cs) (filterEofComment True cs) - EpaCommentsBalanced cp ct -> EpaCommentsBalanced cp ct + Entry a c _ u -> Entry a c FlushComments u -- --------------------------------------------------------------------- @@ -374,7 +371,7 @@ let mflush = when (flush == FlushComments) $ do debugM $ "flushing comments in enterAnn:" ++ showAst cs - flushComments (getFollowingComments cs ++ filterEofComment True (priorComments cs)) + flushComments (getFollowingComments cs) advance edp a' <- exact a @@ -388,6 +385,17 @@ mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs) debugM $ "ending trailing comments" + eof <- getEofPos + case eof of + Nothing -> return () + Just (pos, prior) -> do + let dp = if pos == prior + then (DifferentLine 1 0) + else origDelta pos prior + debugM $ "EOF:(pos,prior,dp) =" ++ showGhc (ss2pos pos, ss2pos prior, dp) + printStringAtLsDelta dp "" + setEofPos Nothing -- Only do this once + let newAchor = anchor' { anchor_op = MovedAnchor edp } let r = case canUpdateAnchor of CanUpdateAnchor -> setAnnotationAnchor a' newAchor (mkEpaComments (priorCs++ postCs) []) @@ -432,23 +440,12 @@ -- ones in the state. flushComments :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () flushComments trailing = do - addCommentsA (filterEofComment False trailing) + addCommentsA trailing cs <- getUnallocatedComments debugM $ "flushing comments starting" mapM_ printOneComment (sortComments cs) - debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing) - debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing) - mapM_ printOneComment (concatMap tokComment (filterEofComment True trailing)) debugM $ "flushing comments done" -filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment] -filterEofComment keep cs = fixCs cs - where - notEof com = case com of - L _ (GHC.EpaComment (EpaEofComment) _) -> keep - _ -> not keep - fixCs c = filter notEof c - -- --------------------------------------------------------------------- -- |In order to interleave annotations into the stream, we turn them into @@ -497,7 +494,7 @@ printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () printSourceText (NoSourceText) txt = printStringAdvance txt >> return () -printSourceText (SourceText txt) _ = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () -- --------------------------------------------------------------------- @@ -518,7 +515,7 @@ p' <- adjustDeltaForOffsetM p debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') printStringAtLsDelta p' str - setPriorEndASTD True pa + setPriorEndASTD pa cs' <- case capture of CaptureComments -> takeAppliedComments NoCaptureComments -> return [] @@ -573,7 +570,7 @@ p2 <- getPosP pe2 <- getPriorEndD debugM $ "printStringAtAA:(pe1,pe2,p1,p2)=" ++ show (pe1,pe2,p1,p2) - setPriorEndASTPD True (pe1,pe2) + setPriorEndASTPD (pe1,pe2) cs' <- case capture of CaptureComments -> takeAppliedComments NoCaptureComments -> return [] @@ -584,7 +581,7 @@ markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m () markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return () -markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return () +markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return () -- --------------------------------------------------------------------- @@ -636,6 +633,15 @@ -- --------------------------------------------------------------------- +markLToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => Located (HsToken tok) -> EP w m (Located (HsToken tok)) +markLToken (L (RealSrcSpan aa mb) t) = do + epaLoc'<- printStringAtAA (EpaSpan aa mb) (symbolVal (Proxy @tok)) + case epaLoc' of + EpaSpan aa' mb' -> return (L (RealSrcSpan aa' mb') t) + _ -> return (L (RealSrcSpan aa mb ) t) +markLToken (L lt t) = return (L lt t) + markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) markToken (L NoTokenLoc t) = return (L NoTokenLoc t) @@ -678,21 +684,21 @@ markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) -markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt) +markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt) markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt) markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt markAnnOpen'' :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation markAnnOpen'' el NoSourceText txt = printStringAtAA el txt -markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt +markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt -- --------------------------------------------------------------------- {- @@ -1223,24 +1229,6 @@ debugM $ "markAnnListA: an5=" ++ showAst an return (an5, r) - -markAnnList' :: (Monad m, Monoid w) - => Bool -> EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) -markAnnList' reallyTrail an action = do - p <- getPosP - debugM $ "markAnnList : " ++ showPprUnsafe (p, an) - an0 <- markLensMAA an lal_open - an1 <- if (not reallyTrail) - then markTrailingL an0 lal_trailing - else return an0 - an2 <- markEpAnnAllL an1 lal_rest AnnSemi - r <- action - an3 <- markLensMAA an2 lal_close - an4 <- if reallyTrail - then markTrailingL an3 lal_trailing - else return an3 - return (an4, r) - -- --------------------------------------------------------------------- printComments :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () @@ -1401,25 +1389,46 @@ m' <- markAnnotated m mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec + mexports' <- setLayoutTopLevelP $ markAnnotated mexports + an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere return (an1, Just m', mdeprec', mexports') - let ann_decls = EpAnn (entry an) (am_decls $ anns an0) emptyComments - (ann_decls', (decls', imports')) <- markAnnList' False ann_decls $ do - imports' <- markTopLevelList imports - decls' <- markTopLevelList decls - return (decls', imports') - let am_decls' = case ann_decls' of - EpAnnNotUsed -> (am_decls $ anns an0) - EpAnn _ r _ -> r + lo0 <- case lo of + ExplicitBraces open close -> do + open' <- markToken open + return (ExplicitBraces open' close) + _ -> return lo + am_decls' <- markTrailing (am_decls $ anns an0) + imports' <- markTopLevelList imports + decls' <- markTopLevelList (filter removeDocDecl decls) + + lo1 <- case lo0 of + ExplicitBraces open close -> do + close' <- markToken close + return (ExplicitBraces open close') + _ -> return lo + + -- Print EOF + case am_eof $ anns an of + Nothing -> return () + Just (pos, prior) -> do + debugM $ "am_eof:" ++ showGhc (pos, prior) + setEofPos (Just (pos, prior)) + let anf = an0 { anns = (anns an0) { am_decls = am_decls' }} - debugM $ "HsModule, anf=" ++ showAst anf + -- debugM $ "HsModule, anf=" ++ showAst anf - return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls') + return (HsModule (XModulePs anf lo1 mdeprec' mbDoc') mmn' mexports' imports' decls') + +removeDocDecl :: LHsDecl GhcPs -> Bool +removeDocDecl (L _ DocD{}) = False +removeDocDecl _ = True + -- --------------------------------------------------------------------- instance ExactPrint ModuleName where @@ -1436,13 +1445,14 @@ getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an l) (WarningTxt (L la src) ws)) = do + exact (L (SrcSpanAnn an l) (WarningTxt mb_cat (L la src) ws)) = do an0 <- markAnnOpenP an src "{-# WARNING" + mb_cat' <- markAnnotated mb_cat an1 <- markEpAnnL an0 lapr_rest AnnOpenS ws' <- markAnnotated ws an2 <- markEpAnnL an1 lapr_rest AnnCloseS an3 <- markAnnCloseP an2 - return (L (SrcSpanAnn an3 l) (WarningTxt (L la src) ws')) + return (L (SrcSpanAnn an3 l) (WarningTxt mb_cat' (L la src) ws')) exact (L (SrcSpanAnn an l) (DeprecatedTxt (L ls src) ws)) = do an0 <- markAnnOpenP an src "{-# DEPRECATED" @@ -1452,6 +1462,25 @@ an3 <- markAnnCloseP an2 return (L (SrcSpanAnn an3 l) (DeprecatedTxt (L ls src) ws')) +instance ExactPrint InWarningCategory where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a + + exact (InWarningCategory tkIn source (L l wc)) = do + tkIn' <- markLToken tkIn + L _ (_,wc') <- markAnnotated (L l (source, wc)) + return (InWarningCategory tkIn' source (L l wc')) + +instance ExactPrint (SourceText, WarningCategory) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a + + exact (st, WarningCategory wc) = do + case st of + NoSourceText -> printStringAdvance $ "\"" ++ (unpackFS wc) ++ "\"" + SourceText src -> printStringAdvance $ (unpackFS src) + return (st, WarningCategory wc) + -- --------------------------------------------------------------------- instance ExactPrint (ImportDecl GhcPs) where @@ -1531,6 +1560,10 @@ instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ = a + + -- exact ds = do + -- (printStringAdvance . exactPrintHsDocString) ds + -- return ds exact (MultiLineDocString decorator (x :| xs)) = do printStringAdvance ("-- " ++ printDecorator decorator) pe <- getPriorEndD @@ -1790,20 +1823,21 @@ getAnnotationEntry (Warning an _ _) = fromAnn an setAnnotationAnchor (Warning an a b) anc cs = Warning (setAnchorEpa an anc cs) a b - exact (Warning an lns txt) = do + exact (Warning an lns (WarningTxt mb_cat src ls )) = do + mb_cat' <- markAnnotated mb_cat lns' <- markAnnotated lns an0 <- markEpAnnL an lidl AnnOpenS -- "[" - txt' <- - case txt of - WarningTxt src ls -> do - ls' <- markAnnotated ls - return (WarningTxt src ls') - DeprecatedTxt src ls -> do - ls' <- markAnnotated ls - return (DeprecatedTxt src ls') + ls' <- markAnnotated ls an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" - return (Warning an1 lns' txt') + return (Warning an1 lns' (WarningTxt mb_cat' src ls')) + exact (Warning an lns (DeprecatedTxt src ls)) = do + lns' <- markAnnotated lns + an0 <- markEpAnnL an lidl AnnOpenS -- "[" + ls' <- markAnnotated ls + an1 <- markEpAnnL an0 lidl AnnCloseS -- "]" + return (Warning an1 lns' (DeprecatedTxt src ls')) + -- --------------------------------------------------------------------- instance ExactPrint StringLiteral where @@ -1834,7 +1868,7 @@ an0 <- case src of NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt) + SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt) rules' <- markAnnotated rules an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") return (HsRules (an1,src) rules') @@ -2027,12 +2061,12 @@ -- --------------------------------------------------------------------- instance (ExactPrint tm, ExactPrint ty, Outputable tm, Outputable ty) - => ExactPrint (HsArg tm ty) where + => ExactPrint (HsArg GhcPs tm ty) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a exact a@(HsValArg tm) = markAnnotated tm >> return a - exact a@(HsTypeArg ss ty) = printStringAtSs ss "@" >> markAnnotated ty >> return a + exact a@(HsTypeArg at ty) = markToken at >> markAnnotated ty >> return a exact x@(HsArgPar _sp) = withPpr x -- Does not appear in original source -- --------------------------------------------------------------------- @@ -2121,6 +2155,11 @@ an1 <- markAnnCloseP an0 return (L (SrcSpanAnn an1 l) (Incoherent src)) + exact (L (SrcSpanAnn an l) (NonCanonical src)) = do + an0 <- markAnnOpenP an src "{-# INCOHERENT" + an1 <- markAnnCloseP an0 + return (L (SrcSpanAnn an1 l) (Incoherent src)) + -- --------------------------------------------------------------------- instance ExactPrint (HsBind GhcPs) where @@ -2751,15 +2790,11 @@ printStringAtAA l "_" >> return () printStringAtAA cb "`" >> return () return x - exact x@(HsOverLabel an src l) = do - let str = "#" ++ case src of - NoSourceText -> (unpackFS l) - SourceText txt -> txt - case an of - EpAnnNotUsed -> printString True str - EpAnn anc _ _ -> do - _ <- markAnnotated (L (RealSrcSpan (anchor anc) Strict.Nothing) (fsLit str)) - return () + exact x@(HsOverLabel _ src l) = do + printStringAtLsDelta (SameLine 0) "#" + case src of + NoSourceText -> printStringAtLsDelta (SameLine 0) (unpackFS l) + SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt) return x exact x@(HsIPVar _ (HsIPName n)) @@ -2771,7 +2806,7 @@ HsFractional (FL { fl_text = src }) -> src HsIsString src _ -> src case str of - SourceText s -> printStringAdvance s >> return () + SourceText s -> printStringAdvance (unpackFS s) >> return () NoSourceText -> withPpr x >> return () return x @@ -3184,17 +3219,18 @@ return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- -instance - (ExactPrint (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body), - ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)) - => ExactPrint - (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)] - [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where +instance ExactPrint (LHsRecUpdFields GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (Left rbinds) = Left <$> markAnnotated rbinds - exact (Right pbinds) = Right <$> markAnnotated pbinds + exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do + debugM $ "RegularRecUpdFields" + rbinds' <- markAnnotated rbinds + return $ flds { recUpdFields = rbinds' } + exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do + debugM $ "OverloadedRecUpdFields" + pbinds' <- markAnnotated pbinds + return $ flds { olRecUpdFields = pbinds' } -- --------------------------------------------------------------------- @@ -3681,13 +3717,13 @@ an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - an00 <- if isTypeDataDefnCons condecls - then markEpAnnL an' lidl AnnType - else return an' - - an0 <- markEpAnnL an00 lidl $ case condecls of - DataTypeCons _ _ -> AnnData - NewTypeCon _ -> AnnNewtype + an0 <- case condecls of + DataTypeCons is_type_data _ -> do + an0' <- if is_type_data + then markEpAnnL an' lidl AnnType + else return an' + markEpAnnL an0' lidl AnnData + NewTypeCon _ -> markEpAnnL an' lidl AnnNewtype an1 <- markEpAnnL an0 lidl AnnInstance -- optional mb_ct' <- mapM markAnnotated mb_ct @@ -3729,12 +3765,13 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context = do let exact_tyvars (varl:varsr) - | fixity == Infix && length varsr > 1 = do + | hvarsr : tvarsr@(_ : _) <- varsr + , fixity == Infix = do varl' <- markAnnotated varl thing' <- markAnnotated thing - hvarsr <- markAnnotated (head varsr) - tvarsr <- markAnnotated (tail varsr) - return (thing', varl':hvarsr:tvarsr) + hvarsr' <- markAnnotated hvarsr + tvarsr' <- markAnnotated tvarsr + return (thing', varl':hvarsr':tvarsr') | fixity == Infix = do varl' <- markAnnotated varl thing' <- markAnnotated thing @@ -3788,6 +3825,16 @@ SpecifiedSpec -> (AnnOpenP, AnnCloseP) InferredSpec -> (AnnOpenC, AnnCloseC) +instance ExactPrintTVFlag (HsBndrVis GhcPs) where + exactTVDelimiters an0 bvis thing_inside = do + case bvis of + HsBndrRequired -> return () + HsBndrInvisible at -> markToken at >> return () + an1 <- markEpAnnAllL an0 lid AnnOpenP + r <- thing_inside + an2 <- markEpAnnAllL an1 lid AnnCloseP + return (an2, r) + instance ExactPrintTVFlag flag => ExactPrint (HsTyVarBndr flag GhcPs) where getAnnotationEntry (UserTyVar an _ _) = fromAnn an getAnnotationEntry (KindedTyVar an _ _ _) = fromAnn an @@ -3819,7 +3866,7 @@ getAnnotationEntry (HsQualTy _ _ _) = NoEntryVal getAnnotationEntry (HsTyVar an _ _) = fromAnn an getAnnotationEntry (HsAppTy _ _ _) = NoEntryVal - getAnnotationEntry (HsAppKindTy _ _ _) = NoEntryVal + getAnnotationEntry (HsAppKindTy _ _ _ _) = NoEntryVal getAnnotationEntry (HsFunTy an _ _ _) = fromAnn an getAnnotationEntry (HsListTy an _) = fromAnn an getAnnotationEntry (HsTupleTy an _ _) = fromAnn an @@ -3843,7 +3890,7 @@ setAnnotationAnchor a@(HsQualTy _ _ _) _ _s = a setAnnotationAnchor (HsTyVar an a b) anc cs = (HsTyVar (setAnchorEpa an anc cs) a b) setAnnotationAnchor a@(HsAppTy _ _ _) _ _s = a - setAnnotationAnchor a@(HsAppKindTy _ _ _) _ _s = a + setAnnotationAnchor a@(HsAppKindTy _ _ _ _) _ _s = a setAnnotationAnchor (HsFunTy an a b c) anc cs = (HsFunTy (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b) @@ -3884,11 +3931,11 @@ t1' <- markAnnotated t1 t2' <- markAnnotated t2 return (HsAppTy an t1' t2') - exact (HsAppKindTy ss ty ki) = do + exact (HsAppKindTy ss ty at ki) = do ty' <- markAnnotated ty - printStringAtSs ss "@" + at' <- markToken at ki' <- markAnnotated ki - return (HsAppKindTy ss ty' ki') + return (HsAppKindTy ss ty' at' ki') exact (HsFunTy an mult ty1 ty2) = do ty1' <- markAnnotated ty1 mult' <- markArrow mult @@ -3950,7 +3997,7 @@ NoSourceText -> return an SourceText src -> do debugM $ "HsBangTy: src=" ++ showAst src - an0 <- markEpAnnLMS an lid AnnOpen (Just src) + an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src) an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}") debugM $ "HsBangTy: done unpackedness" return an1 @@ -4137,10 +4184,23 @@ (o',_,c') <- markName a o Nothing c t' <- markTrailing t return (NameAnnOnly a o' c' t') - NameAnnRArrow nl t -> do - (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl) + NameAnnRArrow unicode o nl c t -> do + o' <- case o of + Just o0 -> do + (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0) + return (Just o') + Nothing -> return Nothing + (AddEpAnn _ nl') <- + if unicode + then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl) + else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl) + c' <- case c of + Just c0 -> do + (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0) + return (Just c') + Nothing -> return Nothing t' <- markTrailing t - return (NameAnnRArrow nl' t') + return (NameAnnRArrow unicode o' nl' c' t') NameAnnQuote q name t -> do debugM $ "NameAnnQuote" (AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q) @@ -4500,37 +4560,41 @@ instance ExactPrint (IE GhcPs) where getAnnotationEntry (IEVar _ _) = NoEntryVal - getAnnotationEntry (IEThingAbs an _) = fromAnn an - getAnnotationEntry (IEThingAll an _) = fromAnn an - getAnnotationEntry (IEThingWith an _ _ _) = fromAnn an - getAnnotationEntry (IEModuleContents an _)= fromAnn an + getAnnotationEntry (IEThingAbs (_, an) _) = fromAnn an + getAnnotationEntry (IEThingAll (_, an) _) = fromAnn an + getAnnotationEntry (IEThingWith (_, an) _ _ _) = fromAnn an + getAnnotationEntry (IEModuleContents (_, an) _)= fromAnn an getAnnotationEntry (IEGroup _ _ _) = NoEntryVal getAnnotationEntry (IEDoc _ _) = NoEntryVal getAnnotationEntry (IEDocNamed _ _) = NoEntryVal setAnnotationAnchor a@(IEVar _ _) _ _s = a - setAnnotationAnchor (IEThingAbs an a) anc cs = (IEThingAbs (setAnchorEpa an anc cs) a) - setAnnotationAnchor (IEThingAll an a) anc cs = (IEThingAll (setAnchorEpa an anc cs) a) - setAnnotationAnchor (IEThingWith an a b c) anc cs = (IEThingWith (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (IEModuleContents an a) anc cs = (IEModuleContents (setAnchorEpa an anc cs) a) + setAnnotationAnchor (IEThingAbs (depr, an) a) anc cs = (IEThingAbs (depr, setAnchorEpa an anc cs) a) + setAnnotationAnchor (IEThingAll (depr, an) a) anc cs = (IEThingAll (depr, setAnchorEpa an anc cs) a) + setAnnotationAnchor (IEThingWith (depr, an) a b c) anc cs = (IEThingWith (depr, setAnchorEpa an anc cs) a b c) + setAnnotationAnchor (IEModuleContents (depr, an) a) anc cs = (IEModuleContents (depr, setAnchorEpa an anc cs) a) setAnnotationAnchor a@(IEGroup _ _ _) _ _s = a setAnnotationAnchor a@(IEDoc _ _) _ _s = a setAnnotationAnchor a@(IEDocNamed _ _) _ _s = a - exact (IEVar x ln) = do + exact (IEVar depr ln) = do + depr' <- markAnnotated depr ln' <- markAnnotated ln - return (IEVar x ln') - exact (IEThingAbs x thing) = do + return (IEVar depr' ln') + exact (IEThingAbs (depr, an) thing) = do + depr' <- markAnnotated depr thing' <- markAnnotated thing - return (IEThingAbs x thing') - exact (IEThingAll an thing) = do + return (IEThingAbs (depr', an) thing') + exact (IEThingAll (depr, an) thing) = do + depr' <- markAnnotated depr thing' <- markAnnotated thing an0 <- markEpAnnL an lidl AnnOpenP an1 <- markEpAnnL an0 lidl AnnDotdot an2 <- markEpAnnL an1 lidl AnnCloseP - return (IEThingAll an2 thing') + return (IEThingAll (depr', an2) thing') - exact (IEThingWith an thing wc withs) = do + exact (IEThingWith (depr, an) thing wc withs) = do + depr' <- markAnnotated depr thing' <- markAnnotated thing an0 <- markEpAnnL an lidl AnnOpenP (an1, wc', withs') <- @@ -4546,12 +4610,13 @@ as' <- markAnnotated as return (an2, wc, bs'++as') an2 <- markEpAnnL an1 lidl AnnCloseP - return (IEThingWith an2 thing' wc' withs') + return (IEThingWith (depr', an2) thing' wc' withs') - exact (IEModuleContents an m) = do + exact (IEModuleContents (depr, an) m) = do + depr' <- markAnnotated depr an0 <- markEpAnnL an lidl AnnModule m' <- markAnnotated m - return (IEModuleContents an0 m') + return (IEModuleContents (depr', an0) m') -- These three exist to not error out, but are no-ops The contents -- appear as "normal" comments too, which we process instead. @@ -4728,7 +4793,7 @@ HsIsString src _ -> src in case str of - SourceText s -> printStringAdvance s >> return ol + SourceText s -> printStringAdvance (unpackFS s) >> return ol NoSourceText -> return ol -- --------------------------------------------------------------------- @@ -4743,7 +4808,13 @@ HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" HsIntPrim src v -> toSourceTextWithSuffix src v "" HsWordPrim src v -> toSourceTextWithSuffix src v "" + HsInt8Prim src v -> toSourceTextWithSuffix src v "" + HsInt16Prim src v -> toSourceTextWithSuffix src v "" + HsInt32Prim src v -> toSourceTextWithSuffix src v "" HsInt64Prim src v -> toSourceTextWithSuffix src v "" + HsWord8Prim src v -> toSourceTextWithSuffix src v "" + 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 "" @@ -4752,11 +4823,11 @@ toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix sourceTextToString :: SourceText -> String -> String sourceTextToString NoSourceText alt = alt -sourceTextToString (SourceText txt) _ = txt +sourceTextToString (SourceText txt) _ = unpackFS txt -- --------------------------------------------------------------------- @@ -4816,11 +4887,14 @@ colOffset <- getLayoutOffsetP if isGoodDeltaWithOffset cl colOffset then do + dprior <- getPriorEndD printStringAt (undelta p cl colOffset) s - -- `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + -- `debug` ("printStringAtLsDelta:(cl,colOffset):" ++ show (cl,colOffset,s)) p' <- getPosP - d <- getPriorEndD - debugM $ "printStringAtLsDelta:(pos,p',d,s):" ++ show (undelta p cl colOffset,p',d,s) + dafter <- getPriorEndD + setPriorEndASTPD (dprior,dafter) + + debugM $ "printStringAtLsDelta:(pos,p,p',d,s):" ++ show (undelta p cl colOffset,p,p',dafter,s) else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (cl,s)) -- --------------------------------------------------------------------- @@ -4881,7 +4955,7 @@ setPosP :: (Monad m, Monoid w) => Pos -> EP w m () setPosP l = do - -- debugM $ "setPosP:" ++ show l + debugM $ "setPosP:" ++ show l modify (\s -> s {epPos = l}) getExtraDP :: (Monad m, Monoid w) => EP w m (Maybe Anchor) @@ -4907,13 +4981,13 @@ debugM $ "setPriorEndNoLayoutD:pe=" ++ show pe modify (\s -> s { dPriorEndPosition = pe }) -setPriorEndASTD :: (Monad m, Monoid w) => Bool -> RealSrcSpan -> EP w m () -setPriorEndASTD layout pe = setPriorEndASTPD layout (rs2range pe) +setPriorEndASTD :: (Monad m, Monoid w) => RealSrcSpan -> EP w m () +setPriorEndASTD pe = setPriorEndASTPD (rs2range pe) -setPriorEndASTPD :: (Monad m, Monoid w) => Bool -> (Pos,Pos) -> EP w m () -setPriorEndASTPD layout pe@(fm,to) = do +setPriorEndASTPD :: (Monad m, Monoid w) => (Pos,Pos) -> EP w m () +setPriorEndASTPD pe@(fm,to) = do debugM $ "setPriorEndASTD:pe=" ++ show pe - when layout $ setLayoutStartD (snd fm) + when True $ setLayoutStartD (snd fm) modify (\s -> s { dPriorEndPosition = to } ) setLayoutStartD :: (Monad m, Monoid w) => Int -> EP w m () @@ -4931,6 +5005,14 @@ setAnchorU rss = do debugM $ "setAnchorU:" ++ show (rs2range rss) modify (\s -> s { uAnchorSpan = rss }) + +getEofPos :: (Monad m, Monoid w) => EP w m (Maybe (RealSrcSpan, RealSrcSpan)) +getEofPos = gets epEof + +setEofPos :: (Monad m, Monoid w) => Maybe (RealSrcSpan, RealSrcSpan) -> EP w m () +setEofPos l = modify (\s -> s {epEof = l}) + +-- --------------------------------------------------------------------- getUnallocatedComments :: (Monad m, Monoid w) => EP w m [Comment] getUnallocatedComments = gets epComments diff --git a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs --- a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs @@ -4,6 +4,7 @@ import Data.Default import GHC hiding (EpaComment) +import GHC.Types.SrcLoc -- --------------------------------------------------------------------- @@ -89,5 +90,8 @@ instance Default EpAnnSumPat where def = EpAnnSumPat def def def +instance Semigroup RealSrcSpan where + a <> b = combineRealSrcSpans a b + instance Default AnnsModule where - def = AnnsModule [] mempty + def = AnnsModule [] mempty mempty 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 @@ -47,7 +47,6 @@ import Language.Haskell.GHC.ExactPrint.Preprocess --- import Control.Monad.RWS import Data.Functor (void) import qualified GHC hiding (parseModule) @@ -261,7 +260,7 @@ GHC.PFailed pst -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst) GHC.POk _ pmod - -> Right $ (injectedComments, dflags', fixModuleTrailingComments pmod) + -> Right $ (injectedComments, dflags', fixModuleComments pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. @@ -270,23 +269,24 @@ -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - -- TODO:AZ perhaps inject the comments into the parsedsource here already - mkAnns (_cs, _, m) = fixModuleTrailingComments m + mkAnns (_cs, _, m) = fixModuleComments m +fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource +fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p + fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleTrailingComments (GHC.L l p) = GHC.L l p' where an' = case GHC.hsmodAnn $ GHC.hsmodExt p of - (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs) + (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance ocs) unused -> unused p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } } - -- p' = error $ "fixModuleTrailingComments: an'=" ++ showAst an' - rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments - rebalance al cs = cs' + rebalance :: GHC.EpAnnComments -> GHC.EpAnnComments + rebalance cs = cs' where - cs' = case GHC.al_close al of - Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) -> + cs' = case GHC.hsmodLayout $ GHC.hsmodExt p of + GHC.ExplicitBraces _ (GHC.L (GHC.TokenLoc (GHC.EpaSpan ss _)) _) -> let pc = GHC.priorComments cs fc = GHC.getFollowingComments cs @@ -295,6 +295,48 @@ cs'' = GHC.EpaCommentsBalanced (pc <> prior) f in cs'' _ -> cs + +-- Deal with https://gitlab.haskell.org/ghc/ghc/-/issues/23984 +-- The Lexer works bottom-up, so does not have module declaration info +-- when the first top decl processed +fixModuleHeaderComments :: GHC.ParsedSource -> GHC.ParsedSource +fixModuleHeaderComments (GHC.L l p) = GHC.L l p' + where + moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments + -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments) + moveComments GHC.EpaDelta{} dd cs = (dd,cs) + moveComments _loc dd@(GHC.L (GHC.SrcSpanAnn GHC.EpAnnNotUsed _) _) cs = (dd,cs) + moveComments (GHC.EpaSpan r _) (GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd) ll) a) cs = (dd,css) + where + -- Move any comments on the decl that occur prior to the location + pc = GHC.priorComments csd + fc = GHC.getFollowingComments csd + bf (GHC.L anch _) = GHC.anchor anch > r + (move,keep) = break bf pc + csd' = GHC.EpaCommentsBalanced keep fc + + dd = GHC.L (GHC.SrcSpanAnn (GHC.EpAnn anc an csd') ll) a + css = cs <> GHC.EpaComments move + + (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p) + p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' }, + GHC.hsmodDecls = ds' + } + + rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) + -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) + rebalance (ds, GHC.EpAnnNotUsed) = (ds, GHC.EpAnnNotUsed) + rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') + where + (ds1,cs') = case break (\(GHC.AddEpAnn k _) -> k == GHC.AnnWhere) (GHC.am_main an) of + (_, (GHC.AddEpAnn _ whereLoc:_)) -> + case GHC.hsmodDecls p of + (d:ds0) -> (d':ds0, cs0) + where (d',cs0) = moveComments whereLoc d cs + ds0 -> (ds0,cs) + _ -> (ds,cs) + + -- | Internal function. Initializes DynFlags value for parsing. -- diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -26,7 +26,6 @@ import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Fingerprint.Type as GHC --- import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC import qualified GHC.Types.Error as GHC @@ -195,7 +194,7 @@ stripPreprocessorDirectives buf = buf' where srcByLine = lines $ sbufToString buf - noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine + noDirectivesLines = map (\line -> case line of '#' : _ -> ""; _ -> line) srcByLine buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines -- --------------------------------------------------------------------- @@ -227,6 +226,7 @@ txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') +-- showErrorMessages :: GHC.Messages GHC.DriverMessage -> String showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String showErrorMessages msgs = GHC.renderWithContext GHC.defaultSDocContext @@ -262,7 +262,7 @@ getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)] getPreprocessorAsComments srcFile = do fcontents <- readFileGhc srcFile - let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#') + let directives = filter (\(_lineNum,line) -> case line of '#' : _ -> True; _ -> False) $ zip [1..] (lines fcontents) let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line (makeBufSpan l)),line) 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 @@ -325,7 +325,7 @@ l) a where cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') - lc = head $ reverse $ (L ca c:cs') + lc = last $ (L ca c:cs') delta = tweakDelta $ ss2delta (ss2pos $ anchor $ getLoc lc) r line = getDeltaLine delta col = deltaColumn delta @@ -709,15 +709,6 @@ op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) then MovedAnchor (DifferentLine 1 0) else op' - --- --------------------------------------------------------------------- - - --- | For comment-related deltas starting on a new line we have an --- off-by-one problem. Adjust -tweakDelta :: DeltaPos -> DeltaPos -tweakDelta (SameLine d) = SameLine d -tweakDelta (DifferentLine l d) = DifferentLine l (d-1) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -4,20 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -module Language.Haskell.GHC.ExactPrint.Utils - -- ( - -- -- * Manipulating Positons - -- ss2pos - -- , ss2posEnd - -- , undelta - -- , isPointSrcSpan - -- , pos2delta - -- , ss2delta - -- , addDP - -- , spanLength - -- , isGoodDelta - -- ) where - where +module Language.Haskell.GHC.ExactPrint.Utils where import Control.Monad (when) import Data.Function @@ -171,6 +158,25 @@ -- --------------------------------------------------------------------- +origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos +origDelta pos pp = op + where + (r,c) = ss2posEnd pp + + op = if r == 0 + then ( ss2delta (r,c+1) pos) + else (tweakDelta $ ss2delta (r,c ) pos) + +-- --------------------------------------------------------------------- + +-- | For comment-related deltas starting on a new line we have an +-- off-by-one problem. Adjust +tweakDelta :: DeltaPos -> DeltaPos +tweakDelta (SameLine d) = SameLine d +tweakDelta (DifferentLine l d) = DifferentLine l (d-1) + +-- --------------------------------------------------------------------- + -- |Given a list of items and a list of keys, returns a list of items -- ordered by their position in the list of keys. orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)] @@ -349,21 +355,6 @@ name2String :: Name -> String name2String = showPprUnsafe - --- --------------------------------------------------------------------- - --- occAttributes :: OccName.OccName -> String --- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" --- where --- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " --- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " --- vo = if isVarOcc o then "Var " else "" --- tv = if isTvOcc o then "Tv " else "" --- tc = if isTcOcc o then "Tc " else "" --- d = if isDataOcc o then "Data " else "" --- ds = if isDataSymOcc o then "DataSym " else "" --- s = if isSymOcc o then "Sym " else "" --- v = if isValOcc o then "Val " else "" -- --------------------------------------------------------------------- diff --git a/tests/PrepareHackage.hs b/tests/PrepareHackage.hs --- a/tests/PrepareHackage.hs +++ b/tests/PrepareHackage.hs @@ -43,10 +43,11 @@ preparePackage' :: Text -> IO () preparePackage' package = do (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty - -- myecho (T.pack $ "cabal get:" ++ show dir) + myecho (T.pack $ "cabal get:" ++ show dir) + -- cabal get:"Unpacking to\n./hackage-roundtrip-work/amazonka-kinesis-video-archived-media-2.0/\n" myecho (T.pack $ show ec) when (ec == ExitSuccess) $ do - let bits = T.splitOn " " (head $ T.lines dir) + let bits = T.splitOn " " (last $ T.lines dir) myecho (T.pack $ "cabal get:dir=" ++ show (last bits)) cleanPackage (last bits) return () diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs --- a/tests/Roundtrip.hs +++ b/tests/Roundtrip.hs @@ -82,6 +82,8 @@ case as of [] -> putStrLn "Must enter directory to process" ["failures"] -> do + -- !knownFailures <- readFileIfPresent knownFailuresFile + -- let done = S.fromList knownFailures fs <- lines <$> readFile origFailuresFile () <$ runTests (TestList (map (mkParserTest libdir) fs)) ["clean"] -> do @@ -122,10 +124,11 @@ -- Hackage dir roundTripHackage :: LibDir -> S.Set String -> FilePath -> IO Test roundTripHackage libdir done hackageDir = do - packageDirs <- drop 2 <$> getDirectoryContents hackageDir + packageDirs <- listDirectory hackageDir + dirsOnly <- filterM (doesDirectoryExist . (hackageDir )) packageDirs when (verb <= Debug) (traceShowM hackageDir) - when (verb <= Debug) (traceShowM packageDirs) - TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir ) packageDirs)) + when (verb <= Debug) (traceShowM dirsOnly) + TestList <$> mapM (roundTripPackage libdir done) (zip [0..] (map (hackageDir ) dirsOnly)) roundTripPackage :: LibDir -> S.Set String -> (Int, FilePath) -> IO Test diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,25 +28,25 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC94 - | GHC96 +data GHCVersion = GHC96 + | GHC98 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,6,0) -ghcVersion = GHC96 +#if MIN_VERSION_ghc(9,8,0) +ghcVersion = GHC98 #else -ghcVersion = GHC94 +ghcVersion = GHC96 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC94 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94"] GHC96 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96"] - -- GHC96 -> ["ghc96"] - -- GHC96 -> ["ghc96-copied"] + GHC98 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96", "ghc98"] + -- GHC98 -> ["ghc98"] + -- GHC98 -> ["ghc98-copied"] -- --------------------------------------------------------------------- @@ -183,9 +183,9 @@ formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () formatTT (ts, fs) = do - when (not . null $ tail ts) (do + when (not . null $ (drop 1) ts) (do putStrLn "Pass" - mapM_ (putStrLn . fst) (tail ts) + mapM_ (putStrLn . fst) ((drop 1) ts) ) when (not . null $ fs) (do putStrLn "Fail" @@ -201,49 +201,10 @@ tt' = do let libdir = GHC.Paths.libdir runTestText (putTextToHandle stdout True) $ TestList [ - - -- mkTestModChange libdir rmDecl7 "RmDecl7.hs" - - -- mkTestModChange libdir changeLocalDecls "LocalDecls.hs" - -- mkTestModChange libdir changeLayoutLet2 "LayoutLet2.hs" - -- mkTestModChange libdir addLocaLDecl5 "AddLocalDecl5.hs" - - -- mkTestModChange libdir rmDecl1 "RmDecl1.hs" - - -- mkTestModChange libdir rmDecl4 "RmDecl4.hs" - -- mkParserTestMD libdir "ghc92" "Foo.hs" - -- mkParserTest libdir "ghc92" "Foo.hs" - -- mkParserTestMD libdir "ghc92" "Foo.hs" - -- mkParserTest libdir "ghc92" "Foo2.hs" - -- mkParserTest libdir "ghc710" "EmptyMostly.hs" - -- mkParserTestBC libdir "ghc710" "Control.hs" - -- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs" - -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs" - - -- mkParserTest libdir "ghc92" "ConstructorComment.hs" - -- mkParserTest libdir "ghc92" "Binary.hs" - -- mkParserTest libdir "ghc92" "Observer.hs" - -- mkParserTest libdir "ghc92" "Observer1.hs" - - -- mkTestModChange libdir addLocaLDecl1 "AddLocalDecl1.hs" - -- mkTestModChange libdir addLocaLDecl3 "AddLocalDecl3.hs" - - -- mkParserTestBC libdir "ghc710" "MultiParamTypeClasses.hs" - - -- mkParserTestBC libdir "ghc710" "DataFamilies.hs" - -- mkParserTestBC libdir "ghc710" "Cpp.hs" - -- mkParserTestBC libdir "ghc80" "T4139.hs" - - -- mkParserTestBC libdir "ghc92" "Checkpoint.hs" - - -- mkParserTestBC libdir "ghc92" "CommentPlacement6.hs" - -- mkParserTest libdir "ghc92" "CommentPlacement6.hs" - -- mkParserTest libdir "ghc92" "TopLevelSemis.hs" -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs" -- mkParserTestMD libdir "ghc92" "TopLevelSemis.hs" - -- mkParserTest libdir "ghc96" "T11671_run.hs" -- mkParserTest libdir "ghc96" "LexerM.hs" @@ -251,7 +212,11 @@ -- mkParserTest libdir "ghc94" "Haddock.hs" -- mkParserTest libdir "ghc94" "Haddock1.hs" - mkParserTestBC libdir "ghc94" "Haddock1.hs" + -- mkParserTest libdir "ghc94" "Haddock2.hs" + -- mkParserTestBC libdir "ghc94" "Haddock1.hs" + + -- mkParserTest libdir "ghc98" "IndentedModule2.hs" + mkParserTest libdir "ghc98" "ModuleComments.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 @@ -31,16 +31,13 @@ import Language.Haskell.GHC.ExactPrint --- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess import qualified Control.Monad.IO.Class as GHC -import qualified GHC as GHC hiding (parseModule) --- import qualified GHC.Data.Bag as GHC +import qualified GHC hiding (parseModule) import qualified GHC.Driver.Session as GHC --- import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt @@ -146,6 +143,13 @@ cppStatus = if useCpp then Just orig else Nothing return $ Right Report {..} +-- showErrorMessages :: Messages GhcMessage -> String +-- showErrorMessages msgs = +-- renderWithContext defaultSDocContext +-- $ vcat +-- $ pprMsgEnvelopeBagWithLocDefault +-- $ getMessages +-- $ msgs mkDebugOutput :: FilePath -> String -> String -> GHC.ParsedSource -> String @@ -199,7 +203,7 @@ let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of - [] -> return Nothing - fs -> return (Just (snd $ head fs)) + (f:_) -> return (Just (snd f)) + _ -> return Nothing -- --------------------------------------------------------------------- diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -618,8 +618,8 @@ [L li imp1,imp2] = hsmodImports p n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0) (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) @@ -653,8 +653,8 @@ emptyComments) (locA lh)) n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar Nothing (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar Nothing (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) L ln n = last ns n' = L (addComma ln) n imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))} diff --git a/tests/examples/ghc94/Haddock1.hs b/tests/examples/ghc94/Haddock1.hs --- a/tests/examples/ghc94/Haddock1.hs +++ b/tests/examples/ghc94/Haddock1.hs @@ -30,4 +30,7 @@ data T a b = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ + B (T a b, T Int Float) -- ^ abcd + +-- | An abstract data declaration +data T2 a b = T2 a b diff --git a/tests/examples/ghc94/Haddock2.hs b/tests/examples/ghc94/Haddock2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc94/Haddock2.hs @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock -ddump-parsed -dkeep-comments #-} +module Haddock2 where + +data T + = B -- ^ abcd + +-- | An abstract data declaration +data T2 = T2 diff --git a/tests/examples/ghc98/ExportWarnings_aux.hs b/tests/examples/ghc98/ExportWarnings_aux.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/ExportWarnings_aux.hs @@ -0,0 +1,7 @@ +module ExportWarnings_aux ( + {-# WARNING "warn" #-} x, + {-# WARNING in "x-custom-\72" [ "is" , "deprecated"] #-} S(S1), + ) where +import ExportWarnings_base (x) + +data S = S1 | S2 diff --git a/tests/examples/ghc98/IndentedModule2.hs b/tests/examples/ghc98/IndentedModule2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/IndentedModule2.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} +{- -} module Main where +main = putStr "foo" + diff --git a/tests/examples/ghc98/LexerM2.hs b/tests/examples/ghc98/LexerM2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/LexerM2.hs @@ -0,0 +1,215 @@ +---------------------------------------------------------------------------- +-- | +-- Module : FastTags.LexerM +-- Copyright : (c) Sergey Vinokurov 2019 +-- +-- All the types and functions needed to make lexer run: +-- - 'AlexInput' - primary workhorse, an optimized representation of input +-- stream as a pointer to utf8 bytes and our position within it. +-- - Lexer monad 'AlexM' - a monad (self-explanatory) with state that describes +-- current lexing context. +-- - 'AlexState' - state of the lexing monad, maintains current Alex code, +-- comment depth, quasiquoter depth, indentation size, whether we're in +-- a literate mode (and in which one) or vanilla mode and whether there +-- are any TH quasiquotes present till the end of file. +-- +-- All the functions are to do with +---------------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} + +module FastTags.LexerM + ( AlexState(..) + , mkAlexState + , alexEnterBirdLiterateEnv + , alexEnterLiterateLatexEnv + , alexExitLiterateEnv + , pushContext + , modifyCommentDepth + , modifyQuasiquoterDepth + , modifyPreprocessorDepth + , addIndentationSize + , checkQuasiQuoteEndPresent + + , AlexM + , runAlexM + , alexSetInput + , alexSetNextCode + + , AlexInput(..) + , aiLineL + , takeText + , countInputSpace + , extractDefineOrLetName + , dropUntilNL + , dropUntilUnescapedNL + , dropUntilNLOr + , dropUntilNLOrEither + , unsafeTextHeadAscii + , unsafeTextHeadOfTailAscii + , unsafeTextHead + , utf8BS + + , asCodeL + , asCommentDepthL + , asQuasiquoterDepthL + , asIndentationSizeL + , asPreprocessorDepthL + , asLiterateLocL + , asHaveQQEndL + + -- * Alex interface + , alexInputPrevChar + , alexGetByte + ) where + +import Control.Applicative as A +import Control.DeepSeq +import Control.Exception +import Control.Monad.ST +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict + +import Data.Char +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Void (Void, vacuous) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Internal as BSI +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as UM + +import Foreign.ForeignPtr +import Foreign.Ptr +import GHC.Base +import GHC.Ptr +import GHC.Word +import Text.Printf + +import FastTags.LensBlaze +import FastTags.LexerTypes +import FastTags.Token + +import GHC.Exts (word8ToWord#, wordToWord8#) + + +data AlexState = AlexState + { asInput :: {-# UNPACK #-} !AlexInput + , asIntStore :: {-# UNPACK #-} !Word64 + -- ^ Integer field that stores all the other useful fields for lexing. + , asContextStack :: [Context] + } deriving (Show, Eq, Ord) + + +checkQuasiQuoteEndPresent :: Ptr Word8 -> Bool +checkQuasiQuoteEndPresent + = (\x -> isTrue# (qqessPresent x)) + . utf8Foldl' combine (QQEndsState 0# '\n'#) + where + combine :: QQEndsState -> Char# -> QQEndsState + combine QQEndsState{qqessPresent, qqessPrevChar} c# = QQEndsState + { qqessPresent = + qqessPresent `orI#` + case (# qqessPrevChar, c# #) of + (# '|'#, ']'# #) -> 1# + (# _, '⟧'# #) -> 1# + _ -> 0# + , qqessPrevChar = c# + } + +countInputSpace :: AlexInput -> Int -> Int +countInputSpace AlexInput{aiPtr} len = + utf8FoldlBounded len inc 0 aiPtr + where + inc !acc ' '# = acc + 1 + inc !acc '\t'# = acc + 8 + inc !acc c# = case fixChar c# of + 1## -> acc + 1 + _ -> acc + +-- Translate unicode character into special symbol we teached Alex to recognize. +{-# INLINE fixChar #-} +fixChar :: Char# -> Word# +fixChar = \case + -- These should not be translated since Alex knows about them + '→'# -> reservedSym + '∷'# -> reservedSym + '⇒'# -> reservedSym + '∀'# -> reservedSym + '⦇'# -> reservedSym + '⦈'# -> reservedSym + '⟦'# -> reservedSym + '⟧'# -> reservedSym + '\x00'# -> fullStop + '\x01'# -> fullStop + '\x02'# -> fullStop + '\x03'# -> fullStop + '\x04'# -> fullStop + '\x05'# -> fullStop + '\x06'# -> fullStop + '\x07'# -> fullStop + '\x08'# -> other + c# -> case ord# c# of + c2# | isTrue# (c2# <=# 0x7f#) -> + int2Word# c2# -- Plain ascii needs no fixing. + | otherwise -> + case generalCategory (C# c#) of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> suffix + OtherLetter -> lower + NonSpacingMark -> suffix + DecimalNumber -> digit + OtherNumber -> digit + Space -> space + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + + SpacingCombiningMark -> space + EnclosingMark -> other + LetterNumber -> symbol + OpenPunctuation -> symbol + ClosePunctuation -> symbol + InitialQuote -> symbol + FinalQuote -> symbol + LineSeparator -> space + ParagraphSeparator -> space + Control -> other + Format -> other + Surrogate -> other + PrivateUse -> other + NotAssigned -> other + where + fullStop, space, upper, lower, symbol :: Word# + digit, suffix, reservedSym, other :: Word# + fullStop = 0x00## -- Don't care about these + space = 0x01## + upper = 0x02## + lower = 0x03## + symbol = 0x04## + digit = 0x05## + suffix = 0x06## + reservedSym = 0x07## + other = 0x08## + diff --git a/tests/examples/ghc98/ModuleComments.hs b/tests/examples/ghc98/ModuleComments.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/ModuleComments.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +x = 1 diff --git a/tests/examples/ghc98/MonoidsFD.hs b/tests/examples/ghc98/MonoidsFD.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/MonoidsFD.hs @@ -0,0 +1,112 @@ +-- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html + +-------------------- FUNCTIONAL DEPENDENCY VERSION ---------------- + +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE UnicodeSyntax #-} + +module Main where +import Control.Monad (Monad(..), join, ap) +import Data.Monoid (Monoid(..)) +import Data.Semigroup (Semigroup(..)) + +-- First we define the type class Monoidy: + +class Monoidy to comp id m | m to → comp id where + munit :: id `to` m + mjoin :: (m `comp` m) `to` m + +-- We use functional dependencies to help the typechecker understand that +-- m and ~> uniquely determine comp (times) and id. +-- +-- This kind of type class would not have been possible in previous +-- versions of GHC; with the new kind system, however, we can abstract +-- over kinds!2 Now, let’s create types for the additive and +-- multiplicative monoids over the natural numbers: + +newtype Sum a = Sum a deriving Show +newtype Product a = Product a deriving Show +instance Num a ⇒ Monoidy (→) (,) () (Sum a) where + munit _ = Sum 0 + mjoin (Sum x, Sum y) = Sum $ x + y +instance Num a ⇒ Monoidy (→) (,) () (Product a) where + munit _ = Product 1 + mjoin (Product x, Product y) = Product $ x * y + +-- It will be slightly more complicated to make a monadic instance with +-- Monoidy. First, we need to define the identity functor, a type for +-- natural transformations, and a type for functor composition: + +data Id α = Id { runId :: α } deriving Functor + +-- A natural transformation (Λ f g α. (f α) → (g α)) may be encoded in Haskell as follows: + +data NT f g = NT { runNT :: ∀ α. f α → g α } + +-- Functor composition (Λ f g α. f (g α)) is encoded as follows: + +data FC f g α = FC { runFC :: f (g α) } + +-- Now, let us define some type T which should be a monad: + +data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor) +instance Monoidy NT FC Id Wrapper where + munit = NT $ Wrapper . runId + mjoin = NT $ runWrapper . runFC + +-- With these defined, we can use them as follows: + +test1 = do { print (mjoin (munit (), Sum 2)) + -- Sum 2 + ; print (mjoin (Product 2, Product 3)) + -- Product 6 + ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world")) + -- Wrapper {runWrapper = "hello, world" } + } + +-- We can even provide a special binary operator for the appropriate monoids as follows: + +(<+>) :: Monoidy (→) (,) () m ⇒ m → m → m +(<+>) = curry mjoin + +test2 = print (Sum 1 <+> Sum 2 <+> Sum 4) -- Sum 7 + +-- Now, all the extra wrapping that Haskell requires for encoding this is +-- rather cumbersome in actual use. So, we can give traditional Monad and +-- Monoid instances for instances of Monoidy: + +instance Monoidy (→) (,) () m ⇒ Semigroup m where + (<>) = curry mjoin + +instance Monoidy (→) (,) () m ⇒ Monoid m where + mempty = munit () + +instance Applicative Wrapper where + pure x = runNT munit $ Id x + (<*>) = ap + +-- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where +instance Monad Wrapper where + x >>= f = runNT mjoin $ FC (f `fmap` x) + +-- And so the following works: + +test3 + = do { print (mappend mempty (Sum 2)) + -- Sum 2 + ; print (mappend (Product 2) (Product 3)) + -- Product 6 + ; print (join $ Wrapper $ Wrapper "hello") + -- Wrapper {runWrapper = "hello" } + ; print (Wrapper "hello, world" >>= return) + -- Wrapper {runWrapper = "hello, world" } + } + +main = test1 >> test2 >> test3 diff --git a/tests/examples/ghc98/T13343.hs b/tests/examples/ghc98/T13343.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/T13343.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +module Bug where + +import GHC.Exts + +type Bad :: forall v . TYPE v +type Bad @v = (forall (v1 :: RuntimeRep) (a1 :: TYPE v). a1) :: TYPE v + +-- Note v /= v1. + diff --git a/tests/examples/ghc98/T23465.hs b/tests/examples/ghc98/T23465.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/T23465.hs @@ -0,0 +1,14 @@ +module T23465 {-# WaRNING in "x-a" "b" #-} where + +{-# WARNInG in "x-c" e "d" #-} +e = e + +{-# WARNInG + in "x-f" f "fw" ; + in "x-f" g "gw" +#-} +f = f +g = g + +{-# WARNinG h "hw" #-} +h = h diff --git a/tests/examples/ghc98/Token.hs b/tests/examples/ghc98/Token.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc98/Token.hs @@ -0,0 +1,261 @@ +{-# language BangPatterns #-} +{-# language BinaryLiterals #-} +{-# language DerivingStrategies #-} +{-# language DuplicateRecordFields #-} +{-# language LambdaCase #-} +{-# language MagicHash #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language UnboxedTuples #-} + +module Json.Token + ( Token(..) + , TokenException(..) + , decode + ) where + +import Control.Monad.ST (ST,runST) +import Data.Bits ((.&.),(.|.),unsafeShiftR) +import Data.Builder.ST (Builder) +import Data.Bytes.Parser (Parser) +import Data.Bytes.Types (Bytes(..)) +import Data.Char (ord) +import Data.Primitive (MutableByteArray,ByteArray) +import Data.Primitive (SmallArray) +import Data.Text.Short (ShortText) +import Data.Word (Word8,Word16) +import GHC.Exts (Int(I#),Char(C#)) +import GHC.Exts (word2Int#,chr#,gtWord#,ltWord#) +import GHC.Word (Word16(W16#),Word8(W8#)) +import Data.Number.Scientific (Scientific) + +import qualified Data.ByteString.Short.Internal as BSS +import qualified Data.Bytes.Parser as P +import qualified Data.Bytes.Parser.Utf8 as Utf8 +import qualified Data.Bytes.Parser.Latin as Latin +import qualified Data.Bytes.Parser.Unsafe as Unsafe +import qualified Data.Builder.ST as B +import qualified Data.Chunks as C +import qualified Data.Primitive as PM +import qualified Data.Text.Short.Unsafe as TS +import qualified Data.Number.Scientific as SCI + +-- | A token in a JSON document. +data Token + = LeftBrace + | RightBrace + | LeftBracket + | RightBracket + | Comma + | Colon + | BooleanTrue + | BooleanFalse + | Null + | String {-# UNPACK #-} !ShortText + | Number {-# UNPACK #-} !Scientific + deriving stock (Eq,Show) + +-- | An exception encountered while tokenizing a JSON document. +data TokenException + = InvalidNumber + | InvalidLeader + | ExpectedTrue + | ExpectedFalse + | ExpectedNull + | LeadingZero + | InvalidEscapeSequence + | IncompleteString + | IncompleteEscapeSequence + deriving stock (Eq,Show) + +isSpace :: Word8 -> Bool +isSpace w = + w == c2w ' ' + || w == c2w '\t' + || w == c2w '\r' + || w == c2w '\n' + +-- | Decode a sequence as JSON tokens. This allows token +-- sequences that would be rejected by the ABNF given in +-- : +-- +-- >>> decode (Bytes.fromAsciiString "[ , true }") +-- Right [ LeftBracket, Comma, BooleanTrue, RightBrace ] +-- +-- It is up to the user to reject such malformed JSON when +-- they parse the token sequence. More surprisingly, this +-- tokenizer accepts some unnatural juxtapositions of token +-- sequences without whitespace. For example: +-- +-- >>> decode (Bytes.fromAsciiString "55truefalse") +-- Right [ Number 55, BooleanTrue, BooleanFalse ] +-- >>> decode (Bytes.fromAsciiString "null\"hello\"") +-- Right [ Null, String "hello" ] +-- +-- Acceptance of such samples simplifies the implementation +-- of this tokenizer. These unnatural juxtapositions always +-- result in token sequences that should be rejected anyway in +-- the subsequent parsing done by the user. Consequently, their +-- acceptance is not considered harmful. +decode :: Bytes -> Either TokenException (SmallArray Token) +decode !bs = runST $ do + !b <- B.new + P.parseBytesEffectfully (P.skipWhile isSpace *> manyTokens b) bs >>= \case + P.Failure err -> pure (Left err) + -- Since manyTokens only completes once the end of the input + -- has been reached, we do not need to check the length here. + P.Success (P.Slice _ _ cs) -> pure (Right cs) + +manyTokens :: + Builder s Token + -> Parser TokenException s (SmallArray Token) +manyTokens !b0 = do + t <- oneToken + !b1 <- P.effect (B.push t b0) + P.skipWhile isSpace + done <- P.isEndOfInput + if done + then P.effect $ do + cs <- B.freeze b1 + pure $! C.concat cs + else manyTokens b1 + +-- TODO: oneToken is only called in contexts where the initial +-- call to Latin.any cannot fail. Consider refactoring to make +-- this more explicit. +oneToken :: Parser TokenException s Token +oneToken = Latin.any InvalidLeader >>= \case + '{' -> pure LeftBrace + '}' -> pure RightBrace + '[' -> pure LeftBracket + ']' -> pure RightBracket + ',' -> pure Comma + ':' -> pure Colon + 't' -> do + Latin.char3 ExpectedTrue 'r' 'u' 'e' + pure BooleanTrue + 'f' -> do + Latin.char4 ExpectedFalse 'a' 'l' 's' 'e' + pure BooleanFalse + 'n' -> do + Latin.char3 ExpectedNull 'u' 'l' 'l' + pure Null + '"' -> do + start <- Unsafe.cursor + string start + '-' -> fmap Number (SCI.parserNegatedUtf8Bytes InvalidNumber) + '0' -> Latin.trySatisfy (\c -> c >= '0' && c <= '9') >>= \case + True -> P.fail LeadingZero + False -> fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber 0) + c | c >= '1' && c <= '9' -> + fmap Number (SCI.parserTrailingUtf8Bytes InvalidNumber (ord c - 48)) + _ -> P.fail InvalidLeader + +copyAndEscape :: Int -> Parser TokenException s Token +copyAndEscape !maxLen = do + !dst <- P.effect (PM.newByteArray maxLen) + let go !ix = Utf8.any# IncompleteString `P.bindFromCharToLifted` \c -> case c of + '\\'# -> Latin.any IncompleteEscapeSequence >>= \case + '"' -> do + P.effect (PM.writeByteArray dst ix (c2w '"')) + go (ix + 1) + '\\' -> do + P.effect (PM.writeByteArray dst ix (c2w '\\')) + go (ix + 1) + 't' -> do + P.effect (PM.writeByteArray dst ix (c2w '\t')) + go (ix + 1) + 'n' -> do + P.effect (PM.writeByteArray dst ix (c2w '\n')) + go (ix + 1) + 'r' -> do + P.effect (PM.writeByteArray dst ix (c2w '\r')) + go (ix + 1) + '/' -> do + P.effect (PM.writeByteArray dst ix (c2w '/')) + go (ix + 1) + 'b' -> do + P.effect (PM.writeByteArray dst ix (c2w '\b')) + go (ix + 1) + 'f' -> do + P.effect (PM.writeByteArray dst ix (c2w '\f')) + go (ix + 1) + 'u' -> do + w <- Latin.hexFixedWord16 InvalidEscapeSequence + if w >= 0xD800 && w < 0xDFFF + then go =<< P.effect (encodeUtf8Char dst ix '\xFFFD') + else go =<< P.effect (encodeUtf8Char dst ix (w16ToChar w)) + _ -> P.fail InvalidEscapeSequence + '"'# -> do + str <- P.effect + (PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray dst ix) + pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) + _ -> go =<< P.effect (encodeUtf8Char dst ix (C# c)) + go 0 + +encodeUtf8Char :: MutableByteArray s -> Int -> Char -> ST s Int +encodeUtf8Char !marr !ix !c + | c < '\128' = do + PM.writeByteArray marr ix (c2w c) + pure (ix + 1) + | c < '\x0800' = do + PM.writeByteArray marr ix + (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6 .|. 0b11000000)) + PM.writeByteArray marr (ix + 1) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) + pure (ix + 2) + | c <= '\xffff' = do + PM.writeByteArray marr ix + (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 12 .|. 0b11100000)) + PM.writeByteArray marr (ix + 1) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (unsafeShiftR (ord c) 6)))) + PM.writeByteArray marr (ix + 2) + (0b10000000 .|. (0b00111111 .&. (fromIntegral @Int @Word8 (ord c)))) + pure (ix + 3) + | otherwise = error "encodeUtf8Char: write this" + + +-- Compute the maximum number of bytes that could possibly +-- be required to house the UTF-8-encoded string once any +-- JSON escape sequences have been resolved. +-- The correctness of this hinges on the assumption that +-- the UTF-8 encoding of a character never takes up more +-- bytes than its escape sequence. +-- TODO: Something fishy is going on with escape sequences +-- in this function. Look over this again. +string :: Int -> Parser TokenException s Token +string !start = go 1 where + go !canMemcpy = do + P.any IncompleteString >>= \case + 92 -> P.any InvalidEscapeSequence *> go 0 -- backslash + 34 -> do -- double quote + !pos <- Unsafe.cursor + case canMemcpy of + 1 -> do + src <- Unsafe.expose + str <- P.effect $ do + let end = pos - 1 + let len = end - start + dst <- PM.newByteArray len + PM.copyByteArray dst 0 src start len + PM.unsafeFreezeByteArray dst + pure (String (TS.fromShortByteStringUnsafe (byteArrayToShortByteString str))) + _ -> do + Unsafe.unconsume (pos - start) + let end = pos - 1 + let maxLen = end - start + copyAndEscape maxLen + W8# w -> go (canMemcpy .&. I# (ltWord# w 128##) .&. I# (gtWord# w 31##)) + +byteArrayToShortByteString :: ByteArray -> BSS.ShortByteString +byteArrayToShortByteString (PM.ByteArray x) = BSS.SBS x + +c2w :: Char -> Word8 +c2w = fromIntegral . ord + +-- Precondition: Not in the range [U+D800 .. U+DFFF] +w16ToChar :: Word16 -> Char +w16ToChar (W16# w) = C# (chr# (word2Int# w)) +