diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,47 @@ +2015-03-24 v0.2 + This release contains a major rewrite of all internal modules. + + The external interface has also changed significantly. A description is + omitted. + + # Top-level changes + The most notable change is that the common structor of the modules known as + `ExactPrint` and `Annotate` has been factored out into a common module + (`Annotate`). The aforementioned modules are now known as `Delta` and + `Print` and contain functions to interpret this common structure. + + The top level module `ExactPrint` now just reexports a consistent interface + from the base modules. + + Introduced a new module `Lookup` which contains a mapping from AnnKeywordId + to their String representation. + + # Internal Changes + + `Annotate` contains all the information about which annotations appear on + each AST element. This is achieved by building up a syntax tree (using a + free monad) which can then be interpreted by programs requiring access to + this information. + + # Layout compensation + + The method which compensates for layout rules has been clarified. + + 1. When the Layout Flag is activated in `Annotate`, we mark + the current column as the start of the layout block. + + 2. This is important when we move to a new line. We take the offset at + that current point to be the baseline and calculate the correct next + position based on this. + + 3. This method is very general as one can think of a entire source file as + obeying layout rules where the offset is equal to zero. + + +2015-03-11 v0.1.1.0 + Handles indentation when the AST is edited + Major rework of internal monads by @mpickering +2015-01-28 v0.1.0.1 + Update cabal to prevent building with GHC 7.70,thanks @peti +2015-01-24 v0.1.0.0 + Initial release, for GHC 7.10 RC 2 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: ghc-exactprint -version: 0.1.1.0 +version: 0.2 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10 RC2, this library provides a means to round trip any* code that can @@ -17,18 +17,30 @@ license: BSD3 license-file: LICENSE -author: Alan Zimmerman, Matt Pickering +author: Alan Zimmerman, Matthew Pickering maintainer: alan.zimm@gmail.com -- copyright: category: Development build-type: Simple --- extra-source-files: +extra-source-files: ChangeLog + tests/examples/*.hs + tests/examples/*.hs.expected + tests/examples/*.hs-boot cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/alanz/ghc-exactprint.git + library exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.Types , Language.Haskell.GHC.ExactPrint.Utils + , Language.Haskell.GHC.ExactPrint.Delta + , Language.Haskell.GHC.ExactPrint.Lookup + , Language.Haskell.GHC.ExactPrint.Annotate + , Language.Haskell.GHC.ExactPrint.Print + GHC-Options: -Wall -- other-modules: -- other-extensions: build-depends: base >=4.7 && <4.9 @@ -40,6 +52,7 @@ , ghc-syb-utils , mtl , syb + , free hs-source-dirs: src default-language: Haskell2010 -- Note: the following constraint actually requires RC2 or better @@ -66,8 +79,5 @@ , stm , syb -source-repository head - type: git - location: https://github.com/alanz/ghc-exactprint.git diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint.hs @@ -1,2071 +1,14 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.GHC.ExactPrint --- --- Based on Language.Haskell.Exts.Annotated.ExactPrint --- ------------------------------------------------------------------------------ -module Language.Haskell.GHC.ExactPrint - ( annotateAST - , Anns - , exactPrintAnnotated - , exactPrintAnnotation - - , exactPrint - , ExactP - - ) where - -import Language.Haskell.GHC.ExactPrint.Types -import Language.Haskell.GHC.ExactPrint.Utils - -import Control.Applicative -import Control.Exception -import Control.Monad.RWS -import Data.Data -import Data.List -import Data.Maybe - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC -import qualified SrcLoc as GHC - -import qualified Data.Map as Map - --- --------------------------------------------------------------------- - --- Compatibiity types, from HSE - --- | A portion of the source, extended with information on the position of entities within the span. -data SrcSpanInfo = SrcSpanInfo - { srcInfoSpan :: GHC.SrcSpan - , srcInfoPoints :: [GHC.SrcSpan] -- Marks the location of specific entities inside the span - } - deriving (Eq,Ord,Show,Typeable,Data) - - --- | A class to work over all kinds of source location information. -class SrcInfo si where - toSrcInfo :: GHC.SrcLoc -> [GHC.SrcSpan] -> GHC.SrcLoc -> si - fromSrcInfo :: SrcSpanInfo -> si - getPointLoc :: si -> GHC.SrcLoc - fileName :: si -> String - startLine :: si -> Int - startColumn :: si -> Int - - getPointLoc si = GHC.mkSrcLoc (GHC.mkFastString $ fileName si) (startLine si) (startColumn si) - - -instance SrcInfo GHC.SrcSpan where - toSrcInfo = error "toSrcInfo GHC.SrcSpan undefined" - fromSrcInfo = error "toSrcInfo GHC.SrcSpan undefined" - - getPointLoc = GHC.srcSpanStart - - fileName (GHC.RealSrcSpan s) = GHC.unpackFS $ GHC.srcSpanFile s - fileName _ = "bad file name for SrcSpan" - - startLine = srcSpanStartLine - startColumn = srcSpanStartColumn - -class Annotated a where - ann :: a -> GHC.SrcSpan - -instance Annotated (GHC.Located a) where - ann (GHC.L l _) = l - ------------------------------------------------------- --- The EP monad and basic combinators - --- The (ColOffset,ColOffset) value carries the normal and current --- column offset. The second one captures the difference between the --- original col when the DP was captured and the current one. - -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? - -- AZ, it is already in the last element of Annotation, for withOffset - } - -data EPLocal = EPLocal - { eFunId :: (Bool, String) - , eFunIsInfix :: Bool -- AZ:Needed? is in first field of eFunId - , epStack :: (ColOffset,ColDelta) -- ^ stack of offsets that currently apply - , epSrcSpan :: GHC.SrcSpan - } - -type EP a = RWS EPLocal (Endo String) EPState a - -runEP :: EP () -> GHC.SrcSpan -> Anns -> String -runEP f ss ans = - flip appEndo "" . snd . execRWS f (defaultLocal ss) $ (defaultState ans) - -defaultState :: Anns -> EPState -defaultState as = EPState - { epPos = (1,1) - , epAnns = as - , epAnnKds = [] - } - -defaultLocal :: GHC.SrcSpan -> EPLocal -defaultLocal ss = EPLocal - { eFunId = (False, "") - , eFunIsInfix = False - , epStack = (0,0) - , epSrcSpan = ss - } - -getPos :: EP Pos -getPos = gets epPos - -setPos :: Pos -> EP () -setPos l = modify (\s -> s {epPos = l}) - --- --------------------------------------------------------------------- - --- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous --- offset --- -withOffset :: Annotation -> (EP () -> EP ()) -withOffset a@(Ann (DP (edLine, edColumn)) newline originalStartCol annDelta _) k = do - -- The colOffset is the offset to be used when going to the next line. - -- The colIndent is how far the current code block has been indented. - (colOffset, colIndent) <- asks epStack - (_l, currentColumn) <- getPos - let - -- Add extra indentation for this SrcSpan - colOffset' = annDelta + colOffset - -- Work out where new column starts, based on the entry delta - newStartColumn = if edLine == 0 - then edColumn + currentColumn -- same line, use entry delta - else colOffset -- different line, use current offset - newColIndent = newStartColumn - originalStartCol - - offsetValNewIndent = (colOffset' + (newColIndent - colIndent), newColIndent) - offsetValSameIndent = (colOffset' , colIndent) - offsetValNewline = (annDelta + colIndent, colIndent) - - newOffset = - case newline of - -- For use by AST modifiers, to preserve the indentation - -- level for the next line after an AST modification - KeepOffset -> offsetValNewline - - -- Generated during the annotation phase - LineChanged -> offsetValNewline - LayoutLineChanged -> offsetValNewline - - LineSame -> offsetValSameIndent - LayoutLineSame -> offsetValNewIndent - local (\s -> s {epStack = newOffset }) k - `debug` ("pushOffset:(a, colOffset, colIndent, currentColumn, newOffset)=" - ++ show (a, colOffset, colIndent, currentColumn, newOffset)) - --- |Get the current column offset -getOffset :: EP ColOffset -getOffset = asks (fst . epStack) - --- --------------------------------------------------------------------- - -withSrcSpan :: GHC.SrcSpan -> (EP () -> EP ()) -withSrcSpan ss = local (\s -> s {epSrcSpan = ss}) - -getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation) -getAndRemoveAnnotation a = do - (r, an') <- gets (getAndRemoveAnnotationEP a . epAnns) - modify (\s -> s { epAnns = an' }) - return r - -withKds :: [(KeywordId, DeltaPos)] -> EP () -> EP () -withKds kd action = do - modify (\s -> s { epAnnKds = kd : (epAnnKds s) }) - action - modify (\s -> s { epAnnKds = tail (epAnnKds s) }) - --- | Get and remove the first item in the (k,v) list for which the k matches. --- Return the value, together with any comments skipped over to get there. -destructiveGetFirst :: KeywordId -> ([(KeywordId,v)],[(KeywordId,v)]) - -> ([(KeywordId,v)],[v],[(KeywordId,v)]) -destructiveGetFirst _key (acc,[]) = ([],[],acc) -destructiveGetFirst key (acc,((k,v):kvs)) - | k == key = let (cs,others) = commentsAndOthers acc in (cs,[v],others++kvs) - | otherwise = destructiveGetFirst key (acc++[(k,v)],kvs) - where - commentsAndOthers kvs' = partition isComment kvs' - isComment ((AnnComment _),_) = True - isComment _ = False - --- |destructive get, hence use an annotation once only -getAnnFinal :: KeywordId -> EP ([DComment], [DeltaPos]) -getAnnFinal kw = do - kd <- gets epAnnKds - let (r, kd', dcs) = case kd of - [] -> ([],[], []) - (k:kds) -> (r',kk:kds, dcs') - where (cs', r',kk) = destructiveGetFirst kw ([],k) - dcs' = concatMap keywordIdToDComment cs' - modify (\s -> s { epAnnKds = kd' }) - return (dcs, r) - --- --------------------------------------------------------------------- - -getStoredListSrcSpan :: EP GHC.SrcSpan -getStoredListSrcSpan = do - kd <- gets epAnnKds - let - isAnnList ((AnnList _),_) = True - isAnnList _ = False - - kdf = ghead "getStoredListSrcSpan.1" kd - (AnnList ss,_) = ghead "getStoredListSrcSpan.2" $ filter isAnnList kdf - return ss - --- --------------------------------------------------------------------- - -keywordIdToDComment :: (KeywordId, DeltaPos) -> [DComment] -keywordIdToDComment (AnnComment comment,_dp) = [comment] -keywordIdToDComment _ = [] - --- |non-destructive get -peekAnnFinal :: KeywordId -> EP [DeltaPos] -peekAnnFinal kw = do - (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds) - return r - -getFunId :: EP (Bool,String) -getFunId = asks eFunId - -withFunId :: (Bool,String) -> (EP () -> EP ()) -withFunId st = local (\s -> s{eFunId = st}) - -getFunIsInfix :: EP Bool -getFunIsInfix = asks eFunIsInfix - -withFunIsInfix :: Bool -> (EP () -> EP ()) -withFunIsInfix b = local (\s -> s {eFunIsInfix = b}) - --- --------------------------------------------------------------------- - -printString :: String -> EP () -printString str = do - (l,c) <- gets epPos - setPos (l, c + length str) - tell (Endo $ showString str) - -newLine :: EP () -newLine = do - (l,_) <- getPos - printString "\n" - setPos (l+1,1) - -padUntil :: Pos -> EP () -padUntil (l,c) = do - (l1,c1) <- getPos - case {- trace (show ((l,c), (l1,c1))) -} () of - _ {-()-} | l1 >= l && c1 <= c -> printString $ replicate (c - c1) ' ' - | l1 < l -> newLine >> padUntil (l,c) - | otherwise -> return () - -printWhitespace :: Pos -> EP () -printWhitespace p = do - -- mPrintComments p >> padUntil p - padUntil p - -printStringAt :: Pos -> String -> EP () -printStringAt p str = printWhitespace p >> printString str - --- --------------------------------------------------------------------- - --- |This should be the final point where things are mode concrete, --- before output. Hence the point where comments can be inserted -printStringAtLsDelta :: [DComment] -> [DeltaPos] -> String -> EP () -printStringAtLsDelta cs mc s = - case reverse mc of - (cl:_) -> do - p <- getPos - colOffset <- getOffset - if isGoodDeltaWithOffset cl colOffset - then do - mapM_ printQueuedComment cs - printStringAt (undelta p cl colOffset) s - `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) - else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (mc,s)) - _ -> return () - - -isGoodDeltaWithOffset :: DeltaPos -> Int -> Bool -isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset)) - --- AZ:TODO: harvest the commonality between this and printStringAtLsDelta -printQueuedComment :: DComment -> EP () -printQueuedComment (DComment (dp,de) s) = do - p <- getPos - colOffset <- getOffset - let (dr,dc) = undelta (0,0) dp colOffset - if isGoodDelta (DP (dr,max 0 dc)) -- do not lose comments against the left margin - then do - printStringAt (undelta p dp colOffset) s - `debug` ("printQueuedComment:(pos,s):" ++ show (undelta p dp colOffset,s)) - setPos (undelta p de colOffset) - else return () `debug` ("printQueuedComment::bad delta for (dp,s):" ++ show (dp,s)) - --- --------------------------------------------------------------------- - -getPosForDelta :: DeltaPos -> EP Pos -getPosForDelta dp = do - p <- getPos - colOffset <- getOffset - return (undelta p dp colOffset) - --- --------------------------------------------------------------------- - -printStringAtMaybeAnn :: KeywordId -> String -> EP () -printStringAtMaybeAnn an str = do - (comments, ma) <- getAnnFinal an - printStringAtLsDelta comments ma str - `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str)) - -printStringAtMaybeAnnAll :: KeywordId -> String -> EP () -printStringAtMaybeAnnAll an str = go - where - go = do - (comments, ma) <- getAnnFinal an - case ma of - [] -> return () - [d] -> printStringAtLsDelta comments [d] str >> go - --- --------------------------------------------------------------------- - -countAnns :: KeywordId -> EP Int -countAnns an = do - ma <- peekAnnFinal an - return (length ma) - ------------------------------------------------------------------------------- --- Printing of source elements - --- | Print an AST exactly as specified by the annotations on the nodes in the tree. --- exactPrint :: (ExactP ast) => ast -> [Comment] -> String -exactPrint :: (ExactP ast) => GHC.Located ast -> String -exactPrint ast@(GHC.L l _) = runEP (exactPC ast) l Map.empty - - -exactPrintAnnotated :: - GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> String -exactPrintAnnotated ast@(GHC.L l _) ghcAnns = runEP (exactPC ast) l an - where - an = annotateLHsModule ast ghcAnns - -exactPrintAnnotation :: ExactP ast => - GHC.Located ast -> Anns -> String -exactPrintAnnotation ast@(GHC.L l _) an = runEP (exactPC ast) l an - -- `debug` ("exactPrintAnnotation:an=" ++ (concatMap (\(l,a) -> show (ss2span l,a)) $ Map.toList an )) - -annotateAST :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns -> Anns -annotateAST ast ghcAnns = annotateLHsModule ast ghcAnns - - --- --------------------------------------------------------------------- - --- |First move to the given location, then call exactP -exactPC :: (ExactP ast) => GHC.Located ast -> EP () -exactPC a@(GHC.L l ast) = - do return () `debug` ("exactPC entered for:" ++ showGhc l) - ma <- getAndRemoveAnnotation a - let an@(Ann _edp _nl _sc _dc kds) = fromMaybe annNone ma - withContext kds l an - (do - exactP ast - printStringAtMaybeAnn (G GHC.AnnComma) "," - printStringAtMaybeAnnAll AnnSemiSep ";") - epStack' <- asks epStack - return () `debug` ("popOffset:after pop:(l,epStack')=" ++ showGhc (l,epStack')) - -withContext :: [(KeywordId, DeltaPos)] - -> GHC.SrcSpan - -> Annotation - -> (EP () -> EP ()) -withContext kds l an = withKds kds . withSrcSpan l . withOffset an - --- --------------------------------------------------------------------- - -printMerged :: (ExactP a, ExactP b) => [GHC.Located a] -> [GHC.Located b] -> EP () -printMerged [] [] = return () -printMerged [] bs = mapM_ exactPC bs -printMerged as [] = mapM_ exactPC as -printMerged (a@(GHC.L l1 _):as) (b@(GHC.L l2 _):bs) = - if l1 < l2 - then exactPC a >> printMerged as (b:bs) - else exactPC b >> printMerged (a:as) bs - --- --------------------------------------------------------------------- - -prepareListPrint :: ExactP ast - => [GHC.GenLocated GHC.SrcSpan ast] -> [(GHC.SrcSpan, EP ())] -prepareListPrint ls = map (\b@(GHC.L l _) -> (l,exactPC b)) ls - -applyListPrint :: (Monad m, Ord a) => [(a, m b)] -> m () -applyListPrint ls = mapM_ (\(_,b) -> b) $ sortBy (\(a,_) (b,_) -> compare a b) ls - --- --------------------------------------------------------------------- --- Exact printing for GHC - -class (Data ast) => ExactP ast where - -- | Print an AST fragment. The correct position in output is - -- already established. - exactP :: ast -> EP () - -instance ExactP (GHC.HsModule GHC.RdrName) where - exactP (GHC.HsModule mmn mexp imps decls mdepr _haddock) = do - - case mmn of - Just (GHC.L _ mn) -> do - printStringAtMaybeAnn (G GHC.AnnModule) "module" -- `debug` ("exactP.HsModule:cs=" ++ show cs) - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn) - Nothing -> return () - - case mdepr of - Nothing -> return () - Just depr -> exactPC depr - - case mexp of - Just lexps -> do - return () `debug` ("about to exactPC lexps") - exactPC lexps - return () - Nothing -> return () - - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" -- possible leading semis - exactP imps - - mapM_ exactPC decls - - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - -- put the end of file whitespace in - printStringAtMaybeAnn (G GHC.AnnEofPos) "" - --- --------------------------------------------------------------------- - -instance ExactP GHC.WarningTxt where - exactP (GHC.WarningTxt (GHC.L _ ls) lss) = do - printStringAtMaybeAnn (G GHC.AnnOpen) ls - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - mapM_ exactPC lss - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.DeprecatedTxt (GHC.L _ ls) lss) = do - printStringAtMaybeAnn (G GHC.AnnOpen) ls - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - mapM_ exactPC lss - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.ModuleName) where - exactP mn = do - printString (GHC.moduleNameString mn) - --- --------------------------------------------------------------------- - -instance ExactP [GHC.LIE GHC.RdrName] where - exactP ies = do - printStringAtMaybeAnn (G GHC.AnnHiding) "hiding" - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - mapM_ exactPC ies - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.IE GHC.RdrName) where - exactP (GHC.IEVar ln) = do - printStringAtMaybeAnn (G GHC.AnnPattern) "pattern" - printStringAtMaybeAnn (G GHC.AnnType) "type" - exactPC ln - - exactP (GHC.IEThingAbs n) = do - printStringAtMaybeAnn (G GHC.AnnType) "type" - exactPC n - - exactP (GHC.IEThingWith n ns) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - mapM_ exactPC ns - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.IEThingAll n) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.IEModuleContents (GHC.L _ mn)) = do - printStringAtMaybeAnn (G GHC.AnnModule) "module" - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn) - - exactP x = printString ("no exactP.IE for " ++ showGhc (x)) - --- --------------------------------------------------------------------- - -instance ExactP [GHC.LImportDecl GHC.RdrName] where - exactP imps = mapM_ exactPC imps - --- --------------------------------------------------------------------- - -instance ExactP (GHC.ImportDecl GHC.RdrName) where - exactP imp = do - printStringAtMaybeAnn (G GHC.AnnImport) "import" - - printStringAtMaybeAnn (G GHC.AnnOpen) "{-# SOURCE" - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - printStringAtMaybeAnn (G GHC.AnnSafe) "safe" - printStringAtMaybeAnn (G GHC.AnnQualified) "qualified" - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp) - - case GHC.ideclAs imp of - Nothing -> return () - Just mn -> do - printStringAtMaybeAnn (G GHC.AnnAs) "as" - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.moduleNameString mn) - - case GHC.ideclHiding imp of - Nothing -> return () - Just (_,lie) -> do - -- printStringAtMaybeAnn (G GHC.AnnHiding "hiding" - exactPC lie - --- --------------------------------------------------------------------- - -doMaybe :: (Monad m) => (a -> m ()) -> Maybe a -> m () -doMaybe f ma = case ma of - Nothing -> return () - Just a -> f a - -instance ExactP (GHC.HsDecl GHC.RdrName) where - exactP decl = case decl of - GHC.TyClD d -> exactP d - GHC.InstD d -> exactP d - GHC.DerivD d -> exactP d - GHC.ValD d -> exactP d - GHC.SigD d -> exactP d - GHC.DefD d -> exactP d - GHC.ForD d -> exactP d - GHC.WarningD d -> exactP d - GHC.AnnD d -> exactP d - GHC.RuleD d -> exactP d - GHC.VectD d -> exactP d - GHC.SpliceD d -> exactP d - GHC.DocD d -> exactP d - GHC.QuasiQuoteD d -> exactP d - GHC.RoleAnnotD d -> exactP d - --- --------------------------------------------------------------------- - -instance ExactP (GHC.RoleAnnotDecl GHC.RdrName) where - exactP (GHC.RoleAnnotDecl ln mr) = do - printStringAtMaybeAnn (G GHC.AnnType) "type" - printStringAtMaybeAnn (G GHC.AnnRole) "role" - exactPC ln - mapM_ exactPC mr - -instance ExactP (Maybe GHC.Role) where - exactP Nothing = printStringAtMaybeAnn (G GHC.AnnVal) "_" - exactP (Just r) = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS $ GHC.fsFromRole r) - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsQuasiQuote GHC.RdrName) where - exactP = assert False undefined - --- --------------------------------------------------------------------- - -instance ExactP (GHC.SpliceDecl GHC.RdrName) where - exactP (GHC.SpliceDecl (GHC.L _ (GHC.HsSplice _n e)) flag) = do - case flag of - GHC.ExplicitSplice -> - printStringAtMaybeAnn (G GHC.AnnOpen) "$(" - GHC.ImplicitSplice -> - printStringAtMaybeAnn (G GHC.AnnOpen) "$$(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) ")" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.VectDecl GHC.RdrName) where - exactP (GHC.HsVect src ln e) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE" - exactPC ln - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.HsNoVect src ln) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# NOVECTORISE" - exactPC ln - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.HsVectTypeIn src _b ln mln) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" - printStringAtMaybeAnn (G GHC.AnnType) "type" - exactPC ln - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - case mln of - Nothing -> return () - Just n -> exactPC n - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.HsVectTypeOut {}) = error $ "exactP.HsVectTypeOut: only valid after type checker" - - exactP (GHC.HsVectClassIn src ln) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# VECTORISE" - printStringAtMaybeAnn (G GHC.AnnClass) "class" - exactPC ln - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.HsVectClassOut {}) = error $ "exactP.HsVectClassOut: only valid after type checker" - exactP (GHC.HsVectInstIn {}) = error $ "exactP.HsVectInstIn: not supported?" - exactP (GHC.HsVectInstOut {}) = error $ "exactP.HsVectInstOut: not supported?" - - --- --------------------------------------------------------------------- - -instance ExactP (GHC.RuleDecls GHC.RdrName) where - exactP (GHC.HsRules src rules) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - mapM_ exactPC rules - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.AnnDecl GHC.RdrName) where - exactP (GHC.HsAnnotation src prov e) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnType) "type" - printStringAtMaybeAnn (G GHC.AnnModule) "module" - case prov of - (GHC.ValueAnnProvenance n) -> exactPC n - (GHC.TypeAnnProvenance n) -> exactPC n - (GHC.ModuleAnnProvenance) -> return () - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.RuleDecl GHC.RdrName) where - exactP (GHC.HsRule ln act bndrs lhs _ rhs _) = do - exactPC ln - -- activation - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - case act of - GHC.ActiveBefore n -> printStringAtMaybeAnn (G GHC.AnnVal) (show n) - GHC.ActiveAfter n -> printStringAtMaybeAnn (G GHC.AnnVal) (show n) - _ -> return () - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - printStringAtMaybeAnn (G GHC.AnnForall) "forall" - mapM_ exactPC bndrs - printStringAtMaybeAnn (G GHC.AnnDot) "." - - exactPC lhs - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC rhs - --- --------------------------------------------------------------------- - -instance ExactP (GHC.RuleBndr GHC.RdrName) where - exactP (GHC.RuleBndr ln) = exactPC ln - exactP (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC ln - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC thing - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.WarnDecls GHC.RdrName) where - exactP (GHC.Warnings src warns) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - mapM_ exactPC warns - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.WarnDecl GHC.RdrName) where - exactP (GHC.Warning lns txt) = do - mapM_ exactPC lns - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - case txt of - -- TODO: AZ: why are we ignoring src? - GHC.WarningTxt src ls -> mapM_ exactPC ls - GHC.DeprecatedTxt src ls -> mapM_ exactPC ls - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - -instance ExactP GHC.FastString where - exactP fs = printStringAtMaybeAnn (G GHC.AnnVal) (show (GHC.unpackFS fs)) - --- --------------------------------------------------------------------- - -instance ExactP (GHC.ForeignDecl GHC.RdrName) where - exactP (GHC.ForeignImport ln typ _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L _ src))) = do - printStringAtMaybeAnn (G GHC.AnnForeign) "foreign" - printStringAtMaybeAnn (G GHC.AnnImport) "import" - - exactPC cconv - - if ll == GHC.noSrcSpan - then return () - else exactPC safety - - printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"") - exactPC ln - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - - exactP (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L _ src))) = do - printStringAtMaybeAnn (G GHC.AnnForeign) "foreign" - printStringAtMaybeAnn (G GHC.AnnExport) "export" - exactPC spec - printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ src ++ "\"") - exactPC ln - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - --- --------------------------------------------------------------------- - -instance (ExactP GHC.CExportSpec) where - exactP (GHC.CExportStatic _ cconv) = exactP cconv - --- --------------------------------------------------------------------- - -instance ExactP GHC.CCallConv where - exactP GHC.StdCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "stdcall" - exactP GHC.CCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "ccall" - exactP GHC.CApiConv = printStringAtMaybeAnn (G GHC.AnnVal) "capi" - exactP GHC.PrimCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "prim" - exactP GHC.JavaScriptCallConv = printStringAtMaybeAnn (G GHC.AnnVal) "javascript" - --- --------------------------------------------------------------------- - -instance ExactP GHC.Safety where - exactP GHC.PlayRisky = printStringAtMaybeAnn (G GHC.AnnVal) "unsafe" - exactP GHC.PlaySafe = printStringAtMaybeAnn (G GHC.AnnVal) "safe" - exactP GHC.PlayInterruptible = printStringAtMaybeAnn (G GHC.AnnVal) "interruptible" - - --- --------------------------------------------------------------------- - -instance ExactP (GHC.DerivDecl GHC.RdrName) where - exactP (GHC.DerivDecl typ mov) = do - printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving" - printStringAtMaybeAnn (G GHC.AnnInstance) "instance" - case mov of - Nothing -> return () - Just ov -> exactPC ov - exactPC typ - --- --------------------------------------------------------------------- - -instance ExactP (GHC.DefaultDecl GHC.RdrName) where - exactP (GHC.DefaultDecl typs) = do - printStringAtMaybeAnn (G GHC.AnnDefault) "default" - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - mapM_ exactPC typs - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.InstDecl GHC.RdrName) where - exactP (GHC.ClsInstD cid) = exactP cid - exactP (GHC.DataFamInstD dfid) = exactP dfid - exactP (GHC.TyFamInstD tfid) = exactP tfid - --- --------------------------------------------------------------------- - -instance ExactP GHC.OverlapMode where - exactP (GHC.NoOverlap src) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.Overlappable src) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.Overlapping src) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.Overlaps src) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - exactP (GHC.Incoherent src) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - --- --------------------------------------------------------------------- - -instance ExactP (GHC.ClsInstDecl GHC.RdrName) where - exactP (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do - printStringAtMaybeAnn (G GHC.AnnInstance) "instance" - case mov of - Nothing -> return () - Just ov -> exactPC ov - exactPC poly - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - - applyListPrint (prepareListPrint (GHC.bagToList binds) - ++ prepareListPrint sigs - ++ prepareListPrint tyfams - ++ prepareListPrint datafams - ) - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.TyFamInstDecl GHC.RdrName) where - exactP (GHC.TyFamInstDecl eqn _) = do - printStringAtMaybeAnn (G GHC.AnnType) "type" - printStringAtMaybeAnn (G GHC.AnnInstance) "instance" - exactPC eqn - --- --------------------------------------------------------------------- - -instance ExactP (GHC.DataFamInstDecl GHC.RdrName) where - exactP (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) - (GHC.HsDataDefn _nOrD _ctx _mtyp mkind cons mderivs) _) = do - printStringAtMaybeAnn (G GHC.AnnData) "data" - printStringAtMaybeAnn (G GHC.AnnNewtype) "newtype" - printStringAtMaybeAnn (G GHC.AnnInstance) "instance" - exactPC ln - mapM_ exactPC pats - - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - doMaybe exactPC mkind - - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - - mapM_ exactPC cons - doMaybe exactPC mderivs - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsBind GHC.RdrName) where - exactP (GHC.FunBind (GHC.L _ n) isInfix (GHC.MG matches _ _ _) _ _ _) = do - withFunId (isSymbolRdrName n,rdrName2String n) ( - withFunIsInfix isInfix - (mapM_ exactPC matches)) - - exactP (GHC.PatBind lhs (GHC.GRHSs grhs lb) _ty _fvs _ticks) = do - exactPC lhs - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - mapM_ exactPC grhs - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - -- exactP lb - exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) - - - exactP (GHC.VarBind _var_id _var_rhs _var_inline ) = printString "VarBind" - exactP (GHC.AbsBinds _abs_tvs _abs_ev_vars _abs_exports _abs_ev_binds _abs_binds) = printString "AbsBinds" - - exactP (GHC.PatSynBind (GHC.PSB n _fvs args def dir)) = do - printStringAtMaybeAnn (G GHC.AnnPattern) "pattern" - exactPC n - case args of - GHC.InfixPatSyn na nb -> do - exactPC na - exactPC nb - GHC.PrefixPatSyn ns -> do - mapM_ exactPC ns - - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - printStringAtMaybeAnn (G GHC.AnnLarrow) "<-" - - exactPC def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> exactPMatchGroup mg - - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.IPBind GHC.RdrName) where - exactP (GHC.IPBind en e) = do - case en of - Left n -> exactPC n - Right _i -> error $ "annotateP.IPBind:should not happen" - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC e - --- --------------------------------------------------------------------- - -instance (ExactP body) => ExactP (GHC.Match GHC.RdrName (GHC.Located body)) where - exactP (GHC.Match mln pats typ (GHC.GRHSs grhs lb)) = do - (isSym,funid) <- getFunId - isInfix <- getFunIsInfix - let - get_infix Nothing = isInfix - get_infix (Just (_,f)) = f - case (get_infix mln,pats) of - (True,[a,b]) -> do - exactPC a - case mln of - Nothing -> do - if isSym - then printStringAtMaybeAnn (G GHC.AnnFunId) funid - else printStringAtMaybeAnn (G GHC.AnnFunId) ("`"++ funid ++ "`") - Just (n,_) -> exactPC n - exactPC b - _ -> do - case mln of - Nothing -> printStringAtMaybeAnn (G GHC.AnnFunId) funid - Just (n,_) -> exactPC n - mapM_ exactPC pats - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" -- for HsLam - mapM_ exactPC typ - mapM_ exactPC grhs - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - -- exactP lb - exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.Pat GHC.RdrName) where - - exactP (GHC.WildPat _) = printStringAtMaybeAnn (G GHC.AnnVal) "_" - - exactP (GHC.VarPat n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n) - - exactP (GHC.LazyPat p) = do - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - exactPC p - - exactP (GHC.AsPat n p) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnAt) "@" - exactPC p - - exactP (GHC.ParPat p) = do - return () `debug` ("in exactP.ParPat") - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC p - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.BangPat p) = do - printStringAtMaybeAnn (G GHC.AnnBang) "!" - exactPC p - - exactP (GHC.ListPat ps _ _) = do - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - mapM_ exactPC ps - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - exactP (GHC.TuplePat pats b _) = do - if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - else printStringAtMaybeAnn (G GHC.AnnOpen) "(#" - mapM_ exactPC pats - if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - else printStringAtMaybeAnn (G GHC.AnnClose) "#)" - - exactP (GHC.PArrPat ps _) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[:" - mapM_ exactPC ps - printStringAtMaybeAnn (G GHC.AnnClose) ":]" - - exactP (GHC.ConPatIn n dets) = do - case dets of - GHC.PrefixCon args -> do - exactPC n - mapM_ exactPC args - GHC.RecCon (GHC.HsRecFields fs _) -> do - exactPC n - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - mapM_ exactPC fs - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - GHC.InfixCon a1 a2 -> do - exactPC a1 - exactPC n - exactPC a2 - - exactP (GHC.ConPatOut {}) = return () - - exactP (GHC.ViewPat e pat _) = do - exactPC e - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - exactPC pat - - exactP (GHC.SplicePat (GHC.HsSplice _ e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "$(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) ")" - - exactP (GHC.QuasiQuotePat (GHC.HsQuasiQuote n _ q)) = do - printStringAtMaybeAnn (G GHC.AnnVal) - ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]") - - exactP (GHC.LitPat lp) = do - printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lp) - - exactP (GHC.NPat ol _ _) = do - printStringAtMaybeAnn (G GHC.AnnMinus) "-" - exactPC ol - - exactP (GHC.NPlusKPat ln ol _ _) = do - exactPC ln - printStringAtMaybeAnn (G GHC.AnnVal) "+" - exactPC ol - - exactP (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do - exactPC pat - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC ty - - exactP (GHC.SigPatOut {}) = return () - exactP (GHC.CoPat {}) = return () - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsType GHC.Name) where - exactP typ = do - return () `debug` ("exactP.HsType not implemented for " ++ showGhc (typ)) - printString "HsType.Name" - -- Note: This should never appear, only the one for GHC.RdrName - assert False undefined - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsType GHC.RdrName) where - exactP (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - printStringAtMaybeAnn (G GHC.AnnForall) "forall" - mapM_ exactPC tvs - printStringAtMaybeAnn (G GHC.AnnDot) "." - - case mwc of - Nothing -> exactPC ctx - Just lwc -> exactPC (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs))) - - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - exactPC typ - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.HsTyVar n) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - exactP n - - exactP (GHC.HsAppTy t1 t2) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - exactPC t1 - exactPC t2 - - exactP (GHC.HsFunTy t1 t2) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - exactPC t1 - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - exactPC t2 - - exactP (GHC.HsListTy t) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - exactPC t - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - exactP (GHC.HsPArrTy t) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[:" - exactPC t - printStringAtMaybeAnn (G GHC.AnnClose) ":]" - - exactP (GHC.HsTupleTy _tsort ts) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - printStringAtMaybeAnn (G GHC.AnnOpen) "(#" - mapM_ exactPC ts - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - printStringAtMaybeAnn (G GHC.AnnClose) "#)" - - exactP (GHC.HsOpTy t1 (_,op) t2) = do - exactPC t1 - exactPC op - exactPC t2 - - exactP (GHC.HsParTy t1) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC t1 - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.HsIParamTy (GHC.HsIPName n) t) = do - printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ (GHC.unpackFS n)) - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC t - - exactP (GHC.HsEqTy t1 t2) = do - exactPC t1 - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - exactPC t2 - - exactP (GHC.HsKindSig t k) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC t - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC k - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote n _ss q)) = do - printStringAtMaybeAnn (G GHC.AnnVal) - ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS q) ++ "|]") - - exactP (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "$(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) ")" - - exactP (GHC.HsDocTy t d) = do - exactPC t - exactPC d - - exactP (GHC.HsBangTy b t) = do - case b of - (GHC.HsSrcBang ms (Just True) _) -> do - printStringAtMaybeAnn (G GHC.AnnOpen) (maybe "{-# UNPACK" id ms) - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - printStringAtMaybeAnn (G GHC.AnnBang) "!" - (GHC.HsSrcBang ms (Just False) _) -> do - printStringAtMaybeAnn (G GHC.AnnOpen) (maybe "{-# NOUNPACK" id ms) - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - printStringAtMaybeAnn (G GHC.AnnBang) "!" - _ -> do - printStringAtMaybeAnn (G GHC.AnnBang) "!" - exactPC t - - exactP (GHC.HsRecTy cons) = do - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - mapM_ exactPC cons - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.HsCoreTy _t) = return () - - exactP (GHC.HsExplicitListTy _ ts) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - printStringAtMaybeAnn (G GHC.AnnOpen) "'[" - mapM_ exactPC ts - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - exactP (GHC.HsExplicitTupleTy _ ts) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - printStringAtMaybeAnn (G GHC.AnnOpen) "'(" - mapM_ exactPC ts - printStringAtMaybeAnn (G GHC.AnnClose) ")" - - exactP (GHC.HsTyLit lit) = do - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" -- for HsKind, aliased to HsType - case lit of - (GHC.HsNumTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s - (GHC.HsStrTy s _) -> printStringAtMaybeAnn (G GHC.AnnVal) s - - exactP (GHC.HsWrapTy _ _) = return () - - exactP GHC.HsWildcardTy = do - printStringAtMaybeAnn (G GHC.AnnVal) "_" - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" -- if only part of a partial type signature context - - exactP (GHC.HsNamedWildcardTy n) = do - printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n) - --- --------------------------------------------------------------------- - -instance ExactP GHC.HsDocString where - exactP (GHC.HsDocString s) = do - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS s) - -instance ExactP (GHC.ConDeclField GHC.RdrName) where - exactP (GHC.ConDeclField ns ty mdoc) = do - mapM_ exactPC ns - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC ty - case mdoc of - Just doc -> exactPC doc - Nothing -> return () - -instance ExactP (GHC.HsContext GHC.RdrName) where - exactP typs = do - -- printStringAtMaybeAnn (G GHC.AnnUnit "()" - - printStringAtMaybeAnn (G GHC.AnnDeriving) "deriving" - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - mapM_ exactPC typs - -- printStringAtMaybeAnn (G GHC.AnnUnit "()" - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - -instance (ExactP body) => ExactP (GHC.GRHS GHC.RdrName (GHC.Located body)) where - exactP (GHC.GRHS guards expr) = do - printStringAtMaybeAnn (G GHC.AnnVbar) "|" - mapM_ exactPC guards - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" -- in a case - exactPC expr - -instance (ExactP body) - => ExactP (GHC.Stmt GHC.RdrName (GHC.Located body)) where - - exactP (GHC.LastStmt body _) = exactPC body - `debug` ("exactP.LastStmt") - - exactP (GHC.BindStmt pat body _ _) = do - exactPC pat - printStringAtMaybeAnn (G GHC.AnnLarrow) "<-" - exactPC body - printStringAtMaybeAnn (G GHC.AnnVbar) "|" -- possible in list comprehension - - exactP (GHC.BodyStmt e _ _ _) = do - exactPC e - - exactP (GHC.LetStmt lb) = do - printStringAtMaybeAnn (G GHC.AnnLet) "let" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.ParStmt pbs _ _) = do - mapM_ exactPParStmtBlock pbs - - exactP (GHC.TransStmt form stmts _b using by _ _ _) = do - mapM_ exactPC stmts - case form of - GHC.ThenForm -> do - printStringAtMaybeAnn (G GHC.AnnThen) "then" - exactPC using - printStringAtMaybeAnn (G GHC.AnnBy) "by" - case by of - Just b -> exactPC b - Nothing -> return () - GHC.GroupForm -> do - printStringAtMaybeAnn (G GHC.AnnThen) "then" - printStringAtMaybeAnn (G GHC.AnnGroup) "group" - printStringAtMaybeAnn (G GHC.AnnBy) "by" - case by of - Just b -> exactPC b - Nothing -> return () - printStringAtMaybeAnn (G GHC.AnnUsing) "using" - exactPC using - - exactP (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do - printStringAtMaybeAnn (G GHC.AnnRec) "rec" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - mapM_ exactPC stmts - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -exactPParStmtBlock :: GHC.ParStmtBlock GHC.RdrName GHC.RdrName -> EP () -exactPParStmtBlock (GHC.ParStmtBlock stmts _ns _) = do - mapM_ exactPC stmts - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsExpr GHC.RdrName) where - exactP (GHC.HsVar v) = exactP v - exactP (GHC.HsIPVar (GHC.HsIPName v)) = do - printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS v) - exactP (GHC.HsOverLit lit) = exactP lit - exactP (GHC.HsLit lit) = exactP lit - exactP (GHC.HsLam match) = do - printStringAtMaybeAnn (G GHC.AnnLam) "\\" - exactPMatchGroup match - exactP (GHC.HsLamCase _ match) = exactPMatchGroup match - exactP (GHC.HsApp e1 e2) = exactPC e1 >> exactPC e2 - exactP (GHC.OpApp e1 op _f e2) = exactPC e1 >> exactPC op >> exactPC e2 - - exactP (GHC.NegApp e _) = do - printStringAtMaybeAnn (G GHC.AnnMinus) "-" - exactPC e - - exactP (GHC.HsPar e) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.SectionL e1 e2) = exactPC e1 >> exactPC e2 - exactP (GHC.SectionR e1 e2) = exactPC e1 >> exactPC e2 - - exactP (GHC.ExplicitTuple args b) = do - if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - else printStringAtMaybeAnn (G GHC.AnnOpen) "(#" - - mapM_ exactPC args `debug` ("exactP.ExplicitTuple") - - if b == GHC.Boxed then printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - else printStringAtMaybeAnn (G GHC.AnnClose) "#)" - - exactP (GHC.HsCase e1 matches) = do - printStringAtMaybeAnn (G GHC.AnnCase) "case" - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnOf) "of" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - exactPMatchGroup matches - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.HsIf _ e1 e2 e3) = do - printStringAtMaybeAnn (G GHC.AnnIf) "if" - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnSemi) ";" - printStringAtMaybeAnn (G GHC.AnnThen) "then" - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnSemi) ";" - printStringAtMaybeAnn (G GHC.AnnElse) "else" - exactPC e3 - - exactP (GHC.HsMultiIf _ rhs) = do - printStringAtMaybeAnn (G GHC.AnnIf) "if" - mapM_ exactPC rhs - - exactP (GHC.HsLet lb e) = do - return () `debug` ("exactP.HsLet started") - printStringAtMaybeAnn (G GHC.AnnLet) "let" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) - return () `debug` ("exactP.HsLet lb done") - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - printStringAtMaybeAnn (G GHC.AnnIn) "in" - exactPC e - return () `debug` ("exactP.HsLet ended") - - exactP (GHC.HsDo cts stmts _typ) = do - printStringAtMaybeAnn (G GHC.AnnDo) "do" - let (ostr,cstr,isComp) = - if isListComp cts - then case cts of - GHC.PArrComp -> ("[:",":]",True) - _ -> ("[", "]",True) - else ("{","}",False) - - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - printStringAtMaybeAnn (G GHC.AnnOpen) ostr - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - if isComp - then do - exactPC(last stmts) - printStringAtMaybeAnn (G GHC.AnnVbar) "|" - mapM_ exactPC (init stmts) - else do - ss <- getStoredListSrcSpan - exactPC (GHC.L ss stmts) - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - printStringAtMaybeAnn (G GHC.AnnClose) cstr - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.ExplicitList _ _ es) = do - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - mapM_ exactPC es - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - exactP (GHC.ExplicitPArr _ es) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[:" - mapM_ exactPC es - printStringAtMaybeAnn (G GHC.AnnClose) ":]" - - exactP (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - mapM_ exactPC fs - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - -- TODO: AZ: cons are not processed - exactP (GHC.RecordUpd e (GHC.HsRecFields fs _) cons _ _) = do - exactPC e - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - mapM_ exactPC fs - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.ExprWithTySig e typ _) = do - exactPC e - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - - exactP (GHC.ExprWithTySigOut e typ) = do - exactPC e - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - - exactP (GHC.ArithSeq _ _ seqInfo) = do - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - case seqInfo of - GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - GHC.FromTo e1 e2 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - exactPC e2 - GHC.FromThen e1 e2 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnComma) "," - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - GHC.FromThenTo e1 e2 e3 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnComma) "," - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - exactPC e3 - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - - exactP (GHC.PArrSeq _ seqInfo) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[:" - case seqInfo of - GHC.From e1 -> exactPC e1 >> printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - GHC.FromTo e1 e2 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - exactPC e2 - GHC.FromThen e1 e2 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnComma) "," - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - GHC.FromThenTo e1 e2 e3 -> do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnComma) "," - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - exactPC e3 - printStringAtMaybeAnn (G GHC.AnnClose) ":]" - - exactP (GHC.HsSCC src str e) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# SCC" - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str) - printStringAtMaybeAnn (G GHC.AnnValStr) ("\"" ++ GHC.unpackFS str ++ "\"") - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - exactPC e - - exactP (GHC.HsCoreAnn src str e) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# CORE" - printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS str) - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - exactPC e - - exactP (GHC.HsBracket (GHC.VarBr single v)) = do - if single then printStringAtMaybeAnn (G GHC.AnnVal) ("'" ++ rdrName2String v) - else printStringAtMaybeAnn (G GHC.AnnVal) ("''" ++ rdrName2String v) - exactP (GHC.HsBracket (GHC.DecBrL ds)) = do - cnt <- countAnns (G GHC.AnnOpen) - case cnt of - 1 -> do - printStringAtMaybeAnn (G GHC.AnnOpen) "[d|" - mapM_ exactPC ds - printStringAtMaybeAnn (G GHC.AnnClose) "|]" - _ -> do - printStringAtMaybeAnn (G GHC.AnnOpen) "[d|" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - mapM_ exactPC ds - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - printStringAtMaybeAnn (G GHC.AnnClose) "|]" - exactP (GHC.HsBracket (GHC.ExpBr e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[|" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "|]" - exactP (GHC.HsBracket (GHC.TExpBr e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[||" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "||]" - exactP (GHC.HsBracket (GHC.TypBr e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[t|" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "|]" - exactP (GHC.HsBracket (GHC.PatBr e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "[p|" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) "|]" - - exactP (GHC.HsRnBracketOut _ _) = return () - exactP (GHC.HsTcBracketOut _ _) = return () - - exactP (GHC.HsSpliceE False (GHC.HsSplice _ e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "$(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) ")" - exactP (GHC.HsSpliceE True (GHC.HsSplice _ e)) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "$$(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnClose) ")" - - exactP (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote n _ str)) = do - printStringAtMaybeAnn (G GHC.AnnVal) - ("[" ++ (rdrName2String n) ++ "|" ++ (GHC.unpackFS str) ++ "|]") - - exactP (GHC.HsProc p c) = do - printStringAtMaybeAnn (G GHC.AnnProc) "proc" - exactPC p - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - exactPC c - - exactP (GHC.HsStatic e) = do - printStringAtMaybeAnn (G GHC.AnnStatic) "static" - exactPC e - - exactP (GHC.HsArrApp e1 e2 _ _ _) = do - exactPC e1 - -- only one of the next 4 will be resent - printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<" - printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-" - printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<" - printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-" - - exactPC e2 - - exactP (GHC.HsArrForm e _ cs) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "(|" - exactPC e - mapM_ exactPC cs - printStringAtMaybeAnn (G GHC.AnnClose) "|)" - - exactP (GHC.HsTick _ _) = return () - exactP (GHC.HsBinTick _ _ _) = return () - - exactP (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - printStringAtMaybeAnn (G GHC.AnnOpen) src -- "{-# GENERATED" - printStringAtMaybeAnn (G GHC.AnnVal) (show $ GHC.unpackFS str) - printStringAtMaybeAnn (G GHC.AnnVal) (show v1) - printStringAtMaybeAnn (G GHC.AnnColon) ":" - printStringAtMaybeAnn (G GHC.AnnVal) (show v2) - printStringAtMaybeAnn (G GHC.AnnMinus) "-" - printStringAtMaybeAnn (G GHC.AnnVal) (show v3) - printStringAtMaybeAnn (G GHC.AnnColon) ":" - printStringAtMaybeAnn (G GHC.AnnVal) (show v4) - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - exactPC e - - exactP (GHC.EWildPat) = printStringAtMaybeAnn (G GHC.AnnVal) "_" - - exactP (GHC.EAsPat n e) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnAt) "@" - exactPC e - - exactP (GHC.EViewPat e1 e2) = do - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - exactPC e2 - - exactP (GHC.ELazyPat e) = do - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - exactPC e - - exactP (GHC.HsType ty) = exactPC ty - exactP (GHC.HsWrap _ _) = return () - exactP (GHC.HsUnboundVar _) = return () - - exactP e = printString "HsExpr" - `debug` ("exactP.HsExpr:not processing " ++ (showGhc e) ) - --- --------------------------------------------------------------------- - -instance ExactP ([GHC.ExprLStmt GHC.RdrName]) where - exactP ls = mapM_ exactPC ls - --- --------------------------------------------------------------------- - -instance (ExactP arg) => ExactP (GHC.HsRecField GHC.RdrName (GHC.Located arg)) where - exactP (GHC.HsRecField n e _) = do - exactPC n - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC e - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsCmdTop GHC.RdrName) where - exactP (GHC.HsCmdTop cmd _ _ _) = exactPC cmd - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsCmd GHC.RdrName) where - exactP (GHC.HsCmdArrApp e1 e2 _ _ _) = do - exactPC e1 - -- only one of the next 4 will be resent - printStringAtMaybeAnn (G GHC.Annlarrowtail) "-<" - printStringAtMaybeAnn (G GHC.Annrarrowtail) ">-" - printStringAtMaybeAnn (G GHC.AnnLarrowtail) "-<<" - printStringAtMaybeAnn (G GHC.AnnRarrowtail) ">>-" - - exactPC e2 - - exactP (GHC.HsCmdArrForm e _ cs) = do - printStringAtMaybeAnn (G GHC.AnnOpen) "(|" - exactPC e - mapM_ exactPC cs - printStringAtMaybeAnn (G GHC.AnnClose) "|)" - - exactP (GHC.HsCmdApp e1 e2) = exactPC e1 >> exactPC e2 - - exactP (GHC.HsCmdLam match) = do - printStringAtMaybeAnn (G GHC.AnnLam) "\\" - exactPMatchGroup match - - exactP (GHC.HsCmdPar e) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC e - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - - exactP (GHC.HsCmdCase e1 matches) = do - printStringAtMaybeAnn (G GHC.AnnCase) "case" - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnOf) "of" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactPMatchGroup matches - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.HsCmdIf _ e1 e2 e3) = do - printStringAtMaybeAnn (G GHC.AnnIf) "if" - exactPC e1 - printStringAtMaybeAnn (G GHC.AnnSemi) ";" - printStringAtMaybeAnn (G GHC.AnnThen) "then" - exactPC e2 - printStringAtMaybeAnn (G GHC.AnnSemi) ";" - printStringAtMaybeAnn (G GHC.AnnElse) "else" - exactPC e3 - - exactP (GHC.HsCmdLet lb e) = do - printStringAtMaybeAnn (G GHC.AnnLet) "let" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - -- exactP lb - exactPC (GHC.L (getLocalBindsSrcSpan lb) lb) - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - printStringAtMaybeAnn (G GHC.AnnIn) "in" - exactPC e - - exactP (GHC.HsCmdDo stmts _typ) = do - printStringAtMaybeAnn (G GHC.AnnDo) "do" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - -- mapM_ exactPC stmts - ss <- getStoredListSrcSpan - exactPC (GHC.L ss stmts) - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - - exactP (GHC.HsCmdCast {}) = error $ "exactP.HsCmdCast: only valid after type checker" - --- --------------------------------------------------------------------- - -instance ExactP [GHC.CmdLStmt GHC.RdrName] where - exactP ls = mapM_ exactPC ls - --- --------------------------------------------------------------------- - -instance ExactP GHC.RdrName where - exactP n = do - case rdrName2String n of - "[]" -> do - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - "()" -> do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - "(##)" -> do - printStringAtMaybeAnn (G GHC.AnnOpen) "(#" - printStringAtMaybeAnn (G GHC.AnnClose) "#)" - "[::]" -> do - printStringAtMaybeAnn (G GHC.AnnOpen) "[:" - printStringAtMaybeAnn (G GHC.AnnClose) ":]" - str -> do - printStringAtMaybeAnn (G GHC.AnnType) "type" - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - printStringAtMaybeAnn (G GHC.AnnBackquote) "`" - printStringAtMaybeAnn (G GHC.AnnTildehsh) "~#" - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - printStringAtMaybeAnn (G GHC.AnnVal) str - printStringAtMaybeAnn (G GHC.AnnBackquote) "`" - printStringAtMaybeAnnAll (G GHC.AnnCommaTuple) "," -- For '(,,,)' - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - return () `debug` ("exactP.RdrName:n=" ++ str) - -instance ExactP GHC.HsIPName where - exactP (GHC.HsIPName n) = do - printStringAtMaybeAnn (G GHC.AnnVal) ("?" ++ GHC.unpackFS n) - --- --------------------------------------------------------------------- - -exactPMatchGroup :: (ExactP body) => (GHC.MatchGroup GHC.RdrName (GHC.Located body)) - -> EP () -exactPMatchGroup (GHC.MG matches _ _ _) = do - ss <- getStoredListSrcSpan - exactPC (GHC.L ss matches) - --- --------------------------------------------------------------------- - -instance ExactP body => (ExactP [GHC.LMatch GHC.RdrName (GHC.Located body)]) where - exactP ls = mapM_ exactPC ls - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsTupArg GHC.RdrName) where - exactP (GHC.Missing _) = do - printStringAtMaybeAnn (G GHC.AnnComma) "," - return () - exactP (GHC.Present e) = do - exactPC e - printStringAtMaybeAnn (G GHC.AnnComma) "," - -instance ExactP (GHC.HsLocalBinds GHC.RdrName) where - exactP (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do - printMerged (GHC.bagToList binds) sigs - exactP (GHC.HsValBinds (GHC.ValBindsOut _binds _sigs)) = printString "ValBindsOut" - exactP (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ exactPC binds - exactP (GHC.EmptyLocalBinds) = return () - --- --------------------------------------------------------------------- - -instance ExactP (GHC.Sig GHC.RdrName) where - exactP (GHC.TypeSig lns typ _) = do - mapM_ exactPC lns - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - - exactP (GHC.PatSynSig n (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do - printStringAtMaybeAnn (G GHC.AnnPattern) "pattern" - exactPC n - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - - -- Note: The 'forall' bndrs '.' may occur multiple times - printStringAtMaybeAnn (G GHC.AnnForall) "forall" - mapM_ exactPC bndrs - printStringAtMaybeAnn (G GHC.AnnDot) "." - - exactPC ctx1 - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - exactPC ctx2 - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - exactPC typ - - exactP (GHC.GenericSig ns typ) = do - printStringAtMaybeAnn (G GHC.AnnDefault) "default" - mapM_ exactPC ns - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC typ - - exactP (GHC.IdSig _) = return () - - exactP (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do - let fixstr = case fdir of - GHC.InfixL -> "infixl" - GHC.InfixR -> "infixr" - GHC.InfixN -> "infix" - printStringAtMaybeAnn (G GHC.AnnInfix) fixstr - printStringAtMaybeAnn (G GHC.AnnVal) (show v) - mapM_ exactPC lns - - exactP (GHC.InlineSig n inl) = do - let actStr = case GHC.inl_act inl of - GHC.NeverActive -> "" - GHC.AlwaysActive -> "" - GHC.ActiveBefore np -> show np - GHC.ActiveAfter np -> show np - printStringAtMaybeAnn (G GHC.AnnOpen) (GHC.inl_src inl) -- "{-# INLINE" - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - printStringAtMaybeAnn (G GHC.AnnVal) actStr - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - exactPC n - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - - exactP (GHC.SpecSig n typs inl) = do - printStringAtMaybeAnn (G GHC.AnnOpen) (GHC.inl_src inl) -- "{-# SPECIALISE" - printStringAtMaybeAnn (G GHC.AnnOpenS) "[" - printStringAtMaybeAnn (G GHC.AnnTilde) "~" - printStringAtMaybeAnn (G GHC.AnnVal) "TODO:what here?" -- e.g. 34 - printStringAtMaybeAnn (G GHC.AnnCloseS) "]" - exactPC n - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - mapM_ exactPC typs - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - - - exactP _ = printString "Sig" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsOverLit GHC.RdrName) where - exactP ol = do - case GHC.ol_val ol of - GHC.HsIntegral src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src - GHC.HsFractional l -> printStringAtMaybeAnn (G GHC.AnnVal) (GHC.fl_text l) - GHC.HsIsString src _ -> printStringAtMaybeAnn (G GHC.AnnVal) src - --- --------------------------------------------------------------------- - -instance ExactP GHC.HsLit where - exactP lit = printStringAtMaybeAnn (G GHC.AnnVal) (hsLit2String lit) - -hsLit2String :: GHC.HsLit -> GHC.SourceText -hsLit2String lit = - case lit of - GHC.HsChar src _ -> src - GHC.HsCharPrim src _ -> src - GHC.HsString src _ -> src - GHC.HsStringPrim src _ -> src - GHC.HsInt src _ -> src - GHC.HsIntPrim src _ -> src - GHC.HsWordPrim src _ -> src - GHC.HsInt64Prim src _ -> src - GHC.HsWord64Prim src _ -> src - GHC.HsInteger src _ _ -> src - GHC.HsRat (GHC.FL src _) _ -> src - GHC.HsFloatPrim (GHC.FL src _) -> src - GHC.HsDoublePrim (GHC.FL src _) -> src - --- --------------------------------------------------------------------- - - -instance ExactP (GHC.TyClDecl GHC.RdrName) where - exactP (GHC.FamDecl famdecl) = exactP famdecl - - exactP (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do - printStringAtMaybeAnn (G GHC.AnnType) "type" - exactPC ln - mapM_ exactPC tyvars - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC typ - - exactP (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) - (GHC.HsDataDefn _nOrD ctx mctyp mkind cons mderivs) _) = do - printStringAtMaybeAnn (G GHC.AnnData) "data" - printStringAtMaybeAnn (G GHC.AnnNewtype) "newtype" - doMaybe exactPC mctyp - exactPC ctx - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - printTyClass ln tyVars - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - doMaybe exactPC mkind - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - mapM_ exactPC cons - doMaybe exactPC mderivs - - exactP (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds - sigs meths ats atdefs docs _) = do - printStringAtMaybeAnn (G GHC.AnnClass) "class" - exactPC ctx - printTyClass ln tyVars - printStringAtMaybeAnn (G GHC.AnnVbar) "|" - mapM_ exactPC fds - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - printStringAtMaybeAnnAll (G GHC.AnnSemi) ";" - - applyListPrint (prepareListPrint sigs - ++ prepareListPrint (GHC.bagToList meths) - ++ prepareListPrint ats - ++ prepareListPrint atdefs - ++ prepareListPrint docs - ) - - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -printTyClass :: (ExactP ast, ExactP ast1) - => GHC.Located ast -> [GHC.Located ast1] -> EP () -printTyClass ln tyVars = do - printStringAtMaybeAnnAll (G GHC.AnnOpenP) "(" - applyListPrint (prepareListPrint [ln] - ++ prepareListPrint (take 2 tyVars)) - -- exactPC ln - printStringAtMaybeAnnAll (G GHC.AnnCloseP) ")" - mapM_ exactPC (drop 2 tyVars) - --- --------------------------------------------------------------------- - -instance ExactP (GHC.FamilyDecl GHC.RdrName) where - exactP (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do - printStringAtMaybeAnn (G GHC.AnnType) "type" - printStringAtMaybeAnn (G GHC.AnnData) "data" - printStringAtMaybeAnn (G GHC.AnnFamily) "family" - exactPC ln - mapM_ exactPC tyvars - case mkind of - Nothing -> return () - Just k -> exactPC k - printStringAtMaybeAnn (G GHC.AnnWhere) "where" - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - case info of - GHC.ClosedTypeFamily eqns -> mapM_ exactPC eqns - _ -> return () - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.TyFamDefltEqn GHC.RdrName) where - exactP = assert False undefined - --- --------------------------------------------------------------------- - -instance ExactP (GHC.TyFamInstEqn GHC.RdrName) where - exactP (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do - exactPC ln - mapM_ exactPC pats - printStringAtMaybeAnn (G GHC.AnnEqual) "=" - exactPC typ - --- --------------------------------------------------------------------- - -instance ExactP GHC.DocDecl where - exactP (GHC.DocCommentNext (GHC.HsDocString fs)) - = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs) - exactP (GHC.DocCommentPrev (GHC.HsDocString fs)) - = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs) - exactP (GHC.DocCommentNamed _s (GHC.HsDocString fs)) - = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs) - exactP (GHC.DocGroup _i (GHC.HsDocString fs)) - = printStringAtMaybeAnn (G GHC.AnnVal) (GHC.unpackFS fs) - --- --------------------------------------------------------------------- - -instance ExactP (GHC.FunDep (GHC.Located GHC.RdrName)) where - exactP (ls,rs) = do - mapM_ exactPC ls - printStringAtMaybeAnn (G GHC.AnnRarrow) "->" - mapM_ exactPC rs - --- --------------------------------------------------------------------- - -instance ExactP (GHC.HsTyVarBndr GHC.RdrName) where - exactP (GHC.UserTyVar n) = printStringAtMaybeAnn (G GHC.AnnVal) (rdrName2String n) - exactP (GHC.KindedTyVar n ty) = do - printStringAtMaybeAnn (G GHC.AnnOpenP) "(" - exactPC n - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - exactPC ty - printStringAtMaybeAnn (G GHC.AnnCloseP) ")" - --- --------------------------------------------------------------------- - -instance ExactP [GHC.LConDecl GHC.RdrName] where - exactP cons = mapM_ exactPC cons - --- --------------------------------------------------------------------- - -instance ExactP (GHC.ConDecl GHC.RdrName) where - exactP (GHC.ConDecl lns _exp (GHC.HsQTvs _ns bndrs) ctx dets res _ _) = do - case res of - GHC.ResTyH98 -> do - printStringAtMaybeAnn (G GHC.AnnForall) "forall" - mapM_ exactPC bndrs - printStringAtMaybeAnn (G GHC.AnnDot) "." - - exactPC ctx - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - - -- only do names if not infix - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ exactPC lns - - case dets of - GHC.PrefixCon args -> mapM_ exactPC args - GHC.RecCon fs -> do - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactPC fs - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - GHC.InfixCon a1 a2 -> do - exactPC a1 - mapM_ exactPC lns - exactPC a2 - - - GHC.ResTyGADT ls ty -> do - -- only do names if not infix - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ exactPC lns - - case dets of - GHC.PrefixCon args -> mapM_ exactPC args - GHC.RecCon fs -> do - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - exactPC fs - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - GHC.InfixCon a1 a2 -> do - exactPC a1 - mapM_ exactPC lns - exactPC a2 - - printStringAtMaybeAnn (G GHC.AnnDcolon) "::" - - exactPC (GHC.L ls (ResTyGADTHook bndrs)) - - exactPC ctx - printStringAtMaybeAnn (G GHC.AnnDarrow) "=>" - exactPC ty - - printStringAtMaybeAnn (G GHC.AnnVbar) "|" - --- --------------------------------------------------------------------- - -instance ExactP (ResTyGADTHook GHC.RdrName) where - exactP (ResTyGADTHook bndrs) = do - printStringAtMaybeAnn (G GHC.AnnForall) "forall" - mapM_ exactPC bndrs - printStringAtMaybeAnn (G GHC.AnnDot) "." - --- --------------------------------------------------------------------- - -instance ExactP [GHC.LConDeclField GHC.RdrName] where - exactP fs = do - printStringAtMaybeAnn (G GHC.AnnOpenC) "{" - mapM_ exactPC fs - printStringAtMaybeAnn (G GHC.AnnDotdot) ".." - printStringAtMaybeAnn (G GHC.AnnCloseC) "}" - --- --------------------------------------------------------------------- - -instance ExactP (GHC.CType) where - exactP (GHC.CType src mh f) = do - printStringAtMaybeAnn (G GHC.AnnOpen) src - case mh of - Nothing -> return () - Just (GHC.Header h) -> - printStringAtMaybeAnn (G GHC.AnnHeader) ("\"" ++ GHC.unpackFS h ++ "\"") - printStringAtMaybeAnn (G GHC.AnnVal) ("\"" ++ GHC.unpackFS f ++ "\"") - printStringAtMaybeAnn (G GHC.AnnClose) "#-}" - --- --------------------------------------------------------------------- - - +module Language.Haskell.GHC.ExactPrint + ( -- * Relativising + relativiseApiAnns + , Anns + + -- * Printing + , exactPrintWithAnns + , exactPrint + + ) where + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Delta +import Language.Haskell.GHC.ExactPrint.Print diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs @@ -0,0 +1,1961 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Language.Haskell.GHC.ExactPrint.Annotate + ( + markLocated + , AnnotationF(..) + , Annotated + , Annotate(..)) where + +import Control.Exception (assert) +import Data.Data (Data) +import Data.List (sort, sortBy) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils (rdrName2String, showGhc, isListComp, debug) + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified Outputable as GHC +import qualified SrcLoc as GHC + + +import Control.Monad.Trans.Free +import Control.Monad.Free.TH (makeFreeCon) + +-- --------------------------------------------------------------------- + + +data AnnotationF next where + MarkEOF :: next -> AnnotationF next + MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next + MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next + MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next + MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next + MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next + MarkAfter :: GHC.AnnKeywordId -> next -> AnnotationF next + WithAST :: Data a => GHC.Located a -> LayoutFlag -> Annotated b -> next -> AnnotationF next + CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next + -- Abstraction breakers + SetLayoutFlag :: GHC.AnnKeywordId -> Annotated () -> next -> AnnotationF next + OutputKD :: (DeltaPos, (GHC.SrcSpan, KeywordId)) -> next -> AnnotationF next + +deriving instance Functor (AnnotationF) + + +type Annotated = Free AnnotationF + +-- --------------------------------------------------------------------- + +makeFreeCon 'OutputKD +makeFreeCon 'MarkEOF +makeFreeCon 'MarkPrim +makeFreeCon 'MarkOutside +makeFreeCon 'MarkInside +makeFreeCon 'MarkExternal +makeFreeCon 'MarkMany +makeFreeCon 'MarkOffsetPrim +makeFreeCon 'MarkAfter +makeFreeCon 'CountAnns +makeFreeCon 'SetLayoutFlag +-- --------------------------------------------------------------------- +-- Additional smart constructors + +mark :: GHC.AnnKeywordId -> Annotated () +mark kwid = markPrim kwid Nothing + +markWithString :: GHC.AnnKeywordId -> String -> Annotated () +markWithString kwid s = markPrim kwid (Just s) + +markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () +markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) + +markOffset :: GHC.AnnKeywordId -> Int -> Annotated () +markOffset kwid n = markOffsetPrim kwid n Nothing + +withAST :: Data a => GHC.Located a -> LayoutFlag -> Annotated () -> Annotated () +withAST lss layout action = liftF (WithAST lss layout prog ()) + where + prog = do + action + -- Automatically add any trailing comma or semi + markAfter GHC.AnnComma + 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 NoLayoutRules markAST + +withLocated :: Data a + => GHC.Located a + -> LayoutFlag + -> (GHC.SrcSpan -> a -> Annotated ()) + -> Annotated () +withLocated a@(GHC.L l ast) layoutFlag action = + withAST a layoutFlag (action l ast) + +markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () +markMaybe Nothing = return () +markMaybe (Just ast) = markLocated ast + +markList :: (Annotate ast) => [GHC.Located ast] -> Annotated () +markList xs = mapM_ markLocated xs + +-- | Flag the item to be annotated as requiring layout. +markWithLayout :: Annotate ast => GHC.Located ast -> Annotated () +markWithLayout a = withLocated a LayoutRules markAST + +markListWithLayout :: Annotate [GHC.Located ast] => GHC.SrcSpan -> [GHC.Located ast] -> Annotated () +markListWithLayout l ls = do + let ss = getListSrcSpan ls + outputKD $ ((DP (0,0)), (l,AnnList ss)) + markWithLayout (GHC.L ss ls) + +-- --------------------------------------------------------------------- +-- Managing lists which have been separated, e.g. Sigs and Binds + +prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] +prepareListAnnotation ls = map (\b@(GHC.L l _) -> (l,markLocated b)) ls + +applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () +applyListAnnotations ls + = mapM_ snd $ sortBy (\(a,_) (b,_) -> compare a b) ls + +-- --------------------------------------------------------------------- + +class Data ast => Annotate ast where + markAST :: GHC.SrcSpan -> ast -> Annotated () + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.HsModule GHC.RdrName) where + markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do + + + case mmn of + Nothing -> return () + Just (GHC.L ln mn) -> do + mark GHC.AnnModule + markExternal ln GHC.AnnVal (GHC.moduleNameString mn) + + case mdepr of + Nothing -> return () + Just depr -> markLocated depr + + case mexp of + Nothing -> return () + Just expr -> markLocated expr + + mark GHC.AnnWhere + mark GHC.AnnOpenC -- Possible '{' + markMany GHC.AnnSemi -- possible leading semis + mapM_ markLocated imps + + markList decs + + mark GHC.AnnCloseC -- Possible '}' + + markEOF + +-- --------------------------------------------------------------------- + +instance Annotate GHC.WarningTxt where + markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + mapM_ markLocated lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do + markExternal ls GHC.AnnOpen txt + mark GHC.AnnOpenS + mapM_ markLocated lss + mark GHC.AnnCloseS + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate [GHC.LIE name] where + markAST _ ls = do + mark GHC.AnnHiding -- in an import decl + mark GHC.AnnOpenP -- '(' + mapM_ markLocated ls + mark GHC.AnnCloseP -- ')' + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.IE name) where + markAST _ ie = do + + case ie of + (GHC.IEVar ln) -> do + mark GHC.AnnPattern + mark GHC.AnnType + markLocated ln + + (GHC.IEThingAbs ln) -> do + mark GHC.AnnType + markLocated ln + + (GHC.IEThingWith ln ns) -> do + markLocated ln + mark GHC.AnnOpenP + mapM_ markLocated ns + mark GHC.AnnCloseP + + (GHC.IEThingAll ln) -> do + markLocated ln + mark GHC.AnnOpenP + mark GHC.AnnDotdot + mark GHC.AnnCloseP + + (GHC.IEModuleContents (GHC.L lm mn)) -> do + mark GHC.AnnModule + markExternal lm GHC.AnnVal (GHC.moduleNameString mn) + + -- Only used in Haddock mode so we can ignore them. + (GHC.IEGroup _ _) -> return () + + (GHC.IEDoc _) -> return () + + (GHC.IEDocNamed _) -> return () + +-- --------------------------------------------------------------------- + +instance Annotate GHC.RdrName where + markAST l n = do + case rdrName2String n of + "[]" -> do + mark GHC.AnnOpenS -- '[' + mark GHC.AnnCloseS -- ']' + "()" -> do + mark GHC.AnnOpenP -- '(' + mark GHC.AnnCloseP -- ')' + "(##)" -> do + markWithString GHC.AnnOpen "(#" -- '(#' + markWithString GHC.AnnClose "#)"-- '#)' + "[::]" -> do + markWithString GHC.AnnOpen "[:" -- '[:' + markWithString GHC.AnnClose ":]" -- ':]' + str -> do + mark GHC.AnnType + mark GHC.AnnOpenP -- '(' + markOffset GHC.AnnBackquote 0 + markMany GHC.AnnCommaTuple -- For '(,,,)' + cnt <- countAnns GHC.AnnVal + cntT <- countAnns GHC.AnnCommaTuple + cntR <- countAnns GHC.AnnRarrow + case cnt of + 0 -> if cntT >0 || cntR >0 + then return () + else markExternal l GHC.AnnVal str + 1 -> markWithString GHC.AnnVal str + x -> error $ "markP.RdrName: too many AnnVal :" ++ showGhc (l,x) + mark GHC.AnnTildehsh + mark GHC.AnnTilde + mark GHC.AnnRarrow + markOffset GHC.AnnBackquote 1 + mark GHC.AnnCloseP -- ')' + +-- --------------------------------------------------------------------- + +-- TODO: What is this used for? Not in ExactPrint +instance Annotate GHC.Name where + markAST l n = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.ImportDecl name) where + markAST _ imp@(GHC.ImportDecl msrc (GHC.L ln _) _pkg src safeflag _qual _impl _as hiding) = do + + -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + mark GHC.AnnImport + + -- "{-# SOURCE" and "#-}" + when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) + >> markWithString GHC.AnnClose "#-}") + when safeflag (mark GHC.AnnSafe) + mark GHC.AnnQualified + mark GHC.AnnPackageName + + markExternal ln GHC.AnnVal (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp) + + case GHC.ideclAs imp of + Nothing -> return () + Just mn -> do + mark GHC.AnnAs + markWithString GHC.AnnVal (GHC.moduleNameString mn) + + case hiding of + Nothing -> return () + Just (_isHiding,lie) -> do + mark GHC.AnnHiding + markLocated lie + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsDecl name) where + markAST l decl = do + case decl of + GHC.TyClD d -> markAST l d + GHC.InstD d -> markAST l d + GHC.DerivD d -> markAST l d + GHC.ValD d -> markAST l d + GHC.SigD d -> markAST l d + GHC.DefD d -> markAST l d + GHC.ForD d -> markAST l d + GHC.WarningD d -> markAST l d + GHC.AnnD d -> markAST l d + GHC.RuleD d -> markAST l d + GHC.VectD d -> markAST l d + GHC.SpliceD d -> markAST l d + GHC.DocD d -> markAST l d + GHC.QuasiQuoteD d -> markAST l d + GHC.RoleAnnotD d -> markAST l d + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.RoleAnnotDecl name) where + markAST _ (GHC.RoleAnnotDecl ln mr) = do + mark GHC.AnnType + mark GHC.AnnRole + markLocated ln + mapM_ markLocated mr + +instance Annotate (Maybe GHC.Role) where + markAST l Nothing = markExternal l GHC.AnnVal "_" + markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.HsQuasiQuote name) where + markAST _ (GHC.HsQuasiQuote _n _ss _fs) = assert False undefined + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.SpliceDecl name) where + markAST _ (GHC.SpliceDecl (GHC.L _ (GHC.HsSplice _n e)) flag) = do + case flag of + GHC.ExplicitSplice -> + markWithString GHC.AnnOpen "$(" + GHC.ImplicitSplice -> + markWithString GHC.AnnOpen "$$(" + markLocated e + markWithString GHC.AnnClose ")" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.VectDecl name) where + markAST _ (GHC.HsVect src ln e) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + markLocated ln + mark GHC.AnnEqual + markLocated e + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsNoVect src ln) = do + markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeIn src _b ln mln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" + mark GHC.AnnType + markLocated ln + mark GHC.AnnEqual + markMaybe mln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectTypeOut {}) = error $ "markP.HsVectTypeOut: only valid after type checker" + + markAST _ (GHC.HsVectClassIn src ln) = do + markWithString GHC.AnnOpen src -- "{-# VECTORISE" + mark GHC.AnnClass + markLocated ln + markWithString GHC.AnnClose "#-}" -- "#-}" + + markAST _ (GHC.HsVectClassOut {}) = error $ "markP.HsVectClassOut: only valid after type checker" + markAST _ (GHC.HsVectInstIn {}) = error $ "markP.HsVectInstIn: not supported?" + markAST _ (GHC.HsVectInstOut {}) = error $ "markP.HsVectInstOut: not supported?" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.RuleDecls name) where + markAST _ (GHC.HsRules src rules) = do + markWithString GHC.AnnOpen src + mapM_ markLocated rules + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.RuleDecl name) where + markAST _ (GHC.HsRule ln act bndrs lhs _ rhs _) = do + markLocated ln + -- activation + mark GHC.AnnOpenS -- "[" + mark GHC.AnnTilde + case act of + GHC.ActiveBefore n -> markWithString GHC.AnnVal (show n) + GHC.ActiveAfter n -> markWithString GHC.AnnVal (show n) + _ -> return () + mark GHC.AnnCloseS -- "]" + + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated lhs + mark GHC.AnnEqual + markLocated rhs + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.RuleBndr name) where + markAST _ (GHC.RuleBndr ln) = markLocated ln + markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do + mark GHC.AnnOpenP -- "(" + markLocated ln + mark GHC.AnnDcolon + markLocated thing + mark GHC.AnnCloseP -- ")" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.AnnDecl name) where + markAST _ (GHC.HsAnnotation src prov e) = do + markWithString GHC.AnnOpen src + mark GHC.AnnType + mark GHC.AnnModule + case prov of + (GHC.ValueAnnProvenance n) -> markLocated n + (GHC.TypeAnnProvenance n) -> markLocated n + (GHC.ModuleAnnProvenance) -> return () + + markLocated e + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance Annotate name => Annotate (GHC.WarnDecls name) where + markAST _ (GHC.Warnings src warns) = do + markWithString GHC.AnnOpen src + mapM_ markLocated warns + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (Annotate name) + => Annotate (GHC.WarnDecl name) where + markAST _ (GHC.Warning lns txt) = do + mapM_ markLocated lns + mark GHC.AnnOpenS -- "[" + case txt of + GHC.WarningTxt _src ls -> mapM_ markLocated ls + GHC.DeprecatedTxt _src ls -> mapM_ markLocated ls + mark GHC.AnnCloseS -- "]" + +instance Annotate GHC.FastString where + markAST l fs = markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.ForeignDecl name) where + + markAST _ (GHC.ForeignImport ln typ _ + (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnImport + markLocated cconv + if ll == GHC.noSrcSpan + then return () + else markLocated safety + -- markMaybe mh + markExternal ls GHC.AnnVal ("\"" ++ src ++ "\"") + markLocated ln + mark GHC.AnnDcolon + markLocated typ + + + markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do + mark GHC.AnnForeign + mark GHC.AnnExport + markLocated spec + markExternal ls GHC.AnnVal ("\"" ++ src ++ "\"") + markLocated ln + mark GHC.AnnDcolon + markLocated typ + + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CExportSpec) where + markAST l (GHC.CExportStatic _ cconv) = markAST l cconv + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.CCallConv) where + markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" + markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" + markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" + markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" + markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" + +-- --------------------------------------------------------------------- + +instance (Annotate GHC.Safety) where + markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" + markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" + markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.DerivDecl name) where + + markAST _ (GHC.DerivDecl typ mov) = do + mark GHC.AnnDeriving + mark GHC.AnnInstance + markMaybe mov + markLocated typ + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.DefaultDecl name) where + + markAST _ (GHC.DefaultDecl typs) = do + mark GHC.AnnDefault + mark GHC.AnnOpenP -- '(' + mapM_ markLocated typs + mark GHC.AnnCloseP -- ')' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.InstDecl name) where + + markAST l (GHC.ClsInstD cid) = markAST l cid + markAST l (GHC.DataFamInstD dfid) = markAST l dfid + markAST l (GHC.TyFamInstD tfid) = markAST l tfid + +-- --------------------------------------------------------------------- + +instance Annotate GHC.OverlapMode where + markAST _ (GHC.NoOverlap src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlappable src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlapping src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Overlaps src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + + markAST _ (GHC.Incoherent src) = do + markWithString GHC.AnnOpen src + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.ClsInstDecl name) where + + markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do + mark GHC.AnnInstance + markMaybe mov + markLocated poly + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + + -- AZ:Need to turn this into a located list annotation. + -- must merge all the rest + applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ++ prepareListAnnotation tyfams + ++ prepareListAnnotation datafams + ) + + mark GHC.AnnCloseC -- '}' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.TyFamInstDecl name) where + + markAST _ (GHC.TyFamInstDecl eqn _) = do + mark GHC.AnnType + mark GHC.AnnInstance + markLocated eqn + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.DataFamInstDecl name) where + + markAST l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do + mark GHC.AnnData + mark GHC.AnnNewtype + mark GHC.AnnInstance + markLocated ln + mapM_ markLocated pats + mark GHC.AnnWhere + mark GHC.AnnEqual + markDataDefn l defn + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) => + Annotate (GHC.HsBind name) where + markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do + mapM_ markLocated matches + -- markMatchGroup l mg + + markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do + markLocated lhs + mark GHC.AnnEqual + mapM_ markLocated grhs + mark GHC.AnnWhere + + -- TODO: Store the following SrcSpan in an AnnList instance for exactPC + markLocated (GHC.L (getLocalBindsSrcSpan lb) lb) + + markAST _ (GHC.VarBind _n rhse _) = + -- Note: this bind is introduced by the typechecker + markLocated rhse + + markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do + mark GHC.AnnPattern + markLocated ln + case args of + GHC.InfixPatSyn la lb -> do + markLocated la + markLocated lb + GHC.PrefixPatSyn ns -> do + mapM_ markLocated ns + mark GHC.AnnEqual + mark GHC.AnnLarrow + markLocated def + case dir of + GHC.Unidirectional -> return () + GHC.ImplicitBidirectional -> return () + GHC.ExplicitBidirectional mg -> markMatchGroup l mg + + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + mark GHC.AnnCloseC -- '}' + + -- Introduced after renaming. + markAST _ (GHC.AbsBinds _ _ _ _ _) = return () + + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.IPBind name) where + markAST _ (GHC.IPBind en e) = do + case en of + Left n -> markLocated n + Right _i -> error $ "markP.IPBind:should not happen" + mark GHC.AnnEqual + markLocated e + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsIPName where + markAST l (GHC.HsIPName n) = markExternal l (GHC.AnnVal) ("?" ++ GHC.unpackFS n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name, + Annotate body) + => Annotate (GHC.Match name (GHC.Located body)) where + + markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do + let + get_infix Nothing = False + get_infix (Just (_,f)) = f + case (get_infix mln,pats) of + (True,[a,b]) -> do + markLocated a + case mln of + Nothing -> do + markWithString GHC.AnnOpen "`" -- possible '`' + mark GHC.AnnFunId + markWithString GHC.AnnClose "`"-- possible '`' + Just (n,_) -> markLocated n + markLocated b + _ -> do + case mln of + Nothing -> mark GHC.AnnFunId + Just (n,_) -> markLocated n + mapM_ markLocated pats + + mark GHC.AnnEqual + mark GHC.AnnRarrow -- For HsLam + + mapM_ markLocated grhs + + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) + mark GHC.AnnCloseC -- '}' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name, + Annotate body) + => Annotate (GHC.GRHS name (GHC.Located body)) where + markAST _ (GHC.GRHS guards expr) = do + + mark GHC.AnnVbar + mapM_ markLocated guards + mark GHC.AnnEqual + mark GHC.AnnRarrow -- in case alts + markLocated expr + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.Sig name) where + + markAST _ (GHC.TypeSig lns typ _) = do + mapM_ markLocated lns + mark GHC.AnnDcolon + markLocated typ + + markAST _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do + mark GHC.AnnPattern + markLocated ln + mark GHC.AnnDcolon + + -- Note: The 'forall' bndrs '.' may occur multiple times + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated ctx1 + markOffset GHC.AnnDarrow 0 + markLocated ctx2 + markOffset GHC.AnnDarrow 1 + markLocated typ + + + markAST _ (GHC.GenericSig ns typ) = do + mark GHC.AnnDefault + mapM_ markLocated ns + mark GHC.AnnDcolon + markLocated typ + + markAST _ (GHC.IdSig _) = return () + + -- FixSig (FixitySig name) + markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do + let fixstr = case fdir of + GHC.InfixL -> "infixl" + GHC.InfixR -> "infixr" + GHC.InfixN -> "infix" + markWithString GHC.AnnInfix fixstr + markWithString GHC.AnnVal (show v) + mapM_ markLocated lns + + -- InlineSig (Located name) InlinePragma + -- '{-# INLINE' activation qvar '#-}' + markAST _ (GHC.InlineSig ln inl) = do + let actStr = case GHC.inl_act inl of + GHC.NeverActive -> "" + GHC.AlwaysActive -> "" + GHC.ActiveBefore np -> show np + GHC.ActiveAfter np -> show np + markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal actStr -- e.g. 34 + mark GHC.AnnCloseS -- ']' + markLocated ln + markWithString GHC.AnnClose "#-}" -- '#-}' + + + markAST _ (GHC.SpecSig ln typs inl) = do + markWithString GHC.AnnOpen (GHC.inl_src inl) + mark GHC.AnnOpenS -- '[' + mark GHC.AnnTilde -- ~ + markWithString GHC.AnnVal "TODO: What here" + + mark GHC.AnnCloseS -- ']' + markLocated ln + mark GHC.AnnDcolon -- '::' + mapM_ markLocated typs + markWithString GHC.AnnClose "#-}" -- '#-}' + + + -- '{-# SPECIALISE' 'instance' inst_type '#-}' + markAST _ (GHC.SpecInstSig src typ) = do + markWithString GHC.AnnOpen src + mark GHC.AnnInstance + markLocated typ + markWithString GHC.AnnClose "#-}" -- '#-}' + + + -- MinimalSig (BooleanFormula (Located name)) + markAST _ (GHC.MinimalSig src formula) = do + markWithString GHC.AnnOpen src + markBooleanFormula formula + markWithString GHC.AnnClose "#-}" + + +-- --------------------------------------------------------------------- + +markBooleanFormula :: GHC.BooleanFormula (GHC.Located name) -> Annotated () +markBooleanFormula = assert False undefined + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) => + Annotate (GHC.HsTyVarBndr name) where + markAST l (GHC.UserTyVar n) = do + markAST l n + + markAST _ (GHC.KindedTyVar n ty) = do + mark GHC.AnnOpenP -- '(' + markLocated n + mark GHC.AnnDcolon -- '::' + markLocated ty + mark GHC.AnnCloseP -- '(' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsType name) where + + markAST _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do + mark GHC.AnnOpenP -- "(" + mark GHC.AnnForall + mapM_ markLocated tvs + mark GHC.AnnDot + + case mwc of + Nothing -> if lc /= GHC.noSrcSpan then markLocated ctx else return () + Just lwc -> markLocated (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs))) + + mark GHC.AnnDarrow + markLocated typ + mark GHC.AnnCloseP -- ")" + + markAST l (GHC.HsTyVar n) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + markAST l n + + markAST _ (GHC.HsAppTy t1 t2) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + markLocated t1 + markLocated t2 + + markAST _ (GHC.HsFunTy t1 t2) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + markLocated t1 + mark GHC.AnnRarrow + markLocated t2 + + markAST _ (GHC.HsListTy t) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + mark GHC.AnnOpenS -- '[' + markLocated t + mark GHC.AnnCloseS -- ']' + + markAST _ (GHC.HsPArrTy t) = do + markWithString GHC.AnnOpen "[:" -- '[:' + markLocated t + markWithString GHC.AnnClose ":]" -- ':]' + + markAST _ (GHC.HsTupleTy _tt ts) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + markWithString GHC.AnnOpen "(#" -- '(#' + mark GHC.AnnOpenP -- '(' + mapM_ markLocated ts + mark GHC.AnnCloseP -- ')' + markWithString GHC.AnnClose "#)" -- '#)' + + markAST _ (GHC.HsOpTy t1 (_,lo) t2) = do + markLocated t1 + markLocated lo + markLocated t2 + + markAST _ (GHC.HsParTy t) = do + mark GHC.AnnDcolon -- for HsKind, alias for HsType + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnCloseP -- ')' + + markAST _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do + markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) + mark GHC.AnnDcolon + markLocated t + + markAST _ (GHC.HsEqTy t1 t2) = do + markLocated t1 + mark GHC.AnnTilde + markLocated t2 + + markAST _ (GHC.HsKindSig t k) = do + mark GHC.AnnOpenP -- '(' + markLocated t + mark GHC.AnnDcolon -- '::' + markLocated k + mark GHC.AnnCloseP -- ')' + + -- HsQuasiQuoteTy (HsQuasiQuote name) + -- TODO: Probably wrong + markAST l (GHC.HsQuasiQuoteTy (GHC.HsQuasiQuote n _ss q)) = do + markExternal l GHC.AnnVal + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]") + + -- HsSpliceTy (HsSplice name) (PostTc name Kind) + markAST _ (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do + markWithString GHC.AnnOpen "$(" -- '$(' + markLocated e + markWithString GHC.AnnClose ")" -- ')' + + markAST _ (GHC.HsDocTy t ds) = do + markLocated t + markLocated ds + + markAST _ (GHC.HsBangTy b t) = do + case b of + (GHC.HsSrcBang ms (Just True) _) -> do + markWithString GHC.AnnOpen (maybe "{-# UNPACK" id ms) + markWithString GHC.AnnClose "#-}" + (GHC.HsSrcBang ms (Just False) _) -> do + markWithString GHC.AnnOpen (maybe "{-# NOUNPACK" id ms) + markWithString GHC.AnnClose "#-}" + _ -> return () + mark GHC.AnnBang + markLocated t + + -- HsRecTy [LConDeclField name] + markAST _ (GHC.HsRecTy cons) = do + mark GHC.AnnOpenC -- '{' + mapM_ markLocated cons + mark GHC.AnnCloseC -- '}' + + -- HsCoreTy Type + markAST _ (GHC.HsCoreTy _t) = return () + + markAST _ (GHC.HsExplicitListTy _ ts) = do + -- TODO: what about SIMPLEQUOTE? + markWithString GHC.AnnOpen "'[" -- "'[" + mapM_ markLocated ts + mark GHC.AnnCloseS -- ']' + + markAST _ (GHC.HsExplicitTupleTy _ ts) = do + markWithString GHC.AnnOpen "'(" -- "'(" + mapM_ markLocated ts + markWithString GHC.AnnClose ")" -- ')' + + -- HsTyLit HsTyLit + markAST l (GHC.HsTyLit lit) = do + case lit of + (GHC.HsNumTy s _) -> + markExternal l GHC.AnnVal s + (GHC.HsStrTy s _) -> + markExternal l GHC.AnnVal s + + -- HsWrapTy HsTyAnnotated (HsType name) + markAST _ (GHC.HsWrapTy _ _) = return () + + markAST l (GHC.HsWildcardTy) = do + markExternal l GHC.AnnVal "_" + mark GHC.AnnDarrow -- if only part of a partial type signature context +-- TODO: Probably wrong + markAST l (GHC.HsNamedWildcardTy n) = do + markExternal l GHC.AnnVal (showGhc n) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) => + Annotate (GHC.ConDeclField name) where + markAST _ (GHC.ConDeclField ns ty mdoc) = do + mapM_ markLocated ns + mark GHC.AnnDcolon + markLocated ty + markMaybe mdoc + +-- --------------------------------------------------------------------- + +instance Annotate GHC.HsDocString where + markAST l (GHC.HsDocString s) = do + markExternal l GHC.AnnVal (GHC.unpackFS s) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name) + => Annotate (GHC.Pat name) where + markAST l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" + -- TODO: probably wrong + markAST l (GHC.VarPat n) = markExternal l GHC.AnnVal (showGhc n) + markAST _ (GHC.LazyPat p) = do + mark GHC.AnnTilde + markLocated p + + markAST _ (GHC.AsPat ln p) = do + markLocated ln + mark GHC.AnnAt + markLocated p + + markAST _ (GHC.ParPat p) = do + mark GHC.AnnOpenP + markLocated p + mark GHC.AnnCloseP + + markAST _ (GHC.BangPat p) = do + mark GHC.AnnBang + markLocated p + + markAST _ (GHC.ListPat ps _ _) = do + mark GHC.AnnOpenS + mapM_ markLocated ps + mark GHC.AnnCloseS + + markAST _ (GHC.TuplePat pats b _) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + mapM_ markLocated pats + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markAST _ (GHC.PArrPat ps _) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated ps + markWithString GHC.AnnClose ":]" + + markAST _ (GHC.ConPatIn n dets) = do + markHsConPatDetails n dets + + markAST _ (GHC.ConPatOut {}) = return () + + -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) + markAST _ (GHC.ViewPat e pat _) = do + markLocated e + mark GHC.AnnRarrow + markLocated pat + + -- SplicePat (HsSplice id) + markAST _ (GHC.SplicePat (GHC.HsSplice _ e)) = do + markWithString GHC.AnnOpen "$(" -- '$(' + markLocated e + markWithString GHC.AnnClose ")" -- ')' + + -- QuasiQuotePat (HsQuasiQuote id) + -- TODO + markAST l (GHC.QuasiQuotePat (GHC.HsQuasiQuote n _ q)) = do + markExternal l GHC.AnnVal + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]") + + -- LitPat HsLit + markAST l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) + + -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) + markAST _ (GHC.NPat ol _ _) = do + mark GHC.AnnMinus + markLocated ol + + -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) + markAST _ (GHC.NPlusKPat ln ol _ _) = do + markLocated ln + markWithString GHC.AnnVal "+" -- "+" + markLocated ol + + markAST l (GHC.SigPatIn pat ty) = do + markLocated pat + mark GHC.AnnDcolon + markAST l ty + + markAST _ (GHC.SigPatOut {}) = return () + + -- CoPat HsAnnotated (Pat id) Type + markAST _ (GHC.CoPat {}) = return () + +-- --------------------------------------------------------------------- +hsLit2String :: GHC.HsLit -> GHC.SourceText +hsLit2String lit = + case lit of + GHC.HsChar src _ -> src + GHC.HsCharPrim src _ -> src + GHC.HsString src _ -> src + GHC.HsStringPrim src _ -> src + GHC.HsInt src _ -> src + GHC.HsIntPrim src _ -> src + GHC.HsWordPrim src _ -> src + GHC.HsInt64Prim src _ -> src + GHC.HsWord64Prim src _ -> src + GHC.HsInteger src _ _ -> src + GHC.HsRat (GHC.FL src _) _ -> src + GHC.HsFloatPrim (GHC.FL src _) -> src + GHC.HsDoublePrim (GHC.FL src _) -> src + +markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () +markHsConPatDetails ln dets = do + case dets of + GHC.PrefixCon args -> do + markLocated ln + mapM_ markLocated args + GHC.RecCon (GHC.HsRecFields fs _) -> do + markLocated ln + mark GHC.AnnOpenC -- '{' + mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- '}' + GHC.InfixCon a1 a2 -> do + markLocated a1 + markLocated ln + markLocated a2 + +markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () +markHsConDeclDetails lns dets = do + case dets of + GHC.PrefixCon args -> mapM_ markLocated args + GHC.RecCon fs -> do + mark GHC.AnnOpenC + markLocated fs + mark GHC.AnnCloseC + GHC.InfixCon a1 a2 -> do + markLocated a1 + mapM_ markLocated lns + markLocated a2 + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate [GHC.LConDeclField name] where + markAST _ fs = do + mark GHC.AnnOpenC -- '{' + mapM_ markLocated fs + mark GHC.AnnDotdot + mark GHC.AnnCloseC -- '}' + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where + markAST l ol = + let str = case GHC.ol_val ol of + GHC.HsIntegral src _ -> src + GHC.HsFractional l2 -> (GHC.fl_text l2) + GHC.HsIsString src _ -> src + in + markExternal l GHC.AnnVal str + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate arg) + => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where + markAST _ (GHC.HsWB thing _ _ _) = markLocated thing + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) => + Annotate (GHC.Stmt name (GHC.Located body)) where + + markAST _ (GHC.LastStmt body _) = markLocated body + + markAST _ (GHC.BindStmt pat body _ _) = do + markLocated pat + mark GHC.AnnLarrow + markLocated body + mark GHC.AnnVbar -- possible in list comprehension + + markAST _ (GHC.BodyStmt body _ _ _) = do + markLocated body + + markAST _ (GHC.LetStmt lb) = do + -- return () `debug` ("markP.LetStmt entered") + mark GHC.AnnLet + mark GHC.AnnOpenC -- '{' + markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) + mark GHC.AnnCloseC -- '}' + -- return () `debug` ("markP.LetStmt done") + + markAST _ (GHC.ParStmt pbs _ _) = do + mapM_ markParStmtBlock pbs + + markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do + mapM_ markLocated stmts + case form of + GHC.ThenForm -> do + mark GHC.AnnThen + markLocated using + mark GHC.AnnBy + case by of + Just b -> markLocated b + Nothing -> return () + GHC.GroupForm -> do + mark GHC.AnnThen + mark GHC.AnnGroup + mark GHC.AnnBy + case by of + Just b -> markLocated b + Nothing -> return () + mark GHC.AnnUsing + markLocated using + + markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do + mark GHC.AnnRec + mark GHC.AnnOpenC + markInside GHC.AnnSemi + mapM_ markLocated stmts + mark GHC.AnnCloseC + +-- --------------------------------------------------------------------- + +markParStmtBlock :: (GHC.DataId name,GHC.OutputableBndr name, Annotate name) + => GHC.ParStmtBlock name name -> Annotated () +markParStmtBlock (GHC.ParStmtBlock stmts _ns _) = + mapM_ markLocated stmts + +-- --------------------------------------------------------------------- + +-- | Local binds need to be indented as a group, and thus need to have a +-- SrcSpan around them so they can be processed via the normal +-- markLocated / exactPC machinery. +getLocalBindsSrcSpan :: GHC.HsLocalBinds name -> GHC.SrcSpan +getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) + = case spans of + [] -> GHC.noSrcSpan + sss -> GHC.combineSrcSpans (head sss) (last sss) + where + spans = sort (map GHC.getLoc (GHC.bagToList binds) ++ map GHC.getLoc sigs) + +getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsOut {})) + = error "getLocalBindsSrcSpan: only valid after type checking" + +getLocalBindsSrcSpan (GHC.HsIPBinds (GHC.IPBinds binds _)) + = case sort (map GHC.getLoc binds) of + [] -> GHC.noSrcSpan + sss -> GHC.combineSrcSpans (head sss) (last sss) + +getLocalBindsSrcSpan (GHC.EmptyLocalBinds) = GHC.noSrcSpan + +-- --------------------------------------------------------------------- + +-- | Generate a SrcSpan that enclosed the given list +getListSrcSpan :: [GHC.Located a] -> GHC.SrcSpan +getListSrcSpan ls + = case ls of + [] -> GHC.noSrcSpan + sss -> GHC.combineLocs (head sss) (last sss) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsLocalBinds name) where + markAST _ lb = markHsLocalBinds lb + +-- --------------------------------------------------------------------- + +markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => (GHC.HsLocalBinds name) -> Annotated () +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do + applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) + ++ prepareListAnnotation sigs + ) +markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {})) + = error $ "markHsLocalBinds: only valid after type checking" + +markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated binds +markHsLocalBinds (GHC.EmptyLocalBinds) = return () + +-- --------------------------------------------------------------------- + +markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name, + Annotate body) + => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body)) + -> Annotated () +markMatchGroup l (GHC.MG matches _ _ _) + = markListWithLayout l matches + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name, + Annotate body) + => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsExpr name) where + markAST l (GHC.HsVar n) = markAST l n + markAST l (GHC.HsIPVar (GHC.HsIPName v)) = + markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) + markAST l (GHC.HsOverLit ov) = markAST l ov + markAST l (GHC.HsLit lit) = markAST l lit + + markAST l (GHC.HsLam match) = do + mark GHC.AnnLam + markMatchGroup l match + + markAST l (GHC.HsLamCase _ match) = markMatchGroup l match + + markAST _ (GHC.HsApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST _ (GHC.OpApp e1 e2 _ e3) = do + markLocated e1 + markLocated e2 + markLocated e3 + + markAST _ (GHC.NegApp e _) = do + mark GHC.AnnMinus + markLocated e + + markAST _ (GHC.HsPar e) = do + mark GHC.AnnOpenP -- '(' + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST _ (GHC.SectionL e1 e2) = do + markLocated e1 + markLocated e2 + + markAST _ (GHC.SectionR e1 e2) = do + markLocated e1 + markLocated e2 + + markAST _ (GHC.ExplicitTuple args b) = do + if b == GHC.Boxed then mark GHC.AnnOpenP + else markWithString GHC.AnnOpen "(#" + + mapM_ markLocated args + + if b == GHC.Boxed then mark GHC.AnnCloseP + else markWithString GHC.AnnClose "#)" + + markAST l (GHC.HsCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + mark GHC.AnnOpenC + markInside GHC.AnnSemi + markMatchGroup l matches + mark GHC.AnnCloseC + + markAST _ (GHC.HsIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsMultiIf _ rhs) = do + mark GHC.AnnIf + mapM_ markLocated rhs + + markAST _ (GHC.HsLet binds e) = do + mark GHC.AnnLet + setLayoutFlag GHC.AnnLet (do -- Make sure the 'in' gets indented too + mark GHC.AnnOpenC + markInside GHC.AnnSemi + markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) + mark GHC.AnnCloseC + mark GHC.AnnIn + markLocated e) + + markAST l (GHC.HsDo cts es _) = do + mark GHC.AnnDo + let (ostr,cstr,_isComp) = + if isListComp cts + then case cts of + GHC.PArrComp -> ("[:",":]",True) + _ -> ("[", "]",True) + else ("{","}",False) + + markWithString GHC.AnnOpen ostr + mark GHC.AnnOpenS + mark GHC.AnnOpenC + markInside GHC.AnnSemi + if isListComp cts + then do + markLocated (last es) + mark GHC.AnnVbar + mapM_ markLocated (init es) + else do + markListWithLayout l es + mark GHC.AnnCloseS + mark GHC.AnnCloseC + markWithString GHC.AnnClose cstr + + markAST _ (GHC.ExplicitList _ _ es) = do + mark GHC.AnnOpenS + mapM_ markLocated es + mark GHC.AnnCloseS + + markAST _ (GHC.ExplicitPArr _ es) = do + markWithString GHC.AnnOpen "[:" + mapM_ markLocated es + markWithString GHC.AnnClose ":]" + + markAST _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do + markLocated n + mark GHC.AnnOpenC + mark GHC.AnnDotdot + mapM_ markLocated fs + mark GHC.AnnCloseC + + markAST _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do + markLocated e + mark GHC.AnnOpenC + mark GHC.AnnDotdot + mapM_ markLocated fs + mark GHC.AnnCloseC + + markAST _ (GHC.ExprWithTySig e typ _) = do + markLocated e + mark GHC.AnnDcolon + markLocated typ + + markAST _ (GHC.ExprWithTySigOut e typ) = do + markLocated e + mark GHC.AnnDcolon + markLocated typ + + markAST _ (GHC.ArithSeq _ _ seqInfo) = do + mark GHC.AnnOpenS -- '[' + case seqInfo of + GHC.From e -> do + markLocated e + mark GHC.AnnDotdot + GHC.FromTo e1 e2 -> do + markLocated e1 + mark GHC.AnnDotdot + markLocated e2 + GHC.FromThen e1 e2 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + GHC.FromThenTo e1 e2 e3 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + markLocated e3 + mark GHC.AnnCloseS -- ']' + + markAST _ (GHC.PArrSeq _ seqInfo) = do + markWithString GHC.AnnOpen "[:" -- '[:' + case seqInfo of + GHC.From e -> do + markLocated e + mark GHC.AnnDotdot + GHC.FromTo e1 e2 -> do + markLocated e1 + mark GHC.AnnDotdot + markLocated e2 + GHC.FromThen e1 e2 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + GHC.FromThenTo e1 e2 e3 -> do + markLocated e1 + mark GHC.AnnComma + markLocated e2 + mark GHC.AnnDotdot + markLocated e3 + markWithString GHC.AnnClose ":]" -- ':]' + + markAST _ (GHC.HsSCC src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# SCC" + markWithString GHC.AnnVal (GHC.unpackFS csFStr) + markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") + markWithString GHC.AnnClose "#-}" + markLocated e + + markAST _ (GHC.HsCoreAnn src csFStr e) = do + markWithString GHC.AnnOpen src -- "{-# CORE" + markWithString GHC.AnnVal (GHC.unpackFS csFStr) + markWithString GHC.AnnClose "#-}" + markLocated e + -- TODO: make monomorphic + markAST l (GHC.HsBracket (GHC.VarBr single v)) = + let str = + if single then ("'" ++ showGhc v) + else ("''" ++ showGhc v) + in + markExternal l GHC.AnnVal str + markAST _ (GHC.HsBracket (GHC.DecBrL ds)) = do + markWithString GHC.AnnOpen "[d|" + mark GHC.AnnOpenC + mapM_ markLocated ds + mark GHC.AnnCloseC + markWithString GHC.AnnClose "|]" + -- Introduced after the renamer + markAST _ (GHC.HsBracket (GHC.DecBrG _)) = return () + markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do + markWithString GHC.AnnOpen "[|" + markLocated e + markWithString GHC.AnnClose "|]" + markAST _ (GHC.HsBracket (GHC.TExpBr e)) = do + markWithString GHC.AnnOpen "[||" + markLocated e + markWithString GHC.AnnClose "||]" + markAST _ (GHC.HsBracket (GHC.TypBr e)) = do + markWithString GHC.AnnOpen "[t|" + markLocated e + markWithString GHC.AnnClose "|]" + markAST _ (GHC.HsBracket (GHC.PatBr e)) = do + markWithString GHC.AnnOpen "[p|" + markLocated e + markWithString GHC.AnnClose "|]" + + markAST _ (GHC.HsRnBracketOut _ _) = return () + markAST _ (GHC.HsTcBracketOut _ _) = return () + + markAST _ (GHC.HsSpliceE False (GHC.HsSplice _ e)) = do + markWithString GHC.AnnOpen "$(" + markLocated e + markWithString GHC.AnnClose ")" + + markAST _ (GHC.HsSpliceE True (GHC.HsSplice _ e)) = do + markWithString GHC.AnnOpen "$$(" + markLocated e + markWithString GHC.AnnClose ")" + + markAST l (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote n _ q)) = do + markExternal l GHC.AnnVal + ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS q) ++ "|]") + + + markAST _ (GHC.HsProc p c) = do + mark GHC.AnnProc + markLocated p + mark GHC.AnnRarrow + markLocated c + + markAST _ (GHC.HsStatic e) = do + mark GHC.AnnStatic + markLocated e + + markAST _ (GHC.HsArrApp e1 e2 _ _ _) = do + markLocated e1 + -- only one of the next 4 will be resent + mark GHC.Annlarrowtail + mark GHC.Annrarrowtail + mark GHC.AnnLarrowtail + mark GHC.AnnRarrowtail + + markLocated e2 + + markAST _ (GHC.HsArrForm e _ cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markAST _ (GHC.HsTick _ _) = return () + markAST _ (GHC.HsBinTick _ _ _) = return () + + markAST _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do + -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' + markWithString GHC.AnnOpen src + markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING + markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER + markOffset GHC.AnnColon 0 -- ':' + markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER + mark GHC.AnnMinus -- '-' + markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER + markOffset GHC.AnnColon 1 -- ':' + markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER + markWithString GHC.AnnClose "#-}" + markLocated e + + markAST l (GHC.EWildPat) = do + markExternal l GHC.AnnVal "_" + + markAST _ (GHC.EAsPat ln e) = do + markLocated ln + mark GHC.AnnAt + markLocated e + + markAST _ (GHC.EViewPat e1 e2) = do + markLocated e1 + mark GHC.AnnRarrow + markLocated e2 + + markAST _ (GHC.ELazyPat e) = do + mark GHC.AnnTilde + markLocated e + + markAST _ (GHC.HsType ty) = markLocated ty + + markAST _ (GHC.HsWrap _ _) = return () + markAST _ (GHC.HsUnboundVar _) = return () + +instance Annotate GHC.HsLit where + markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) +-- --------------------------------------------------------------------- + +-- |Used for declarations that need to be aligned together, e.g. in a +-- do or let .. in statement/expr +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate ([GHC.ExprLStmt name]) where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsTupArg name) where + markAST _ (GHC.Present e) = do + markLocated e + + markAST _ (GHC.Missing _) = do + mark GHC.AnnComma + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsCmdTop name) where + markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.HsCmd name) where + markAST _ (GHC.HsCmdArrApp e1 e2 _ _ _) = do + markLocated e1 + -- only one of the next 4 will be resent + mark GHC.Annlarrowtail + mark GHC.Annrarrowtail + mark GHC.AnnLarrowtail + mark GHC.AnnRarrowtail + + markLocated e2 + + markAST _ (GHC.HsCmdArrForm e _mf cs) = do + markWithString GHC.AnnOpen "(|" + markLocated e + mapM_ markLocated cs + markWithString GHC.AnnClose "|)" + + markAST _ (GHC.HsCmdApp e1 e2) = do + markLocated e1 + markLocated e2 + + markAST l (GHC.HsCmdLam match) = do + mark GHC.AnnLam + markMatchGroup l match + + markAST _ (GHC.HsCmdPar e) = do + mark GHC.AnnOpenP + markLocated e + mark GHC.AnnCloseP -- ')' + + markAST l (GHC.HsCmdCase e1 matches) = do + mark GHC.AnnCase + markLocated e1 + mark GHC.AnnOf + mark GHC.AnnOpenC + markMatchGroup l matches + mark GHC.AnnCloseC + + markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do + mark GHC.AnnIf + markLocated e1 + markOffset GHC.AnnSemi 0 + mark GHC.AnnThen + markLocated e2 + markOffset GHC.AnnSemi 1 + mark GHC.AnnElse + markLocated e3 + + markAST _ (GHC.HsCmdLet binds e) = do + mark GHC.AnnLet + mark GHC.AnnOpenC + markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) + mark GHC.AnnCloseC + mark GHC.AnnIn + markLocated e + + markAST l (GHC.HsCmdDo es _) = do + mark GHC.AnnDo + mark GHC.AnnOpenC + -- mapM_ markLocated es + markListWithLayout l es + mark GHC.AnnCloseC + + markAST _ (GHC.HsCmdCast {}) = error $ "markP.HsCmdCast: only valid after type checker" + + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where + markAST _ ls = mapM_ markLocated ls + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate (GHC.TyClDecl name) where + + markAST l (GHC.FamDecl famdecl) = markAST l famdecl + + markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do + mark GHC.AnnType + markLocated ln + mapM_ markLocated tyvars + mark GHC.AnnEqual + markLocated typ + + markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) + (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do + mark GHC.AnnData + mark GHC.AnnNewtype + markMaybe mctyp + markLocated ctx + mark GHC.AnnDarrow + markTyClass ln tyVars + mark GHC.AnnDcolon + markMaybe mk + mark GHC.AnnEqual + mark GHC.AnnWhere + mapM_ markLocated cons + markMaybe mderivs + + -- ----------------------------------- + + markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds + sigs meths ats atdefs docs _) = do + mark GHC.AnnClass + markLocated ctx + + markTyClass ln tyVars + + mark GHC.AnnVbar + mapM_ markLocated fds + mark GHC.AnnWhere + mark GHC.AnnOpenC -- '{' + markInside GHC.AnnSemi + applyListAnnotations (prepareListAnnotation sigs + ++ prepareListAnnotation (GHC.bagToList meths) + ++ prepareListAnnotation ats + ++ prepareListAnnotation atdefs + ++ prepareListAnnotation docs + ) + mark GHC.AnnCloseC -- '}' + +-- --------------------------------------------------------------------- + +markTyClass :: (Annotate a, Annotate ast) + => GHC.Located a -> [GHC.Located ast] -> Annotated () +markTyClass ln tyVars = do + markMany GHC.AnnOpenP + applyListAnnotations (prepareListAnnotation [ln] + ++ prepareListAnnotation (take 2 tyVars)) + markMany GHC.AnnCloseP + mapM_ markLocated (drop 2 tyVars) + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name) + => Annotate (GHC.FamilyDecl name) where + markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do + mark GHC.AnnType + mark GHC.AnnData + mark GHC.AnnFamily + markLocated ln + mapM_ markLocated tyvars + mark GHC.AnnDcolon + markMaybe mkind + mark GHC.AnnWhere + mark GHC.AnnOpenC -- { + case info of + GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns + _ -> return () + case info of + GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns + _ -> return () + mark GHC.AnnCloseC -- } + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name) + => Annotate (GHC.TyFamInstEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do + markLocated ln + mapM_ markLocated pats + mark GHC.AnnEqual + markLocated typ + + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name) + => Annotate (GHC.TyFamDefltEqn name) where + markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do + markLocated ln + mapM_ markLocated bndrs + mark GHC.AnnEqual + markLocated typ + +-- --------------------------------------------------------------------- + +-- TODO: modify lexer etc, in the meantime to not set haddock flag +instance Annotate GHC.DocDecl where + markAST l v = + let str = + case v of + (GHC.DocCommentNext (GHC.HsDocString fs)) -> (GHC.unpackFS fs) + (GHC.DocCommentPrev (GHC.HsDocString fs)) -> (GHC.unpackFS fs) + (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> (GHC.unpackFS fs) + (GHC.DocGroup _i (GHC.HsDocString fs)) -> (GHC.unpackFS fs) + in + markExternal l (GHC.AnnVal) str + +-- --------------------------------------------------------------------- + +markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () +markDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do + markLocated ctx + markMaybe typ + markMaybe mk + mapM_ markLocated cons + case mderivs of + Nothing -> return () + Just d -> markLocated d + +-- --------------------------------------------------------------------- + +-- Note: GHC.HsContext name aliases to here too +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) + => Annotate [GHC.LHsType name] where + markAST l ts = do + return () `debug` ("markP.HsContext:l=" ++ showGhc l) + mark GHC.AnnDeriving + mark GHC.AnnOpenP + mapM_ markLocated ts + mark GHC.AnnCloseP + mark GHC.AnnDarrow + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name) + => Annotate (GHC.ConDecl name) where + markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx + dets res _ _) = do + case res of + GHC.ResTyH98 -> do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + + markLocated ctx + mark GHC.AnnDarrow + + case dets of + GHC.InfixCon _ _ -> return () + _ -> mapM_ markLocated lns + + markHsConDeclDetails lns dets + + GHC.ResTyGADT ls ty -> do + -- only print names if not infix + case dets of + GHC.InfixCon _ _ -> return () + _ -> mapM_ markLocated lns + + markHsConDeclDetails lns dets + + mark GHC.AnnDcolon + + markLocated (GHC.L ls (ResTyGADTHook bndrs)) + + markLocated ctx + mark GHC.AnnDarrow + + markLocated ty + + + mark GHC.AnnVbar + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) => + Annotate (ResTyGADTHook name) where + markAST _ (ResTyGADTHook bndrs) = do + mark GHC.AnnForall + mapM_ markLocated bndrs + mark GHC.AnnDot + +-- --------------------------------------------------------------------- + +instance (Annotate name,Annotate a) + => Annotate (GHC.HsRecField name (GHC.Located a)) where + markAST _ (GHC.HsRecField n e _) = do + markLocated n + mark GHC.AnnEqual + markLocated e + +-- --------------------------------------------------------------------- + +instance (GHC.DataId name,Annotate name) + => Annotate (GHC.FunDep (GHC.Located name)) where + + markAST _ (ls,rs) = do + mapM_ markLocated ls + mark GHC.AnnRarrow + mapM_ markLocated rs + +-- --------------------------------------------------------------------- + +instance Annotate (GHC.CType) where + markAST _ (GHC.CType src mh f) = do + markWithString GHC.AnnOpen src + case mh of + Nothing -> return () + Just (GHC.Header h) -> + markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"") + markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"") + markWithString GHC.AnnClose "#-}" + +-- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Language.Haskell.GHC.ExactPrint.Delta (relativiseApiAnns) where + +import Control.Monad.RWS +import Control.Applicative +import Control.Monad.Trans.Free + +import Data.Data (Data) +import Data.List (sort, nub, partition) +import Data.Maybe (fromMaybe) + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated + , markLocated, Annotate(..)) + +import qualified GHC +import qualified SrcLoc as GHC + +import qualified Data.Map as Map + + +-- --------------------------------------------------------------------- +-- +-- | Type used in the Delta Monad. The state variables maintain +-- - the current SrcSpan and the constructor of the thing it encloses +-- as a stack to the root of the AST as it is traversed, +-- - the srcspan of the last thing annotated, to calculate delta's from +-- - extra data needing to be stored in the monad +-- - the annotations provided by GHC +type Delta a = RWS DeltaStack DeltaWriter DeltaState a + +-- | Transform concrete annotations into relative annotations which are +-- more useful when transforming an AST. +relativiseApiAnns :: Annotate ast + => GHC.Located ast + -> GHC.ApiAnns + -> Anns +relativiseApiAnns modu@(GHC.L ss _) ghcAnns + = runDelta (markLocated modu) ghcAnns ss + + +runDelta :: Annotated () -> GHC.ApiAnns -> GHC.SrcSpan -> Anns +runDelta action ga priorEnd = + ($ mempty) . appEndo . finalAnns . snd + . (\next -> execRWS next initialDeltaStack (defaultDeltaState priorEnd ga)) + . simpleInterpret $ action + +-- --------------------------------------------------------------------- + +data DeltaState = DeltaState + { -- | Position reached when processing the last element + priorEndPosition :: GHC.SrcSpan + -- | Ordered list of comments still to be allocated + , apComments :: [Comment] + -- | The original GHC Delta Annotations + , apAnns :: GHC.ApiAnns + } + +data DeltaStack = DeltaStack + { -- | Current `SrcSpan` + curSrcSpan :: GHC.SrcSpan + -- | Constuctor of current AST element, useful for + -- debugging + , annConName :: AnnConName + -- | Start column of the current layout block + , layoutStart :: LayoutStartCol + } + +initialDeltaStack :: DeltaStack +initialDeltaStack = + DeltaStack + { curSrcSpan = GHC.noSrcSpan + , annConName = annGetConstr () + , layoutStart = 0 + } + +defaultDeltaState :: GHC.SrcSpan -> GHC.ApiAnns -> DeltaState +defaultDeltaState priorEnd ga = + DeltaState + { priorEndPosition = priorEnd + , apComments = cs + , apAnns = ga -- $ + } + where + cs :: [Comment] + cs = flattenedComments ga + + flattenedComments :: GHC.ApiAnns -> [Comment] + flattenedComments (_,cm) = + map tokComment . GHC.sortLocated . concat $ Map.elems cm + + tokComment :: GHC.Located GHC.AnnotationComment -> Comment + tokComment t@(GHC.L lt _) = Comment (ss2span lt) (ghcCommentText t) + + +data DeltaWriter = DeltaWriter + { -- Final list of annotations + finalAnns :: Endo (Map.Map AnnKey Annotation) + -- Used locally to pass Keywords, delta pairs relevant to a specific + -- subtree to the parent. + , annKds :: [(KeywordId, DeltaPos)] + -- Used locally to report a subtrees aderhence to haskell's layout + -- rules. + , propOffset :: First LayoutStartCol -- Used to pass the offset upwards + } + +-- Writer helpers + +tellFinalAnn :: (AnnKey, Annotation) -> Delta () +tellFinalAnn (k, v) = + tell (mempty { finalAnns = Endo (Map.insertWith (<>) k v) }) + +tellKd :: (KeywordId, DeltaPos) -> Delta () +tellKd kd = tell (mempty { annKds = [kd] }) + + +instance Monoid DeltaWriter where + mempty = DeltaWriter mempty mempty mempty + (DeltaWriter a b e) `mappend` (DeltaWriter c d f) = DeltaWriter (a <> c) (b <> d) (e <> f) + +----------------------------------- +-- Interpretation code + +simpleInterpret :: Annotated a -> Delta a +simpleInterpret = iterTM go + where + go :: AnnotationF (Delta a) -> Delta a + go (MarkEOF next) = addEofAnnotation >> next + go (MarkPrim kwid _ next) = + addDeltaAnnotation kwid >> next + go (MarkOutside akwid kwid next) = + addDeltaAnnotationsOutside akwid kwid >> next + go (MarkInside akwid next) = + addDeltaAnnotationsInside akwid >> next + go (MarkMany akwid next) = addDeltaAnnotations akwid >> next + go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next + go (MarkAfter akwid next) = addDeltaAnnotationAfter akwid >> next + go (WithAST lss layoutflag prog next) = + withAST lss layoutflag (simpleInterpret prog) >> next + go (OutputKD (kwid, (_, dp)) next) = tellKd (dp, kwid) >> next + go (CountAnns kwid next) = countAnnsDelta kwid >>= next + go (SetLayoutFlag kwid action next) = setLayoutFlag kwid (simpleInterpret action) >> next + go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next + + +-- | Used specifically for "HsLet" +setLayoutFlag :: GHC.AnnKeywordId -> Delta () -> Delta () +setLayoutFlag kwid action = do + c <- srcSpanStartColumn . head <$> getAnnotationDelta kwid + tell (mempty { propOffset = First (Just (LayoutStartCol c)) }) + local (\s -> s { layoutStart = LayoutStartCol c }) action + + +-- ------------------------------------- + +getSrcSpan :: Delta GHC.SrcSpan +getSrcSpan = asks curSrcSpan + +withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b +withSrcSpanDelta (GHC.L l a) = + local (\s -> s { curSrcSpan = l + , annConName = annGetConstr a + }) + + + +getUnallocatedComments :: Delta [Comment] +getUnallocatedComments = gets apComments + +putUnallocatedComments :: [Comment] -> Delta () +putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) + +-- --------------------------------------------------------------------- + +adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos +adjustDeltaForOffsetM dp = do + colOffset <- asks layoutStart + return (adjustDeltaForOffset colOffset dp) + +adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos +adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line +adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset) + +-- --------------------------------------------------------------------- + +getPriorEnd :: Delta GHC.SrcSpan +getPriorEnd = gets priorEndPosition + +setPriorEnd :: GHC.SrcSpan -> Delta () +setPriorEnd pe = modify (\s -> s { priorEndPosition = pe }) + +setLayoutOffset :: LayoutStartCol -> Delta a -> Delta a +setLayoutOffset lhs = local (\s -> s { layoutStart = lhs }) + +-- ------------------------------------- + +getAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan] +getAnnotationDelta an = do + ga <- gets apAnns + ss <- getSrcSpan + return $ GHC.getAnnotation ga ss an + +getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta [GHC.SrcSpan] +getAndRemoveAnnotationDelta sp an = do + ga <- gets apAnns + let (r,ga') = GHC.getAndRemoveAnnotation ga sp an + r <$ modify (\s -> s { apAnns = ga' }) + +-- ------------------------------------- + +-- |Add some annotation to the currently active SrcSpan +addAnnotationsDelta :: Annotation -> Delta () +addAnnotationsDelta ann = do + l <- ask + tellFinalAnn (getAnnKey l ,ann) + +getAnnKey :: DeltaStack -> AnnKey +getAnnKey DeltaStack {curSrcSpan, annConName} = AnnKey curSrcSpan annConName + +-- ------------------------------------- + +addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta () +addAnnDeltaPos kw dp = tellKd (kw, dp) + +-- ------------------------------------- + + +-- | Enter a new AST element. Maintain SrcSpan stack +withAST :: Data a => GHC.Located a -> LayoutFlag -> Delta b -> Delta b +withAST lss@(GHC.L ss _) layout action = do + -- Calculate offset required to get to the start of the SrcSPan + pe <- getPriorEnd + off <- asks layoutStart + let whenLayout = case layout of + LayoutRules -> + setLayoutOffset + (LayoutStartCol (srcSpanStartColumn ss)) + NoLayoutRules -> id + (whenLayout . withSrcSpanDelta lss) (do + + let maskWriter s = s { annKds = [] + , propOffset = First Nothing } + + (res, w) <- censor maskWriter (listen action) + let edp = adjustDeltaForOffset + -- Use the propagated offset if one is set + (fromMaybe off (getFirst $ propOffset w)) + (deltaFromSrcSpans pe ss) + let kds = annKds w + addAnnotationsDelta Ann + { annEntryDelta = edp + , annDelta = ColDelta (srcSpanStartColumn ss + - getLayoutStartCol off) + , annsDP = kds } + -- `debug` ("leaveAST:(ss,finaledp,dp,nl,kds)=" ++ show (showGhc ss,edp,dp,nl,kds)) + return res) + +-- --------------------------------------------------------------------- + +-- |Split the ordered list of comments into ones that occur prior to +-- the given SrcSpan and the rest +allocatePriorComments :: [Comment] -> GHC.SrcSpan -> ([Comment],[Comment]) +allocatePriorComments cs ss = partition isPrior cs + where + (start,_) = ss2span ss + isPrior (Comment s _) = fst s < start + `debug` ("allocatePriorComments:(s,ss,cond)=" ++ showGhc (s,ss,(fst s) < start)) + +-- --------------------------------------------------------------------- + +addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta () +addAnnotationWorker ann pa = do + unless (isPointSrcSpan pa) $ + do + pe <- getPriorEnd + ss <- getSrcSpan + let p = deltaFromSrcSpans pe pa + case (ann,isGoodDelta p) of + (G GHC.AnnComma,False) -> return () + (G GHC.AnnSemi, False) -> return () + (G GHC.AnnOpen, False) -> return () + (G GHC.AnnClose,False) -> return () + _ -> do + cs <- getUnallocatedComments + let (allocated,cs') = allocatePriorComments cs pa + putUnallocatedComments cs' + return () `debug`("addAnnotationWorker:(ss,pa,allocated,cs)=" ++ showGhc (ss,pa,allocated,cs)) + mapM_ addDeltaComment allocated + p' <- adjustDeltaForOffsetM p + addAnnDeltaPos ann p' + setPriorEnd pa + -- `debug` ("addDeltaAnnotationWorker:(ss,pe,pa,p,ann)=" ++ show (ss2span ss,ss2span pe,ss2span pa,p,ann)) + +-- --------------------------------------------------------------------- + +addDeltaComment :: Comment -> Delta () +addDeltaComment (Comment paspan str) = do + let pa = span2ss paspan + pe <- getPriorEnd + let p = deltaFromSrcSpans pe pa + p' <- adjustDeltaForOffsetM p + setPriorEnd pa + let e = ss2deltaP (ss2posEnd pe) (snd paspan) + e' <- adjustDeltaForOffsetM e + addAnnDeltaPos (AnnComment (DComment (p',e') str)) p' + +-- --------------------------------------------------------------------- + +-- | Look up and add a Delta annotation at the current position, and +-- advance the position to the end of the annotation +addDeltaAnnotation :: GHC.AnnKeywordId -> Delta () +addDeltaAnnotation ann = do + ss <- getSrcSpan + when (ann == GHC.AnnVal) (debugM (showGhc ss)) + ma <- getAnnotationDelta ann + when (ann == GHC.AnnVal && null ma) (debugM "empty") + case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier + [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show ann) + [pa] -> addAnnotationWorker (G ann) pa + _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma) + +-- | Look up and add a Delta annotation appearing beyond the current +-- SrcSpan at the current position, and advance the position to the +-- end of the annotation +addDeltaAnnotationAfter :: GHC.AnnKeywordId -> Delta () +addDeltaAnnotationAfter ann = do + ss <- getSrcSpan + ma <- getAnnotationDelta ann + let ma' = filter (\s -> not (GHC.isSubspanOf s ss)) ma + case ma' of + [] -> return () `debug` "addDeltaAnnotation empty ma" + [pa] -> addAnnotationWorker (G ann) pa + _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma) + +-- | Look up and add a Delta annotation at the current position, and +-- advance the position to the end of the annotation +addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> Delta () +addDeltaAnnotationLs ann off = do + ma <- getAnnotationDelta ann + case drop off ma of + [] -> return () + -- `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma)) + (pa:_) -> addAnnotationWorker (G ann) pa + +-- | Look up and add possibly multiple Delta annotation at the current +-- position, and advance the position to the end of the annotations +addDeltaAnnotations :: GHC.AnnKeywordId -> Delta () +addDeltaAnnotations ann = do + ma <- getAnnotationDelta ann + let do_one ap' = addAnnotationWorker (G ann) ap' + -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) + mapM_ do_one (sort ma) + +-- | Look up and add possibly multiple Delta annotations enclosed by +-- the current SrcSpan at the current position, and advance the +-- position to the end of the annotations +addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta () +addDeltaAnnotationsInside ann = do + ss <- getSrcSpan + ma <- getAnnotationDelta ann + let do_one ap' = addAnnotationWorker (G ann) ap' + -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) + let filtered = sort $ filter (\s -> GHC.isSubspanOf s ss) ma + mapM_ do_one filtered + +-- | Look up and add possibly multiple Delta annotations not enclosed by +-- the current SrcSpan at the current position, and advance the +-- position to the end of the annotations +addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta () +addDeltaAnnotationsOutside gann ann = do + ss <- getSrcSpan + unless (ss2span ss == ((1,1),(1,1))) $ + do + -- ma <- getAnnotationDelta ss gann + ma <- getAndRemoveAnnotationDelta ss gann + let do_one ap' = addAnnotationWorker ann ap' + mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma) + +-- | Add a Delta annotation at the current position, and advance the +-- position to the end of the annotation +addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta () +addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s + +addEofAnnotation :: Delta () +addEofAnnotation = do + pe <- getPriorEnd + ma <- withSrcSpanDelta (GHC.noLoc ()) (getAnnotationDelta GHC.AnnEofPos) + case ma of + [] -> return () + (pa:pss) -> do + cs <- getUnallocatedComments + mapM_ addDeltaComment cs + let DP (r,c) = deltaFromSrcSpans pe pa + addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1)) + setPriorEnd pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) + + +countAnnsDelta :: GHC.AnnKeywordId -> Delta Int +countAnnsDelta ann = do + ma <- getAnnotationDelta ann + return (length ma) + + + diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs @@ -0,0 +1,90 @@ +module Language.Haskell.GHC.ExactPrint.Lookup (keywordToString) where + +import GHC (AnnKeywordId(..)) + +-- | Maps `AnnKeywordId` to the corresponding String representation. +-- There is no specific mapping for the following constructors. +-- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, +-- `AnnInfix` +keywordToString :: AnnKeywordId -> String +keywordToString kw = + let mkErr x = error $ "keywordToString: missing case for:" ++ show x + in + case kw of + -- Specifically handle all cases so that there are pattern match + -- warnings if new constructors are added. + AnnOpen -> mkErr kw + AnnClose -> mkErr kw + AnnVal -> mkErr kw + AnnPackageName -> mkErr kw + AnnHeader -> mkErr kw + AnnFunId -> mkErr kw + AnnInfix -> mkErr kw + AnnValStr -> mkErr kw + AnnAs -> "as" + AnnAt -> "@" + AnnBang -> "!" + AnnBackquote -> "`" + AnnBy -> "by" + AnnCase -> "case" + AnnClass -> "class" + AnnCloseC -> "}" + AnnCloseP -> ")" + AnnCloseS -> "]" + AnnColon -> ":" + AnnComma -> "," + AnnCommaTuple -> "," + AnnDarrow -> "=>" + AnnData -> "data" + AnnDcolon -> "::" + AnnDefault -> "default" + AnnDeriving -> "deriving" + AnnDo -> "do" + AnnDot -> "." + AnnDotdot -> ".." + AnnElse -> "else" + AnnEqual -> "=" + AnnExport -> "export" + AnnFamily -> "family" + AnnForall -> "forall" + AnnForeign -> "foreign" + AnnGroup -> "group" + AnnHiding -> "hiding" + AnnIf -> "if" + AnnImport -> "import" + AnnIn -> "in" + AnnInstance -> "instance" + AnnLam -> "\\" + AnnLarrow -> "<-" + AnnLet -> "let" + AnnMdo -> "mdo" + AnnMinus -> "-" + AnnModule -> "module" + AnnNewtype -> "newtype" + AnnOf -> "of" + AnnOpenC -> "{" + AnnOpenP -> "(" + AnnOpenS -> "[" + AnnPattern -> "pattern" + AnnProc -> "proc" + AnnQualified -> "qualified" + AnnRarrow -> "->" + AnnRec -> "rec" + AnnRole -> "role" + AnnSafe -> "safe" + AnnSemi -> ";" + AnnStatic -> "static" + AnnThen -> "then" + AnnTilde -> "~" + AnnTildehsh -> "~#" + AnnType -> "type" + AnnUnit -> "()" + AnnUsing -> "using" + AnnVbar -> "|" + AnnWhere -> "where" + Annlarrowtail -> "-<" + Annrarrowtail -> "->" + AnnLarrowtail -> "-<<" + AnnRarrowtail -> ">>-" + AnnEofPos -> "" + diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE NamedFieldPuns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.GHC.ExactPrint.Print +-- +----------------------------------------------------------------------------- +module Language.Haskell.GHC.ExactPrint.Print + ( + Anns + , exactPrintWithAnns + + , exactPrint + + ) where + +import Language.Haskell.GHC.ExactPrint.Types +import Language.Haskell.GHC.ExactPrint.Utils ( debug, undelta, isGoodDelta, showGhc, ) +import Language.Haskell.GHC.ExactPrint.Annotate + (AnnotationF(..), Annotated, Annotate(..), markLocated) +import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString) +import Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns ) + +import Control.Applicative +import Control.Monad.RWS +import Data.Data (Data) +import Data.List (partition) +import Data.Maybe (mapMaybe, fromMaybe, maybeToList) + +import Control.Monad.Trans.Free + +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 + => GHC.Located ast + -> Anns + -> String +exactPrintWithAnns ast an = runEP (markLocated ast) an + + +------------------------------------------------------ +-- The EP monad and basic combinators + +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? + -- AZ, it is already in the last element of Annotation, for withOffset + } + +data EPStack = EPStack + { epLHS :: LayoutStartCol -- ^ Marks the column of the LHS of the i + -- current layout block + } + +defaultEPState :: Anns -> EPState +defaultEPState as = EPState + { epPos = (1,1) + , epAnns = as + , epAnnKds = [] + } + +initialEPStack :: EPStack +initialEPStack = EPStack + { epLHS = 0 + } + +data EPWriter = EPWriter + { output :: Endo String } + +instance Monoid EPWriter where + mempty = EPWriter mempty + (EPWriter a) `mappend` (EPWriter c) = EPWriter (a <> c) + +--------------------------------------------------------- + +type EP a = RWS EPStack EPWriter EPState a + +runEP :: Annotated () -> Anns -> String +runEP action ans = + flip appEndo "" . output . snd + . (\next -> execRWS next initialEPStack (defaultEPState ans)) + . printInterpret $ action + + + + +printInterpret :: Annotated a -> EP a +printInterpret = iterTM go + where + go :: AnnotationF (EP a) -> EP a + go (MarkEOF next) = + printStringAtMaybeAnn (G GHC.AnnEofPos) "" >> next + go (MarkPrim kwid mstr next) = + let annString = fromMaybe (keywordToString kwid) mstr in + printStringAtMaybeAnn (G kwid) annString >> next + go (MarkOutside _ kwid next) = + printStringAtMaybeAnnAll kwid ";" >> next + go (MarkInside akwid next) = + allAnns akwid >> next + go (MarkMany akwid next) = + allAnns akwid >> next + go (MarkOffsetPrim kwid _ mstr next) = + let annString = fromMaybe (keywordToString kwid) mstr in + printStringAtMaybeAnn (G kwid) annString >> next + go (MarkAfter akwid next) = + justOne akwid >> next + go (WithAST lss flag action next) = + exactPC lss flag (NoLayoutRules <$ printInterpret action) >> next + go (OutputKD _ next) = + next + go (CountAnns kwid next) = + countAnnsEP (G kwid) >>= next + go (SetLayoutFlag kwid action next) = + setLayout kwid (printInterpret action) >> next + go (MarkExternal _ akwid s next) = + printStringAtMaybeAnn (G akwid) s >> next + +justOne, allAnns :: GHC.AnnKeywordId -> EP () +justOne kwid = printStringAtMaybeAnn (G kwid) (keywordToString kwid) +allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString kwid) + +------------------------------------------------------------------------- +-- |First move to the given location, then call exactP +exactPC :: Data ast => GHC.Located ast -> LayoutFlag -> EP LayoutFlag -> EP LayoutFlag +exactPC ast flag action = + do return () `debug` ("exactPC entered for:" ++ showGhc (GHC.getLoc ast)) + ma <- getAndRemoveAnnotation ast + let an@(Ann _ _ kds) = fromMaybe annNone ma + withContext kds an flag action + +getAndRemoveAnnotation :: (Data a) => GHC.Located a -> EP (Maybe Annotation) +getAndRemoveAnnotation a = do + (r, an') <- gets (getAndRemoveAnnotationEP a . epAnns) + modify (\s -> s { epAnns = an' }) + return r + +withContext :: [(KeywordId, DeltaPos)] + -> Annotation + -> LayoutFlag + -> EP LayoutFlag -> EP LayoutFlag +withContext kds an flag = withKds kds . withOffset an flag + +-- --------------------------------------------------------------------- +-- +-- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous +-- offset +-- +withOffset :: Annotation -> LayoutFlag -> (EP LayoutFlag -> EP LayoutFlag) +withOffset Ann{annEntryDelta, annDelta} flag k = do + let DP (edLine, edColumn) = annEntryDelta + oldOffset <- asks epLHS -- Shift from left hand column + (_l, currentColumn) <- getPos + rec + -- Calculate the new offset + -- 1. If the LayoutRules flag is set then we need to mark this position + -- as the start of a new layout block. + -- There are two cases (1) If we are on the same line and (2) if we + -- move to a new line. + -- (1) The start of the layout block is the current position added to + -- the delta + -- (2) The start of the layout block is the old offset added to the + -- "annOffset" (i.e., how far this annotation was from the edge) + let offset = case flag <> f of + LayoutRules -> LayoutStartCol $ + if edLine == 0 + then currentColumn + edColumn + else getLayoutStartCol oldOffset + getColDelta annDelta + NoLayoutRules -> oldOffset + f <- local (\s -> s { epLHS = offset }) k + return f + + +-- --------------------------------------------------------------------- +-- +-- Necessary as there are destructive gets of Kds across scopes +withKds :: [(KeywordId, DeltaPos)] -> EP a -> EP a +withKds kd action = do + modify (\s -> s { epAnnKds = kd : epAnnKds s }) + r <- action + modify (\s -> s { epAnnKds = tail (epAnnKds s) }) + return r + +------------------------------------------------------------------------ + +setLayout :: GHC.AnnKeywordId -> EP () -> EP LayoutFlag +setLayout akiwd k = do + p <- gets epPos + local (\s -> s { epLHS = LayoutStartCol (snd p - length (keywordToString akiwd))}) + (LayoutRules <$ k) + +getPos :: EP Pos +getPos = gets epPos + +setPos :: Pos -> EP () +setPos l = modify (\s -> s {epPos = l}) + +-- |Get the current column offset +getLayoutOffset :: EP LayoutStartCol +getLayoutOffset = asks epLHS + +-- --------------------------------------------------------------------- + +printStringAtMaybeAnn :: KeywordId -> String -> EP () +printStringAtMaybeAnn an str = do + (comments, ma) <- getAnnFinal an + printStringAtLsDelta comments (maybeToList ma) str + -- ++AZ++: Enabling the following line causes a very weird error associated with AnnPackageName. I suspect it is because it is forcing the evaluation of a non-existent an or str + -- `debug` ("printStringAtMaybeAnn:(an,ma,str)=" ++ show (an,ma,str)) + +printStringAtMaybeAnnAll :: KeywordId -> String -> EP () +printStringAtMaybeAnnAll an str = go + where + go = do + (comments, ma) <- getAnnFinal an + case ma of + Nothing -> return () + Just d -> printStringAtLsDelta comments [d] str >> go + +-- --------------------------------------------------------------------- + + +-- |destructive get, hence use an annotation once only +getAnnFinal :: KeywordId -> EP ([DComment], Maybe DeltaPos) +getAnnFinal kw = do + kd <- gets epAnnKds + let (r, kd', dcs) = case kd of + [] -> (Nothing ,[], []) + (k:kds) -> (r',kk:kds, dcs') + where (cs', r',kk) = destructiveGetFirst kw ([],k) + dcs' = mapMaybe keywordIdToDComment cs' + modify (\s -> s { epAnnKds = kd' }) + return (dcs, r) + +keywordIdToDComment :: (KeywordId, DeltaPos) -> Maybe DComment +keywordIdToDComment (AnnComment comment,_dp) = Just comment +keywordIdToDComment _ = Nothing + +-- | Get and remove the first item in the (k,v) list for which the k matches. +-- Return the value, together with any comments skipped over to get there. +destructiveGetFirst :: KeywordId -> ([(KeywordId,v)],[(KeywordId,v)]) + -> ([(KeywordId,v)], Maybe v,[(KeywordId,v)]) +destructiveGetFirst _key (acc,[]) = ([], Nothing ,acc) +destructiveGetFirst key (acc, (k,v):kvs ) + | k == key = let (cs,others) = commentsAndOthers acc in (cs, Just v ,others++kvs) + | otherwise = destructiveGetFirst key (acc++[(k,v)],kvs) + where + commentsAndOthers kvs' = partition isComment kvs' + isComment (AnnComment _ , _ ) = True + isComment _ = False + +-- --------------------------------------------------------------------- + +-- |This should be the final point where things are mode concrete, +-- before output. Hence the point where comments can be inserted +printStringAtLsDelta :: [DComment] -> [DeltaPos] -> String -> EP () +printStringAtLsDelta cs mc s = + case reverse mc of + (cl:_) -> do + p <- getPos + colOffset <- getLayoutOffset + if isGoodDeltaWithOffset cl colOffset + then do + mapM_ printQueuedComment cs + printStringAt (undelta p cl colOffset) s + `debug` ("printStringAtLsDelta:(pos,s):" ++ show (undelta p cl colOffset,s)) + else return () `debug` ("printStringAtLsDelta:bad delta for (mc,s):" ++ show (mc,s)) + _ -> return () + + +isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool +isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP (undelta (0,0) dp colOffset)) + +-- AZ:TODO: harvest the commonality between this and printStringAtLsDelta +printQueuedComment :: DComment -> EP () +printQueuedComment (DComment (dp,de) s) = do + p <- getPos + colOffset <- getLayoutOffset + let (dr,dc) = undelta (0,0) dp colOffset + if isGoodDelta (DP (dr,max 0 dc)) -- do not lose comments against the left margin + then do + printStringAt (undelta p dp colOffset) s + `debug` ("printQueuedComment:(pos,s):" ++ show (undelta p dp colOffset,s)) + setPos (undelta p de colOffset) + else return () `debug` ("printQueuedComment::bad delta for (dp,s):" ++ show (dp,s)) + +-- --------------------------------------------------------------------- + +-- |non-destructive get +peekAnnFinal :: KeywordId -> EP (Maybe DeltaPos) +peekAnnFinal kw = do + (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds) + return r + +countAnnsEP :: KeywordId -> EP Int +countAnnsEP an = length <$> peekAnnFinal an + +-- --------------------------------------------------------------------- +-- Printing functions + +printString :: String -> EP () +printString str = do + (l,c) <- gets epPos + setPos (l, c + length str) + tell (mempty {output = Endo $ showString str }) + +newLine :: EP () +newLine = do + (l,_) <- getPos + printString "\n" + setPos (l+1,1) + +padUntil :: Pos -> EP () +padUntil (l,c) = do + (l1,c1) <- getPos + case {- trace (show ((l,c), (l1,c1))) -} () of + _ {-()-} | l1 >= l && c1 <= c -> printString $ replicate (c - c1) ' ' + | l1 < l -> newLine >> padUntil (l,c) + | otherwise -> return () + +printWhitespace :: Pos -> EP () +printWhitespace = padUntil + +printStringAt :: Pos -> String -> EP () +printStringAt p str = printWhitespace p >> printString str diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs --- a/src/Language/Haskell/GHC/ExactPrint/Types.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId module Language.Haskell.GHC.ExactPrint.Types ( @@ -9,8 +10,7 @@ , Span , PosToken , DeltaPos(..) - , ColOffset,ColDelta,Col - , LineChanged(..) + , LayoutStartCol(..) , ColDelta(..) , Annotation(..) , combineAnns , annNone @@ -19,19 +19,19 @@ , mkAnnKey , AnnConName(..) , annGetConstr - , unConName , ResTyGADTHook(..) , getAnnotationEP , getAndRemoveAnnotationEP + , LayoutFlag(..) + ) where -import Data.Data -import Data.Monoid +import Data.Data (Data, Typeable, toConstr) -import qualified GHC as GHC +import qualified GHC import qualified Outputable as GHC import qualified Data.Map as Map @@ -57,51 +57,40 @@ type Pos = (Int,Int) type Span = (Pos,Pos) -data DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) -type ColOffset = Int -- ^ indentation point for a new line -type ColDelta = Int -- ^ difference between two cols -type Col = Int +newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) +-- | Marks the start column of a layout block. +newtype LayoutStartCol = LayoutStartCol { getLayoutStartCol :: Int } + deriving (Eq, Show, Num) +-- | Marks the distance from the start of the layout block to the element. +newtype ColDelta = ColDelta { getColDelta :: Int } + deriving (Eq, Show, Num) + annNone :: Annotation -annNone = Ann (DP (0,0)) LineSame 0 0 [] +annNone = Ann (DP (0,0)) 0 [] combineAnns :: Annotation -> Annotation -> Annotation -combineAnns (Ann ed1 nl1 c1 dp1 dps1) (Ann _ed2 _nl2 _c2 _dp2 dps2) - = Ann ed1 nl1 c1 dp1 (dps1 ++ dps2) - -data LineChanged = LineSame | LineChanged - | KeepOffset -- ^ For use in AST editing - | LayoutLineSame | LayoutLineChanged -- experimental, may replace LineSame and LineChanged - deriving (Show,Eq,Typeable) +combineAnns (Ann ed1 c1 dps1) (Ann _ed2 _c2 dps2) + = Ann ed1 c1 (dps1 ++ dps2) data Annotation = Ann { - ann_entry_delta :: !DeltaPos -- ^ Offset used to get to the start - -- of the SrcSpan, during the - -- annotatePC phase - , ann_original_nl :: !LineChanged -- ^ Did the original span start - -- on a new line wrt to the prior - -- one? - , ann_original_col :: !Col -- ^ Start of the SrcSpan, as used - -- during the annotatePC phase - , ann_delta :: !ColOffset -- ^ Indentation level introduced - -- by this SrcSpan, for other items - -- at same layout level - , anns :: [(KeywordId, DeltaPos)] -- TODO:AZ change this to ann_dps + annEntryDelta :: !DeltaPos -- ^ Offset used to get to the start + -- of the SrcSpan. + , annDelta :: !ColDelta -- ^ Offset from the start of the current layout + -- block. This is used when moving onto new + -- lines when layout rules must be obeyed. + , annsDP :: [(KeywordId, DeltaPos)] -- ^ Annotations associated with this element. } deriving (Typeable,Eq) instance Show Annotation where - show (Ann dp nl c d ans) = "(Ann (" ++ show dp ++ ") " ++ show nl ++ " " ++ show c ++ " " ++ show d ++ " " ++ show ans ++ ")" + show (Ann dp c ans) = "(Ann (" ++ show dp ++ ") " ++ show c ++ " " ++ " " ++ show ans ++ ")" instance Monoid Annotation where mempty = annNone mappend = combineAnns - -instance Show GHC.RdrName where - show n = "(a RdrName)" - type Anns = Map.Map AnnKey Annotation -- | For every @Located a@, use the @SrcSpan@ and constructor name of @@ -114,26 +103,12 @@ mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a) -- Holds the name of a constructor -data AnnConName = CN String +data AnnConName = CN { unConName :: String } deriving (Eq,Show,Ord) annGetConstr :: (Data a) => a -> AnnConName annGetConstr a = CN (show $ toConstr a) -{- -annGetConstr a = CN con - where - -- map all RdrName constuctors to the same field. - con = case show $ toConstr a of - "Unqual" -> "RdrName" - "Qual" -> "RdrName" - "Orig" -> "RdrName" - "Exact" -> "RdrName" - s -> s --} -unConName :: AnnConName -> String -unConName (CN s) = s - -- |We need our own version of keywordid to distinguish between a -- semi-colon appearing within an AST element and one separating AST -- elements in a list. @@ -150,6 +125,14 @@ -- potential AST edits. deriving (Eq,Show,Ord) +data LayoutFlag = LayoutRules | NoLayoutRules deriving (Show, Eq) + +instance Monoid LayoutFlag where + mempty = NoLayoutRules + LayoutRules `mappend` _ = LayoutRules + _ `mappend` LayoutRules = LayoutRules + _ `mappend` _ = NoLayoutRules + -- --------------------------------------------------------------------- instance GHC.Outputable KeywordId where @@ -182,14 +165,15 @@ -- --------------------------------------------------------------------- getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation -getAnnotationEP (GHC.L ss a) anns = Map.lookup (AnnKey ss (annGetConstr a)) anns +getAnnotationEP (GHC.L ss a) annotations = + Map.lookup (AnnKey ss (annGetConstr a)) annotations getAndRemoveAnnotationEP :: (Data a) => GHC.Located a -> Anns -> (Maybe Annotation,Anns) -getAndRemoveAnnotationEP (GHC.L ss a) anns +getAndRemoveAnnotationEP (GHC.L ss a) annotations = let key = AnnKey ss (annGetConstr a) in - case Map.lookup key anns of - Nothing -> (Nothing,anns) - Just av -> (Just av,Map.delete key anns) + case Map.lookup key annotations of + Nothing -> (Nothing, annotations) + Just av -> (Just av, Map.delete key annotations) -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -1,2471 +1,275 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId -module Language.Haskell.GHC.ExactPrint.Utils - ( - annotateLHsModule - - , srcSpanStartLine - , srcSpanEndLine - , srcSpanStartColumn - , srcSpanEndColumn - , getListSrcSpan - , getLocalBindsSrcSpan - - , ss2span - , ss2pos - , ss2posEnd - , span2ss - , undelta - , undeltaComment - , isGoodDelta - , rdrName2String - , isSymbolRdrName - - , isListComp - - , showGhc - , showAnnData - - - -- * For tests - , debug - - , runAP - , AP - , getSrcSpanAP, pushSrcSpanAP, popSrcSpanAP - , getAnnotationAP - , addAnnotationsAP - - , ghead - , glast - , gtail - , gfromJust - - ) where - -import Control.Monad.State -import Control.Monad.Writer -import Control.Applicative -import Control.Exception -import Data.Data -import Data.Generics -import Data.List - -import Language.Haskell.GHC.ExactPrint.Types - -import qualified Bag as GHC -import qualified BasicTypes as GHC -import qualified BooleanFormula as GHC -import qualified Class as GHC -import qualified CoAxiom as GHC -import qualified DynFlags as GHC -import qualified FastString as GHC -import qualified ForeignCall as GHC -import qualified GHC as GHC -import qualified Name as GHC -import qualified NameSet as GHC -import qualified Outputable as GHC -import qualified RdrName as GHC -import qualified SrcLoc as GHC -import qualified Var as GHC - -import qualified OccName(occNameString) - -import qualified Data.Map as Map - -import Debug.Trace - -debug :: c -> String -> c --- debug = flip trace -debug c _ = c - --- --------------------------------------------------------------------- - - -data APState = APState - { -- | A stack to the root of the AST. - apStack :: [StackItem] - , priorEndPosition :: GHC.SrcSpan - -- | Ordered list of comments still to be allocated - , apComments :: [Comment] - -- | isInfix for a FunBind - -- AZ: Is this still needed? - , e_is_infix :: Bool - -- | The original GHC API Annotations - , apAnns :: GHC.ApiAnns - } - -data StackItem = StackItem - { -- | Current `SrcSpan` - curSrcSpan :: GHC.SrcSpan - -- | The offset required to get from the prior end point to the - -- start of the current SrcSpan. Accessed via `getEntryDP` - , offset :: DeltaPos - -- | Offsets for the elements annotated in this `SrcSpan` - , annOffsets :: [(KeywordId, DeltaPos)] - -- | Indicates whether the contents of this SrcSpan are - -- subject to vertical alignment layout rules - , curLayoutOn :: Bool - -- | The constructor name of the AST element, to - -- distinguish between nested elements that have the same - -- `SrcSpan` in the AST. - , annConName :: AnnConName - } - -defaultAPState :: GHC.ApiAnns -> APState -defaultAPState ga = - let cs = flattenedComments ga in - APState - { apStack = [] - , priorEndPosition = GHC.noSrcSpan - , apComments = cs - , e_is_infix = False -- ^ AZ: Is this still needed? isInfix for a FunBind - , apAnns = ga -- $ - } - --- | Type used in the AP Monad. The state variables maintain --- - the current SrcSpan and the constructor of the thing it encloses --- as a stack to the root of the AST as it is traversed, --- - the srcspan of the last thing annotated, to calculate delta's from --- - extra data needing to be stored in the monad --- - the annotations provided by GHC -type AP a = StateT APState (Writer [(AnnKey, Annotation)]) a - -data Grouping = None | Primed GHC.SrcSpan | Active DeltaPos | Done DeltaPos - deriving (Eq,Show) - - -runAP :: AP () -> GHC.ApiAnns -> Anns -runAP apf ga = Map.fromListWith combineAnns . snd . runWriter - . flip execStateT (defaultAPState ga) $ apf - --- `debug` ("runAP:cs=" ++ showGhc cs) - - --- --------------------------------------------------------------------- - -flattenedComments :: GHC.ApiAnns -> [Comment] -flattenedComments (_,cm) = map tokComment . GHC.sortLocated . concat $ Map.elems cm - --- ------------------------------------- - -getSrcSpanAP :: AP GHC.SrcSpan -getSrcSpanAP = gets (curSrcSpan . ghead "getSrcSpanAP" . apStack) - -getPriorSrcSpanAP :: AP GHC.SrcSpan -getPriorSrcSpanAP = gets (curSrcSpan . ghead "getPriorSrcSpanAP" . tail . apStack) - -pushSrcSpanAP :: Data a => (GHC.Located a) -> DeltaPos -> AP () -pushSrcSpanAP (GHC.L l a) edp = - let newss = StackItem l edp [] False (annGetConstr a) in - modify (\s -> s { apStack = newss : (apStack s) }) - -popSrcSpanAP :: AP () -popSrcSpanAP = modify (\s -> s { apStack = tail (apStack s) }) - -getEntryDP :: AP DeltaPos -getEntryDP = gets (offset . head . apStack) - -getUnallocatedComments :: AP [Comment] -getUnallocatedComments = gets apComments - -putUnallocatedComments :: [Comment] -> AP () -putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) - --- --------------------------------------------------------------------- - -adjustDeltaForOffsetM :: DeltaPos -> AP DeltaPos -adjustDeltaForOffsetM dp = do - colOffset <- getCurrentColOffset - return (adjustDeltaForOffset colOffset dp) - -adjustDeltaForOffset :: Int -> DeltaPos -> DeltaPos -adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line -adjustDeltaForOffset colOffset (DP (l,c)) = DP (l,c - colOffset) - --- --------------------------------------------------------------------- - --- | Get the current column offset -getCurrentColOffset :: AP ColOffset -getCurrentColOffset = srcSpanStartColumn <$> getSrcSpanAP - --- |Get the difference between the current and the previous --- colOffsets, if they are on the same line -getCurrentDP :: AP (ColOffset,LineChanged) -getCurrentDP = do - -- Note: the current col offsets are not needed here, any - -- indentation should be fully nested in an AST element - ss <- getSrcSpanAP - ps <- getPriorSrcSpanAP - layoutOn <- getLayoutOn - {- - let r = if srcSpanStartLine ss == srcSpanStartLine ps - then (srcSpanStartColumn ss - srcSpanStartColumn ps,LineSame) - else (srcSpanStartColumn ss, LineChanged) - -} - let colOffset = if srcSpanStartLine ss == srcSpanStartLine ps - then srcSpanStartColumn ss - srcSpanStartColumn ps - else srcSpanStartColumn ss - let r = case (layoutOn, srcSpanStartLine ss == srcSpanStartLine ps) of - (True, True) -> (colOffset, LayoutLineSame) - (True, False) -> (colOffset, LayoutLineChanged) - (False, True) -> (colOffset, LineSame) - (False,False) -> (colOffset, LineChanged) - return r - `debug` ("getCurrentDP:layoutOn=" ++ show layoutOn) - --- --------------------------------------------------------------------- - --- |Note: assumes the prior end SrcSpan stack is nonempty -getPriorEnd :: AP GHC.SrcSpan -getPriorEnd = gets priorEndPosition - -setPriorEnd :: GHC.SrcSpan -> AP () -setPriorEnd pe = modify (\s -> s { priorEndPosition = pe }) - --- ------------------------------------- - -getAnnotationAP :: GHC.AnnKeywordId -> AP [GHC.SrcSpan] -getAnnotationAP an = do - ga <- gets apAnns - ss <- getSrcSpanAP - return $ GHC.getAnnotation ga ss an - -getAndRemoveAnnotationAP :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP [GHC.SrcSpan] -getAndRemoveAnnotationAP sp an = do - ga <- gets apAnns - let (r,ga') = GHC.getAndRemoveAnnotation ga sp an - r <$ modify (\s -> s { apAnns = ga' }) - - -tokComment :: GHC.Located GHC.AnnotationComment -> Comment -tokComment t@(GHC.L lt _) = Comment (ss2span lt) (ghcCommentText t) - --- ------------------------------------- - --- |Add some annotation to the currently active SrcSpan -addAnnotationsAP :: Annotation -> AP () -addAnnotationsAP ann = do - l <- gets apStack - tell [((getAnnKey $ ghead "addAnnotationsAP" l),ann)] - -getAnnKey :: StackItem -> AnnKey -getAnnKey StackItem {curSrcSpan, annConName} = AnnKey curSrcSpan annConName - --- ------------------------------------- - -addAnnDeltaPos :: (GHC.SrcSpan,KeywordId) -> DeltaPos -> AP () -addAnnDeltaPos (_s,kw) dp = do - (st:sts) <- gets apStack - modify (\s -> s { apStack = (manip st) : sts }) - where - manip s = s { annOffsets = (kw, dp) : (annOffsets s) } - --- ------------------------------------- - -getLayoutOn :: AP Bool -getLayoutOn = gets (curLayoutOn . ghead "getSrcSpanAP" . apStack) - -setLayoutOn :: Bool -> AP () -setLayoutOn layoutOn = do - (st:sts) <- gets apStack - modify (\s -> s { apStack = (manip st) : sts }) - where - manip s = s { curLayoutOn = layoutOn } - --- ------------------------------------- - -getKds :: AP [(KeywordId,DeltaPos)] -getKds = gets (reverse . annOffsets . head . apStack) - --- ------------------------------------- - -setFunIsInfix :: Bool -> AP () -setFunIsInfix e = modify (\s -> s {e_is_infix = e}) - -getFunIsInfix :: AP Bool -getFunIsInfix = gets e_is_infix - --- ------------------------------------- - --- | Enter a new AST element. Maintain SrcSpan stack -enterAST :: Data a => GHC.Located a -> AP () -enterAST lss = do - return () `debug` ("enterAST entered for " ++ show (ss2span $ GHC.getLoc lss)) - -- return () `debug` ("enterAST:currentColOffset=" ++ show (DP (0,srcSpanStartColumn $ GHC.getLoc lss))) - -- Calculate offset required to get to the start of the SrcSPan - pe <- getPriorEnd - let ss = (GHC.getLoc lss) - let edp = deltaFromSrcSpans pe ss - edp' <- adjustDeltaForOffsetM edp - -- need to save edp', and put it in Annotation - - pushSrcSpanAP lss edp' - - return () - - --- | Pop up the SrcSpan stack, capture the annotations -leaveAST :: AP () -leaveAST = do - -- Automatically add any trailing comma or semi - addDeltaAnnotationAfter GHC.AnnComma - ss <- getSrcSpanAP - if ss2span ss == ((1,1),(1,1)) - then return () - else addDeltaAnnotationsOutside GHC.AnnSemi AnnSemiSep - - (dp,nl) <- getCurrentDP - edp <- getEntryDP - kds <- getKds - addAnnotationsAP (Ann edp nl (srcSpanStartColumn ss) dp kds) - `debug` ("leaveAST:(ss,edp,dp,kds)=" ++ show (showGhc ss,edp,dp,kds,dp)) - popSrcSpanAP - return () -- `debug` ("leaveAST:(ss,dp,priorEnd)=" ++ show (ss2span ss,dp,ss2span priorEnd)) - --- --------------------------------------------------------------------- - -class Data ast => AnnotateP ast where - annotateP :: GHC.SrcSpan -> ast -> AP () - --- |First move to the given location, then call exactP -annotatePC :: (AnnotateP ast) => GHC.Located ast -> AP () -annotatePC a = withLocated a annotateP - -withLocated :: Data a => GHC.Located a -> (GHC.SrcSpan -> a -> AP ()) -> AP () -withLocated a@(GHC.L l ast) action = do - enterAST a `debug` ("annotatePC:entering " ++ showGhc l) - action l ast - leaveAST `debug` ("annotatePC:leaving " ++ showGhc (l)) - -annotateMaybe :: (AnnotateP ast) => Maybe (GHC.Located ast) -> AP () -annotateMaybe Nothing = return () -annotateMaybe (Just ast) = annotatePC ast - -annotateList :: (AnnotateP ast) => [GHC.Located ast] -> AP () -annotateList xs = mapM_ annotatePC xs - --- | Flag the item to be annotated as requiring layout. -annotateWithLayout :: AnnotateP ast => GHC.Located ast -> AP () -annotateWithLayout a = do - withLocated a (\l ast -> annotateP l ast >> setLayoutOn True) - -annotateListWithLayout :: AnnotateP [GHC.Located ast] => GHC.SrcSpan -> [GHC.Located ast] -> AP () -annotateListWithLayout l ls = do - let ss = getListSrcSpan ls - addAnnDeltaPos (l,AnnList ss) (DP (0,0)) - annotateWithLayout (GHC.L ss ls) - --- --------------------------------------------------------------------- - -isGoodDelta :: DeltaPos -> Bool -isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0 - --- --------------------------------------------------------------------- - --- |Split the ordered list of comments into ones that occur prior to --- the given SrcSpan and the rest -allocatePriorComments :: [Comment] -> GHC.SrcSpan -> ([Comment],[Comment]) -allocatePriorComments cs ss = partition isPrior cs - where - (start,_) = ss2span ss - isPrior (Comment s _) = (fst s) < start - `debug` ("allocatePriorComments:(s,ss,cond)=" ++ showGhc (s,ss,(fst s) < start)) - --- --------------------------------------------------------------------- - -addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> AP () -addAnnotationWorker ann pa = do - if not (isPointSrcSpan pa) - then do - pe <- getPriorEnd - ss <- getSrcSpanAP - let p = deltaFromSrcSpans pe pa - case (ann,isGoodDelta p) of - (G GHC.AnnComma,False) -> return () - (G GHC.AnnSemi, False) -> return () - (G GHC.AnnOpen, False) -> return () - (G GHC.AnnClose,False) -> return () - _ -> do - cs <- getUnallocatedComments - let (allocated,cs') = allocatePriorComments cs pa - putUnallocatedComments cs' - return () `debug`("addAnnotationWorker:(ss,pa,allocated,cs)=" ++ showGhc (ss,pa,allocated,cs)) - mapM_ addDeltaComment allocated - p' <- adjustDeltaForOffsetM p - addAnnDeltaPos (ss,ann) p' - setPriorEnd pa - -- `debug` ("addDeltaAnnotationWorker:(ss,pe,pa,p,ann)=" ++ show (ss2span ss,ss2span pe,ss2span pa,p,ann)) - else do - return () - -- `debug` ("addDeltaAnnotationWorker::point span:(ss,ma,ann)=" ++ show (ss2span pa,ann)) - --- --------------------------------------------------------------------- - -addDeltaComment :: Comment -> AP () -addDeltaComment (Comment paspan str) = do - let pa = span2ss paspan - pe <- getPriorEnd - ss <- getSrcSpanAP - let p = deltaFromSrcSpans pe pa - p' <- adjustDeltaForOffsetM p - setPriorEnd pa - let e = ss2deltaP (ss2posEnd pe) (snd paspan) - e' <- adjustDeltaForOffsetM e - addAnnDeltaPos (ss,AnnComment (DComment (p',e') str)) p' - --- --------------------------------------------------------------------- - --- | Look up and add a Delta annotation at the current position, and --- advance the position to the end of the annotation -addDeltaAnnotation :: GHC.AnnKeywordId -> AP () -addDeltaAnnotation ann = do - ss <- getSrcSpanAP - ma <- getAnnotationAP ann - case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier - [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show ann) - [pa] -> addAnnotationWorker (G ann) pa - _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma) - --- | Look up and add a Delta annotation appearing beyond the current --- SrcSpan at the current position, and advance the position to the --- end of the annotation -addDeltaAnnotationAfter :: GHC.AnnKeywordId -> AP () -addDeltaAnnotationAfter ann = do - ss <- getSrcSpanAP - ma <- getAnnotationAP ann - let ma' = filter (\s -> not (GHC.isSubspanOf s ss)) ma - case ma' of - [] -> return () `debug` ("addDeltaAnnotation empty ma") - [pa] -> addAnnotationWorker (G ann) pa - _ -> error $ "addDeltaAnnotation:(ss,ann,ma)=" ++ showGhc (ss,ann,ma) - --- | Look up and add a Delta annotation at the current position, and --- advance the position to the end of the annotation -addDeltaAnnotationLs :: GHC.AnnKeywordId -> Int -> AP () -addDeltaAnnotationLs ann off = do - ma <- getAnnotationAP ann - case (drop off ma) of - [] -> return () - -- `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma)) - (pa:_) -> addAnnotationWorker (G ann) pa - --- | Look up and add possibly multiple Delta annotation at the current --- position, and advance the position to the end of the annotations -addDeltaAnnotations :: GHC.AnnKeywordId -> AP () -addDeltaAnnotations ann = do - ma <- getAnnotationAP ann - let do_one ap' = addAnnotationWorker (G ann) ap' - -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - mapM_ do_one (sort ma) - --- | Look up and add possibly multiple Delta annotations enclosed by --- the current SrcSpan at the current position, and advance the --- position to the end of the annotations -addDeltaAnnotationsInside :: GHC.AnnKeywordId -> AP () -addDeltaAnnotationsInside ann = do - ss <- getSrcSpanAP - ma <- getAnnotationAP ann - let do_one ap' = addAnnotationWorker (G ann) ap' - -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - mapM_ do_one (sort $ filter (\s -> GHC.isSubspanOf s ss) ma) - --- | Look up and add possibly multiple Delta annotations not enclosed by --- the current SrcSpan at the current position, and advance the --- position to the end of the annotations -addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> AP () -addDeltaAnnotationsOutside gann ann = do - ss <- getSrcSpanAP - -- ma <- getAnnotationAP ss gann - ma <- getAndRemoveAnnotationAP ss gann - let do_one ap' = addAnnotationWorker ann ap' - -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) - mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma) - --- | Add a Delta annotation at the current position, and advance the --- position to the end of the annotation -addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> AP () -addDeltaAnnotationExt s ann = do - addAnnotationWorker (G ann) s - - -addEofAnnotation :: AP () -addEofAnnotation = do - pe <- getPriorEnd - ss <- getSrcSpanAP - pushSrcSpanAP (GHC.noLoc ()) (DP (0,0)) - ma <- getAnnotationAP GHC.AnnEofPos - popSrcSpanAP - case ma of - [] -> return () - [pa] -> do - cs <- getUnallocatedComments - mapM_ addDeltaComment cs - let DP (r,c) = deltaFromSrcSpans pe pa - addAnnDeltaPos (ss,G GHC.AnnEofPos) (DP (r, c - 1)) - setPriorEnd pa - -countAnnsAP :: GHC.AnnKeywordId -> AP Int -countAnnsAP ann = do - ma <- getAnnotationAP ann - return (length ma) - --- --------------------------------------------------------------------- --- Managing lists which have been separated, e.g. Sigs and Binds - -prepareListAnnotation :: AnnotateP a => [GHC.Located a] -> [(GHC.SrcSpan,AP ())] -prepareListAnnotation ls = map (\b@(GHC.L l _) -> (l,annotatePC b)) ls - -applyListAnnotations :: [(GHC.SrcSpan,AP ())] -> AP () -applyListAnnotations ls - = mapM_ (\(_,b) -> b) $ sortBy (\(a,_) (b,_) -> compare a b) ls - --- --------------------------------------------------------------------- --- Start of application specific part - --- --------------------------------------------------------------------- - -annotateLHsModule :: GHC.Located (GHC.HsModule GHC.RdrName) -> GHC.ApiAnns - -> Anns -annotateLHsModule modu ghcAnns - = runAP (pushSrcSpanAP (GHC.L GHC.noSrcSpan ()) (DP (0,0)) >> annotatePC modu) ghcAnns - --- --------------------------------------------------------------------- - -instance AnnotateP (GHC.HsModule GHC.RdrName) where - annotateP lm (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do - setPriorEnd lm - - addDeltaAnnotation GHC.AnnModule - - case mmn of - Nothing -> return () - Just (GHC.L ln _) -> addDeltaAnnotationExt ln GHC.AnnVal - - annotateMaybe mdepr - - case mexp of - Nothing -> return () - Just expr -> annotatePC expr - - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- Possible '{' - addDeltaAnnotations GHC.AnnSemi -- possible leading semis - mapM_ annotatePC imps - - annotateList decs - - addDeltaAnnotation GHC.AnnCloseC -- Possible '}' - - addEofAnnotation - - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.WarningTxt where - annotateP _ (GHC.WarningTxt (GHC.L ls _) lss) = do - addDeltaAnnotationExt ls GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenS - mapM_ annotatePC lss - addDeltaAnnotation GHC.AnnCloseS - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.DeprecatedTxt (GHC.L ls _) lss) = do - addDeltaAnnotationExt ls GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenS - mapM_ annotatePC lss - addDeltaAnnotation GHC.AnnCloseS - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name) - => AnnotateP [GHC.LIE name] where - annotateP _ ls = do - addDeltaAnnotation GHC.AnnHiding -- in an import decl - addDeltaAnnotation GHC.AnnOpenP -- '(' - mapM_ annotatePC ls - addDeltaAnnotation GHC.AnnCloseP -- ')' - -instance (GHC.DataId name,AnnotateP name) - => AnnotateP (GHC.IE name) where - annotateP _ ie = do - - case ie of - (GHC.IEVar ln) -> do - addDeltaAnnotation GHC.AnnPattern - addDeltaAnnotation GHC.AnnType - annotatePC ln - - (GHC.IEThingAbs ln) -> do - addDeltaAnnotation GHC.AnnType - annotatePC ln - - (GHC.IEThingWith ln ns) -> do - annotatePC ln - addDeltaAnnotation GHC.AnnOpenP - mapM_ annotatePC ns - addDeltaAnnotation GHC.AnnCloseP - - (GHC.IEThingAll ln) -> do - annotatePC ln - addDeltaAnnotation GHC.AnnOpenP - addDeltaAnnotation GHC.AnnDotdot - addDeltaAnnotation GHC.AnnCloseP - - (GHC.IEModuleContents (GHC.L lm _n)) -> do - addDeltaAnnotation GHC.AnnModule - addDeltaAnnotationExt lm GHC.AnnVal - - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.RdrName where - annotateP l n = do - case rdrName2String n of - "[]" -> do - addDeltaAnnotation GHC.AnnOpenS -- '[' - addDeltaAnnotation GHC.AnnCloseS -- ']' - "()" -> do - addDeltaAnnotation GHC.AnnOpenP -- '(' - addDeltaAnnotation GHC.AnnCloseP -- ')' - "(##)" -> do - addDeltaAnnotation GHC.AnnOpen -- '(#' - addDeltaAnnotation GHC.AnnClose -- '#)' - "[::]" -> do - addDeltaAnnotation GHC.AnnOpen -- '[:' - addDeltaAnnotation GHC.AnnClose -- ':]' - _ -> do - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnOpenP -- '(' - addDeltaAnnotationLs GHC.AnnBackquote 0 - addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)' - cnt <- countAnnsAP GHC.AnnVal - cntT <- countAnnsAP GHC.AnnCommaTuple - cntR <- countAnnsAP GHC.AnnRarrow - case cnt of - 0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal - 1 -> addDeltaAnnotation GHC.AnnVal - x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x) - addDeltaAnnotation GHC.AnnTildehsh - addDeltaAnnotation GHC.AnnTilde - addDeltaAnnotation GHC.AnnRarrow - addDeltaAnnotationLs GHC.AnnBackquote 1 - addDeltaAnnotation GHC.AnnCloseP -- ')' - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.Name where - annotateP l _n = do - addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name) - => AnnotateP (GHC.ImportDecl name) where - annotateP _ (GHC.ImportDecl _msrc (GHC.L ln _) _pkg _src _safe _qual _impl _as hiding) = do - - -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec - addDeltaAnnotation GHC.AnnImport - - -- "{-# SOURCE" and "#-}" - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnClose - addDeltaAnnotation GHC.AnnSafe - addDeltaAnnotation GHC.AnnQualified - addDeltaAnnotation GHC.AnnPackageName - - addDeltaAnnotationExt ln GHC.AnnVal -- modid - - addDeltaAnnotation GHC.AnnAs - addDeltaAnnotation GHC.AnnVal -- as modid - - case hiding of - Nothing -> return () - Just (_isHiding,lie) -> do - addDeltaAnnotation GHC.AnnHiding - annotatePC lie - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsDecl name) where - annotateP l decl = do - case decl of - GHC.TyClD d -> annotateP l d - GHC.InstD d -> annotateP l d - GHC.DerivD d -> annotateP l d - GHC.ValD d -> annotateP l d - GHC.SigD d -> annotateP l d - GHC.DefD d -> annotateP l d - GHC.ForD d -> annotateP l d - GHC.WarningD d -> annotateP l d - GHC.AnnD d -> annotateP l d - GHC.RuleD d -> annotateP l d - GHC.VectD d -> annotateP l d - GHC.SpliceD d -> annotateP l d - GHC.DocD d -> annotateP l d - GHC.QuasiQuoteD d -> annotateP l d - GHC.RoleAnnotD d -> annotateP l d - --- --------------------------------------------------------------------- - -instance (AnnotateP name) - => AnnotateP (GHC.RoleAnnotDecl name) where - annotateP _ (GHC.RoleAnnotDecl ln mr) = do - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnRole - annotatePC ln - mapM_ annotatePC mr - -instance AnnotateP (Maybe GHC.Role) where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (AnnotateP name) - => AnnotateP (GHC.HsQuasiQuote name) where - annotateP _ (GHC.HsQuasiQuote _n _ss _fs) = assert False undefined - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.SpliceDecl name) where - annotateP _ (GHC.SpliceDecl (GHC.L _ls (GHC.HsSplice _n e)) _flag) = do - addDeltaAnnotation GHC.AnnOpen -- "$(" or "$$(" - annotatePC e - addDeltaAnnotation GHC.AnnClose -- ")" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.VectDecl name) where - annotateP _ (GHC.HsVect _src ln e) = do - addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE" - annotatePC ln - addDeltaAnnotation GHC.AnnEqual - annotatePC e - addDeltaAnnotation GHC.AnnClose -- "#-}" - - annotateP _ (GHC.HsNoVect _src ln) = do - addDeltaAnnotation GHC.AnnOpen -- "{-# NOVECTORISE" - annotatePC ln - addDeltaAnnotation GHC.AnnClose -- "#-}" - - annotateP _ (GHC.HsVectTypeIn _src _b ln mln) = do - addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" - addDeltaAnnotation GHC.AnnType - annotatePC ln - addDeltaAnnotation GHC.AnnEqual - annotateMaybe mln - addDeltaAnnotation GHC.AnnClose -- "#-}" - - annotateP _ (GHC.HsVectTypeOut {}) = error $ "annotateP.HsVectTypeOut: only valid after type checker" - - annotateP _ (GHC.HsVectClassIn _src ln) = do - addDeltaAnnotation GHC.AnnOpen -- "{-# VECTORISE" - addDeltaAnnotation GHC.AnnClass - annotatePC ln - addDeltaAnnotation GHC.AnnClose -- "#-}" - - annotateP _ (GHC.HsVectClassOut {}) = error $ "annotateP.HsVectClassOut: only valid after type checker" - annotateP _ (GHC.HsVectInstIn {}) = error $ "annotateP.HsVectInstIn: not supported?" - annotateP _ (GHC.HsVectInstOut {}) = error $ "annotateP.HsVectInstOut: not supported?" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.RuleDecls name) where - annotateP _ (GHC.HsRules _src rules) = do - addDeltaAnnotation GHC.AnnOpen - mapM_ annotatePC rules - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.RuleDecl name) where - annotateP _ (GHC.HsRule ln _act bndrs lhs _ rhs _) = do - annotatePC ln - -- activation - addDeltaAnnotation GHC.AnnOpenS -- "[" - addDeltaAnnotation GHC.AnnTilde - addDeltaAnnotation GHC.AnnVal - addDeltaAnnotation GHC.AnnCloseS -- "]" - - addDeltaAnnotation GHC.AnnForall - mapM_ annotatePC bndrs - addDeltaAnnotation GHC.AnnDot - - annotatePC lhs - addDeltaAnnotation GHC.AnnEqual - annotatePC rhs - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.RuleBndr name) where - annotateP _ (GHC.RuleBndr ln) = annotatePC ln - annotateP _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do - addDeltaAnnotation GHC.AnnOpenP -- "(" - annotatePC ln - addDeltaAnnotation GHC.AnnDcolon - annotatePC thing - addDeltaAnnotation GHC.AnnCloseP -- ")" - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.AnnDecl name) where - annotateP _ (GHC.HsAnnotation _src prov e) = do - addDeltaAnnotation GHC.AnnOpen -- "{-# Ann" - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnModule - case prov of - (GHC.ValueAnnProvenance n) -> annotatePC n - (GHC.TypeAnnProvenance n) -> annotatePC n - (GHC.ModuleAnnProvenance) -> return () - - annotatePC e - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - -instance AnnotateP name => AnnotateP (GHC.WarnDecls name) where - annotateP _ (GHC.Warnings _src warns) = do - addDeltaAnnotation GHC.AnnOpen - mapM_ annotatePC warns - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - -instance (AnnotateP name) - => AnnotateP (GHC.WarnDecl name) where - annotateP _ (GHC.Warning lns txt) = do - mapM_ annotatePC lns - addDeltaAnnotation GHC.AnnOpenS -- "[" - case txt of - GHC.WarningTxt _src ls -> mapM_ annotatePC ls - GHC.DeprecatedTxt _src ls -> mapM_ annotatePC ls - addDeltaAnnotation GHC.AnnCloseS -- "]" - -instance AnnotateP GHC.FastString where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.ForeignDecl name) where - - annotateP _ (GHC.ForeignImport ln typ _ - (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls _src))) = do - addDeltaAnnotation GHC.AnnForeign - addDeltaAnnotation GHC.AnnImport - annotatePC cconv - if ll == GHC.noSrcSpan - then return () - else annotatePC safety - -- annotateMaybe mh - addDeltaAnnotationExt ls GHC.AnnVal - annotatePC ln - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - - annotateP _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls _src))) = do - addDeltaAnnotation GHC.AnnForeign - addDeltaAnnotation GHC.AnnExport - annotatePC spec - addDeltaAnnotationExt ls GHC.AnnVal - annotatePC ln - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - --- --------------------------------------------------------------------- - -instance (AnnotateP GHC.CExportSpec) where - annotateP l (GHC.CExportStatic _ cconv) = annotateP l cconv - --- --------------------------------------------------------------------- - -instance (AnnotateP GHC.CCallConv) where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (AnnotateP GHC.Safety) where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.DerivDecl name) where - - annotateP _ (GHC.DerivDecl typ mov) = do - addDeltaAnnotation GHC.AnnDeriving - addDeltaAnnotation GHC.AnnInstance - annotateMaybe mov - annotatePC typ - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.DefaultDecl name) where - - annotateP _ (GHC.DefaultDecl typs) = do - addDeltaAnnotation GHC.AnnDefault - addDeltaAnnotation GHC.AnnOpenP -- '(' - mapM_ annotatePC typs - addDeltaAnnotation GHC.AnnCloseP -- ')' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.InstDecl name) where - - annotateP l (GHC.ClsInstD cid) = annotateP l cid - annotateP l (GHC.DataFamInstD dfid) = annotateP l dfid - annotateP l (GHC.TyFamInstD tfid) = annotateP l tfid - --- --------------------------------------------------------------------- - -instance AnnotateP (GHC.OverlapMode) where - annotateP _ _ = do - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.ClsInstDecl name) where - - annotateP _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do - addDeltaAnnotation GHC.AnnInstance - annotateMaybe mov - annotatePC poly - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- '{' - addDeltaAnnotationsInside GHC.AnnSemi - - -- AZ:Need to turn this into a located list annotation. - -- must merge all the rest - applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ++ prepareListAnnotation tyfams - ++ prepareListAnnotation datafams - ) - - addDeltaAnnotation GHC.AnnCloseC -- '}' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.TyFamInstDecl name) where - - annotateP _ (GHC.TyFamInstDecl eqn _) = do - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnInstance - annotatePC eqn - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.DataFamInstDecl name) where - - annotateP l (GHC.DataFamInstDecl ln (GHC.HsWB pats _ _ _) defn _) = do - addDeltaAnnotation GHC.AnnData - addDeltaAnnotation GHC.AnnNewtype - addDeltaAnnotation GHC.AnnInstance - annotatePC ln - mapM_ annotatePC pats - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnEqual - annotateDataDefn l defn - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => - AnnotateP (GHC.HsBind name) where - annotateP _ (GHC.FunBind (GHC.L _ln _n) isInfix (GHC.MG matches _ _ _) _ _ _) = do - setFunIsInfix isInfix - mapM_ annotatePC matches - - annotateP _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do - annotatePC lhs - addDeltaAnnotation GHC.AnnEqual - mapM_ annotatePC grhs - addDeltaAnnotation GHC.AnnWhere - - -- TODO: Store the following SrcSpan in an AnnList instance for exactPC - annotatePC (GHC.L (getLocalBindsSrcSpan lb) lb) - - annotateP _ (GHC.VarBind _n rhse _) = - -- Note: this bind is introduced by the typechecker - annotatePC rhse - - annotateP l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do - addDeltaAnnotation GHC.AnnPattern - annotatePC ln - case args of - GHC.InfixPatSyn la lb -> do - annotatePC la - annotatePC lb - GHC.PrefixPatSyn ns -> do - mapM_ annotatePC ns - addDeltaAnnotation GHC.AnnEqual - addDeltaAnnotation GHC.AnnLarrow - annotatePC def - case dir of - GHC.Unidirectional -> return () - GHC.ImplicitBidirectional -> return () - GHC.ExplicitBidirectional mg -> annotateMatchGroup l mg - - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- '{' - addDeltaAnnotation GHC.AnnCloseC -- '}' - - return () - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.IPBind name) where - annotateP _ (GHC.IPBind en e) = do - case en of - Left n -> annotatePC n - Right _i -> error $ "annotateP.IPBind:should not happen" - addDeltaAnnotation GHC.AnnEqual - annotatePC e - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.HsIPName where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, - AnnotateP body) - => AnnotateP (GHC.Match name (GHC.Located body)) where - - annotateP _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do - isInfix <- getFunIsInfix - let - get_infix Nothing = isInfix - get_infix (Just (_,f)) = f - case (get_infix mln,pats) of - (True,[a,b]) -> do - annotatePC a - case mln of - Nothing -> do - addDeltaAnnotation GHC.AnnOpen -- possible '`' - addDeltaAnnotation GHC.AnnFunId - addDeltaAnnotation GHC.AnnClose -- possible '`' - Just (n,_) -> annotatePC n - annotatePC b - _ -> do - case mln of - Nothing -> addDeltaAnnotation GHC.AnnFunId - Just (n,_) -> annotatePC n - mapM_ annotatePC pats - - addDeltaAnnotation GHC.AnnEqual - addDeltaAnnotation GHC.AnnRarrow -- For HsLam - - mapM_ annotatePC grhs - - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- '{' - addDeltaAnnotationsInside GHC.AnnSemi - -- annotateHsLocalBinds lb - annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) - addDeltaAnnotation GHC.AnnCloseC -- '}' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, - AnnotateP body) - => AnnotateP (GHC.GRHS name (GHC.Located body)) where - annotateP _ (GHC.GRHS guards expr) = do - - addDeltaAnnotation GHC.AnnVbar - mapM_ annotatePC guards - addDeltaAnnotation GHC.AnnEqual - addDeltaAnnotation GHC.AnnRarrow -- in case alts - annotatePC expr - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.Sig name) where - - annotateP _ (GHC.TypeSig lns typ _) = do - mapM_ annotatePC lns - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - annotateP _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do - addDeltaAnnotation GHC.AnnPattern - annotatePC ln - addDeltaAnnotation GHC.AnnDcolon - - -- Note: The 'forall' bndrs '.' may occur multiple times - addDeltaAnnotation GHC.AnnForall - mapM_ annotatePC bndrs - addDeltaAnnotation GHC.AnnDot - - annotatePC ctx1 - addDeltaAnnotationLs GHC.AnnDarrow 0 - annotatePC ctx2 - addDeltaAnnotationLs GHC.AnnDarrow 1 - annotatePC typ - - - annotateP _ (GHC.GenericSig ns typ) = do - addDeltaAnnotation GHC.AnnDefault - mapM_ annotatePC ns - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - annotateP _ (GHC.IdSig _) = return () - - -- FixSig (FixitySig name) - annotateP _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity _v _fdir))) = do - addDeltaAnnotation GHC.AnnInfix - addDeltaAnnotation GHC.AnnVal - mapM_ annotatePC lns - - -- InlineSig (Located name) InlinePragma - -- '{-# INLINE' activation qvar '#-}' - annotateP _ (GHC.InlineSig ln _inl) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# INLINE' - addDeltaAnnotation GHC.AnnOpenS -- '[' - addDeltaAnnotation GHC.AnnTilde -- ~ - addDeltaAnnotation GHC.AnnVal -- e.g. 34 - addDeltaAnnotation GHC.AnnCloseS -- ']' - annotatePC ln - addDeltaAnnotation GHC.AnnClose -- '#-}' - - - annotateP _ (GHC.SpecSig ln typs _inl) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# SPECIALISE' - addDeltaAnnotation GHC.AnnOpenS -- '[' - addDeltaAnnotation GHC.AnnTilde -- ~ - addDeltaAnnotation GHC.AnnVal -- e.g. 34 - - addDeltaAnnotation GHC.AnnCloseS -- ']' - annotatePC ln - addDeltaAnnotation GHC.AnnDcolon -- '::' - mapM_ annotatePC typs - addDeltaAnnotation GHC.AnnClose -- '#-}' - - - -- '{-# SPECIALISE' 'instance' inst_type '#-}' - annotateP _ (GHC.SpecInstSig _ typ) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# SPECIALISE' - addDeltaAnnotation GHC.AnnInstance - annotatePC typ - addDeltaAnnotation GHC.AnnClose -- '#-}' - - - -- MinimalSig (BooleanFormula (Located name)) - annotateP _ (GHC.MinimalSig _ formula) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# MINIMAL' - annotateBooleanFormula formula - addDeltaAnnotation GHC.AnnClose -- '#-}' - - --- --------------------------------------------------------------------- - -annotateBooleanFormula :: GHC.BooleanFormula (GHC.Located name) -> AP () -annotateBooleanFormula = assert False undefined - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => - AnnotateP (GHC.HsTyVarBndr name) where - annotateP l (GHC.UserTyVar _n) = do - addDeltaAnnotationExt l GHC.AnnVal - - annotateP _ (GHC.KindedTyVar n ty) = do - addDeltaAnnotation GHC.AnnOpenP -- '(' - annotatePC n - addDeltaAnnotation GHC.AnnDcolon -- '::' - annotatePC ty - addDeltaAnnotation GHC.AnnCloseP -- '(' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsType name) where - - annotateP _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do - addDeltaAnnotation GHC.AnnOpenP -- "(" - addDeltaAnnotation GHC.AnnForall - mapM_ annotatePC tvs - addDeltaAnnotation GHC.AnnDot - - case mwc of - Nothing -> if lc /= GHC.noSrcSpan then annotatePC ctx else return () - Just lwc -> annotatePC (GHC.L lc (GHC.sortLocated ((GHC.L lwc GHC.HsWildcardTy):ctxs))) - - addDeltaAnnotation GHC.AnnDarrow - annotatePC typ - addDeltaAnnotation GHC.AnnCloseP -- ")" - - annotateP l (GHC.HsTyVar n) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - annotateP l n - - annotateP _ (GHC.HsAppTy t1 t2) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - annotatePC t1 - annotatePC t2 - - annotateP _ (GHC.HsFunTy t1 t2) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - annotatePC t1 - addDeltaAnnotation GHC.AnnRarrow - annotatePC t2 - - annotateP _ (GHC.HsListTy t) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - addDeltaAnnotation GHC.AnnOpenS -- '[' - annotatePC t - addDeltaAnnotation GHC.AnnCloseS -- ']' - - annotateP _ (GHC.HsPArrTy t) = do - addDeltaAnnotation GHC.AnnOpen -- '[:' - annotatePC t - addDeltaAnnotation GHC.AnnClose -- ':]' - - annotateP _ (GHC.HsTupleTy _tt ts) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - addDeltaAnnotation GHC.AnnOpen -- '(#' - addDeltaAnnotation GHC.AnnOpenP -- '(' - mapM_ annotatePC ts - addDeltaAnnotation GHC.AnnCloseP -- ')' - addDeltaAnnotation GHC.AnnClose -- '#)' - - annotateP _ (GHC.HsOpTy t1 (_,lo) t2) = do - annotatePC t1 - annotatePC lo - annotatePC t2 - - annotateP _ (GHC.HsParTy t) = do - addDeltaAnnotation GHC.AnnDcolon -- for HsKind, alias for HsType - addDeltaAnnotation GHC.AnnOpenP -- '(' - annotatePC t - addDeltaAnnotation GHC.AnnCloseP -- ')' - - annotateP _ (GHC.HsIParamTy _n t) = do - addDeltaAnnotation GHC.AnnVal - addDeltaAnnotation GHC.AnnDcolon - annotatePC t - - annotateP _ (GHC.HsEqTy t1 t2) = do - annotatePC t1 - addDeltaAnnotation GHC.AnnTilde - annotatePC t2 - - annotateP _ (GHC.HsKindSig t k) = do - addDeltaAnnotation GHC.AnnOpenP -- '(' - annotatePC t - addDeltaAnnotation GHC.AnnDcolon -- '::' - annotatePC k - addDeltaAnnotation GHC.AnnCloseP -- ')' - - -- HsQuasiQuoteTy (HsQuasiQuote name) - annotateP l (GHC.HsQuasiQuoteTy _qq) = do - addDeltaAnnotationExt l GHC.AnnVal - - -- HsSpliceTy (HsSplice name) (PostTc name Kind) - annotateP _ (GHC.HsSpliceTy (GHC.HsSplice _is e) _) = do - addDeltaAnnotation GHC.AnnOpen -- '$(' - annotatePC e - addDeltaAnnotation GHC.AnnClose -- ')' - - annotateP _ (GHC.HsDocTy t ds) = do - annotatePC t - annotatePC ds - - annotateP _ (GHC.HsBangTy _b t) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# UNPACK' or '{-# NOUNPACK' - addDeltaAnnotation GHC.AnnClose -- '#-}' - addDeltaAnnotation GHC.AnnBang -- '!' - annotatePC t - - -- HsRecTy [LConDeclField name] - annotateP _ (GHC.HsRecTy cons) = do - addDeltaAnnotation GHC.AnnOpenC -- '{' - mapM_ annotatePC cons - addDeltaAnnotation GHC.AnnCloseC -- '}' - - -- HsCoreTy Type - annotateP _ (GHC.HsCoreTy _t) = return () - - annotateP _ (GHC.HsExplicitListTy _ ts) = do - -- TODO: what about SIMPLEQUOTE? - addDeltaAnnotation GHC.AnnOpen -- "'[" - mapM_ annotatePC ts - addDeltaAnnotation GHC.AnnCloseS -- ']' - - annotateP _ (GHC.HsExplicitTupleTy _ ts) = do - addDeltaAnnotation GHC.AnnOpen -- "'(" - mapM_ annotatePC ts - addDeltaAnnotation GHC.AnnClose -- ')' - - -- HsTyLit HsTyLit - annotateP l (GHC.HsTyLit _tl) = do - addDeltaAnnotationExt l GHC.AnnVal - - -- HsWrapTy HsTyWrapper (HsType name) - annotateP _ (GHC.HsWrapTy _ _) = return () - - annotateP l (GHC.HsWildcardTy) = do - addDeltaAnnotationExt l GHC.AnnVal - addDeltaAnnotation GHC.AnnDarrow -- if only part of a partial type signature context - - annotateP l (GHC.HsNamedWildcardTy _n) = do - addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => - AnnotateP (GHC.ConDeclField name) where - annotateP _ (GHC.ConDeclField ns ty mdoc) = do - mapM_ annotatePC ns - addDeltaAnnotation GHC.AnnDcolon - annotatePC ty - annotateMaybe mdoc - --- --------------------------------------------------------------------- - -instance AnnotateP GHC.HsDocString where - annotateP l (GHC.HsDocString _s) = do - addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name) - => AnnotateP (GHC.Pat name) where - annotateP l (GHC.WildPat _) = addDeltaAnnotationExt l GHC.AnnVal - annotateP l (GHC.VarPat _) = addDeltaAnnotationExt l GHC.AnnVal - annotateP _ (GHC.LazyPat p) = do - addDeltaAnnotation GHC.AnnTilde - annotatePC p - - annotateP _ (GHC.AsPat ln p) = do - annotatePC ln - addDeltaAnnotation GHC.AnnAt - annotatePC p - - annotateP _ (GHC.ParPat p) = do - addDeltaAnnotation GHC.AnnOpenP - annotatePC p - addDeltaAnnotation GHC.AnnCloseP - - annotateP _ (GHC.BangPat p) = do - addDeltaAnnotation GHC.AnnBang - annotatePC p - - annotateP _ (GHC.ListPat ps _ _) = do - addDeltaAnnotation GHC.AnnOpenS - mapM_ annotatePC ps - addDeltaAnnotation GHC.AnnCloseS - - annotateP _ (GHC.TuplePat ps _ _) = do - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenP - mapM_ annotatePC ps - addDeltaAnnotation GHC.AnnCloseP - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.PArrPat ps _) = do - addDeltaAnnotation GHC.AnnOpen - mapM_ annotatePC ps - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.ConPatIn n dets) = do - annotateHsConPatDetails n dets - - annotateP _ (GHC.ConPatOut {}) = return () - - -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) - annotateP _ (GHC.ViewPat e pat _) = do - annotatePC e - addDeltaAnnotation GHC.AnnRarrow - annotatePC pat - - -- SplicePat (HsSplice id) - annotateP _ (GHC.SplicePat (GHC.HsSplice _ e)) = do - addDeltaAnnotation GHC.AnnOpen -- '$(' - annotatePC e - addDeltaAnnotation GHC.AnnClose -- ')' - - -- QuasiQuotePat (HsQuasiQuote id) - annotateP l (GHC.QuasiQuotePat (GHC.HsQuasiQuote _ _ _)) = do - addDeltaAnnotationExt l GHC.AnnVal - - -- LitPat HsLit - annotateP l (GHC.LitPat _lp) = addDeltaAnnotationExt l GHC.AnnVal - - -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) - annotateP _ (GHC.NPat ol _ _) = do - addDeltaAnnotation GHC.AnnMinus - annotatePC ol - - -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) - annotateP _ (GHC.NPlusKPat ln ol _ _) = do - annotatePC ln - addDeltaAnnotation GHC.AnnVal -- "+" - annotatePC ol - - annotateP l (GHC.SigPatIn pat ty) = do - annotatePC pat - addDeltaAnnotation GHC.AnnDcolon - annotateP l ty - - annotateP _ (GHC.SigPatOut {}) = return () - - -- CoPat HsWrapper (Pat id) Type - annotateP _ (GHC.CoPat {}) = return () - --- --------------------------------------------------------------------- - -annotateHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => GHC.Located name -> GHC.HsConPatDetails name -> AP () -annotateHsConPatDetails ln dets = do - case dets of - GHC.PrefixCon args -> do - annotatePC ln - mapM_ annotatePC args - GHC.RecCon (GHC.HsRecFields fs _) -> do - annotatePC ln - addDeltaAnnotation GHC.AnnOpenC -- '{' - mapM_ annotatePC fs - addDeltaAnnotation GHC.AnnDotdot - addDeltaAnnotation GHC.AnnCloseC -- '}' - GHC.InfixCon a1 a2 -> do - annotatePC a1 - annotatePC ln - annotatePC a2 - -annotateHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => [GHC.Located name] -> GHC.HsConDeclDetails name -> AP () -annotateHsConDeclDetails lns dets = do - case dets of - GHC.PrefixCon args -> mapM_ annotatePC args - GHC.RecCon fs -> do - addDeltaAnnotation GHC.AnnOpenC - annotatePC fs - addDeltaAnnotation GHC.AnnCloseC - GHC.InfixCon a1 a2 -> do - annotatePC a1 - mapM_ annotatePC lns - annotatePC a2 - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP [GHC.LConDeclField name] where - annotateP _ fs = do - addDeltaAnnotation GHC.AnnOpenC -- '{' - mapM_ annotatePC fs - addDeltaAnnotation GHC.AnnDotdot - addDeltaAnnotation GHC.AnnCloseC -- '}' - --- --------------------------------------------------------------------- - -instance (GHC.DataId name) => AnnotateP (GHC.HsOverLit name) where - annotateP l _ol = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP arg) - => AnnotateP (GHC.HsWithBndrs name (GHC.Located arg)) where - annotateP _ (GHC.HsWB thing _ _ _) = annotatePC thing - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name,AnnotateP body) => - AnnotateP (GHC.Stmt name (GHC.Located body)) where - - annotateP _ (GHC.LastStmt body _) = annotatePC body - - annotateP _ (GHC.BindStmt pat body _ _) = do - annotatePC pat - addDeltaAnnotation GHC.AnnLarrow - annotatePC body - addDeltaAnnotation GHC.AnnVbar -- possible in list comprehension - - annotateP _ (GHC.BodyStmt body _ _ _) = do - annotatePC body - - annotateP _ (GHC.LetStmt lb) = do - -- return () `debug` ("annotateP.LetStmt entered") - addDeltaAnnotation GHC.AnnLet - addDeltaAnnotation GHC.AnnOpenC -- '{' - annotateWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb) - addDeltaAnnotation GHC.AnnCloseC -- '}' - -- return () `debug` ("annotateP.LetStmt done") - - annotateP _ (GHC.ParStmt pbs _ _) = do - mapM_ annotateParStmtBlock pbs - - annotateP _ (GHC.TransStmt form stmts _b using by _ _ _) = do - mapM_ annotatePC stmts - case form of - GHC.ThenForm -> do - addDeltaAnnotation GHC.AnnThen - annotatePC using - addDeltaAnnotation GHC.AnnBy - case by of - Just b -> annotatePC b - Nothing -> return () - GHC.GroupForm -> do - addDeltaAnnotation GHC.AnnThen - addDeltaAnnotation GHC.AnnGroup - addDeltaAnnotation GHC.AnnBy - case by of - Just b -> annotatePC b - Nothing -> return () - addDeltaAnnotation GHC.AnnUsing - annotatePC using - - annotateP _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do - addDeltaAnnotation GHC.AnnRec - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotationsInside GHC.AnnSemi - mapM_ annotatePC stmts - addDeltaAnnotation GHC.AnnCloseC - --- --------------------------------------------------------------------- - -annotateParStmtBlock :: (GHC.DataId name,GHC.OutputableBndr name, AnnotateP name) - => GHC.ParStmtBlock name name -> AP () -annotateParStmtBlock (GHC.ParStmtBlock stmts _ns _) = - mapM_ annotatePC stmts - --- --------------------------------------------------------------------- - --- | Local binds need to be indented as a group, and thus need to have a --- SrcSpan around them so they can be processed via the normal --- annotatePC / exactPC machinery. -getLocalBindsSrcSpan :: GHC.HsLocalBinds name -> GHC.SrcSpan -getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) - = case spans of - [] -> GHC.noSrcSpan - sss -> GHC.combineSrcSpans (head sss) (last sss) - where - spans = sort (map GHC.getLoc (GHC.bagToList binds) ++ map GHC.getLoc sigs) - -getLocalBindsSrcSpan (GHC.HsValBinds (GHC.ValBindsOut {})) - = error "getLocalBindsSrcSpan: only valid after type checking" - -getLocalBindsSrcSpan (GHC.HsIPBinds (GHC.IPBinds binds _)) - = case sort (map GHC.getLoc binds) of - [] -> GHC.noSrcSpan - sss -> GHC.combineSrcSpans (head sss) (last sss) - -getLocalBindsSrcSpan (GHC.EmptyLocalBinds) = GHC.noSrcSpan - --- --------------------------------------------------------------------- - --- | Generate a SrcSpan that enclosed the given list -getListSrcSpan :: [GHC.Located a] -> GHC.SrcSpan -getListSrcSpan ls - = case ls of - [] -> GHC.noSrcSpan - sss -> GHC.combineLocs (head sss) (last sss) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsLocalBinds name) where - annotateP _ lb = annotateHsLocalBinds lb - --- --------------------------------------------------------------------- - -annotateHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => (GHC.HsLocalBinds name) -> AP () -annotateHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do - applyListAnnotations (prepareListAnnotation (GHC.bagToList binds) - ++ prepareListAnnotation sigs - ) -annotateHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {})) - = error $ "annotateHsLocalBinds: only valid after type checking" - -annotateHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ annotatePC binds -annotateHsLocalBinds (GHC.EmptyLocalBinds) = return () - --- --------------------------------------------------------------------- - -annotateMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, - AnnotateP body) - => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body)) - -> AP () -annotateMatchGroup l (GHC.MG matches _ _ _) - = annotateListWithLayout l matches - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name, - AnnotateP body) - => AnnotateP [GHC.Located (GHC.Match name (GHC.Located body))] where - annotateP _ ls = mapM_ annotatePC ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsExpr name) where - annotateP l (GHC.HsVar n) = annotateP l n - annotateP l (GHC.HsIPVar _) = addDeltaAnnotationExt l GHC.AnnVal - annotateP l (GHC.HsOverLit _ov) = addDeltaAnnotationExt l GHC.AnnVal - annotateP l (GHC.HsLit _) = addDeltaAnnotationExt l GHC.AnnVal - - annotateP l (GHC.HsLam match) = do - addDeltaAnnotation GHC.AnnLam - annotateMatchGroup l match - - annotateP l (GHC.HsLamCase _ match) = annotateMatchGroup l match - - annotateP _ (GHC.HsApp e1 e2) = do - annotatePC e1 - annotatePC e2 - - annotateP _ (GHC.OpApp e1 e2 _ e3) = do - annotatePC e1 - annotatePC e2 - annotatePC e3 - - annotateP _ (GHC.NegApp e _) = do - addDeltaAnnotation GHC.AnnMinus - annotatePC e - - annotateP _ (GHC.HsPar e) = do - addDeltaAnnotation GHC.AnnOpenP -- '(' - annotatePC e - addDeltaAnnotation GHC.AnnCloseP -- ')' - - annotateP _ (GHC.SectionL e1 e2) = do - annotatePC e1 - annotatePC e2 - - annotateP _ (GHC.SectionR e1 e2) = do - annotatePC e1 - annotatePC e2 - - annotateP _ (GHC.ExplicitTuple args _boxity) = do - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenP - mapM_ annotatePC args - addDeltaAnnotation GHC.AnnCloseP - addDeltaAnnotation GHC.AnnClose - - annotateP l (GHC.HsCase e1 matches) = do - addDeltaAnnotation GHC.AnnCase - annotatePC e1 - addDeltaAnnotation GHC.AnnOf - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotationsInside GHC.AnnSemi - annotateMatchGroup l matches - addDeltaAnnotation GHC.AnnCloseC - - annotateP _ (GHC.HsIf _ e1 e2 e3) = do - addDeltaAnnotation GHC.AnnIf - annotatePC e1 - addDeltaAnnotationLs GHC.AnnSemi 0 - addDeltaAnnotation GHC.AnnThen - annotatePC e2 - addDeltaAnnotationLs GHC.AnnSemi 1 - addDeltaAnnotation GHC.AnnElse - annotatePC e3 - - annotateP _ (GHC.HsMultiIf _ rhs) = do - addDeltaAnnotation GHC.AnnIf - mapM_ annotatePC rhs - - annotateP _ (GHC.HsLet binds e) = do - setLayoutOn True -- Make sure the 'in' gets indented too - addDeltaAnnotation GHC.AnnLet - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotationsInside GHC.AnnSemi - annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) - addDeltaAnnotation GHC.AnnCloseC - addDeltaAnnotation GHC.AnnIn - annotatePC e - - annotateP l (GHC.HsDo cts es _) = do - addDeltaAnnotation GHC.AnnDo - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenS - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotationsInside GHC.AnnSemi - if isListComp cts - then do - annotatePC (last es) - addDeltaAnnotation GHC.AnnVbar - mapM_ annotatePC (init es) - else do - annotateListWithLayout l es - addDeltaAnnotation GHC.AnnCloseS - addDeltaAnnotation GHC.AnnCloseC - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.ExplicitList _ _ es) = do - addDeltaAnnotation GHC.AnnOpenS - mapM_ annotatePC es - addDeltaAnnotation GHC.AnnCloseS - - annotateP _ (GHC.ExplicitPArr _ es) = do - addDeltaAnnotation GHC.AnnOpen - mapM_ annotatePC es - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do - annotatePC n - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotation GHC.AnnDotdot - mapM_ annotatePC fs - addDeltaAnnotation GHC.AnnCloseC - - annotateP _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do - annotatePC e - addDeltaAnnotation GHC.AnnOpenC - addDeltaAnnotation GHC.AnnDotdot - mapM_ annotatePC fs - addDeltaAnnotation GHC.AnnCloseC - - annotateP _ (GHC.ExprWithTySig e typ _) = do - annotatePC e - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - annotateP _ (GHC.ExprWithTySigOut e typ) = do - annotatePC e - addDeltaAnnotation GHC.AnnDcolon - annotatePC typ - - annotateP _ (GHC.ArithSeq _ _ seqInfo) = do - addDeltaAnnotation GHC.AnnOpenS -- '[' - case seqInfo of - GHC.From e -> do - annotatePC e - addDeltaAnnotation GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnDotdot - annotatePC e2 - GHC.FromThen e1 e2 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnComma - annotatePC e2 - addDeltaAnnotation GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnComma - annotatePC e2 - addDeltaAnnotation GHC.AnnDotdot - annotatePC e3 - addDeltaAnnotation GHC.AnnCloseS -- ']' - - annotateP _ (GHC.PArrSeq _ seqInfo) = do - addDeltaAnnotation GHC.AnnOpen -- '[:' - case seqInfo of - GHC.From e -> do - annotatePC e - addDeltaAnnotation GHC.AnnDotdot - GHC.FromTo e1 e2 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnDotdot - annotatePC e2 - GHC.FromThen e1 e2 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnComma - annotatePC e2 - addDeltaAnnotation GHC.AnnDotdot - GHC.FromThenTo e1 e2 e3 -> do - annotatePC e1 - addDeltaAnnotation GHC.AnnComma - annotatePC e2 - addDeltaAnnotation GHC.AnnDotdot - annotatePC e3 - addDeltaAnnotation GHC.AnnClose -- ':]' - - annotateP _ (GHC.HsSCC _ _csFStr e) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# SCC' - addDeltaAnnotation GHC.AnnVal - addDeltaAnnotation GHC.AnnValStr - addDeltaAnnotation GHC.AnnClose -- '#-}' - annotatePC e - - annotateP _ (GHC.HsCoreAnn _ _csFStr e) = do - addDeltaAnnotation GHC.AnnOpen -- '{-# CORE' - addDeltaAnnotation GHC.AnnVal - addDeltaAnnotation GHC.AnnClose -- '#-}' - annotatePC e - - annotateP l (GHC.HsBracket (GHC.VarBr _ _)) = do - addDeltaAnnotationExt l GHC.AnnVal - annotateP _ (GHC.HsBracket (GHC.DecBrL ds)) = do - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnOpenC - mapM_ annotatePC ds - addDeltaAnnotation GHC.AnnCloseC - addDeltaAnnotation GHC.AnnClose - annotateP _ (GHC.HsBracket (GHC.ExpBr e)) = do - addDeltaAnnotation GHC.AnnOpen - annotatePC e - addDeltaAnnotation GHC.AnnClose - annotateP _ (GHC.HsBracket (GHC.TExpBr e)) = do - addDeltaAnnotation GHC.AnnOpen - annotatePC e - addDeltaAnnotation GHC.AnnClose - annotateP _ (GHC.HsBracket (GHC.TypBr e)) = do - addDeltaAnnotation GHC.AnnOpen - annotatePC e - addDeltaAnnotation GHC.AnnClose - annotateP _ (GHC.HsBracket (GHC.PatBr e)) = do - addDeltaAnnotation GHC.AnnOpen - annotatePC e - addDeltaAnnotation GHC.AnnClose - - annotateP _ (GHC.HsRnBracketOut _ _) = return () - annotateP _ (GHC.HsTcBracketOut _ _) = return () - - annotateP _ (GHC.HsSpliceE _typed (GHC.HsSplice _ e)) = do - addDeltaAnnotation GHC.AnnOpen -- possible '$(' - annotatePC e - addDeltaAnnotation GHC.AnnClose -- possible ')' - - annotateP l (GHC.HsQuasiQuoteE (GHC.HsQuasiQuote _ _ _)) = do - addDeltaAnnotationExt l GHC.AnnVal - - annotateP _ (GHC.HsProc p c) = do - addDeltaAnnotation GHC.AnnProc - annotatePC p - addDeltaAnnotation GHC.AnnRarrow - annotatePC c - - annotateP _ (GHC.HsStatic e) = do - addDeltaAnnotation GHC.AnnStatic - annotatePC e - - annotateP _ (GHC.HsArrApp e1 e2 _ _ _) = do - annotatePC e1 - -- only one of the next 4 will be resent - addDeltaAnnotation GHC.Annlarrowtail - addDeltaAnnotation GHC.Annrarrowtail - addDeltaAnnotation GHC.AnnLarrowtail - addDeltaAnnotation GHC.AnnRarrowtail - - annotatePC e2 - - annotateP _ (GHC.HsArrForm e _ cs) = do - addDeltaAnnotation GHC.AnnOpen -- '(|' - annotatePC e - mapM_ annotatePC cs - addDeltaAnnotation GHC.AnnClose -- '|)' - - annotateP _ (GHC.HsTick _ _) = return () - annotateP _ (GHC.HsBinTick _ _ _) = return () - - annotateP _ (GHC.HsTickPragma _ (_str,(_v1,_v2),(_v3,_v4)) e) = do - -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' - addDeltaAnnotation GHC.AnnOpen -- '{-# GENERATED' - addDeltaAnnotationLs GHC.AnnVal 0 -- STRING - addDeltaAnnotationLs GHC.AnnVal 1 -- INTEGER - addDeltaAnnotationLs GHC.AnnColon 0 -- ':' - addDeltaAnnotationLs GHC.AnnVal 2 -- INTEGER - addDeltaAnnotation GHC.AnnMinus -- '-' - addDeltaAnnotationLs GHC.AnnVal 3 -- INTEGER - addDeltaAnnotationLs GHC.AnnColon 1 -- ':' - addDeltaAnnotationLs GHC.AnnVal 4 -- INTEGER - addDeltaAnnotation GHC.AnnClose -- '#-}' - annotatePC e - - annotateP l (GHC.EWildPat) = do - addDeltaAnnotationExt l GHC.AnnVal - - annotateP _ (GHC.EAsPat ln e) = do - annotatePC ln - addDeltaAnnotation GHC.AnnAt - annotatePC e - - annotateP _ (GHC.EViewPat e1 e2) = do - annotatePC e1 - addDeltaAnnotation GHC.AnnRarrow - annotatePC e2 - - annotateP _ (GHC.ELazyPat e) = do - addDeltaAnnotation GHC.AnnTilde - annotatePC e - - annotateP _ (GHC.HsType ty) = annotatePC ty - - annotateP _ (GHC.HsWrap _ _) = return () - annotateP _ (GHC.HsUnboundVar _) = return () - - --- --------------------------------------------------------------------- - --- |Used for declarations that need to be aligned together, e.g. in a --- do or let .. in statement/expr -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP ([GHC.ExprLStmt name]) where - annotateP _ ls = mapM_ annotatePC ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsTupArg name) where - annotateP _ (GHC.Present e) = do - annotatePC e - - annotateP _ (GHC.Missing _) = do - addDeltaAnnotation GHC.AnnComma - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsCmdTop name) where - annotateP _ (GHC.HsCmdTop cmd _ _ _) = annotatePC cmd - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.HsCmd name) where - annotateP _ (GHC.HsCmdArrApp e1 e2 _ _ _) = do - annotatePC e1 - -- only one of the next 4 will be resent - addDeltaAnnotation GHC.Annlarrowtail - addDeltaAnnotation GHC.Annrarrowtail - addDeltaAnnotation GHC.AnnLarrowtail - addDeltaAnnotation GHC.AnnRarrowtail - - annotatePC e2 - - annotateP _ (GHC.HsCmdArrForm e _mf cs) = do - addDeltaAnnotation GHC.AnnOpen -- '(|' - annotatePC e - mapM_ annotatePC cs - addDeltaAnnotation GHC.AnnClose -- '|)' - - annotateP _ (GHC.HsCmdApp e1 e2) = do - annotatePC e1 - annotatePC e2 - - annotateP l (GHC.HsCmdLam match) = do - addDeltaAnnotation GHC.AnnLam - annotateMatchGroup l match - - annotateP _ (GHC.HsCmdPar e) = do - addDeltaAnnotation GHC.AnnOpenP -- '(' - annotatePC e - addDeltaAnnotation GHC.AnnCloseP -- ')' - - annotateP l (GHC.HsCmdCase e1 matches) = do - addDeltaAnnotation GHC.AnnCase - annotatePC e1 - addDeltaAnnotation GHC.AnnOf - addDeltaAnnotation GHC.AnnOpenC - annotateMatchGroup l matches - addDeltaAnnotation GHC.AnnCloseC - - annotateP _ (GHC.HsCmdIf _ e1 e2 e3) = do - addDeltaAnnotation GHC.AnnIf - annotatePC e1 - addDeltaAnnotationLs GHC.AnnSemi 0 - addDeltaAnnotation GHC.AnnThen - annotatePC e2 - addDeltaAnnotationLs GHC.AnnSemi 1 - addDeltaAnnotation GHC.AnnElse - annotatePC e3 - - annotateP _ (GHC.HsCmdLet binds e) = do - addDeltaAnnotation GHC.AnnLet - addDeltaAnnotation GHC.AnnOpenC - annotateWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds) - addDeltaAnnotation GHC.AnnCloseC - addDeltaAnnotation GHC.AnnIn - annotatePC e - - annotateP l (GHC.HsCmdDo es _) = do - addDeltaAnnotation GHC.AnnDo - addDeltaAnnotation GHC.AnnOpenC - -- mapM_ annotatePC es - annotateListWithLayout l es - addDeltaAnnotation GHC.AnnCloseC - - annotateP _ (GHC.HsCmdCast {}) = error $ "annotateP.HsCmdCast: only valid after type checker" - - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where - annotateP _ ls = mapM_ annotatePC ls - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP (GHC.TyClDecl name) where - - annotateP l (GHC.FamDecl famdecl) = annotateP l famdecl - - annotateP _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars) typ _) = do - addDeltaAnnotation GHC.AnnType - annotatePC ln - mapM_ annotatePC tyvars - addDeltaAnnotation GHC.AnnEqual - annotatePC typ - - annotateP _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) - (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do - addDeltaAnnotation GHC.AnnData - addDeltaAnnotation GHC.AnnNewtype - annotateMaybe mctyp - annotatePC ctx - addDeltaAnnotation GHC.AnnDarrow - annotateTyClass ln tyVars - addDeltaAnnotation GHC.AnnDcolon - annotateMaybe mk - addDeltaAnnotation GHC.AnnEqual - addDeltaAnnotation GHC.AnnWhere - mapM_ annotatePC cons - annotateMaybe mderivs - - -- ----------------------------------- - - annotateP _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds - sigs meths ats atdefs docs _) = do - addDeltaAnnotation GHC.AnnClass - annotatePC ctx - - annotateTyClass ln tyVars - - addDeltaAnnotation GHC.AnnVbar - mapM_ annotatePC fds - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- '{' - addDeltaAnnotationsInside GHC.AnnSemi - applyListAnnotations (prepareListAnnotation sigs - ++ prepareListAnnotation (GHC.bagToList meths) - ++ prepareListAnnotation ats - ++ prepareListAnnotation atdefs - ++ prepareListAnnotation docs - ) - addDeltaAnnotation GHC.AnnCloseC -- '}' - --- --------------------------------------------------------------------- - -annotateTyClass :: (AnnotateP a, AnnotateP ast) - => GHC.Located a -> [GHC.Located ast] -> AP () -annotateTyClass ln tyVars = do - addDeltaAnnotations GHC.AnnOpenP - applyListAnnotations (prepareListAnnotation [ln] - ++ prepareListAnnotation (take 2 tyVars)) - addDeltaAnnotations GHC.AnnCloseP - mapM_ annotatePC (drop 2 tyVars) - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name, GHC.OutputableBndr name) - => AnnotateP (GHC.FamilyDecl name) where - annotateP _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars) mkind) = do - addDeltaAnnotation GHC.AnnType - addDeltaAnnotation GHC.AnnData - addDeltaAnnotation GHC.AnnFamily - annotatePC ln - mapM_ annotatePC tyvars - addDeltaAnnotation GHC.AnnDcolon - annotateMaybe mkind - addDeltaAnnotation GHC.AnnWhere - addDeltaAnnotation GHC.AnnOpenC -- { - case info of - GHC.ClosedTypeFamily eqns -> mapM_ annotatePC eqns - _ -> return () - case info of - GHC.ClosedTypeFamily eqns -> mapM_ annotatePC eqns - _ -> return () - addDeltaAnnotation GHC.AnnCloseC -- } - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name) - => AnnotateP (GHC.TyFamInstEqn name) where - annotateP _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do - annotatePC ln - mapM_ annotatePC pats - addDeltaAnnotation GHC.AnnEqual - annotatePC typ - - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name) - => AnnotateP (GHC.TyFamDefltEqn name) where - annotateP _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do - annotatePC ln - mapM_ annotatePC bndrs - addDeltaAnnotation GHC.AnnEqual - annotatePC typ - --- --------------------------------------------------------------------- - --- TODO: modify lexer etc, in the meantime to not set haddock flag -instance AnnotateP GHC.DocDecl where - annotateP l _ = addDeltaAnnotationExt l GHC.AnnVal - --- --------------------------------------------------------------------- - -annotateDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => GHC.SrcSpan -> GHC.HsDataDefn name -> AP () -annotateDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do - annotatePC ctx - annotateMaybe typ - annotateMaybe mk - mapM_ annotatePC cons - case mderivs of - Nothing -> return () - Just d -> annotatePC d - --- --------------------------------------------------------------------- - --- Note: GHC.HsContext name aliases to here too -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) - => AnnotateP [GHC.LHsType name] where - annotateP l ts = do - return () `debug` ("annotateP.HsContext:l=" ++ showGhc l) - addDeltaAnnotation GHC.AnnDeriving - addDeltaAnnotation GHC.AnnOpenP - mapM_ annotatePC ts - addDeltaAnnotation GHC.AnnCloseP - addDeltaAnnotation GHC.AnnDarrow - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name,GHC.OutputableBndr name) - => AnnotateP (GHC.ConDecl name) where - annotateP _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx - dets res _ _) = do - case res of - GHC.ResTyH98 -> do - addDeltaAnnotation GHC.AnnForall - mapM_ annotatePC bndrs - addDeltaAnnotation GHC.AnnDot - - annotatePC ctx - addDeltaAnnotation GHC.AnnDarrow - - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ annotatePC lns - - annotateHsConDeclDetails lns dets - - GHC.ResTyGADT ls ty -> do - -- only print names if not infix - case dets of - GHC.InfixCon _ _ -> return () - _ -> mapM_ annotatePC lns - - annotateHsConDeclDetails lns dets - - addDeltaAnnotation GHC.AnnDcolon - - annotatePC (GHC.L ls (ResTyGADTHook bndrs)) - - annotatePC ctx - addDeltaAnnotation GHC.AnnDarrow - - annotatePC ty - - - addDeltaAnnotation GHC.AnnVbar - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,GHC.OutputableBndr name,AnnotateP name) => - AnnotateP (ResTyGADTHook name) where - annotateP _ (ResTyGADTHook bndrs) = do - addDeltaAnnotation GHC.AnnForall - mapM_ annotatePC bndrs - addDeltaAnnotation GHC.AnnDot - --- --------------------------------------------------------------------- - -instance (AnnotateP name,AnnotateP a) - => AnnotateP (GHC.HsRecField name (GHC.Located a)) where - annotateP _ (GHC.HsRecField n e _) = do - annotatePC n - addDeltaAnnotation GHC.AnnEqual - annotatePC e - --- --------------------------------------------------------------------- - -instance (GHC.DataId name,AnnotateP name) - => AnnotateP (GHC.FunDep (GHC.Located name)) where - - annotateP _ (ls,rs) = do - mapM_ annotatePC ls - addDeltaAnnotation GHC.AnnRarrow - mapM_ annotatePC rs - --- --------------------------------------------------------------------- - -instance AnnotateP (GHC.CType) where - annotateP _ _ = do - addDeltaAnnotation GHC.AnnOpen - addDeltaAnnotation GHC.AnnHeader - addDeltaAnnotation GHC.AnnVal - addDeltaAnnotation GHC.AnnClose - --- --------------------------------------------------------------------- - --- | Apply the delta to the current position, taking into account the --- current column offset -undeltaComment :: Pos -> Int -> DComment -> Comment -undeltaComment l con (DComment (dps,dpe) s) = r - -- `debug` ("undeltaComment:(l,con,dcomment,r)=" ++ show (l,con,dco,r)) - where - r = Comment ((adj dps $ undelta l dps co),(adj dps $ undelta l dpe co)) s - co = con - dc = - con -- + (coo - con) - - -- adj makes provision for the possible movement of the - -- surrounding context, and so applies the difference between the - -- original and current offsets - adj (DP ( 0,_dco)) (row,c) = (row,c) - adj (DP (_dro,_dco)) (row,c) = (row,c + dc) - --- | Create a delta covering the gap between the end of the first --- @SrcSpan@ and the start of the second. -deltaFromSrcSpans :: GHC.SrcSpan -> GHC.SrcSpan -> DeltaPos -deltaFromSrcSpans ss1 ss2 = ss2delta (ss2posEnd ss1) ss2 - -ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos -ss2delta ref ss = ss2deltaP ref (ss2pos ss) - --- | Convert the start of the second @Pos@ to be an offset from the --- first. The assumption is the reference starts before the second @Pos@ -ss2deltaP :: Pos -> Pos -> DeltaPos -ss2deltaP (refl,refc) (l,c) = DP (lo,co) - where - lo = l - refl - co = if lo == 0 then c - refc - else c - --- | Apply the delta to the current position, taking into account the --- current column offset if advancing to a new line -undelta :: Pos -> DeltaPos -> ColOffset -> Pos -undelta (l,c) (DP (dl,dc)) co = (fl,fc) - where - fl = l + dl - fc = if dl == 0 then c + dc - else co + dc - --- --------------------------------------------------------------------- - -ss2pos :: GHC.SrcSpan -> Pos -ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss) - -ss2posEnd :: GHC.SrcSpan -> Pos -ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) - -ss2span :: GHC.SrcSpan -> Span -ss2span ss = (ss2pos ss,ss2posEnd ss) - -srcSpanStart :: GHC.SrcSpan -> Pos -srcSpanStart ss = (srcSpanStartLine ss,srcSpanStartColumn ss) - -srcSpanEnd :: GHC.SrcSpan -> Pos -srcSpanEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) - - -srcSpanEndColumn :: GHC.SrcSpan -> Int -srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s -srcSpanEndColumn _ = 0 - -srcSpanStartColumn :: GHC.SrcSpan -> Int -srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s -srcSpanStartColumn _ = 0 - -srcSpanEndLine :: GHC.SrcSpan -> Int -srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s -srcSpanEndLine _ = 0 - -srcSpanStartLine :: GHC.SrcSpan -> Int -srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s -srcSpanStartLine _ = 0 - --- --------------------------------------------------------------------- - -span2ss :: Span -> GHC.SrcSpan -span2ss ((sr,sc),(er,ec)) = l - where - filename = (GHC.mkFastString "f") - l = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec) - --- --------------------------------------------------------------------- - -isPointSrcSpan :: GHC.SrcSpan -> Bool -isPointSrcSpan ss = s == e where (s,e) = ss2span ss - --- --------------------------------------------------------------------- - -isListComp :: GHC.HsStmtContext name -> Bool -isListComp cts = case cts of - GHC.ListComp -> True - GHC.MonadComp -> True - GHC.PArrComp -> True - - GHC.DoExpr -> False - GHC.MDoExpr -> False - GHC.ArrowExpr -> False - GHC.GhciStmtCtxt -> False - - GHC.PatGuard {} -> False - GHC.ParStmtCtxt {} -> False - GHC.TransStmtCtxt {} -> False - --- --------------------------------------------------------------------- - -ghcCommentText :: GHC.Located GHC.AnnotationComment -> String -ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s -ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s -ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s -ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = "{-" ++ s ++ "-}" - --- --------------------------------------------------------------------- - -isSymbolRdrName :: GHC.RdrName -> Bool -isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n - -rdrName2String :: GHC.RdrName -> String -rdrName2String r = - case GHC.isExact_maybe r of - Just n -> name2String n - Nothing -> - case r of - GHC.Unqual _occ -> GHC.occNameString $ GHC.rdrNameOcc r - GHC.Qual modname _occ -> GHC.moduleNameString modname ++ "." - ++ (GHC.occNameString $ GHC.rdrNameOcc r) - -name2String :: GHC.Name -> String -name2String name = showGhc name - --- |Show a GHC API structure -showGhc :: (GHC.Outputable a) => a -> String -showGhc x = GHC.showPpr GHC.unsafeGlobalDynFlags x - - --- |Show a GHC API structure -showGhcDebug :: (GHC.Outputable a) => a -> String -showGhcDebug x = GHC.showSDocDebug GHC.unsafeGlobalDynFlags (GHC.ppr x) - --- --------------------------------------------------------------------- - -instance Show (GHC.GenLocated GHC.SrcSpan GHC.Token) where - show (GHC.L l tok) = show ((srcSpanStart l, srcSpanEnd l),tok) - --- --------------------------------------------------------------------- - -pp :: GHC.Outputable a => a -> String -pp a = GHC.showPpr GHC.unsafeGlobalDynFlags a - --- --------------------------------------------------------------------- - --- Based on ghc-syb-utils version, but adding the annotation --- information to each SrcLoc. -showAnnData :: Data a => Anns -> Int -> a -> String -showAnnData anns n = - generic -- `ext1Q` located - `ext1Q` list - `extQ` string `extQ` fastString `extQ` srcSpan - `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon - `extQ` overLit - `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet - `extQ` fixity - `ext2Q` located - where generic :: Data a => a -> String - generic t = indent n ++ "(" ++ showConstr (toConstr t) - ++ space (concat (intersperse " " (gmapQ (showAnnData anns (n+1)) t))) ++ ")" - space "" = "" - space s = ' ':s - indent i = "\n" ++ replicate i ' ' - string = show :: String -> String - fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String - list l = indent n ++ "[" - ++ concat (intersperse "," (map (showAnnData anns (n+1)) l)) ++ "]" - - name = ("{Name: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Name -> String - occName = ("{OccName: "++) . (++"}") . OccName.occNameString - moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String - - -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String - srcSpan :: GHC.SrcSpan -> String - srcSpan ss = "{ "++ (showSDoc_ (GHC.hang (GHC.ppr ss) (n+2) - -- (GHC.ppr (Map.lookup ss anns) - (GHC.text "") - )) - ++"}" - - var = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String - dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String - - overLit :: (GHC.HsOverLit GHC.RdrName) -> String - overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr - - bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String - bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList - bagName :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String - bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList - bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String - bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList - - nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems - - fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String - - located :: (Data b,Data loc) => GHC.GenLocated loc b -> String - -- located la = show (getAnnotationEP la anns) - located la@(GHC.L ss a) = indent n ++ "(" - ++ case (cast ss) of - Just (s::GHC.SrcSpan) -> srcSpan s - ++ indent (n + 1) ++ show (getAnnotationEP (GHC.L s a) anns) - Nothing -> "nnnnnnnn" - ++ showAnnData anns (n+1) a - ++ ")" - --- --------------------------------------------------------------------- - -showSDoc_ :: GHC.SDoc -> String -showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags - --- --------------------------------------------------------------------- --- Putting these here for the time being, to avoid import loops - -ghead :: String -> [a] -> a -ghead info [] = error $ "ghead "++info++" []" -ghead _info (h:_) = h - -glast :: String -> [a] -> a -glast info [] = error $ "glast " ++ info ++ " []" -glast _info h = last h - -gtail :: String -> [a] -> [a] -gtail info [] = error $ "gtail " ++ info ++ " []" -gtail _info h = tail h - -gfromJust :: [Char] -> Maybe a -> a -gfromJust _info (Just h) = h -gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing" - +{-# LANGUAGE ScopedTypeVariables #-} +module Language.Haskell.GHC.ExactPrint.Utils + ( + + srcSpanStartLine + , srcSpanEndLine + , srcSpanStartColumn + , srcSpanEndColumn + + , ss2span + , ss2pos + , ss2posEnd + , span2ss + , undelta + , rdrName2String + , isSymbolRdrName + , deltaFromSrcSpans + , ghcCommentText + , isPointSrcSpan + , ss2deltaP + , isGoodDelta + + , isListComp + + , showGhc + , showAnnData + + + -- * For tests + , debug + , debugM + , warn + + ) where + + +import Control.Monad (when) +import Data.Data (Data, toConstr, showConstr, cast) +import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) +import Data.List (intercalate) + +import Language.Haskell.GHC.ExactPrint.Types + +import qualified GHC +import qualified Bag as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified Name as GHC +import qualified NameSet as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified Var as GHC + +import qualified OccName(occNameString) + +import Debug.Trace + +-- --------------------------------------------------------------------- + +-- |Global switch to enable debug tracing in ghc-exactprint +debugEnabledFlag :: Bool +-- debugEnabledFlag = True +debugEnabledFlag = False + +-- |Provide a version of trace the comes at the end of the line, so it can +-- easily be commented out when debugging different things. +debug :: c -> String -> c +debug c s = if debugEnabledFlag + then trace s c + else c + +debugM :: Monad m => String -> m () +debugM s = when debugEnabledFlag $ traceM s + +-- --------------------------------------------------------------------- + +warn :: c -> String -> c +-- warn = flip trace +warn c _ = c + +isGoodDelta :: DeltaPos -> Bool +isGoodDelta (DP (ro,co)) = ro >= 0 && co >= 0 + +-- | Create a delta covering the gap between the end of the first +-- @SrcSpan@ and the start of the second. +deltaFromSrcSpans :: GHC.SrcSpan -> GHC.SrcSpan -> DeltaPos +deltaFromSrcSpans ss1 ss2 = ss2delta (ss2posEnd ss1) ss2 + +ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos +ss2delta ref ss = ss2deltaP ref (ss2pos ss) + +-- | Convert the start of the second @Pos@ to be an offset from the +-- first. The assumption is the reference starts before the second @Pos@ +ss2deltaP :: Pos -> Pos -> DeltaPos +ss2deltaP (refl,refc) (l,c) = DP (lo,co) + where + lo = l - refl + co = if lo == 0 then c - refc + else c + +-- | Apply the delta to the current position, taking into account the +-- current column offset if advancing to a new line +undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos +undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc) + where + fl = l + dl + fc = if dl == 0 then c + dc + else co + dc + +-- --------------------------------------------------------------------- + +ss2pos :: GHC.SrcSpan -> Pos +ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss) + +ss2posEnd :: GHC.SrcSpan -> Pos +ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) + +ss2span :: GHC.SrcSpan -> Span +ss2span ss = (ss2pos ss,ss2posEnd ss) + +srcSpanEndColumn :: GHC.SrcSpan -> Int +srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s +srcSpanEndColumn _ = 0 + +srcSpanStartColumn :: GHC.SrcSpan -> Int +srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s +srcSpanStartColumn _ = 0 + +srcSpanEndLine :: GHC.SrcSpan -> Int +srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s +srcSpanEndLine _ = 0 + +srcSpanStartLine :: GHC.SrcSpan -> Int +srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s +srcSpanStartLine _ = 0 + +-- --------------------------------------------------------------------- + +span2ss :: Span -> GHC.SrcSpan +span2ss ((sr,sc),(er,ec)) = l + where + filename = GHC.mkFastString "f" + l = GHC.mkSrcSpan (GHC.mkSrcLoc filename sr sc) (GHC.mkSrcLoc filename er ec) + +-- --------------------------------------------------------------------- + +isPointSrcSpan :: GHC.SrcSpan -> Bool +isPointSrcSpan ss = s == e where (s,e) = ss2span ss + +-- --------------------------------------------------------------------- + +isListComp :: GHC.HsStmtContext name -> Bool +isListComp cts = case cts of + GHC.ListComp -> True + GHC.MonadComp -> True + GHC.PArrComp -> True + + GHC.DoExpr -> False + GHC.MDoExpr -> False + GHC.ArrowExpr -> False + GHC.GhciStmtCtxt -> False + + GHC.PatGuard {} -> False + GHC.ParStmtCtxt {} -> False + GHC.TransStmtCtxt {} -> False + +-- --------------------------------------------------------------------- + +ghcCommentText :: GHC.Located GHC.AnnotationComment -> String +ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s +ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s +ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s +ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s +ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s +ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s +ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s +ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = "{-" ++ s ++ "-}" + +-- --------------------------------------------------------------------- + +isSymbolRdrName :: GHC.RdrName -> Bool +isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n + +rdrName2String :: GHC.RdrName -> String +rdrName2String r = + case GHC.isExact_maybe r of + Just n -> name2String n + Nothing -> + case r of + GHC.Unqual _occ -> GHC.occNameString $ GHC.rdrNameOcc r + GHC.Qual modname _occ -> GHC.moduleNameString modname ++ "." + ++ GHC.occNameString (GHC.rdrNameOcc r) + GHC.Orig _ _ -> error "GHC.Orig introduced after renaming" + GHC.Exact _ -> error "GHC.Exact introduced after renaming" + +name2String :: GHC.Name -> String +name2String = showGhc + +-- |Show a GHC API structure +showGhc :: (GHC.Outputable a) => a -> String +showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags + +-- --------------------------------------------------------------------- + +-- Based on ghc-syb-utils version, but adding the annotation +-- information to each SrcLoc. +showAnnData :: Data a => Anns -> Int -> a -> String +showAnnData anns n = + generic -- `ext1Q` located + `ext1Q` list + `extQ` string `extQ` fastString `extQ` srcSpan + `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon + `extQ` overLit + `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet + `extQ` fixity + `ext2Q` located + where generic :: Data a => a -> String + generic t = indent n ++ "(" ++ showConstr (toConstr t) + ++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")" + space "" = "" + space s = ' ':s + indent i = "\n" ++ replicate i ' ' + string = show :: String -> String + fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String + list l = indent n ++ "[" + ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]" + + name = ("{Name: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Name -> String + occName = ("{OccName: "++) . (++"}") . OccName.occNameString + moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String + + -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String + srcSpan :: GHC.SrcSpan -> String + srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2) + -- (GHC.ppr (Map.lookup ss anns) + (GHC.text "") + ) + ++"}" + + var = ("{Var: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Var -> String + dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String + + overLit :: GHC.HsOverLit GHC.RdrName -> String + overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr + + bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GHC.RdrName)) -> String + bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList + bagName :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Name)) -> String + bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList + bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GHC.Var)) -> String + bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList + + nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems + + fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String + + located :: (Data b,Data loc) => GHC.GenLocated loc b -> String + -- located la = show (getAnnotationEP la anns) + located (GHC.L ss a) = + indent n ++ "(" + ++ case cast ss of + Just (s :: GHC.SrcSpan) -> + srcSpan s + ++ indent (n + 1) ++ + show (getAnnotationEP (GHC.L s a) anns) + Nothing -> "nnnnnnnn" + ++ showAnnData anns (n+1) a + ++ ")" + +-- --------------------------------------------------------------------- + +showSDoc_ :: GHC.SDoc -> String +showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags + +-- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,27 +1,24 @@ +{-# LANGUAGE TupleSections #-} -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests. module Main where import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + import GHC.Paths ( libdir ) -import qualified Bag as GHC import qualified DynFlags as GHC -import qualified ErrUtils as GHC import qualified FastString as GHC import qualified GHC as GHC import qualified HscTypes as GHC -import qualified Lexer as GHC import qualified MonadUtils as GHC import qualified OccName as GHC import qualified Outputable as GHC import qualified RdrName as GHC -import qualified SrcLoc as GHC import qualified StringBuffer as GHC --- import qualified Outputable as GHC import qualified Data.Generics as SYB import qualified GHC.SYB.Utils as SYB @@ -37,10 +34,15 @@ import Test.HUnit --- import qualified Data.Map as Map +import Control.Applicative +import Data.List (partition) -- --------------------------------------------------------------------- +ghead :: String -> [a] -> a +ghead s [] = error ("Empty list at: " ++ s) +ghead s (x:xs) = x + main :: IO () main = do cnts <- runTestTT tests @@ -130,7 +132,13 @@ , mkTestMod "B.hs" "Main" , mkTestMod "LayoutWhere.hs" "Main" , mkTestMod "LayoutLet.hs" "Main" + , mkTestMod "LayoutLet2.hs" "LayoutLet2" + , mkTestMod "LayoutLet3.hs" "LayoutLet3" + , mkTestMod "LayoutLet4.hs" "LayoutLet4" , mkTestMod "LayoutIn1.hs" "LayoutIn1" + , mkTestMod "LayoutIn3.hs" "LayoutIn3" + , mkTestMod "LayoutIn3a.hs" "LayoutIn3a" + , mkTestMod "LayoutIn3b.hs" "LayoutIn3b" , mkTestMod "LayoutIn4.hs" "LayoutIn4" , mkTestMod "Deprecation.hs" "Deprecation" , mkTestMod "Infix.hs" "Main" @@ -139,12 +147,18 @@ , mkTestMod "LetExprSemi.hs" "LetExprSemi" , mkTestMod "WhereIn4.hs" "WhereIn4" , mkTestMod "LocToName.hs" "LocToName" + , mkTestMod "IfThenElse1.hs" "Main" + , mkTestMod "IfThenElse2.hs" "Main" + , mkTestMod "IfThenElse3.hs" "Main" , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" , mkTestModChange changeRename1 "Rename1.hs" "Main" , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" + , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3" + , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a" + , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b" , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" , mkTestModChange changeLocToName "LocToName.hs" "LocToName" @@ -171,114 +185,154 @@ -- --------------------------------------------------------------------- -tt :: IO Bool -tt = do -{- - manipulateAstTest "LetExpr.hs" "LetExpr" - manipulateAstTest "ExprPragmas.hs" "ExprPragmas" - manipulateAstTest "ListComprehensions.hs" "Main" - manipulateAstTest "MonadComprehensions.hs" "Main" - manipulateAstTest "FunDeps.hs" "Main" - manipulateAstTest "RecursiveDo.hs" "Main" - manipulateAstTest "TypeFamilies.hs" "Main" - manipulateAstTest "MultiParamTypeClasses.hs" "Main" - manipulateAstTest "DataFamilies.hs" "DataFamilies" - manipulateAstTest "Deriving.hs" "Main" - manipulateAstTest "Default.hs" "Main" - manipulateAstTest "ForeignDecl.hs" "ForeignDecl" - manipulateAstTest "Warning.hs" "Warning" - manipulateAstTest "Annotations.hs" "Annotations" - manipulateAstTestTH "QuasiQuote.hs" "QuasiQuote" - manipulateAstTest "Roles.hs" "Roles" - manipulateAstTest "Splice.hs" "Splice" - manipulateAstTest "ImportsSemi.hs" "ImportsSemi" - manipulateAstTest "Stmts.hs" "Stmts" - manipulateAstTest "Mixed.hs" "Main" - manipulateAstTest "Arrow.hs" "Arrow" - manipulateAstTest "PatSynBind.hs" "Main" - manipulateAstTest "HsDo.hs" "HsDo" - manipulateAstTest "ForAll.hs" "ForAll" - manipulateAstTest "BangPatterns.hs" "Main" - manipulateAstTest "Associated.hs" "Main" - manipulateAstTest "Move1.hs" "Move1" - manipulateAstTest "TypeOperators.hs" "Main" - manipulateAstTest "NullaryTypeClasses.hs" "Main" - manipulateAstTest "FunctionalDeps.hs" "Main" - manipulateAstTest "DerivingOC.hs" "Main" - manipulateAstTest "GenericDeriving.hs" "Main" - manipulateAstTest "OverloadedStrings.hs" "Main" - manipulateAstTest "RankNTypes.hs" "Main" - manipulateAstTest "Existential.hs" "Main" - manipulateAstTest "ScopedTypeVariables.hs" "Main" - manipulateAstTest "Arrows.hs" "Main" - manipulateAstTest "TH.hs" "Main" - manipulateAstTest "StaticPointers.hs" "Main" - manipulateAstTest "DataDecl.hs" "Main" - manipulateAstTest "Guards.hs" "Main" - manipulateAstTest "RdrNames.hs" "RdrNames" - manipulateAstTest "Vect.hs" "Vect" - manipulateAstTest "Tuple.hs" "Main" - manipulateAstTest "ExtraConstraints1.hs" "ExtraConstraints1" - manipulateAstTest "AddAndOr3.hs" "AddAndOr3" - manipulateAstTest "Ann01.hs" "Ann01" - manipulateAstTest "StrictLet.hs" "Main" - manipulateAstTest "Cg008.hs" "Cg008" - manipulateAstTest "T2388.hs" "T2388" - manipulateAstTest "T3132.hs" "T3132" - manipulateAstTest "Stream.hs" "Stream" - manipulateAstTest "Trit.hs" "Trit" - manipulateAstTest "DataDecl.hs" "Main" - manipulateAstTest "Zipper.hs" "Zipper" - manipulateAstTest "Sigs.hs" "Sigs" - manipulateAstTest "Utils2.hs" "Utils2" - manipulateAstTest "EmptyMostlyInst.hs" "EmptyMostlyInst" - manipulateAstTest "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis" - manipulateAstTest "EmptyMostly.hs" "EmptyMostly" - manipulateAstTest "FromUtils.hs" "Main" - manipulateAstTest "DocDecls.hs" "DocDecls" - manipulateAstTest "RecordUpdate.hs" "Main" - -- manipulateAstTest "Unicode.hs" "Main" - manipulateAstTest "B.hs" "Main" - manipulateAstTest "LayoutWhere.hs" "Main" - manipulateAstTest "Deprecation.hs" "Deprecation" - manipulateAstTest "Infix.hs" "Main" - manipulateAstTest "BCase.hs" "Main" - manipulateAstTest "LetExprSemi.hs" "LetExprSemi" - manipulateAstTest "LetExpr2.hs" "Main" - manipulateAstTest "LetStmt.hs" "Layout.LetStmt" - manipulateAstTest "LayoutLet.hs" "Main" - manipulateAstTest "ImplicitParams.hs" "Main" - manipulateAstTest "RebindableSyntax.hs" "Main" - manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" - manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5" - manipulateAstTest "EmptyMostly2.hs" "EmptyMostly2" - manipulateAstTest "WhereIn4.hs" "WhereIn4" - manipulateAstTest "AltsSemis.hs" "Main" - manipulateAstTest "PArr.hs" "PArr" - manipulateAstTest "Dead1.hs" "Dead1" - manipulateAstTest "DocDecls.hs" "DocDecls" - manipulateAstTest "ViewPatterns.hs" "Main" - manipulateAstTest "LayoutLet2.hs" "LayoutLet2" - manipulateAstTest "FooExpected.hs" "Main" - manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" - manipulateAstTest "LayoutIn1.hs" "LayoutIn1" - manipulateAstTestWithMod changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" - manipulateAstTest "LocToName.hs" "LocToName" - -} - -- manipulateAstTestWithMod changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" - manipulateAstTestWithMod changeLocToName "LocToName.hs" "LocToName" - -- manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" - -- manipulateAstTestWithMod changeRename1 "Rename1.hs" "Main" - -- manipulateAstTest "Rename1.hs" "Main" - -- manipulateAstTest "Rules.hs" "Rules" +formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () +formatTT (ts, fs) = do + when (not . null $ tail ts) (do + putStrLn "Pass" + mapM_ (putStrLn . fst) (tail ts) + ) + when (not . null $ fs) (do + putStrLn "Fail" + mapM_ (putStrLn . fst) fs) -{- - manipulateAstTest "ParensAroundContext.hs" "ParensAroundContext" - manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4" - manipulateAstTest "Cpp.hs" "Main" - manipulateAstTest "Lhs.lhs" "Main" - manipulateAstTest "Foo.hs" "Main" +tt :: IO () +tt = formatTT =<< partition snd <$> sequence [ return ("", True) + {- + , manipulateAstTestWFname "LetExpr.hs" "LetExpr" + -} + -- , manipulateAstTestWFname "ExprPragmas.hs" "ExprPragmas" + {- + , manipulateAstTestWFname "ListComprehensions.hs" "Main" + , manipulateAstTestWFname "MonadComprehensions.hs" "Main" + , manipulateAstTestWFname "FunDeps.hs" "Main" + , manipulateAstTestWFname "RecursiveDo.hs" "Main" + , manipulateAstTestWFname "TypeFamilies.hs" "Main" + , manipulateAstTestWFname "MultiParamTypeClasses.hs" "Main" + , manipulateAstTestWFname "DataFamilies.hs" "DataFamilies" + , manipulateAstTestWFname "Deriving.hs" "Main" + , manipulateAstTestWFname "Default.hs" "Main" + , manipulateAstTestWFname "ForeignDecl.hs" "ForeignDecl" + , manipulateAstTestWFname "Warning.hs" "Warning" + -} + -- , manipulateAstTestWFname "Annotations.hs" "Annotations" + {- + , manipulateAstTestWFnameTH "QuasiQuote.hs" "QuasiQuote" + , manipulateAstTestWFname "Roles.hs" "Roles" + , manipulateAstTestWFname "Splice.hs" "Splice" + , manipulateAstTestWFname "ImportsSemi.hs" "ImportsSemi" + , manipulateAstTestWFname "Stmts.hs" "Stmts" + -} + -- , manipulateAstTestWFname "Mixed.hs" "Main" + {- + , manipulateAstTestWFname "Arrow.hs" "Arrow" + , manipulateAstTestWFname "PatSynBind.hs" "Main" + -} + -- , manipulateAstTestWFname "HsDo.hs" "HsDo" + {- + , manipulateAstTestWFname "ForAll.hs" "ForAll" + , manipulateAstTestWFname "BangPatterns.hs" "Main" + , manipulateAstTestWFname "Associated.hs" "Main" + -} + -- , manipulateAstTestWFname "Move1.hs" "Move1" + {- + , manipulateAstTestWFname "TypeOperators.hs" "Main" + , manipulateAstTestWFname "NullaryTypeClasses.hs" "Main" + , manipulateAstTestWFname "FunctionalDeps.hs" "Main" + , manipulateAstTestWFname "DerivingOC.hs" "Main" + , manipulateAstTestWFname "GenericDeriving.hs" "Main" + , manipulateAstTestWFname "OverloadedStrings.hs" "Main" + , manipulateAstTestWFname "RankNTypes.hs" "Main" + -} + -- , manipulateAstTestWFname "Existential.hs" "Main" + {- + , manipulateAstTestWFname "ScopedTypeVariables.hs" "Main" + , manipulateAstTestWFname "Arrows.hs" "Main" + , manipulateAstTestWFname "TH.hs" "Main" + , manipulateAstTestWFname "StaticPointers.hs" "Main" + , manipulateAstTestWFname "DataDecl.hs" "Main" + , manipulateAstTestWFname "Guards.hs" "Main" + , manipulateAstTestWFname "RdrNames.hs" "RdrNames" + -} + -- , manipulateAstTestWFname "Vect.hs" "Vect" + {- + , manipulateAstTestWFname "Tuple.hs" "Main" + , manipulateAstTestWFname "ExtraConstraints1.hs" "ExtraConstraints1" + , manipulateAstTestWFname "AddAndOr3.hs" "AddAndOr3" + -} + -- , manipulateAstTestWFname "Ann01.hs" "Ann01" + -- , manipulateAstTestWFname "StrictLet.hs" "Main" + {- + , manipulateAstTestWFname "Cg008.hs" "Cg008" + , manipulateAstTestWFname "T2388.hs" "T2388" + , manipulateAstTestWFname "T3132.hs" "T3132" + , manipulateAstTestWFname "Stream.hs" "Stream" + , manipulateAstTestWFname "Trit.hs" "Trit" + , manipulateAstTestWFname "DataDecl.hs" "Main" + , manipulateAstTestWFname "Zipper.hs" "Zipper" + -} + -- , manipulateAstTestWFname "Sigs.hs" "Sigs" + -- , manipulateAstTestWFname "Utils2.hs" "Utils2" + {- + , manipulateAstTestWFname "EmptyMostlyInst.hs" "EmptyMostlyInst" + , manipulateAstTestWFname "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis" + , manipulateAstTestWFname "EmptyMostly.hs" "EmptyMostly" + , manipulateAstTestWFname "FromUtils.hs" "Main" + , manipulateAstTestWFname "DocDecls.hs" "DocDecls" + , manipulateAstTestWFname "RecordUpdate.hs" "Main" + -- manipulateAstTestWFname "Unicode.hs" "Main" + , manipulateAstTestWFname "B.hs" "Main" + , manipulateAstTestWFname "LayoutWhere.hs" "Main" + -} + -- , manipulateAstTestWFname "Deprecation.hs" "Deprecation" + {- + , manipulateAstTestWFname "Infix.hs" "Main" + , manipulateAstTestWFname "BCase.hs" "Main" + , manipulateAstTestWFname "LetExprSemi.hs" "LetExprSemi" + , manipulateAstTestWFname "LetExpr2.hs" "Main" + , manipulateAstTestWFname "LetStmt.hs" "Layout.LetStmt" + , manipulateAstTestWFname "LayoutLet.hs" "Main" + -} + -- , manipulateAstTestWFname "ImplicitParams.hs" "Main" + {- + , manipulateAstTestWFname "RebindableSyntax.hs" "Main" + , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4" + , manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5" + , manipulateAstTestWFname "EmptyMostly2.hs" "EmptyMostly2" + , manipulateAstTestWFname "WhereIn4.hs" "WhereIn4" + , manipulateAstTestWFname "AltsSemis.hs" "Main" + , manipulateAstTestWFname "PArr.hs" "PArr" + -} + -- , manipulateAstTestWFname "Dead1.hs" "Dead1" + {- + , manipulateAstTestWFname "DocDecls.hs" "DocDecls" + , manipulateAstTestWFname "ViewPatterns.hs" "Main" + , manipulateAstTestWFname "FooExpected.hs" "Main" + , manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2" + , manipulateAstTestWFname "LayoutIn1.hs" "LayoutIn1" + , manipulateAstTestWithMod changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1" + , manipulateAstTestWFname "LocToName.hs" "LocToName" + , manipulateAstTestWithMod changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4" + , manipulateAstTestWithMod changeLocToName "LocToName.hs" "LocToName" + , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3" + , manipulateAstTestWithMod changeRename1 "Rename1.hs" "Main" + , manipulateAstTestWFname "Rename1.hs" "Main" + -} + -- , manipulateAstTestWFname "Rules.hs" "Rules" + -- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2" + -- , manipulateAstTestWFname "LayoutIn3.hs" "LayoutIn3" + -- , manipulateAstTestWFname "LayoutIn3a.hs" "LayoutIn3a" + , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a" + -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b" + -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3" + -- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2" + {- + , manipulateAstTestWFname "ParensAroundContext.hs" "ParensAroundContext" + , manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4" + , manipulateAstTestWFname "Cpp.hs" "Main" + , manipulateAstTestWFname "Lhs.lhs" "Main" + , manipulateAstTestWFname "Foo.hs" "Main" -} + ] -- --------------------------------------------------------------------- @@ -288,6 +342,10 @@ changeLocToName :: GHC.ParsedSource -> GHC.ParsedSource changeLocToName parsed = rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed +changeLayoutIn3 :: GHC.ParsedSource -> GHC.ParsedSource +changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed +-- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed + changeLayoutIn4 :: GHC.ParsedSource -> GHC.ParsedSource changeLayoutIn4 parsed = rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed @@ -354,9 +412,17 @@ manipulateAstTestWithMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO Bool manipulateAstTestWithMod change file modname = manipulateAstTest' (Just change) False file modname +manipulateAstTestWFnameMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO (FilePath,Bool) +manipulateAstTestWFnameMod change fileName modname + = do r <- manipulateAstTestWithMod change fileName modname + return (fileName,r) + manipulateAstTest :: FilePath -> String -> IO Bool manipulateAstTest file modname = manipulateAstTest' Nothing False file modname +manipulateAstTestWFname :: FilePath -> String -> IO (FilePath, Bool) +manipulateAstTestWFname file modname = (file,) <$> manipulateAstTest file modname + manipulateAstTestTH :: FilePath -> String -> IO Bool manipulateAstTestTH file modname = manipulateAstTest' Nothing True file modname @@ -377,13 +443,13 @@ -- parsedAST = showGhc parsed -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule))) -- try to pretty-print; summarize the test result - ann = annotateAST parsed ghcAnns + ann = relativiseApiAnns parsed ghcAnns `debug` ("ghcAnns:" ++ showGhc ghcAnns) parsed' = case mchange of Nothing -> parsed Just change -> change parsed - printed = exactPrintAnnotation parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann)) + printed = exactPrintWithAnns parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann)) result = if printed == contents then "Match\n" @@ -395,7 +461,9 @@ writeFile out $ result -- putStrLn $ "Test:parsed=" ++ parsedAST -- putStrLn $ "Test:ann :" ++ showGhc ann + -- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns -- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed + -- putStrLn $ "Test:showdata:parsed'" ++ SYB.showData SYB.Parser 0 parsed' -- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed' return ("Match\n" == result) @@ -550,4 +618,3 @@ case Map.lookup tmp_dir mapping of Nothing -> error "should already be a tmpDir" Just d -> return d - diff --git a/tests/examples/AddAndOr3.hs b/tests/examples/AddAndOr3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/AddAndOr3.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module AddAndOr3 where + +addAndOr3 :: _ -> _ -> _ +addAndOr3 (a, b) (c, d) = (a `plus` d, b || c) + where plus :: Int -> Int -> Int + x `plus` y = x + y diff --git a/tests/examples/AltsSemis.hs b/tests/examples/AltsSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/AltsSemis.hs @@ -0,0 +1,11 @@ + + +foo x = + case x of + { ;;; -- leading + 0 -> 'a'; -- case 0 + 1 -> 'b' -- case 1 + ; 2 -> 'c' ; -- case 2 + ; 3 -> 'd' -- case 3 + ;;; -- case 4 + } diff --git a/tests/examples/Ann01.hs b/tests/examples/Ann01.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Ann01.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Ann01 where + +{-# ANN module (1 :: Int) #-} +{-# ANN module (1 :: Integer) #-} +{-# ANN module (1 :: Double) #-} +{-# ANN module $([| 1 :: Int |]) #-} +{-# ANN module "Hello" #-} +{-# ANN module (Just (1 :: Int)) #-} +{-# ANN module [1 :: Int, 2, 3] #-} +{-# ANN module ([1..10] :: [Integer]) #-} +{-# ANN module ''Foo #-} +{-# ANN module (-1 :: Int) #-} + +{-# ANN type Foo (1 :: Int) #-} +{-# ANN type Foo (1 :: Integer) #-} +{-# ANN type Foo (1 :: Double) #-} +{-# ANN type Foo $([| 1 :: Int |]) #-} +{-# ANN type Foo "Hello" #-} +{-# ANN type Foo (Just (1 :: Int)) #-} +{-# ANN type Foo [1 :: Int, 2, 3] #-} +{-# ANN type Foo ([1..10] :: [Integer]) #-} +{-# ANN type Foo ''Foo #-} +{-# ANN type Foo (-1 :: Int) #-} +data Foo = Bar Int + +{-# ANN f (1 :: Int) #-} +{-# ANN f (1 :: Integer) #-} +{-# ANN f (1 :: Double) #-} +{-# ANN f $([| 1 :: Int |]) #-} +{-# ANN f "Hello" #-} +{-# ANN f (Just (1 :: Int)) #-} +{-# ANN f [1 :: Int, 2, 3] #-} +{-# ANN f ([1..10] :: [Integer]) #-} +{-# ANN f 'f #-} +{-# ANN f (-1 :: Int) #-} +f x = x diff --git a/tests/examples/Annotations.hs b/tests/examples/Annotations.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Annotations.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Annotations where + +{-# ANN module (1 :: Int) #-} +{-# ANN module (1 :: Integer) #-} +{-# ANN module (1 :: Double) #-} +{-# ANN module $([| 1 :: Int |]) #-} +{-# ANN module "Hello" #-} +{-# ANN module (Just (1 :: Int)) #-} +{-# ANN module [1 :: Int, 2, 3] #-} +{-# ANN module ([1..10] :: [Integer]) #-} +{-# ANN module ''Foo #-} +{-# ANN module (-1 :: Int) #-} + +{-# ANN type Foo (1 :: Int) #-} +{-# ANN type Foo (1 :: Integer) #-} +{-# ANN type Foo (1 :: Double) #-} +{-# ANN type Foo $([| 1 :: Int |]) #-} +{-# ANN type Foo "Hello" #-} +{-# ANN type Foo (Just (1 :: Int)) #-} +{-# ANN type Foo [1 :: Int, 2, 3] #-} +{-# ANN type Foo ([1..10] :: [Integer]) #-} +{-# ANN type Foo ''Foo #-} +{-# ANN type Foo (-1 :: Int) #-} +data Foo = Bar Int + +{-# ANN f (1 :: Int) #-} +{-# ANN f (1 :: Integer) #-} +{-# ANN f (1 :: Double) #-} +{-# ANN f $([| 1 :: Int |]) #-} +{-# ANN f "Hello" #-} +{-# ANN f (Just (1 :: Int)) #-} +{-# ANN f [1 :: Int, 2, 3] #-} +{-# ANN f ([1..10] :: [Integer]) #-} +{-# ANN f 'f #-} +{-# ANN f (-1 :: Int) #-} +f x = x diff --git a/tests/examples/Arrow.hs b/tests/examples/Arrow.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Arrow.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Arrows #-} +module Arrow where + +import Control.Arrow +import qualified Control.Category as Cat + +addA :: Arrow a => a b Int -> a b Int -> a b Int +addA f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y + z + +newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } + +instance Cat.Category Circuit where + id = Circuit $ \a -> (Cat.id, a) + (.) = dot + where + (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> + let (cir1', b) = cir1 a + (cir2', c) = cir2 b + in (cir2' `dot` cir1', c) + +instance Arrow Circuit where + arr f = Circuit $ \a -> (arr f, f a) + first (Circuit cir) = Circuit $ \(b, d) -> + let (cir', c) = cir b + in (first cir', (c, d)) + +-- | Accumulator that outputs a value determined by the supplied function. +accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b +accum acc f = Circuit $ \input -> + let (output, acc') = input `f` acc + in (accum acc' f, output) + +-- | Accumulator that outputs the accumulator value. +accum' :: b -> (a -> b -> b) -> Circuit a b +accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) + +total :: Num a => Circuit a a +total = accum' 0 (+) + +mean3 :: Fractional a => Circuit a a +mean3 = proc value -> do + (t, n) <- (| (&&&) (total -< value) (total -< 1) |) + returnA -< t / n diff --git a/tests/examples/Arrows.hs b/tests/examples/Arrows.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Arrows.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE Arrows #-} +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html + +import Control.Monad (guard) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli) + +f :: Int -> (Int, Int) +f = \x -> + let y = 2 * x + z1 = y + 3 + z2 = y - 5 + in (z1, z2) + +-- ghci> f 10 +-- (23, 15) + +fM :: Int -> Identity (Int, Int) +fM = \x -> do + y <- return (2 * x) + z1 <- return (y + 3) + z2 <- return (y - 5) + return (z1, z2) + +-- ghci> runIdentity (fM 10) +-- (23,15) + + +fA :: Int -> (Int, Int) +fA = proc x -> do + y <- (2 *) -< x + z1 <- (+ 3) -< y + z2 <- (subtract 5) -< y + returnA -< (z1, z2) + +-- ghci> fA 10 +-- (23,15) + +range :: Int -> [Int] +range r = [-r..r] + +cM :: Int -> [(Int, Int)] +cM = \r -> do + x <- range 5 + y <- range 5 + guard (x*x + y*y <= r*r) + return (x, y) + +-- ghci> take 10 (cM 5) +-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] + + +type K = Kleisli + +k :: (a -> m b) -> Kleisli m a b +k = Kleisli + +runK :: Kleisli m a b -> (a -> m b) +runK = runKleisli + +cA :: Kleisli [] Int (Int, Int) +cA = proc r -> do + x <- k range -< 5 + y <- k range -< 5 + k guard -< (x*x + y*y <= r*r) + returnA -< (x, y) + +-- ghci> take 10 (runK cA 5) +-- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] + +getLineM :: String -> IO String +getLineM prompt = do + print prompt + getLine + +printM :: String -> IO () +printM = print + +writeFileM :: (FilePath, String) -> IO () +writeFileM (filePath, string) = writeFile filePath string + +procedureM :: String -> IO () +procedureM = \prompt -> do + input <- getLineM prompt + if input == "Hello" + then printM "You said 'Hello'" + else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'") diff --git a/tests/examples/Associated.hs b/tests/examples/Associated.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Associated.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} + +-- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example + +import qualified Data.IntMap +import Prelude hiding (lookup) +import Data.Char (ord) + +class GMapKey k where + data GMap k :: * -> * + empty :: GMap k v + lookup :: k -> GMap k v -> Maybe v + insert :: k -> v -> GMap k v -> GMap k v + +-- An Int instance +instance GMapKey Int where + data GMap Int v = GMapInt (Data.IntMap.IntMap v) + empty = GMapInt Data.IntMap.empty + lookup k (GMapInt m) = Data.IntMap.lookup k m + insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m) + +-- A Char instance +instance GMapKey Char where + data GMap Char v = GMapChar (GMap Int v) + empty = GMapChar empty + lookup k (GMapChar m) = lookup (ord k) m + insert k v (GMapChar m) = GMapChar (insert (ord k) v m) + +-- A Unit instance +instance GMapKey () where + data GMap () v = GMapUnit (Maybe v) + empty = GMapUnit Nothing + lookup () (GMapUnit v) = v + insert () v (GMapUnit _) = GMapUnit $ Just v + +-- Product and sum instances +instance (GMapKey a, GMapKey b) => GMapKey (a, b) where + data GMap (a, b) v = GMapPair (GMap a (GMap b v)) + empty = GMapPair empty + lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b + insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of + Nothing -> insert a (insert b v empty) gm + Just gm2 -> insert a (insert b v gm2 ) gm + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + empty = GMapEither empty empty + lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 + lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 + insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 + insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) + +myGMap :: GMap (Int, Either Char ()) String +myGMap = insert (5, Left 'c') "(5, Left 'c')" $ + insert (4, Right ()) "(4, Right ())" $ + insert (5, Right ()) "This is the one!" $ + insert (5, Right ()) "This is the two!" $ + insert (6, Right ()) "(6, Right ())" $ + insert (5, Left 'a') "(5, Left 'a')" $ + empty + +main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap + +-- (Type) Synonym Family + +type family Elem c + +type instance Elem [e] = e + +-- type instance Elem BitSet = Char + + +data family T a +data instance T Int = T1 Int | T2 Bool +newtype instance T Char = TC Bool + +data family G a b +data instance G [a] b where + G1 :: c -> G [Int] b + G2 :: G [a] Bool diff --git a/tests/examples/B.hs b/tests/examples/B.hs new file mode 100644 --- /dev/null +++ b/tests/examples/B.hs @@ -0,0 +1,4 @@ + +foo x = case (odd x) of + True -> "Odd" + False -> "Even" diff --git a/tests/examples/BCase.hs b/tests/examples/BCase.hs new file mode 100644 --- /dev/null +++ b/tests/examples/BCase.hs @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/BIf.hs b/tests/examples/BIf.hs new file mode 100644 --- /dev/null +++ b/tests/examples/BIf.hs @@ -0,0 +1,8 @@ + + +main = + if 1 > 10 + then do putStrLn "hello" + putStrLn "there" + else do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/BangPatterns.hs b/tests/examples/BangPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/BangPatterns.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE BangPatterns #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html + +import Data.Function (fix) +import Data.List (foldl') + +hello3 :: Bool -> String +hello3 !loud = "Hello." + +mean :: [Double] -> Double +mean xs = s / fromIntegral l + where + (s, l) = foldl' step (0, 0) xs + step (!s, !l) a = (s + a, l + 1) + diff --git a/tests/examples/BootImport.hs b/tests/examples/BootImport.hs new file mode 100644 --- /dev/null +++ b/tests/examples/BootImport.hs @@ -0,0 +1,3 @@ +module BootImport where + +data Foo = Foo Int diff --git a/tests/examples/BootImport.hs-boot b/tests/examples/BootImport.hs-boot new file mode 100644 --- /dev/null +++ b/tests/examples/BootImport.hs-boot @@ -0,0 +1,3 @@ +module BootImport where + +data Foo diff --git a/tests/examples/Cg008.hs b/tests/examples/Cg008.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Cg008.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE MagicHash, BangPatterns #-} +{-# OPTIONS_GHC -O0 #-} + +-- Variant of cgrun066; compilation as a module is different. + +module Cg008 (hashStr) where + +import Foreign.C +import Data.Word +import Foreign.Ptr +import GHC.Exts + +import Control.Exception + +hashStr :: Ptr Word8 -> Int -> Int +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | isTrue# (n GHC.Exts.==# len#) = I# h + | otherwise = loop h2 (n GHC.Exts.+# 1#) + where !c = ord# (indexCharOffAddr# a# n) + !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# diff --git a/tests/examples/Cpp.hs b/tests/examples/Cpp.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Cpp.hs @@ -0,0 +1,9 @@ +{-# Language CPP #-} + +#if __GLASGOW_HASKELL__ > 704 +foo :: Int +#else +foo :: Integer +#endif +foo = 3 + diff --git a/tests/examples/DataDecl.hs b/tests/examples/DataDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/DataDecl.hs @@ -0,0 +1,34 @@ +{-# Language DatatypeContexts #-} +{-# Language ExistentialQuantification #-} +{-# LAnguage GADTs #-} +{-# LAnguage KindSignatures #-} + +data Foo = A + | B + | C + +-- | data_or_newtype capi_ctype tycl_hdr constrs deriving +data {-# Ctype "Foo" "bar" #-} F1 = F1 +data {-# Ctype "baz" #-} Eq a => F2 a = F2 a + +data (Eq a,Ord a) => F3 a = F3 Int a + +data F4 a = forall x y. (Eq x,Eq y) => F4 a x y + | forall x y. (Eq x,Eq y) => F4b a x y + + +data G1 a :: * where + G1A, G1B :: Int -> G1 a + G1C :: Double -> G1 a + +data G2 a :: * where + G2A { g2a :: a, g2b :: Int } :: G2 a + G2C :: Double -> G2 a + + + +data (Eq a,Ord a) => G3 a = G3 + { g3A :: Int + , g3B :: Bool + , g3a :: a + } deriving (Eq,Ord) diff --git a/tests/examples/DataFamilies.hs b/tests/examples/DataFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/DataFamilies.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families + +module DataFamilies + ( + GMap + , GMapKey(type GMapK) + ) where + +-- Type 1, Top level + +data family GMap k :: * -> * + +data family Array e + +data family ArrayK :: * -> * + + +-- Type 2, associated types + +class GMapKey k where + data GMapK k :: * -> * + +class C a b c where { data T1 c a :: * } -- OK +-- class C a b c where { data T a a :: * } -- Bad: repeated variable +-- class D a where { data T a x :: * } -- Bad: x is not a class variable +class D a where { data T2 a :: * -> * } -- OK + +-- Instances + +data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) + +data family T3 a +data instance T3 Int = A +data instance T3 Char = B +nonsense :: T3 a -> Int +-- nonsense A = 1 -- WRONG: These two equations together... +-- nonsense B = 2 -- ...will produce a type error. +nonsense = undefined + + +instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where + data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v) + +-- data GMap () v = GMapUnit (Maybe v) +-- deriving Show + + diff --git a/tests/examples/Dead1.hs b/tests/examples/Dead1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Dead1.hs @@ -0,0 +1,42 @@ +{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-} + +module Dead1(foo) where + +foo :: Int -> Int +foo n = baz (n+1) (bar1 n) + +{-# NOINLINE bar1 #-} +bar1 n = 1 + bar n + +bar :: Int -> Int +{-# NOINLINE bar #-} +{-# RULES +"bar/foo" forall n. bar (foo n) = n + #-} +bar n = n-1 + +baz :: Int -> Int -> Int +{-# INLINE [0] baz #-} +baz m n = m + + +{- Ronam writes (Feb08) + + Note that bar becomes dead as soon as baz gets inlined. But strangely, + the simplifier only deletes it after full laziness and CSE. That is, it + is not deleted in the phase in which baz gets inlined. In fact, it is + still there after w/w and the subsequent simplifier run. It gets deleted + immediately if I comment out the rule. + + I stumbled over this when I removed one simplifier run after SpecConstr + (at the moment, it runs twice at the end but I don't think that should + be necessary). With this change, the original version of a specialised + loop (the one with the rules) is not longer deleted even if it isn't + used any more. I'll reenable the second simplifier run for now but + should this really be necessary? + +No, it should not be necessary. A refactoring in OccurAnal makes +this work right. Look at the simplifier output just before strictness +analysis; there should be a binding for 'foo', but for nothing else. + +-} diff --git a/tests/examples/Default.hs b/tests/examples/Default.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Default.hs @@ -0,0 +1,8 @@ +default (Integer, Double) -- "default default" + +mag :: Float -> Float -> Float +mag x y = sqrt( x^2 + y^2 ) + +main = do + +print $ mag 1 1 diff --git a/tests/examples/Deprecation.hs b/tests/examples/Deprecation.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Deprecation.hs @@ -0,0 +1,14 @@ + +module Deprecation +{-# Deprecated ["This is a module \"deprecation\"", + "multi-line"] #-} + ( foo ) + where + +{-# DEPRECATEd foo + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + diff --git a/tests/examples/Deriving.hs b/tests/examples/Deriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Deriving.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +import Data.Data + +data Foo = FooA | FooB + +deriving instance Show Foo + +deriving instance {-# Overlappable #-} Eq Foo +deriving instance {-# Overlapping #-} Ord Foo +deriving instance {-# Overlaps #-} Typeable Foo +deriving instance {-# Incoherent #-} Data Foo + diff --git a/tests/examples/DerivingOC.hs b/tests/examples/DerivingOC.hs new file mode 100644 --- /dev/null +++ b/tests/examples/DerivingOC.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html + +import Data.Data +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.State + +data MiniIoF a = Terminate + | PrintLine String a + | ReadLine (String -> a) + deriving (Functor) + + +-- data List a = Nil | Cons a (List a) +-- deriving (Eq, Show, Functor, Foldable, Traversable) + + + +data List a = Nil | Cons a (List a) + deriving ( Eq, Show + , Functor, Foldable, Traversable + , Typeable, Data) + +data Config = C String String +data AppState = S Int Bool + +newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a } + deriving (Monad, MonadReader Config, + MonadState AppState, MonadIO, + Applicative,Functor) diff --git a/tests/examples/DocDecls.hs b/tests/examples/DocDecls.hs new file mode 100644 --- /dev/null +++ b/tests/examples/DocDecls.hs @@ -0,0 +1,7 @@ +module DocDecls where + +-- | A document before +data Foo = A Int | B Char + deriving (Show) + + diff --git a/tests/examples/EmptyMostly.hs b/tests/examples/EmptyMostly.hs new file mode 100644 --- /dev/null +++ b/tests/examples/EmptyMostly.hs @@ -0,0 +1,13 @@ +module EmptyMostly where + { ;;; + ;;x=let{;;;;;y=2;;z=3;;;;}in y; + -- ;;;; + class Foo a where {;;;;;; + (--<>--) :: a -> a -> Int ; + infixl 5 --<>-- ; + (--<>--) _ _ = 2 ; -- empty decl at the end. +}; +-- ;;;;;;;;;;;; +-- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} +-- ;; + } diff --git a/tests/examples/EmptyMostly2.hs b/tests/examples/EmptyMostly2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/EmptyMostly2.hs @@ -0,0 +1,8 @@ +module EmptyMostly2 where + { +;;;;;;;;;;;; +; +class Baz a where {;;;;;;;;; + ; baz :: a -> Int;;; +} + } diff --git a/tests/examples/EmptyMostlyInst.hs b/tests/examples/EmptyMostlyInst.hs new file mode 100644 --- /dev/null +++ b/tests/examples/EmptyMostlyInst.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE FlexibleInstances #-} +module EmptyMostlyInst where + { +;;;;;;;;;;;; +; +instance Eq (Int,Integer) where {;;;;;;;;; +;;;;;;; a == b = False;;;;;;;;;;; +} + } diff --git a/tests/examples/EmptyMostlyNoSemis.hs b/tests/examples/EmptyMostlyNoSemis.hs new file mode 100644 --- /dev/null +++ b/tests/examples/EmptyMostlyNoSemis.hs @@ -0,0 +1,8 @@ +module EmptyMostlyNoSemis where + +x=let{y=2}in y +class Foo a where { + (--<>--) :: a -> a -> Int; + infixl 5 --<>--; + (--<>--) _ _ = 2 ; -- empty decl at the end. + } diff --git a/tests/examples/Existential.hs b/tests/examples/Existential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Existential.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html + +data HashMap k v = HM -- ... -- actual implementation + +class Hashable v where + h :: v -> Int + +data HashMapM hm = HashMapM + { empty :: forall k v . hm k v + , lookup :: Hashable k => k -> hm k v -> Maybe v + , insert :: Hashable k => k -> v -> hm k v -> hm k v + , union :: Hashable k => hm k v -> hm k v -> hm k v + } + + +data HashMapE = forall hm . HashMapE (HashMapM hm) + +-- public +mkHashMapE :: Int -> HashMapE +mkHashMapE = HashMapE . mkHashMapM + +-- private +mkHashMapM :: Int -> HashMapM HashMap +mkHashMapM salt = HashMapM { {- implementation -} } + +instance Hashable String where + +type Name = String +data Gift = G String + +giraffe :: Gift +giraffe = G "giraffe" + +addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift +addGift mod gifts = + let + HashMapM{..} = mod + in + insert "Ollie" giraffe gifts + +-- ------------------------------- + +santa'sSecretSalt = undefined +sendGiftToOllie = undefined +traverse_ = undefined + +sendGifts = + case mkHashMapE santa'sSecretSalt of + HashMapE (mod@HashMapM{..}) -> + let + gifts = addGift mod empty + in + traverse_ sendGiftToOllie $ lookup "Ollie" gifts diff --git a/tests/examples/Expr.hs b/tests/examples/Expr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Expr.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Expr where + +import Data.Generics +import Language.Haskell.TH as TH +import Language.Haskell.TH.Quote + +-- import Text.ParserCombinators.Parsec +-- import Text.ParserCombinators.Parsec.Char + +data Expr = IntExpr Integer + | AntiIntExpr String + | BinopExpr BinOp Expr Expr + | AntiExpr String + deriving(Typeable, Data,Show) + +data BinOp = AddOp + | SubOp + | MulOp + | DivOp + deriving(Typeable, Data,Show) + +eval :: Expr -> Integer +eval (IntExpr n) = n +eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) + where + opToFun AddOp = (+) + opToFun SubOp = (-) + opToFun MulOp = (*) + opToFun DivOp = (div) + +small = lower <|> char '_' +large = upper +idchar = small <|> large <|> digit <|> char '\'' + +lexeme p = do{ x <- p; spaces; return x } +symbol name = lexeme (string name) +parens p = undefined -- between (symbol "(") (symbol ")") p + +_expr :: CharParser st Expr +_expr = term `chainl1` mulop + +term :: CharParser st Expr +term = factor `chainl1` addop + +factor :: CharParser st Expr +factor = parens _expr <|> integer <|> anti + +mulop = undefined +{- + do{ symbol "*"; return $ BinopExpr MulOp } + <|> do{ symbol "/"; return $ BinopExpr DivOp } +-} +addop = undefined +{- + do{ symbol "+"; return $ BinopExpr AddOp } + <|> do{ symbol "-"; return $ BinopExpr SubOp } +-} + +integer :: CharParser st Expr +integer = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) } + +anti = undefined +{- + lexeme $ + do symbol "$" + c <- small + cs <- many idchar + return $ AntiIntExpr (c : cs) +-} + +parseExpr :: Monad m => TH.Loc -> String -> m Expr +parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s = + case runParser p () "" s of + Left err -> fail $ "baz" + Right e -> return e + where + p = do pos <- getPosition + setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file + spaces + e <- _expr + eof + return e + +expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat } + +parseExprExp :: String -> Q Exp +parseExprExp s = do loc <- location + expr <- parseExpr loc s + dataToExpQ (const Nothing `extQ` antiExprExp) expr + +antiExprExp :: Expr -> Maybe (Q Exp) +antiExprExp (AntiIntExpr v) = Just $ appE (conE (mkName "IntExpr")) + (varE (mkName v)) +antiExprExp (AntiExpr v) = Just $ varE (mkName v) +antiExprExp _ = Nothing + +parseExprPat :: String -> Q Pat +parseExprPat s = do loc <- location + expr <- parseExpr loc s + dataToPatQ (const Nothing `extQ` antiExprPat) expr + +antiExprPat :: Expr -> Maybe (Q Pat) +antiExprPat (AntiIntExpr v) = Just $ conP (mkName "IntExpr") + [varP (mkName v)] +antiExprPat (AntiExpr v) = Just $ varP (mkName v) +antiExprPat _ = Nothing + +-- keep parser happy +runParser = undefined +getPosition = undefined +setPosition = undefined +setSourceName = undefined +setSourceLine = undefined +setSourceColumn = undefined +spaces = undefined +eof = undefined +many = undefined +digit = undefined +many1 = undefined +data CharParser a b = F a b +(<|>) = undefined +chainl1 = undefined +string = undefined +char = undefined +lower = undefined +upper = undefined +between = undefined +instance Monad (CharParser a) where +instance Applicative (CharParser a) where +instance Functor (CharParser a) where + diff --git a/tests/examples/ExprPragmas.hs b/tests/examples/ExprPragmas.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ExprPragmas.hs @@ -0,0 +1,7 @@ +module ExprPragmas where + +a = {-# SCC "name" #-} 0x5 + +b = {-# SCC foo #-} 006 + +c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 diff --git a/tests/examples/ExtraConstraints1.hs b/tests/examples/ExtraConstraints1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ExtraConstraints1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ExtraConstraints1 where + +arbitCs1 :: _ => a -> String +arbitCs1 x = show (succ x) ++ show (x == x) + +arbitCs2 :: (Show a, _) => a -> String +arbitCs2 x = arbitCs1 x + +arbitCs3 :: (Show a, Enum a, _) => a -> String +arbitCs3 x = arbitCs1 x + +arbitCs4 :: (Eq a, _) => a -> String +arbitCs4 x = arbitCs1 x + +arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String +arbitCs5 x = arbitCs1 x diff --git a/tests/examples/Foo.hs b/tests/examples/Foo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Foo.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecursiveDo #-} + +bar :: IO () +bar = do + rec {} + return () + diff --git a/tests/examples/FooExpected.hs b/tests/examples/FooExpected.hs new file mode 100644 --- /dev/null +++ b/tests/examples/FooExpected.hs @@ -0,0 +1,8 @@ + + +main = + case 1 > 10 of + True -> do putStrLn "hello" + putStrLn "there" + False -> do putStrLn "blah" + putStrLn "blah" diff --git a/tests/examples/ForAll.hs b/tests/examples/ForAll.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ForAll.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes #-} +module ForAll where + +import Data.Data + +foo :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a +foo a = a diff --git a/tests/examples/ForeignDecl.hs b/tests/examples/ForeignDecl.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ForeignDecl.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Based on ghc/testsuite/tests/ffi/should_compile contents +module ForeignDecl where + +import Foreign +import GHC.Exts +import Data.Int +import Data.Word + +-- simple functions + +foreign import ccall unsafe "a" a :: IO Int + +foreign import ccall unsafe "b" b :: Int -> IO Int + +foreign import ccall unsafe "c" + c :: Int -> Char -> Float -> Double -> IO Float + +-- simple monadic code + +d = a >>= \ x -> + b x >>= \ y -> + c y 'f' 1.0 2.0 + +-- We can't import the same function using both stdcall and ccall +-- calling conventions in the same file when compiling via C (this is a +-- restriction in the C backend caused by the need to emit a prototype +-- for stdcall functions). +foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) +foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int + +-- We can't redefine the calling conventions of certain functions (those from +-- math.h). +foreign import stdcall "my_sin" my_sin :: Double -> IO Double +foreign import stdcall "my_cos" my_cos :: Double -> IO Double + +foreign import stdcall "m1" m8 :: IO Int8 +foreign import stdcall "m2" m16 :: IO Int16 +foreign import stdcall "m3" m32 :: IO Int32 +foreign import stdcall "m4" m64 :: IO Int64 + +foreign import stdcall "dynamic" d8 :: FunPtr (IO Int8) -> IO Int8 +foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16 +foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 +foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 + +foreign import ccall unsafe "kitchen" + sink :: Ptr a + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO () + + +type Sink2 b = Ptr b + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Word8 + -> Word16 + -> Word32 + -> Float + -> Double + -> IO () + +foreign import ccall unsafe "dynamic" + sink2 :: Ptr (Sink2 b) -> Sink2 b + +-- exports +foreign export ccall "plusInt" (+) :: Int -> Int -> Int diff --git a/tests/examples/FromUtils.hs b/tests/examples/FromUtils.hs new file mode 100644 --- /dev/null +++ b/tests/examples/FromUtils.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +import Data.Data + + +-- --------------------------------------------------------------------- + +instance AnnotateP RdrName where + annotateP l n = do + case rdrName2String n of + "[]" -> do + addDeltaAnnotation AnnOpenS -- '[' + addDeltaAnnotation AnnCloseS -- ']' + +-- --------------------------------------------------------------------- + +class (Typeable ast) => AnnotateP ast where + annotateP :: SrcSpan -> ast -> IO () + + +type SrcSpan = Int +rdrName2String = undefined +type RdrName = String + +data A = AnnOpenS | AnnCloseS + +addDeltaAnnotation = undefined diff --git a/tests/examples/FunDeps.hs b/tests/examples/FunDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/FunDeps.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- FunDeps example +class Foo a b c | a b -> c where + bar :: a -> b -> c + diff --git a/tests/examples/FunctionalDeps.hs b/tests/examples/FunctionalDeps.hs new file mode 100644 --- /dev/null +++ b/tests/examples/FunctionalDeps.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} + +-- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html + +import Data.Foldable (forM_) +import Data.IORef + +class Store store m | store -> m where + new :: a -> m (store a) + get :: store a -> m a + put :: store a -> a -> m () + +instance Store IORef IO where + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + diff --git a/tests/examples/GenericDeriving.hs b/tests/examples/GenericDeriving.hs new file mode 100644 --- /dev/null +++ b/tests/examples/GenericDeriving.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +import GHC.Generics + +-- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html + +data Valid e a = Error e | OK a + deriving (Generic) + +toEither :: Valid e a -> Either e a +toEither (Error e) = Left e +toEither (OK a) = Right a + +fromEither :: Either e a -> Valid e a +fromEither (Left e) = Error e +fromEither (Right a) = OK a + +-- --------------------------------------------------------------------- + +class GetError rep e | rep -> e where + getError' :: rep a -> Maybe e + +instance GetError f e => GetError (M1 i c f) e where + getError' (M1 m1) = getError' m1 + +instance GetError l e => GetError (l :+: r) e where + getError' (L1 l) = getError' l + getError' (R1 _) = Nothing + +instance GetError (K1 i e) e where + getError' (K1 e) = Just e + +getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e +getError = getError' . from + diff --git a/tests/examples/Guards.hs b/tests/examples/Guards.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Guards.hs @@ -0,0 +1,6 @@ + + +f x | x > 0, x /= 10 = 1 / x + | x == 0 = undefined + where + y = 4 diff --git a/tests/examples/HsDo.hs b/tests/examples/HsDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/HsDo.hs @@ -0,0 +1,22 @@ +module HsDo where + +import qualified Data.Map as Map + +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + +graphFromEdgedVertices = undefined +nodes = undefined +lookup_node = undefined +type NodeMap a = Map.Map (Int,Int) (Int,Int,Int) +data SummaryNode = SummaryNode +moduleName = undefined +ms_mod = undefined +ms_hsc_src = undefined + diff --git a/tests/examples/IfThenElse1.hs b/tests/examples/IfThenElse1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/IfThenElse1.hs @@ -0,0 +1,7 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = do + cs <- if True + then getLine + else return "computer input" + putStrLn cs + diff --git a/tests/examples/IfThenElse2.hs b/tests/examples/IfThenElse2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/IfThenElse2.hs @@ -0,0 +1,5 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = if True +then print 12 +else print 42 + diff --git a/tests/examples/IfThenElse3.hs b/tests/examples/IfThenElse3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/IfThenElse3.hs @@ -0,0 +1,6 @@ +-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai +main = do + print 3 + if True then do + print 5 + else print 7 diff --git a/tests/examples/ImplicitParams.hs b/tests/examples/ImplicitParams.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ImplicitParams.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ImplicitParams #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html + +import Data.Char + + +type LogFunction = String -> IO () + +type Present = String + +queueNewChristmasPresents :: LogFunction -> [Present] -> IO () +queueNewChristmasPresents logMessage presents = do + mapM (logMessage . ("Queueing present for delivery: " ++)) presents + return () + +queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO () +queueNewChristmasPresents2 presents = do + mapM (?logMessage . ("Queueing present for delivery: " ++)) presents + return () + + +ex1 :: IO () +ex1 = + let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t) + in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"] + + +ex2 :: IO () +ex2 = do + -- Specifies its own logger + ex1 + + -- We can locally define a new logging function + let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i + then c + else toUpper c) + [0..] + t) + queueNewChristmasPresents2 ["Category Theory Books"] + diff --git a/tests/examples/ImportsSemi.hs b/tests/examples/ImportsSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ImportsSemi.hs @@ -0,0 +1,6 @@ +module ImportsSemi where +{ +; ; ; ; ; ; +import Data.List +;;; +} diff --git a/tests/examples/Infix.hs b/tests/examples/Infix.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Infix.hs @@ -0,0 +1,8 @@ + +infix 3 &&& + +(&&&) :: (Eq a) => [a] -> [a] -> [a] +(&&& ) [] [] = [] +xs &&& [] = xs +( &&&) [] ys = ys + diff --git a/tests/examples/LayoutIn1.hs b/tests/examples/LayoutIn1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn1.hs @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= sq x + sq y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/tests/examples/LayoutIn1.hs.expected b/tests/examples/LayoutIn1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn1.hs.expected @@ -0,0 +1,9 @@ +module LayoutIn1 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'sq' to 'square'. + +sumSquares x y= square x + square y where sq x= x^pow + --There is a comment. + pow=2 diff --git a/tests/examples/LayoutIn3.hs b/tests/examples/LayoutIn3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3.hs @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in (let y = 3 + z = 2 in x * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn3.hs.expected b/tests/examples/LayoutIn3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn3 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in (let y = 3 + z = 2 in anotherX * y * z * w) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn3a.hs b/tests/examples/LayoutIn3a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3a.hs @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( + x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn3a.hs.expected b/tests/examples/LayoutIn3a.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3a.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn3a where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( + anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn3b.hs b/tests/examples/LayoutIn3b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3b.hs @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let x = 12 in ( x ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn3b.hs.expected b/tests/examples/LayoutIn3b.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn3b.hs.expected @@ -0,0 +1,12 @@ +module LayoutIn3b where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'x' after 'let' to 'anotherX'. + +foo x = let anotherX = 12 in ( anotherX ) where y = 2 + --there is a comment. + w = x + where + x = let y = 5 in y + 3 + diff --git a/tests/examples/LayoutIn4.hs b/tests/examples/LayoutIn4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn4.hs @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = ioFun "hello" where ioFun s= do let k = reverse s + --There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/tests/examples/LayoutIn4.hs.expected b/tests/examples/LayoutIn4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutIn4.hs.expected @@ -0,0 +1,13 @@ +module LayoutIn4 where + +--Layout rule applies after 'where','let','do' and 'of' + +--In this Example: rename 'ioFun' to 'io' + +main = io "hello" where io s= do let k = reverse s +--There is a comment + s <- getLine + let q = (k ++ s) + putStr q + putStr "foo" + diff --git a/tests/examples/LayoutLet.hs b/tests/examples/LayoutLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet.hs @@ -0,0 +1,7 @@ + +foo x = + let + a = 1 + b = 2 + in x + a + b + diff --git a/tests/examples/LayoutLet2.hs b/tests/examples/LayoutLet2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet2.hs @@ -0,0 +1,9 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 in xxx + a + b + diff --git a/tests/examples/LayoutLet2.hs.expected b/tests/examples/LayoutLet2.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet2.hs.expected @@ -0,0 +1,9 @@ +module LayoutLet2 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 in xxxlonger + a + b + diff --git a/tests/examples/LayoutLet3.hs b/tests/examples/LayoutLet3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet3.hs @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + diff --git a/tests/examples/LayoutLet3.hs.expected b/tests/examples/LayoutLet3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet3.hs.expected @@ -0,0 +1,10 @@ +module LayoutLet3 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + diff --git a/tests/examples/LayoutLet4.hs b/tests/examples/LayoutLet4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet4.hs @@ -0,0 +1,11 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + +bar = 3 diff --git a/tests/examples/LayoutLet4.hs.expected b/tests/examples/LayoutLet4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet4.hs.expected @@ -0,0 +1,11 @@ +module LayoutLet4 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxxlonger = let a = 1 + b = 2 + in xxxlonger + a + b + +bar = 3 diff --git a/tests/examples/LayoutLet5.hs b/tests/examples/LayoutLet5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet5.hs @@ -0,0 +1,11 @@ +module LayoutLet5 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo xxx = let a = 1 + b = 2 + in xxx + a + b + +bar = 3 diff --git a/tests/examples/LayoutLet5.hs.expected b/tests/examples/LayoutLet5.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutLet5.hs.expected @@ -0,0 +1,11 @@ +module LayoutLet5 where + +-- Simple let expression, rename xxx to something longer or shorter +-- and the let/in layout should adjust accordingly +-- In this case the tokens for xxx + a + b should also shift out + +foo x = let a = 1 + b = 2 + in x + a + b + +bar = 3 diff --git a/tests/examples/LayoutWhere.hs b/tests/examples/LayoutWhere.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LayoutWhere.hs @@ -0,0 +1,6 @@ + +foo x = r + where + a = 3 + b = 4 + r = a + a + b diff --git a/tests/examples/LetExpr.hs b/tests/examples/LetExpr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LetExpr.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language DeriveFoldable #-} +{-# LANGUAGE Safe #-} +{-# options_ghc -w #-} + +-- | A simple let expression, to ensure the layout is detected +-- With some haddock in the top +{- And a normal + multiline comment too -} + module {- brah -} LetExpr ( foo -- foo does .. + , bar -- bar does .. + , Baz () -- baz does .. + , Ba ( ..),Ca(Cc,Cd) , + bbb , aaa + , module Data.List + , pattern Bar + ) + where + +import Data.List +-- A comment in the middle +import {-# SOURCE #-} BootImport ( Foo(..) ) +import {-# SoURCE #-} safe qualified BootImport as BI +import qualified Data.Map as {- blah -} Foo.Map + +import Control.Monad ( ) +import Data.Word (Word8) +import Data.Tree hiding ( drawTree ) + +import qualified Data.Maybe as M hiding ( maybe , isJust ) + + +-- comment +foo = let x = 1 + y = 2 + in x + y + +bar = 3 +bbb x + | x == 1 = () + | otherwise = () + + +aaa [ ] _ = 0 +aaa x _unk = 1 + +aba () = 0 + +x `ccc` 1 = x + 1 +x `ccc` y = x + y + +x !@# y = x + y + +data Baz = Baz1 | Baz2 + +data Ba = Ba | Bb + +data Ca = Cc | Cd + +pattern Foo a <- RealFoo a +pattern Bar a <- RealBar a + +data Thing = RealFoo Thing | RealBar Int diff --git a/tests/examples/LetExpr2.hs b/tests/examples/LetExpr2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LetExpr2.hs @@ -0,0 +1,4 @@ +l z = + let + ll = 34 + in ll + z diff --git a/tests/examples/LetExprSemi.hs b/tests/examples/LetExprSemi.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LetExprSemi.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language DeriveFoldable #-} +{-# LANGUAGE Safe #-} +{-# options_ghc -w #-} + +-- | A simple let expression, to ensure the layout is detected +-- With some haddock in the top +{- And a normal + multiline comment too -} + module {- brah -} LetExprSemi ( foo -- foo does .. + , bar -- bar does .. + , Baz () -- baz does .. + , Ba ( ..),Ca(Cc,Cd) , + bbb , aaa + , module Data.List + , pattern Bar + ) + where +{ +import Data.List +-- A comment in the middle +; import {-# SOURCE #-} BootImport ( Foo(..) ) ; +import {-# SOURCE #-} safe qualified BootImport as BI +;;; import qualified Data.Map as {- blah -} Foo.Map; + +import Control.Monad ( ) ; +import Data.Word (Word8); +import Data.Tree hiding ( drawTree ) ; + + ; import qualified Data.Maybe as M hiding ( maybe , isJust ) +; + +-- comment +foo = let x = 1 + y = 2 + in x + y +; +bar = 3; +bbb x + | x == 1 = () + | otherwise = () + +; +aaa [] _ = 0; +aaa x _unk = 1 +; +x `ccc` 1 = x + 1; +x `ccc` y = x + y +; +x !@# y = x + y +; +data Baz = Baz1 | Baz2 +; +data Ba = Ba | Bb +; +data Ca = Cc | Cd +; +pattern Foo a <- RealFoo a ; +pattern Bar a <- RealBar a +; +data Thing = RealFoo Thing | RealBar Int +} + + diff --git a/tests/examples/LetStmt.hs b/tests/examples/LetStmt.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LetStmt.hs @@ -0,0 +1,9 @@ +-- A simple let statement, to ensure the layout is detected + +module Layout.LetStmt where + +foo = do +{- ffo -}let x = 1 + y = 2 -- baz + x+y + diff --git a/tests/examples/ListComprehensions.hs b/tests/examples/ListComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ListComprehensions.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +-- MonadComprehensions, + +-- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html + +import GHC.Exts +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.List (sortBy) + +-- Let’s look at a simple, normal list comprehension to start: + +regularListComp :: [Int] +regularListComp = [ x + y * z + | x <- [0..10] + , y <- [10..20] + , z <- [20..30] + ] + +parallelListComp :: [Int] +parallelListComp = [ x + y * z + | x <- [0..10] + | y <- [10..20] + | z <- [20..30] + ] + +-- fibs :: [Int] +-- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + +fibs :: [Int] +fibs = 0 : 1 : [ x + y + | x <- fibs + | y <- tail fibs + ] + +fiblikes :: [Int] +fiblikes = 0 : 1 : [ x + y + z + | x <- fibs + | y <- tail fibs + | z <- tail (tail fibs) + ] + +-- TransformListComp +data Character = Character + { firstName :: String + , lastName :: String + , birthYear :: Int + } deriving (Show, Eq) + +friends :: [Character] +friends = [ Character "Phoebe" "Buffay" 1963 + , Character "Chandler" "Bing" 1969 + , Character "Rachel" "Green" 1969 + , Character "Joey" "Tribbiani" 1967 + , Character "Monica" "Geller" 1964 + , Character "Ross" "Geller" 1966 + ] + +oldest :: Int -> [Character] -> [String] +oldest k tbl = [ firstName ++ " " ++ lastName + | Character{..} <- tbl + , then sortWith by birthYear + , then take k + ] + +groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] +groupByLargest f = sortBy (comparing (negate . length)) . groupWith f + +bestBirthYears :: [Character] -> [(Int, [String])] +bestBirthYears tbl = [ (the birthYear, firstName) + | Character{..} <- tbl + , then group by birthYear using groupByLargest + ] + diff --git a/tests/examples/LocToName.hs b/tests/examples/LocToName.hs new file mode 100644 --- /dev/null +++ b/tests/examples/LocToName.hs @@ -0,0 +1,24 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +sumSquares (x:xs) = x ^2 + sumSquares xs + -- where sq x = x ^pow + -- pow = 2 + +sumSquares [] = 0 diff --git a/tests/examples/LocToName.hs.expected b/tests/examples/LocToName.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/LocToName.hs.expected @@ -0,0 +1,24 @@ +module LocToName where + +{- + + + + + + + + +-} + + + + + + + +LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs + -- where sq x = x ^pow + -- pow = 2 + +LocToName.newPoint [] = 0 diff --git a/tests/examples/Mixed.hs b/tests/examples/Mixed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Mixed.hs @@ -0,0 +1,48 @@ + +import Data.List () +import Data.List hiding () + +infixl 1 `f` +-- infixr 2 `\\\` +infix 3 :==> +infix 4 `MkFoo` + +data Foo = MkFoo Int | Float :==> Double + +x `f` y = x + +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) xs ys = xs + +g x = x + if True then 1 else 2 +h x = x + 1::Int + +{-# SPECIALISe j :: Int -> Int #-} +j n = n + 1 + +test = let k x y = x+y in 1 `k` 2 `k` 3 + +data Rec = (:<-:) { a :: Int, b :: Float } + +ng1 x y = negate y + +instance (Num a, Num b) => Num (a,b) + where + negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y + + + +class Foo1 a where + +class Foz a + +x = 2 where +y = 3 + +instance Foo1 Int where + +ff = ff where g = g where +type T = Int + + + diff --git a/tests/examples/MonadComprehensions.hs b/tests/examples/MonadComprehensions.hs new file mode 100644 --- /dev/null +++ b/tests/examples/MonadComprehensions.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ParallelListComp, + TransformListComp, + RecordWildCards #-} +{-# LANGUAGE MonadComprehensions #-} + +-- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html + +import GHC.Exts +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.List (sortBy) + + +-- Monad Comprehensions + +sqrts :: M.Map Int Int +sqrts = M.fromList $ [ (x, sx) + | x <- map (^2) [1..100] + | sx <- [1..100] + ] + +sumIntSqrts :: Int -> Int -> Maybe Int +sumIntSqrts a b = [ x + y + | x <- M.lookup a sqrts + , y <- M.lookup b sqrts + ] + +greet :: IO String +greet = [ name + | name <- getLine + , _ <- putStrLn $ unwords ["Hello, ", name, "!"] + ] + diff --git a/tests/examples/Move1.hs b/tests/examples/Move1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Move1.hs @@ -0,0 +1,53 @@ +module Move1 where + +data Located a = L Int a +type Name = String +hsBinds = undefined +divideDecls = undefined +definingDeclsNames = undefined +nub = undefined +definedPNs :: a -> [b] +definedPNs = undefined +logm = undefined +showGhc = undefined +pnsNeedRenaming = undefined +concatMap1 = undefined + +-- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath +-- -> Located Name +-- -> RefactGhc [a] +liftToTopLevel' :: Int -> Located Name -> IO [a] +liftToTopLevel' modName pn@(L _ n) = do + liftToMod + return [] + where + {-step1: divide the module's top level declaration list into three parts: + 'parent' is the top level declaration containing the lifted declaration, + 'before' and `after` are those declarations before and after 'parent'. + step2: get the declarations to be lifted from parent, bind it to liftedDecls + step3: remove the lifted declarations from parent and extra arguments may be introduce. + step4. test whether there are any names need to be renamed. + -} + liftToMod :: IO () + liftToMod = do + -- renamed <- getRefactRenamed + let renamed = undefined + let declsr = hsBinds renamed + let (before,parent,after) = divideDecls declsr pn + -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ + {- ++AZ++ : hsBinds does not return class or instance definitions + when (isClassDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" + when (isInstDecl $ ghead "liftToMod" parent) + $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" + -} + let liftedDecls = definingDeclsNames [n] parent True True + declaredPns = nub $ concatMap1 definedPNs liftedDecls + + -- TODO: what about declarations between this + -- one and the top level that are used in this one? + + logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) + -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns + -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns + return () diff --git a/tests/examples/MultiParamTypeClasses.hs b/tests/examples/MultiParamTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/MultiParamTypeClasses.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Foldable (forM_) +import Data.IORef + +class Store store m where + new :: a -> m (store a) + get :: store a -> m a + put :: store a -> a -> m () + +type Present = String +storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present]) +storePresents xs = do + store <- new [] + forM_ xs $ \x -> do + old <- get store + put store (x : old) + return store + +instance Store IORef IO where + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + +-- ex ps = do +-- store <- storePresents ps +-- get (store :: IORef [Present]) diff --git a/tests/examples/NullaryTypeClasses.hs b/tests/examples/NullaryTypeClasses.hs new file mode 100644 --- /dev/null +++ b/tests/examples/NullaryTypeClasses.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NullaryTypeClasses #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html + +class Logger where + logMessage :: String -> IO () + +type Present = String +queueNewChristmasPresents :: Logger => [Present] -> IO () +queueNewChristmasPresents presents = do + mapM (logMessage . ("Queueing present for delivery: " ++)) presents + return () + +instance Logger where + logMessage t = putStrLn ("[XMAS LOG]: " ++ t) + diff --git a/tests/examples/OverloadedStrings.hs b/tests/examples/OverloadedStrings.hs new file mode 100644 --- /dev/null +++ b/tests/examples/OverloadedStrings.hs @@ -0,0 +1,15 @@ +{-# Language OverloadedStrings #-} +-- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html + +import Data.String + +n :: Num a => a +n = 43 + +f :: Fractional a => a +f = 03.1420 + +-- foo :: Text +foo :: Data.String.IsString a => a +foo = "hello\n there" + diff --git a/tests/examples/PArr.hs b/tests/examples/PArr.hs new file mode 100644 --- /dev/null +++ b/tests/examples/PArr.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ParallelListComp #-} + +module PArr where + +blah xs ys = [ (x, y) | x <- xs | y <- ys ] + +-- bar = [: 1, 2 .. 3 :] + + +-- entry point for desugaring a parallel array comprehension + +-- parr = [:e | qss:] = <<[:e | qss:]>> () [:():] + +{- +ary = let arr1 = toP [1..10] + arr2 = toP [1..10] + f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :] + in f !: 1 +-} + + +foo = 'a' + diff --git a/tests/examples/ParensAroundContext.hs b/tests/examples/ParensAroundContext.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ParensAroundContext.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PartialTypeSignatures #-} +module ParensAroundContext where + +f :: ((Eq a, _)) => a -> a -> Bool +f x y = x == y diff --git a/tests/examples/PatBind.hs b/tests/examples/PatBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/PatBind.hs @@ -0,0 +1,34 @@ +module Layout.PatBind where + +a,b :: Int +a = 1 +b = 2 + +c :: Maybe (a -> b) +c = Nothing + +f :: (Num a1, Num a) => a -> a1 -> ( a, a1 ) +f x y = ( x+1, y-1 ) + +-- Chris done comment attachment problem +foo = x + where -- do stuff + doStuff = do stuff +x = 1 +stuff = 4 + + -- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + +blah = do { + ; print "a" + ; print "b" + } + + diff --git a/tests/examples/PatSynBind.hs b/tests/examples/PatSynBind.hs new file mode 100644 --- /dev/null +++ b/tests/examples/PatSynBind.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html + +import Foreign.C + +{- + +data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending + +toBlendMode :: BlendMode -> CInt +toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE} +-- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND} + +fromBlendMode :: CInt -> Maybe BlendMode +fromBlendMode 0 = Just NoBlending + +-} + +{- + +pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt + +setUpBlendMode :: CInt -> IO () +setUpBlendMode AlphaBlending = do + putStrLn "Enabling Alpha Blending" + activateAlphaBlendingForAllTextures + activateRenderAlphaBlending + +-} + +newtype BlendMode = MkBlendMode { unBlendMode :: CInt } + +pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE} +pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND} + +setUpBlendMode :: BlendMode -> IO () +setUpBlendMode AlphaBlending = do + putStrLn "Enabling Alpha Blending" + activateAlphaBlendingForAllTextures + activateRenderAlphaBlending + +data Renderer + +setRenderAlphaBlending :: Renderer -> IO () +setRenderAlphaBlending r = + sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending) + +activateAlphaBlendingForAllTextures = return () +activateRenderAlphaBlending = return () + +sdlSetRenderDrawBlendMode _ _ = return () + +-- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms + +data Date = Date { month :: Int, day :: Int } deriving Show + +-- Months +pattern January day = Date { month = 1, day = day } +pattern February day = Date { month = 2, day = day } +pattern March day = Date { month = 3, day = day } +-- elided +pattern December day = Date { month = 12, day = day } + +-- Holidays +pattern Christmas = Date { month = 12, day = 25 } + +describe :: Date -> String +describe (January 1) = "First day of year" +describe (February n) = show n ++ "th of February" +describe Christmas = "Presents!" +describe _ = "meh" + +pattern Christmas2 = December 25 + +pattern BeforeChristmas <- December (compare 25 -> GT) +pattern Christmas3 <- December (compare 25 -> EQ) +pattern AfterChristmas <- December (compare 25 -> LT) + +react :: Date -> String +react BeforeChristmas = "Waiting :(" +react Christmas = "Presents!" +react AfterChristmas = "Have to wait a whole year :(" +react _ = "It's not even December..." + +isItNow :: Int -> (Ordering, Int) +isItNow day = (compare 25 day, day) + +pattern BeforeChristmas4 day <- December (isItNow -> (GT, day)) +pattern Christmas4 <- December (isItNow -> (EQ, _)) +pattern AfterChristmas4 day <- December (isItNow -> (LT, day)) + +days'tilChristmas :: Date -> Int +days'tilChristmas (BeforeChristmas4 n) = 25 - n +days'tilChristmas Christmas4 = 0 +days'tilChristmas (AfterChristmas4 n) = 365 + 25 - n diff --git a/tests/examples/QuasiQuote.hs b/tests/examples/QuasiQuote.hs new file mode 100644 --- /dev/null +++ b/tests/examples/QuasiQuote.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} +module QuasiQuote where + +import T7918A + +ex1 = [qq|e1|] +ex2 = [qq|e2|] +ex3 = [qq|e3|] +ex4 = [qq|e4|] + +tx1 = undefined :: [qq|t1|] +tx2 = undefined :: [qq|t2|] +tx3 = undefined :: [qq|t3|] +tx4 = undefined :: [qq|t4|] + +px1 [qq|p1|] = undefined +px2 [qq|p2|] = undefined +px3 [qq|p3|] = undefined +px4 [qq|p4|] = undefined diff --git a/tests/examples/RankNTypes.hs b/tests/examples/RankNTypes.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RankNTypes.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html + +import System.Random +import Control.Monad.State +import Data.Char + + +id' :: forall a. a -> a +id' x = x + +f = print (id' (3 :: Integer), + id' "blah") + +-- rank 2 polymorphism +type IdFunc = forall a. a -> a + +id'' :: IdFunc +id'' x = x + +someInt :: IdFunc -> Integer +someInt id' = id' 3 + +-- rank 3 polymorphism +type SomeInt = IdFunc -> Integer + +someOtherInt :: SomeInt -> Integer +someOtherInt someInt' = + someInt' id + someInt' id + +-- random numbers + +data Player = + Player { + playerName :: String, + playerPos :: (Double, Double) + } + deriving (Eq, Ord, Show) + + +{- +randomPlayer + :: (MonadIO m, MonadState g m, RandomGen g) + => m Player +-} + +type GenAction m = forall a. (Random a) => m a + +type GenActionR m = forall a. (Random a) => (a, a) -> m a + +-- genRandom :: (RandomGen g) => GenAction (State g) +-- genRandom = state random + +genRandomR :: (RandomGen g) => GenActionR (State g) +genRandomR range = state (randomR range) + +genRandom :: (Random a, RandomGen g) => State g a +genRandom = state random + + +randomPlayer :: (MonadIO m) => GenActionR m -> m Player +randomPlayer genR = do + liftIO (putStrLn "Generating random player...") + + len <- genR (8, 12) + name <- replicateM len (genR ('a', 'z')) + x <- genR (-100, 100) + y <- genR (-100, 100) + + liftIO (putStrLn "Done.") + return (Player name (x, y)) + +main :: IO () +main = randomPlayer randomRIO >>= print + +-- scott encoding + +data List a + = Cons a (List a) + | Nil + +uncons :: (a -> List a -> r) -> r -> List a -> r +uncons co ni (Cons x xs) = co x xs +uncons co ni Nil = ni + +listNull :: List a -> Bool +listNull = uncons (\_ _ -> False) True + +listMap :: (a -> b) -> List a -> List b +listMap f = + uncons (\x xs -> Cons (f x) (listMap f xs)) + Nil + +newtype ListS a = + ListS { + unconsS :: forall r. (a -> ListS a -> r) -> r -> r + } + +nilS :: ListS a +nilS = ListS (\co ni -> ni) + +consS :: a -> ListS a -> ListS a +consS x xs = ListS (\co ni -> co x xs) + +unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r +unconsS' co ni (ListS f) = f co ni + +instance Functor ListS where + fmap f = + unconsS' (\x xs -> consS (f x) (fmap f xs)) + nilS + +-- Church Encoding +newtype ListC a = + ListC { + foldC :: forall r. (a -> r -> r) -> r -> r + } + +foldC' :: (a -> r -> r) -> r -> ListC a -> r +foldC' co ni (ListC f) = f co ni + +instance Functor ListC where + fmap f = foldC' (\x xs -> consC (f x) xs) nilC + +consC = undefined +nilC = undefined + +-- GADTs and continuation passing style +data Some :: * -> * where + SomeInt :: Int -> Some Int + SomeChar :: Char -> Some Char + Anything :: a -> Some a + + +unSome :: Some a -> a +unSome (SomeInt x) = x + 3 +unSome (SomeChar c) = toLower c +unSome (Anything x) = x + + +newtype SomeC a = + SomeC { + runSomeC :: + forall r. + ((a ~ Int) => Int -> r) -> + ((a ~ Char) => Char -> r) -> + (a -> r) -> + r + } + +-- dependent types + +idk :: forall (a :: *). a -> a +idk x = x + diff --git a/tests/examples/RdrNames.hs b/tests/examples/RdrNames.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RdrNames.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE TypeFamilies #-} +module RdrNames where + +import Data.Monoid + +-- --------------------------------------------------------------------- + +-- | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) +-- [mj AnnType $1,mj AnnVal $2] } + +-- Tested in DataFamilies.hs + +-- --------------------------------------------------------------------- + +-- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +ff = (RdrNames.:::) 0 1 + + +-- --------------------------------------------------------------------- + +-- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +data FF = ( ::: ) Int Int + +-- --------------------------------------------------------------------- + +-- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +data GG = GG Int Int +gg = 0 ` GG ` 1 + +-- --------------------------------------------------------------------- + +-- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vv = "a" ` mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } +vvq = "a" ` Data.Monoid.mappend ` "b" + +-- --------------------------------------------------------------------- + +-- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) +-- [mo $1,mc $2] } +-- Tested in Vect.hs + +-- --------------------------------------------------------------------- + +-- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +ng :: (, , ,) Int Int Int Int +ng = undefined + +-- --------------------------------------------------------------------- + +-- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple +-- (snd $2 + 1))) +-- (mo $1:mc $3:(mcommas (fst $2))) } +-- Tested in Unboxed.hs + +-- --------------------------------------------------------------------- + +-- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) +-- [mo $1,mj AnnRarrow $2,mc $3] } + +ft :: (->) a b +ft = undefined + +type family F a :: * -> * -> * +type instance F Int = (->) +type instance F Char = ( , ) + +-- --------------------------------------------------------------------- + +-- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } +lt :: [] a +lt = undefined + +-- --------------------------------------------------------------------- + +-- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } + +-- GHC source indicates this constuctor is only available in PrelPArr +-- ltp :: [::] a +-- ltp = undefined + +-- --------------------------------------------------------------------- + +-- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) +-- [mo $1,mj AnnTildehsh $2,mc $3] } + +-- primitive type? +-- Refl Int :: ~# * Int Int +-- Refl Maybe :: ~# (* -> *) Maybe Maybe + + +-- --------------------------------------------------------------------- + +-- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) +-- [mo $1,mj AnnVal $2,mc $3] } +-- TBD + +-- --------------------------------------------------------------------- + +-- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) +-- [mo $1,mj AnnTilde $2,mc $3] } + +-- --------------------------------------------------------------------- + +-- tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) +-- [mj AnnBackquote $1,mj AnnVal $2 +-- ,mj AnnBackquote $3] } + +-- --------------------------------------------------------------------- + + + diff --git a/tests/examples/RebindableSyntax.hs b/tests/examples/RebindableSyntax.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RebindableSyntax.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-} + +-- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html + +import Prelude hiding ((>>), (>>=), return) +import Data.Monoid +import Control.Monad ((<=<)) +import Data.Map as M + +addNumbers = do + 80 + 60 + 10 + where (>>) = (+) + return = return + +(>>) = mappend +return = mempty + +-- We can perform the same computation as above using the Sum wrapper: + +someSum :: Sum Int +someSum = do + Sum 80 + Sum 60 + Sum 10 + return + +someProduct :: Product Int +someProduct = do + Product 10 + Product 30 + +-- Why not try something non-numeric? + +tummyMuscle :: String +tummyMuscle = do + "a" + "b" + + +ff = let + (>>) = flip (.) + return = id + + arithmetic = do + (+1) + (*100) + (/300) + return + + -- Here, the input is numeric and all functions operate on a number. + -- What if we want to take a list and output a string? No problem: + + check = do + sum + sqrt + floor + show + in 4 diff --git a/tests/examples/RecordUpdate.hs b/tests/examples/RecordUpdate.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RecordUpdate.hs @@ -0,0 +1,6 @@ + +data Foo = F { f1 :: Int, f2 :: String } + +foo :: Int -> Foo -> Foo +foo v f = f { f1 = v } + diff --git a/tests/examples/RecursiveDo.hs b/tests/examples/RecursiveDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RecursiveDo.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE RecursiveDo #-} +-- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html + +import Control.Monad.Fix + +data RoseTree a = RoseTree a [RoseTree a] + deriving (Show) + +exampleTree :: RoseTree Int +exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []] + +pureMax :: Ord a => RoseTree a -> RoseTree (a, a) +pureMax tree = + let (t, largest) = go largest tree + in t + where + go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a) + go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x) + go biggest (RoseTree x xs) = + let sub = map (go biggest) xs + (xs', largests) = unzip sub + in (RoseTree (x, biggest) xs', max x (maximum largests)) + +t = pureMax exampleTree + +-- --------------------------------------------------------------------- + +impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b)) +impureMin f tree = do + rec (t, largest) <- go largest tree + return t + where + go smallest (RoseTree x []) = do + b <- f x + return (RoseTree (x, smallest) [], b) + + go smallest (RoseTree x xs) = do + sub <- mapM (go smallest) xs + b <- f x + let (xs', bs) = unzip sub + return (RoseTree (x, smallest) xs', min b (minimum bs)) + +budget :: String -> IO Int +budget "Ada" = return 10 -- A struggling startup programmer +budget "Curry" = return 50 -- A big-earner in finance +budget "Dijkstra" = return 20 -- Teaching is the real reward +budget "Howard" = return 5 -- An frugile undergraduate! + +inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" [] + , RoseTree "Curry" [ RoseTree "Howard" []] + ] + +ti = impureMin budget inviteTree + diff --git a/tests/examples/Rename1.hs b/tests/examples/Rename1.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Rename1.hs @@ -0,0 +1,6 @@ + + +foo x y = + do c <- getChar + return c + diff --git a/tests/examples/Rename1.hs.expected b/tests/examples/Rename1.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/Rename1.hs.expected @@ -0,0 +1,6 @@ + + +bar2 x y = + do c <- getChar + return c + diff --git a/tests/examples/Roles.hs b/tests/examples/Roles.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Roles.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RoleAnnotations, PolyKinds #-} + +module Roles where + +data T1 a = K1 a +data T2 a = K2 a +data T3 (a :: k) = K3 +data T4 (a :: * -> *) b = K4 (a b) + +data T5 a = K5 a +data T6 a = K6 +data T7 a b = K7 b + +type role T1 nominal +type role T2 representational +type role T3 phantom +type role T4 nominal _ +type role T5 _ diff --git a/tests/examples/Rules.hs b/tests/examples/Rules.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Rules.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +module Rules where + +import Data.Char + +{-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} + +{-# NOINLINE map' #-} +map' f [] = [] +map' f (x:xs) = f x : map' f xs + +main = print (map' toUpper "Hello, World") + +-- Should warn +foo1 x = x +{-# RULES "foo1" [ 1] forall x. foo1 x = x #-} + +-- Should warn +foo2 x = x +{-# INLINE foo2 #-} +{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-} + +-- Should not warn +foo3 x = x +{-# NOINLINE foo3 #-} +{-# RULES "foo3" forall x. foo3 x = x #-} + +{-# NOINLINE f #-} +f :: Int -> String +f x = "NOT FIRED" + +{-# NOINLINE neg #-} +neg :: Int -> Int +neg = negate + +{-# RULES + "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" + #-} + + diff --git a/tests/examples/ScopedTypeVariables.hs b/tests/examples/ScopedTypeVariables.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ScopedTypeVariables.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html + +import qualified Data.Map as Map + +insertMany :: forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v +insertMany f vs m = foldr f1 m vs + where + f1 :: (k, v) -> Map.Map k v -> Map.Map k v + f1 (k,v) m = Map.insertWith f k v m diff --git a/tests/examples/Sigs.hs b/tests/examples/Sigs.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Sigs.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Sigs where + +-- TypeSig +f :: Num a => a -> a +f = undefined + +pattern Single :: () => (Show a) => a -> [a] +pattern Single x = [x] + +g :: (Show a) => [a] -> a +g (Single x) = x + +-- Fixities + +infixr 6 +++ +infixr 7 ***,/// + +(+++) :: Int -> Int -> Int +a +++ b = a + 2*b + +(***) :: Int -> Int -> Int +a *** b = a - 4*b + +(///) :: Int -> Int -> Int +a /// b = 2*a - 3*b + +-- Inline signatures + +{-# Inline g #-} +{-# INLINE [~34] f #-} + +-- Specialise signature + +-- Multiple sigs +x,y,z :: Int +x = 0 +y = 0 +z = 0 diff --git a/tests/examples/Simple.hs b/tests/examples/Simple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Simple.hs @@ -0,0 +1,6 @@ +-- A simple let statement, to ensure the layout is detected + +-- module Layout.Simple where + +x = 1 + diff --git a/tests/examples/Splice.hs b/tests/examples/Splice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Splice.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, + MultiParamTypeClasses, TypeSynonymInstances #-} + +module Splice where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH + +foo $( return $ VarP $ mkName "x" ) = x +bar $( [p| x |] ) = x + +baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |] + + +class Eq a => MyClass a +data Foo = Foo deriving Eq + +instance MyClass Foo + +data Bar = Bar + deriving Eq + +type Baz = Bar +instance MyClass Baz + +data Quux a = Quux a deriving Eq +data Quux2 a = Quux2 a deriving Eq +instance Eq a => MyClass (Quux a) +instance Ord a => MyClass (Quux2 a) + +class MyClass2 a b +instance MyClass2 Int Bool + +$(return []) + +main = do + putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) + print $(isInstance ''Eq [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Foo] >>= lift) + print $ not $(isInstance ''Show [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one + print $(isInstance ''MyClass [ConT ''Baz] >>= lift) + print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one + print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one + print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) + print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift) + diff --git a/tests/examples/StaticPointers.hs b/tests/examples/StaticPointers.hs new file mode 100644 --- /dev/null +++ b/tests/examples/StaticPointers.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Main where + +import GHC.StaticPtr +import GHC.Word +import GHC.Generics +import Data.Data +import Data.Binary +import Data.ByteString + +fact :: Int -> Int +fact 0 = 1 +fact n = n * fact (n - 1) + +main = do + let sptr :: StaticPtr (Int -> Int) + sptr = static fact + print $ staticPtrInfo sptr + print $ deRefStaticPtr sptr 10 + +-- --------------------------------------------------------------------- + +type StaticKey1 = Fingerprint + +-- Defined in GHC.Fingerprint. +data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Generic, Typeable) + +staticKey :: StaticPtr a -> StaticKey1 +staticKey = undefined + + diff --git a/tests/examples/Stmts.hs b/tests/examples/Stmts.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Stmts.hs @@ -0,0 +1,22 @@ +module Stmts where + +-- Make sure we get all the semicolons in statements + +foo :: IO () +foo = do + do { ;;;; a } + a + +bar :: IO () +bar = do + { ; + a ;; + b + } + +baz :: IO () +baz = do { ;; s ; s ; ; s ;; } + +a = undefined +b = undefined +s = undefined diff --git a/tests/examples/Stream.hs b/tests/examples/Stream.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Stream.hs @@ -0,0 +1,156 @@ +module Stream (Stream, carry, addStream, rationalToStream, + streamToFloat, addFiniteStream, negate', average) where + +import Data.Ratio + + +type Digit = Integer +type Stream = [Integer] + + + +-- Convert from a Rational fraction to its stream representation +rationalToStream :: Rational -> Stream +rationalToStream x + |t<1 = 0:rationalToStream t + |otherwise = 1:rationalToStream (t-1) + where t = 2*x + + + + +-- Convert from a stream to the Float value +streamToFloat :: Stream -> Float +streamToFloat x = f x (1) + +f :: Stream -> Integer -> Float +f [] n = 0 +f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1) + + + + + +-- Add two stream +addStream :: Stream -> Stream -> Stream +addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys)) + where u = interim x1 x2 y1 y2 + c = carry x2 x3 y2 y3 + + + +-- Compute carry, the C(i) value, given x(i) and y(i) +carry :: Digit -> Digit -> Digit -> Digit -> Digit +carry x1 x2 y1 y2 + |t>1 = 1 + |t<(-1) = -1 + |t==1 && (minus1 x2 y2) = 0 + |t==1 && not (minus1 x2 y2) = 1 + |t==(-1) && (minus1 x2 y2) = -1 + |t==(-1) && not (minus1 x2 y2) = 0 + |t==0 = 0 + where t = x1+y1 + + + +-- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i) +interim :: Digit -> Digit -> Digit -> Digit -> Digit +interim x1 x2 y1 y2 + |t>1 = 0 + |t<(-1) = 0 + |t==1 && (minus1 x2 y2) = 1 + |t==1 && not (minus1 x2 y2) = -1 + |t==(-1) && (minus1 x2 y2) = 1 + |t==(-1) && not (minus1 x2 y2) = -1 + |t==0 = 0 + where t = x1+y1 + + + +-- Check if at least one of 2 digits is -1 +minus1 :: Digit -> Digit -> Bool +minus1 x y = (x==(-1))|| (y==(-1)) + + + + + + +-- Algin two stream so that they have the same length +align :: Stream -> Stream -> (Stream, Stream) +align xs ys + |x>y = (xs, (copy 0 (x-y)) ++ys) + |otherwise = ((copy 0 (y-x)) ++ xs, ys) + where x = toInteger(length xs) + y = toInteger(length ys) + + + +-- Generate a list of x +copy :: Integer -> Integer -> [Integer] +copy x n = [x| i<- [1..n]] + + + + + + + +-- Add two finite stream (to add the integral part) +addFiniteStream :: Stream -> Stream -> Stream +addFiniteStream xs ys = add' u v + where (u,v) = align xs ys + + + +-- Utility function for addFinitieStream +add' :: Stream -> Stream -> Stream +add' u v = normalise (f u v) + where f [] [] = [] + f (x:xs) (y:ys) = (x+y):f xs ys + + +-- Normalise the sum +normalise :: Stream -> Stream +normalise = foldr f [0] + where f x (y:ys) = (u:v:ys) + where u = (x+y) `div` 2 + v = (x+y) `mod` 2 + + +-- Negate a stream +negate' :: Stream -> Stream +negate' = map (*(-1)) + + + +-- Compute average of two stream +-- Using [-2,-1,0,1,2] to add, and then divide by 2 +average :: Stream -> Stream -> Stream +average xs ys = div2 (add xs ys) + + +-- Addition of two streams, using [-2,-1,0,1,2] +add :: Stream -> Stream -> Stream +add (x:xs) (y:ys) = (x+y):(add xs ys) + + +-- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1] +div2 :: Stream -> Stream +div2 (2:xs) = 1:div2 xs +div2 ((-2):xs) = (-1):div2 xs +div2 (0:xs) = 0:div2 xs +div2 (1:(-2):xs) = div2 (0:0:xs) +div2 (1:(-1):xs) = div2 (0:1:xs) +div2 (1:0:xs) = div2 (0:2:xs) +div2 (1:1:xs) = div2 (2:(-1):xs) +div2 (1:2:xs) = div2 (2:0:xs) +div2 ((-1):(-2):xs) = div2 ((-2):0:xs) +div2 ((-1):(-1):xs) = div2 ((-2):1:xs) +div2 ((-1):0:xs) = div2 (0:(-2):xs) +div2 ((-1):1:xs) = div2 (0:(-1):xs) +div2 ((-1):2:xs) = div2 (0:0:xs) + + + +test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3))) diff --git a/tests/examples/StrictLet.hs b/tests/examples/StrictLet.hs new file mode 100644 --- /dev/null +++ b/tests/examples/StrictLet.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MagicHash #-} + +{- +If the (unboxed, hence strict) "let thunk =" would survive to the CallArity +stage, it might yield wrong results (eta-expanding thunk and hence "cond" would +be called multiple times). + +It does not actually happen (CallArity sees a "case"), so this test just +safe-guards against future changes here. +-} + +import Debug.Trace +import GHC.Exts +import System.Environment + +cond :: Int# -> Bool +cond x = trace ("cond called with " ++ show (I# x)) True +{-# NOINLINE cond #-} + + +bar (I# x) = + let go n = let x = thunk n + in case n of + 100# -> I# x + _ -> go (n +# 1#) + in go x + where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#) + + +main = do + args <- getArgs + bar (length args) `seq` return () diff --git a/tests/examples/T2388.hs b/tests/examples/T2388.hs new file mode 100644 --- /dev/null +++ b/tests/examples/T2388.hs @@ -0,0 +1,14 @@ +module T2388 where + +import Data.Bits +import Data.Word +import Data.Int + +test1 :: Word32 -> Char +test1 w | w .&. 0x80000000 /= 0 = 'a' +test1 _ = 'b' + +-- this should use a testq instruction on x86_64 +test2 :: Int64 -> Char +test2 w | w .&. (-3) /= 0 = 'a' +test2 _ = 'b' diff --git a/tests/examples/T3132.hs b/tests/examples/T3132.hs new file mode 100644 --- /dev/null +++ b/tests/examples/T3132.hs @@ -0,0 +1,6 @@ +module T3132 where + +import Data.Array.Unboxed + +step :: UArray Int Double -> [Double] +step y = [y!1 + y!0] diff --git a/tests/examples/T7918A.hs b/tests/examples/T7918A.hs new file mode 100644 --- /dev/null +++ b/tests/examples/T7918A.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +module T7918A where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +qq = QuasiQuoter { + quoteExp = \str -> case str of + "e1" -> [| True |] + "e2" -> [| id True |] + "e3" -> [| True || False |] + "e4" -> [| False |] + , quoteType = \str -> case str of + "t1" -> [t| Bool |] + "t2" -> [t| Maybe Bool |] + "t3" -> [t| Either Bool Int |] + "t4" -> [t| Int |] + , quotePat = let x = VarP (mkName "x") + y = VarP (mkName "y") + in \str -> case str of + "p1" -> return $ x + "p2" -> return $ ConP 'Just [x] + "p3" -> return $ TupP [x, y] + "p4" -> return $ y + , quoteDec = undefined + } diff --git a/tests/examples/TH.hs b/tests/examples/TH.hs new file mode 100644 --- /dev/null +++ b/tests/examples/TH.hs @@ -0,0 +1,71 @@ +{-# Language TemplateHaskell #-} + +-- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html + +import Language.Haskell.TH + +e1 :: IO Exp +e1 = runQ [| 1 + 2 |] + +e2 :: Integer +e2 = $( return (InfixE (Just (LitE (IntegerL 1))) + (VarE (mkName "+")) + (Just (LitE (IntegerL 2))) + ) + ) + +fibs :: [Integer] +fibs = 0 : 1 : zipWith (+) fibs (tail fibs) + +fibQ :: Int -> Q Exp +fibQ n = [| fibs !! n |] + +-- e3 gives stage restriction, need to import this module to get it +-- e3 = $(fibQ 22) + +e4 = $(runQ [| fibs !! $( [| 8 |]) |]) + +e5 :: IO Exp +e5 = runQ [| 1 + 2 |] + +e6 :: IO [Dec] +e6 = runQ [d|x = 5|] + +e7 :: IO Type +e7 = runQ [t|Int|] + +e8 :: IO Pat +e8 = runQ [p|(x,y)|] + +myExp :: Q Exp; myExp = runQ [| 1 + 2 |] + +e9 = runQ(myExp) >>= putStrLn.pprint + +-- --------------------------------------------------------------------- + +isPrime :: (Integral a) => a -> Bool +isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1]) + +nextPrime :: (Integral a) => a -> a +nextPrime n | isPrime n = n | otherwise = nextPrime (n+1) + +-- returns a list of all primes between n and m, using the nextPrime function +doPrime :: (Integral a) => a -> a -> [a] +doPrime n m + | curr > m = [] + | otherwise = curr:doPrime (curr+1) m + where curr = nextPrime n + +-- and our Q expression +primeQ :: Int -> Int -> Q Exp +primeQ n m = [| doPrime n m |] + +-- stage restriction on e10 +-- e10 = $(primeQ 0 67) + +-- --------------------------------------------------------------------- + +e11 = $(stringE . show =<< reify ''Bool) + +-- stage restriction e12 +-- e12 = $(stringE . show =<< reify 'primeQ) diff --git a/tests/examples/Trit.hs b/tests/examples/Trit.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Trit.hs @@ -0,0 +1,112 @@ +module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction', + neg, addTrits, subTrits, shiftLeft, shiftRight, multiply + ) where + +import Stream +import Utilities +import Data.Ratio + +type Mantissa = Stream +type Fraction = Stream +type Trit = (Mantissa, Fraction) + + +-- Convert from a Rational number to its Trit representation (Integral, Fraction) +rationalToTrit :: Rational -> Trit +rationalToTrit x + |x<1 = ([0], rationalToStream x) + |otherwise = (u', rationalToStream v) + where u = n `div` d + u' = toBinary u + v = x - (toRational u) + n = numerator x + d = denominator x + + +-- Get the integral part of Trit +getIntegral :: Trit -> Mantissa +getIntegral = fst + + + +-- Get the fraction part of Trit, with n digit of the stream +getFraction :: Int -> Trit -> Stream +getFraction n = take n. snd + + +-- Get the fraction part of Trit +getFraction' :: Trit -> Stream +getFraction' = snd + + + +-- Negate a Trit +neg :: Trit -> Trit +neg (a, b) = (negate' a, negate' b) + + + +-- Add two Trits +addTrits :: Trit -> Trit -> Trit +addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys)) + where u' = addFiniteStream m1 m2 + c = [carry x1 x2 y1 y2] + u = addFiniteStream u' c + + + +-- Substraction of 2 Trits +subTrits :: Trit -> Trit -> Trit +subTrits x y = addTrits x (neg y) + + + +-- Shift left = *2 opertaion with Trit +shiftLeft :: Trit -> Trit +shiftLeft (x, (y:ys)) = (x++ [y], ys) + + +-- Shift right = /2 operation with Trit +shiftRight :: Trit -> Integer -> Trit +shiftRight (x, xs) 1 = (init x, (u:xs)) + where u = last x +shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1) + where u = last x + + + +-- Multiply a Trit stream by 1,0 or -1, simply return the stream +mulOneDigit :: Integer -> Stream -> Stream +mulOneDigit x xs + |x==1 = xs + |x==0 = zero' + |otherwise = negate' xs + where zero' = (0:zero') + + + + + + +-- Multiplication of two streams +multiply :: Stream -> Stream -> Stream +multiply (a0:a1:x) (b0:b1:y) = average p q + where p = average (a1*b0: (average (mulOneDigit b1 x) + (mulOneDigit a1 y))) + (average (mulOneDigit b0 x) + (mulOneDigit a0 y)) + q = (a0*b0:a0*b1:a1*b1:(multiply x y)) + + + + +start0 = take 30 (multiply (rationalToStream (1%2)) zo) + +zo :: Stream +zo = 1:(-1):zero + where zero = 0:zero + +start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4)))) + + + diff --git a/tests/examples/Tuple.hs b/tests/examples/Tuple.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Tuple.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TupleSections #-} + +baz = (1, "hello", 6.5,,) 'a' (Just ()) + diff --git a/tests/examples/TypeFamilies.hs b/tests/examples/TypeFamilies.hs new file mode 100644 --- /dev/null +++ b/tests/examples/TypeFamilies.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html + +import Control.Concurrent.STM +import Control.Concurrent.MVar +import Data.Foldable (forM_) +import Data.IORef + +class IOStore store where + newIO :: a -> IO (store a) + getIO :: store a -> IO a + putIO :: store a -> a -> IO () + +instance IOStore MVar where + newIO = newMVar + getIO = readMVar + putIO mvar a = modifyMVar_ mvar (return . const a) + +instance IOStore IORef where + newIO = newIORef + getIO = readIORef + putIO ioref a = modifyIORef ioref (const a) + +type Present = String +storePresentsIO :: IOStore store => [Present] -> IO (store [Present]) +storePresentsIO xs = do + store <- newIO [] + forM_ xs $ \x -> do + old <- getIO store + putIO store (x : old) + return store + +-- Type family version + +class Store store where + type StoreMonad store :: * -> * + new :: a -> (StoreMonad store) (store a) + get :: store a -> (StoreMonad store) a + put :: store a -> a -> (StoreMonad store) () + +instance Store IORef where + type StoreMonad IORef = IO + new = newIORef + get = readIORef + put ioref a = modifyIORef ioref (const a) + +instance Store TVar where + type StoreMonad TVar = STM + new = newTVar + get = readTVar + put ioref a = modifyTVar ioref (const a) + +storePresents :: (Store store, Monad (StoreMonad store)) + => [Present] -> (StoreMonad store) (store [Present]) +storePresents xs = do + store <- new [] + forM_ xs $ \x -> do + old <- get store + put store (x : old) + return store + diff --git a/tests/examples/TypeOperators.hs b/tests/examples/TypeOperators.hs new file mode 100644 --- /dev/null +++ b/tests/examples/TypeOperators.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +-- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html + +import Data.String + +data I a = I { unI :: a } +data Var a x = Var { unK :: a } + +infixr 8 + +data ((f + g)) a = InL (f a) | InR (g a) +-- data (f + g) a = InL (f a) | InR (g a) + +class sub :<: sup where + inj :: sub a -> sup a + +instance (sym :<: sym) where + inj = id + +instance (sym1 :<: (sym1 + sym2)) where inj = InL + +instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where + inj = InR . inj + +instance (I :<: g, IsString s) => IsString ((f + g) s) where + fromString = inj . I . fromString + +var :: (Var a :<: f) => a -> f e +var = inj . Var + +elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b +elim eval f = + case f of + InL (Var xs) -> inj (I (eval xs)) + InR g -> g + +-------------------------------------------------------------------------------- + +data UserVar = UserName + +data ChristmasVar = ChristmasPresent + +email :: [(Var UserVar + Var ChristmasVar + I) String] +email = [ "Dear " + , var UserName + , ", thank you for your recent email to Santa & Santa Inc." + , "You have asked for a: " + , var ChristmasPresent + ] + +main :: IO () +main = + do name <- getLine + present <- getLine + putStrLn (concatMap (unI . + (elim (\ChristmasPresent -> present) . + elim (\UserName -> name))) + email) + +{- + +*Main> main +Ollie +Lambda Necklace +Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace + +-} diff --git a/tests/examples/Unboxed.hs b/tests/examples/Unboxed.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Unboxed.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE UnboxedTuples #-} +module Layout.Unboxed where + +a,b :: Int +a = 1 +b = 2 + +c :: Maybe (a -> b) +c = Nothing + +f :: (Num a1, Num a) => a -> a1 -> (# a, a1 #) +f x y = (# x+1, y-1 #) + +f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1 +f1 x y = (# , #) x+1 y-1 + +g :: Num a => a -> a +g x = case f x x of { (# a, b #) -> a + b } + + + -- Pattern bind +tup :: (Int, Int) +h :: Int +t :: Int +tup@(h,t) = head $ zip [1..10] [3..ff] + where + ff :: Int + ff = 15 + + diff --git a/tests/examples/Utilities.hs b/tests/examples/Utilities.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Utilities.hs @@ -0,0 +1,17 @@ +module Utilities (toBinary, fl) where + +import Stream +import Data.Ratio + +-- Convert from an Integer to its signed-digit representation +toBinary :: Integer -> Stream +toBinary 0 = [0] +toBinary x = toBinary t ++ [x `mod` 2] + where t = x `div` 2 + + + +fl :: Stream -> Stream +fl (x:xs) = (f x):xs + where f 0 = 1 + f 1 = 0 diff --git a/tests/examples/Utils2.hs b/tests/examples/Utils2.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Utils2.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +module Utils2 where + + +import Control.Applicative (Applicative(..)) +import Control.Monad (when, liftM, ap) +import Control.Exception +import Data.Data +import Data.List +import Data.Maybe +import Data.Monoid + +-- import Language.Haskell.GHC.ExactPrint.Utils +import Language.Haskell.GHC.ExactPrint.Types + +import qualified Bag as GHC +import qualified BasicTypes as GHC +import qualified BooleanFormula as GHC +import qualified Class as GHC +import qualified CoAxiom as GHC +import qualified DynFlags as GHC +import qualified FastString as GHC +import qualified ForeignCall as GHC +import qualified GHC as GHC +import qualified GHC.Paths as GHC +import qualified Lexer as GHC +import qualified Name as GHC +import qualified NameSet as GHC +import qualified Outputable as GHC +import qualified RdrName as GHC +import qualified SrcLoc as GHC +import qualified StringBuffer as GHC +import qualified UniqSet as GHC +import qualified Unique as GHC +import qualified Var as GHC + +import qualified Data.Map as Map + +-- --------------------------------------------------------------------- + +instance AnnotateP GHC.RdrName where + annotateP l n = do + case rdrName2String n of + "[]" -> do + addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG + addDeltaAnnotation GHC.AnnCloseS -- ']' BUG + "()" -> do + addDeltaAnnotation GHC.AnnOpenP -- '(' + addDeltaAnnotation GHC.AnnCloseP -- ')' + "(##)" -> do + addDeltaAnnotation GHC.AnnOpen -- '(#' + addDeltaAnnotation GHC.AnnClose -- '#)' + "[::]" -> do + addDeltaAnnotation GHC.AnnOpen -- '[:' + addDeltaAnnotation GHC.AnnClose -- ':]' + _ -> do + addDeltaAnnotation GHC.AnnType + addDeltaAnnotation GHC.AnnOpenP -- '(' + addDeltaAnnotationLs GHC.AnnBackquote 0 + addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)' + cnt <- countAnnsAP GHC.AnnVal + cntT <- countAnnsAP GHC.AnnCommaTuple + cntR <- countAnnsAP GHC.AnnRarrow + case cnt of + 0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal + 1 -> addDeltaAnnotation GHC.AnnVal + x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x) + addDeltaAnnotation GHC.AnnTildehsh + addDeltaAnnotation GHC.AnnTilde + addDeltaAnnotation GHC.AnnRarrow + addDeltaAnnotationLs GHC.AnnBackquote 1 + addDeltaAnnotation GHC.AnnCloseP -- ')' + + -- temporary, for test +class (Typeable ast) => AnnotateP ast where + annotateP :: GHC.SrcSpan -> ast -> IO () + +addDeltaAnnotation = undefined +addDeltaAnnotations = undefined +addDeltaAnnotationLs = undefined +addDeltaAnnotationExt = undefined +countAnnsAP = undefined +showGhc = undefined +rdrName2String = undefined + diff --git a/tests/examples/Vect.hs b/tests/examples/Vect.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Vect.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ParallelArrays #-} +{-# OPTIONS_GHC -fvectorise #-} +{-# LANGUAGE UnboxedTuples #-} + +module Vect where + +-- import Data.Array.Parallel + + +{-# VECTORISe isFive = blah #-} +{-# NoVECTORISE isEq #-} + +{-# VECTORISE SCALAR type Int #-} +{-# VECTORISE type Char #-} +{-# VECTORISE type ( ) #-} +{-# VECTORISE type (# #) #-} + +{-# VECTORISE SCALAR type Integer = Int #-} +{-# VECTORISE type Bool = String #-} + +{-# Vectorise class Eq #-} + +blah = 5 + +data MyBool = MyTrue | MyFalse + +class Eq a => Cmp a where + cmp :: a -> a -> Bool + +-- FIXME: +-- instance Cmp Int where +-- cmp = (==) +-- isFive :: (Eq a, Num a) => a -> Bool +isFive :: Int -> Bool +isFive x = x == 5 + +isEq :: Eq a => a -> Bool +isEq x = x == x + + +fiveEq :: Int -> Bool +fiveEq x = isFive x && isEq x + +cmpArrs :: PArray Int -> PArray Int -> Bool +{-# NOINLINE cmpArrs #-} +cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w) + +cmpArrs' :: [:Int:] -> [:Int:] -> Bool +cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:] + +isFives :: PArray Int -> Bool +{-# NOINLINE isFives #-} +isFives xs = isFives' (fromPArrayP xs) + +isFives' :: [:Int:] -> Bool +isFives' xs = andP (mapP isFive xs) + +isEqs :: PArray Int -> Bool +{-# NOINLINE isEqs #-} +isEqs xs = isEqs' (fromPArrayP xs) + +isEqs' :: [:Int:] -> Bool +isEqs' xs = undefined -- andP (mapP isEq xs) + +-- fudge for compiler + +fromPArrayP = undefined +andP = undefined +mapP = undefined +data PArray a = PArray a diff --git a/tests/examples/ViewPatterns.hs b/tests/examples/ViewPatterns.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ViewPatterns.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ViewPatterns #-} + +-- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns +import Prelude hiding (length) + +data JList a = Empty + | Single a + | Join (JList a) (JList a) + +data JListView a = Nil + | Cons a (JList a) + + +view :: JList a -> JListView a +view Empty = Nil +view (Single a) = Cons a Empty +view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y +view (Join (view -> Nil) y) = view y + +length :: JList a -> Integer +length (view -> Nil) = 0 +length (view -> Cons x xs) = 1 + length xs + diff --git a/tests/examples/Warning.hs b/tests/examples/Warning.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Warning.hs @@ -0,0 +1,16 @@ + +module Warning +{-# WARNINg ["This is a module warning", + "multi-line"] #-} + where + +{-# Warning foo , bar + ["This is a multi-line", + "deprecation message", + "for foo"] #-} +foo :: Int +foo = 4 + +bar :: Char +bar = 'c' + diff --git a/tests/examples/WhereIn4.hs b/tests/examples/WhereIn4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/WhereIn4.hs @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/tests/examples/WhereIn4.hs.expected b/tests/examples/WhereIn4.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/WhereIn4.hs.expected @@ -0,0 +1,19 @@ +module WhereIn4 where + +--A definition can be demoted to the local 'where' binding of a friend declaration, +--if it is only used by this friend declaration. + +--Demoting a definition narrows down the scope of the definition. +--In this example, demote the top level 'sq' to 'sumSquares' +--In this case (there is single matches), if possible, +--the parameters will be folded after demoting and type sigature will be removed. + +sumSquares x y = sq p x + sq p y + where p_2=2 {-There is a comment-} + +sq::Int->Int->Int +sq pow z = z^pow --there is a comment + +anotherFun 0 y = sq y + where sq x = x^2 + diff --git a/tests/examples/Zipper.hs b/tests/examples/Zipper.hs new file mode 100644 --- /dev/null +++ b/tests/examples/Zipper.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Generics.Zipper +-- Copyright : (c) Michael D. Adams, 2010 +-- License : BSD-style (see the LICENSE file) +-- +-- ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types. +-- Michael D. Adams. WGP '10: Proceedings of the 2010 ACM SIGPLAN +-- workshop on Generic programming, 2010.'' +-- +-- See +-- +----------------------------------------------------------------------------- + +{-# OPTIONS -Wall #-} +{-# LANGUAGE Rank2Types, GADTs #-} + +module Zipper where + +import Data.Generics +import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM) +import Data.Maybe (fromJust) + +-- Core types + +-- | A generic zipper with a root object of type @root@. +data Zipper root = + forall hole. (Data hole) => + Zipper hole (Context hole root) + +---- Internal types and functions +data Context hole root where + CtxtNull :: Context a a + CtxtCons :: + forall hole root rights parent. (Data parent) => + Left (hole -> rights) + -> Right rights parent + -> Context parent root + -> Context hole root + +combine :: Left (hole -> rights) + -> hole + -> Right rights parent + -> parent +combine lefts hole rights = + fromRight ((fromLeft lefts) hole) rights + +data Left expects + = LeftUnit expects + | forall b. (Data b) => LeftCons (Left (b -> expects)) b + +toLeft :: (Data a) => a -> Left a +toLeft a = gfoldl LeftCons LeftUnit a + +fromLeft :: Left r -> r +fromLeft (LeftUnit a) = a +fromLeft (LeftCons f b) = fromLeft f b + +data Right provides parent where + RightNull :: Right parent parent + RightCons :: + (Data b) => b -> Right a t -> Right (b -> a) t + +fromRight :: r -> Right r parent -> parent +fromRight f (RightNull) = f +fromRight f (RightCons b r) = fromRight (f b) r + +-- | Apply a generic monadic transformation to the hole +transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a) +transM f (Zipper hole ctxt) = do + hole' <- f hole + return (Zipper hole' ctxt) + +-- Generic zipper traversals +---- Traversal helpers +-- | A movement operation such as 'left', 'right', 'up', or 'down'. +type Move a = Zipper a -> Maybe (Zipper a) + +-- | Apply a generic query using the specified movement operation. +moveQ :: Move a -- ^ Move operation + -> b -- ^ Default if can't move + -> (Zipper a -> b) -- ^ Query if can move + -> Zipper a -- ^ Zipper + -> b +moveQ move b f z = case move z of + Nothing -> b + Just z' -> f z' + +-- | Repeatedly apply a monadic 'Maybe' generic transformation at the +-- top-most, left-most position that the transformation returns +-- 'Just'. Behaves like iteratively applying 'zsomewhere' but is +-- more efficient because it re-evaluates the transformation +-- at only the parents of the last successful application. +zreduce :: GenericM Maybe -> Zipper a -> Zipper a +zreduce f z = + case transM f z of + Nothing -> + downQ (g z) (zreduce f . leftmost) z where + g z' = rightQ (upQ z' g z') (zreduce f) z' + Just x -> zreduce f (reduceAncestors1 f x x) + +reduceAncestors1 :: + GenericM Maybe -> Zipper a -> Zipper a -> Zipper a +reduceAncestors1 f z def = upQ def g z where + g z' = reduceAncestors1 f z' def' where + def' = case transM f z' of + Nothing -> def + Just x -> reduceAncestors1 f x x + +------ Query +-- | Apply a generic query to the left sibling if one exists. +leftQ :: b -- ^ Value to return of no left sibling exists. + -> (Zipper a -> b) -> Zipper a -> b +leftQ b f z = moveQ left b f z + +-- | Apply a generic query to the right sibling if one exists. +rightQ :: b -- ^ Value to return if no right sibling exists. + -> (Zipper a -> b) -> Zipper a -> b +rightQ b f z = moveQ right b f z + +-- | Apply a generic query to the parent if it exists. +downQ :: b -- ^ Value to return if no children exist. + -> (Zipper a -> b) -> Zipper a -> b +downQ b f z = moveQ down b f z + +-- | Apply a generic query to the rightmost child if one exists. +upQ :: b -- ^ Value to return if parent does not exist. + -> (Zipper a -> b) -> Zipper a -> b +upQ b f z = moveQ up b f z + +---- Basic movement + +-- | Move left. Returns 'Nothing' iff already at leftmost sibling. +left :: Zipper a -> Maybe (Zipper a) +left (Zipper _ CtxtNull) = Nothing +left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing +left (Zipper h (CtxtCons (LeftCons l h') r c)) = + Just (Zipper h' (CtxtCons l (RightCons h r) c)) + +-- | Move right. Returns 'Nothing' iff already at rightmost sibling. +right :: Zipper a -> Maybe (Zipper a) +right (Zipper _ CtxtNull) = Nothing +right (Zipper _ (CtxtCons _ RightNull _)) = Nothing +right (Zipper h (CtxtCons l (RightCons h' r) c)) = + Just (Zipper h' (CtxtCons (LeftCons l h) r c)) + +-- | Move down. Moves to rightmost immediate child. Returns 'Nothing' iff at a leaf and thus no children exist. +down :: Zipper a -> Maybe (Zipper a) +down (Zipper hole ctxt) = + case toLeft hole of + LeftUnit _ -> Nothing + LeftCons l hole' -> + Just (Zipper hole' (CtxtCons l RightNull ctxt)) + +-- | Move up. Returns 'Nothing' iff already at root and thus no parent exists. +up :: Zipper a -> Maybe (Zipper a) +up (Zipper _ CtxtNull) = Nothing +up (Zipper hole (CtxtCons l r ctxt)) = + Just (Zipper (combine l hole r) ctxt) + +------ Movement +-- | Move to the leftmost sibling. +leftmost :: Zipper a -> Zipper a +leftmost z = leftQ z leftmost z +