Skip to content

Commit

Permalink
Support GHC 9.0.1
Browse files Browse the repository at this point in the history
Summary: Fixes facebookincubator#25

Reviewed By: pepeiborra

Differential Revision: D27555935

fbshipit-source-id: 3d91ffe8307872fed6a496f2813390230f1d855e
  • Loading branch information
Andrew Farmer authored and facebook-github-bot committed Apr 5, 2021
1 parent de8c901 commit d286944
Show file tree
Hide file tree
Showing 20 changed files with 337 additions and 67 deletions.
1 change: 1 addition & 0 deletions CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@ x.x.x.x (xxx)
* Added --adhoc-type flag (#13)
* Added --adhoc-pattern, --pattern-forward, --pattern-backward (#15)
* Removed support for GHC 8.4 and 8.8
* Added support for GHC 9.0.1

0.1.1.1 (June 1, 2020)

Expand Down
6 changes: 3 additions & 3 deletions Retrie/CPP.hs
Original file line number Diff line number Diff line change
Expand Up @@ -116,7 +116,7 @@ printCPP repls (CPP orig is ms) = Text.unpack $ Text.unlines $
sorted = sortOn fst
[ (r, replReplacement)
| Replacement{..} <- repls
, RealSrcSpan r <- [replLocation]
, Just r <- [getRealSpan replLocation]
]

origLines = Text.lines orig
Expand Down Expand Up @@ -319,8 +319,8 @@ isPragma = Text.isPrefixOf "{-#"
insertImports
:: Monad m
=> [AnnotatedImports] -- ^ imports and their annotations
-> Located (HsModule GhcPs) -- ^ target module
-> TransformT m (Located (HsModule GhcPs))
-> Located HsModule -- ^ target module
-> TransformT m (Located HsModule)
insertImports is (L l m) = do
imps <- graftA $ filterAndFlatten (unLoc <$> hsmodName m) is
let
Expand Down
3 changes: 3 additions & 0 deletions Retrie/Context.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -79,7 +80,9 @@ updateContext c i =
updGRHSs = addInScope neverParen . collectLocalBinders . unLoc . grhssLocalBinds

updGRHS :: GRHS GhcPs (LHsExpr GhcPs) -> Context
#if __GLASGOW_HASKELL__ < 900
updGRHS XGRHS{} = neverParen
#endif
updGRHS (GRHS _ gs _)
-- binders are in scope over the body (right child) only
| i > firstChild = addInScope neverParen bs
Expand Down
16 changes: 15 additions & 1 deletion Retrie/ExactPrint.hs
Original file line number Diff line number Diff line change
Expand Up @@ -75,7 +75,7 @@ import Language.Haskell.GHC.ExactPrint.Utils (annLeadingCommentEntryDelta, showG
import Retrie.ExactPrint.Annotated
import Retrie.Fixity
import Retrie.GHC
import Retrie.SYB
import Retrie.SYB hiding (ext1)

import GHC.Stack

Expand Down Expand Up @@ -113,13 +113,23 @@ fixOneExpr env (L l2 (OpApp x2 ap1@(L l1 (OpApp x1 x op1 y)) op2 z))
fixOneExpr _ e = return e

fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
#if __GLASGOW_HASKELL__ < 900
fixOnePat env (dLPat -> Just (L l2 (ConPatIn op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPatIn op1 (InfixCon x y)))) z))))
| associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
let ap2' = L l2 (ConPatIn op2 (InfixCon y z))
swapEntryDPT ap1 ap2'
transferAnnsT isComma ap2' ap1
rhs <- fixOnePat env (cLPat ap2')
return $ cLPat $ L l1 (ConPatIn op1 (InfixCon x rhs))
#else
fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPat ext1 op1 (InfixCon x y)))) z))))
| associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
let ap2' = L l2 (ConPat ext2 op2 (InfixCon y z))
swapEntryDPT ap1 ap2'
transferAnnsT isComma ap2' ap1
rhs <- fixOnePat env (cLPat ap2')
return $ cLPat $ L l1 (ConPat ext1 op1 (InfixCon x rhs))
#endif
fixOnePat _ e = return e

-- Move leading whitespace from the left child of an operator application
Expand Down Expand Up @@ -152,7 +162,11 @@ fixOneEntryExpr e = return e

fixOneEntryPat :: Monad m => LPat GhcPs -> TransformT m (LPat GhcPs)
fixOneEntryPat pat
#if __GLASGOW_HASKELL__ < 900
| Just p@(L _ (ConPatIn _ (InfixCon x _))) <- dLPat pat =
#else
| Just p@(L _ (ConPat _ _ (InfixCon x _))) <- dLPat pat =
#endif
cLPat <$> fixOneEntry p (dLPatUnsafe x)
| otherwise = return pat

Expand Down
2 changes: 1 addition & 1 deletion Retrie/ExactPrint/Annotated.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ type AnnotatedHsExpr = Annotated (LHsExpr GhcPs)
type AnnotatedHsType = Annotated (LHsType GhcPs)
type AnnotatedImport = Annotated (LImportDecl GhcPs)
type AnnotatedImports = Annotated [LImportDecl GhcPs]
type AnnotatedModule = Annotated (Located (HsModule GhcPs))
type AnnotatedModule = Annotated (Located HsModule)
type AnnotatedPat = Annotated (Located (Pat GhcPs))
type AnnotatedStmt = Annotated (LStmt GhcPs (LHsExpr GhcPs))

Expand Down
19 changes: 16 additions & 3 deletions Retrie/Expr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
Expand Down Expand Up @@ -127,7 +128,11 @@ mkConPatIn
-> HsConPatDetails GhcPs
-> TransformT m (Located (Pat GhcPs))
mkConPatIn patName params = do
#if __GLASGOW_HASKELL__ < 900
p <- mkLoc $ ConPatIn patName params
#else
p <- mkLoc $ ConPat noExtField patName params
#endif
setEntryDPT p (DP (0,0))
return p

Expand Down Expand Up @@ -178,7 +183,14 @@ patToExpr orig = case dLPat orig of
return e
where
go WildPat{} = newWildVar >>= lift . mkLocatedHsVar . noLoc
#if __GLASGOW_HASKELL__ < 900
go XPat{} = error "patToExpr XPat"
go CoPat{} = error "patToExpr CoPat"
go (ConPatIn con ds) = conPatHelper con ds
go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc
#else
go (ConPat _ con ds) = conPatHelper con ds
#endif
go (LazyPat _ pat) = patToExpr pat
go (BangPat _ pat) = patToExpr pat
go (ListPat _ ps) = do
Expand All @@ -203,10 +215,7 @@ patToExpr orig = case dLPat orig of
lift $ mkLoc $ Present noExtField e
lift $ mkLoc $ ExplicitTuple noExtField es boxity
go (VarPat _ i) = lift $ mkLocatedHsVar i
go XPat{} = error "patToExpr XPat"
go AsPat{} = error "patToExpr AsPat"
go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc
go CoPat{} = error "patToExpr CoPat"
go NPlusKPat{} = error "patToExpr NPlusKPat"
go SplicePat{} = error "patToExpr SplicePat"
go SumPat{} = error "patToExpr SumPat"
Expand Down Expand Up @@ -292,8 +301,12 @@ parenifyP Context{..} p@(L _ pat)
needed TuplePat{} = False
needed VarPat{} = False
needed WildPat{} = False
#if __GLASGOW_HASKELL__ < 900
needed (ConPatIn _ (PrefixCon [])) = False
needed ConPatOut{pat_args = PrefixCon []} = False
#else
needed (ConPat _ _ (PrefixCon [])) = False
#endif
needed _ = True

parenifyT
Expand Down
92 changes: 84 additions & 8 deletions Retrie/GHC.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE RecordWildCards #-}
module Retrie.GHC
( module Retrie.GHC
#if __GLASGOW_HASKELL__ < 900
, module ApiAnnotation
, module Bag
, module BasicTypes
Expand All @@ -28,20 +29,40 @@ module Retrie.GHC
, module Unique
, module UniqFM
, module UniqSet
#else
-- GHC >= 9.0
, module GHC.Data.Bag
, module GHC.Data.FastString
, module GHC.Data.FastString.Env
, module GHC.Utils.Error
, module GHC.Hs
, module GHC.Parser.Annotation
, module GHC.Types.Basic
, module GHC.Types.Name
, module GHC.Types.Name.Reader
, module GHC.Types.SrcLoc
, module GHC.Types.Unique
, module GHC.Types.Unique.FM
, module GHC.Types.Unique.Set
, module GHC.Unit
#endif
) where

#if __GLASGOW_HASKELL__ < 900
import ApiAnnotation
import Bag
import BasicTypes
import FastString
import FastStringEnv
#if __GLASGOW_HASKELL__ < 810
import HsExpr
import HsSyn
import HsSyn hiding (HsModule)
import qualified HsSyn as HS
#else
import ErrUtils
import GHC.Hs.Expr
import GHC.Hs
import GHC.Hs hiding (HsModule)
import qualified GHC.Hs as HS
#endif
import Module
import Name
Expand All @@ -51,10 +72,31 @@ import SrcLoc
import Unique
import UniqFM
import UniqSet
#else
-- GHC >= 9.0
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Utils.Error
import GHC.Hs
import GHC.Parser.Annotation
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Unit
#endif

import Data.Bifunctor (second)
import Data.Maybe

#if __GLASGOW_HASKELL__ < 900
type HsModule = HS.HsModule GhcPs
#endif

cLPat :: Located (Pat (GhcPass p)) -> LPat (GhcPass p)
#if __GLASGOW_HASKELL__ == 808
cLPat = composeSrcSpan
Expand Down Expand Up @@ -100,7 +142,7 @@ tyvarRdrName :: HsType p -> Maybe (Located (IdP p))
tyvarRdrName (HsTyVar _ _ n) = Just n
tyvarRdrName _ = Nothing

fixityDecls :: HsModule p -> [(Located (IdP p), Fixity)]
fixityDecls :: HsModule -> [(Located RdrName, Fixity)]
fixityDecls m =
[ (nm, fixity)
| L _ (SigD _ (FixSig _ (FixitySig _ nms fixity))) <- hsmodDecls m
Expand All @@ -114,23 +156,36 @@ ruleInfo (HsRule _ (L _ (_, riName)) _ tyBs valBs riLHS riRHS) =
map unLoc (tyBindersToLocatedRdrNames (fromMaybe [] tyBs)) ++
ruleBindersToQs valBs
in [ RuleInfo{..} ]
#if __GLASGOW_HASKELL__ < 900
ruleInfo XRuleDecl{} = []
#endif

ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
ruleBindersToQs bs = catMaybes
[ case b of
RuleBndr _ (L _ v) -> Just v
RuleBndrSig _ (L _ v) _ -> Just v
#if __GLASGOW_HASKELL__ < 900
XRuleBndr{} -> Nothing
#endif
| L _ b <- bs
]

#if __GLASGOW_HASKELL__ < 900
tyBindersToLocatedRdrNames :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
#else
tyBindersToLocatedRdrNames :: [LHsTyVarBndr () GhcPs] -> [Located RdrName]
#endif
tyBindersToLocatedRdrNames vars = catMaybes
[ case var of
#if __GLASGOW_HASKELL__ < 900
UserTyVar _ v -> Just v
KindedTyVar _ v _ -> Just v
XTyVarBndr{} -> Nothing
#else
UserTyVar _ _ v -> Just v
KindedTyVar _ _ v _ -> Just v
#endif
| L _ var <- vars ]

data RuleInfo = RuleInfo
Expand All @@ -146,10 +201,11 @@ noExtField = noExt
#endif

overlaps :: SrcSpan -> SrcSpan -> Bool
overlaps (RealSrcSpan s1) (RealSrcSpan s2) =
srcSpanFile s1 == srcSpanFile s2 &&
((srcSpanStartLine s1, srcSpanStartCol s1) `within` s2 ||
(srcSpanEndLine s1, srcSpanEndCol s1) `within` s2)
overlaps ss1 ss2
| Just s1 <- getRealSpan ss1, Just s2 <- getRealSpan ss2 =
srcSpanFile s1 == srcSpanFile s2 &&
((srcSpanStartLine s1, srcSpanStartCol s1) `within` s2 ||
(srcSpanEndLine s1, srcSpanEndCol s1) `within` s2)
overlaps _ _ = False

within :: (Int, Int) -> RealSrcSpan -> Bool
Expand All @@ -162,11 +218,31 @@ within (l,p) s =
lineCount :: [SrcSpan] -> Int
lineCount ss = sum
[ srcSpanEndLine s - srcSpanStartLine s + 1
| RealSrcSpan s <- ss
| Just s <- map getRealSpan ss
]

showRdrs :: [RdrName] -> String
showRdrs = show . map (occNameString . occName)

#if __GLASGOW_HASKELL__ < 900
uniqBag :: Uniquable a => [(a,b)] -> UniqFM [b]
#else
uniqBag :: Uniquable a => [(a,b)] -> UniqFM a [b]
#endif
uniqBag = listToUFM_C (++) . map (second pure)

getRealLoc :: SrcLoc -> Maybe RealSrcLoc
#if __GLASGOW_HASKELL__ < 900
getRealLoc (RealSrcLoc l) = Just l
#else
getRealLoc (RealSrcLoc l _) = Just l
#endif
getRealLoc _ = Nothing

getRealSpan :: SrcSpan -> Maybe RealSrcSpan
#if __GLASGOW_HASKELL__ < 900
getRealSpan (RealSrcSpan s) = Just s
#else
getRealSpan (RealSrcSpan s _) = Just s
#endif
getRealSpan _ = Nothing
5 changes: 5 additions & 0 deletions Retrie/PatternMap/Bag.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
Expand Down Expand Up @@ -139,7 +140,11 @@ instance PatternMap FSEnv where

------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ < 900
newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM [a] }
#else
newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM (Key UniqFM) [a] }
#endif
deriving (Functor)

instance PatternMap UniqFM where
Expand Down
3 changes: 2 additions & 1 deletion Retrie/PatternMap/Class.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
module Retrie.PatternMap.Class where

import Control.Monad
import Data.Kind
import Data.Maybe

import Retrie.AlphaEnv
Expand Down Expand Up @@ -51,7 +52,7 @@ unionOn f m1 m2 = mUnion (f m1) (f m2)
------------------------------------------------------------------------

class PatternMap m where
type Key m :: *
type Key m :: Type

mEmpty :: m a
mUnion :: m a -> m a -> m a
Expand Down
Loading

0 comments on commit d286944

Please sign in to comment.