summaryrefslogtreecommitdiff
path: root/utils
diff options
context:
space:
mode:
Diffstat (limited to 'utils')
-rw-r--r--utils/check-exact/ExactPrint.hs52
-rw-r--r--utils/check-exact/Main.hs2
-rw-r--r--utils/check-exact/Transform.hs24
m---------utils/haddock0
4 files changed, 36 insertions, 42 deletions
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 1255d492e0..ef2e98841b 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -944,18 +944,18 @@ instance ExactPrint (ForeignDecl GhcPs) where
-- ---------------------------------------------------------------------
-instance ExactPrint ForeignImport where
+instance ExactPrint (ForeignImport GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (CImport cconv safety@(L ll _) _mh _imp (L ls src)) = do
+ exact (CImport (L ls src) cconv safety@(L ll _) _mh _imp) = do
markAnnotated cconv
unless (ll == noSrcSpan) $ markAnnotated safety
unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
-- ---------------------------------------------------------------------
-instance ExactPrint ForeignExport where
+instance ExactPrint (ForeignExport GhcPs) where
getAnnotationEntry = const NoEntryVal
- exact (CExport spec (L ls src)) = do
+ exact (CExport (L ls src) spec) = do
debugM $ "CExport starting"
markAnnotated spec
unless (ls == noSrcSpan) $ markExternalSourceText ls src ""
@@ -983,8 +983,8 @@ instance ExactPrint CCallConv where
-- ---------------------------------------------------------------------
instance ExactPrint (WarnDecls GhcPs) where
- getAnnotationEntry (Warnings an _ _) = fromAnn an
- exact (Warnings an src warns) = do
+ getAnnotationEntry (Warnings (an,_) _) = fromAnn an
+ exact (Warnings (an,src) warns) = do
markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED
markAnnotated warns
markLocatedAALS an id AnnClose (Just "#-}")
@@ -1024,8 +1024,8 @@ instance ExactPrint FastString where
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecls GhcPs) where
- getAnnotationEntry (HsRules an _ _) = fromAnn an
- exact (HsRules an src rules) = do
+ getAnnotationEntry (HsRules (an,_) _) = fromAnn an
+ exact (HsRules (an, src) rules) = do
case src of
NoSourceText -> markLocatedAALS an id AnnOpen (Just "{-# RULES")
SourceText srcTxt -> markLocatedAALS an id AnnOpen (Just srcTxt)
@@ -1036,8 +1036,8 @@ instance ExactPrint (RuleDecls GhcPs) where
-- ---------------------------------------------------------------------
instance ExactPrint (RuleDecl GhcPs) where
- getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an
- exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do
+ getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an
+ exact (HsRule (an,_) ln act mtybndrs termbndrs lhs rhs) = do
debugM "HsRule entered"
markAnnotated ln
debugM "HsRule after ln"
@@ -1309,9 +1309,9 @@ instance ExactPrint (HsBind GhcPs) where
getAnnotationEntry VarBind{} = NoEntryVal
getAnnotationEntry PatSynBind{} = NoEntryVal
- exact (FunBind _ _ matches _) = do
+ exact (FunBind _ _ matches) = do
markAnnotated matches
- exact (PatBind _ pat grhss _) = do
+ exact (PatBind _ pat grhss) = do
markAnnotated pat
markAnnotated grhss
exact (PatSynBind _ bind) = markAnnotated bind
@@ -1593,14 +1593,13 @@ instance ExactPrint (Sig GhcPs) where
getAnnotationEntry (TypeSig a _ _) = fromAnn a
getAnnotationEntry (PatSynSig a _ _) = fromAnn a
getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a
- getAnnotationEntry (IdSig {}) = NoEntryVal
getAnnotationEntry (FixSig a _) = fromAnn a
getAnnotationEntry (InlineSig a _ _) = fromAnn a
getAnnotationEntry (SpecSig a _ _ _) = fromAnn a
- getAnnotationEntry (SpecInstSig a _ _) = fromAnn a
- getAnnotationEntry (MinimalSig a _ _) = fromAnn a
- getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a
- getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a
+ getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a
+ getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a
+ getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a
+ getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a
-- instance Annotate (Sig GhcPs) where
@@ -1616,9 +1615,6 @@ instance ExactPrint (Sig GhcPs) where
| is_deflt = markLocatedAAL an asRest AnnDefault >> exactVarSig an vars ty
| otherwise = exactVarSig an vars ty
--- markAST _ (IdSig {}) =
--- traceM "warning: Introduced after renaming"
-
exact (FixSig an (FixitySig _ names (Fixity src v fdir))) = do
let fixstr = case fdir of
InfixL -> "infixl"
@@ -1650,7 +1646,7 @@ instance ExactPrint (Sig GhcPs) where
markAnnotated typs
markLocatedAALS an id AnnClose (Just "#-}")
- exact (SpecInstSig an src typ) = do
+ exact (SpecInstSig (an, src) typ) = do
markAnnOpen an src "{-# SPECIALISE"
markEpAnn an AnnInstance
markAnnotated typ
@@ -1663,7 +1659,7 @@ instance ExactPrint (Sig GhcPs) where
-- markWithString AnnClose "#-}" -- '#-}'
-- markTrailingSemi
- exact (MinimalSig an src formula) = do
+ exact (MinimalSig (an, src) formula) = do
markAnnOpen an src "{-# MINIMAL"
markAnnotated formula
markLocatedAALS an id AnnClose (Just "#-}")
@@ -1674,13 +1670,13 @@ instance ExactPrint (Sig GhcPs) where
-- markWithString AnnClose "#-}"
-- markTrailingSemi
- exact (SCCFunSig an src ln ml) = do
+ exact (SCCFunSig (an, src) ln ml) = do
markAnnOpen an src "{-# SCC"
markAnnotated ln
markAnnotated ml
markLocatedAALS an id AnnClose (Just "#-}")
- exact (CompleteMatchSig an src cs mty) = do
+ exact (CompleteMatchSig (an, src) cs mty) = do
markAnnOpen an src "{-# COMPLETE"
markAnnotated cs
case mty of
@@ -1690,8 +1686,6 @@ instance ExactPrint (Sig GhcPs) where
markAnnotated ty
markLocatedAALS an id AnnClose (Just "#-}")
- exact x = error $ "exact Sig for:" ++ showAst x
-
-- ---------------------------------------------------------------------
exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP ()
@@ -1746,9 +1740,9 @@ instance ExactPrint (DefaultDecl GhcPs) where
-- ---------------------------------------------------------------------
instance ExactPrint (AnnDecl GhcPs) where
- getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an
+ getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an
- exact (HsAnnotation an src prov e) = do
+ exact (HsAnnotation (an, src) prov e) = do
markAnnOpenP an src "{-# ANN"
case prov of
(ValueAnnProvenance n) -> markAnnotated n
@@ -2126,7 +2120,7 @@ exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n)
instance ExactPrint (HsPragE GhcPs) where
getAnnotationEntry HsPragSCC{} = NoEntryVal
- exact (HsPragSCC an st sl) = do
+ exact (HsPragSCC (an, st) sl) = do
markAnnOpenP an st "{-# SCC"
let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl)
markLocatedAALS an apr_rest AnnVal (Just txt) -- optional
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 8e79de24b3..122c63990a 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -692,7 +692,7 @@ addLocaLDecl6 libdir lp = do
[de1'',d2] <- balanceCommentsList decls0
let de1 = captureMatchLineSpacing de1''
- let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)) _)) = de1
+ let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1
let [ma1,_ma2] = ms
(de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do
diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs
index 08b335291c..3009160c89 100644
--- a/utils/check-exact/Transform.hs
+++ b/utils/check-exact/Transform.hs
@@ -263,8 +263,8 @@ captureOrder ls = AnnSortKey $ map (rs . getLocA) ls
-- ---------------------------------------------------------------------
captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs
-captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )) f)))
- = L l (ValD x (FunBind a b (MG c (L d ms')) f))
+captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms )))))
+ = L l (ValD x (FunBind a b (MG c (L d ms'))))
where
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
ms' = captureLineSpacing ms
@@ -447,8 +447,8 @@ getEntryDP anns ast =
-- ---------------------------------------------------------------------
setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs
-setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms )) f))) dp
- = L l' (ValD x (FunBind a b (MG c (L d ms')) f))
+setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp
+ = L l' (ValD x (FunBind a b (MG c (L d ms'))))
where
L l' _ = setEntryDP' decl dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
@@ -552,8 +552,8 @@ transferEntryDP' la lb = do
pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs
-pushDeclDP (ValD x (FunBind a b (MG c (L d ms )) f)) dp
- = ValD x (FunBind a b (MG c (L d' ms')) f)
+pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp
+ = ValD x (FunBind a b (MG c (L d' ms')))
where
L d' _ = setEntryDP' (L d ms) dp
ms' :: [LMatch GhcPs (LHsExpr GhcPs)]
@@ -623,7 +623,7 @@ balanceComments first second = do
-- 'Match' if that 'Match' needs to be manipulated.
balanceCommentsFB :: (Monad m)
=> LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b)
-balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)) t)) second = do
+balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do
logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf)
-- There are comments on lf. We need to
-- + Keep the prior ones here
@@ -655,7 +655,7 @@ balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)) t)) second = do
_ -> (m'',lf')
logTr $ "balanceCommentsMatch done"
-- return (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t), second')
- balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))) t)) second'
+ balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second'
balanceCommentsFB f s = balanceComments' f s
-- | Move comments on the same line as the end of the match into the
@@ -1221,7 +1221,7 @@ hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
-- idempotent.
hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
-hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb
+hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb
hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
-- -------------------------------------
@@ -1243,7 +1243,7 @@ replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc
-- idempotent.
replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs]
-> TransformT m (LHsBind GhcPs)
-replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls
+replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls
= do
logTr "replaceDecls PatBind"
-- Need to throw in a fresh where clause if the binds were empty,
@@ -1261,7 +1261,7 @@ replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls
-- modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)
binds'' <- replaceDeclsValbinds WithWhere binds newDecls
-- let binds' = L (getLoc binds) binds''
- return (L l (PatBind x a (GRHSs xr rhss binds'') b))
+ return (L l (PatBind x a (GRHSs xr rhss binds'')))
replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
@@ -1372,7 +1372,7 @@ hsDeclsGeneric t = q t
-- ---------------------------------
lhsbind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs]
- lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)) _)) = do
+ lhsbind (L _ (FunBind _ _ (MG _ (L _ matches)))) = do
dss <- mapM hsDecls matches
return (concat dss)
lhsbind p@(L _ (PatBind{})) = do
diff --git a/utils/haddock b/utils/haddock
-Subproject 8976930748c4c9ba19cede2f0f29037d1cbce5e
+Subproject 7bd04379ada2d9ff1c406d258629f8abdf617b3
View Lorry Controller Status