summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ChangeLog19
-rw-r--r--ghc-exactprint.cabal2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint.hs1
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Annotate.hs33
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Delta.hs2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Parsers.hs2
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Print.hs177
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Transform.hs938
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Types.hs44
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Utils.hs70
-rw-r--r--tests/Test.hs40
-rw-r--r--tests/Test/Common.hs2
-rw-r--r--tests/Test/Transform.hs335
-rw-r--r--tests/examples/AddHiding1.hs7
-rw-r--r--tests/examples/AddHiding1.hs.expected7
-rw-r--r--tests/examples/AddHiding2.hs5
-rw-r--r--tests/examples/AddHiding2.hs.expected5
-rw-r--r--tests/examples/AddLocalDecl4.hs3
-rw-r--r--tests/examples/AddLocalDecl4.hs.expected6
-rw-r--r--tests/examples/AddLocalDecl5.hs8
-rw-r--r--tests/examples/AddLocalDecl5.hs.expected9
-rw-r--r--tests/examples/AddLocalDecl6.hs9
-rw-r--r--tests/examples/AddLocalDecl6.hs.expected11
-rw-r--r--tests/examples/Base.hs26
-rw-r--r--tests/examples/CloneDecl1.hs10
-rw-r--r--tests/examples/CloneDecl1.hs.expected17
-rw-r--r--tests/examples/Error.hs110
-rw-r--r--tests/examples/Join.hs7
-rw-r--r--tests/examples/Lambda.hs2
-rw-r--r--tests/examples/NormaliseLayout.hs5
-rw-r--r--tests/examples/NormaliseLayout.hs.expected1
-rw-r--r--tests/examples/Rename2.hs4
-rw-r--r--tests/examples/Rename2.hs.expected4
-rw-r--r--tests/examples/RmDecl3.hs1
-rw-r--r--tests/examples/RmDecl3.hs.expected1
-rw-r--r--tests/examples/RmDecl4.hs9
-rw-r--r--tests/examples/RmDecl4.hs.expected10
-rw-r--r--tests/examples/RmDecl5.hs6
-rw-r--r--tests/examples/RmDecl5.hs.expected4
-rw-r--r--tests/examples/RmDecl6.hs11
-rw-r--r--tests/examples/RmDecl6.hs.expected8
-rw-r--r--tests/examples/RmDecl7.hs8
-rw-r--r--tests/examples/RmDecl7.hs.expected6
-rw-r--r--tests/examples/RmTypeSig2.hs7
-rw-r--r--tests/examples/RmTypeSig2.hs.expected6
-rw-r--r--tests/examples/SegFault.hs133
-rw-r--r--tests/examples/SegFault2.hs202
-rw-r--r--tests/examples/SimpleDo.hs4
-rw-r--r--tests/examples/TypeSignature.hs12
49 files changed, 1857 insertions, 492 deletions
diff --git a/ChangeLog b/ChangeLog
index 3eb4abb..946c2c3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,22 @@
+2015-09-28 v0.4.0.0
+ * Rework HasDecls so that there are only instances for which it is
+ idempotent. Provide functions for managing an LHsBind which is not
+ idempotent, and performing general transformations on an AST
+ including FunBinds.
+ * Manage LHsDecl instances so that the Annotation always attaches
+ to the wrapped item, so that they can be seamlessly used in a top
+ level (wrapped) or local (unwrapped) context.
+ * Tweak transformations based on HaRe integration.
+ * This release supports the HaRe 8.0 release, which finally works
+ with GHC 7.10.2
+ * Rename `exactPrintWithAnns` to `exactPrint`. This will possibly
+ break earlier client libraries, but is a simple rename.
+ * Bring in semanticPrintM which allows wrapper functions to be
+ provided for the generated output, for use when emitting e.g. HTML
+ marked up source.
+
2015-08-13 v0.3.1.1
- * Add missing test files to sdist
+ * Add missing test files to sdist, closes #23
2015-08-02 v0.3.1
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index 1f9ab6d..dd651bb 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -1,5 +1,5 @@
name: ghc-exactprint
-version: 0.3.1.1
+version: 0.4.0.0
synopsis: ExactPrint for GHC
description: Using the API Annotations available from GHC 7.10.2, this
library provides a means to round trip any code that can
diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs
index 5dbc67a..3c91bc6 100644
--- a/src/Language/Haskell/GHC/ExactPrint.hs
+++ b/src/Language/Haskell/GHC/ExactPrint.hs
@@ -17,7 +17,6 @@ module Language.Haskell.GHC.ExactPrint
, module Language.Haskell.GHC.ExactPrint.Transform
-- * Printing
- , exactPrintWithAnns
, exactPrint
) where
diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
index 6aac024..bfb54bd 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
@@ -26,7 +26,8 @@ module Language.Haskell.GHC.ExactPrint.Annotate
annotate
, AnnotationF(..)
, Annotated
- , Annotate(..)) where
+ , Annotate(..)
+ ) where
import Data.Maybe ( fromMaybe )
#if __GLASGOW_HASKELL__ <= 710
@@ -190,7 +191,7 @@ markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep
-- | Constructs a syntax tree which contains information about which
-- annotations are required by each element.
markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()
-markLocated a = withLocated a markAST
+markLocated ast = withLocated ast markAST
withLocated :: Data a
=> GHC.Located a
@@ -268,7 +269,7 @@ instance Annotate (GHC.HsModule GHC.RdrName) where
markMany GHC.AnnSemi -- possible leading semis
mapM_ markLocated imps
- mapM_ markLocated decs
+ mapM_ (\(GHC.L l ast) -> markAST l ast) decs
mark GHC.AnnCloseC -- Possible '}'
@@ -492,13 +493,17 @@ instance (GHC.DataId name,Annotate name)
markTrailingSemi
-- ---------------------------------------------------------------------
+
instance Annotate GHC.ModuleName where
markAST l mname =
markExternal l GHC.AnnVal (GHC.moduleNameString mname)
-instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
- => Annotate (GHC.HsDecl name) where
- markAST l decl = do
+-- ---------------------------------------------------------------------
+
+-- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => GHC.LHsDecl name -> Annotated ()
+markLHsDecl (GHC.L l decl) =
case decl of
GHC.TyClD d -> markLocated (GHC.L l d)
GHC.InstD d -> markLocated (GHC.L l d)
@@ -518,6 +523,10 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate n
GHC.QuasiQuoteD d -> markLocated (GHC.L l d)
#endif
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
+ => Annotate (GHC.HsDecl name) where
+ markAST l d = markLHsDecl (GHC.L l d)
+
-- ---------------------------------------------------------------------
instance (Annotate name)
@@ -1660,11 +1669,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate n
else markWithString GHC.AnnClose "#)"
- -- We set the layout for HsCase and HsIf even though they need not obey
- -- layout rules as when moving these expressions it's useful that they
- -- maintain "internal integrity", that is to say the subparts remain
- -- indented relative to each other.
- markAST l (GHC.HsCase e1 matches) = setLayoutFlag $ do
+ markAST l (GHC.HsCase e1 matches) = do
mark GHC.AnnCase
markLocated e1
mark GHC.AnnOf
@@ -1673,6 +1678,10 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate n
markMatchGroup l matches
mark GHC.AnnCloseC
+ -- We set the layout for HsIf even though it need not obey layout rules as
+ -- when moving these expressions it's useful that they maintain "internal
+ -- integrity", that is to say the subparts remain indented relative to each
+ -- other.
markAST _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do
mark GHC.AnnIf
markLocated e1
@@ -1831,7 +1840,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate n
markAST _ (GHC.HsBracket (GHC.DecBrL ds)) = do
markWithString GHC.AnnOpen "[d|"
mark GHC.AnnOpenC
- mapM_ markLocated ds
+ mapM_ (\(GHC.L l d) -> markAST l d) ds
mark GHC.AnnCloseC
markWithString GHC.AnnClose "|]"
-- Introduced after the renamer
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
index 33b4148..60e39b1 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -65,7 +65,7 @@ import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Lookup
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated
- , annotate, Annotate(..))
+ , annotate, Annotate(..))
import qualified GHC
import qualified SrcLoc as GHC
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
index f3f33e2..5569180 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -142,7 +142,7 @@ parsePattern df fp = parseWith df fp GHC.parsePattern
-- parseModule = parseModuleWithCpp defaultCppOptions
-- @
--
--- Note: 'GHC.ParsedSource' is a synonym for @Located (HsModule RdrName)@
+-- Note: 'GHC.ParsedSource' is a synonym for 'GHC.Located' ('GHC.HsModule' 'GHC.RdrName')
parseModule :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, (GHC.Located (GHC.HsModule GHC.RdrName))))
parseModule = parseModuleWithCpp defaultCppOptions
diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs
index 3c912fa..79d4bf1 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Print.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
@@ -13,9 +14,9 @@
-----------------------------------------------------------------------------
module Language.Haskell.GHC.ExactPrint.Print
(
- exactPrintWithAnns
-
- , exactPrint
+ exactPrint
+ , semanticPrint
+ , semanticPrintM
) where
@@ -24,7 +25,6 @@ import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Annotate
(AnnotationF(..), Annotated, Annotate(..), annotate)
import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString, unicodeString)
-import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns )
import Control.Monad.RWS
import Data.Data (Data)
@@ -33,60 +33,86 @@ import Data.Ord (comparing)
import Data.Maybe (fromMaybe)
import Control.Monad.Trans.Free
-
+import Control.Monad.Identity
import qualified GHC
------------------------------------------------------------------------------
-- Printing of source elements
--- | Print an AST exactly as specified by the annotations on the nodes in the tree.
--- The output of this function should exactly match the source file.
-exactPrint :: Annotate ast => GHC.Located ast -> GHC.ApiAnns -> String
-exactPrint ast ghcAnns = exactPrintWithAnns ast relativeAnns
- where
- relativeAnns = relativiseApiAnns ast ghcAnns
-
-- | Print an AST with a map of potential modified `Anns`. The usual way to
--- generate such a map is by calling `relativiseApiAnns`.
-exactPrintWithAnns :: Annotate ast
+-- generate such a map is by using one of the parsers in
+-- "Language.Haskell.GHC.ExactPrint.Parsers".
+exactPrint :: Annotate ast
=> GHC.Located ast
-> Anns
-> String
-exactPrintWithAnns ast an = runEP (annotate ast) an
+exactPrint = semanticPrint (\_ b -> b) id id
+
+-- | A more general version of `semanticPrint`.
+semanticPrintM :: (Annotate ast, Monoid b, Monad m) =>
+ (forall a . Data a => GHC.Located a -> b -> m b) -- ^ How to surround an AST fragment
+ -> (String -> m b) -- ^ How to output a token
+ -> (String -> m b) -- ^ How to output whitespace
+ -> GHC.Located ast
+ -> Anns
+ -> m b
+semanticPrintM astOut tokenOut whiteOut ast as = runEP astOut tokenOut whiteOut (annotate ast) as
+
+
+-- | A more general version of 'exactPrint' which allows the customisation
+-- of the output whilst retaining the original source formatting. This is
+-- useful for smarter syntax highlighting.
+semanticPrint :: (Annotate ast, Monoid b) =>
+ (forall a . Data a => GHC.Located a -> b -> b) -- ^ How to surround an AST fragment
+ -> (String -> b) -- ^ How to output a token
+ -> (String -> b) -- ^ How to output whitespace
+ -> GHC.Located ast
+ -> Anns
+ -> b
+semanticPrint a b c d e = runIdentity (semanticPrintM (\ast s -> Identity (a ast s)) (return . b) (return . c) d e)
------------------------------------------------------
-- The EP monad and basic combinators
-data EPReader = EPReader
+data EPReader m a = EPReader
{
epAnn :: !Annotation
+ , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a
+ , epTokenPrint :: String -> m a
+ , epWhitespacePrint :: String -> m a
}
-data EPWriter = EPWriter
- { output :: !(Endo String) }
+data EPWriter a = EPWriter
+ { output :: !a }
-instance Monoid EPWriter where
+instance Monoid w => Monoid (EPWriter w) where
mempty = EPWriter mempty
(EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b)
data EPState = EPState
{ epPos :: !Pos -- ^ Current output position
, epAnns :: !Anns
- , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local state with suitable refactoring?
+ , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local statE w mith suitable refactoring?
, epMarkLayout :: Bool
, epLHS :: LayoutStartCol
}
---------------------------------------------------------
-type EP a = RWS EPReader EPWriter EPState a
+type EP w m a = RWST (EPReader m w) (EPWriter w) EPState m a
+
-runEP :: Annotated () -> Anns -> String
-runEP action ans =
- flip appEndo "" . output . snd
- . (\next -> execRWS next initialEPReader (defaultEPState ans))
+
+runEP :: (Monad m, Monoid a) =>
+ (forall ast . Data ast => GHC.Located ast -> a -> m a)
+ -> (String -> m a)
+ -> (String -> m a)
+ -> Annotated () -> Anns -> m a
+runEP astPrint wsPrint tokenPrint action ans =
+ fmap (output . snd) .
+ (\next -> execRWST next (initialEPReader astPrint tokenPrint wsPrint) (defaultEPState ans))
. printInterpret $ action
-- ---------------------------------------------------------------------
@@ -100,18 +126,25 @@ defaultEPState as = EPState
, epMarkLayout = False
}
-initialEPReader :: EPReader
-initialEPReader = EPReader
+initialEPReader ::
+ (forall ast . Data ast => GHC.Located ast -> a -> m a)
+ -> (String -> m a)
+ -> (String -> m a)
+ -> EPReader m a
+initialEPReader astPrint tokenPrint wsPrint = EPReader
{
epAnn = annNone
+ , epAstPrint = astPrint
+ , epWhitespacePrint = wsPrint
+ , epTokenPrint = tokenPrint
}
-- ---------------------------------------------------------------------
-printInterpret :: Annotated a -> EP a
-printInterpret = iterTM go
+printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a
+printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m)
where
- go :: AnnotationF (EP a) -> EP a
+ go :: (Monad m, Monoid w) => AnnotationF (EP w m a) -> EP w m a
go (MarkEOF next) =
printStringAtMaybeAnn (G GHC.AnnEofPos) "" >> next
go (MarkPrim kwid mstr next) =
@@ -147,14 +180,14 @@ printInterpret = iterTM go
-------------------------------------------------------------------------
-storeOriginalSrcSpanPrint :: EP AnnKey
+storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey
storeOriginalSrcSpanPrint = do
Ann{..} <- asks epAnn
case annCapturedSpan of
Nothing -> error "Missing captured SrcSpan"
Just v -> return v
-printStoredString :: EP ()
+printStoredString :: (Monad m, Monoid w) => EP w m ()
printStoredString = do
kd <- gets epAnnKds
@@ -166,7 +199,7 @@ printStoredString = do
((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) ss
_ -> return ()
-withSortKey :: [(GHC.SrcSpan, Annotated ())] -> EP ()
+withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m ()
withSortKey xs = do
Ann{..} <- asks epAnn
let ordered = case annSortKey of
@@ -181,12 +214,12 @@ withSortKey xs = do
-------------------------------------------------------------------------
-allAnns :: GHC.AnnKeywordId -> EP ()
+allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m ()
allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString (G kwid))
-------------------------------------------------------------------------
-- |First move to the given location, then call exactP
-exactPC :: Data ast => GHC.Located ast -> EP a -> EP a
+exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a
exactPC ast action =
do
return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))
@@ -196,38 +229,49 @@ exactPC ast action =
, annFollowingComments=fcomments
, annsDP=kds
} = fromMaybe annNone ma
+ EPReader{epAstPrint} <- ask
r <- withContext kds an
(mapM_ (uncurry printQueuedComment) comments
>> advance edp
- >> action
+ >> censorM (epAstPrint ast) action
<* mapM_ (uncurry printQueuedComment) fcomments)
return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast))
-advance :: DeltaPos -> EP ()
+censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a
+censorM f m = passM (liftM (\x -> (x,f)) m)
+
+passM :: (Monoid w, Monad m) => EP w m (a, w -> m w) -> EP w m a
+passM m = RWST $ \r s -> do
+ ~((a, f),s', EPWriter w) <- runRWST m r s
+ w' <- f w
+ return (a, s', EPWriter w')
+
+advance :: (Monad m, Monoid w) => DeltaPos -> EP w m ()
advance cl = do
p <- getPos
colOffset <- getLayoutOffset
printWhitespace (undelta p cl colOffset)
-getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation)
+getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation)
getAndRemoveAnnotation a = gets ((getAnnotationEP a) . epAnns)
-markPrim :: KeywordId -> Maybe String -> EP ()
+markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m ()
markPrim kwid mstr =
let annString = fromMaybe (keywordToString kwid) mstr
in printStringAtMaybeAnn kwid annString
-withContext :: [(KeywordId, DeltaPos)]
+withContext :: (Monad m, Monoid w)
+ => [(KeywordId, DeltaPos)]
-> Annotation
- -> EP a -> EP a
-withContext kds an = withKds kds . withOffset an
+ -> EP w m a -> EP w m a
+withContext kds an x = withKds kds (withOffset an x)
-- ---------------------------------------------------------------------
--
-- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous
-- offset
--
-withOffset :: Annotation -> (EP a -> EP a)
+withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a)
withOffset a =
local (\s -> s { epAnn = a })
@@ -235,7 +279,7 @@ withOffset a =
-- ---------------------------------------------------------------------
--
-- Necessary as there are destructive gets of Kds across scopes
-withKds :: [(KeywordId, DeltaPos)] -> EP a -> EP a
+withKds :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> EP w m a -> EP w m a
withKds kd action = do
modify (\s -> s { epAnnKds = kd : epAnnKds s })
r <- action
@@ -244,7 +288,7 @@ withKds kd action = do
------------------------------------------------------------------------
-setLayout :: EP () -> EP ()
+setLayout :: (Monad m, Monoid w) => EP w m () -> EP w m ()
setLayout k = do
oldLHS <- gets epLHS
modify (\a -> a { epMarkLayout = True } )
@@ -252,27 +296,27 @@ setLayout k = do
, epLHS = oldLHS } )
k <* reset
-getPos :: EP Pos
+getPos :: (Monad m, Monoid w) => EP w m Pos
getPos = gets epPos
-setPos :: Pos -> EP ()
+setPos :: (Monad m, Monoid w) => Pos -> EP w m ()
setPos l = modify (\s -> s {epPos = l})
-- |Get the current column offset
-getLayoutOffset :: EP LayoutStartCol
+getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol
getLayoutOffset = gets epLHS
-- ---------------------------------------------------------------------
-printStringAtMaybeAnn :: KeywordId -> String -> EP ()
+printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> String -> EP w m ()
printStringAtMaybeAnn an str = printStringAtMaybeAnnThen an str (return ())
-printStringAtMaybeAnnAll :: KeywordId -> String -> EP ()
+printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> String -> EP w m ()
printStringAtMaybeAnnAll an str = go
where
go = printStringAtMaybeAnnThen an str go
-printStringAtMaybeAnnThen :: KeywordId -> String -> EP () -> EP ()
+printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> String -> EP w m () -> EP w m ()
printStringAtMaybeAnnThen an str next = do
annFinal <- getAnnFinal an
case (annFinal, an) of
@@ -295,7 +339,7 @@ printStringAtMaybeAnnThen an str next = do
-- ---------------------------------------------------------------------
-- |destructive get, hence use an annotation once only
-getAnnFinal :: KeywordId -> EP (Maybe ([(Comment, DeltaPos)], DeltaPos))
+getAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe ([(Comment, DeltaPos)], DeltaPos))
getAnnFinal kw = do
kd <- gets epAnnKds
case kd of
@@ -324,7 +368,7 @@ destructiveGetFirst key (acc, (k,v):kvs )
-- |This should be the final point where things are mode concrete,
-- before output. Hence the point where comments can be inserted
-printStringAtLsDelta :: [(Comment, DeltaPos)] -> DeltaPos -> String -> EP ()
+printStringAtLsDelta :: (Monad m, Monoid w) => [(Comment, DeltaPos)] -> DeltaPos -> String -> EP w m ()
printStringAtLsDelta cs cl s = do
p <- getPos
colOffset <- getLayoutOffset
@@ -340,7 +384,7 @@ isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool
isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset))
-- AZ:TODO: harvest the commonality between this and printStringAtLsDelta
-printQueuedComment :: Comment -> DeltaPos -> EP ()
+printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
printQueuedComment Comment{commentContents} dp = do
p <- getPos
colOffset <- getLayoutOffset
@@ -354,12 +398,12 @@ printQueuedComment Comment{commentContents} dp = do
-- ---------------------------------------------------------------------
-- |non-destructive get
-peekAnnFinal :: KeywordId -> EP (Maybe DeltaPos)
+peekAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe DeltaPos)
peekAnnFinal kw = do
(r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds)
return (snd <$> r)
-countAnnsEP :: KeywordId -> EP Int
+countAnnsEP :: (Monad m, Monoid w) => KeywordId -> EP w m Int
countAnnsEP an = length <$> peekAnnFinal an
-- ---------------------------------------------------------------------
@@ -368,32 +412,39 @@ countAnnsEP an = length <$> peekAnnFinal an
-- ---------------------------------------------------------------------
-- Printing functions
-printString :: Bool -> String -> EP ()
+printString :: (Monad m, Monoid w) => Bool -> String -> EP w m ()
printString layout str = do
EPState{epPos = (l,c), epMarkLayout} <- get
+ EPReader{epTokenPrint, epWhitespacePrint} <- ask
when (epMarkLayout && layout) (
modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ))
setPos (l, c + length str)
- tell (mempty {output = Endo $ showString str })
+ --
+ -- tell (mempty {output = Endo $ showString str })
+
+ if not layout && c == 0
+ then lift (epWhitespacePrint str) >>= \s -> tell (EPWriter { output = s})
+ else lift (epTokenPrint str) >>= \s -> tell (EPWriter { output = s})
+
-newLine :: EP ()
+newLine :: (Monad m, Monoid w) => EP w m ()
newLine = do
(l,_) <- getPos
printString False "\n"
setPos (l+1,1)
-padUntil :: Pos -> EP ()
+padUntil :: (Monad m, Monoid w) => Pos -> EP w m ()
padUntil (l,c) = do
(l1,c1) <- getPos
if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '
| l1 < l -> newLine >> padUntil (l,c)
| otherwise -> return ()
-printWhitespace :: Pos -> EP ()
+printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m ()
printWhitespace = padUntil
-printCommentAt :: Pos -> String -> EP ()
+printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()
printCommentAt p str = printWhitespace p >> printString False str
-printStringAt :: Pos -> String -> EP ()
+printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m ()
printStringAt p str = printWhitespace p >> printString True str
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
index 4a697f0..612d7b9 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-----------------------------------------------------------------------------
-- |
@@ -12,7 +14,7 @@
-- This module is currently under heavy development, and no promises are made
-- about API stability. Use with care.
--
--- We weclome any feedback / contributions on this, as it is the main point of
+-- We welcome any feedback / contributions on this, as it is the main point of
-- the library.
--
-----------------------------------------------------------------------------
@@ -20,22 +22,41 @@ module Language.Haskell.GHC.ExactPrint.Transform
(
-- * The Transform Monad
Transform
+ , TransformT(..)
, runTransform
+ , runTransformFrom
+ , runTransformFromT
-- * Transform monad operations
, logTr
+ , logDataWithAnnsTr
, getAnnsT, putAnnsT, modifyAnnsT
, uniqueSrcSpanT
- , wrapSigT,wrapDeclT
- , pushDeclAnnT
- , decl2BindT,decl2SigT
+ , cloneT
, getEntryDPT
+ , setEntryDPT
+ , transferEntryDPT
+ , setPrecedingLinesDeclT
+ , setPrecedingLinesT
, addSimpleAnnT
+ , addTrailingCommaT
+ , removeTrailingCommaT
- -- ** Managing lists, Transform monad
+ -- ** Managing declarations, in Transform monad
+ , HasTransform (..)
, HasDecls (..)
+ , hasDeclsSybTransform
+ , hsDeclsGeneric
+ , hsDeclsPatBind, hsDeclsPatBindD
+ , replaceDeclsPatBind, replaceDeclsPatBindD
+ , modifyDeclsT
+ , modifyValD
+ -- *** Utility, does not manage layout
+ , hsDeclsValBinds, replaceDeclsValbinds
+
+ -- ** Managing lists, Transform monad
, insertAtStart
, insertAtEnd
, insertAfter
@@ -53,16 +74,17 @@ module Language.Haskell.GHC.ExactPrint.Transform
-- * Operations
, isUniqueSrcSpan
-
- -- * Managing decls
- , declFun
-
-- * Pure functions
, mergeAnns
, mergeAnnList
, setPrecedingLinesDecl
, setPrecedingLines
, getEntryDP
+ , setEntryDP
+ , transferEntryDP
+ , addTrailingComma
+ , wrapSig, wrapDecl
+ , decl2Sig, decl2Bind
) where
@@ -79,9 +101,16 @@ import qualified GHC as GHC hiding (parseModule)
import qualified Data.Generics as SYB
import Data.Data
+import Data.List
+import Data.Maybe
import qualified Data.Map as Map
+import Data.Functor.Identity
+-- import Control.Monad.Identity
+import Control.Monad.State
+import Control.Monad.Writer
+
-- import Debug.Trace
------------------------------------------------------------------------------
@@ -89,29 +118,57 @@ import qualified Data.Map as Map
-- | Monad type for updating the AST and managing the annotations at the same
-- time. The W state is used to generate logging information if required.
-type Transform a = RWS () [String] (Anns,Int) a
+type Transform = TransformT Identity
+
+-- |Monad transformer version of 'Transform' monad
+newtype TransformT m a = TransformT { runTransformT :: RWST () [String] (Anns,Int) m a }
+ deriving (Monad,Applicative,Functor
+ ,MonadReader ()
+ ,MonadWriter [String]
+ ,MonadState (Anns,Int)
+ -- ,MonadTrans
+ )
+
+
-- | Run a transformation in the 'Transform' monad, returning the updated
-- annotations and any logging generated via 'logTr'
runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])
-runTransform ans f = runRWS f () (ans,0)
+runTransform ans f = runTransformFrom 0 ans f
+
+-- | Run a transformation in the 'Transform' monad, returning the updated
+-- annotations and any logging generated via 'logTr', allocating any new
+-- SrcSpans from the provided initial value.
+runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String])
+runTransformFrom seed ans f = runRWS (runTransformT f) () (ans,seed)
+
+-- |Run a monad transformer stack for the 'TransformT' monad transformer
+runTransformFromT :: (Monad m) => Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String])
+runTransformFromT seed ans f = runRWST (runTransformT f) () (ans,seed)
-- |Log a string to the output of the Monad
-logTr :: String -> Transform ()
+logTr :: (Monad m) => String -> TransformT m ()
logTr str = tell [str]
+-- |Log a representation of the given AST with annotations to the output of the
+-- Monad
+logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m ()
+logDataWithAnnsTr str ast = do
+ anns <- getAnnsT
+ logTr $ str ++ showAnnData anns 0 ast
+
-- |Access the 'Anns' being modified in this transformation
-getAnnsT :: Transform Anns
+getAnnsT :: (Monad m) => TransformT m Anns
getAnnsT = gets fst
-- |Replace the 'Anns' after any changes
-putAnnsT :: Anns -> Transform ()
+putAnnsT :: (Monad m) => Anns -> TransformT m ()
putAnnsT ans = do
(_,col) <- get
put (ans,col)
-- |Change the stored 'Anns'
-modifyAnnsT :: (Anns -> Anns) -> Transform ()
+modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m ()
modifyAnnsT f = do
ans <- getAnnsT
putAnnsT (f ans)
@@ -133,15 +190,24 @@ isUniqueSrcSpan :: GHC.SrcSpan -> Bool
isUniqueSrcSpan ss = srcSpanStartLine ss == -1
-- ---------------------------------------------------------------------
-{-
--- TODO: I suspect this may be needed in future.
-
-- |Make a copy of an AST element, replacing the existing SrcSpans with new
-- ones, and duplicating the matching annotations.
-cloneT :: GHC.Located a -> Transform (GHC.Located a)
-cloneT _ast = do
- error "Transform.cloneT undefined"
--}
+cloneT :: (Data a,Typeable a) => a -> Transform (a, [(GHC.SrcSpan, GHC.SrcSpan)])
+cloneT ast = do
+ runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast
+ where
+ replaceLocated :: forall loc a. (Typeable loc,Typeable a, Data a)
+ => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] Transform (GHC.GenLocated loc a)
+ replaceLocated (GHC.L l t) = do
+ case cast l :: Maybe GHC.SrcSpan of
+ Just ss -> do
+ newSpan <- lift uniqueSrcSpanT
+ lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) anns of
+ Nothing -> anns
+ Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns)
+ tell [(ss, newSpan)]
+ return $ fromJust . cast $ GHC.L newSpan t
+ Nothing -> return (GHC.L l t)
-- ---------------------------------------------------------------------
@@ -178,113 +244,15 @@ decl2Sig _ = []
-- ---------------------------------------------------------------------
--- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl', duplicating the 'GHC.LSig'
--- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the
--- original annotation is restored after a 'pushDeclAnnT' call.
-wrapSigT :: GHC.LSig GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)
-wrapSigT d@(GHC.L _ s) = do
- newSpan <- uniqueSrcSpanT
- let
- f ans = case Map.lookup (mkAnnKey d) ans of
- Nothing -> ans
- Just ann ->
- Map.insert (mkAnnKey (GHC.L newSpan s)) ann
- $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.SigD s))) ann ans
- modifyAnnsT f
- return (GHC.L newSpan (GHC.SigD s))
-
--- ---------------------------------------------------------------------
-
--- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl', duplicating the 'GHC.LHsBind'
--- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the
--- original annotation is restored after a 'pushDeclAnnT' call.
-wrapDeclT :: GHC.LHsBind GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)
-wrapDeclT d@(GHC.L _ s) = do
- newSpan <- uniqueSrcSpanT
- let
- f ans = case Map.lookup (mkAnnKey d) ans of
- Nothing -> ans
- Just ann ->
- Map.insert (mkAnnKey (GHC.L newSpan s )) ann
- $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.ValD s))) ann ans
- modifyAnnsT f
- return (GHC.L newSpan (GHC.ValD s))
-
--- ---------------------------------------------------------------------
-
--- |Copy the top level annotation to a new SrcSpan and the unwrapped decl. This
--- is required so that 'decl2Sig' and 'decl2Bind' will produce values that have
--- the required annotations.
-pushDeclAnnT :: GHC.LHsDecl GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)
-pushDeclAnnT ld@(GHC.L l decl) = do
- newSpan <- uniqueSrcSpanT
- let
- blend ann Nothing = ann
- blend ann (Just annd)
- = annd { annEntryDelta = annEntryDelta ann
- , annPriorComments = annPriorComments ann ++ annPriorComments annd
- , annFollowingComments = annFollowingComments annd ++ annFollowingComments ann
- }
- duplicateAnn d ans =
- case Map.lookup (mkAnnKey ld) ans of
- Nothing -> error $ "pushDeclAnnT:no key found for:" ++ show (mkAnnKey ld)
- -- Nothing -> Anns ans
- Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d))
- (blend ann (Map.lookup (mkAnnKey (GHC.L l d)) ans))
- ans
- case decl of
- GHC.TyClD d -> modifyAnnsT (duplicateAnn d)
- GHC.InstD d -> modifyAnnsT (duplicateAnn d)
- GHC.DerivD d -> modifyAnnsT (duplicateAnn d)
- GHC.ValD d -> modifyAnnsT (duplicateAnn d)
- GHC.SigD d -> modifyAnnsT (duplicateAnn d)
- GHC.DefD d -> modifyAnnsT (duplicateAnn d)
- GHC.ForD d -> modifyAnnsT (duplicateAnn d)
- GHC.WarningD d -> modifyAnnsT (duplicateAnn d)
- GHC.AnnD d -> modifyAnnsT (duplicateAnn d)
- GHC.RuleD d -> modifyAnnsT (duplicateAnn d)
- GHC.VectD d -> modifyAnnsT (duplicateAnn d)
- GHC.SpliceD d -> modifyAnnsT (duplicateAnn d)
- GHC.DocD d -> modifyAnnsT (duplicateAnn d)
- GHC.RoleAnnotD d -> modifyAnnsT (duplicateAnn d)
-#if __GLASGOW_HASKELL__ < 711
- GHC.QuasiQuoteD d -> modifyAnnsT (duplicateAnn d)
-#endif
- return (GHC.L newSpan decl)
-
--- ---------------------------------------------------------------------
-
--- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LHsBind', transferring the top
--- level annotation to a new unique 'GHC.SrcSpan' in the process.
-decl2BindT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LHsBind GHC.RdrName]
-decl2BindT vd@(GHC.L _ (GHC.ValD d)) = do
- newSpan <- uniqueSrcSpanT
- logTr $ "decl2BindT:newSpan=" ++ showGhc newSpan
- let
- duplicateAnn ans =
- case Map.lookup (mkAnnKey vd) ans of
- Nothing -> ans
- Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d)) ann ans
- modifyAnnsT duplicateAnn
- return [GHC.L newSpan d]
-decl2BindT _ = return []
-
--- ---------------------------------------------------------------------
-
--- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LSig', transferring the top
--- level annotation to a new unique 'GHC.SrcSpan' in the process.
-decl2SigT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LSig GHC.RdrName]
-decl2SigT vs@(GHC.L _ (GHC.SigD s)) = do
- newSpan <- uniqueSrcSpanT
- logTr $ "decl2SigT:newSpan=" ++ showGhc newSpan
- let
- duplicateAnn ans =
- case Map.lookup (mkAnnKey vs) ans of
- Nothing -> ans
- Just ann -> Map.insert (mkAnnKey (GHC.L newSpan s)) ann ans
- modifyAnnsT duplicateAnn
- return [GHC.L newSpan s]
-decl2SigT _ = return []
+-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl'
+wrapSig :: GHC.LSig GHC.RdrName -> GHC.LHsDecl GHC.RdrName
+wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s)
+
+-- ---------------------------------------------------------------------
+
+-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl'
+wrapDecl :: GHC.LHsBind GHC.RdrName -> GHC.LHsDecl GHC.RdrName
+wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s)
-- ---------------------------------------------------------------------
@@ -299,6 +267,20 @@ addSimpleAnnT ast dp kds = do
-- ---------------------------------------------------------------------
+-- |Add a trailing comma annotation, unless there is already one
+addTrailingCommaT :: (Data a) => GHC.Located a -> Transform ()
+addTrailingCommaT ast = do
+ modifyAnnsT (addTrailingComma ast (DP (0,0)))
+
+-- ---------------------------------------------------------------------
+
+-- |Remove a trailing comma annotation, if there is one one
+removeTrailingCommaT :: (Data a) => GHC.Located a -> Transform ()
+removeTrailingCommaT ast = do
+ modifyAnnsT (removeTrailingComma ast)
+
+-- ---------------------------------------------------------------------
+
-- |'Transform' monad version of 'getEntryDP'
getEntryDPT :: (Data a) => GHC.Located a -> Transform DeltaPos
getEntryDPT ast = do
@@ -307,6 +289,34 @@ getEntryDPT ast = do
-- ---------------------------------------------------------------------
+-- |'Transform' monad version of 'getEntryDP'
+setEntryDPT :: (Data a) => GHC.Located a -> DeltaPos -> Transform ()
+setEntryDPT ast dp = do
+ modifyAnnsT (setEntryDP ast dp)
+
+-- ---------------------------------------------------------------------
+
+-- |'Transform' monad version of 'transferEntryDP'
+transferEntryDPT :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()
+transferEntryDPT a b =
+ modifyAnnsT (transferEntryDP a b)
+
+-- ---------------------------------------------------------------------
+
+-- |'Transform' monad version of 'setPrecedingLinesDecl'
+setPrecedingLinesDeclT :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Transform ()
+setPrecedingLinesDeclT ld n c =
+ modifyAnnsT (setPrecedingLinesDecl ld n c)
+
+-- ---------------------------------------------------------------------
+
+-- |'Transform' monad version of 'setPrecedingLines'
+setPrecedingLinesT :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Transform ()
+setPrecedingLinesT ld n c =
+ modifyAnnsT (setPrecedingLines ld n c)
+
+-- ---------------------------------------------------------------------
+
-- | Left bias pair union
mergeAnns :: Anns -> Anns -> Anns
mergeAnns
@@ -320,42 +330,15 @@ mergeAnnList (x:xs) = foldr mergeAnns x xs
-- ---------------------------------------------------------------------
-- |Unwrap a HsDecl and call setPrecedingLines on it
+-- ++AZ++ TODO: get rid of this, it is a synonym only
setPrecedingLinesDecl :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Anns -> Anns
-setPrecedingLinesDecl ld n c ans =
- declFun (\a -> setPrecedingLines a n c ans') ld
- where
- ans' = Map.insert (mkAnnKey ld) annNone ans
-
-declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b
-declFun f (GHC.L l de) =
- case de of
- GHC.TyClD d -> f (GHC.L l d)
- GHC.InstD d -> f (GHC.L l d)
- GHC.DerivD d -> f (GHC.L l d)
- GHC.ValD d -> f (GHC.L l d)
- GHC.SigD d -> f (GHC.L l d)
- GHC.DefD d -> f (GHC.L l d)
- GHC.ForD d -> f (GHC.L l d)
- GHC.WarningD d -> f (GHC.L l d)
- GHC.AnnD d -> f (GHC.L l d)
- GHC.RuleD d -> f (GHC.L l d)
- GHC.VectD d -> f (GHC.L l d)
- GHC.SpliceD d -> f (GHC.L l d)
- GHC.DocD d -> f (GHC.L l d)
- GHC.RoleAnnotD d -> f (GHC.L l d)
-#if __GLASGOW_HASKELL__ < 711
- GHC.QuasiQuoteD d -> f (GHC.L l d)
-#endif
+setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans
-- ---------------------------------------------------------------------
-- | Adjust the entry annotations to provide an `n` line preceding gap
setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns
-setPrecedingLines ast n c anne =
- Map.alter go (mkAnnKey ast) anne
- where
- go Nothing = Just (annNone { annEntryDelta = DP (n, c) })
- go (Just a) = Just (a { annEntryDelta = DP (n, c) })
+setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne
-- ---------------------------------------------------------------------
@@ -369,20 +352,114 @@ getEntryDP anns ast =
-- ---------------------------------------------------------------------
+-- |Set the true entry 'DeltaPos' from the annotation for a given AST
+-- element. This is the 'DeltaPos' ignoring any comments.
+setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns
+setEntryDP ast dp anns =
+ case Map.lookup (mkAnnKey ast) anns of
+ Nothing -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns
+ Just ann -> Map.insert (mkAnnKey ast) (ann' { annEntryDelta = annCommentEntryDelta ann' dp}) anns
+ where
+ ann' = setCommentEntryDP ann dp
+
+-- ---------------------------------------------------------------------
+
+-- |When setting an entryDP, the leading comment needs to be adjusted too
+setCommentEntryDP :: Annotation -> DeltaPos -> Annotation
+-- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann'
+setCommentEntryDP ann dp = ann'
+ where
+ ann' = case (annPriorComments ann) of
+ [] -> ann
+ [(pc,_)] -> ann { annPriorComments = [(pc,dp)] }
+ ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) }
+
+-- ---------------------------------------------------------------------
+
+-- |Take the annEntryDelta associated with the first item and associate it with the second.
+-- Also transfer any comments occuring before it.
+transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns
+transferEntryDP a b anns = (const anns2) anns
+ where
+ maybeAnns = do -- Maybe monad
+ anA <- Map.lookup (mkAnnKey a) anns
+ anB <- Map.lookup (mkAnnKey b) anns
+ let anB' = Ann
+ { annEntryDelta = DP (0,0) -- Need to adjust for comments after
+ , annPriorComments = annPriorComments anB
+ , annFollowingComments = annFollowingComments anB
+ , annsDP = annsDP anB
+ , annSortKey = annSortKey anB
+ , annCapturedSpan = annCapturedSpan anB
+ }
+ return ((Map.insert (mkAnnKey b) anB' anns),annLeadingCommentEntryDelta anA)
+ (anns',dp) = fromMaybe
+ (error $ "transferEntryDP: lookup failed (a,b)=" ++ show (mkAnnKey a,mkAnnKey b))
+ maybeAnns
+ anns2 = setEntryDP b dp anns'
+
+-- ---------------------------------------------------------------------
+
+addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns
+addTrailingComma a dp anns =
+ case Map.lookup (mkAnnKey a) anns of
+ Nothing -> anns
+ Just an ->
+ case find isAnnComma (annsDP an) of
+ Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G GHC.AnnComma,dp)]}) anns
+ Just _ -> anns
+ where
+ isAnnComma (G GHC.AnnComma,_) = True
+ isAnnComma _ = False
+
+-- ---------------------------------------------------------------------
+
+removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns
+removeTrailingComma a anns =
+ case Map.lookup (mkAnnKey a) anns of
+ Nothing -> anns
+ Just an ->
+ case find isAnnComma (annsDP an) of
+ Nothing -> anns
+ Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns
+ where
+ isAnnComma (G GHC.AnnComma,_) = True
+ isAnnComma _ = False
+
+-- ---------------------------------------------------------------------
+
+-- |The relatavise phase puts all comments appearing between the end of one AST
+-- item and the beginning of the next as 'annPriorComments' for the second one.
+-- This function takes two adjacent AST items and moves any 'annPriorComments'
+-- from the second one to the 'annFollowingComments' of the first if they belong
+-- to it instead. This is typically required before deleting or duplicating
+-- either of the AST elements.
+balanceComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()
+balanceComments first second = do
+ -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM
+ -- logTr $ "balanceComments entered"
+ -- logDataWithAnnsTr "first" first
+ case cast first :: Maybe (GHC.LHsDecl GHC.RdrName) of
+ Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do
+ balanceCommentsFB (GHC.L l fb) second
+ _ -> case cast first :: Maybe (GHC.LHsBind GHC.RdrName) of
+ Just fb'@(GHC.L _ (GHC.FunBind{})) -> do
+ balanceCommentsFB fb' second
+ _ -> balanceComments' first second
+
-- |Prior to moving an AST element, make sure any trailing comments belonging to
-- it are attached to it, and not the following element. Of necessity this is a
-- heuristic process, to be tuned later. Possibly a variant should be provided
-- with a passed-in decision function.
-balanceComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()
-balanceComments first second = do
+balanceComments' :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()
+balanceComments' first second = do
let
k1 = mkAnnKey first
k2 = mkAnnKey second
moveComments p ans = ans'
where
- an1 = gfromJust "balanceComments k1" $ Map.lookup k1 ans
- an2 = gfromJust "balanceComments k2" $ Map.lookup k2 ans
- -- cs1b = annPriorComments an1
+ an1 = gfromJust "balanceComments' k1" $ Map.lookup k1 ans
+ an2 = gfromJust "balanceComments' k2" $ Map.lookup k2 ans
cs1f = annFollowingComments an1
cs2b = annPriorComments an2
(move,stay) = break p cs2b
@@ -394,13 +471,24 @@ balanceComments first second = do
modifyAnnsT (moveComments simpleBreak)
+-- |Once 'balanceComments' has been called to move trailing comments to a
+-- 'GHC.FunBind', these need to be pushed down from the top level to the last
+-- 'GHC.Match' if that 'GHC.Match' needs to be manipulated.
+balanceCommentsFB :: (Data b) => GHC.LHsBind GHC.RdrName -> GHC.Located b -> Transform ()
+balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do
+ -- logTr $ "balanceCommentsFB entered"
+ balanceComments' (last matches) second
+balanceCommentsFB f s = balanceComments' f s
+
-- ---------------------------------------------------------------------
+
-- |After moving an AST element, make sure any comments that may belong
-- with the following element in fact do. Of necessity this is a heuristic
-- process, to be tuned later. Possibly a variant should be provided with a
-- passed-in decision function.
-balanceTrailingComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform [(Comment, DeltaPos)]
+balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b
+ -> TransformT m [(Comment, DeltaPos)]
balanceTrailingComments first second = do
let
k1 = mkAnnKey first
@@ -412,16 +500,10 @@ balanceTrailingComments first second = do
cs1f = annFollowingComments an1
(move,stay) = break p cs1f
an1' = an1 { annFollowingComments = stay }
- an2' = an2 -- { annPriorComments = move ++ cs2b }
- -- an1' = an1 { annFollowingComments = [] }
- -- an2' = an2 { annPriorComments = cs1f ++ cs2b }
- ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans
- -- ans' = error $ "balanceTrailingComments:(k1,k2)=" ++ showGhc (k1,k2)
- -- ans' = error $ "balanceTrailingComments:(cs1b,cs1f,cs2b,annFollowingComments an2)=" ++ showGhc (cs1b,cs1f,cs2b,annFollowingComments an2)
+ ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans
simpleBreak (_,DP (r,_c)) = r > 0
- -- modifyAnnsT (modifyKeywordDeltas (moveComments simpleBreak))
ans <- getAnnsT
let (ans',mov) = moveComments simpleBreak ans
putAnnsT ans'
@@ -429,6 +511,7 @@ balanceTrailingComments first second = do
-- ---------------------------------------------------------------------
+-- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for
-- |Move any 'annFollowingComments' values from the 'Annotation' associated to
-- the first parameter to that of the second.
moveTrailingComments :: (Data a,Data b)
@@ -451,20 +534,21 @@ moveTrailingComments first second = do
-- ---------------------------------------------------------------------
+-- |Insert a declaration into an AST element having sub-declarations
+-- (@HasDecls@) according to the given location function.
insertAt :: (Data ast, HasDecls (GHC.Located ast))
- => (GHC.SrcSpan -> [GHC.SrcSpan] -> [GHC.SrcSpan])
+ => (GHC.LHsDecl GHC.RdrName
+ -> [GHC.LHsDecl GHC.RdrName]
+ -> [GHC.LHsDecl GHC.RdrName])
-> GHC.Located ast
-> GHC.LHsDecl GHC.RdrName
-> Transform (GHC.Located ast)
-insertAt f m decl = do
- let newKey = GHC.getLoc decl
- modKey = mkAnnKey m
- newValue a@Ann{..} = a { annSortKey = f newKey <$> annSortKey }
- oldDecls <- hsDecls m
- modifyAnnsT (Map.adjust newValue modKey)
-
- replaceDecls m (decl : oldDecls )
+insertAt f t decl = do
+ oldDecls <- hsDecls t
+ replaceDecls t (f decl oldDecls)
+-- |Insert a declaration at the beginning or end of the subdecls of the given
+-- AST item
insertAtStart, insertAtEnd :: (Data ast, HasDecls (GHC.Located ast))
=> GHC.Located ast
-> GHC.LHsDecl GHC.RdrName
@@ -473,31 +557,38 @@ insertAtStart, insertAtEnd :: (Data ast, HasDecls (GHC.Located ast))
insertAtStart = insertAt (:)
insertAtEnd = insertAt (\x xs -> xs ++ [x])
+-- |Insert a declaration at a specific location in the subdecls of the given
+-- AST item
insertAfter, insertBefore :: (Data ast, HasDecls (GHC.Located ast))
=> GHC.Located old
-> GHC.Located ast
-> GHC.LHsDecl GHC.RdrName
-> Transform (GHC.Located ast)
--- insertAfter (mkAnnKey -> k) = insertAt findAfter
insertAfter (GHC.getLoc -> k) = insertAt findAfter
where
findAfter x xs =
- let (fs, b:bs) = span (/= k) xs
+ let (fs, b:bs) = span (\(GHC.L l _) -> l /= k) xs
in fs ++ (b : x : bs)
insertBefore (GHC.getLoc -> k) = insertAt findBefore
where
findBefore x xs =
- let (fs, bs) = span (/= k) xs
+ let (fs, bs) = span (\(GHC.L l _) -> l /= k) xs
in fs ++ (x : bs)
--- ---------------------------------------------------------------------
+-- =====================================================================
+-- start of HasDecls instances
+-- =====================================================================
+-- |Provide a means to get and process the immediate child declartions of a
+-- given AST element.
class (Data t) => HasDecls t where
+-- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent
-- | Return the 'GHC.HsDecl's that are directly enclosed in the
-- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'
- -- form, even if orginating in local decls.
- hsDecls :: t -> Transform [GHC.LHsDecl GHC.RdrName]
+ -- form, even if orginating in local decls. This is safe, as annotations
+ -- never attach to the wrapper, only to the wrapped item.
+ hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GHC.RdrName]
-- | Replace the directly enclosed decl list by the given
-- decl list. Runs in the 'Transform' monad to be able to update list order
@@ -518,7 +609,7 @@ class (Data t) => HasDecls t where
-- where
-- nn = 2
-- @
- replaceDecls :: t -> [GHC.LHsDecl GHC.RdrName] -> Transform t
+ replaceDecls :: (Monad m) => t -> [GHC.LHsDecl GHC.RdrName] -> TransformT m t
-- ---------------------------------------------------------------------
@@ -526,40 +617,20 @@ instance HasDecls GHC.ParsedSource where
hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls
replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls
= do
+ logTr "replaceDecls LHsModule"
modifyAnnsT (captureOrder m decls)
return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks))
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.MatchGroup GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
- hsDecls (GHC.MG matches _ _ _) = hsDecls matches
-
- replaceDecls (GHC.MG matches a r o) newDecls
- = do
- matches' <- replaceDecls matches newDecls
- return (GHC.MG matches' a r o)
-
--- ---------------------------------------------------------------------
-
-instance HasDecls [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] where
- hsDecls ms = do
- ds <- mapM hsDecls ms
- return (concat ds)
-
- replaceDecls [] _ = error "empty match list in replaceDecls [GHC.LMatch GHC.Name]"
- replaceDecls ms newDecls
- = do
- -- ++AZ++: TODO: this one looks dodgy
- m' <- replaceDecls (ghead "replaceDecls" ms) newDecls
- return (m':tail ms)
-
--- ---------------------------------------------------------------------
-
instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
- hsDecls (GHC.L _ (GHC.Match _ _ _ grhs)) = hsDecls grhs
+ hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do
+ decls <- hsDeclsValBinds lb
+ orderedDecls d decls
replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) []
= do
+ logTr "replaceDecls LMatch"
let
noWhere (G GHC.AnnWhere,_) = False
noWhere _ = True
@@ -569,18 +640,19 @@ instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
Nothing -> error "wtf"
Just ann -> Map.insert (mkAnnKey m) ann1 mkds
where
- ann1 = ann { annsDP = filter noWhere (annsDP ann)
+ ann1 = ann { annsDP = filter noWhere (annsDP ann)
}
modifyAnnsT removeWhere
- binds' <- replaceDecls binds []
+ binds' <- replaceDeclsValbinds binds []
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds
= do
+ logTr "replaceDecls LMatch"
-- Need to throw in a fresh where clause if the binds were empty,
-- in the annotations.
- newBinds2 <- case binds of
+ case binds of
GHC.EmptyLocalBinds -> do
let
addWhere mkds =
@@ -591,169 +663,342 @@ instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]
}
modifyAnnsT addWhere
- newBinds' <- mapM pushDeclAnnT newBinds
- modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')
- modifyAnnsT (setPrecedingLinesDecl (ghead "LMatch.replaceDecls" newBinds') 1 4)
- return newBinds'
-
- _ -> do
- -- ++AZ++ TODO: move the duplicate code out of the case statement
- newBinds' <- mapM pushDeclAnnT newBinds
- modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')
- return newBinds'
-
- binds' <- replaceDecls binds newBinds2
+ modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4)
+
+ -- only move the comment if the original where clause was empty.
+ toMove <- balanceTrailingComments m m
+ insertCommentBefore (mkAnnKey m) toMove (matchApiAnn GHC.AnnWhere)
+ _ -> return ()
+
+ modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds)
+ binds' <- replaceDeclsValbinds binds newBinds
+ -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds'
return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
- hsDecls (GHC.GRHSs _ lb) = hsDecls lb
+instance HasDecls (GHC.LHsExpr GHC.RdrName) where
+ hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do
+ ds <- hsDeclsValBinds decls
+ orderedDecls ls ds
+ hsDecls _ = return []
- replaceDecls (GHC.GRHSs rhss b) new
+ replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls
= do
- b' <- replaceDecls b new
- return (GHC.GRHSs rhss b')
+ logTr "replaceDecls HsLet"
+ modifyAnnsT (captureOrder e newDecls)
+ decls' <- replaceDeclsValbinds decls newDecls
+ return (GHC.L l (GHC.HsLet decls' ex))
+ replaceDecls (GHC.L l (GHC.HsPar e)) newDecls
+ = do
+ logTr "replaceDecls HsPar"
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.HsPar e'))
+ replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.HsLocalBinds GHC.RdrName) where
- hsDecls lb = case lb of
- GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do
- bds <- mapM wrapDeclT (GHC.bagToList bs)
- sds <- mapM wrapSigT sigs
- -- ++AZ++ TODO: return in annotated order
- return (bds ++ sds)
- GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"
- GHC.HsIPBinds _ -> return []
- GHC.EmptyLocalBinds -> return []
-
- replaceDecls (GHC.HsValBinds _b) new
+-- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This
+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
+-- idempotent.
+hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]
+hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d)
+hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x
+
+-- | Extract the immediate declarations for a 'GHC.PatBind'. This
+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
+-- idempotent.
+hsDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]
+hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do
+ decls <- hsDeclsValBinds lb
+ orderedDecls d decls
+hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x
+
+-- -------------------------------------
+
+-- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This
+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is
+-- idempotent.
+replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]
+ -> TransformT m (GHC.LHsDecl GHC.RdrName)
+replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do
+ (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls
+ return (GHC.L l (GHC.ValD d'))
+replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x
+
+-- | Replace the immediate declarations for a 'GHC.PatBind'. This
+-- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent
+-- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is
+-- idempotent.
+replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]
+ -> TransformT m (GHC.LHsBind GHC.RdrName)
+replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls
= do
- let decs = GHC.listToBag $ concatMap decl2Bind new
- let sigs = concatMap decl2Sig new
- return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
+ logTr "replaceDecls PatBind"
+ -- Need to throw in a fresh where clause if the binds were empty,
+ -- in the annotations.
+ case binds of
+ GHC.EmptyLocalBinds -> do
+ let
+ addWhere mkds =
+ case Map.lookup (mkAnnKey p) mkds of
+ Nothing -> error "wtf"
+ Just ann -> Map.insert (mkAnnKey p) ann1 mkds
+ where
+ ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]
+ }
+ modifyAnnsT addWhere
+ modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4)
- replaceDecls (GHC.HsIPBinds _b) _new = error "undefined replaceDecls HsIPBinds"
+ _ -> return ()
- replaceDecls (GHC.EmptyLocalBinds) new
- = do
- let newBinds = map decl2Bind new
- newSigs = map decl2Sig new
- ans <- getAnnsT
- logTr $ "replaceDecls:newBinds=" ++ showAnnData ans 0 newBinds
- let decs = GHC.listToBag $ concat newBinds
- let sigs = concat newSigs
- return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
+ modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls)
+ binds' <- replaceDeclsValbinds binds newDecls
+ return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d))
+replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.LHsExpr GHC.RdrName) where
- hsDecls (GHC.L _ (GHC.HsLet decls _ex)) = hsDecls decls
- hsDecls _ = return []
+instance HasDecls (GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
+ hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do
+ decls <- hsDeclsValBinds lb
+ orderedDecls ls decls
+ hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e
+ hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e
+ hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e
+ hsDecls _ = return []
- replaceDecls (GHC.L l (GHC.HsLet decls ex)) newDecls
+ replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls
= do
- decls' <- replaceDecls decls newDecls
- return (GHC.L l (GHC.HsLet decls' ex))
- replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old
+ modifyAnnsT (captureOrder s newDecls)
+ lb' <- replaceDeclsValbinds lb newDecls
+ return (GHC.L l (GHC.LetStmt lb'))
+ replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.LastStmt e' se))
+ replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.BindStmt pat e' a b))
+ replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls
+ = do
+ e' <- replaceDecls e newDecls
+ return (GHC.L l (GHC.BodyStmt e' a b c))
+ replaceDecls x _newDecls = return x
+
+-- =====================================================================
+-- end of HasDecls instances
+-- =====================================================================
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.LHsBinds GHC.RdrName) where
- hsDecls binds = hsDecls $ GHC.bagToList binds
- replaceDecls old _new = error $ "replaceDecls (GHC.LHsBinds name) undefined for:" ++ (showGhc old)
+-- |Do a transformation on an AST fragment by providing a function to process
+-- the general case and one specific for a 'GHC.LHsBind'. This is required
+-- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot
+-- gurantee that 'replaceDecls' after 'hsDecls' is idempotent.
+hasDeclsSybTransform :: (SYB.Data t2, SYB.Typeable t2,Monad m)
+ => (forall t. HasDecls t => t -> m t)
+ -- ^Worker function for the general case
+ -> (GHC.LHsBind GHC.RdrName -> m (GHC.LHsBind GHC.RdrName))
+ -- ^Worker function for FunBind/PatBind
+ -> t2 -- ^Item to be updated
+ -> m t2
+hasDeclsSybTransform workerHasDecls workerBind t = trf t
+ where
+ trf = SYB.mkM parsedSource
+ `SYB.extM` lmatch
+ `SYB.extM` lexpr
+ `SYB.extM` lstmt
+ `SYB.extM` lhsbind
+ `SYB.extM` lvald
--- ---------------------------------------------------------------------
+ parsedSource (p::GHC.ParsedSource) = workerHasDecls p
-instance HasDecls [GHC.LHsBind GHC.RdrName] where
- hsDecls bs = mapM wrapDeclT bs
+ lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
+ = workerHasDecls lm
- replaceDecls _bs newDecls
- = do
- return $ concatMap decl2Bind newDecls
+ lexpr (le::GHC.LHsExpr GHC.RdrName)
+ = workerHasDecls le
+
+ lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName))
+ = workerHasDecls d
+
+ lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GHC.RdrName)
+ = workerBind b
+ lhsbind b@(GHC.L _ GHC.PatBind{})
+ = workerBind b
+ lhsbind x = return x
+
+ lvald (GHC.L l (GHC.ValD d)) = do
+ (GHC.L _ d') <- lhsbind (GHC.L l d)
+ return (GHC.L l (GHC.ValD d'))
+ lvald x = return x
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.LHsBind GHC.RdrName) where
- hsDecls (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsDecls matches
- hsDecls (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsDecls rhs
- hsDecls (GHC.L _ (GHC.VarBind _ rhs _)) = hsDecls rhs
- hsDecls (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsDecls binds
- hsDecls (GHC.L _ (GHC.PatSynBind _)) = error "hsDecls: PatSynBind to implement"
+-- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot
+-- return anything for these as there is not meaningful 'replaceDecls' for it.
+-- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind'
+-- decls too, where they are needed for analysis only.
+hsDeclsGeneric :: (SYB.Data t,SYB.Typeable t) => t -> Transform [GHC.LHsDecl GHC.RdrName]
+hsDeclsGeneric t = q t
+ where
+ q = return []
+ `SYB.mkQ` parsedSource
+ `SYB.extQ` lmatch
+ `SYB.extQ` lexpr
+ `SYB.extQ` lstmt
+ `SYB.extQ` lhsbind
+ `SYB.extQ` lhsbindd
+ `SYB.extQ` localbinds
+ parsedSource (p::GHC.ParsedSource) = hsDecls p
- replaceDecls (GHC.L l fn@(GHC.FunBind a b (GHC.MG matches f g h) c d e)) newDecls
- = do
- matches' <- replaceDecls matches newDecls
- case matches' of
- [] -> return () -- Should be impossible
- ms -> do
- case (GHC.grhssLocalBinds $ GHC.m_grhss $ GHC.unLoc $ last matches) of
- GHC.EmptyLocalBinds -> do
- -- only move the comment if the original where clause was empty.
- toMove <- balanceTrailingComments (GHC.L l (GHC.ValD fn)) (last matches')
- insertCommentBefore (mkAnnKey $ last ms) toMove (matchApiAnn GHC.AnnWhere)
- lbs -> do
- decs <- hsDecls lbs
- balanceComments (last decs) (GHC.L l (GHC.ValD fn))
- return (GHC.L l (GHC.FunBind a b (GHC.MG matches' f g h) c d e))
-
- replaceDecls (GHC.L l (GHC.PatBind a rhs b c d)) newDecls
- = do
- rhs' <- replaceDecls rhs newDecls
- return (GHC.L l (GHC.PatBind a rhs' b c d))
- replaceDecls (GHC.L l (GHC.VarBind a rhs b)) newDecls
- = do
- rhs' <- replaceDecls rhs newDecls
- return (GHC.L l (GHC.VarBind a rhs' b))
- replaceDecls (GHC.L l (GHC.AbsBinds a b c d binds)) newDecls
- = do
- binds' <- replaceDecls binds newDecls
- return (GHC.L l (GHC.AbsBinds a b c d binds'))
- replaceDecls (GHC.L _ (GHC.PatSynBind _)) _ = error "replaceDecls: PatSynBind to implement"
+ lmatch (lm::GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls lm
+
+ lexpr (le::GHC.LHsExpr GHC.RdrName) = hsDecls le
+
+ lstmt (d::GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = hsDecls d
+
+ -- ---------------------------------
+
+ lhsbind :: GHC.LHsBind GHC.RdrName -> Transform [GHC.LHsDecl GHC.RdrName]
+ lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do
+ dss <- mapM hsDecls matches
+ return (concat dss)
+ lhsbind p@(GHC.L _ (GHC.PatBind{})) = do
+ hsDeclsPatBind p
+ lhsbind _ = return []
+
+ -- ---------------------------------
+
+ lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d)
+ lhsbindd _ = return []
+
+ -- ---------------------------------
+
+ localbinds :: GHC.HsLocalBinds GHC.RdrName -> Transform [GHC.LHsDecl GHC.RdrName]
+ localbinds d = hsDeclsValBinds d
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
- hsDecls (GHC.LetStmt lb) = hsDecls lb
- hsDecls (GHC.LastStmt e _) = hsDecls e
- hsDecls (GHC.BindStmt _pat e _ _) = hsDecls e
- hsDecls (GHC.BodyStmt e _ _ _) = hsDecls e
- hsDecls _ = return []
+-- |Look up the annotated order and sort the decls accordingly
+orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GHC.RdrName] -> TransformT m [GHC.LHsDecl GHC.RdrName]
+orderedDecls parent decls = do
+ ans <- getAnnsT
+ case getAnnotationEP parent ans of
+ Nothing -> error $ "orderedDecls:no annotation for:" ++ showAnnData emptyAnns 0 parent
+ Just ann -> case annSortKey ann of
+ Nothing -> do
+ return decls
+ Just keys -> do
+ let ds = map (\s -> (GHC.getLoc s,s)) decls
+ ordered = orderByKey ds keys
+ return ordered
- replaceDecls (GHC.LetStmt lb) newDecls
- = do
- lb' <- replaceDecls lb newDecls
- return (GHC.LetStmt lb')
- replaceDecls (GHC.LastStmt e se) newDecls
- = do
- e' <- replaceDecls e newDecls
- return (GHC.LastStmt e' se)
- replaceDecls (GHC.BindStmt pat e a b) newDecls
+-- ---------------------------------------------------------------------
+
+-- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with
+-- care, as this does not necessarily return the declarations in order, the
+-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'
+-- context in the AST.
+hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GHC.RdrName -> TransformT m [GHC.LHsDecl GHC.RdrName]
+hsDeclsValBinds lb = case lb of
+ GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do
+ let
+ bds = map wrapDecl (GHC.bagToList bs)
+ sds = map wrapSig sigs
+ return (bds ++ sds)
+ GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"
+ GHC.HsIPBinds _ -> return []
+ GHC.EmptyLocalBinds -> return []
+
+-- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with
+-- care, as this does not manage the declaration order, the
+-- ordering should be done by the calling function from the 'GHC.HsLocalBinds'
+-- context in the AST.
+replaceDeclsValbinds :: (Monad m)
+ => GHC.HsLocalBinds GHC.RdrName -> [GHC.LHsDecl GHC.RdrName]
+ -> TransformT m (GHC.HsLocalBinds GHC.RdrName)
+replaceDeclsValbinds _ [] = do
+ return (GHC.EmptyLocalBinds)
+replaceDeclsValbinds (GHC.HsValBinds _b) new
= do
- e' <- replaceDecls e newDecls
- return (GHC.BindStmt pat e' a b)
- replaceDecls (GHC.BodyStmt e a b c) newDecls
+ logTr "replaceDecls HsLocalBinds"
+ let decs = GHC.listToBag $ concatMap decl2Bind new
+ let sigs = concatMap decl2Sig new
+ return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
+replaceDeclsValbinds (GHC.HsIPBinds _b) _new = error "undefined replaceDecls HsIPBinds"
+replaceDeclsValbinds (GHC.EmptyLocalBinds) new
= do
- e' <- replaceDecls e newDecls
- return (GHC.BodyStmt e' a b c)
- replaceDecls x newDecls = return x
+ logTr "replaceDecls HsLocalBinds"
+ let newBinds = map decl2Bind new
+ newSigs = map decl2Sig new
+ let decs = GHC.listToBag $ concat newBinds
+ let sigs = concat newSigs
+ return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))
-- ---------------------------------------------------------------------
-instance HasDecls (GHC.LHsDecl GHC.RdrName) where
- hsDecls (GHC.L l (GHC.ValD d)) = hsDecls (GHC.L l d)
- -- hsDecls (GHC.L l (GHC.SigD d)) = hsDecls (GHC.L l d)
- hsDecls _ = return []
+type Decl = GHC.LHsDecl GHC.RdrName
+type Match = GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
+
+-- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the
+-- declarations are extracted and returned after modification. For a
+-- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific
+-- 'GHC.Match' to be transformed, for when there are multiple of them.
+modifyValD :: forall m t. (HasTransform m)
+ => GHC.SrcSpan
+ -> Decl
+ -> (Match -> [Decl] -> m ([Decl], Maybe t))
+ -> m (Decl,Maybe t)
+modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f =
+ if ss == p
+ then do
+ ds <- liftT $ hsDeclsPatBindD pb
+ (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds
+ pb' <- liftT $ replaceDeclsPatBindD pb ds'
+ return (pb',r)
+ else return (pb,Nothing)
+modifyValD p ast f = do
+ (ast',r) <- runStateT (SYB.everywhereM (SYB.mkM doModLocal) ast) Nothing
+ return (ast',r)
+ where
+ doModLocal :: Match -> StateT (Maybe t) m Match
+ doModLocal (match@(GHC.L ss _) :: Match) = do
+ let
+ if ss == p
+ then do
+ ds <- lift $ liftT $ hsDecls match
+ (ds',r) <- lift $ f match ds
+ put r
+ match' <- lift $ liftT $ replaceDecls match ds'
+ return match'
+ else return match
+
+-- ---------------------------------------------------------------------
+
+-- |Used to integrate a @Transform@ into other Monad stacks
+class (Monad m) => (HasTransform m) where
+ liftT :: Transform a -> m a
+
+instance HasTransform (TransformT Identity) where
+ liftT = id
+
+-- ---------------------------------------------------------------------
- replaceDecls (GHC.L l (GHC.ValD d)) newDecls = do
- (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls
- return (GHC.L l1 (GHC.ValD d1))
- -- replaceDecls (GHC.L l (GHC.SigD d)) newDecls = do
- -- (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls
- -- return (GHC.L l1 (GHC.SigD d1))
- replaceDecls _d _ = error $ "LHsDecl.replaceDecls:not implemented"
+-- | Apply a transformation to the decls contained in @t@
+modifyDeclsT :: (HasDecls t,HasTransform m)
+ => ([GHC.LHsDecl GHC.RdrName] -> m [GHC.LHsDecl GHC.RdrName])
+ -> t -> m t
+modifyDeclsT action t = do
+ decls <- liftT $ hsDecls t
+ decls' <- action decls
+ liftT $ replaceDecls t decls'
-- ---------------------------------------------------------------------
@@ -767,8 +1012,8 @@ matchApiAnn mkw (kw,_)
-- We comments extracted from annPriorComments or annFollowingComments, which
-- need to move to just before the item identified by the predicate, if it
-- fires, else at the end of the annotations.
-insertCommentBefore :: AnnKey -> [(Comment, DeltaPos)]
- -> ((KeywordId, DeltaPos) -> Bool) -> Transform ()
+insertCommentBefore :: (Monad m) => AnnKey -> [(Comment, DeltaPos)]
+ -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m ()
insertCommentBefore key toMove p = do
let
doInsert ans =
@@ -777,7 +1022,6 @@ insertCommentBefore key toMove p = do
Just ann -> Map.insert key ann' ans
where
(before,after) = break p (annsDP ann)
- -- ann' = error $ "insertCommentBefore:" ++ showGhc (before,after)
ann' = ann { annsDP = before ++ (map comment2dp toMove) ++ after}
modifyAnnsT doInsert
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
index 4172939..a6a9ccb 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -1,6 +1,9 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.GHC.ExactPrint.Types
( -- * Core Types
Anns
@@ -21,10 +24,11 @@ module Language.Haskell.GHC.ExactPrint.Types
, annGetConstr
-- * Internal Types
, LayoutStartCol(..)
+ , declFun
) where
-import Data.Data (Data, Typeable, toConstr)
+import Data.Data (Data, Typeable, toConstr,cast)
import qualified DynFlags as GHC
import qualified GHC
@@ -43,7 +47,9 @@ data Comment = Comment
, commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents
, commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.
}
- deriving (Eq,Show,Typeable,Data, Ord)
+ deriving (Eq,Typeable,Data,Ord)
+instance Show Comment where
+ show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")"
instance GHC.Outputable Comment where
ppr x = GHC.text (show x)
@@ -71,6 +77,7 @@ annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing
data Annotation = Ann
{
+ -- The first three fields relate to interfacing up into the AST
annEntryDelta :: !DeltaPos
-- ^ Offset used to get to the start of the SrcSpan, from whatever the prior
-- output was, including all annPriorComments (field below).
@@ -83,6 +90,8 @@ data Annotation = Ann
-- ^ Comments coming after the last output for the element subject to this
-- Annotation. These will only be added by AST transformations, and care
-- must be taken not to disturb layout of following elements.
+
+ -- The next three fields relate to interacing down into the AST
, annsDP :: ![(KeywordId, DeltaPos)]
-- ^ Annotations associated with this element.
, annSortKey :: !(Maybe [GHC.SrcSpan])
@@ -126,9 +135,15 @@ data AnnKey = AnnKey GHC.SrcSpan AnnConName
instance Show AnnKey where
show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn
-mkAnnKey :: (Data a) => GHC.Located a -> AnnKey
-mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a)
+mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey
+mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a)
+-- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise.
+mkAnnKey :: (Data a) => GHC.Located a -> AnnKey
+mkAnnKey ld =
+ case cast ld :: Maybe (GHC.LHsDecl GHC.RdrName) of
+ Just d -> declFun mkAnnKeyPrim d
+ Nothing -> mkAnnKeyPrim ld
-- Holds the name of a constructor
data AnnConName = CN { unConName :: String }
@@ -179,6 +194,27 @@ instance GHC.Outputable DeltaPos where
-- ---------------------------------------------------------------------
+declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b
+declFun f (GHC.L l de) =
+ case de of
+ GHC.TyClD d -> f (GHC.L l d)
+ GHC.InstD d -> f (GHC.L l d)
+ GHC.DerivD d -> f (GHC.L l d)
+ GHC.ValD d -> f (GHC.L l d)
+ GHC.SigD d -> f (GHC.L l d)
+ GHC.DefD d -> f (GHC.L l d)
+ GHC.ForD d -> f (GHC.L l d)
+ GHC.WarningD d -> f (GHC.L l d)
+ GHC.AnnD d -> f (GHC.L l d)
+ GHC.RuleD d -> f (GHC.L l d)
+ GHC.VectD d -> f (GHC.L l d)
+ GHC.SpliceD d -> f (GHC.L l d)
+ GHC.DocD d -> f (GHC.L l d)
+ GHC.RoleAnnotD d -> f (GHC.L l d)
+#if __GLASGOW_HASKELL__ < 711
+ GHC.QuasiQuoteD d -> f (GHC.L l d)
+#endif
+
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
index b02193d..5cca4e3 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -1,5 +1,7 @@
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.GHC.ExactPrint.Utils
(
-- * Manipulating Positons
@@ -20,7 +22,7 @@ module Language.Haskell.GHC.ExactPrint.Utils
, comment2dp
-- * GHC Functions
- , srcSpanStartLine
+ , srcSpanStartLine
, srcSpanEndLine
, srcSpanStartColumn
, srcSpanEndColumn
@@ -33,12 +35,13 @@ module Language.Haskell.GHC.ExactPrint.Utils
-- * Manipulating Annotations
, getAnnotationEP
, annTrueEntryDelta
+ , annCommentEntryDelta
+ , annLeadingCommentEntryDelta
-- * General Utility
, orderByKey
-
-- * For tests
, debug
, debugM
@@ -135,9 +138,10 @@ undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc)
fl = l + dl
fc = if dl == 0 then c + dc
else co + dc
+
-- | Add together two @DeltaPos@ taking into account newlines
--
--- > DP (0, 1) `addDP` DP (0, 2) == DP (0,3)
+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 3)
-- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5)
-- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3)
addDP :: DeltaPos -> DeltaPos -> DeltaPos
@@ -145,6 +149,33 @@ addDP (DP (a, b)) (DP (c, d)) =
if c >= 1 then DP (a+c, d)
else DP (a, b + d)
+-- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the
+-- remaining delta for the second after the first has been applied.
+-- invariant : if c = a `addDP` b
+-- then a `stepDP` c == b
+--
+-- Cases where first DP is <= than second
+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1)
+-- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0)
+-- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1)
+-- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4)
+--
+-- Cases where first DP is > than second
+-- > DP (0, 3) `addDP` DP (0, 2) == DP (0,1) -- advance one at least
+-- > DP (3, 3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col
+-- > DP (3, 3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least
+-- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col
+stepDP :: DeltaPos -> DeltaPos -> DeltaPos
+stepDP (DP (a,b)) (DP (c,d))
+ | (a,b) == (c,d) = DP (a,b)
+ | a == c = if b < d then DP (0,d - b)
+ else if d == 0
+ then DP (1,0)
+ -- else DP (0,1)
+ else DP (c,d)
+ | a < c = DP (c - a,d)
+ | otherwise = DP (1,d)
+
-- ---------------------------------------------------------------------
ss2pos :: GHC.SrcSpan -> Pos
@@ -242,6 +273,23 @@ annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =
foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
`addDP` annEntryDelta
+-- | Take an annotation and a required "true entry" and calculate an equivalent
+-- one relative to the last comment in the annPriorComments.
+annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos
+annCommentEntryDelta Ann{annPriorComments} trueDP = dp
+ where
+ commentDP =
+ foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )
+ dp = stepDP commentDP trueDP
+
+-- | Return the DP of the first item that generates output, either a comment or the entry DP
+annLeadingCommentEntryDelta :: Annotation -> DeltaPos
+annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp
+ where
+ dp = case annPriorComments of
+ [] -> annEntryDelta
+ ((_,ed):_) -> ed
+
-- | Calculates the distance from the start of a string to the end of
-- a string.
dpFromString :: String -> DeltaPos
@@ -333,13 +381,23 @@ showAnnData anns n =
srcSpan s
++ indent (n + 1) ++
show (getAnnotationEP (GHC.L s a) anns)
+ -- ++ case showWrappedDeclAnns (GHC.L s a) of
+ -- Nothing -> ""
+ -- Just annStr -> indent (n + 1) ++ annStr
Nothing -> "nnnnnnnn"
++ showAnnData anns (n+1) a
++ ")"
--- ---------------------------------------------------------------------
-
+{-
+ showWrappedDeclAnns :: (Data a) => GHC.Located a -> Maybe String
+ showWrappedDeclAnns t = everything mappend (Nothing `mkQ` showDecl) t
+ where
+ showDecl :: GHC.LHsDecl GHC.RdrName -> Maybe String
+ showDecl d = Just $ declFun doShowAnn d
+ doShowAnn :: (Data a) => GHC.Located a -> String
+ doShowAnn a = show (getAnnotationEP a anns)
+-}
-- ---------------------------------------------------------------------
showSDoc_ :: GHC.SDoc -> String
diff --git a/tests/Test.hs b/tests/Test.hs
index 9d6384d..677153e 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -39,6 +39,14 @@ main = hSilence [stderr] $ do
then exitFailure
else return () -- exitSuccess
+transform :: IO ()
+transform = hSilence [stderr] $ do
+ cnts <- fst <$> runTestText (putTextToHandle stdout True) (TestList transformTests)
+ putStrLn $ show cnts
+ if errors cnts > 0 || failures cnts > 0
+ then exitFailure
+ else return () -- exitSuccess
+
-- ---------------------------------------------------------------------
tests :: Test
@@ -234,6 +242,7 @@ tests = TestList $
, mkParserTest "T10196.hs"
, mkParserTest "StringGap.hs"
, mkParserTest "RedundantDo.hs"
+ , mkParserTest "TypeSignature.hs"
]
++ transformTests
@@ -463,16 +472,31 @@ tt' = formatTT =<< partition snd <$> sequence [ return ("", True)
-- , manipulateAstTestWFname "WhereIn3.hs" "WhereIn3"
-- , manipulateAstTestWFnameMod changeWhereIn3a "WhereIn3a.hs" "WhereIn3a"
-- , manipulateAstTestWFname "Imports.hs" "Imports"
- , manipulateAstTestWFname "T10196.hs" "T10196"
+ -- , manipulateAstTestWFname "T10196.hs" "T10196"
, manipulateAstTestWFnameMod addLocaLDecl1 "AddLocalDecl1.hs" "AddLocaLDecl1"
- , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2"
- , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3"
- , manipulateAstTestWFnameMod rmDecl1 "RmDecl1.hs" "RmDecl1"
+ -- , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2"
+ -- , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3"
+ -- , manipulateAstTestWFnameMod addLocaLDecl4 "AddLocalDecl4.hs" "AddLocaLDecl4"
+ -- , manipulateAstTestWFnameMod addLocaLDecl5 "AddLocalDecl5.hs" "AddLocaLDecl5"
+ -- , manipulateAstTestWFnameMod addLocaLDecl6 "AddLocalDecl6.hs" "AddLocaLDecl6"
+ -- , manipulateAstTestWFnameMod rmDecl1 "RmDecl1.hs" "RmDecl1"
-- , manipulateAstTestWFname "RmDecl2.hs" "RmDecl2"
- , manipulateAstTestWFnameMod rmDecl2 "RmDecl2.hs" "RmDecl2"
- , manipulateAstTestWFnameMod rmDecl3 "RmDecl3.hs" "RmDecl3"
- , manipulateAstTestWFnameMod rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"
- , manipulateAstTestWFname "StringGap.hs" "StringGap"
+ -- , manipulateAstTestWFnameMod rmDecl2 "RmDecl2.hs" "RmDecl2"
+ -- , manipulateAstTestWFnameMod rmDecl3 "RmDecl3.hs" "RmDecl3"
+ -- , manipulateAstTestWFnameMod rmDecl4 "RmDecl4.hs" "RmDecl4"
+ -- , manipulateAstTestWFnameMod rmDecl5 "RmDecl5.hs" "RmDecl5"
+ -- , manipulateAstTestWFname "RmDecl5.hs" "RmDecl5"
+ -- , manipulateAstTestWFnameMod rmDecl6 "RmDecl6.hs" "RmDecl6"
+ -- , manipulateAstTestWFnameMod rmDecl7 "RmDecl7.hs" "RmDecl7"
+ -- , manipulateAstTestWFname "TypeSignature.hs" "TypeSignature"
+ -- , manipulateAstTestWFnameMod rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"
+ -- , manipulateAstTestWFnameMod rmTypeSig2 "RmTypeSig2.hs" "RmTypeSig2"
+ -- , manipulateAstTestWFname "StringGap.hs" "StringGap"
+ -- , manipulateAstTestWFnameMod addHiding1 "AddHiding1.hs" "AddHiding1"
+ -- , manipulateAstTestWFnameMod addHiding2 "AddHiding2.hs" "AddHiding2"
+ -- , manipulateAstTestWFnameMod cloneDecl1 "CloneDecl1.hs" "CloneDecl1"
+ -- , manipulateAstTestWFname "SimpleDo.hs" "Main"
+ -- , manipulateAstTestWFnameMod changeRename2 "Rename2.hs" "Main"
{-
, manipulateAstTestWFname "Lhs.lhs" "Main"
, manipulateAstTestWFname "Foo.hs" "Main"
diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs
index eba3758..4e5bf5d 100644
--- a/tests/Test/Common.hs
+++ b/tests/Test/Common.hs
@@ -155,7 +155,7 @@ runRoundTrip :: GHC.ApiAnns -> GHC.Located (GHC.HsModule GHC.RdrName)
runRoundTrip !anns !parsedOrig cs =
let
!relAnns = relativiseApiAnnsWithComments cs parsedOrig anns
- !printed = exactPrintWithAnns parsedOrig relAnns
+ !printed = exactPrint parsedOrig relAnns
in (printed, relAnns)
-- ---------------------------------------------------------------------`
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
index bfe2e27..399e496 100644
--- a/tests/Test/Transform.hs
+++ b/tests/Test/Transform.hs
@@ -18,11 +18,13 @@ import qualified SrcLoc as GHC
import qualified FastString as GHC
import qualified Data.Generics as SYB
+-- import qualified GHC.SYB.Utils as SYB
import Control.Monad
import System.FilePath
import System.IO
import qualified Data.Map as Map
+-- import Data.List
import Data.Maybe
import System.IO.Silently
@@ -46,6 +48,7 @@ transformLowLevelTests = [
, mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"
, mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"
, mkTestModChange changeRename1 "Rename1.hs" "Main"
+ , mkTestModChange changeRename2 "Rename2.hs" "Main"
, mkTestModChange changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1"
, mkTestModChange changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3"
, mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a"
@@ -115,7 +118,7 @@ changeLocalDecls2 ans (GHC.L l p) = do
{ annEntryDelta = DP (1,0) }
modifyAnnsT addWhere
let decls = [s,d]
- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
+ -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrderAnnKey newAnnKey decls)
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
(GHC.HsValBinds
@@ -149,11 +152,9 @@ changeLocalDecls ans (GHC.L l p) = do
let a2 = setPrecedingLines s1 2 0 a1
return a2
putAnnsT a'
- let wrapDecl (GHC.L l' w) = GHC.L l' (GHC.ValD w)
- wrapSig (GHC.L l' w) = GHC.L l' (GHC.SigD w)
let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs
let decls = s:d:oldDecls
- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
+ -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)
modifyAnnsT (captureOrder m decls)
return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs
(GHC.HsValBinds
@@ -323,6 +324,9 @@ changeLayoutIn1 ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24
changeRename1 :: Changer
changeRename1 ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed)
+changeRename2 :: Changer
+changeRename2 ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed)
+
changeLayoutLet3 :: Changer
changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)
@@ -448,7 +452,7 @@ manipulateAstTest' mchange useTH file' modname = do
Just (change,_) -> change ann parsed
let
- printed = exactPrintWithAnns parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))
+ printed = exactPrint parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))
outcome = if printed == contents
then "Match\n"
else "Fail\n"
@@ -552,97 +556,173 @@ transformHighLevelTests =
mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" "AddLocalDecl1"
, mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" "AddLocalDecl2"
, mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" "AddLocalDecl3"
+ , mkTestModChange addLocaLDecl4 "AddLocalDecl4.hs" "AddLocalDecl4"
+ , mkTestModChange addLocaLDecl5 "AddLocalDecl5.hs" "AddLocalDecl5"
+ , mkTestModChange addLocaLDecl6 "AddLocalDecl6.hs" "AddLocalDecl6"
, mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1"
, mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2"
, mkTestModChange rmDecl3 "RmDecl3.hs" "RmDecl3"
+ , mkTestModChange rmDecl4 "RmDecl4.hs" "RmDecl4"
+ , mkTestModChange rmDecl5 "RmDecl5.hs" "RmDecl5"
+ , mkTestModChange rmDecl6 "RmDecl6.hs" "RmDecl6"
+ , mkTestModChange rmDecl7 "RmDecl7.hs" "RmDecl7"
, mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"
+ , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" "RmTypeSig2"
+
+ , mkTestModChange addHiding1 "AddHiding1.hs" "AddHiding1"
+ , mkTestModChange addHiding2 "AddHiding2.hs" "AddHiding2"
+
+ , mkTestModChange cloneDecl1 "CloneDecl1.hs" "CloneDecl1"
]
-- ---------------------------------------------------------------------
addLocaLDecl1 :: Changer
addLocaLDecl1 ans lp = do
- Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
+ Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ let declAnns' = setPrecedingLines newDecl 1 4 declAnns
+ doAddLocal = do
+ (d1:d2:_) <- hsDecls lp
+ balanceComments d1 d2
+ (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do
+ return ((newDecl : d),Nothing)
+ replaceDecls lp [d1', d2]
+
+ let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal
+ -- putStrLn $ "log:\n" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+addLocaLDecl2 :: Changer
+addLocaLDecl2 ans lp = do
+ Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ let
doAddLocal = do
tlDecs <- hsDecls lp
let parent = head tlDecs
- decls <- hsDecls parent
balanceComments parent (head $ tail tlDecs)
- modifyAnnsT (setPrecedingLines newDecl 1 4)
+ (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do
+ transferEntryDPT (head decls) newDecl
+ setEntryDPT (head decls) (DP (1, 0))
+ return ((newDecl:decls),Nothing)
- parent' <- replaceDecls parent (newDecl:decls)
replaceDecls lp (parent':tail tlDecs)
- let (lp',(ans',_),_w) = runTransform ans doAddLocal
- return (mergeAnnList [declAnns',ans'],lp')
+ let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal
+ -- putStrLn $ "log:\n" ++ intercalate "\n" _w
+ return (ans',lp')
-- ---------------------------------------------------------------------
-addLocaLDecl2 :: Changer
-addLocaLDecl2 ans lp = do
- Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
-
+addLocaLDecl3 :: Changer
+addLocaLDecl3 ans lp = do
+ Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ let
doAddLocal = do
+ -- logDataWithAnnsTr "parsed:" lp
+ logDataWithAnnsTr "newDecl:" newDecl
tlDecs <- hsDecls lp
let parent = head tlDecs
- decls <- hsDecls parent
balanceComments parent (head $ tail tlDecs)
- DP (r,c) <- getEntryDPT (head decls)
- modifyAnnsT (setPrecedingLines newDecl r c)
- modifyAnnsT (setPrecedingLines (head decls) 1 0)
+ (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do
+ setPrecedingLinesT newDecl 1 0
+ moveTrailingComments m (last decls)
+ return ((decls++[newDecl]),Nothing)
- parent' <- replaceDecls parent (newDecl:decls)
replaceDecls lp (parent':tail tlDecs)
- let (lp',(ans',_),_w) = runTransform ans doAddLocal
- return (mergeAnnList [declAnns',ans'],lp')
+ let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal
+ -- putStrLn $ "log\n" ++ intercalate "\n" _w
+ return (ans',lp')
-- ---------------------------------------------------------------------
-addLocaLDecl3 :: Changer
-addLocaLDecl3 ans lp = do
- Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns
-
+addLocaLDecl4 :: Changer
+addLocaLDecl4 ans lp = do
+ Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")
+ Right (sigAnns, newSig) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")
+ -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp
+ let
doAddLocal = do
tlDecs <- hsDecls lp
let parent = head tlDecs
- decls <- hsDecls parent
- balanceComments parent (head $ tail tlDecs)
- modifyAnnsT (setPrecedingLines newDecl 1 0)
+ setPrecedingLinesT newSig 1 0
+ setPrecedingLinesT newDecl 1 0
+
+ (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do
+ return ((decls++[newSig,newDecl]),Nothing)
- moveTrailingComments parent (last decls)
- parent' <- replaceDecls parent (decls++[newDecl])
replaceDecls lp (parent':tail tlDecs)
+ let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal
+ -- putStrLn $ "log\n" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+addLocaLDecl5 :: Changer
+addLocaLDecl5 ans lp = do
+ let
+ doAddLocal = do
+ [s1,d1,d2,d3] <- hsDecls lp
+
+ transferEntryDPT d2 d3
+
+ (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do
+ return ([d2],Nothing)
+ replaceDecls lp [s1,d1',d3]
+
let (lp',(ans',_),_w) = runTransform ans doAddLocal
- return (mergeAnnList [declAnns',ans'],lp')
+ -- putStrLn $ "log\n" ++ intercalate "\n" _w
+ return (ans',lp')
-- ---------------------------------------------------------------------
+addLocaLDecl6 :: Changer
+addLocaLDecl6 ans lp = do
+ Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3")
+ let declAnns' = setPrecedingLines newDecl 1 4 declAnns
+ doAddLocal = do
+ [d1,d2] <- hsDecls lp
+ balanceComments d1 d2
+
+ let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1
+ balanceComments m1 m2
+
+ (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do
+ return ((newDecl : decls),Nothing)
+ replaceDecls lp [d1', d2]
+
+ let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns') doAddLocal
+ -- putStrLn $ "log:\n" ++ intercalate "\n" _w
+ return (ans',lp')
+-- ---------------------------------------------------------------------
+
rmDecl1 :: Changer
rmDecl1 ans lp = do
let doRmDecl = do
tlDecs <- hsDecls lp
let (d1:s1:d2:ds) = tlDecs
- -- First delete the decl only
+ -- First delete the decl (d2) only
+ balanceComments s1 d2 -- ++AZ++
balanceComments d2 (head ds)
lp1 <- replaceDecls lp (d1:s1:ds)
+ -- return lp1
-- Then delete the sig separately
tlDecs1 <- hsDecls lp1
let (d1':s1':ds') = tlDecs1
+ -- transferEntryDPT s1' (head ds') -- required in HaRe.
balanceComments d1' s1'
balanceComments s1' (head ds')
+ transferEntryDPT s1' (head ds') -- required in HaRe.
replaceDecls lp (d1':ds')
let (lp',(ans',_),_w) = runTransform ans doRmDecl
@@ -655,35 +735,118 @@ rmDecl2 ans lp = do
let
doRmDecl = do
let
+ go :: GHC.LHsExpr GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName)
+ go e@(GHC.L _ (GHC.HsLet{})) = do
+ decs <- hsDecls e
+ e' <- replaceDecls e (init decs)
+ return e'
+ go x = return x
+
+ SYB.everywhereM (SYB.mkM go) lp
+
+ let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:\n" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl3 :: Changer
+rmDecl3 ans lp = do
+ let
+ doRmDecl = do
+ [d1,d2] <- hsDecls lp
+
+ (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do
+ setPrecedingLinesDeclT sd1 2 0
+ return ([],Just sd1)
+
+ replaceDecls lp [d1',sd1,d2]
+
+ let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:\n" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl4 :: Changer
+rmDecl4 ans lp = do
+ let
+ doRmDecl = do
+ [d1] <- hsDecls lp
+
+ (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do
+ -- [sd1,sd2] <- hsDecls d1
+ transferEntryDPT sd1 sd2
+
+ setPrecedingLinesDeclT sd1 2 0
+ -- d1' <- replaceDecls d1 [sd2]
+ return ([sd2],Just sd1)
+
+ replaceDecls lp [d1',sd1]
+
+ let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl5 :: Changer
+rmDecl5 ans lp = do
+ let
+ doRmDecl = do
+ let
go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)
go (GHC.HsLet lb expr) = do
- decs <- hsDecls lb
- lb' <- replaceDecls lb (init decs)
+ decs <- hsDeclsValBinds lb
+ let dec = last decs
+ transferEntryDPT (head decs) dec
+ lb' <- replaceDeclsValbinds lb [dec]
return (GHC.HsLet lb' expr)
go x = return x
SYB.everywhereM (SYB.mkM go) lp
let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:" ++ intercalate "\n" _w
return (ans',lp')
-- ---------------------------------------------------------------------
-rmDecl3 :: Changer
-rmDecl3 ans lp = do
+rmDecl6 :: Changer
+rmDecl6 ans lp = do
+ let
+ doRmDecl = do
+ [d1] <- hsDecls lp
+
+ (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do
+ let (ss1:_sd1:sd2:sds) = subDecs
+ transferEntryDPT ss1 sd2
+
+ return (sd2:sds,Nothing)
+
+ replaceDecls lp [d1']
+
+ let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+rmDecl7 :: Changer
+rmDecl7 ans lp = do
let
doRmDecl = do
tlDecs <- hsDecls lp
- let [d1] = tlDecs
+ let [s1,d1,d2,d3] = tlDecs
- subDecs <- hsDecls d1
- let [sd1] = subDecs
+ balanceComments d1 d2
+ balanceComments d2 d3
- modifyAnnsT (setPrecedingLinesDecl sd1 2 0)
- d1' <- replaceDecls d1 []
- replaceDecls lp [d1',sd1]
+ transferEntryDPT d2 d3
+
+ replaceDecls lp [s1,d1,d3]
let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:" ++ intercalate "\n" _w
return (ans',lp')
-- ---------------------------------------------------------------------
@@ -701,3 +864,83 @@ rmTypeSig1 ans lp = do
return (ans',lp')
-- ---------------------------------------------------------------------
+
+rmTypeSig2 :: Changer
+rmTypeSig2 ans lp = do
+ let doRmDecl = do
+ tlDecs <- hsDecls lp
+ let [d1] = tlDecs
+
+ (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do
+ transferEntryDPT s d
+ return ([d],Nothing)
+ replaceDecls lp [d1']
+
+ let (lp',(ans',_),_w) = runTransform ans doRmDecl
+ -- putStrLn $ "log:" ++ intercalate "\n" _w
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+addHiding1 :: Changer
+addHiding1 ans (GHC.L l p) = do
+ let doTransform = do
+ l0 <- uniqueSrcSpanT
+ l1 <- uniqueSrcSpanT
+ l2 <- uniqueSrcSpanT
+ let
+ [GHC.L li imp1,imp2] = GHC.hsmodImports p
+ n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
+ n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
+ v1 = GHC.L l1 (GHC.IEVar n1)
+ v2 = GHC.L l2 (GHC.IEVar n2)
+ impHiding = GHC.L l0 [v1,v2]
+ imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)}
+ p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]}
+ addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]
+ addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))]
+ addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
+ return (GHC.L l p')
+
+ let (lp',(ans',_),_w) = runTransform ans doTransform
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+addHiding2 :: Changer
+addHiding2 ans (GHC.L l p) = do
+ let doTransform = do
+ l1 <- uniqueSrcSpanT
+ l2 <- uniqueSrcSpanT
+ let
+ [GHC.L li imp1] = GHC.hsmodImports p
+ Just (_,GHC.L lh ns) = GHC.ideclHiding imp1
+ (GHC.L _ (GHC.IEVar ln)) = last ns
+ n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1"))
+ n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2"))
+ v1 = GHC.L l1 (GHC.IEVar n1)
+ v2 = GHC.L l2 (GHC.IEVar n2)
+ imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))}
+ p' = p { GHC.hsmodImports = [GHC.L li imp1']}
+ addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))]
+ addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
+ addTrailingCommaT ln
+ return (GHC.L l p')
+
+ let (lp',(ans',_),_w) = runTransform ans doTransform
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
+
+cloneDecl1 :: Changer
+cloneDecl1 ans lp = do
+ let doChange = do
+ tlDecs <- hsDecls lp
+ let (d1:d2:ds) = tlDecs
+ d2' <- fst <$> cloneT d2
+ replaceDecls lp (d1:d2:d2':ds)
+
+ let (lp',(ans',_),_w) = runTransform ans doChange
+ return (ans',lp')
+
+-- ---------------------------------------------------------------------
diff --git a/tests/examples/AddHiding1.hs b/tests/examples/AddHiding1.hs
new file mode 100644
index 0000000..698983e
--- /dev/null
+++ b/tests/examples/AddHiding1.hs
@@ -0,0 +1,7 @@
+module AddHiding1 where
+
+import Data.Maybe
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
diff --git a/tests/examples/AddHiding1.hs.expected b/tests/examples/AddHiding1.hs.expected
new file mode 100644
index 0000000..2e29096
--- /dev/null
+++ b/tests/examples/AddHiding1.hs.expected
@@ -0,0 +1,7 @@
+module AddHiding1 where
+
+import Data.Maybe hiding (n1,n2)
+
+import Data.Maybe hiding (n1,n2)
+
+f = 1
diff --git a/tests/examples/AddHiding2.hs b/tests/examples/AddHiding2.hs
new file mode 100644
index 0000000..f5f551a
--- /dev/null
+++ b/tests/examples/AddHiding2.hs
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2)
+
+f = 1
diff --git a/tests/examples/AddHiding2.hs.expected b/tests/examples/AddHiding2.hs.expected
new file mode 100644
index 0000000..d620052
--- /dev/null
+++ b/tests/examples/AddHiding2.hs.expected
@@ -0,0 +1,5 @@
+module AddHiding2 where
+
+import Data.Maybe hiding (f1,f2,n1,n2)
+
+f = 1
diff --git a/tests/examples/AddLocalDecl4.hs b/tests/examples/AddLocalDecl4.hs
new file mode 100644
index 0000000..2ec2c0b
--- /dev/null
+++ b/tests/examples/AddLocalDecl4.hs
@@ -0,0 +1,3 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
diff --git a/tests/examples/AddLocalDecl4.hs.expected b/tests/examples/AddLocalDecl4.hs.expected
new file mode 100644
index 0000000..b3c1445
--- /dev/null
+++ b/tests/examples/AddLocalDecl4.hs.expected
@@ -0,0 +1,6 @@
+module AddLocalDecl4 where
+
+toplevel x = c * x
+ where
+ nn :: Int
+ nn = 2
diff --git a/tests/examples/AddLocalDecl5.hs b/tests/examples/AddLocalDecl5.hs
new file mode 100644
index 0000000..9f07e10
--- /dev/null
+++ b/tests/examples/AddLocalDecl5.hs
@@ -0,0 +1,8 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
diff --git a/tests/examples/AddLocalDecl5.hs.expected b/tests/examples/AddLocalDecl5.hs.expected
new file mode 100644
index 0000000..5e66dc5
--- /dev/null
+++ b/tests/examples/AddLocalDecl5.hs.expected
@@ -0,0 +1,9 @@
+module AddLocalDecl5 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+ where
+ -- c,d :: Integer
+ c = 7
+
+d = 9
diff --git a/tests/examples/AddLocalDecl6.hs b/tests/examples/AddLocalDecl6.hs
new file mode 100644
index 0000000..2ab96af
--- /dev/null
+++ b/tests/examples/AddLocalDecl6.hs
@@ -0,0 +1,9 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+ where
+ x = 3
+bar xs = 2 -- comment 3
diff --git a/tests/examples/AddLocalDecl6.hs.expected b/tests/examples/AddLocalDecl6.hs.expected
new file mode 100644
index 0000000..b689feb
--- /dev/null
+++ b/tests/examples/AddLocalDecl6.hs.expected
@@ -0,0 +1,11 @@
+module AddLocalDecl6 where
+
+foo [] = 1 -- comment 0
+ where
+ x = 3
+foo xs = 2 -- comment 1
+
+bar [] = 1 -- comment 2
+ where
+ x = 3
+bar xs = 2 -- comment 3
diff --git a/tests/examples/Base.hs b/tests/examples/Base.hs
new file mode 100644
index 0000000..9fd44f4
--- /dev/null
+++ b/tests/examples/Base.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE BangPatterns, CPP, RankNTypes, MagicHash, UnboxedTuples, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, UnliftedFFITypes #-}
+#if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE RoleAnnotations #-}
+#endif
+{-# OPTIONS_HADDOCK hide #-}
+
+-- Flat unboxed arrays: instances
+
+instance IArray UArray Bool where
+ {-# INLINE bounds #-}
+ bounds (UArray l u _ _) = (l,u)
+ {-# INLINE numElements #-}
+ numElements (UArray _ _ n _) = n
+ {-# INLINE unsafeArray #-}
+ unsafeArray lu ies = runST (unsafeArrayUArray lu ies False)
+ {-# INLINE unsafeAt #-}
+ unsafeAt (UArray _ _ _ arr#) (I# i#) =
+ ((indexWordArray# arr# (bOOL_INDEX i#) `and#` bOOL_BIT i#)
+ `neWord#` int2Word# 0#)
+
+ {-# INLINE unsafeReplace #-}
+ unsafeReplace arr ies = runST (unsafeReplaceUArray arr ies)
+ {-# INLINE unsafeAccum #-}
+ unsafeAccum f arr ies = runST (unsafeAccumUArray f arr ies)
+ {-# INLINE unsafeAccumArray #-}
+ unsafeAccumArray f initialValue lu ies = runST (unsafeAccumArrayUArray f initialValue lu ies)
diff --git a/tests/examples/CloneDecl1.hs b/tests/examples/CloneDecl1.hs
new file mode 100644
index 0000000..387eeee
--- /dev/null
+++ b/tests/examples/CloneDecl1.hs
@@ -0,0 +1,10 @@
+module CloneDecl1 where
+
+z = 3
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
diff --git a/tests/examples/CloneDecl1.hs.expected b/tests/examples/CloneDecl1.hs.expected
new file mode 100644
index 0000000..7d020f9
--- /dev/null
+++ b/tests/examples/CloneDecl1.hs.expected
@@ -0,0 +1,17 @@
+module CloneDecl1 where
+
+z = 3
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
+
+foo a b =
+ let
+ x = a + b + z
+ y = a * b - z
+ in
+ x + y
diff --git a/tests/examples/Error.hs b/tests/examples/Error.hs
new file mode 100644
index 0000000..72aa444
--- /dev/null
+++ b/tests/examples/Error.hs
@@ -0,0 +1,110 @@
+
+module GameData.Data where
+#include "Utils.cpp"
+import qualified Data.List as L
+import qualified Data.List.Zipper as LZ
+import Gamgine.Control (applyIf)
+import qualified Gamgine.Zipper as GZ
+import qualified GameData.Level as LV
+import qualified GameData.Entity as E
+IMPORT_LENS_AS_LE
+
+
+data Data = Data {
+ levels :: LZ.Zipper LV.Level
+ }
+
+LENS(levels)
+
+instance E.ApplyToEntity Data where
+ eMap f = LE.modL currentLevelL (E.eMap f)
+ eFilter p = LE.modL currentLevelL (E.eFilter p)
+
+
+currentLevelL = currentLevelLens
+currentLevelLens = LE.lens getCurrentLevel setCurrentLevel
+ where
+ getCurrentLevel = LZ.cursor . levels
+ setCurrentLevel level = LE.modL levelsL $ LZ.replace level
+
+
+newData :: [LV.Level] -> Data
+newData = Data . LZ.fromList
+
+
+allLevels :: Data -> [LV.Level]
+allLevels = LZ.toList . levels
+
+
+atLastLevel :: Data -> Bool
+atLastLevel = GZ.atLast . levels
+
+
+atFirstLevel :: Data -> Bool
+atFirstLevel = GZ.atFirst . levels
+
+
+levelFinished :: Data -> Bool
+levelFinished = LV.allStarsCollected . LE.getL currentLevelL
+
+
+gameFinished :: Data -> Bool
+gameFinished d = levelFinished d && atLastLevel d
+
+
+toNextLevel :: Data -> Data
+toNextLevel d@Data {levels = lvs}
+ | LZ.emptyp lvs || GZ.atLast lvs = d
+ | otherwise =
+ let lvs = levels d
+ (c', n') = LV.changeLevels (GZ.current lvs) (GZ.next lvs)
+ in d {levels = LZ.replace n' . LZ.right . LZ.replace c' $ lvs}
+
+
+toPreviousLevel :: Data -> Data
+toPreviousLevel d@Data {levels = lvs}
+ | LZ.emptyp lvs || GZ.atFirst lvs = d
+ | otherwise =
+ let (c', p') = LV.changeLevels (GZ.current lvs) (GZ.previous lvs)
+ in d {levels = LZ.replace p' . LZ.left . LZ.replace c' $ lvs}
+
+
+data AddLevel = BeforeCurrent | AfterCurrent | AfterLast
+
+addEmptyLevel :: AddLevel -> Data -> Data
+addEmptyLevel BeforeCurrent d@Data {levels = lvs} =
+ let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel
+ in d {levels = LZ.insert nlv' . LZ.replace c' $ lvs}
+
+addEmptyLevel AfterCurrent d@Data {levels = lvs} =
+ let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel
+ in d {levels = LZ.insert nlv' . LZ.right . LZ.replace c' $ lvs}
+
+addEmptyLevel AfterLast d@Data {levels = lvs} =
+ let (c', nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel
+ in d {levels = LZ.insert nlv' . LZ.end . LZ.replace c' $ lvs}
+
+
+data MoveLevel = Forward | Backward
+
+moveCurrentLevel :: MoveLevel -> Data -> Data
+moveCurrentLevel Forward d@Data {levels = lvs}
+ | LZ.beginp lvs = d
+ | otherwise =
+ let (p, c) = (GZ.previous lvs, GZ.current lvs)
+ in d {levels = LZ.replace c . LZ.left . LZ.replace p $ lvs}
+
+moveCurrentLevel Backward d@Data {levels = lvs}
+ | GZ.atLast lvs = d
+ | otherwise =
+ let (c, n) = (GZ.current lvs, GZ.next lvs)
+ in d {levels = LZ.replace c . LZ.right . LZ.replace n $ lvs}
+
+
+removeCurrentLevel :: Data -> Data
+removeCurrentLevel d@Data {levels = lvs}
+ | GZ.atFirst lvs && GZ.atLast lvs =
+ let (_, nlv') = LV.changeLevels (GZ.current lvs) LV.newEmptyLevel
+ in d {levels = LZ.replace nlv' lvs}
+
+ | otherwise = d {levels = applyIf LZ.endp LZ.left . LZ.delete $ lvs}
diff --git a/tests/examples/Join.hs b/tests/examples/Join.hs
new file mode 100644
index 0000000..5a73cea
--- /dev/null
+++ b/tests/examples/Join.hs
@@ -0,0 +1,7 @@
+
+forkOS_entry :: StablePtr (IO ()) -> IO ()
+forkOS_entry stableAction = do
+ action <- deRefStablePtr stableAction
+ action
+
+
diff --git a/tests/examples/Lambda.hs b/tests/examples/Lambda.hs
new file mode 100644
index 0000000..03481a3
--- /dev/null
+++ b/tests/examples/Lambda.hs
@@ -0,0 +1,2 @@
+
+i = \x -> x
diff --git a/tests/examples/NormaliseLayout.hs b/tests/examples/NormaliseLayout.hs
new file mode 100644
index 0000000..3d07966
--- /dev/null
+++ b/tests/examples/NormaliseLayout.hs
@@ -0,0 +1,5 @@
+module Main where
+
+foo x = baz
+ where foo = 2
+ two = 4 where bax = 4
diff --git a/tests/examples/NormaliseLayout.hs.expected b/tests/examples/NormaliseLayout.hs.expected
new file mode 100644
index 0000000..6ca9a1f
--- /dev/null
+++ b/tests/examples/NormaliseLayout.hs.expected
@@ -0,0 +1 @@
+module Main where
diff --git a/tests/examples/Rename2.hs b/tests/examples/Rename2.hs
new file mode 100644
index 0000000..29fea06
--- /dev/null
+++ b/tests/examples/Rename2.hs
@@ -0,0 +1,4 @@
+
+foo' x = case (odd x) of
+ True -> "Odd"
+ False -> "Even"
diff --git a/tests/examples/Rename2.hs.expected b/tests/examples/Rename2.hs.expected
new file mode 100644
index 0000000..6be3ff6
--- /dev/null
+++ b/tests/examples/Rename2.hs.expected
@@ -0,0 +1,4 @@
+
+joe x = case (odd x) of
+ True -> "Odd"
+ False -> "Even"
diff --git a/tests/examples/RmDecl3.hs b/tests/examples/RmDecl3.hs
index ed42216..280bccf 100644
--- a/tests/examples/RmDecl3.hs
+++ b/tests/examples/RmDecl3.hs
@@ -5,4 +5,5 @@ ff y = y + zz
where
zz = 1
+foo = 3
-- EOF
diff --git a/tests/examples/RmDecl3.hs.expected b/tests/examples/RmDecl3.hs.expected
index 023c9b9..ca14f33 100644
--- a/tests/examples/RmDecl3.hs.expected
+++ b/tests/examples/RmDecl3.hs.expected
@@ -5,4 +5,5 @@ ff y = y + zz
zz = 1
+foo = 3
-- EOF
diff --git a/tests/examples/RmDecl4.hs b/tests/examples/RmDecl4.hs
new file mode 100644
index 0000000..532b738
--- /dev/null
+++ b/tests/examples/RmDecl4.hs
@@ -0,0 +1,9 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+ where
+ zz = 1
+ xx = 2
+
+-- EOF
diff --git a/tests/examples/RmDecl4.hs.expected b/tests/examples/RmDecl4.hs.expected
new file mode 100644
index 0000000..e7c71db
--- /dev/null
+++ b/tests/examples/RmDecl4.hs.expected
@@ -0,0 +1,10 @@
+module RmDecl4 where
+
+-- Remove first declaration from a where clause, last should still be indented
+ff y = y + zz + xx
+ where
+ xx = 2
+
+zz = 1
+
+-- EOF
diff --git a/tests/examples/RmDecl5.hs b/tests/examples/RmDecl5.hs
new file mode 100644
index 0000000..e5dbaed
--- /dev/null
+++ b/tests/examples/RmDecl5.hs
@@ -0,0 +1,6 @@
+module RmDecl5 where
+
+sumSquares x y = let sq 0=0
+ sq z=z^pow
+ pow=2
+ in sq x + sq y
diff --git a/tests/examples/RmDecl5.hs.expected b/tests/examples/RmDecl5.hs.expected
new file mode 100644
index 0000000..9c3c6fe
--- /dev/null
+++ b/tests/examples/RmDecl5.hs.expected
@@ -0,0 +1,4 @@
+module RmDecl5 where
+
+sumSquares x y = let pow=2
+ in sq x + sq y
diff --git a/tests/examples/RmDecl6.hs b/tests/examples/RmDecl6.hs
new file mode 100644
index 0000000..f902880
--- /dev/null
+++ b/tests/examples/RmDecl6.hs
@@ -0,0 +1,11 @@
+module RmDecl6 where
+
+foo a = baz
+ where
+ baz :: Int
+ baz = x + a
+
+ x = 1
+
+ y :: Int -> Int -> Int
+ y a b = undefined
diff --git a/tests/examples/RmDecl6.hs.expected b/tests/examples/RmDecl6.hs.expected
new file mode 100644
index 0000000..e019cb8
--- /dev/null
+++ b/tests/examples/RmDecl6.hs.expected
@@ -0,0 +1,8 @@
+module RmDecl6 where
+
+foo a = baz
+ where
+ x = 1
+
+ y :: Int -> Int -> Int
+ y a b = undefined
diff --git a/tests/examples/RmDecl7.hs b/tests/examples/RmDecl7.hs
new file mode 100644
index 0000000..c6c09e1
--- /dev/null
+++ b/tests/examples/RmDecl7.hs
@@ -0,0 +1,8 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+-- c,d :: Integer
+c = 7
+d = 9
diff --git a/tests/examples/RmDecl7.hs.expected b/tests/examples/RmDecl7.hs.expected
new file mode 100644
index 0000000..daf8438
--- /dev/null
+++ b/tests/examples/RmDecl7.hs.expected
@@ -0,0 +1,6 @@
+module RmDecl7 where
+
+toplevel :: Integer -> Integer
+toplevel x = c * x
+
+d = 9
diff --git a/tests/examples/RmTypeSig2.hs b/tests/examples/RmTypeSig2.hs
new file mode 100644
index 0000000..4dffd8d
--- /dev/null
+++ b/tests/examples/RmTypeSig2.hs
@@ -0,0 +1,7 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+ where
+ ff :: Int
+ ff = 15
diff --git a/tests/examples/RmTypeSig2.hs.expected b/tests/examples/RmTypeSig2.hs.expected
new file mode 100644
index 0000000..b83f304
--- /dev/null
+++ b/tests/examples/RmTypeSig2.hs.expected
@@ -0,0 +1,6 @@
+module RmTypeSig2 where
+
+-- Pattern bind
+tup@(h,t) = (1,ff)
+ where
+ ff = 15
diff --git a/tests/examples/SegFault.hs b/tests/examples/SegFault.hs
new file mode 100644
index 0000000..cf5e810
--- /dev/null
+++ b/tests/examples/SegFault.hs
@@ -0,0 +1,133 @@
+{-# INCLUDE "Parrot_hsc.h" #-}
+{-# LINE 1 "Parrot.hsc" #-}
+{-# OPTIONS_GHC -fglasgow-exts -cpp -fno-full-laziness -fno-cse #-}
+{-# LINE 2 "Parrot.hsc" #-}
+
+{-# LINE 3 "Parrot.hsc" #-}
+
+module Pugs.Embed.Parrot where
+import Data.IORef
+import System.Cmd
+import System.Process
+import System.Directory
+import System.IO
+import System.IO.Unsafe
+import Data.Maybe
+import Control.Monad
+import Pugs.Compat (getEnv, _PUGS_HAVE_POSIX)
+import Pugs.Internals (encodeUTF8)
+
+findExecutable' :: String -> IO (Maybe FilePath)
+findExecutable' cmd = do
+ dir <- getEnv "PARROT_PATH"
+ if isJust dir then (do
+ rv <- findExecutableInDirectory (fromJust dir) cmd
+ if isJust rv then return rv else findExecutable'') else do
+ findExecutable''
+ where
+ findExecutable'' = do
+ rv <- findExecutable cmd
+ if isJust rv then return rv else do
+ cwd <- getCurrentDirectory
+ rv <- findExecutableInDirectory cwd cmd
+ if isJust rv then return rv else do
+ return Nothing
+
+findExecutableInDirectory :: FilePath -> FilePath -> IO (Maybe FilePath)
+findExecutableInDirectory dir cmd = do
+ let file | _PUGS_HAVE_POSIX = dir ++ ('/':cmd)
+ | otherwise = dir ++ ('\\':cmd) ++ ".exe"
+ ok <- doesFileExist file
+ return $ if ok then (Just file) else Nothing
+
+findParrot :: IO FilePath
+findParrot = do
+ rv <- findExecutable' "parrot"
+ case rv of
+ Nothing -> fail "Cannot find the parrot executable in PATH"
+ Just cmd -> return cmd
+
+evalParrotFile :: FilePath -> IO ()
+evalParrotFile file = do
+ cmd <- findParrot
+ -- parrot -j is fatal on systems where jit is not supported,
+ -- so we use the next fastest CGP core.
+ args <- getEnv "PUGS_PARROT_OPTS"
+ let args' | isJust args && fromJust args /= "" = fromJust args
+ | otherwise = "-f"
+ rawSystem cmd [args', file]
+ return ()
+
+evalParrot :: String -> IO ()
+evalParrot str = do
+ tmp <- getTemporaryDirectory
+ (file, fh) <- openTempFile tmp "pugs.pir"
+ hPutStr fh str
+ hClose fh
+ evalParrotFile file
+ removeFile file
+
+evalPGE :: FilePath -> String -> String -> [(String, String)] -> IO String
+evalPGE path match rule subrules = do
+ (inp, out, err, pid) <- initPGE path
+ (`mapM` subrules) $ \(name, rule) -> do
+ let nameStr = escape name
+ ruleStr = escape rule
+ hPutStrLn inp $ unwords
+ ["add_rule", show (length nameStr), show (length ruleStr)]
+ hPutStrLn inp nameStr
+ hPutStrLn inp ruleStr
+ let matchStr = escape match
+ ruleStr = escape rule
+ hPutStrLn inp $ unwords
+ ["match", show (length matchStr), show (length ruleStr)]
+ hPutStrLn inp $ matchStr
+ hPutStrLn inp $ ruleStr
+ hFlush inp
+ rv <- hGetLine out
+ case rv of
+ ('O':'K':' ':sizeStr) -> do
+ size <- readIO sizeStr
+ rv <- sequence (replicate size (hGetChar out))
+ ln <- hGetLine out
+ return $ rv ++ ln
+ _ -> do
+ errMsg <- hGetContents err
+ rv <- waitForProcess pid
+ writeIORef _ParrotInterp Nothing
+ let msg | null errMsg = show rv
+ | otherwise = errMsg
+ fail $ "*** Running external 'parrot' failed:\n" ++ msg
+ where
+ escape = escape . encodeUTF8
+ _escape "" = ""
+ _escape ('\\':xs) = "\\\\" ++ _escape xs
+ _escape ('\n':xs) = "\\n" ++ _escape xs
+ _escape (x:xs) = (x:_escape xs)
+
+initPGE :: FilePath -> IO ParrotInterp
+initPGE path = do
+ rv <- readIORef _ParrotInterp
+ case rv of
+ Just interp@(_, _, _, pid) -> do
+ gone <- getProcessExitCode pid
+ if isNothing gone then return interp else do
+ writeIORef _ParrotInterp Nothing
+ initPGE path
+ Nothing -> do
+ cmd <- findParrot
+ interp <- runInteractiveProcess cmd ["run_pge.pir"] (Just path) Nothing
+ writeIORef _ParrotInterp (Just interp)
+ return interp
+
+type ParrotInterp = (Handle, Handle, Handle, ProcessHandle)
+
+{-# NOINLINE _ParrotInterp #-}
+_ParrotInterp :: IORef (Maybe ParrotInterp)
+_ParrotInterp = unsafePerformIO $ newIORef Nothing
+
+_DoCompile :: Maybe (IORef (String -> FilePath -> String -> IO String))
+_DoCompile = Nothing
+
+
+{-# LINE 387 "Parrot.hsc" #-}
diff --git a/tests/examples/SegFault2.hs b/tests/examples/SegFault2.hs
new file mode 100644
index 0000000..138e055
--- /dev/null
+++ b/tests/examples/SegFault2.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE CPP #-}
+
+module UHC.Light.Compiler.CHR.Constraint
+( Constraint (..)
+, mkReduction
+, cnstrReducablePart
+, UnresolvedTrace (..)
+, cnstrMpSingletonL, cnstrMpFromList
+, ConstraintToInfoTraceMp
+, cnstrTraceMpSingleton, cnstrTraceMpLiftTrace, cnstrTraceMpElimTrace, cnstrTraceMpFromList
+, ConstraintToInfoMap
+, emptyCnstrMp
+, cnstrMpUnion, cnstrMpUnions
+, cnstrRequiresSolve )
+where
+import UHC.Light.Compiler.Base.Common
+import UHC.Light.Compiler.Ty
+import UHC.Light.Compiler.CHR
+import UHC.Light.Compiler.CHR.Key
+import UHC.Light.Compiler.Base.TreeTrie
+import UHC.Light.Compiler.Substitutable
+import UHC.Util.Pretty as PP
+import UHC.Util.Utils
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import UHC.Light.Compiler.VarMp
+import Control.Monad
+import UHC.Util.Binary
+import UHC.Util.Serialize
+import Data.Typeable
+import Data.Generics (Data)
+import UHC.Light.Compiler.Opts.Base
+
+
+
+
+{-# LINE 37 "src/ehc/CHR/Constraint.chs" #-}
+-- | A Constraint is abstracted over the exact predicate, but differentiates on the role: to prove, can be assumed, and side effect of reduction
+data Constraint p info
+ = Prove { cnstrPred :: !p } -- proof obligation
+ | Assume { cnstrPred :: !p } -- assumed constraint
+ | Reduction -- 'side effect', residual info used by (e.g.) codegeneration
+ { cnstrPred :: !p -- the pred to which reduction was done
+ , cnstrInfo :: !info -- additional reduction specific info w.r.t. codegeneration
+ , cnstrFromPreds :: ![p] -- the preds from which reduction was done
+ , cnstrVarMp :: VarMp -- additional bindings for type (etc.) variables, i.e. improving substitution
+ }
+ deriving (Eq, Ord, Show)
+
+{-# LINE 53 "src/ehc/CHR/Constraint.chs" #-}
+mkReduction :: p -> info -> [p] -> Constraint p info
+mkReduction p i ps
+ = Reduction p i ps
+ varlookupEmpty
+
+{-# LINE 62 "src/ehc/CHR/Constraint.chs" #-}
+#if __GLASGOW_HASKELL__ >= 708
+deriving instance Typeable Constraint
+#else
+deriving instance Typeable2 Constraint
+#endif
+deriving instance (Data x, Data y) => Data (Constraint x y)
+
+{-# LINE 71 "src/ehc/CHR/Constraint.chs" #-}
+-- | Dissection of Constraint, including reconstruction function
+cnstrReducablePart :: Constraint p info -> Maybe (String,p,p->Constraint p info)
+cnstrReducablePart (Prove p) = Just ("Prf",p,Prove)
+cnstrReducablePart (Assume p) = Just ("Ass",p,Assume)
+cnstrReducablePart _ = Nothing
+
+{-# LINE 84 "src/ehc/CHR/Constraint.chs" #-}
+instance (CHRMatchable env p s) => CHRMatchable env (Constraint p info) s where
+ chrMatchTo env s c1 c2
+ = do { (_,p1,_) <- cnstrReducablePart c1
+ ; (_,p2,_) <- cnstrReducablePart c2
+ ; chrMatchTo env s p1 p2
+ }
+
+{-# LINE 93 "src/ehc/CHR/Constraint.chs" #-}
+instance TTKeyable p => TTKeyable (Constraint p info) where
+ toTTKey' o c -- = maybe [] (\(s,p,_) -> ttkAdd (TT1K_One $ Key_Str s) [toTTKey' o p]) $ cnstrReducablePart c
+ = case cnstrReducablePart c of
+ Just (s,p,_) -> ttkAdd' (TT1K_One $ Key_Str s) cs
+ where (_,cs) = toTTKeyParentChildren' o p
+ _ -> panic "TTKeyable (Constraint p info).toTTKey'" -- ttkEmpty
+
+{-# LINE 102 "src/ehc/CHR/Constraint.chs" #-}
+instance (VarExtractable p v,VarExtractable info v) => VarExtractable (Constraint p info) v where
+ varFreeSet c
+ = case cnstrReducablePart c of
+ Just (_,p,_) -> varFreeSet p
+ _ -> Set.empty
+
+instance (VarUpdatable p s,VarUpdatable info s) => VarUpdatable (Constraint p info) s where
+ varUpd s (Prove p ) = Prove (varUpd s p)
+ varUpd s (Assume p ) = Assume (varUpd s p)
+ varUpd s r@(Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})
+ = r {cnstrPred=varUpd s p, cnstrInfo=varUpd s i, cnstrFromPreds=map (varUpd s) ps}
+
+{-# LINE 120 "src/ehc/CHR/Constraint.chs" #-}
+-- | The trace of an unresolved predicate
+data UnresolvedTrace p info
+ = UnresolvedTrace_None -- no trace required when all is resolved
+ | UnresolvedTrace_Red -- ok reduction, with failure deeper down
+ { utraceRedFrom :: p
+ , utraceInfoTo2From :: info
+ , utraceRedTo :: [UnresolvedTrace p info]
+ }
+ | UnresolvedTrace_Fail -- failed reduction
+ { utraceRedFrom :: p
+ -- , utraceInfoTo2From :: info
+ , utraceRedTo :: [UnresolvedTrace p info]
+ }
+ | UnresolvedTrace_Overlap -- choice could not be made
+ { utraceRedFrom :: p
+ , utraceRedChoices :: [(info,[UnresolvedTrace p info])]
+ }
+ deriving Show
+
+instance Eq p => Eq (UnresolvedTrace p info) where
+ t1 == t2 = True -- utraceRedFrom t1 == utraceRedFrom t2
+
+instance (PP p, PP info) => PP (UnresolvedTrace p info) where
+ pp x = case x of
+ UnresolvedTrace_None -> PP.empty
+ UnresolvedTrace_Red p i us -> p >|< ":" >#< i >-< indent 2 (vlist $ map pp us)
+ UnresolvedTrace_Fail p us -> p >|< ": FAIL" >-< indent 2 (vlist $ map pp us)
+ UnresolvedTrace_Overlap p uss -> p >|< ": OVERLAP" >-< indent 2 (vlist $ map (\(i,u) -> i >-< indent 2 (vlist $ map pp u)) uss)
+
+{-# LINE 155 "src/ehc/CHR/Constraint.chs" #-}
+-- | Map from constraint to something
+type ConstraintMp' p info x = Map.Map (Constraint p info) [x]
+
+{-# LINE 160 "src/ehc/CHR/Constraint.chs" #-}
+cnstrMpSingletonL :: Constraint p i -> [x] -> ConstraintMp' p i x
+cnstrMpSingletonL c xs = Map.singleton c xs
+
+cnstrMpSingleton :: Constraint p i -> x -> ConstraintMp' p i x
+cnstrMpSingleton c x = cnstrMpSingletonL c [x]
+
+cnstrMpFromList :: (Ord p, Ord i) => [(Constraint p i,x)] -> ConstraintMp' p i x
+cnstrMpFromList l = Map.fromListWith (++) [ (c,[x]) | (c,x) <- l ]
+
+cnstrMpMap :: (Ord p, Ord i) => (x -> y) -> ConstraintMp' p i x -> ConstraintMp' p i y
+cnstrMpMap f = Map.map (map f)
+
+{-# LINE 174 "src/ehc/CHR/Constraint.chs" #-}
+-- | Map from constraint to info + trace
+type ConstraintToInfoTraceMp p info = ConstraintMp' p info (info,[UnresolvedTrace p info])
+
+{-# LINE 179 "src/ehc/CHR/Constraint.chs" #-}
+cnstrTraceMpFromList :: (Ord p, Ord i) => [(Constraint p i,(i,[UnresolvedTrace p i]))] -> ConstraintToInfoTraceMp p i
+cnstrTraceMpFromList = cnstrMpFromList
+
+cnstrTraceMpSingleton :: Constraint p i -> i -> [UnresolvedTrace p i] -> ConstraintToInfoTraceMp p i
+cnstrTraceMpSingleton c i ts = cnstrMpSingleton c (i,ts)
+
+cnstrTraceMpElimTrace :: (Ord p, Ord i) => ConstraintToInfoTraceMp p i -> ConstraintToInfoMap p i
+cnstrTraceMpElimTrace = cnstrMpMap fst
+
+cnstrTraceMpLiftTrace :: (Ord p, Ord i) => ConstraintToInfoMap p i -> ConstraintToInfoTraceMp p i
+cnstrTraceMpLiftTrace = cnstrMpMap (\x -> (x,[]))
+
+{-# LINE 193 "src/ehc/CHR/Constraint.chs" #-}
+-- | Map from constraint to info
+type ConstraintToInfoMap p info = ConstraintMp' p info info
+
+{-# LINE 198 "src/ehc/CHR/Constraint.chs" #-}
+emptyCnstrMp :: ConstraintMp' p info x
+emptyCnstrMp = Map.empty
+
+{-# LINE 208 "src/ehc/CHR/Constraint.chs" #-}
+cnstrMpUnion :: (Ord p, Ord i) => ConstraintMp' p i x -> ConstraintMp' p i x -> ConstraintMp' p i x
+cnstrMpUnion = Map.unionWith (++)
+
+cnstrMpUnions :: (Ord p, Ord i) => [ConstraintMp' p i x] -> ConstraintMp' p i x
+cnstrMpUnions = Map.unionsWith (++)
+
+{-# LINE 220 "src/ehc/CHR/Constraint.chs" #-}
+-- | Predicate for whether solving is required
+cnstrRequiresSolve :: Constraint p info -> Bool
+cnstrRequiresSolve (Reduction {}) = False
+cnstrRequiresSolve _ = True
+
+{-# LINE 231 "src/ehc/CHR/Constraint.chs" #-}
+instance (PP p, PP info) => PP (Constraint p info) where
+ pp (Prove p ) = "Prove" >#< p
+ pp (Assume p ) = "Assume" >#< p
+ pp (Reduction {cnstrPred=p, cnstrInfo=i, cnstrFromPreds=ps})
+ = "Red" >#< p >#< "<" >#< i >#< "<" >#< ppBracketsCommas ps
+
+{-# LINE 243 "src/ehc/CHR/Constraint.chs" #-}
+instance (Serialize p, Serialize i) => Serialize (Constraint p i) where
+ sput (Prove a ) = sputWord8 0 >> sput a
+ sput (Assume a ) = sputWord8 1 >> sput a
+ sput (Reduction a b c d) = sputWord8 2 >> sput a >> sput b >> sput c >> sput d
+ sget = do t <- sgetWord8
+ case t of
+ 0 -> liftM Prove sget
+ 1 -> liftM Assume sget
+ 2 -> liftM4 Reduction sget sget sget sget
+
diff --git a/tests/examples/SimpleDo.hs b/tests/examples/SimpleDo.hs
new file mode 100644
index 0000000..b9ec142
--- /dev/null
+++ b/tests/examples/SimpleDo.hs
@@ -0,0 +1,4 @@
+
+foo = do
+ let x = 1 -- a comment
+ return x
diff --git a/tests/examples/TypeSignature.hs b/tests/examples/TypeSignature.hs
new file mode 100644
index 0000000..cb52d66
--- /dev/null
+++ b/tests/examples/TypeSignature.hs
@@ -0,0 +1,12 @@
+module TypeSignature where
+
+{- Lifting baz to the top level should bring in xx and a as parameters,
+ and update the signature to include these
+-}
+foo a = (baz xx a)
+ where
+ xx :: Int -> Int -> Int
+ xx p1 p2 = p1 + p2
+
+baz :: (Int -> Int -> Int) -> Int ->Int
+baz xx a = xx 1 a