diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2021-06-14 22:24:42 +0100 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2021-06-22 23:20:02 +0100 |
| commit | e9ac323228575248477abd63e8f1f68c470d9275 (patch) | |
| tree | b52a13d98b4780e2b5491bc2bdb53b73ee16a4ff | |
| parent | 62d720db4f6a53014400a608baf5c56555258eee (diff) | |
| download | haskell-e9ac323228575248477abd63e8f1f68c470d9275.tar.gz | |
EPA: Bringing over tests and updates from ghc-exactprintwip/az/exactprint-align-repos
32 files changed, 1269 insertions, 463 deletions
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile index e8bbe7c079..e2081aee9c 100644 --- a/testsuite/tests/printer/Makefile +++ b/testsuite/tests/printer/Makefile @@ -608,3 +608,123 @@ Test19840: Test19850: $(CHECK_PPR) $(LIBDIR) Test19850.hs $(CHECK_EXACT) $(LIBDIR) Test19850.hs + +.PHONY: PprCommentsOnly +PprCommentsOnly: + $(CHECK_PPR) $(LIBDIR) PprCommentsOnly.hs + $(CHECK_EXACT) $(LIBDIR) PprCommentsOnly.hs + +.PHONY: PprSemis +PprSemis: + $(CHECK_PPR) $(LIBDIR) PprSemis.hs + $(CHECK_EXACT) $(LIBDIR) PprSemis.hs + +.PHONY: PprForeignDecl +PprForeignDecl: + # $(CHECK_PPR) $(LIBDIR) PprForeignDecl.hs + $(CHECK_EXACT) $(LIBDIR) PprForeignDecl.hs + +.PHONY: PprRoles +PprRoles: + $(CHECK_PPR) $(LIBDIR) PprRoles.hs + $(CHECK_EXACT) $(LIBDIR) PprRoles.hs + +.PHONY: PprTypeSynParens +PprTypeSynParens: + $(CHECK_PPR) $(LIBDIR) PprTypeSynParens.hs + $(CHECK_EXACT) $(LIBDIR) PprTypeSynParens.hs + +.PHONY: PprEmptyMostlyInst +PprEmptyMostlyInst: + $(CHECK_PPR) $(LIBDIR) PprEmptyMostlyInst.hs + $(CHECK_EXACT) $(LIBDIR) PprEmptyMostlyInst.hs + +.PHONY: PprParenFunBind +PprParenFunBind: + $(CHECK_PPR) $(LIBDIR) PprParenFunBind.hs + $(CHECK_EXACT) $(LIBDIR) PprParenFunBind.hs + +.PHONY: PprRecordSemi +PprRecordSemi: + $(CHECK_PPR) $(LIBDIR) PprRecordSemi.hs + $(CHECK_EXACT) $(LIBDIR) PprRecordSemi.hs + +.PHONY: PprCompleteSig +PprCompleteSig: + $(CHECK_PPR) $(LIBDIR) PprCompleteSig.hs + $(CHECK_EXACT) $(LIBDIR) PprCompleteSig.hs + +.PHONY: PprOverloadedLabels +PprOverloadedLabels: + $(CHECK_PPR) $(LIBDIR) PprOverloadedLabels.hs + $(CHECK_EXACT) $(LIBDIR) PprOverloadedLabels.hs + +.PHONY: PprArrows +PprArrows: + $(CHECK_PPR) $(LIBDIR) PprArrows.hs + $(CHECK_EXACT) $(LIBDIR) PprArrows.hs + +.PHONY: PprOverloadedRecords +PprOverloadedRecords: + $(CHECK_PPR) $(LIBDIR) PprOverloadedRecords.hs + $(CHECK_EXACT) $(LIBDIR) PprOverloadedRecords.hs + +.PHONY: PprArrowLambdaCase +PprArrowLambdaCase: + $(CHECK_PPR) $(LIBDIR) PprArrowLambdaCase.hs + $(CHECK_EXACT) $(LIBDIR) PprArrowLambdaCase.hs + +.PHONY: PprRecursiveDo +PprRecursiveDo: + $(CHECK_PPR) $(LIBDIR) PprRecursiveDo.hs + $(CHECK_EXACT) $(LIBDIR) PprRecursiveDo.hs + +.PHONY: PprTypeBrackets +PprTypeBrackets: + $(CHECK_PPR) $(LIBDIR) PprTypeBrackets.hs + $(CHECK_EXACT) $(LIBDIR) PprTypeBrackets.hs + +.PHONY: PprDynamic +PprDynamic: + $(CHECK_PPR) $(LIBDIR) PprDynamic.hs + $(CHECK_EXACT) $(LIBDIR) PprDynamic.hs + +.PHONY: PprEmptyMostly +PprEmptyMostly: + $(CHECK_PPR) $(LIBDIR) PprEmptyMostly.hs + $(CHECK_EXACT) $(LIBDIR) PprEmptyMostly.hs + +.PHONY: PprClassParens +PprClassParens: + $(CHECK_PPR) $(LIBDIR) PprClassParens.hs + $(CHECK_EXACT) $(LIBDIR) PprClassParens.hs + +.PHONY: PprThAbstractFamily +PprThAbstractFamily: + $(CHECK_PPR) $(LIBDIR) PprThAbstractFamily.hs + $(CHECK_EXACT) $(LIBDIR) PprThAbstractFamily.hs + +.PHONY: PprClassTypeFamily +PprClassTypeFamily: + $(CHECK_PPR) $(LIBDIR) PprClassTypeFamily.hs + $(CHECK_EXACT) $(LIBDIR) PprClassTypeFamily.hs + +.PHONY: PprT13747 +PprT13747: + $(CHECK_PPR) $(LIBDIR) PprT13747.hs + $(CHECK_EXACT) $(LIBDIR) PprT13747.hs + +.PHONY: PprBracesSemiDataDecl +PprBracesSemiDataDecl: + $(CHECK_PPR) $(LIBDIR) PprBracesSemiDataDecl.hs + $(CHECK_EXACT) $(LIBDIR) PprBracesSemiDataDecl.hs + +.PHONY: PprUnicodeSyntax +PprUnicodeSyntax: + $(CHECK_PPR) $(LIBDIR) PprUnicodeSyntax.hs + $(CHECK_EXACT) $(LIBDIR) PprUnicodeSyntax.hs + +.PHONY: PprCommentPlacement2 +PprCommentPlacement2: + $(CHECK_PPR) $(LIBDIR) PprCommentPlacement2.hs + $(CHECK_EXACT) $(LIBDIR) PprCommentPlacement2.hs diff --git a/testsuite/tests/printer/PprArrowLambdaCase.hs b/testsuite/tests/printer/PprArrowLambdaCase.hs new file mode 100644 index 0000000000..c678339890 --- /dev/null +++ b/testsuite/tests/printer/PprArrowLambdaCase.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE Arrows, LambdaCase #-} +module Main (main) where + +import Control.Arrow + +main :: IO () +main = do + putStrLn $ foo (Just 42) + putStrLn $ foo (Just 500) + putStrLn $ foo Nothing + +foo :: ArrowChoice p => p (Maybe Int) String +foo = proc x -> + (| id (\case + Just x | x > 100 -> returnA -< "big " ++ show x + | otherwise -> returnA -< "small " ++ show x + Nothing -> returnA -< "none") + |) x diff --git a/testsuite/tests/printer/PprArrows.hs b/testsuite/tests/printer/PprArrows.hs new file mode 100644 index 0000000000..a98e0689ee --- /dev/null +++ b/testsuite/tests/printer/PprArrows.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows #-} +module Arrow where + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/testsuite/tests/printer/PprBracesSemiDataDecl.hs b/testsuite/tests/printer/PprBracesSemiDataDecl.hs new file mode 100644 index 0000000000..825ba4257d --- /dev/null +++ b/testsuite/tests/printer/PprBracesSemiDataDecl.hs @@ -0,0 +1,6 @@ + +data Nat (t :: NatKind) where +{ + ZeroNat :: Nat Zero; + SuccNat :: Nat t -> Nat (Succ t); +}; diff --git a/testsuite/tests/printer/PprClassParens.hs b/testsuite/tests/printer/PprClassParens.hs new file mode 100644 index 0000000000..344ce63174 --- /dev/null +++ b/testsuite/tests/printer/PprClassParens.hs @@ -0,0 +1,3 @@ +module PprClassParens where + +class (f `Compose` g) x diff --git a/testsuite/tests/printer/PprClassTypeFamily.hs b/testsuite/tests/printer/PprClassTypeFamily.hs new file mode 100644 index 0000000000..27473a8082 --- /dev/null +++ b/testsuite/tests/printer/PprClassTypeFamily.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) diff --git a/testsuite/tests/printer/PprCommentPlacement2.hs b/testsuite/tests/printer/PprCommentPlacement2.hs new file mode 100644 index 0000000000..245f12c9e8 --- /dev/null +++ b/testsuite/tests/printer/PprCommentPlacement2.hs @@ -0,0 +1,8 @@ +module PprCommentPlacement2 where + +c04 = do + let result = do + acceptStr <- y + where + --COMMENT + aa = bb diff --git a/testsuite/tests/printer/PprCommentsOnly.hs b/testsuite/tests/printer/PprCommentsOnly.hs new file mode 100644 index 0000000000..a03c1cb598 --- /dev/null +++ b/testsuite/tests/printer/PprCommentsOnly.hs @@ -0,0 +1,5 @@ +{- +Nothing but comments. Make sure they actually get exact printed +-} + +-- Another one diff --git a/testsuite/tests/printer/PprCompleteSig.hs b/testsuite/tests/printer/PprCompleteSig.hs new file mode 100644 index 0000000000..1a5fbaed66 --- /dev/null +++ b/testsuite/tests/printer/PprCompleteSig.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} +module Simple where + +pattern Foo :: () +pattern Foo = () + +a :: () -> () +a Foo = () + +data A = B | C | D + +{-# COMPLETE Foo #-} +{-# COMPLETE B,C #-} +{-# COMPLETE B #-} + +b :: A -> A +b B = B +b C = C diff --git a/testsuite/tests/printer/PprDynamic.hs b/testsuite/tests/printer/PprDynamic.hs new file mode 100644 index 0000000000..5134d8b067 --- /dev/null +++ b/testsuite/tests/printer/PprDynamic.hs @@ -0,0 +1,341 @@ +{- This is the code extracted from "A reflection on types", by Simon PJ, +Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} + +{-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, + ScopedTypeVariables, GADTs, FlexibleInstances, + UndecidableInstances, RebindableSyntax, + DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} +{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} + +module Dynamic where + +import Data.Map ( Map ) +import qualified Data.Map as Map +import Unsafe.Coerce ( unsafeCoerce ) +import Control.Monad ( (<=<) ) +import Prelude hiding ( lookup, fromInteger, replicate ) +import qualified Prelude +import qualified Data.Typeable +import qualified Data.Data +import Data.Kind + +lookupMap = Map.lookup +insertMap = Map.insert + +-- let's ignore overloaded numbers +fromInteger :: Integer -> Int +fromInteger = Prelude.fromInteger + +insertStore = undefined +schema = undefined +withTypeable = undefined +throw# = undefined + +toDynamicST = undefined +fromDynamicST = undefined + +extendStore :: Typeable a => STRef s a -> a -> Store -> Store +lookupStore :: Typeable a => STRef s a -> Store -> Maybe a + +type Key = Int +data STRef s a = STR Key +type Store = Map Key Dynamic + +extendStore (STR k) v s = insertMap k (toDynamicST v) s +lookupStore (STR k) s = case lookupMap k s of + Just d -> fromDynamicST d + Nothing -> Nothing + +toDynamicST :: Typeable a => a -> Dynamic +fromDynamicST :: Typeable a => Dynamic -> Maybe a + +eval = undefined +data Term + +data DynamicSilly = DIntSilly Int + | DBoolSilly Bool + | DCharSilly Char + | DPairSilly DynamicSilly DynamicSilly + + +toDynInt :: Int -> DynamicSilly +toDynInt = DIntSilly + +fromDynInt :: DynamicSilly -> Maybe Int +fromDynInt (DIntSilly n) = Just n +fromDynInt _ = Nothing + +toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly +toDynPair = DPairSilly + +dynFstSilly :: DynamicSilly -> Maybe DynamicSilly +dynFstSilly (DPairSilly x1 x2) = Just x1 +dynFstSilly _ = Nothing + +eval :: Term -> DynamicSilly + +eqT = undefined + +instance Typeable (->) +instance Typeable Maybe +instance Typeable Bool +instance Typeable Int +instance (Typeable a, Typeable b) => Typeable (a b) +instance Typeable (,) + +instance Eq TypeRepX + +data Dynamic where + Dyn :: TypeRep a -> a -> Dynamic + +toDynamic :: Typeable a => a -> Dynamic +toDynamic x = Dyn typeRep x + +eqTNoKind = undefined + +eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) + -- Primitive; implemented by compiler + +data a :***: b where + ReflNoKind :: a :***: a + +fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d +fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) + = case eqT ra (typeRep :: TypeRep d) of + Nothing -> Nothing + Just Refl -> Just x + +fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d + +fromDynamicMonad (Dyn ra x) + = do Refl <- eqT ra (typeRep :: TypeRep d) + return x + +cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b +cast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) +gcast x = do Refl <- eqT (typeRep :: TypeRep a) + (typeRep :: TypeRep b) + return x + +data SameKind :: k -> k -> Type +type CheckAppResult = SameKind AppResult AppResultNoKind + -- not the most thorough check +foo :: AppResult x -> AppResultNoKind x +foo (App y z) = AppNoKind y z + +splitApp :: TypeRep a -> Maybe (AppResult a) +splitApp = undefined +splitAppNoKind = undefined +splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) + -- Primitive; implemented by compiler + +data AppResultNoKind t where + AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) + +dynFstNoKind :: Dynamic -> Maybe Dynamic +dynFstNoKind (Dyn rpab x) + = do AppNoKind rpa rb <- splitAppNoKind rpab + AppNoKind rp ra <- splitAppNoKind rpa + Refl <- eqT rp (typeRep :: TypeRep (,)) + return (Dyn ra (fst x)) + +dynApply :: Dynamic -> Dynamic -> Maybe Dynamic +dynApply (Dyn rf f) (Dyn rx x) = do + App ra rt2 <- splitApp rf + App rtc rt1 <- splitApp ra + Refl <- eqT rtc (typeRep :: TypeRep (->)) + Refl <- eqT rt1 rx + return (Dyn rt2 (f x)) + +data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind + +class Typeable (a :: k) where + typeRep :: TypeRep a + +data AppResult (t :: k) where + App :: forall k1 k (a :: k1 -> k) (b :: k1). + TypeRep a -> TypeRep b -> AppResult (a b) + +dynFst :: Dynamic -> Maybe Dynamic +dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) + + = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab + -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| + + App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa + -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| + + Refl <- eqT rp (typeRep :: TypeRep (,)) + -- introduces |p ~ (,)| and |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)| + + return (Dyn ra (fst x)) + +eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) + +data (a :: k1) :~: (b :: k2) where + Refl :: forall k (a :: k). a :~: a + +castDance :: (Typeable a, Typeable b) => a -> Maybe b +castDance = castR typeRep typeRep + +withTypeable :: TypeRep a -> (Typeable a => r) -> r + +castR :: TypeRep a -> TypeRep b -> a -> Maybe b +castR ta tb = withTypeable ta (withTypeable tb castDance) + +cmpT = undefined +compareTypeRep = undefined + +data TypeRepX where + TypeRepX :: TypeRep a -> TypeRepX + +type TyMapLessTyped = Map TypeRepX Dynamic + +insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped +insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) + +lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a +lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) + +instance Ord TypeRepX where + compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 + +compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive + +data TyMap = Empty | Node Dynamic TyMap TyMap + +lookup :: TypeRep a -> TyMap -> Maybe a +lookup tr1 (Node (Dyn tr2 v) left right) = + case compareTypeRep tr1 tr2 of + LT -> lookup tr1 left + EQ -> castR tr2 tr1 v -- know this cast will succeed + GT -> lookup tr1 right +lookup tr1 Empty = Nothing + +cmpT :: TypeRep a -> TypeRep b -> OrderingT a b + -- definition is primitive + +data OrderingT a b where + LTT :: OrderingT a b + EQT :: OrderingT t t + GTT :: OrderingT a b + +data TypeRep (a :: k) where + TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) + TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) + +data TyCon = TyCon { tc_module :: Module, tc_name :: String } +data Module = Module { mod_pkg :: String, mod_name :: String } + +tcMaybe :: TyCon +tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" + , mod_name = "Data.Maybe" } + , tc_name = "Maybe" } + +rt = undefined + +delta1 :: Dynamic -> Dynamic +delta1 dn = case fromDynamic dn of + Just f -> f dn + Nothing -> dn +loop1 = delta1 (toDynamic delta1) + +data Rid = MkT (forall a. TypeRep a -> a -> a) +rt :: TypeRep Rid +delta :: forall a. TypeRep a -> a -> a +delta ra x = case (eqT ra rt) of + Just Refl -> case x of MkT y -> y rt x + Nothing -> x +loop = delta rt (MkT delta) + +throw# :: SomeException -> a + +data SomeException where + SomeException :: Exception e => e -> SomeException + +class (Typeable e, Show e) => Exception e where { } + +data Company +data Salary +incS :: Float -> Salary -> Salary +incS = undefined + +-- some impedance matching with SYB +instance Data.Data.Data Company +instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a + +mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a +mkT f x = case (cast f) of + Just g -> g x + Nothing -> x + +data Expr a +frontEnd = undefined + +data DynExp where + DE :: TypeRep a -> Expr a -> DynExp + +frontEnd :: String -> DynExp + +data TyConOld + +typeOf = undefined +eqTOld = undefined +funTcOld = undefined :: TyConOld +splitTyConApp = undefined +mkTyCon3 = undefined +boolTcOld = undefined +tupleTc = undefined +mkTyConApp = undefined +instance Eq TypeRepOld +instance Eq TyConOld + +data TypeRepOld -- Abstract + +class TypeableOld a where + typeRepOld :: proxy a -> TypeRepOld + +data DynamicOld where + DynOld :: TypeRepOld -> a -> DynamicOld + +data Proxy a = Proxy + +fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d +fromDynamicOld (DynOld trx x) + | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) + | otherwise = Nothing + +dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld +dynApplyOld (DynOld trf f) (DynOld trx x) = + case splitTyConApp trf of + (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> + Just (DynOld t2 ((unsafeCoerce f) x)) + _ -> Nothing + +data DynamicClosed where + DynClosed :: TypeRepClosed a -> a -> DynamicClosed + +data TypeRepClosed (a :: Type) where + TBool :: TypeRepClosed Bool + TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) + TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) + + +lookupPil = undefined + +lookupPil :: Typeable a => [Dynamic] -> Maybe a + +data Dyn1 = Dyn1 Int + | DynFun (Dyn1 -> Dyn1) + | DynPair (Dyn1, Dyn1) + +data TypeEnum = IntType | FloatType | BoolType | DateType | StringType +data Schema = Object [Schema] | + Field TypeEnum | + Array Schema + +schema :: Typeable a => a -> Schema diff --git a/testsuite/tests/printer/PprEmptyMostly.hs b/testsuite/tests/printer/PprEmptyMostly.hs new file mode 100644 index 0000000000..ccbade7bd4 --- /dev/null +++ b/testsuite/tests/printer/PprEmptyMostly.hs @@ -0,0 +1,14 @@ +module EmptyMostly where + { ;;; + ;;x=let{;;;;;y=2;;z=3;;;;}in y; + -- ;;;; + class Foo a where {;;;;;; + (--<>--) :: a -> a -> Int ; + infixl 5 --<>-- ; + (--<>--) _ _ = 2 ; -- empty decl at the end. +}; +-- ;;;;;;;;;;;; +-- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} +-- ;; + } +-- really trailing diff --git a/testsuite/tests/printer/PprEmptyMostlyInst.hs b/testsuite/tests/printer/PprEmptyMostlyInst.hs new file mode 100644 index 0000000000..1dbe3c1273 --- /dev/null +++ b/testsuite/tests/printer/PprEmptyMostlyInst.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module EmptyMostlyInst where + { +;;;;;;;;;;;; +; +instance Eq (Int,Integer) where {;;;;;;;;; +;;;;;;; a == b = False;;;;;;;;;;; +} + } diff --git a/testsuite/tests/printer/PprForeignDecl.hs b/testsuite/tests/printer/PprForeignDecl.hs new file mode 100644 index 0000000000..21c35029ab --- /dev/null +++ b/testsuite/tests/printer/PprForeignDecl.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Based on ghc/testsuite/tests/ffi/should_compile contents +module PprForeignDecl where + +import Foreign +import GHC.Exts +import Data.Int +import Data.Word + +-- simple functions + +foreign import ccall unsafe "a" a :: IO Int + +foreign import ccall unsafe "b" b :: Int -> IO Int + +foreign import ccall unsafe "c" + c :: Int -> Char -> Float -> Double -> IO Float + +-- simple monadic code + +d = a >>= \ x -> + b x >>= \ y -> + c y 'f' 1.0 2.0 + +-- We can't import the same function using both stdcall and ccall +-- calling conventions in the same file when compiling via C (this is a +-- restriction in the C backend caused by the need to emit a prototype +-- for stdcall functions). +foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) +foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int + +-- We can't redefine the calling conventions of certain functions (those from +-- math.h). +foreign import stdcall "my_sin" my_sin :: Double -> IO Double +foreign import stdcall "my_cos" my_cos :: Double -> IO Double + +foreign import stdcall "m1" m8 :: IO Int8 +foreign import stdcall "m2" m16 :: IO Int16 +foreign import stdcall "m3" m32 :: IO Int32 +foreign import stdcall "m4" m64 :: IO Int64 + +foreign import stdcall "dynamic" d8 :: FunPtr (IO Int8) -> IO Int8 +foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16 +foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 +foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 + +foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO (); + +foreign import ccall unsafe "kitchen" + sink :: Ptr a + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO () + + +type Sink2 b = Ptr b + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Word8 + -> Word16 + -> Word32 + -> Float + -> Double + -> IO () + +foreign import ccall unsafe "dynamic" + sink2 :: Ptr (Sink2 b) -> Sink2 b + +-- exports +foreign export ccall "plusInt" (+) :: Int -> Int -> Int + +listToJSArray :: ToJSRef a => [a] -> IO (JSArray a) +listToJSArray = toJSArray deconstr + where deconstr (x : xs) = Just (x, xs) + deconstr [] = Nothing + +foreign import javascript unsafe "$r = new Float32Array($1);" + float32Array :: JSArray Float -> IO Float32Array + +foreign import javascript unsafe "$r = new Int32Array($1);" + int32Array :: JSArray Int32 -> IO Int32Array + +foreign import javascript unsafe "$r = new Uint16Array($1);" + uint16Array :: JSArray Word16 -> IO Uint16Array + +foreign import javascript unsafe "$r = new Uint8Array($1);" + uint8Array :: JSArray Word8 -> IO Uint8Array + +foreign import javascript unsafe "$r = $1.getContext(\"webgl\");" + getCtx :: JSRef a -> IO Ctx diff --git a/testsuite/tests/printer/PprOverloadedLabels.hs b/testsuite/tests/printer/PprOverloadedLabels.hs new file mode 100644 index 0000000000..361da45086 --- /dev/null +++ b/testsuite/tests/printer/PprOverloadedLabels.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} + +import GHC.OverloadedLabels + +-- No instance for (OverloadedLabel "x" t0) +a = #x + +-- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) +b = #x #y + +-- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) +c :: IsLabel "x" t => t +c = #y + +main = return () diff --git a/testsuite/tests/printer/PprOverloadedRecords.hs b/testsuite/tests/printer/PprOverloadedRecords.hs new file mode 100644 index 0000000000..49d8c2041d --- /dev/null +++ b/testsuite/tests/printer/PprOverloadedRecords.hs @@ -0,0 +1,27 @@ +-- Test that DuplicateRecordFields works with NamedFieldPuns and +-- RecordWildCards + +{-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} + +data S = MkS { foo :: Int } + deriving Show +data T = MkT { foo :: Int } + deriving Show + +f MkS{foo} = MkT{foo} + +g MkT{..} = MkS{..} + +h e = let foo = 6 in e { foo } :: S + +main = do print a + print b + print c + print d + where + foo = 42 + + a = MkS{foo} + b = f a + c = g b + d = h c diff --git a/testsuite/tests/printer/PprParenFunBind.hs b/testsuite/tests/printer/PprParenFunBind.hs new file mode 100644 index 0000000000..6312cdcaee --- /dev/null +++ b/testsuite/tests/printer/PprParenFunBind.hs @@ -0,0 +1,5 @@ +module ParenFunBind where + +(foo x) y = x + y +((bar x)) y = x + y +((baz x)) (y) = x + y diff --git a/testsuite/tests/printer/PprRecordSemi.hs b/testsuite/tests/printer/PprRecordSemi.hs new file mode 100644 index 0000000000..e06c049722 --- /dev/null +++ b/testsuite/tests/printer/PprRecordSemi.hs @@ -0,0 +1,15 @@ +-- | Generate a generate statement for the builtin function "fst" +genFst :: BuiltinBuilder +genFst = genNoInsts genFst' +genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm] +genFst' res f args@[(arg,argType)] = do { + ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType + ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg] + ; let { + ; labels = getFieldLabels arg_htype 0 + ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0) + ; assign = mkUncondAssign res argexprA + } ; + -- Return the generate functions + ; return [assign] + } diff --git a/testsuite/tests/printer/PprRecursiveDo.hs b/testsuite/tests/printer/PprRecursiveDo.hs new file mode 100644 index 0000000000..174cc9ecf5 --- /dev/null +++ b/testsuite/tests/printer/PprRecursiveDo.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE RecursiveDo #-} +-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html + +import Control.Monad.Fix + +data RoseTree a = RoseTree a [RoseTree a] + deriving (Show) + +exampleTree :: RoseTree Int +exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []] + +pureMax :: Ord a => RoseTree a -> RoseTree (a, a) +pureMax tree = + let (t, largest) = go largest tree + in t + where + go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a) + go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x) + go biggest (RoseTree x xs) = + let sub = map (go biggest) xs + (xs', largests) = unzip sub + in (RoseTree (x, biggest) xs', max x (maximum largests)) + +t = pureMax exampleTree + +-- --------------------------------------------------------------------- + +impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b)) +impureMin f tree = do + rec (t, largest) <- go largest tree + return t + where + go smallest (RoseTree x []) = do + b <- f x + return (RoseTree (x, smallest) [], b) + + go smallest (RoseTree x xs) = do + sub <- mapM (go smallest) xs + b <- f x + let (xs', bs) = unzip sub + return (RoseTree (x, smallest) xs', min b (minimum bs)) + +budget :: String -> IO Int +budget "Ada" = return 10 -- A struggling startup programmer +budget "Curry" = return 50 -- A big-earner in finance +budget "Dijkstra" = return 20 -- Teaching is the real reward +budget "Howard" = return 5 -- An frugile undergraduate! + +inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" [] + , RoseTree "Curry" [ RoseTree "Howard" []] + ] + +ti = impureMin budget inviteTree + +simplemdo = mdo + return 5 diff --git a/testsuite/tests/printer/PprRoles.hs b/testsuite/tests/printer/PprRoles.hs new file mode 100644 index 0000000000..abdc222868 --- /dev/null +++ b/testsuite/tests/printer/PprRoles.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RoleAnnotations, PolyKinds #-} + +module Roles where + +data T1 a = K1 a +data T2 a = K2 a +data T3 (a :: k) = K3 +data T4 (a :: * -> *) b = K4 (a b) + +data T5 a = K5 a +data T6 a = K6 +data T7 a b = K7 b + +type role T1 nominal +type role T2 representational +type role T3 phantom +type role T4 nominal _ +type role T5 _ diff --git a/testsuite/tests/printer/PprSemis.hs b/testsuite/tests/printer/PprSemis.hs new file mode 100644 index 0000000000..9faf3c51c2 --- /dev/null +++ b/testsuite/tests/printer/PprSemis.hs @@ -0,0 +1,18 @@ +module Semis where + +-- Make sure we get all the semicolons in statements + +foo :: IO () +foo = do + do { ;;;; a } + a + +bar :: IO () +bar = do + { ; + a ;; + b + } + +baz :: IO () +baz = do { ;; s ; s ; ; s ;; } diff --git a/testsuite/tests/printer/PprT13747.hs b/testsuite/tests/printer/PprT13747.hs new file mode 100644 index 0000000000..749d8d2fc4 --- /dev/null +++ b/testsuite/tests/printer/PprT13747.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +module T13747 where + +class C a where + type family TC a :: * + +class D a where + data family TD a :: * + +instance C Int where + type instance TC Int = Int + +instance D Double where + data instance TD Double = TDDouble + +instance D Int where + newtype instance TD Int = TDInt Int + +instance D Char where + data instance TD Char where + C1 :: TD Char + C2 :: TD Char diff --git a/testsuite/tests/printer/PprThAbstractFamily.hs b/testsuite/tests/printer/PprThAbstractFamily.hs new file mode 100644 index 0000000000..a76b00b602 --- /dev/null +++ b/testsuite/tests/printer/PprThAbstractFamily.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} +module TH_abstractFamily where + +import Language.Haskell.TH + +-- Empty closed type families are okay... +ds1 :: Q [Dec] +ds1 = [d| type family F a where |] + +-- ...but abstract ones should result in a type error +ds2 :: Q [Dec] +ds2 = [d| type family G a where .. |] diff --git a/testsuite/tests/printer/PprTypeBrackets.hs b/testsuite/tests/printer/PprTypeBrackets.hs new file mode 100644 index 0000000000..eeb343d176 --- /dev/null +++ b/testsuite/tests/printer/PprTypeBrackets.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} + +foo (f :: (Maybe t -> Int)) = + undefined + +type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f +type (f `ObjectsFOver` a) = f :/\: ConstF f a + +type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a +type (c `ObjectsOver` a) = Id c `ObjectsFOver` a + +type family ((a :: Bool) || (b :: Bool)) :: Bool +type instance 'True || a = 'True +type instance a || 'True = 'True +type instance 'False || a = a +type instance a || 'False = a + +-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the +-- previously applied style. Or be a specific value. +data MaybeDefault v where + Default :: MaybeDefault v + KeepCurrent :: MaybeDefault v + SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v + SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v + +bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) +baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v + +instance Dsp (S n) where + data (ASig (S n)) = S_A CVar + data ((KSig (S n))) = S_K CVar + data (((INum (S n)))) = S_I CVar + getSr = fst <$> ask + getKsmps = snd <$> ask diff --git a/testsuite/tests/printer/PprTypeSynParens.hs b/testsuite/tests/printer/PprTypeSynParens.hs new file mode 100644 index 0000000000..b77c01de2f --- /dev/null +++ b/testsuite/tests/printer/PprTypeSynParens.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TypeFamilies #-} + +class Compilable a where + type CompileResult a :: * + +instance Compilable a => Compilable [a] where + type CompileResult [a] = [CompileResult a] + +instance Compilable a => Compilable (Maybe a) where + type CompileResult (Maybe a) = Maybe (CompileResult a) + +instance Compilable InterpreterStmt where + type CompileResult InterpreterStmt = [Hask.Stmt] + +instance Compilable ModuleSpan where + type ((CompileResult ModuleSpan)) = Hask.Module + +instance Compilable StatementSpan where + type (CompileResult StatementSpan) = [Stmt] diff --git a/testsuite/tests/printer/PprUnicodeSyntax.hs b/testsuite/tests/printer/PprUnicodeSyntax.hs new file mode 100644 index 0000000000..c40d06a5cc --- /dev/null +++ b/testsuite/tests/printer/PprUnicodeSyntax.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE UnicodeSyntax #-} + +foo x = addToEnv (∀) diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T index e936cdc64e..1de996cb9c 100644 --- a/testsuite/tests/printer/all.T +++ b/testsuite/tests/printer/all.T @@ -142,3 +142,31 @@ test('Test19834', ignore_stderr, makefile_test, ['Test19834']) test('Test19839', ignore_stderr, makefile_test, ['Test19839']) test('Test19840', ignore_stderr, makefile_test, ['Test19840']) test('Test19850', ignore_stderr, makefile_test, ['Test19850']) +test('PprCommentsOnly', ignore_stderr, makefile_test, ['PprCommentsOnly']) +test('PprSemis', ignore_stderr, makefile_test, ['PprSemis']) + +# Normal ppr does not reproduce all foreign decls, commented out +# in the Makefile for this test. +test('PprForeignDecl', ignore_stderr, makefile_test, ['PprForeignDecl']) + +test('PprRoles', ignore_stderr, makefile_test, ['PprRoles']) +test('PprTypeSynParens', ignore_stderr, makefile_test, ['PprTypeSynParens']) +test('PprEmptyMostlyInst', ignore_stderr, makefile_test, ['PprEmptyMostlyInst']) +test('PprParenFunBind', ignore_stderr, makefile_test, ['PprParenFunBind']) +test('PprRecordSemi', ignore_stderr, makefile_test, ['PprRecordSemi']) +test('PprCompleteSig', ignore_stderr, makefile_test, ['PprCompleteSig']) +test('PprOverloadedLabels', ignore_stderr, makefile_test, ['PprOverloadedLabels']) +test('PprArrows', ignore_stderr, makefile_test, ['PprArrows']) +test('PprOverloadedRecords', ignore_stderr, makefile_test, ['PprOverloadedRecords']) +test('PprArrowLambdaCase', ignore_stderr, makefile_test, ['PprArrowLambdaCase']) +test('PprRecursiveDo', ignore_stderr, makefile_test, ['PprRecursiveDo']) +test('PprTypeBrackets', ignore_stderr, makefile_test, ['PprTypeBrackets']) +test('PprDynamic', ignore_stderr, makefile_test, ['PprDynamic']) +test('PprEmptyMostly', ignore_stderr, makefile_test, ['PprEmptyMostly']) +test('PprClassParens', ignore_stderr, makefile_test, ['PprClassParens']) +test('PprThAbstractFamily', ignore_stderr, makefile_test, ['PprThAbstractFamily']) +test('PprClassTypeFamily', ignore_stderr, makefile_test, ['PprClassTypeFamily']) +test('PprT13747', ignore_stderr, makefile_test, ['PprT13747']) +test('PprBracesSemiDataDecl', ignore_stderr, makefile_test, ['PprBracesSemiDataDecl']) +test('PprUnicodeSyntax', ignore_stderr, makefile_test, ['PprUnicodeSyntax']) +test('PprCommentPlacement2', ignore_stderr, makefile_test, ['PprCommentPlacement2']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index fc45e8f9e4..e4f689bbbb 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance module ExactPrint ( @@ -74,10 +75,10 @@ xx = id defaultEPState :: EPState defaultEPState = EPState - { epPos = (1,1) - , dLHS = 1 + { epPos = (1,1) + , dLHS = 0 , pMarkLayout = False - , pLHS = 1 + , pLHS = 0 , dMarkLayout = False , dPriorEndPosition = (1,1) , uAnchorSpan = badRealSrcSpan @@ -275,9 +276,6 @@ enterAnn (Entry anchor' cs) a = do addCommentsA :: [LEpaComment] -> EPP () addCommentsA csNew = addComments (map tokComment csNew) - -- cs <- getUnallocatedComments - -- -- AZ:TODO: sortedlist? - -- putUnallocatedComments (sort $ (map tokComment csNew) ++ cs) addComments :: [Comment] -> EPP () addComments csNew = do @@ -290,6 +288,17 @@ addComments csNew = do -- --------------------------------------------------------------------- +-- | Just before we print out the EOF comments, flush the remaining +-- ones in the state. +flushComments :: EPP () +flushComments = do + cs <- getUnallocatedComments + -- Must compare without span filenames, for CPP injected comments with fake filename + let cmp (Comment _ l1 _) (Comment _ l2 _) = compare (ss2pos $ anchor l1) (ss2pos $ anchor l2) + mapM_ printOneComment (sortBy cmp cs) + +-- --------------------------------------------------------------------- + -- |In order to interleave annotations into the stream, we turn them into -- comments. annotationsToComments :: [AddEpAnn] -> [AnnKeywordId] -> EPP () @@ -308,6 +317,9 @@ annotationsToComments ans kws = do newComments <- mapM doOne kws addComments (concat newComments) +annotationsToCommentsA :: EpAnn [AddEpAnn] -> [AnnKeywordId] -> EPP () +annotationsToCommentsA EpAnnNotUsed _ = return () +annotationsToCommentsA an kws = annotationsToComments (anns an) kws -- --------------------------------------------------------------------- @@ -379,13 +391,13 @@ instance ExactPrint HsModule where debugM $ "HsModule.AnnWhere coming" setLayoutTopLevelP $ markEpAnn' an am_main AnnWhere - markAnnList' False (am_decls $ anns an) $ do - markTopLevelList imports - markTopLevelList decls + -- In the weird case of an empty file with comments, make sure + -- they print + flushComments -- --------------------------------------------------------------------- @@ -570,6 +582,11 @@ markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) where anns = filter (\(AddEpAnn ka _) -> ka == kw) (f a) +markAnnAll :: [AddEpAnn] -> AnnKeywordId -> EPP () +markAnnAll a kw = mapM_ markKw (sort anns) + where + anns = filter (\(AddEpAnn ka _) -> ka == kw) a + mark :: [AddEpAnn] -> AnnKeywordId -> EPP () mark anns kw = do case find (\(AddEpAnn k _) -> k == kw) anns of @@ -613,14 +630,12 @@ markAnnList' reallyTrail ann action = do debugM $ "markAnnList : " ++ showPprUnsafe (p, ann) mapM_ markAddEpAnn (al_open ann) unless reallyTrail $ markTrailing (al_trailing ann) -- Only makes sense for HsModule. - mark (sort $ al_rest ann) AnnSemi + markAnnAll (sort $ al_rest ann) AnnSemi action - debugM $ "markAnnList: calling markAddEpAnn on:" ++ showPprUnsafe (al_close ann) mapM_ markAddEpAnn (al_close ann) debugM $ "markAnnList: calling markTrailing with:" ++ showPprUnsafe (al_trailing ann) when reallyTrail $ markTrailing (al_trailing ann) -- normal case - -- --------------------------------------------------------------------- printComments :: RealSrcSpan -> EPP () @@ -644,18 +659,12 @@ printOneComment c@(Comment _str loc _mo) = do dp'' <- adjustDeltaForOffsetM dp mep <- getExtraDP dp' <- case mep of - Nothing -> return dp'' Just (Anchor _ (MovedAnchor edp)) -> do - -- setExtraDP Nothing debugM $ "printOneComment:edp=" ++ show edp return edp - Just (Anchor r _) -> do - pe <- getPriorEndD - let dp' = ss2delta pe r - debugM $ "printOneComment:extraDP(dp,pe,anchor loc)=" ++ showGhc (dp',pe,ss2pos r) - return dp + _ -> return dp'' LayoutStartCol dOff <- gets dLHS - debugM $ "printOneComment:(dp,dp',dOff)=" ++ showGhc (dp,dp',dOff) + debugM $ "printOneComment:(dp,dp',dp'',dOff)=" ++ showGhc (dp,dp',dp'',dOff) setPriorEndD (ss2posEnd (anchor loc)) printQueuedComment (anchor loc) c dp' @@ -885,24 +894,14 @@ instance ExactPrint (ForeignDecl GhcPs) where markAnnotated n markEpAnn an AnnDcolon markAnnotated ty - exact x = error $ "ForDecl: exact for " ++ showAst x -{- - markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do - mark GHC.AnnForeign - mark GHC.AnnImport - - markLocated cconv - unless (ll == GHC.noSrcSpan) $ markLocated safety - markExternalSourceText ls src "" - - markLocated ln - mark GHC.AnnDcolon - markLocated typ - markTrailingSemi - --} + exact (ForeignExport an n ty fexport) = do + markEpAnn an AnnForeign + markEpAnn an AnnExport + markAnnotated fexport + markAnnotated n + markEpAnn an AnnDcolon + markAnnotated ty -- --------------------------------------------------------------------- @@ -915,6 +914,23 @@ instance ExactPrint ForeignImport where -- --------------------------------------------------------------------- +instance ExactPrint ForeignExport where + getAnnotationEntry = const NoEntryVal + exact (CExport spec (L ls src)) = do + debugM $ "CExport starting" + markAnnotated spec + unless (ls == noSrcSpan) $ markExternalSourceText ls src "" + +-- --------------------------------------------------------------------- + +instance ExactPrint CExportSpec where + getAnnotationEntry = const NoEntryVal + exact (CExportStatic _st _lbl cconv) = do + debugM $ "CExportStatic starting" + markAnnotated cconv + +-- --------------------------------------------------------------------- + instance ExactPrint Safety where getAnnotationEntry = const NoEntryVal exact = withPpr @@ -1066,7 +1082,9 @@ instance ExactPrint (RoleAnnotDecl GhcPs) where markEpAnn an AnnType markEpAnn an AnnRole markAnnotated ltycon - markAnnotated roles + let markRole (L l (Just r)) = markAnnotated (L l r) + markRole (L l Nothing) = printStringAtSs l "_" + mapM_ markRole roles -- --------------------------------------------------------------------- @@ -1152,8 +1170,10 @@ exactHsFamInstLHS an thing bndrs typats fixity mb_ctxt = do mapM_ markAnnotated pats exact_pats pats = do + markAnnAll (epAnnAnns an) AnnOpenP markAnnotated thing markAnnotated pats + markAnnAll (epAnnAnns an) AnnCloseP -- --------------------------------------------------------------------- @@ -1190,6 +1210,7 @@ instance ExactPrint (ClsInstDecl GhcPs) where top_matter markEpAnn an AnnWhere markEpAnn an AnnOpenC + markEpAnnAll an id AnnSemi -- = vcat [ top_matter <+> text "where" -- , nest 2 $ pprDeclList $ -- map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ @@ -1335,7 +1356,7 @@ instance ExactPrint (RecordPatSynField GhcPs) where instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry (Match ann _ _ _) = fromAnn ann - exact match@(Match EpAnnNotUsed _ _ _) = withPpr match + -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match exact (Match an mctxt pats grhss) = do exactMatch (Match an mctxt pats grhss) @@ -1344,7 +1365,7 @@ instance ExactPrint (Match GhcPs (LocatedA (HsCmd GhcPs))) where instance ExactPrint (Match GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry (Match ann _ _ _) = fromAnn ann - exact match@(Match EpAnnNotUsed _ _ _) = withPpr match + -- exact match@(Match EpAnnNotUsed _ _ _) = withPpr match exact (Match an mctxt pats grhss) = do exactMatch (Match an mctxt pats grhss) -- -- Based on Expr.pprMatch @@ -1402,6 +1423,7 @@ exactMatch (Match an mctxt pats grhss) = do _ -> pure () case fixity of Prefix -> do + annotationsToCommentsA an [AnnOpenP,AnnCloseP] markAnnotated fun markAnnotated pats Infix -> @@ -1463,7 +1485,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc) _ -> return () - markAnnList True an $ markAnnotatedWithLayout valbinds + markAnnList False an $ markAnnotatedWithLayout valbinds exact (HsIPBinds an bs) = markAnnList True an (markLocatedAAL an al_rest AnnWhere >> markAnnotated bs) @@ -1508,26 +1530,8 @@ instance ExactPrint HsIPName where exact (HsIPName fs) = printStringAdvance ("?" ++ (unpackFS fs)) -- --------------------------------------------------------------------- - --- instance ExactPrint (HsValBindsLR GhcPs GhcPs) where --- getAnnotationEntry _ = NoEntryVal - --- exact (ValBinds sortKey binds sigs) = do --- -- printStringAdvance "ValBinds" --- setLayoutBoth $ withSortKey sortKey --- (prepareListAnnotationA (bagToList binds) --- ++ prepareListAnnotationA sigs --- ) - --- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds - --- AZ:TODO: generalise this, and the next one --- prepareListAnnotationFamilyD :: [LFamilyDecl GhcPs] -> [(RealSrcSpan,EPP ())] --- prepareListAnnotationFamilyD ls --- = map (\b -> (realSrcSpan $ getLocA b,exactFamilyDecl NotTopLevel (unLoc b))) ls - prepareListAnnotationF :: (a -> EPP ()) -> [LocatedAn an a] -> [(RealSrcSpan,EPP ())] prepareListAnnotationF f ls = map (\b -> (realSrcSpan $ getLocA b, f (unLoc b))) ls @@ -1536,10 +1540,6 @@ prepareListAnnotationA :: ExactPrint (LocatedAn an a) => [LocatedAn an a] -> [(RealSrcSpan,EPP ())] prepareListAnnotationA ls = map (\b -> (realSrcSpan $ getLocA b,markAnnotated b)) ls - --- applyListAnnotations :: [(RealSrcSpan, EPP ())] -> EPP () --- applyListAnnotations ls = withSortKey ls - withSortKey :: AnnSortKey -> [(RealSrcSpan, EPP ())] -> EPP () withSortKey annSortKey xs = do debugM $ "withSortKey:annSortKey=" ++ showAst annSortKey @@ -1650,16 +1650,15 @@ instance ExactPrint (Sig GhcPs) where markAnnotated ml markLocatedAALS an id AnnClose (Just "#-}") --- markAST _ (CompleteMatchSig _ src (L _ ns) mlns) = do --- markAnnOpen src "{-# COMPLETE" --- markListIntercalate ns --- case mlns of --- Nothing -> return () --- Just _ -> do --- mark AnnDcolon --- markMaybe mlns --- markWithString AnnClose "#-}" -- '#-}' --- markTrailingSemi + exact (CompleteMatchSig an src cs mty) = do + markAnnOpen an src "{-# COMPLETE" + markAnnotated cs + case mty of + Nothing -> return () + Just ty -> do + markEpAnn an AnnDcolon + markAnnotated ty + markLocatedAALS an id AnnClose (Just "#-}") exact x = error $ "exact Sig for:" ++ showAst x @@ -1848,7 +1847,8 @@ instance ExactPrint (HsExpr GhcPs) where printStringAtAA l "_" printStringAtAA cb "`" -- exact x@(HsRecSel{}) = withPpr x - -- exact x@(HsOverLabel ann _ _) = withPpr x + exact x@(HsOverLabel _ _) = withPpr x + exact (HsIPVar _ (HsIPName n)) = printStringAdvance ("?" ++ unpackFS n) @@ -1888,9 +1888,9 @@ instance ExactPrint (HsExpr GhcPs) where printStringAtSs ss "@" markAnnotated arg exact (OpApp _an e1 e2 e3) = do - exact e1 - exact e2 - exact e3 + markAnnotated e1 + markAnnotated e2 + markAnnotated e3 exact (NegApp an e _) = do markEpAnn an AnnMinus @@ -1903,10 +1903,14 @@ instance ExactPrint (HsExpr GhcPs) where markToken rpar debugM $ "HsPar done" - -- exact (SectionL an expr op) = do + exact (SectionL _an expr op) = do + markAnnotated expr + markAnnotated op + exact (SectionR _an op expr) = do markAnnotated op markAnnotated expr + exact (ExplicitTuple an args b) = do if b == Boxed then markEpAnn an AnnOpenP else markEpAnn an AnnOpenPH @@ -2230,8 +2234,8 @@ instance (ExactPrint body) -- --------------------------------------------------------------------- -- instance ExactPrint (HsRecUpdField GhcPs ) where -instance (ExactPrint body) - => ExactPrint (HsFieldBind (Located (AmbiguousFieldOcc GhcPs)) body) where +instance (ExactPrint (LocatedA body)) + => ExactPrint (HsFieldBind (Located (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where -- instance (ExactPrint body) -- => ExactPrint (HsFieldBind (AmbiguousFieldOcc GhcPs) body) where getAnnotationEntry x = fromAnn (hfbAnn x) @@ -2240,27 +2244,10 @@ instance (ExactPrint body) markAnnotated f if isPun then return () else markEpAnn an AnnEqual - markAnnotated arg - --- --------------------------------------------------------------------- --- instance (ExactPrint body) --- => ExactPrint (Either (HsFieldBind (Located (AmbiguousFieldOcc GhcPs)) body) --- (HsFieldBind (Located (FieldOcc GhcPs)) body)) where --- getAnnotationEntry = const NoEntryVal --- exact (Left rbinds) = markAnnotated rbinds --- exact (Right pbinds) = markAnnotated pbinds + unless ((locA $ getLoc arg) == noSrcSpan ) $ markAnnotated arg -- --------------------------------------------------------------------- --- instance (ExactPrint body) --- => ExactPrint --- (Either [LocatedA (HsFieldBind (Located (AmbiguousFieldOcc GhcPs)) body)] --- [LocatedA (HsFieldBind (Located (FieldOcc GhcPs)) body)]) where --- getAnnotationEntry = const NoEntryVal --- exact (Left rbinds) = markAnnotated rbinds --- exact (Right pbinds) = markAnnotated pbinds - --- --------------------------------------------------------------------- -instance -- (ExactPrint body) +instance (ExactPrint (HsFieldBind (Located (a GhcPs)) body), ExactPrint (HsFieldBind (Located (b GhcPs)) body)) => ExactPrint @@ -2317,14 +2304,6 @@ instance ExactPrint (HsCmd GhcPs) where getAnnotationEntry (HsCmdDo an _) = fromAnn an --- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) --- = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] --- ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) --- = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] --- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) --- = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] --- ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) --- = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] exact (HsCmdArrApp an arr arg _o isRightToLeft) = do if isRightToLeft @@ -2336,60 +2315,25 @@ instance ExactPrint (HsCmd GhcPs) where markAnnotated arg markKw (anns an) markAnnotated arr --- markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do --- -- isRightToLeft True => right-to-left (f -< arg) --- -- False => left-to-right (arg >- f) --- if isRightToLeft --- then do --- markLocated e1 --- case o of --- GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail --- GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail --- else do --- markLocated e2 --- case o of --- GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail --- GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail - --- if isRightToLeft --- then markLocated e2 --- else markLocated e1 - - exact (HsCmdArrForm an e fixity _mf [arg1,arg2]) = do + + exact (HsCmdArrForm an e fixity _mf cs) = do markLocatedMAA an al_open - case fixity of - Infix -> do + case (fixity, cs) of + (Infix, (arg1:argrest)) -> do markAnnotated arg1 markAnnotated e - markAnnotated arg2 - Prefix -> do + markAnnotated argrest + (Prefix, _) -> do markAnnotated e - markAnnotated arg1 - markAnnotated arg2 + markAnnotated cs + (Infix, []) -> error "Not possible" markLocatedMAA an al_close --- markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do --- -- The AnnOpen should be marked for a prefix usage, not for a postfix one, --- -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm - --- let isPrefixOp = case fixity of --- GHC.Infix -> False --- GHC.Prefix -> True --- when isPrefixOp $ mark GHC.AnnOpenB -- "(|" - --- -- This may be an infix operation --- applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) --- (Set.singleton InfixOp) (Set.singleton InfixOp)) --- (prepareListAnnotation [e] --- ++ prepareListAnnotation cs) --- when isPrefixOp $ mark GHC.AnnCloseB -- "|)" - --- markAST _ (GHC.HsCmdApp _ e1 e2) = do --- markLocated e1 --- markLocated e2 + + exact (HsCmdApp _an e1 e2) = do + markAnnotated e1 + markAnnotated e2 exact (HsCmdLam _ match) = markAnnotated match --- markAST l (GHC.HsCmdLam _ match) = do --- setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match exact (HsCmdPar _an lpar e rpar) = do markToken lpar @@ -2404,31 +2348,11 @@ instance ExactPrint (HsCmd GhcPs) where markEpAnnAll an hsCaseAnnsRest AnnSemi markAnnotated alts markEpAnn' an hsCaseAnnsRest AnnCloseC - -- markEpAnn an AnnCase - -- markAnnotated e1 - -- markEpAnn an AnnOf - -- markEpAnn an AnnOpenC - -- markAnnotated matches - -- markEpAnn an AnnCloseC - --- markAST l (GHC.HsCmdCase _ e1 matches) = do --- mark GHC.AnnCase --- markLocated e1 --- mark GHC.AnnOf --- markOptional GHC.AnnOpenC --- setContext (Set.singleton CaseAlt) $ do --- markMatchGroup l matches --- markOptional GHC.AnnCloseC --- markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do --- mark GHC.AnnIf --- markLocated e1 --- markOffset GHC.AnnSemi 0 --- mark GHC.AnnThen --- markLocated e2 --- markOffset GHC.AnnSemi 1 --- mark GHC.AnnElse --- markLocated e3 + exact (HsCmdLamCase an matches) = do + markEpAnn an AnnLam + markEpAnn an AnnCase + markAnnotated matches exact (HsCmdIf an _ e1 e2 e3) = do markAnnKw an aiIf AnnIf @@ -2474,10 +2398,12 @@ instance ExactPrint (HsCmd GhcPs) where -- --------------------------------------------------------------------- --- instance ExactPrint (StmtLR GhcPs GhcPs (LHsCmd GhcPs)) where -instance (ExactPrint (LocatedA body)) - => ExactPrint (StmtLR GhcPs GhcPs (LocatedA body)) where --- instance ExactPrint (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs))) where +instance ( + ExactPrint (LocatedA (body GhcPs)), + Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL, + (ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where getAnnotationEntry (LastStmt _ _ _ _) = NoEntryVal getAnnotationEntry (BindStmt an _ _) = fromAnn an getAnnotationEntry (ApplicativeStmt _ _ _) = NoEntryVal @@ -2579,10 +2505,10 @@ instance (ExactPrint (LocatedA body)) -- inContext (Set.singleton Intercalate) $ mark GHC.AnnComma -- markTrailingSemi - exact (RecStmt _ _stmts _ _ _ _ _) = do - -- TODO: implement RecStmt + exact (RecStmt an stmts _ _ _ _ _) = do debugM $ "RecStmt" - error $ "need to test RecStmt" + markLocatedAAL an al_rest AnnRec + markAnnList True an (markAnnotated stmts) -- markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do -- mark GHC.AnnRec @@ -2643,11 +2569,11 @@ instance ExactPrint (TyClDecl GhcPs) where -- There may be arbitrary parens around parts of the constructor that are -- infix. -- Turn these into comments so that they feed into the right place automatically - -- annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] + annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP] markEpAnn an AnnType -- markTyClass Nothing fixity ln tyvars - exactVanillaDeclHead an ltycon tyvars fixity Nothing + exactVanillaDeclHead ltycon tyvars fixity Nothing markEpAnn an AnnEqual markAnnotated rhs @@ -2680,7 +2606,7 @@ instance ExactPrint (TyClDecl GhcPs) where exact (DataDecl { tcdDExt = an, tcdLName = ltycon, tcdTyVars = tyvars , tcdFixity = fixity, tcdDataDefn = defn }) = - exactDataDefn an (exactVanillaDeclHead an ltycon tyvars fixity) defn + exactDataDefn an (exactVanillaDeclHead ltycon tyvars fixity) defn -- ----------------------------------- @@ -2693,13 +2619,16 @@ instance ExactPrint (TyClDecl GhcPs) where tcdDocs = _docs}) -- TODO: add a test that demonstrates tcdDocs | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part - = top_matter + = do + top_matter + markEpAnn an AnnOpenC + markEpAnn an AnnCloseC | otherwise -- Laid out = do top_matter - -- markEpAnn an AnnWhere markEpAnn an AnnOpenC + markEpAnnAll an id AnnSemi withSortKey sortKey (prepareListAnnotationA sigs ++ prepareListAnnotationA (bagToList methods) @@ -2710,71 +2639,14 @@ instance ExactPrint (TyClDecl GhcPs) where markEpAnn an AnnCloseC where top_matter = do + annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] markEpAnn an AnnClass - exactVanillaDeclHead an lclas tyvars fixity context + exactVanillaDeclHead lclas tyvars fixity context unless (null fds) $ do markEpAnn an AnnVbar markAnnotated fds markEpAnn an AnnWhere --- -- ----------------------------------- - --- markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds --- sigs meths ats atdefs docs) = do --- mark GHC.AnnClass --- markLocated ctx - --- markTyClass Nothing fixity ln tyVars - --- unless (null fds) $ do --- mark GHC.AnnVbar --- markListIntercalateWithFunLevel markLocated 2 fds --- mark GHC.AnnWhere --- markOptional GHC.AnnOpenC -- '{' --- markInside GHC.AnnSemi --- -- AZ:TODO: we end up with both the tyVars and the following body of the --- -- class defn in annSortKey for the class. This could cause problems when --- -- changing things. --- setContext (Set.singleton InClassDecl) $ --- applyListAnnotationsLayout --- (prepareListAnnotation sigs --- ++ prepareListAnnotation (GHC.bagToList meths) --- ++ prepareListAnnotation ats --- ++ prepareListAnnotation atdefs --- ++ prepareListAnnotation docs --- ) --- markOptional GHC.AnnCloseC -- '}' --- markTrailingSemi --- {- --- | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs --- tcdCtxt :: LHsContext pass, -- ^ Context... --- tcdLName :: Located (IdP pass), -- ^ Name of the class --- tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables --- tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration --- tcdFDs :: [Located (FunDep (Located (IdP pass)))], --- -- ^ Functional deps --- tcdSigs :: [LSig pass], -- ^ Methods' signatures --- tcdMeths :: LHsBinds pass, -- ^ Default methods --- tcdATs :: [LFamilyDecl pass], -- ^ Associated types; --- tcdATDefs :: [LTyFamDefltEqn pass], --- -- ^ Associated type defaults --- tcdDocs :: [LDocDecl] -- ^ Haddock docs --- } - --- -} - --- markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) --- = error "extension hit for TyClDecl" --- markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) --- = error "extension hit for TyClDecl" --- markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) --- = error "extension hit for TyClDecl" --- markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) --- = error "extension hit for TyClDecl" --- markAST _ (GHC.XTyClDecl _) --- = error "extension hit for TyClDecl" - -- exact x = error $ "exact TyClDecl for:" ++ showAst x - -- --------------------------------------------------------------------- instance ExactPrint (FunDep GhcPs) where @@ -2804,7 +2676,8 @@ instance ExactPrint (FamilyDecl GhcPs) where -- , nest 2 $ pp_eqns ] exactFlavour an info exact_top_level - exactVanillaDeclHead an ltycon tyvars fixity Nothing + annotationsToCommentsA an [AnnOpenP,AnnCloseP] + exactVanillaDeclHead ltycon tyvars fixity Nothing exact_kind case mb_inj of Nothing -> return () @@ -2816,14 +2689,19 @@ instance ExactPrint (FamilyDecl GhcPs) where markEpAnn an AnnWhere markEpAnn an AnnOpenC case mb_eqns of - Nothing -> printStringAdvance ".." + Nothing -> markEpAnn an AnnDotdot Just eqns -> markAnnotated eqns markEpAnn an AnnCloseC _ -> return () where exact_top_level = case top_level of TopLevel -> markEpAnn an AnnFamily - NotTopLevel -> return () + NotTopLevel -> do + -- It seems that in some kind of legacy + -- mode the 'family' keyword is still + -- accepted. + markEpAnn an AnnFamily + return () exact_kind = case result of NoSig _ -> return () @@ -2861,10 +2739,11 @@ exactDataDefn an exactHdr , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) = do - -- annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] + annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] if new_or_data == DataType then markEpAnn an AnnData else markEpAnn an AnnNewtype + markEpAnn an AnnInstance -- optional mapM_ markAnnotated mb_ct exactHdr context case mb_sig of @@ -2873,17 +2752,18 @@ exactDataDefn an exactHdr markEpAnn an AnnDcolon markAnnotated kind when (isGadt condecls) $ markEpAnn an AnnWhere + markEpAnn an AnnOpenC exact_condecls an condecls + markEpAnn an AnnCloseC mapM_ markAnnotated derivings return () -exactVanillaDeclHead :: EpAnn [AddEpAnn] - -> LocatedN RdrName +exactVanillaDeclHead :: LocatedN RdrName -> LHsQTyVars GhcPs -> LexicalFixity -> Maybe (LHsContext GhcPs) -> EPP () -exactVanillaDeclHead an thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do +exactVanillaDeclHead thing (HsQTvs { hsq_explicit = tyvars }) fixity context = do let exact_tyvars :: [LHsTyVarBndr () GhcPs] -> EPP () exact_tyvars (varl:varsr) @@ -2891,7 +2771,6 @@ exactVanillaDeclHead an thing (HsQTvs { hsq_explicit = tyvars }) fixity context -- = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) -- , (ppr.unLoc) (head varsr), char ')' -- , hsep (map (ppr.unLoc) (tail vaprsr))] - annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP] markAnnotated varl markAnnotated thing markAnnotated (head varsr) @@ -2900,7 +2779,6 @@ exactVanillaDeclHead an thing (HsQTvs { hsq_explicit = tyvars }) fixity context | fixity == Infix = do -- = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) -- , hsep (map (ppr.unLoc) varsr)] - annotationsToComments (epAnnAnns an) [AnnOpenP,AnnCloseP] markAnnotated varl markAnnotated thing markAnnotated varsr @@ -3046,9 +2924,9 @@ instance ExactPrint (HsType GhcPs) where then printStringAdvance "\x2605" -- Unicode star else printStringAdvance "*" exact (HsKindSig an ty k) = do - exact ty + markAnnotated ty markEpAnn an AnnDcolon - exact k + markAnnotated k exact (HsSpliceTy _ splice) = do markAnnotated splice -- exact x@(HsDocTy an _ _) = withPpr x @@ -3191,7 +3069,11 @@ instance ExactPrint (LocatedN RdrName) where exact (L (SrcSpanAnn EpAnnNotUsed l) n) = do p <- getPosP debugM $ "LocatedN RdrName:NOANN: (p,l,str)=" ++ show (p,ss2range l, showPprUnsafe n) - printStringAtSs l (showPprUnsafe n) + let str = case (showPprUnsafe n) of + -- TODO: unicode support? + "forall" -> if spanLength (realSrcSpan l) == 1 then "∀" else "forall" + s -> s + printStringAtSs l str exact (L (SrcSpanAnn (EpAnn _anchor ann _cs) _ll) n) = do case ann of NameAnn a o l c t -> do @@ -3451,19 +3333,6 @@ instance ExactPrint (LocatedP CType) where markLocatedAALS an apr_rest AnnVal (Just (toSourceTextWithSuffix stct (unpackFS ct) "")) markAnnCloseP an --- instance Annotate GHC.CType where --- markAST _ (GHC.CType src mh f) = do --- -- markWithString GHC.AnnOpen src --- markAnnOpen src "" --- case mh of --- Nothing -> return () --- Just (GHC.Header srcH _h) -> --- -- markWithString GHC.AnnHeader srcH --- markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") --- -- markWithString GHC.AnnVal (fst f) --- markSourceText (fst f) (GHC.unpackFS $ snd f) --- markWithString GHC.AnnClose "#-}" - -- --------------------------------------------------------------------- instance ExactPrint (SourceText, RuleName) where @@ -3503,6 +3372,20 @@ instance ExactPrint (LocatedL [LocatedA (IE GhcPs)]) where debugM $ "LocatedL [LIE:p=" ++ showPprUnsafe p markAnnList True ann (markAnnotated ies) +-- instance (ExactPrint (LocatedA body), (ExactPrint (Match GhcPs (LocatedA body)))) => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where +instance (ExactPrint (Match GhcPs (LocatedA body))) + => ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA body))]) where + getAnnotationEntry = entryFromLocatedA + exact (L la a) = do + debugM $ "LocatedL [LMatch" + -- TODO: markAnnList? + markEpAnnAll (ann la) al_rest AnnWhere + markLocatedMAA (ann la) al_open + markEpAnnAll (ann la) al_rest AnnSemi + markAnnotated a + markLocatedMAA (ann la) al_close + +{- -- AZ:TODO: combine with next instance instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsExpr GhcPs)))]) where getAnnotationEntry = entryFromLocatedA @@ -3525,6 +3408,7 @@ instance ExactPrint (LocatedL [LocatedA (Match GhcPs (LocatedA (HsCmd GhcPs)))]) markEpAnnAll (ann la) al_rest AnnSemi markAnnotated a markLocatedMAA (ann la) al_close +-} -- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where @@ -3697,12 +3581,6 @@ instance ExactPrint (Pat GhcPs) where markAnnotated pat markAnnKwAll an sumPatVbarsAfter AnnVbar markLocatedAAL an sumPatParens AnnClosePH - -- markPat _ (GHC.SumPat _ pat alt arity) = do - -- markWithString GHC.AnnOpen "(#" - -- replicateM_ (alt - 1) $ mark GHC.AnnVbar - -- markLocated pat - -- replicateM_ (arity - alt) $ mark GHC.AnnVbar - -- markWithString GHC.AnnClose "#)" -- | ConPat an con args) exact (ConPat an con details) = exactUserCon an con details @@ -3724,95 +3602,6 @@ instance ExactPrint (Pat GhcPs) where -- exact x = withPpr x exact x = error $ "missing match for Pat:" ++ showAst x --- instance Annotate (GHC.Pat GHC.GhcPs) where --- markAST loc typ = do --- markPat loc typ --- inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") --- where --- markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" --- markPat l (GHC.VarPat _ n) = do --- -- The parser inserts a placeholder value for a record pun rhs. This must be --- -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is --- -- resolved, particularly for pretty printing where annotations are added. --- let pun_RDR = "pun-right-hand-side" --- when (showPprUnsafe n /= pun_RDR) $ --- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) --- -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n --- markPat _ (GHC.LazyPat _ p) = do --- mark GHC.AnnTilde --- markLocated p - --- markPat _ (GHC.AsPat _ ln p) = do --- markLocated ln --- mark GHC.AnnAt --- markLocated p - --- markPat _ (GHC.ParPat _ p) = do --- mark GHC.AnnOpenP --- markLocated p --- mark GHC.AnnCloseP - --- markPat _ (GHC.BangPat _ p) = do --- mark GHC.AnnBang --- markLocated p - --- markPat _ (GHC.ListPat _ ps) = do --- mark GHC.AnnOpenS --- markListIntercalateWithFunLevel markLocated 2 ps --- mark GHC.AnnCloseS - --- markPat _ (GHC.TuplePat _ pats b) = do --- if b == GHC.Boxed then mark GHC.AnnOpenP --- else markWithString GHC.AnnOpen "(#" --- markListIntercalateWithFunLevel markLocated 2 pats --- if b == GHC.Boxed then mark GHC.AnnCloseP --- else markWithString GHC.AnnClose "#)" - --- markPat _ (GHC.SumPat _ pat alt arity) = do --- markWithString GHC.AnnOpen "(#" --- replicateM_ (alt - 1) $ mark GHC.AnnVbar --- markLocated pat --- replicateM_ (arity - alt) $ mark GHC.AnnVbar --- markWithString GHC.AnnClose "#)" - --- markPat _ (GHC.ConPatIn n dets) = do --- markHsConPatDetails n dets - --- markPat _ GHC.ConPatOut {} = --- traceM "warning: ConPatOut Introduced after renaming" - --- markPat _ (GHC.ViewPat _ e pat) = do --- markLocated e --- mark GHC.AnnRarrow --- markLocated pat - --- markPat l (GHC.SplicePat _ s) = do --- markAST l s - --- markPat l (GHC.LitPat _ lp) = markAST l lp - --- markPat _ (GHC.NPat _ ol mn _) = do --- when (isJust mn) $ mark GHC.AnnMinus --- markLocated ol - --- markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do --- markLocated ln --- markWithString GHC.AnnVal "+" -- "+" --- markLocated ol - - --- markPat _ (GHC.SigPat _ pat ty) = do --- markLocated pat --- mark GHC.AnnDcolon --- markLHsSigWcType ty - --- markPat _ GHC.CoPat {} = --- traceM "warning: CoPat introduced after renaming" - --- markPat _ (GHC.XPat (GHC.L l p)) = markPat l p --- -- markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showPprUnsafe x - - -- --------------------------------------------------------------------- instance ExactPrint (HsPatSigType GhcPs) where @@ -3977,7 +3766,7 @@ setLayoutTopLevelP k = do debugM $ "setLayoutTopLevelP entered" oldAnchorOffset <- getLayoutOffsetP modify (\a -> a { pMarkLayout = False - , pLHS = 1} ) + , pLHS = 0} ) k debugM $ "setLayoutTopLevelP:resetting" setLayoutOffsetP oldAnchorOffset @@ -4108,10 +3897,6 @@ adjustDeltaForOffsetM dp = do colOffset <- gets dLHS return (adjustDeltaForOffset 0 colOffset dp) --- adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos --- adjustDeltaForOffset _ _colOffset dp@(DP (0,_)) = dp -- same line --- adjustDeltaForOffset d (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset - d) - -- --------------------------------------------------------------------- -- Printing functions diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index b67efa2039..2034808362 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -2,22 +2,23 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -import Data.List (intercalate) import Data.Data -import GHC.Types.Name.Occurrence -import GHC.Types.Name.Reader -import GHC.Unit.Module.ModSummary -import Control.Monad.IO.Class +import Data.List (intercalate) import GHC hiding (moduleName) +import GHC.Data.Bag +import GHC.Driver.Errors.Types import GHC.Driver.Ppr -import GHC.Driver.Session -import GHC.Driver.Make import GHC.Hs.Dump -import GHC.Data.Bag +import GHC.Types.Error +import GHC.Types.Name.Occurrence +import GHC.Types.Name.Reader +import GHC.Utils.Error +import GHC.Utils.Outputable import System.Environment( getArgs ) import System.Exit import System.FilePath @@ -29,7 +30,7 @@ import ExactPrint import Transform import Parsers -import GHC.Parser.Lexer +import GHC.Parser.Lexer hiding (getMessages) import GHC.Data.FastString import GHC.Types.SrcLoc @@ -195,7 +196,9 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/printer/Test19834.hs" Nothing -- "../../testsuite/tests/printer/Test19840.hs" Nothing -- "../../testsuite/tests/printer/Test19850.hs" Nothing - "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing + -- "../../testsuite/tests/printer/PprLinearArrow.hs" Nothing + -- "../../testsuite/tests/printer/PprSemis.hs" Nothing + "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing -- cloneT does not need a test, function can be retired @@ -284,8 +287,8 @@ testOneFile _ libdir fileName mchanger = do (p,_toks) <- parseOneFile libdir fileName -- putStrLn $ "\n\ngot p" ++ showAst (take 4 $ reverse _toks) let - origAst = ppAst (pm_parsed_source p) - pped = exactPrint (pm_parsed_source p) + origAst = ppAst p + pped = exactPrint p newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName newFileChanged = dropExtension fileName <.> "changed" <.> takeExtension fileName @@ -299,7 +302,7 @@ testOneFile _ libdir fileName mchanger = do (changedSourceOk, expectedSource, changedSource) <- case mchanger of Just changer -> do - (pped', ast') <- exactprintWithChange libdir changer (pm_parsed_source p) + (pped', ast') <- exactprintWithChange libdir changer p writeBinFile changedAstFile (ppAst ast') writeBinFile newFileChanged pped' @@ -311,7 +314,7 @@ testOneFile _ libdir fileName mchanger = do (p',_) <- parseOneFile libdir newFile let newAstStr :: String - newAstStr = ppAst (pm_parsed_source p') + newAstStr = ppAst p' writeBinFile newAstFile newAstStr let origAstOk = origAst == newAstStr @@ -340,21 +343,23 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast -parseOneFile :: FilePath -> FilePath -> IO (ParsedModule, [Located Token]) -parseOneFile libdir fileName = - runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream - _ <- setSessionDynFlags dflags2 - hsc_env <- getSession - emodSum <- liftIO $ summariseFile hsc_env [] fileName Nothing Nothing - case emsModSummary <$> emodSum of - Left _err -> error "parseOneFile" - Right modSum -> do - pm <- GHC.parseModule modSum - toks <- liftIO $ getTokenStream modSum - return (pm, toks) +parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile libdir fileName = do + res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + case res of + Left m -> error (showErrorMessages m) + Right (injectedComments, _dflags, pmod) -> do + let !pmodWithComments = insertCppComments pmod injectedComments + return (pmodWithComments, []) + +showErrorMessages :: Messages GhcMessage -> String +showErrorMessages msgs = + renderWithContext defaultSDocContext + $ vcat + $ pprMsgEnvelopeBagWithLoc + $ getMessages + $ msgs -- --------------------------------------------------------------------- @@ -507,7 +512,7 @@ changeLocalDecls libdir (L l p) = do os' = setEntryDP' os (DifferentLine 2 0) let sortKey = captureOrder decls let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs) + let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 5)))) a b c dd) cs) let binds' = (HsValBinds van' (ValBinds sortKey (listToBag $ decl':oldBinds) (sig':os':oldSigs))) @@ -531,8 +536,8 @@ changeLocalDecls2 libdir (L l p) = do -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do newSpan <- uniqueSrcSpanT - let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))) - let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))) + let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3))) + let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5))) let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] []) @@ -579,7 +584,7 @@ changeWhereIn3b _libdir (L l p) = do addLocaLDecl1 :: Changer addLocaLDecl1 libdir lp = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP' (L ld decl) (DifferentLine 1 4) + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 5) doAddLocal = do (de1:d2:d3:_) <- hsDecls lp (de1'',d2') <- balanceComments de1 d2 diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index cb6af2ad94..a42bba42cd 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -15,6 +15,7 @@ module Parsers ( , withDynFlags , CppOptions(..) , defaultCppOptions + , LibDir -- * Module Parsers , parseModule @@ -45,7 +46,6 @@ module Parsers ( ) where import Preprocess -import Types import Control.Monad.RWS @@ -124,6 +124,8 @@ parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- +type LibDir = FilePath + type ParseResult a = Either GHC.ErrorMessages a type Parser a = GHC.DynFlags -> FilePath -> String @@ -159,7 +161,7 @@ parsePattern df fp = parseWith df fp GHC.parsePattern -- @ -- -- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GhcPs') -parseModule :: FilePath -> FilePath -> IO (ParseResult GHC.ParsedSource) +parseModule :: LibDir -> FilePath -> IO (ParseResult GHC.ParsedSource) parseModule libdir file = parseModuleWithCpp libdir defaultCppOptions file @@ -217,7 +219,7 @@ parseModuleEpAnnsWithCpp -> IO ( Either GHC.ErrorMessages - ([Comment], GHC.DynFlags, GHC.ParsedSource) + ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleEpAnnsWithCpp libdir cppOptions file = ghcWrapper libdir $ do dflags <- initDynFlags file @@ -239,7 +241,7 @@ parseModuleEpAnnsWithCppInternal -> m ( Either GHC.ErrorMessages - ([Comment], GHC.DynFlags, GHC.ParsedSource) + ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleEpAnnsWithCppInternal cppOptions dflags file = do let useCpp = GHC.xopt LangExt.Cpp dflags @@ -258,16 +260,40 @@ parseModuleEpAnnsWithCppInternal cppOptions dflags file = do GHC.PFailed pst -> Left (GHC.GhcPsMessage <$> GHC.getErrorMessages pst) GHC.POk _ pmod - -> Right $ (injectedComments, dflags', pmod) + -> Right $ (injectedComments, dflags', fixModuleTrailingComments pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. postParseTransform - :: Either a ([Comment], GHC.DynFlags, GHC.ParsedSource) + :: Either a ([GHC.LEpaComment], GHC.DynFlags, GHC.ParsedSource) -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = m + -- TODO:AZ perhaps inject the comments into the parsedsource here already + mkAnns (_cs, _, m) = fixModuleTrailingComments m + +fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource +fixModuleTrailingComments (GHC.L l p) = GHC.L l p' + where + an' = case GHC.hsmodAnn p of + (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs) + unused -> unused + p' = p { GHC.hsmodAnn = an' } + -- p' = error $ "fixModuleTrailingComments: an'=" ++ showAst an' + + rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments + rebalance al cs = cs' + where + cs' = case GHC.al_close al of + Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) -> + let + pc = GHC.priorComments cs + fc = GHC.getFollowingComments cs + bf (GHC.L anc _) = GHC.anchor anc > ss + (prior,f) = break bf fc + cs'' = GHC.EpaCommentsBalanced (pc <> prior) f + in cs'' + _ -> cs -- | Internal function. Initializes DynFlags value for parsing. -- diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index a085648f36..9d7e883aad 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -59,29 +59,29 @@ defaultCppOptions = CppOptions [] [] [] -- --------------------------------------------------------------------- -- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments. -stripLinePragmas :: String -> (String, [Comment]) +stripLinePragmas :: String -> (String, [GHC.LEpaComment]) stripLinePragmas = unlines' . unzip . findLines . lines where unlines' (a, b) = (unlines a, catMaybes b) -findLines :: [String] -> [(String, Maybe Comment)] +findLines :: [String] -> [(String, Maybe GHC.LEpaComment)] findLines = zipWith checkLine [1..] -checkLine :: Int -> String -> (String, Maybe Comment) +checkLine :: Int -> String -> (String, Maybe GHC.LEpaComment) checkLine line s | "{-# LINE" `isPrefixOf` s = let (pragma, res) = getPragma s size = length pragma mSrcLoc = mkSrcLoc (mkFastString "LINE") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1)) - in (res, Just $ mkComment pragma (GHC.spanAsAnchor ss)) + in (res, Just $ mkLEpaComment pragma (GHC.spanAsAnchor ss)) -- Deal with shebang/cpp directives too -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s) | "#!" `isPrefixOf` s = let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG") ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s)) in - ("",Just $ mkComment s (GHC.spanAsAnchor ss)) + ("",Just $ mkLEpaComment s (GHC.spanAsAnchor ss)) | otherwise = (s, Nothing) getPragma :: String -> (String, String) @@ -100,7 +100,7 @@ getPragma s@(x:xs) getCppTokensAsComments :: GHC.GhcMonad m => CppOptions -- ^ Preprocessor Options -> FilePath -- ^ Path to source file - -> m [Comment] + -> m [GHC.LEpaComment] getCppTokensAsComments cppOptions sourceFile = do source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1 @@ -116,12 +116,16 @@ getCppTokensAsComments cppOptions sourceFile = do let toks = GHC.addSourceToTokens startLoc source ts cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks return $ filter goodComment - $ map (tokComment . GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks + $ map (GHC.commentToAnnotation . toRealLocated . fst) cppCommentToks GHC.PFailed pst -> parseError pst -goodComment :: Comment -> Bool -goodComment (Comment "" _ _) = False -goodComment _ = True + +goodComment :: GHC.LEpaComment -> Bool +goodComment c = isGoodComment (tokComment c) + where + isGoodComment :: Comment -> Bool + isGoodComment (Comment "" _ _) = False + isGoodComment _ = True toRealLocated :: GHC.Located a -> GHC.RealLocated a diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 0e40a14d39..b9e400613f 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -383,14 +383,14 @@ getEntryDPT ast = do -- --------------------------------------------------------------------- -- |'Transform' monad version of 'getEntryDP' -setEntryDPT :: (Data a,Monad m) => LocatedA a -> DeltaPos -> TransformT m () +setEntryDPT :: (Monad m) => LocatedA a -> DeltaPos -> TransformT m () setEntryDPT ast dp = do modifyAnnsT (setEntryDP ast dp) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'transferEntryDP' -transferEntryDPT :: (Data a,Data b,Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b) +transferEntryDPT :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA b) transferEntryDPT _a b = do return b -- modifyAnnsT (transferEntryDP a b) @@ -405,7 +405,7 @@ setPrecedingLinesDeclT ld n c = -- --------------------------------------------------------------------- -- |'Transform' monad version of 'setPrecedingLines' -setPrecedingLinesT :: (Data a,Monad m) => LocatedA a -> Int -> Int -> TransformT m () +setPrecedingLinesT :: (Monad m) => LocatedA a -> Int -> Int -> TransformT m () setPrecedingLinesT ld n c = modifyAnnsT (setPrecedingLines ld n c) @@ -431,7 +431,7 @@ setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans -- --------------------------------------------------------------------- -- | Adjust the entry annotations to provide an `n` line preceding gap -setPrecedingLines :: (Data a) => LocatedA a -> Int -> Int -> Anns -> Anns +setPrecedingLines :: LocatedA a -> Int -> Int -> Anns -> Anns setPrecedingLines ast n c anne = setEntryDP ast (deltaPos n c) anne -- --------------------------------------------------------------------- @@ -489,12 +489,12 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp col = deltaColumn delta -- TODO: this adjustment by 1 happens all over the place. Generalise it edp' = if line == 0 then SameLine col - else DifferentLine line (col - 1) + else DifferentLine line col edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. -setEntryDP :: (Data a) => LocatedA a -> DeltaPos -> Anns -> Anns +setEntryDP :: LocatedA a -> DeltaPos -> Anns -> Anns setEntryDP _ast _dp anns = anns -- --------------------------------------------------------------------- @@ -534,7 +534,7 @@ transferEntryDP (L (SrcSpanAnn (EpAnn anc1 _an1 cs1) _l1) _) (L (SrcSpanAnn (EpA -- TODO: what happens if the receiving side already has comments? (L anc _:_) -> do logDataWithAnnsTr "transferEntryDP':priorComments anc=" anc - return (L (SrcSpanAnn (EpAnn (kludgeAnchor anc) an2 cs2) l2) b) + return (L (SrcSpanAnn (EpAnn anc an2 cs2) l2) b) transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 an2 cs2) l2) b) = do logTr $ "transferEntryDP': EpAnnNotUsed,EpAnn" return (L (SrcSpanAnn (EpAnn anc2' an2 cs2) l2) b) @@ -550,15 +550,6 @@ transferEntryDP' la lb = do (L l2 b) <- transferEntryDP la lb return (L l2 (pushDeclDP b (SameLine 0))) --- There is an off-by-one in DPs. I *think* it has to do wether we --- calculate the final position when applying it against the stored --- final pos or against another RealSrcSpan. Must get to the bottom --- of it and come up with a canonical DP. This function adjusts a --- "comment space" DP to a "enterAnn" space one -kludgeAnchor :: Anchor -> Anchor -kludgeAnchor a@(Anchor _ (MovedAnchor (SameLine _))) = a -kludgeAnchor (Anchor a (MovedAnchor (DifferentLine r c))) = (Anchor a (MovedAnchor (deltaPos r (c - 1)))) -kludgeAnchor a = a pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs pushDeclDP (ValD x (FunBind a b (MG c (L d ms ) e) f)) dp @@ -631,7 +622,7 @@ balanceComments first second = do -- |Once 'balanceComments' has been called to move trailing comments to a -- 'FunBind', these need to be pushed down from the top level to the last -- 'Match' if that 'Match' needs to be manipulated. -balanceCommentsFB :: (Data b,Monad m) +balanceCommentsFB :: (Monad m) => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) @@ -799,23 +790,7 @@ splitComments p (EpaCommentsBalanced cs ts) = EpaCommentsBalanced cs' ts' -- original locations. commentOrigDeltas :: [LEpaComment] -> [LEpaComment] commentOrigDeltas [] = [] -commentOrigDeltas lcs@(L _ (GHC.EpaComment _ pt):_) = go pt lcs - -- TODO:AZ: we now have deltas wrt *all* tokens, not just preceding - -- non-comment. Simplify this. - where - go :: RealSrcSpan -> [LEpaComment] -> [LEpaComment] - go _ [] = [] - go p (L (Anchor la _) (GHC.EpaComment t pp):ls) - = L (Anchor la op) (GHC.EpaComment t pp) : go p' ls - where - p' = p - (r,c) = ss2posEnd pp - op' = if r == 0 - then MovedAnchor (ss2delta (r,c+1) la) - else MovedAnchor (ss2delta (r,c) la) - op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) - then MovedAnchor (DifferentLine 1 0) - else op' +commentOrigDeltas lcs = map commentOrigDelta lcs addCommentOrigDeltas :: EpAnnComments -> EpAnnComments addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs) @@ -834,6 +809,23 @@ anchorFromLocatedA (L (SrcSpanAnn an loc) _) EpAnnNotUsed -> realSrcSpan loc (EpAnn anc _ _) -> anchor anc +-- | A GHC comment includes the span of the preceding token. Take an +-- original comment, and convert the 'Anchor to have a have a +-- `MovedAnchor` operation based on the original location, only if it +-- does not already have one. +commentOrigDelta :: LEpaComment -> LEpaComment +-- commentOrigDelta c@(L (GHC.Anchor _ (GHC.MovedAnchor _)) _) = c +commentOrigDelta (L (GHC.Anchor la _) (GHC.EpaComment t pp)) + = (L (GHC.Anchor la op) (GHC.EpaComment t pp)) + where + (r,c) = ss2posEnd pp + op' = if r == 0 + then MovedAnchor (ss2delta (r,c+1) la) + else MovedAnchor (ss2delta (r,c) la) + op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) + then MovedAnchor (DifferentLine 1 0) + else op' + -- --------------------------------------------------------------------- balanceSameLineComments :: (Monad m) @@ -1428,8 +1420,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) newWhereAnnotation ww = do newSpan <- uniqueSrcSpanT - let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)) - let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)) + let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 3)) + let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 5)) let w = case ww of WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] WithoutWhere -> [] diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index e92ce96638..5739df9dd3 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -52,8 +52,8 @@ debugEnabledFlag = False -- |Global switch to enable debug tracing in ghc-exactprint Pretty debugPEnabledFlag :: Bool -debugPEnabledFlag = True --- debugPEnabledFlag = False +-- debugPEnabledFlag = True +debugPEnabledFlag = False -- |Provide a version of trace that comes at the end of the line, so it can -- easily be commented out when debugging different things. @@ -110,7 +110,6 @@ ss2deltaStart rrs ss = ss2delta ref ss where (r,c) = ss2pos rrs ref = if r == 0 - -- then (r,c+1) then (r,c) else (r,c) @@ -237,6 +236,17 @@ isExactName = False `mkQ` isExact -- --------------------------------------------------------------------- +insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource +insertCppComments (L l p) cs = L l p' + where + ncs = EpaComments cs + an' = case GHC.hsmodAnn p of + (EpAnn a an ocs) -> EpAnn a an (ocs <> ncs) + unused -> unused + p' = p { GHC.hsmodAnn = an' } + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s @@ -250,6 +260,10 @@ ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = "" tokComment :: LEpaComment -> Comment tokComment t@(L lt _) = mkComment (normaliseCommentText $ ghcCommentText t) lt +mkLEpaComment :: String -> Anchor -> LEpaComment +-- Note: fudging the ac_prior_tok value, hope it does not cause a problem +mkLEpaComment s anc = (L anc (GHC.EpaComment (EpaLineComment s) (anchor anc))) + mkComment :: String -> Anchor -> Comment mkComment c anc = Comment c anc Nothing @@ -272,7 +286,6 @@ comment2dp = first AnnComment sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a] sortAnchorLocated = sortBy (compare `on` (anchor . getLoc)) - getAnnotationEP :: (Data a) => Located a -> Anns -> Maybe Annotation getAnnotationEP la as = Map.lookup (mkAnnKey la) as |