ghc-exactprint 0.2 → 0.3
raw patch · 165 files changed
+12155/−3067 lines, 165 filesdep +Diffdep +filemanipdep +silentlydep −ghc-syb-utilsdep −stmdep ~basenew-component:exe:roundtripnew-component:exe:static
Dependencies added: Diff, filemanip, silently, temporary
Dependencies removed: ghc-syb-utils, stm
Dependency ranges changed: base
Files
- ChangeLog +18/−0
- ghc-exactprint.cabal +74/−21
- src/Language/Haskell/GHC/ExactPrint.hs +16/−1
- src/Language/Haskell/GHC/ExactPrint/Annotate.hs +2337/−1958
- src/Language/Haskell/GHC/ExactPrint/Delta.hs +389/−190
- src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs +19/−0
- src/Language/Haskell/GHC/ExactPrint/Lookup.hs +128/−77
- src/Language/Haskell/GHC/ExactPrint/Parsers.hs +192/−0
- src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +258/−0
- src/Language/Haskell/GHC/ExactPrint/Print.hs +218/−157
- src/Language/Haskell/GHC/ExactPrint/Transform.hs +736/−0
- src/Language/Haskell/GHC/ExactPrint/Types.hs +106/−95
- src/Language/Haskell/GHC/ExactPrint/Utils.hs +138/−47
- tests/Roundtrip.hs +137/−0
- tests/Static.hs +91/−0
- tests/Test.hs +407/−506
- tests/Test/Common.hs +188/−0
- tests/Test/Consistency.hs +27/−0
- tests/Test/Transform.hs +683/−0
- tests/examples/AddDecl.hs +9/−0
- tests/examples/AddDecl.hs.expected +11/−0
- tests/examples/AddLocalDecl1.hs +9/−0
- tests/examples/AddLocalDecl1.hs.expected +11/−0
- tests/examples/AddLocalDecl2.hs +10/−0
- tests/examples/AddLocalDecl2.hs.expected +11/−0
- tests/examples/AddLocalDecl3.hs +10/−0
- tests/examples/AddLocalDecl3.hs.expected +11/−0
- tests/examples/AnnPackageName.hs +4/−0
- tests/examples/AssociatedType.hs +5/−0
- tests/examples/Backquote.hs +11/−0
- tests/examples/BracesSemiDataDecl.hs +7/−0
- tests/examples/C.hs +12/−0
- tests/examples/C.hs.expected +12/−0
- tests/examples/CExpected.hs +12/−0
- tests/examples/Commands.hs +257/−0
- tests/examples/Control.hs +210/−0
- tests/examples/CorePragma.hs +6/−0
- tests/examples/Cpp.hs +8/−0
- tests/examples/Dead1.hs +1/−1
- tests/examples/DefaultTypeInstance.hs +6/−0
- tests/examples/Deprecation.hs +3/−1
- tests/examples/DoParens.hs +4/−0
- tests/examples/DoPatBind.hs +4/−0
- tests/examples/DoubleForall.hs +9/−0
- tests/examples/DroppedComma.hs +5/−0
- tests/examples/DroppedDoSpace.hs +26/−0
- tests/examples/DroppedDoSpace2.hs +6/−0
- tests/examples/ExplicitNamespaces.hs +9/−0
- tests/examples/Foo.hs +0/−7
- tests/examples/ForeignDecl.hs +22/−0
- tests/examples/GADTContext.hs +13/−0
- tests/examples/GADTRecords.hs +20/−0
- tests/examples/GADTRecords2.hs +7/−0
- tests/examples/GHCOrig.hs +211/−0
- tests/examples/Hang.hs +1/−0
- tests/examples/HangingRecord.hs +5/−0
- tests/examples/HashQQ.hs +44/−0
- tests/examples/ImplicitSemi.hs +4/−0
- tests/examples/ImplicitTypeSyn.hs +17/−0
- tests/examples/Imports.hs +9/−0
- tests/examples/IndentedDo.hs +12/−0
- tests/examples/InfixOperator.hs +26/−0
- tests/examples/InfixPatternSynonyms.hs +18/−0
- tests/examples/InlineSemi.hs +1/−0
- tests/examples/Internals.hs +427/−0
- tests/examples/Jon.hs +4/−0
- tests/examples/LambdaCase.hs +10/−0
- tests/examples/LetIn1.hs +19/−0
- tests/examples/LetIn1.hs.expected +18/−0
- tests/examples/LiftedConstructors.hs +25/−0
- tests/examples/LiftedInfixConstructor.hs +12/−0
- tests/examples/LinePragma.hs +36/−0
- tests/examples/ListComprehensions.hs +23/−0
- tests/examples/LocalDecls.hs +8/−0
- tests/examples/LocalDecls.hs.expected +11/−0
- tests/examples/LocalDecls2.hs +3/−0
- tests/examples/LocalDecls2.hs.expected +6/−0
- tests/examples/LocalDecls2Expected.hs +6/−0
- tests/examples/MagicHash.hs +29/−0
- tests/examples/MangledSemiLet.hs +10/−0
- tests/examples/Minimal.hs +37/−0
- tests/examples/MultiImplicitParams.hs +7/−0
- tests/examples/MultiLineCommentWithPragmas.hs +18/−0
- tests/examples/MultiLineWarningPragma.hs +18/−0
- tests/examples/MultiWayIf.hs +11/−0
- tests/examples/MultipleInferredContexts.hs +4/−0
- tests/examples/NestedDoLambda.hs +31/−0
- tests/examples/NestedLambda.hs +8/−0
- tests/examples/Obscure.hs +29/−0
- tests/examples/OptSig.hs +18/−0
- tests/examples/OptSig2.hs +5/−0
- tests/examples/OveridingPrimitives.hs +6/−0
- tests/examples/PatSigBind.hs +15/−0
- tests/examples/PatternGuards.hs +7/−0
- tests/examples/ProcNotation.hs +12/−0
- tests/examples/Pseudonym.hs +41/−0
- tests/examples/PuncFunctions.hs +25/−0
- tests/examples/QuasiQuote.hs +12/−0
- tests/examples/RSA.hs +19/−0
- tests/examples/RdrNames.hs +12/−0
- tests/examples/RecordSemi.hs +15/−0
- tests/examples/RecordWildcard.hs +8/−0
- tests/examples/RecursiveDo.hs +3/−0
- tests/examples/Remorse.hs +88/−0
- tests/examples/RmDecl1.hs +12/−0
- tests/examples/RmDecl1.hs.expected +8/−0
- tests/examples/RmDecl2.hs +10/−0
- tests/examples/RmDecl2.hs.expected +9/−0
- tests/examples/RmTypeSig1.hs +7/−0
- tests/examples/RmTypeSig1.hs.expected +7/−0
- tests/examples/Rules.hs +0/−1
- tests/examples/RulesSemi.hs +9/−0
- tests/examples/SemiInstance.hs +11/−0
- tests/examples/SemiWorkout.hs +60/−0
- tests/examples/Shebang.hs +5/−0
- tests/examples/ShiftingLambda.hs +22/−0
- tests/examples/Simple.hs +1/−3
- tests/examples/SimpleComplexTuple.hs +3/−0
- tests/examples/SlidingDataClassDecl.hs +14/−0
- tests/examples/SlidingDoClause.hs +13/−0
- tests/examples/SlidingLambda.hs +3/−0
- tests/examples/SlidingListComp.hs +8/−0
- tests/examples/SlidingRecordSetter.hs +4/−0
- tests/examples/SlidingTypeSyn.hs +14/−0
- tests/examples/SpacesSplice.hs +3/−0
- tests/examples/SpliceSemi.hs +4/−0
- tests/examples/StrangeTypeClass.hs +18/−0
- tests/examples/StringGap.hs +8/−0
- tests/examples/T10196.hs +13/−0
- tests/examples/T5951.hs +11/−0
- tests/examples/THMonadInstance.hs +22/−0
- tests/examples/TemplateHaskell.hs +40/−0
- tests/examples/TooManyAnnVal.hs +518/−0
- tests/examples/TransformListComp.hs +7/−0
- tests/examples/TupleSections.hs +21/−0
- tests/examples/TypeBrackets.hs +11/−0
- tests/examples/TypeBrackets2.hs +23/−0
- tests/examples/TypeBrackets3.hs +15/−0
- tests/examples/TypeBrackets4.hs +8/−0
- tests/examples/TypeFamilies.hs +14/−0
- tests/examples/TypeFamilies2.hs +10/−0
- tests/examples/TypeInstance.hs +11/−0
- tests/examples/TypeSignatureParens.hs +7/−0
- tests/examples/TypeSynOperator.hs +3/−0
- tests/examples/TypeSynParens.hs +19/−0
- tests/examples/Undefined10.hs +643/−0
- tests/examples/Undefined11.hs +423/−0
- tests/examples/Undefined13.hs +130/−0
- tests/examples/Undefined2.hs +56/−0
- tests/examples/Undefined3.hs +340/−0
- tests/examples/Undefined4.hs +280/−0
- tests/examples/Undefined5.hs +66/−0
- tests/examples/Undefined6.hs +238/−0
- tests/examples/Undefined7.hs +76/−0
- tests/examples/Undefined8.hs +134/−0
- tests/examples/Undefined9.hs +30/−0
- tests/examples/Unicode.hs +31/−0
- tests/examples/UnicodeRules.hs +16/−0
- tests/examples/UnicodeSyntax.hs +236/−0
- tests/examples/UnicodeSyntaxFailure.hs +3/−0
- tests/examples/Utils2.hs +1/−2
- tests/examples/WhereIn3.hs +19/−0
- tests/examples/WhereIn3.hs.expected +16/−0
- tests/examples/WhereIn3a.hs +19/−0
- tests/examples/WhereIn3a.hs.expected +25/−0
ChangeLog view
@@ -1,3 +1,21 @@+2015-07-20 v0.3+ Substantial rework to manage changes introduced in GHC 7.10.2 rc2+ and beyond.++ Simplification of the core Annotation data type coupled with+ simplification of the various phases, by @mpickering.++ Introduction of initial Transform functions, driven by the needs+ of HaRe [1] and apply-refact [2] for applying hlint hints. Both of+ these are currently works in progress, and this module is likely+ to change substantially in future releases.++ Support for processing files making use of CPP.++ Links+ [1] https://github.com/alanz/HaRe/tree/wip+ [2] https://github.com/mpickering/apply-refact+ 2015-03-24 v0.2 This release contains a major rewrite of all internal modules.
ghc-exactprint.cabal view
@@ -1,25 +1,29 @@--- Initial ghc-exactprint.cabal generated by cabal init. For further--- documentation, see http://haskell.org/cabal/users-guide/- name: ghc-exactprint-version: 0.2+version: 0.3 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- be compiled by GHC+description: Using the API Annotations available from GHC 7.10.2, this+ library provides a means to round trip any code that can+ be compiled by GHC, currently excluding lhs files. .- * any currently excludes anything using CPP or lhs.+ It does this with a phased approach .- The dependency footprint is deliberately kept small so that- it can easily be tested against GHC HEAD+ * Delta - converts GHC API Annotations into relative+ offsets, indexed by SrcSpan .- Note: requires GHC 7.10 RC2 or later+ * Transform - functions to facilitate changes to+ the AST, adjusting the annotations generated in the+ Delta phase to suit the changes.+ .+ * Print - converts an AST and its annotations to+ properly formatted source text.+ .+ .+ Note: requires GHC 7.10.2 or later license: BSD3 license-file: LICENSE author: Alan Zimmerman, Matthew Pickering maintainer: alan.zimm@gmail.com--- copyright: category: Development build-type: Simple extra-source-files: ChangeLog@@ -32,39 +36,52 @@ type: git location: https://github.com/alanz/ghc-exactprint.git +Flag roundtrip {+ Description: Build roundtripping executables+ Default: False+}++ library exposed-modules: Language.Haskell.GHC.ExactPrint- , Language.Haskell.GHC.ExactPrint.Types- , Language.Haskell.GHC.ExactPrint.Utils+ , Language.Haskell.GHC.ExactPrint.Annotate , Language.Haskell.GHC.ExactPrint.Delta+ , Language.Haskell.GHC.ExactPrint.GhcInterim , Language.Haskell.GHC.ExactPrint.Lookup- , Language.Haskell.GHC.ExactPrint.Annotate+ , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Print- GHC-Options: -Wall+ , Language.Haskell.GHC.ExactPrint.Transform+ , Language.Haskell.GHC.ExactPrint.Types+ , Language.Haskell.GHC.ExactPrint.Utils+ , Language.Haskell.GHC.ExactPrint.Parsers++ -- other-modules: -- other-extensions:+ GHC-Options: -Wall build-depends: base >=4.7 && <4.9 , containers , directory , filepath , ghc , ghc-paths- , ghc-syb-utils , mtl , syb , free hs-source-dirs: src default-language: Haskell2010- -- Note: the following constraint actually requires RC2 or better- if impl (ghc < 7.10)+ if impl (ghc < 7.10.2) buildable: False Test-Suite test type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Test.hs+ other-modules: Test.Common, Test.Consistency, Test.Transform GHC-Options: -threaded Default-language: Haskell2010+ if impl (ghc < 7.10.2)+ buildable: False Build-depends: HUnit , base < 5 , containers@@ -73,11 +90,47 @@ , ghc , ghc-exactprint , ghc-paths- , ghc-syb-utils , mtl , random- , stm , syb+ , silently+ , filemanip +executable roundtrip+ main-is: Roundtrip.hs+ hs-source-dirs: tests+ other-modules: Test.Common+ default-language: Haskell2010+ if impl (ghc >= 7.10.2) && flag (roundtrip)+ build-depends:+ HUnit+ , base+ , containers+ , directory+ , filemanip+ , filepath+ , ghc+ , ghc-exactprint+ , ghc-paths+ , syb+ , temporary+ buildable: True+ else+ buildable: False+ ghc-options:+ -threaded++executable static+ main-is: Static.hs+ hs-source-dirs: tests+ default-language: Haskell2010+ if flag (roundtrip)+ build-depends: base+ , directory+ , filepath+ , Diff+ buildable: True+ else+ buildable: False
src/Language/Haskell/GHC/ExactPrint.hs view
@@ -1,14 +1,29 @@+{-# LANGUAGE LambdaCase #-}+-- | @ghc-exactprint@ is a library to manage manipulating Haskell+-- source files. There are four components. module Language.Haskell.GHC.ExactPrint ( -- * Relativising relativiseApiAnns+ , relativiseApiAnnsWithComments , Anns+ , Comment+ , Annotation(..)+ , AnnKey(..) + -- * Parsing+ , parseModule++ -- * Transformation+ , module Language.Haskell.GHC.ExactPrint.Transform+ -- * Printing , exactPrintWithAnns , exactPrint ) where -import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Delta import Language.Haskell.GHC.ExactPrint.Print+import Language.Haskell.GHC.ExactPrint.Transform+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Parsers
src/Language/Haskell/GHC/ExactPrint/Annotate.hs view
@@ -1,1961 +1,2340 @@-{-# 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 ++ "\"")+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | 'annotate' is a function which given a GHC AST fragment, constructs+-- a syntax tree which indicates which annotations belong to each specific+-- part of the fragment.+--+-- "Delta" and "Print" provide two interpreters for this structure. You+-- should probably use those unless you know what you're doing!+--+-- The functor 'AnnotationF' has a number of constructors which correspond+-- to different sitations which annotations can arise. It is hoped that in+-- future versions of GHC these can be simplified by making suitable+-- modifications to the AST.+module Language.Haskell.GHC.ExactPrint.Annotate+ (+ annotate+ , AnnotationF(..)+ , Annotated+ , Annotate(..)) where++import Data.Maybe ( fromMaybe )+#if __GLASGOW_HASKELL__ <= 710+import Data.Ord ( comparing )+import Data.List ( sortBy )+#endif++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++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 OccName as GHC+import qualified Outputable as GHC++import Control.Monad.Trans.Free+import Control.Monad.Free.TH (makeFreeCon)+import Control.Monad.Identity+import Data.Data++import Debug.Trace+++-- ---------------------------------------------------------------------++-- |+-- ['MarkPrim']+-- The main constructor. Marks that a specific AnnKeywordId could+-- appear with an optional String which is used when printing.+-- ['MarkEOF']+-- Special constructor which marks the end of file marker.+-- ['MarkExternal'] TODO+-- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the+-- current context. This is usually used to reassociated located+-- @RdrName@ which are more naturally associated with their parent than+-- in their own annotation.+-- ['MarkInside']+-- The dual of MarkOutside. If we wish to mark a non-separating comma+-- or semi-colon then we must use this constructor.+-- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks+-- without reflection in the AST. This construction greedily takes all of+-- the specified @AnnKeywordId@.+-- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are+-- seperated by different @AnnKeywordId@. Thus using MarkMany is+-- unsuitable and instead we provide an index to specify which specific+-- instance to choose each time.+-- ['WithAST'] TODO+-- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the+-- only way to tell what the concrete source was is to count a certain+-- kind of @AnnKeywordId@.+-- ['WithSortKey'] There are many places where the syntactic ordering of elements is+-- thrown away by the AST. This constructor captures the original+-- ordering and reflects any changes in ordered as specified by the+-- @annSortKey@ field in @Annotation@.+-- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This+-- constructor wraps a computation to indicate that LayoutRules apply to+-- the corresponding construct.+-- ['StoreOriginalSrcSpan'] TODO+-- ['GetSrcSpanFromKw'] TODO+-- ['StoreString'] TODO+-- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other+-- option but to convert a fragment of source code into a comment. This+-- means it is impossible to edit such a fragment but means that+-- processing files with such fragments is still possible.+data AnnotationF next where+ MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next+ MarkEOF :: 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+ WithAST :: Data a => GHC.Located a+ -> Annotated b -> next -> AnnotationF next+ CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next+ WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next++ SetLayoutFlag :: Annotated () -> next -> AnnotationF next++ -- Required to work around deficiencies in the GHC AST+ StoreOriginalSrcSpan :: AnnKey -> (AnnKey -> next) -> AnnotationF next+ GetSrcSpanForKw :: GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next+ StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next+ AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next++deriving instance Functor (AnnotationF)++type Annotated = FreeT AnnotationF Identity+++-- ---------------------------------------------------------------------++makeFreeCon 'MarkEOF+makeFreeCon 'MarkPrim+makeFreeCon 'MarkOutside+makeFreeCon 'MarkInside+makeFreeCon 'MarkExternal+makeFreeCon 'MarkMany+makeFreeCon 'MarkOffsetPrim+makeFreeCon 'CountAnns+makeFreeCon 'StoreOriginalSrcSpan+makeFreeCon 'GetSrcSpanForKw+makeFreeCon 'StoreString+makeFreeCon 'AnnotationsToComments+makeFreeCon 'SetLayoutFlag+makeFreeCon 'WithSortKey++-- ---------------------------------------------------------------------++-- | Construct a syntax tree which represent which KeywordIds must appear+-- where.+annotate :: (Annotate ast) => GHC.Located ast -> Annotated ()+annotate = markLocated++-- ---------------------------------------------------------------------++workOutString :: GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated ()+workOutString kw f = do+ ss <- getSrcSpanForKw kw+ storeString (f ss) ss+++-- ---------------------------------------------------------------------++-- |Main driver point for annotations.+withAST :: Data a => GHC.Located a -> Annotated () -> Annotated ()+withAST lss action =+ liftF (WithAST lss prog ())+ where+ prog = do+ action+ -- Automatically add any trailing comma or semi+ markOutside GHC.AnnComma (G GHC.AnnComma)++-- ---------------------------------------------------------------------+-- 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++-- ---------------------------------------------------------------------++-- | Constructs a syntax tree which contains information about which+-- annotations are required by each element.+markLocated :: (Annotate ast) => GHC.Located ast -> Annotated ()+markLocated a = withLocated a markAST++withLocated :: Data a+ => GHC.Located a+ -> (GHC.SrcSpan -> a -> Annotated ())+ -> Annotated ()+withLocated a@(GHC.L l ast) action =+ withAST a (action l ast)++-- ---------------------------------------------------------------------++markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated ()+markListWithLayout ls =+ setLayoutFlag (mapM_ markLocated ls)++markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => GHC.HsLocalBinds name -> Annotated ()+markLocalBindsWithLayout binds =+ setLayoutFlag (markHsLocalBinds binds)++-- ---------------------------------------------------------------------++-- |This function is used to get around shortcomings in the GHC AST for 7.10.1+markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> ast -> Annotated ()+markLocatedFromKw kw a = do+ ss <- getSrcSpanForKw kw+ AnnKey ss' _ <- storeOriginalSrcSpan (mkAnnKey (GHC.L ss a))+ markLocated (GHC.L ss' a)++-- ---------------------------------------------------------------------++markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()+markMaybe Nothing = return ()+markMaybe (Just ast) = markLocated ast++-- ---------------------------------------------------------------------+-- 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.getLoc b,markLocated b)) ls++applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated ()+applyListAnnotations ls = withSortKey ls++#if __GLASGOW_HASKELL__ <= 710+lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a]+lexicalSortLocated = sortBy (comparing GHC.getLoc)+#endif++-- ---------------------------------------------------------------------++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++ mapM_ markLocated 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 Annotate (GHC.SourceText,GHC.FastString) where+ markAST l (_,fs) = markAST l fs++-- ---------------------------------------------------------------------++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@(GHC.L _ n)) -> do+ {-+ At the moment (7.10.2) GHC does not cleanly represent an export of the form+ "type Foo"+ and it only captures the name "Foo".++ The Api Annotations workaround is to have the IEThingAbs SrcSpan+ extend across both the "type" and "Foo", and then to capture the+ individual item locations in an AnnType and AnnVal annotation.++ This need to be fixed for 7.12.+ -}+ cnt <- countAnns GHC.AnnType+ if cnt == 1+ then do+ mark GHC.AnnType+ markLocatedFromKw GHC.AnnVal n+ else 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 ()++-- ---------------------------------------------------------------------+{-+-- For details on above see note [Api annotations] in ApiAnnotation+data RdrName+ = Unqual OccName+ -- ^ Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@.+ -- Create such a 'RdrName' with 'mkRdrUnqual'++ | Qual ModuleName OccName+ -- ^ A qualified name written by the user in+ -- /source/ code. The module isn't necessarily+ -- the module where the thing is defined;+ -- just the one from which it is imported.+ -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@.+ -- Create such a 'RdrName' with 'mkRdrQual'++ | Orig Module OccName+ -- ^ An original name; the module is the /defining/ module.+ -- This is used when GHC generates code that will be fed+ -- into the renamer (e.g. from deriving clauses), but where+ -- we want to say \"Use Prelude.map dammit\". One of these+ -- can be created with 'mkOrig'++ | Exact Name+ -- ^ We know exactly the 'Name'. This is used:+ --+ -- (1) When the parser parses built-in syntax like @[]@+ -- and @(,)@, but wants a 'RdrName' from it+ --+ -- (2) By Template Haskell, when TH has generated a unique name+ --+ -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name'+ deriving (Data, Typeable)+-}++instance Annotate GHC.RdrName where+ markAST l n = do+ let+ str = rdrName2String n+ doNormalRdrName = do+ let str' = case str of+ "forall" -> if spanLength l == 1 then "∀" else str+ _ -> str+ mark GHC.AnnType+ mark GHC.AnnOpenP -- '('+ markOffset GHC.AnnBackquote 0+ cnt <- countAnns GHC.AnnVal+ cntT <- countAnns GHC.AnnCommaTuple+ markMany GHC.AnnCommaTuple -- For '(,,,)'+ case cnt of+ 0 -> if cntT > 0+ then return () -- traceM $ "Printing RdrName, no AnnVal, multiple AnnCommTuple:" ++ showGhc (l,n)+ else markExternal l GHC.AnnVal str'+ 1 -> markWithString GHC.AnnVal str'+ _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n)+ markOffset GHC.AnnBackquote 1+ mark GHC.AnnCloseP++ case n of+ GHC.Unqual _ -> doNormalRdrName+ GHC.Qual _ _ -> doNormalRdrName+ _ -> do+ case str of+ -- Special handling for atypical RdrNames.+ "[]" -> 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 ":]" -- ':]'+ "(->)" -> do+ mark GHC.AnnOpenP -- '('+ mark GHC.AnnRarrow+ mark GHC.AnnCloseP -- ')'+ "~#" -> do+ mark GHC.AnnOpenP -- '('+ mark GHC.AnnTildehsh+ mark GHC.AnnCloseP+ "~" -> do+ mark GHC.AnnOpenP+ mark GHC.AnnTilde+ mark GHC.AnnCloseP+ _ -> doNormalRdrName++-- ---------------------------------------------------------------------++-- 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 modname mpkg 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+ case mpkg of+ Nothing -> return ()+#if __GLASGOW_HASKELL__ <= 710+ Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg))+#else+ Just (srcPkg,_pkg) -> markWithString GHC.AnnPackageName srcPkg+#endif++ markLocated modname++ 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+ markOutside (GHC.AnnSemi) (G GHC.AnnSemi)++-- ---------------------------------------------------------------------+instance Annotate GHC.ModuleName where+ markAST l mname =+ markExternal l GHC.AnnVal (GHC.moduleNameString mname)++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsDecl name) where+ markAST l decl = do+ case decl of+ GHC.TyClD d -> markLocated (GHC.L l d)+ GHC.InstD d -> markLocated (GHC.L l d)+ GHC.DerivD d -> markLocated (GHC.L l d)+ GHC.ValD d -> markLocated (GHC.L l d)+ GHC.SigD d -> markLocated (GHC.L l d)+ GHC.DefD d -> markLocated (GHC.L l d)+ GHC.ForD d -> markLocated (GHC.L l d)+ GHC.WarningD d -> markLocated (GHC.L l d)+ GHC.AnnD d -> markLocated (GHC.L l d)+ GHC.RuleD d -> markLocated (GHC.L l d)+ GHC.VectD d -> markLocated (GHC.L l d)+ GHC.SpliceD d -> markLocated (GHC.L l d)+ GHC.DocD d -> markLocated (GHC.L l d)+ GHC.RoleAnnotD d -> markLocated (GHC.L l d)+#if __GLASGOW_HASKELL__ < 711+ GHC.QuasiQuoteD d -> markLocated (GHC.L l d)+#endif++-- ---------------------------------------------------------------------++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 (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.SpliceDecl name) where+ markAST _ (GHC.SpliceDecl e _flag) = do+ mark GHC.AnnOpenPE+ markLocated e+ mark GHC.AnnCloseP+ markOutside GHC.AnnSemi AnnSemiSep++{-+- data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y)+- ImplicitSplice -- <=> f x y, i.e. a naked+- top level expression+-+-}++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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 {}) =+ traceM "warning: HsVectTypeOut appears after renaming"++ markAST _ (GHC.HsVectClassIn src ln) = do+ markWithString GHC.AnnOpen src -- "{-# VECTORISE"+ mark GHC.AnnClass+ markLocated ln+ markWithString GHC.AnnClose "#-}" -- "#-}"++ markAST _ (GHC.HsVectClassOut {}) =+ traceM "warning: HsVecClassOut appears after renaming"+ markAST _ (GHC.HsVectInstIn {}) =+ traceM "warning: HsVecInstsIn appears after renaming"+ markAST _ (GHC.HsVectInstOut {}) =+ traceM "warning: HsVecInstOut appears after renaming"++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.RuleDecls name) where+ markAST _ (GHC.HsRules src rules) = do+ markWithString GHC.AnnOpen src+ mapM_ markLocated rules+ markWithString GHC.AnnClose "#-}"+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName 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+ -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies.+ markAST l fs = markExternal l GHC.AnnVal (show (GHC.unpackFS fs))+ -- markAST l fs = markExternal l GHC.AnnVal ('"':(GHC.unpackFS fs++"\""))++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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 (show src)+ markLocated ln+ mark GHC.AnnDcolon+ markLocated typ+ markOutside (GHC.AnnSemi) AnnSemiSep+++ 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 (show src)+ markLocated ln+ mark GHC.AnnDcolon+ markLocated typ+++-- ---------------------------------------------------------------------++instance (Annotate GHC.CExportSpec) where+#if __GLASGOW_HASKELL__ <= 710+ markAST l (GHC.CExportStatic _ cconv) = markAST l cconv+#else+ markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv+#endif++-- ---------------------------------------------------------------------++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,GHC.HasOccName 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,GHC.HasOccName 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 -- ')'+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName 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++ applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)+ ++ prepareListAnnotation sigs+ ++ prepareListAnnotation tyfams+ ++ prepareListAnnotation datafams+ )++ mark GHC.AnnCloseC -- '}'+ markOutside GHC.AnnSemi (AnnSemiSep)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.TyFamInstDecl name) where++ markAST _ (GHC.TyFamInstDecl eqn _) = do+ mark GHC.AnnType+ mark GHC.AnnInstance+ markLocated eqn+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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+ mark GHC.AnnOpenP++ applyListAnnotations (prepareListAnnotation [ln]+ ++ prepareListAnnotation pats+ )++ mark GHC.AnnCloseP+ mark GHC.AnnWhere+ mark GHC.AnnEqual+ markDataDefn l defn++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsBind name) where+ markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do+ mapM_ markLocated matches+ --markOutside GHC.AnnSemi AnnSemiSep+ -- 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++ markLocalBindsWithLayout lb+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ 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+ case args of+ GHC.InfixPatSyn la lb -> do+ markLocated la+ markLocated ln+ markLocated lb+ GHC.PrefixPatSyn ns -> do+ markLocated ln+ 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 -- '}'+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ -- Introduced after renaming.+ markAST _ (GHC.AbsBinds _ _ _ _ _) =+ traceM "warning: AbsBind introduced after renaming"+++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.IPBind name) where+ markAST _ (GHC.IPBind en e) = do+ case en of+ Left n -> markLocated n+ Right _i -> return ()+ mark GHC.AnnEqual+ markLocated e+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance Annotate GHC.HsIPName where+ markAST l (GHC.HsIPName n) = markExternal l (GHC.AnnVal) ("?" ++ GHC.unpackFS n)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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:xs)) -> do+ mark GHC.AnnOpenP+ markLocated a+ case mln of+ Nothing -> return ()+ Just (n,_) -> markLocated n+ markLocated b+ mark GHC.AnnCloseP+ mapM_ markLocated xs+ _ -> do+ case mln of+ Nothing -> mark GHC.AnnFunId+ Just (n,_) -> markLocated n+ mapM_ markLocated pats++ -- TODO: The AnnEqual annotation actually belongs in the first GRHS value+ mark GHC.AnnEqual+ mark GHC.AnnRarrow -- For HsLam++ mapM_ markLocated grhs++ mark GHC.AnnWhere+ mark GHC.AnnOpenC -- '{'+ markInside GHC.AnnSemi+ markLocalBindsWithLayout lb+ mark GHC.AnnCloseC -- '}'+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,+ Annotate name, Annotate body)+ => Annotate (GHC.GRHS name (GHC.Located body)) where+ markAST _ (GHC.GRHS guards expr) = do+ case guards of+ [] -> return ()+ (_:_) -> mark GHC.AnnVbar >> mapM_ markLocated guards+ mark GHC.AnnEqual+ cntL <- countAnns GHC.AnnLam+ when (cntL == 0) $ mark GHC.AnnRarrow -- For HsLam+ markLocated expr++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.Sig name) where++ markAST _ (GHC.TypeSig lns typ _) = do+ mapM_ markLocated lns+ mark GHC.AnnDcolon+ markLocated typ+ markOutside (GHC.AnnSemi) (G GHC.AnnSemi)++ 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 _) =+ traceM "warning: Introduced after renaming"++ -- 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+ markOutside (GHC.AnnSemi) (G GHC.AnnSemi)++ -- 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 "#-}" -- '#-}'+ markOutside GHC.AnnSemi AnnSemiSep+++ markAST _ (GHC.SpecSig ln typs inl) = do+ markWithString GHC.AnnOpen (GHC.inl_src inl)+ mark GHC.AnnOpenS -- '['+ mark GHC.AnnTilde -- ~++ mark GHC.AnnCloseS -- ']'+ markLocated ln+ mark GHC.AnnDcolon -- '::'+ mapM_ markLocated typs+ markWithString GHC.AnnClose "#-}" -- '#-}'+ markOutside GHC.AnnSemi AnnSemiSep+++ -- '{-# SPECIALISE' 'instance' inst_type '#-}'+ markAST _ (GHC.SpecInstSig src typ) = do+ markWithString GHC.AnnOpen src+ mark GHC.AnnInstance+ markLocated typ+ markWithString GHC.AnnClose "#-}" -- '#-}'+ markOutside GHC.AnnSemi AnnSemiSep++++ -- MinimalSig (BooleanFormula (Located name))+ markAST l (GHC.MinimalSig src formula) = do+ markWithString GHC.AnnOpen src+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar]+ markAST l formula+ markWithString GHC.AnnClose "#-}"+ markOutside GHC.AnnSemi AnnSemiSep+++-- --------------------------------------------------------------------++-- In practice, due to the way the BooleanFormula is constructed in the parser,+-- we will get the following variants+-- a | b : Or [a,b]+-- a , b : And [a,b]+-- ( a ) : a+-- A bottom level Located RdrName is captured in a Var. This is the only part+-- with a location in it.+--+-- So the best strategy might be to convert all the annotations into comments,+-- and then just print the names. DONE+instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where+ markAST _ (GHC.Var x) = markLocated x+ markAST l (GHC.Or ls) = mapM_ (markAST l) ls+ markAST l (GHC.And ls) = mapM_ (markAST l) ls++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName 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 -> do+#if __GLASGOW_HASKELL__ <= 710+ let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs)+ markLocated (GHC.L lc sorted)+#else+ applyListAnnotations (prepareListAnnotation [GHC.L lwc WildCardAnon]+ ++ prepareListAnnotation ctxs)+#endif++ mark GHC.AnnDarrow+ markLocated typ+ mark GHC.AnnCloseP -- ")"++ markAST l (GHC.HsTyVar name) = do+ mark GHC.AnnDcolon -- for HsKind, alias for HsType+ n <- countAnns GHC.AnnSimpleQuote+ case n of+ 1 -> do+ mark GHC.AnnSimpleQuote+ markLocatedFromKw GHC.AnnName name+ _ -> markAST l name++ 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+ mark GHC.AnnSimpleQuote+ 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 -- ')'+-- mark GHC.AnnDarrow -- May appear after context in a ConDecl++ 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 -- ')'++ markAST l (GHC.HsSpliceTy s _) = do+ mark GHC.AnnOpenPE+ markAST l s+ mark GHC.AnnCloseP++ 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) =+ traceM "warning: HsCoreTy Introduced after renaming"++ markAST _ (GHC.HsExplicitListTy _ ts) = do+ mark GHC.AnnSimpleQuote+ mark GHC.AnnOpenS -- "["+ mapM_ markLocated ts+ mark GHC.AnnCloseS -- ']'++ markAST _ (GHC.HsExplicitTupleTy _ ts) = do+ mark GHC.AnnSimpleQuote+ mark GHC.AnnOpenP+ mapM_ markLocated ts+ mark GHC.AnnCloseP++ -- 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 _ _) =+ traceM "warning: HsWrapTyy Introduced after renaming"++#if __GLASGOW_HASKELL__ <= 710+ markAST l (GHC.HsWildcardTy) = do+ markExternal l GHC.AnnVal "_"+ markAST l (GHC.HsNamedWildcardTy n) = do+ markExternal l GHC.AnnVal (showGhc n)+#else+ markAST l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do+ markExternal l GHC.AnnVal "_"+ markAST l (GHC.HsWildCardTy (GHC.NamedWildCard n)) = do+ markExternal l GHC.AnnVal (showGhc n)+#endif++#if __GLASGOW_HASKELL__ <= 710+ markAST l (GHC.HsQuasiQuoteTy n) = do+ markAST l n+#endif++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsSplice name) where+#if __GLASGOW_HASKELL__ > 710+ markAST l c =+ case c of+ GHC.HsQuasiQuote _ n _pos fs -> do+ markExternal l GHC.AnnVal+ ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")++ GHC.HsTypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do+ markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))+ markLocated b+ GHC.HsTypedSplice _n b -> do+ mark GHC.AnnOpenPTE+ markLocated b+ mark GHC.AnnCloseP++ GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do+ markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))+ markLocated b+ GHC.HsUntypedSplice _n b -> do+ mark GHC.AnnThIdSplice+ mark GHC.AnnOpenPE+ markLocated b+ mark GHC.AnnCloseP+#else+ markAST _ c =+ case c of+ GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do+ markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n)))+ markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n)))+ markLocated b+ GHC.HsSplice _n b -> do+ mark GHC.AnnThIdSplice+ mark GHC.AnnOpenPTE+ mark GHC.AnnOpenPE+ markLocated b+ mark GHC.AnnCloseP+#endif++#if __GLASGOW_HASKELL__ > 710+#else+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsQuasiQuote name) where+ markAST l (GHC.HsQuasiQuote n _pos fs) = do+ markExternal l GHC.AnnVal+ ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]")+#endif++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName name)+ => Annotate (GHC.Pat name) where+ markAST l (GHC.WildPat _) = markExternal l GHC.AnnVal "_"+ markAST l (GHC.VarPat n) = do+ markAST l 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 {}) =+ traceM "warning: ConPatOut Introduced after renaming"++ -- 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 l (GHC.SplicePat s) = do+ mark GHC.AnnOpenPE+ markAST l s+ mark GHC.AnnCloseP++ -- 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 _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do+ markLocated pat+ mark GHC.AnnDcolon+ markLocated ty++ markAST _ (GHC.SigPatOut {}) =+ traceM "warning: SigPatOut introduced after renaming"++ -- CoPat HsAnnotated (Pat id) Type+ markAST _ (GHC.CoPat {}) =+ traceM "warning: CoPat introduced after renaming"++#if __GLASGOW_HASKELL__ <= 710+ markAST l (GHC.QuasiQuotePat p) = markAST l p+#endif++-- ---------------------------------------------------------------------+hsLit2String :: GHC.HsLit -> GHC.SourceText+hsLit2String lit =+ case lit of+ GHC.HsChar src _ -> src+ -- It should be included here+ -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471+ 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,GHC.HasOccName 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,GHC.HasOccName 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,GHC.HasOccName name,Annotate name)+ => Annotate [GHC.LConDeclField name] where+ markAST _ fs = do+ mark GHC.AnnOpenC -- '{'+ mapM_ markLocated fs+ mark GHC.AnnDotdot+ mark GHC.AnnCloseC -- '}'+ mark GHC.AnnRarrow++-- ---------------------------------------------------------------------++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 _ _ _) = do+ markLocated thing++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name+ ,GHC.HasOccName 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+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ markAST _ (GHC.BodyStmt body _ _ _) = do+ markLocated body+ mark GHC.AnnVbar -- possible in list comprehension+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ markAST _ (GHC.LetStmt lb) = do+ -- return () `debug` ("markP.LetStmt entered")+ mark GHC.AnnLet+ mark GHC.AnnOpenC -- '{'+ --markOffset GHC.AnnSemi 0+ markInside GHC.AnnSemi+ markLocalBindsWithLayout lb+ mark GHC.AnnCloseC -- '}'+ -- return () `debug` ("markP.LetStmt done")+ mark GHC.AnnVbar -- possible in list comprehension+ markOutside GHC.AnnSemi AnnSemiSep++ markAST l (GHC.ParStmt pbs _ _) = do+ mapM_ (markAST l) pbs+ mark GHC.AnnVbar -- possible in list comprehension+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do+ mapM_ markLocated stmts+ case form of+ GHC.ThenForm -> do+ mark GHC.AnnThen+ markLocated using+ case by of+ Just b -> mark GHC.AnnBy >> markLocated b+ Nothing -> return ()+ GHC.GroupForm -> do+ mark GHC.AnnThen+ mark GHC.AnnGroup+ case by of+ Just b -> mark GHC.AnnBy >> markLocated b+ Nothing -> return ()+ mark GHC.AnnUsing+ markLocated using+ mark GHC.AnnVbar -- possible in list comprehension+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do+ mark GHC.AnnRec+ mark GHC.AnnOpenC+ markInside GHC.AnnSemi+ mapM_ markLocated stmts+ mark GHC.AnnCloseC+ mark GHC.AnnVbar -- possible in list comprehension+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.ParStmtBlock name name) where+ markAST _ (GHC.ParStmtBlock stmts _ns _) =+ mapM_ markLocated stmts++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsLocalBinds name) where+ markAST _ lb = markHsLocalBinds lb++-- ---------------------------------------------------------------------++markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => (GHC.HsLocalBinds name) -> Annotated ()+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =+ applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)+ ++ prepareListAnnotation sigs+ )+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {}))+ = traceM "warning: ValBindsOut introduced after renaming"++markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated (reverse binds)+markHsLocalBinds (GHC.EmptyLocalBinds) = return ()++-- ---------------------------------------------------------------------++markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,+ Annotate body)+ => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)+ -> Annotated ()+markMatchGroup _ (GHC.MG matches _ _ _)+ = markListWithLayout matches++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName 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 _ (GHC.HsLam match) = do+ mark GHC.AnnLam+ -- TODO: Change this, HsLam binds do not need obey layout rules.+ mapM_ markLocated (GHC.mg_alts match)++ markAST l (GHC.HsLamCase _ match) = do+ mark GHC.AnnLam+ mark GHC.AnnCase+ mark GHC.AnnOpenC+ markMatchGroup l match+ mark GHC.AnnCloseC++ 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+ setLayoutFlag (do -- Make sure the 'in' gets indented too+ mark GHC.AnnLet+ mark GHC.AnnOpenC+ markInside GHC.AnnSemi+ markLocalBindsWithLayout binds+ mark GHC.AnnCloseC+ mark GHC.AnnIn+ markLocated e)++ markAST _ (GHC.HsDo cts es _) = do+ mark GHC.AnnDo+ mark GHC.AnnMdo+ 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 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+ mapM_ markLocated fs+ mark GHC.AnnDotdot+ mark GHC.AnnCloseC++ markAST _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do+ markLocated e+ mark GHC.AnnOpenC+ mapM_ markLocated fs+ mark GHC.AnnDotdot+ 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"+#if __GLASGOW_HASKELL__ <= 710+ markWithString GHC.AnnVal (GHC.unpackFS csFStr)+ markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"")+#else+ markWithString GHC.AnnVal (fst csFStr)+ markWithString GHC.AnnValStr (fst csFStr)+#endif+ markWithString GHC.AnnClose "#-}"+ markLocated e++ markAST _ (GHC.HsCoreAnn src csFStr e) = do+ markWithString GHC.AnnOpen src -- "{-# CORE"+#if __GLASGOW_HASKELL__ <= 710+ markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"")+#else+ markWithString GHC.AnnVal (fst csFStr)+#endif+ markWithString GHC.AnnClose "#-}"+ markLocated e+ -- TODO: make monomorphic+ markAST _ (GHC.HsBracket (GHC.VarBr _single v)) = do+ mark GHC.AnnSimpleQuote+ mark GHC.AnnThTyQuote+ markLocatedFromKw GHC.AnnName v+ 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 _)) =+ traceM "warning: DecBrG introduced after renamer"+ markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do+-- markWithString GHC.AnnOpen "[|"+ -- This exists like this as the lexer collapses [e| and [| into the+ -- same construtor+ workOutString GHC.AnnOpen+ (\ss -> if spanLength ss == 2+ then "[|"+ else "[e|")+ 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 _ _) =+ traceM "warning: HsRnBracketOut introduced after renamer"+ markAST _ (GHC.HsTcBracketOut _ _) =+ traceM "warning: HsTcBracketOut introduced after renamer"++#if __GLASGOW_HASKELL__ > 710+ markAST l (GHC.HsSpliceE e) = do+ mark GHC.AnnOpenPE+ markAST l e+ mark GHC.AnnCloseP+#else+ markAST l (GHC.HsSpliceE _ e) = do+ mark GHC.AnnOpenPE+ markAST l e+ mark GHC.AnnCloseP++ markAST l (GHC.HsQuasiQuoteE e) = do+ markAST l e+#endif++ 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+#if __GLASGOW_HASKELL__ <= 710+ markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING+#else+ markOffsetWithString GHC.AnnVal 0 (fst str) -- STRING+#endif+ 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 _ _) =+ traceM "warning: HsWrap introduced after renaming"+ markAST _ (GHC.HsUnboundVar _) =+ traceM "warning: HsUnboundVar introduced after renaming"++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,GHC.HasOccName name,Annotate name)+ => Annotate ([GHC.ExprLStmt name]) where+ markAST _ ls = mapM_ markLocated ls++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName name,Annotate name)+ => Annotate (GHC.HsCmdTop name) where+ markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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 "(|"+ -- This may be an infix operation+ applyListAnnotations (prepareListAnnotation [e]+ ++ prepareListAnnotation cs)+ -- 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+ markLocalBindsWithLayout binds+ mark GHC.AnnCloseC+ mark GHC.AnnIn+ markLocated e++ markAST _ (GHC.HsCmdDo es _) = do+ mark GHC.AnnDo+ mark GHC.AnnOpenC+ markListWithLayout es+ mark GHC.AnnCloseC++ markAST _ (GHC.HsCmdCast {}) =+ traceM "warning: HsCmdCast introduced after renaming"+++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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,GHC.HasOccName 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+ -- There may be arbitrary parens around parts of the constructor that are+ -- infix.+ -- Turn these into comments so that they feed into the right place automatically+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP]+ mark GHC.AnnType+ -- ln may be used infix, in which case rearrange the order. It may be+ -- simplest to just sort ln:tyvars+ applyListAnnotations (prepareListAnnotation [ln]+ ++ prepareListAnnotation tyvars)+ -- markMany GHC.AnnCloseP+ mark GHC.AnnEqual+ markLocated typ+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ 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+ mark GHC.AnnOpenC+ mapM_ markLocated cons+ markMaybe mderivs+ mark GHC.AnnCloseC+ markOutside GHC.AnnSemi (G GHC.AnnSemi)++ -- -----------------------------------++ 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 -- '}'+ markOutside (GHC.AnnSemi) AnnSemiSep++-- ---------------------------------------------------------------------++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,GHC.HasOccName 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+ mark GHC.AnnOpenP+ applyListAnnotations (prepareListAnnotation [ln]+ ++ prepareListAnnotation tyvars)+ mark GHC.AnnCloseP+ mark GHC.AnnDcolon+ markMaybe mkind+ mark GHC.AnnWhere+ mark GHC.AnnOpenC -- {+ case info of+#if __GLASGOW_HASKELL__ > 710+ GHC.ClosedTypeFamily (Just eqns) -> mapM_ markLocated eqns+#else+ GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns+#endif+ _ -> return ()+ mark GHC.AnnCloseC -- }+ markOutside GHC.AnnSemi AnnSemiSep++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)+ => Annotate (GHC.TyFamInstEqn name) where+ markAST _ (GHC.TyFamEqn ln (GHC.HsWB pats _ _ _) typ) = do+ mark GHC.AnnOpenP+ applyListAnnotations (prepareListAnnotation [ln]+ ++ prepareListAnnotation pats)+ mark GHC.AnnCloseP+ mark GHC.AnnEqual+ markLocated typ++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)+ => Annotate (GHC.TyFamDefltEqn name) where+ markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do+ mark GHC.AnnType+ mark GHC.AnnInstance+ 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,GHC.HasOccName 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,GHC.HasOccName name,Annotate name)+ => Annotate [GHC.LHsType name] where+ markAST _ ts = do+ mark GHC.AnnDeriving+ markMany GHC.AnnOpenP -- may be nested parens around context+ mapM_ markLocated ts+ markMany GHC.AnnCloseP -- may be nested parens around context+ -- mark GHC.AnnDarrow+ markOutside GHC.AnnDarrow (G GHC.AnnDarrow)++-- ---------------------------------------------------------------------++instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name)+ => Annotate (GHC.ConDecl name) where+ markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx+ dets res _ depc_syntax) = 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++ if depc_syntax+ then ( do+ markHsConDeclDetails lns dets+ mark GHC.AnnDcolon+ markMany GHC.AnnOpenP+ )++ else ( do+ mark GHC.AnnDcolon+ markLocated (GHC.L ls (ResTyGADTHook bndrs))+ markMany GHC.AnnOpenP+ markLocated ctx+ mark GHC.AnnDarrow+ markHsConDeclDetails lns dets )++ markLocated ty++ markMany GHC.AnnCloseP+++ mark GHC.AnnVbar+ markOutside GHC.AnnSemi (G GHC.AnnSemi)+++-- ResTyGADT has a SrcSpan for the original sigtype, we need to create+-- a type for exactPC and annotatePC+data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]+ deriving (Typeable)+deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)+deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name)++instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where+ ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs+++#if __GLASGOW_HASKELL__ > 710+-- WildCardAnon exists because the GHC anonymous wildcard type is defined as+-- = AnonWildCard (PostRn name Name)+-- We need to reconstruct this from the typed hole SrcSpan in an HsForAllTy, but+-- the instance doing this is parameterised on name, so we cannot put a value in+-- for the (PostRn name Name) field. This is used instead.+data WildCardAnon = WildCardAnon deriving (Show,Data,Typeable)++instance Annotate WildCardAnon where+ markAST l WildCardAnon = do+ markExternal l GHC.AnnVal "_"+#endif++-- ---------------------------------------------------------------------++instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)+ => Annotate (ResTyGADTHook name) where+ markAST _ (ResTyGADTHook bndrs) = do+ mark GHC.AnnForall+ mapM_ markLocated bndrs+ mark GHC.AnnDot++-- ---------------------------------------------------------------------++instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)+ => Annotate (GHC.HsRecField name (GHC.LPat name)) where+ markAST _ (GHC.HsRecField n e _) = do+ markLocated n+ mark GHC.AnnEqual+ markLocated e+++instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name)+ => Annotate (GHC.HsRecField name (GHC.LHsExpr name)) 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 ()+#if __GLASGOW_HASKELL__ <= 710+ Just (GHC.Header h) ->+ markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"")+ markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"")+#else+ Just (GHC.Header srcH _h) ->+ markWithString GHC.AnnHeader srcH+ markWithString GHC.AnnVal (fst f)+#endif markWithString GHC.AnnClose "#-}" -- ---------------------------------------------------------------------
src/Language/Haskell/GHC/ExactPrint/Delta.hs view
@@ -1,86 +1,173 @@ {-# LANGUAGE NamedFieldPuns #-}-module Language.Haskell.GHC.ExactPrint.Delta (relativiseApiAnns) where+{-# LANGUAGE BangPatterns #-}+-- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a+-- structure created by the "Annotate" modue.+--+-- == Structure of an Annotation+--+-- As a rule of thumb, every located element in the GHC AST will have+-- a corresponding entry in 'Anns'. An 'Annotation' contains 6 fields which+-- can be modifed to change how the AST is printed.+--+-- == Layout Calculation+--+-- Certain expressions such as do blocks and let bindings obey+-- <https://en.wikibooks.org/wiki/Haskell/Indentation layout rules>. We+-- calculate the 'annEntryDelta' slightly differently when such rules+-- apply.+--+-- 1. The first element which the layout rule applies to is given+-- a 'annEntryDelta' as normal.+-- 2. Further elements which must obey the rules are then given+-- 'annEntryDelta's relative to the LHS of the first element.+--+-- For example, in the following expression the statement corresponding to+-- `baz` will be given a 'annEntryDelta' of @DP (1, 2)@ as it appears+-- 1 line and 2 columns after the @do@ keyword. On the other hand, @bar@+-- will be given a 'annEntryDelta' of @DP (1,0)@ as it appears 1 line+-- further than @baz@ but in the same column as the start of the layout+-- block.+--+-- @+-- foo = do+-- baz+-- bar+-- @+--+-- A useful way to think of these rules is that the 'DeltaPos' is relative+-- to the further left an expression could have been placed. In the+-- previous example, we could have placed @baz@ anywhere on the line as its+-- position determines where the other statements must be. @bar@ could have+-- not been placed any further left without resulting in a syntax error+-- which is why the relative column is 0.+--+-- === annTrueEntryDelta+-- A very useful function is 'annTrueEntryDelta' which calculates the+-- offset from the last synctactic element (ignoring comments). This is+-- different to 'annEntryDelta' which does not ignore comments.+--+--+--+module Language.Haskell.GHC.ExactPrint.Delta+ ( relativiseApiAnns+ , relativiseApiAnnsWithComments+ ) 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 Data.List (sort, nub, partition, sortBy) -import Language.Haskell.GHC.ExactPrint.Types+import Data.Ord+ import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Lookup+import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Annotate (AnnotationF(..), Annotated- , markLocated, Annotate(..))+ , annotate, Annotate(..)) import qualified GHC import qualified SrcLoc as GHC import qualified Data.Map as Map +-- import Debug.Trace --- --------------------------------------------------------------------------- | 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+relativiseApiAnns = relativiseApiAnnsWithComments [] +-- | Exactly the same as 'relativiseApiAnns' but with the possibilty to+-- inject comments. This is typically used if the source has been preprocessed+-- by e.g. CPP, and the parts stripped out of the original source are re-added+-- as comments so they are not lost for round tripping.+relativiseApiAnnsWithComments ::+ Annotate ast+ => [Comment]+ -> GHC.Located ast+ -> GHC.ApiAnns+ -> Anns+relativiseApiAnnsWithComments cs modu ghcAnns+ = runDeltaWithComments cs (annotate modu) ghcAnns (ss2pos $ GHC.getLoc modu) -runDelta :: Annotated () -> GHC.ApiAnns -> GHC.SrcSpan -> Anns-runDelta action ga priorEnd =- ($ mempty) . appEndo . finalAnns . snd- . (\next -> execRWS next initialDeltaStack (defaultDeltaState priorEnd ga))- . simpleInterpret $ action+-- ---------------------------------------------------------------------+--+-- | Type used in the Delta Monad.+type Delta a = RWS DeltaReader DeltaWriter DeltaState a +runDeltaWithComments :: [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns+runDeltaWithComments cs action ga priorEnd =+ mkAnns . snd+ . (\next -> execRWS next initialDeltaReader (defaultDeltaState cs priorEnd ga))+ . deltaInterpret $ action+ where+ mkAnns :: DeltaWriter -> Anns+ mkAnns = f . dwAnns+ f :: Monoid a => Endo a -> a+ f = ($ mempty) . appEndo+ -- --------------------------------------------------------------------- +data DeltaReader = DeltaReader+ {+ -- | Current `SrcSpan, part of current AnnKey`+ curSrcSpan :: !GHC.SrcSpan++ -- | Constuctor of current AST element, part of current AnnKey+ , annConName :: !AnnConName++ }++data DeltaWriter = DeltaWriter+ { -- | Final list of annotations, and sort keys+ dwAnns :: Endo (Map.Map AnnKey Annotation)++ -- | Used locally to pass Keywords, delta pairs relevant to a specific+ -- subtree to the parent.+ , annKds :: ![(KeywordId, DeltaPos)]+ , sortKeys :: !(Maybe [GHC.SrcSpan])+ , dwCapturedSpan :: !(First AnnKey)+ }+ 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- }+ { -- | Position reached when processing the last element+ priorEndPosition :: !Pos -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- }+ -- | Ordered list of comments still to be allocated+ , apComments :: ![Comment] -initialDeltaStack :: DeltaStack-initialDeltaStack =- DeltaStack+ -- | The original GHC Delta Annotations+ , apAnns :: !GHC.ApiAnns++ , apMarkLayout :: Bool+ , apLayoutStart :: LayoutStartCol++ }++-- ---------------------------------------------------------------------++initialDeltaReader :: DeltaReader+initialDeltaReader =+ DeltaReader { curSrcSpan = GHC.noSrcSpan , annConName = annGetConstr ()- , layoutStart = 0 } -defaultDeltaState :: GHC.SrcSpan -> GHC.ApiAnns -> DeltaState-defaultDeltaState priorEnd ga =+defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState+defaultDeltaState injectedComments priorEnd ga = DeltaState- { priorEndPosition = priorEnd- , apComments = cs- , apAnns = ga -- $+ { priorEndPosition = priorEnd+ , apComments = cs ++ injectedComments+ , apAnns = ga+ , apLayoutStart = 1+ , apMarkLayout = False } where cs :: [Comment]@@ -90,70 +177,112 @@ 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) })+ -- tell (mempty { dwAnns = Endo (Map.insertWith (<>) k v) })+ tell (mempty { dwAnns = Endo (Map.insert k v) }) +tellSortKey :: [GHC.SrcSpan] -> Delta ()+tellSortKey xs = tell (mempty { sortKeys = Just xs } )++tellCapturedSpan :: AnnKey -> Delta ()+tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key })+ 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)+ mempty = DeltaWriter mempty mempty mempty mempty+ (DeltaWriter a b e g) `mappend` (DeltaWriter c d f h)+ = DeltaWriter (a <> c) (b <> d) (e <> f) (g <> h) -------------------------------------- Interpretation code+-- Free Monad Interpretation code -simpleInterpret :: Annotated a -> Delta a-simpleInterpret = iterTM go+deltaInterpret :: Annotated a -> Delta a+deltaInterpret = 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+ 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 (WithAST lss prog next) = withAST lss (deltaInterpret prog) >> next+ go (CountAnns kwid next) = countAnnsDelta kwid >>= next+ go (SetLayoutFlag action next) = setLayoutFlag (deltaInterpret action) >> next+ go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next+ go (StoreOriginalSrcSpan key next) = storeOriginalSrcSpanDelta key >>= next+ go (GetSrcSpanForKw kw next) = getSrcSpanForKw kw >>= next+ go (StoreString s ss next) = storeString s ss >> next+ go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next+ go (WithSortKey kws next) = withSortKey kws >> next +withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Delta ()+withSortKey kws =+ let order = sortBy (comparing fst) kws+ in do+ tellSortKey (map fst order)+ mapM_ (deltaInterpret . snd) order --- | 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 +setLayoutFlag :: Delta () -> Delta ()+setLayoutFlag action = do+ oldLay <- gets apLayoutStart+ modify (\s -> s { apMarkLayout = True } )+ let reset = do+ modify (\s -> s { apMarkLayout = False+ , apLayoutStart = oldLay })+ action <* reset --- ------------------------------------- +-- ---------------------------------------------------------------------++storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey+storeOriginalSrcSpanDelta key = do+ tellCapturedSpan key+ return key++storeString :: String -> GHC.SrcSpan -> Delta ()+storeString s ss = addAnnotationWorker (AnnString s) ss++-- ---------------------------------------------------------------------++-- |In order to interleave annotations into the stream, we turn them into+-- comments.+annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta ()+annotationsToCommentsDelta kws = do+ ga <- gets apAnns+ ss <- getSrcSpan+ cs <- gets apComments+ let+ doOne :: GHC.AnnKeywordId -> [Comment]+ doOne kw = comments+ where+ spans = GHC.getAnnotation ga ss kw+ comments = map (mkKWComment kw) spans+ -- TODO:AZ make sure these are sorted/merged properly when the invariant for+ -- allocateComments is re-established.+ newComments = concatMap doOne kws+ putUnallocatedComments (cs ++ newComments)++-- ---------------------------------------------------------------------++-- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1+getSrcSpanForKw :: GHC.AnnKeywordId -> Delta GHC.SrcSpan+getSrcSpanForKw kw = do+ ga <- gets apAnns+ ss <- getSrcSpan+ case GHC.getAnnotation ga ss kw of+ [] -> return GHC.noSrcSpan+ (sp:_) -> return sp++-- ---------------------------------------------------------------------+ getSrcSpan :: Delta GHC.SrcSpan getSrcSpan = asks curSrcSpan @@ -164,7 +293,6 @@ }) - getUnallocatedComments :: Delta [Comment] getUnallocatedComments = gets apComments @@ -175,48 +303,80 @@ adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos adjustDeltaForOffsetM dp = do- colOffset <- asks layoutStart+ colOffset <- gets apLayoutStart 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)+adjustDeltaForOffset _colOffset dp@(DP (0,_)) = dp -- same line+adjustDeltaForOffset (LayoutStartCol colOffset) (DP (l,c)) = DP (l,c - colOffset) -- --------------------------------------------------------------------- -getPriorEnd :: Delta GHC.SrcSpan+getPriorEnd :: Delta Pos getPriorEnd = gets priorEndPosition -setPriorEnd :: GHC.SrcSpan -> Delta ()-setPriorEnd pe = modify (\s -> s { priorEndPosition = pe })+setPriorEnd :: Pos -> Delta ()+setPriorEnd pe =+ modify (\s -> s { priorEndPosition = pe }) -setLayoutOffset :: LayoutStartCol -> Delta a -> Delta a-setLayoutOffset lhs = local (\s -> s { layoutStart = lhs })+setPriorEndAST :: GHC.SrcSpan -> Delta ()+setPriorEndAST pe = do+ setLayoutStart (snd (ss2pos pe))+ modify (\s -> s { priorEndPosition = (ss2posEnd pe) } ) +setLayoutStart :: Int -> Delta ()+setLayoutStart p = do+ DeltaState{apMarkLayout} <- get+ when apMarkLayout (+ modify (\s -> s { apMarkLayout = False+ , apLayoutStart = LayoutStartCol p}))++ -- ------------------------------------- -getAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]-getAnnotationDelta an = do+peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+peekAnnotationDelta an = do ga <- gets apAnns ss <- getSrcSpan return $ GHC.getAnnotation ga ss an +getAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+getAnnotationDelta an = do+ ss <- getSrcSpan+ getAndRemoveAnnotationDelta 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' }) --- -------------------------------------+getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+getOneAnnotationDelta an = do+ ss <- getSrcSpan+ getAndRemoveOneAnnotationDelta ss an +getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta [GHC.SrcSpan]+getAndRemoveOneAnnotationDelta sp an = do+ (anns,cs) <- gets apAnns+ let (r,ga') = case Map.lookup (sp,an) anns of+ Nothing -> ([],(anns,cs))+ Just [] -> ([], (Map.delete (sp,an) anns,cs))+ Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs))+ modify (\s -> s { apAnns = ga' })+ return r++-- ---------------------------------------------------------------------+ -- |Add some annotation to the currently active SrcSpan addAnnotationsDelta :: Annotation -> Delta () addAnnotationsDelta ann = do l <- ask- tellFinalAnn (getAnnKey l ,ann)+ tellFinalAnn (getAnnKey l,ann) -getAnnKey :: DeltaStack -> AnnKey-getAnnKey DeltaStack {curSrcSpan, annConName} = AnnKey curSrcSpan annConName+getAnnKey :: DeltaReader -> AnnKey+getAnnKey DeltaReader {curSrcSpan, annConName}+ = AnnKey curSrcSpan annConName -- ------------------------------------- @@ -225,86 +385,143 @@ -- ------------------------------------- - -- | 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+withAST :: Data a+ => GHC.Located a+ -> Delta b -> Delta b+withAST lss@(GHC.L ss _) 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+ off <- gets apLayoutStart+ (resetAnns . withSrcSpanDelta lss) (do let maskWriter s = s { annKds = []- , propOffset = First Nothing }+ , sortKeys = Nothing+ , dwCapturedSpan = mempty } - (res, w) <- censor maskWriter (listen action)+ -- make sure all kds are relative to the start of the SrcSpan+ let spanStart = ss2pos ss++ cs <- do+ priorEndBeforeComments <- getPriorEnd+ if GHC.isGoodSrcSpan ss && priorEndBeforeComments < ss2pos ss+ then+ commentAllocation (priorComment spanStart) return+ else+ return []+ priorEndAfterComments <- getPriorEnd let edp = adjustDeltaForOffset -- Use the propagated offset if one is set- (fromMaybe off (getFirst $ propOffset w))- (deltaFromSrcSpans pe ss)+ -- Note that we need to use the new offset if it has+ -- changed.+ off (ss2delta priorEndAfterComments ss)+ -- Preparation complete, perform the action+ when (GHC.isGoodSrcSpan ss && priorEndAfterComments < ss2pos ss) (do+ modify (\s -> s { priorEndPosition = (ss2pos ss) } ))+ (res, w) <- censor maskWriter (listen action)+ 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))+ an = Ann+ { annEntryDelta = edp+ , annPriorComments = cs+ , annFollowingComments = [] -- only used in Transform and Print+ , annsDP = kds+ , annSortKey = sortKeys w+ , annCapturedSpan = getFirst $ dwCapturedSpan w }++ addAnnotationsDelta an+ `debug` ("leaveAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) return res) --- ---------------------------------------------------------------------+resetAnns :: Delta a -> Delta a+resetAnns action = do+ ans <- gets apAnns+ action <* modify (\s -> s { apAnns = ans }) ++-- --------------------------------------------------------------------- -- |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))+-- the give SrcSpan and the rest+priorComment :: Pos -> Comment -> Bool+priorComment start c = (ss2pos . commentIdentifier $ c) < start +-- TODO:AZ: We scan the entire comment list here. It may be better to impose an+-- invariant that the comments are sorted, and consume them as the pos+-- advances. It then becomes a process of using `takeWhile p` rather than a full+-- partition.+allocateComments :: (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])+allocateComments = partition+ -- --------------------------------------------------------------------- addAnnotationWorker :: KeywordId -> GHC.SrcSpan -> Delta ()-addAnnotationWorker ann pa = do+addAnnotationWorker ann pa =+ -- Zero-width source spans are injected by the GHC Lexer when it puts virtual+ -- '{', ';' and '}' tokens in for layout unless (isPointSrcSpan pa) $ do pe <- getPriorEnd ss <- getSrcSpan- let p = deltaFromSrcSpans pe pa+ let p = ss2delta 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))+ commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment))+ addAnnDeltaPos (checkUnicode ann pa) p'+ setPriorEndAST pa+ `debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann)) +checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId+checkUnicode gkw@(G kw) ss =+ if kw `elem` unicodeSyntax+ then+ let s = keywordToString gkw in+ if (length s /= spanLength ss)+ then AnnUnicode kw+ else gkw+ else+ gkw+ where+ unicodeSyntax =+ [ GHC.AnnDcolon+ , GHC.AnnDarrow+ , GHC.AnnForall+ , GHC.AnnRarrow+ , GHC.AnnLarrow+ , GHC.Annlarrowtail+ , GHC.Annrarrowtail+ , GHC.AnnLarrowtail+ , GHC.AnnLarrowtail]+checkUnicode kwid _ = kwid+ -- --------------------------------------------------------------------- -addDeltaComment :: Comment -> Delta ()-addDeltaComment (Comment paspan str) = do- let pa = span2ss paspan+commentAllocation :: (Comment -> Bool)+ -> ([(Comment, DeltaPos)] -> Delta a)+ -> Delta a+commentAllocation p k = do+ cs <- getUnallocatedComments+ let (allocated,cs') = allocateComments p cs+ putUnallocatedComments cs'+ k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated)+++makeDeltaComment :: Comment -> Delta (Comment, DeltaPos)+makeDeltaComment c = do+ let pa = commentIdentifier c pe <- getPriorEnd- let p = deltaFromSrcSpans pe pa+ let p = ss2delta pe pa p' <- adjustDeltaForOffsetM p- setPriorEnd pa- let e = ss2deltaP (ss2posEnd pe) (snd paspan)- e' <- adjustDeltaForOffsetM e- addAnnDeltaPos (AnnComment (DComment (p',e') str)) p'+ setPriorEnd (ss2posEnd pa)+ return $ (c, p') +addDeltaComment :: Comment -> DeltaPos -> Delta ()+addDeltaComment d p = do+ addAnnDeltaPos (AnnComment d) p+ -- --------------------------------------------------------------------- -- | Look up and add a Delta annotation at the current position, and@@ -312,35 +529,23 @@ 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")+ -- ma <- getAnnotationDelta ann+ ma <- getOneAnnotationDelta 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 -> 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)+ [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann))+ [pa] -> addAnnotationWorker (G ann) pa+ (pa:_) -> addAnnotationWorker (G ann) pa `warn` ("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+ ss <- getSrcSpan+ ma <- peekAnnotationDelta ann+ let ma' = filter (\s -> (GHC.isSubspanOf s ss)) ma+ case drop off ma' of [] -> return ()- -- `debug` ("addDeltaAnnotationLs:missed:(off,pe,ann,ma)=" ++ show (off,ss2span pe,ann,fmap ss2span ma))+ `debug` ("addDeltaAnnotationLs:missed:(off,ann,ma)=" ++ showGhc (off,ss,ann)) (pa:_) -> addAnnotationWorker (G ann) pa -- | Look up and add possibly multiple Delta annotation at the current@@ -349,7 +554,7 @@ addDeltaAnnotations ann = do ma <- getAnnotationDelta ann let do_one ap' = addAnnotationWorker (G ann) ap'- -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))+ `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) mapM_ do_one (sort ma) -- | Look up and add possibly multiple Delta annotations enclosed by@@ -358,7 +563,7 @@ addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta () addDeltaAnnotationsInside ann = do ss <- getSrcSpan- ma <- getAnnotationDelta ann+ ma <- peekAnnotationDelta 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@@ -370,12 +575,9 @@ 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)+ 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@@ -389,17 +591,14 @@ case ma of [] -> return () (pa:pss) -> do- cs <- getUnallocatedComments- mapM_ addDeltaComment cs- let DP (r,c) = deltaFromSrcSpans pe pa+ commentAllocation (const True) (mapM_ (uncurry addDeltaComment))+ let DP (r,c) = ss2delta pe pa addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1))- setPriorEnd pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss)+ setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) countAnnsDelta :: GHC.AnnKeywordId -> Delta Int countAnnsDelta ann = do- ma <- getAnnotationDelta ann+ ma <- peekAnnotationDelta ann return (length ma)--
+ src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs view
@@ -0,0 +1,19 @@+-- functions from GHC copied here until they can be exported in the next version.+module Language.Haskell.GHC.ExactPrint.GhcInterim where++import ApiAnnotation+import Lexer+import SrcLoc++-- ---------------------------------------------------------------------+-- From Lexer.x+commentToAnnotation :: Located Token -> Located AnnotationComment+commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s)+commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s)+commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)+commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s)+commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s)+commentToAnnotation (L l (ITdocOptionsOld s)) = L l (AnnDocOptionsOld s)+commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s)+commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s)+commentToAnnotation _ = error $ "commentToAnnotation called for non-comment:" -- ++ show x
src/Language/Haskell/GHC/ExactPrint/Lookup.hs view
@@ -1,90 +1,141 @@-module Language.Haskell.GHC.ExactPrint.Lookup (keywordToString) where+module Language.Haskell.GHC.ExactPrint.Lookup+ (+ keywordToString+ , unicodeString+ ) where -import GHC (AnnKeywordId(..))+import Language.Haskell.GHC.ExactPrint.Types+import qualified GHC (AnnKeywordId(..))+import Data.Maybe -- | 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 :: KeywordId -> 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 -> ""+ AnnComment _ -> mkErr kw+ AnnString _ -> mkErr kw+ AnnUnicode kw' -> keywordToString (G kw')+ AnnSemiSep -> ";"+ (G GHC.AnnOpen ) -> mkErr kw+ (G GHC.AnnClose ) -> mkErr kw+ (G GHC.AnnVal ) -> mkErr kw+ (G GHC.AnnPackageName) -> mkErr kw+ (G GHC.AnnHeader ) -> mkErr kw+ (G GHC.AnnFunId ) -> mkErr kw+ (G GHC.AnnInfix ) -> mkErr kw+ (G GHC.AnnValStr ) -> mkErr kw+ (G GHC.AnnName ) -> mkErr kw+ (G GHC.AnnAs ) -> "as"+ (G GHC.AnnAt ) -> "@"+ (G GHC.AnnBang ) -> "!"+ (G GHC.AnnBackquote ) -> "`"+ (G GHC.AnnBy ) -> "by"+ (G GHC.AnnCase ) -> "case"+ (G GHC.AnnClass ) -> "class"+ (G GHC.AnnCloseC ) -> "}"+ (G GHC.AnnCloseP ) -> ")"+ (G GHC.AnnCloseS ) -> "]"+ (G GHC.AnnColon ) -> ":"+ (G GHC.AnnComma ) -> ","+ (G GHC.AnnCommaTuple ) -> ","+ (G GHC.AnnDarrow ) -> "=>"+ (G GHC.AnnData ) -> "data"+ (G GHC.AnnDcolon ) -> "::"+ (G GHC.AnnDefault ) -> "default"+ (G GHC.AnnDeriving ) -> "deriving"+ (G GHC.AnnDo ) -> "do"+ (G GHC.AnnDot ) -> "."+ (G GHC.AnnDotdot ) -> ".."+ (G GHC.AnnElse ) -> "else"+ (G GHC.AnnEqual ) -> "="+ (G GHC.AnnExport ) -> "export"+ (G GHC.AnnFamily ) -> "family"+ (G GHC.AnnForall ) -> "forall"+ (G GHC.AnnForeign ) -> "foreign"+ (G GHC.AnnGroup ) -> "group"+ (G GHC.AnnHiding ) -> "hiding"+ (G GHC.AnnIf ) -> "if"+ (G GHC.AnnImport ) -> "import"+ (G GHC.AnnIn ) -> "in"+ (G GHC.AnnInstance ) -> "instance"+ (G GHC.AnnLam ) -> "\\"+ (G GHC.AnnLarrow ) -> "<-"+ (G GHC.AnnLet ) -> "let"+ (G GHC.AnnMdo ) -> "mdo"+ (G GHC.AnnMinus ) -> "-"+ (G GHC.AnnModule ) -> "module"+ (G GHC.AnnNewtype ) -> "newtype"+ (G GHC.AnnOf ) -> "of"+ (G GHC.AnnOpenC ) -> "{"+ (G GHC.AnnOpenP ) -> "("+ (G GHC.AnnOpenPE ) -> "$("+ (G GHC.AnnOpenPTE ) -> "$$("+ (G GHC.AnnOpenS ) -> "["+ (G GHC.AnnPattern ) -> "pattern"+ (G GHC.AnnProc ) -> "proc"+ (G GHC.AnnQualified ) -> "qualified"+ (G GHC.AnnRarrow ) -> "->"+ (G GHC.AnnRec ) -> "rec"+ (G GHC.AnnRole ) -> "role"+ (G GHC.AnnSafe ) -> "safe"+ (G GHC.AnnSemi ) -> ";"+ (G GHC.AnnStatic ) -> "static"+ (G GHC.AnnThen ) -> "then"+ (G GHC.AnnTilde ) -> "~"+ (G GHC.AnnTildehsh ) -> "~#"+ (G GHC.AnnType ) -> "type"+ (G GHC.AnnUnit ) -> "()"+ (G GHC.AnnUsing ) -> "using"+ (G GHC.AnnVbar ) -> "|"+ (G GHC.AnnWhere ) -> "where"+ (G GHC.Annlarrowtail ) -> "-<"+ (G GHC.Annrarrowtail ) -> "->"+ (G GHC.AnnLarrowtail ) -> "-<<"+ (G GHC.AnnRarrowtail ) -> ">>-"+ (G GHC.AnnSimpleQuote ) -> "'"+ (G GHC.AnnThTyQuote ) -> "''"+ (G GHC.AnnThIdSplice ) -> "$"+ (G GHC.AnnThIdTySplice ) -> "$$"+ (G GHC.AnnEofPos ) -> "" +-- | Tries to find a unicode equivalent to a 'KeywordId'.+-- If none exists then fall back to find the ASCII version.+unicodeString :: KeywordId -> String+unicodeString kw =+ fromMaybe (keywordToString kw) (lookup kw unicodeChars)++unicodeChars :: [(KeywordId, String)]+unicodeChars =+ [ (G GHC.AnnDcolon, "∷")+ , (G GHC.AnnDarrow, "⇒")+ , (G GHC.AnnForall, "∀")+ , (G GHC.AnnRarrow, "→")+ , (G GHC.AnnLarrow, "←")+ , (G GHC.Annlarrowtail, "⤙")+ , (G GHC.Annrarrowtail, "⤚")+ , (G GHC.AnnLarrowtail, "⤛")+ , (G GHC.AnnRarrowtail, "⤜")]+{-+From Lexer.x++ ,("∷", ITdcolon, unicodeSyntaxEnabled)+ ,("⇒", ITdarrow, unicodeSyntaxEnabled)+ ,("∀", ITforall, unicodeSyntaxEnabled)+ ,("→", ITrarrow, unicodeSyntaxEnabled)+ ,("←", ITlarrow, unicodeSyntaxEnabled)++ ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+ ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+ ,("⤛", ITLarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)+ ,("⤜", ITRarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i)++ ,("★", ITstar, unicodeSyntaxEnabled)++-}
+ src/Language/Haskell/GHC/ExactPrint/Parsers.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- This module rexposes wrapped parsers from the GHC API. Along with+-- returning the parse result, the corresponding annotations are also+-- returned such that it is then easy to modify the annotations and print+-- the result.+--+----------------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint.Parsers (+ -- * Utility+ Parser+ , withDynFlags+ , CppOptions(..)+ , defaultCppOptions++ -- * Module Parsers+ , parseModule+ , parseModuleWithCpp++ -- * Basic Parsers+ , parseExpr+ , parseImport+ , parseType+ , parseDecl+ , parsePattern+ , parseStmt++ , parseWith+ ) where++import Language.Haskell.GHC.ExactPrint.Annotate+import Language.Haskell.GHC.ExactPrint.Delta+import Language.Haskell.GHC.ExactPrint.Preprocess+import Language.Haskell.GHC.ExactPrint.Types++import Control.Monad.RWS++import GHC.Paths (libdir)++import qualified ApiAnnotation as GHC+import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified GHC as GHC hiding (parseModule)+import qualified HeaderInfo as GHC+import qualified Lexer as GHC+import qualified MonadUtils as GHC+import qualified Outputable as GHC+import qualified Parser as GHC+import qualified SrcLoc as GHC+import qualified StringBuffer as GHC++#if __GLASGOW_HASKELL__ <= 710+import qualified OrdList as OL+#endif++import qualified Data.Map as Map++-- ---------------------------------------------------------------------++-- | Wrapper function which returns Annotations along with the parsed+-- element.+parseWith :: Annotate w+ => GHC.DynFlags+ -> FilePath+ -> GHC.P (GHC.Located w)+ -> String+ -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w)+parseWith dflags fileName parser s =+ case runParser parser dflags fileName s of+ GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m)+ GHC.POk (mkApiAnns -> apianns) pmod -> Right (as, pmod)+ where as = relativiseApiAnns pmod apianns++-- ---------------------------------------------------------------------++runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a+runParser parser flags filename str = GHC.unP parser parseState+ where+ location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1+ buffer = GHC.stringToStringBuffer str+ parseState = GHC.mkPState flags buffer location++-- ---------------------------------------------------------------------++-- | Provides a safe way to consume a properly initialised set of+-- 'DynFlags'.+--+-- @+-- myParser fname expr = withDynFlags (\\d -> parseExpr d fname expr)+-- @+withDynFlags :: (GHC.DynFlags -> a) -> IO a+withDynFlags action =+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $+ GHC.runGhc (Just libdir) $ do+ dflags <- GHC.getSessionDynFlags+ void $ GHC.setSessionDynFlags dflags+ return (action dflags)++-- ---------------------------------------------------------------------++parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.RdrName))+parseFile = runParser GHC.parseModule++-- ---------------------------------------------------------------------++type Parser a = GHC.DynFlags -> FilePath -> String+ -> Either (GHC.SrcSpan, String)+ (Anns, a)++parseExpr :: Parser (GHC.LHsExpr GHC.RdrName)+parseExpr df fp = parseWith df fp GHC.parseExpression++parseImport :: Parser (GHC.LImportDecl GHC.RdrName)+parseImport df fp = parseWith df fp GHC.parseImport++parseType :: Parser (GHC.LHsType GHC.RdrName)+parseType df fp = parseWith df fp GHC.parseType++-- safe, see D1007+parseDecl :: Parser (GHC.LHsDecl GHC.RdrName)+#if __GLASGOW_HASKELL__ <= 710+parseDecl df fp = parseWith df fp (head . OL.fromOL <$> GHC.parseDeclaration)+#else+parseDecl df fp = parseWith df fp GHC.parseDeclaration+#endif++parseStmt :: Parser (GHC.ExprLStmt GHC.RdrName)+parseStmt df fp = parseWith df fp GHC.parseStatement++parsePattern :: Parser (GHC.LPat GHC.RdrName)+parsePattern df fp = parseWith df fp GHC.parsePattern++-- ---------------------------------------------------------------------+--++-- | This entry point will also work out which language extensions are+-- required and perform CPP processing if necessary.+--+-- @+-- parseModule = parseModuleWithCpp defaultCppOptions+-- @+--+-- Note: 'GHC.ParsedSource' is a synonym for @Located (HsModule RdrName)@+parseModule :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, (GHC.Located (GHC.HsModule GHC.RdrName))))+parseModule = parseModuleWithCpp defaultCppOptions++-- | Parse a module with specific instructions for the C pre-processor.+parseModuleWithCpp :: CppOptions+ -> FilePath+ -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.Located (GHC.HsModule GHC.RdrName)))+parseModuleWithCpp cppOptions file =+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $+ GHC.runGhc (Just libdir) $ do+ dflags <- initDynFlags file+ let useCpp = GHC.xopt GHC.Opt_Cpp dflags+ (fileContents, injectedComments) <-+ if useCpp+ then do+ contents <- getPreprocessedSrcDirect cppOptions file+ cppComments <- getCppTokensAsComments cppOptions file+ return (contents,cppComments)+ else do+ txt <- GHC.liftIO $ readFile file+ let (contents1,lp) = stripLinePragmas txt+ return (contents1,lp)+ return $+ case parseFile dflags file fileContents of+ GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m))+ GHC.POk (mkApiAnns -> apianns) pmod ->+ let as = relativiseApiAnnsWithComments injectedComments pmod apianns in+ Right $ (as, pmod)++-- ---------------------------------------------------------------------++initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags+initDynFlags file = do+ dflags0 <- GHC.getSessionDynFlags+ let dflags1 = GHC.gopt_set dflags0 GHC.Opt_KeepRawTokenStream+ src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags1 file+ (dflags2, _, _)+ <- GHC.parseDynamicFilePragma dflags1 src_opts+ void $ GHC.setSessionDynFlags dflags2+ return dflags2++-- ---------------------------------------------------------------------++mkApiAnns :: GHC.PState -> GHC.ApiAnns+mkApiAnns pstate+ = ( Map.fromListWith (++) . GHC.annotations $ pstate+ , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate)))
+ src/Language/Haskell/GHC/ExactPrint/Preprocess.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE RecordWildCards #-}+-- | This module provides support for CPP, interpreter directives and line+-- pragmas.+module Language.Haskell.GHC.ExactPrint.Preprocess+ (+ stripLinePragmas+ , getCppTokensAsComments+ , getPreprocessedSrcDirect++ , CppOptions(..)+ , defaultCppOptions+ ) where++import qualified Bag as GHC+import qualified DriverPipeline as GHC+import qualified DynFlags as GHC+import qualified ErrUtils as GHC+import qualified FastString as GHC+import qualified GHC as GHC hiding (parseModule)+import qualified HscTypes as GHC+import qualified Lexer as GHC+import qualified MonadUtils as GHC+import qualified SrcLoc as GHC+import qualified StringBuffer as GHC++import SrcLoc (mkSrcSpan, mkSrcLoc)+import FastString (mkFastString)++import Control.Exception+import Data.List hiding (find)+import Data.Maybe+import Language.Haskell.GHC.ExactPrint.GhcInterim (commentToAnnotation)+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils+import qualified Data.Set as Set++-- import Debug.Trace+--+data CppOptions = CppOptions+ { cppDefine :: [String] -- ^ CPP #define macros+ , cppInclude :: [FilePath] -- ^ CPP Includes directory+ , cppFile :: [FilePath] -- ^ CPP pre-include file+ }++defaultCppOptions :: CppOptions+defaultCppOptions = CppOptions [] [] []++-- ---------------------------------------------------------------------+-- | Remove GHC style line pragams (@{-# LINE .. #-}@) and convert them into comments.+stripLinePragmas :: String -> (String, [Comment])+stripLinePragmas = unlines' . unzip . findLines . lines+ where+ unlines' (a, b) = (unlines a, catMaybes b)++findLines :: [String] -> [(String, Maybe Comment)]+findLines = zipWith checkLine [1..]++checkLine :: Int -> String -> (String, Maybe Comment)+checkLine line s+ | "{-# LINE" `isPrefixOf` s =+ let (pragma, res) = getPragma s+ size = length pragma+ mSrcLoc = mkSrcLoc (mkFastString "LINE")+ ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (size+1))+ in (res, Just $ mkComment pragma ss)+ -- Deal with shebang/cpp directives too+ -- x | "#" `isPrefixOf` s = ("",Just $ Comment ((line, 1), (line, length s)) s)+ | "#!" `isPrefixOf` s =+ let mSrcLoc = mkSrcLoc (mkFastString "SHEBANG")+ ss = mkSrcSpan (mSrcLoc line 1) (mSrcLoc line (length s))+ in+ ("",Just $ mkComment s ss)+ | otherwise = (s, Nothing)++getPragma :: String -> (String, String)+getPragma [] = error "Input must not be empty"+getPragma s@(x:xs)+ | "#-}" `isPrefixOf` s = ("#-}", " " ++ drop 3 s)+ | otherwise =+ let (prag, remline) = getPragma xs+ in (x:prag, ' ':remline)++-- ---------------------------------------------------------------------++-- | Replacement for original 'getRichTokenStream' which will return+-- the tokens for a file processed by CPP.+-- See bug <http://ghc.haskell.org/trac/ghc/ticket/8265>+getCppTokensAsComments :: GHC.GhcMonad m+ => CppOptions -- ^ Preprocessor Options+ -> FilePath -- ^ Path to source file+ -> m [Comment]+getCppTokensAsComments cppOptions sourceFile = do+ source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile+ let startLoc = GHC.mkRealSrcLoc (GHC.mkFastString sourceFile) 1 1+ (_txt,strSrcBuf,flags2) <- getPreprocessedSrcDirectPrim cppOptions sourceFile+ -- #ifdef tokens+ directiveToks <- GHC.liftIO $ getPreprocessorAsComments sourceFile+ -- Tokens without #ifdef+ nonDirectiveToks <- tokeniseOriginalSrc startLoc flags2 source+ case GHC.lexTokenStream strSrcBuf startLoc flags2 of+ GHC.POk _ ts ->+ do+ let toks = GHC.addSourceToTokens startLoc source ts+ cppCommentToks = getCppTokens directiveToks nonDirectiveToks toks+ return $ map (tokComment . commentToAnnotation . fst) cppCommentToks+ GHC.PFailed sspan err -> parseError flags2 sspan err++-- ---------------------------------------------------------------------++-- | Combine the three sets of tokens to produce a single set that+-- represents the code compiled, and will regenerate the original+-- source file.+-- [@directiveToks@] are the tokens corresponding to preprocessor+-- directives, converted to comments+-- [@origSrcToks@] are the tokenised source of the original code, with+-- the preprocessor directives stripped out so that+-- the lexer does not complain+-- [@postCppToks@] are the tokens that the compiler saw originally+-- NOTE: this scheme will only work for cpp in -nomacro mode+getCppTokens ::+ [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+ -> [(GHC.Located GHC.Token, String)]+getCppTokens directiveToks origSrcToks postCppToks = toks+ where+ locFn (GHC.L l1 _,_) (GHC.L l2 _,_) = compare l1 l2+ m1Toks = mergeBy locFn postCppToks directiveToks++ -- We must now find the set of tokens that are in origSrcToks, but+ -- not in m1Toks++ -- GHC.Token does not have Ord, can't use a set directly+ origSpans = map (\(GHC.L l _,_) -> l) origSrcToks+ m1Spans = map (\(GHC.L l _,_) -> l) m1Toks+ missingSpans = (Set.fromList origSpans) Set.\\ (Set.fromList m1Spans)++ missingToks = filter (\(GHC.L l _,_) -> Set.member l missingSpans) origSrcToks++ missingAsComments = map mkCommentTok missingToks+ where+ mkCommentTok :: (GHC.Located GHC.Token,String) -> (GHC.Located GHC.Token,String)+ mkCommentTok (GHC.L l _,s) = (GHC.L l (GHC.ITlineComment s),s)++ toks = mergeBy locFn directiveToks missingAsComments++-- ---------------------------------------------------------------------++tokeniseOriginalSrc ::+ GHC.GhcMonad m+ => GHC.RealSrcLoc -> GHC.DynFlags -> GHC.StringBuffer+ -> m [(GHC.Located GHC.Token, String)]+tokeniseOriginalSrc startLoc flags buf = do+ let src = stripPreprocessorDirectives buf+ case GHC.lexTokenStream src startLoc flags of+ GHC.POk _ ts -> return $ GHC.addSourceToTokens startLoc src ts+ GHC.PFailed sspan err -> parseError flags sspan err++-- ---------------------------------------------------------------------++-- | Strip out the CPP directives so that the balance of the source+-- can tokenised.+stripPreprocessorDirectives :: GHC.StringBuffer -> GHC.StringBuffer+stripPreprocessorDirectives buf = buf'+ where+ srcByLine = lines $ sbufToString buf+ noDirectivesLines = map (\line -> if line /= [] && head line == '#' then "" else line) srcByLine+ buf' = GHC.stringToStringBuffer $ unlines noDirectivesLines++-- ---------------------------------------------------------------------++sbufToString :: GHC.StringBuffer -> String+sbufToString sb@(GHC.StringBuffer _buf len _cur) = GHC.lexemeToString sb len++-- ---------------------------------------------------------------------+getPreprocessedSrcDirect :: (GHC.GhcMonad m) => CppOptions -> FilePath -> m String+getPreprocessedSrcDirect cppOptions src =+ (\(a,_,_) -> a) <$> getPreprocessedSrcDirectPrim cppOptions src++getPreprocessedSrcDirectPrim :: (GHC.GhcMonad m)+ => CppOptions+ -> FilePath+ -> m (String, GHC.StringBuffer, GHC.DynFlags)+getPreprocessedSrcDirectPrim cppOptions src_fn = do+ hsc_env <- GHC.getSession+ let dfs = GHC.extractDynFlags hsc_env+ new_env = GHC.replaceDynFlags hsc_env (injectCppOptions cppOptions dfs)+ (dflags', hspp_fn) <- GHC.liftIO $ GHC.preprocess new_env (src_fn, Nothing)+ buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn+ txt <- GHC.liftIO $ readFile hspp_fn+ return (txt, buf, dflags')++injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags+injectCppOptions CppOptions{..} dflags =+ foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile)+ where+ mkDefine = ("-D" ++)+ mkIncludeDir = ("-I" ++)+ mkInclude = ("-include" ++)+++addOptP :: String -> GHC.DynFlags -> GHC.DynFlags+addOptP f = alterSettings (\s -> s { GHC.sOpt_P = f : GHC.sOpt_P s})++alterSettings :: (GHC.Settings -> GHC.Settings) -> GHC.DynFlags -> GHC.DynFlags+alterSettings f dflags = dflags { GHC.settings = f (GHC.settings dflags) }++-- ---------------------------------------------------------------------++-- | Get the preprocessor directives as comment tokens from the+-- source.+getPreprocessorAsComments :: FilePath -> IO [(GHC.Located GHC.Token, String)]+getPreprocessorAsComments srcFile = do+ fcontents <- readFile srcFile+ let directives = filter (\(_lineNum,line) -> line /= [] && head line == '#')+ $ zip [1..] (lines fcontents)++ let mkTok (lineNum,line) = (GHC.L l (GHC.ITlineComment line),line)+ where+ start = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum 1+ end = GHC.mkSrcLoc (GHC.mkFastString srcFile) lineNum (length line)+ l = GHC.mkSrcSpan start end++ let toks = map mkTok directives+ return toks++-- ---------------------------------------------------------------------++parseError :: GHC.DynFlags -> GHC.SrcSpan -> GHC.MsgDoc -> m b+parseError dflags sspan err = do+ throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err)++-- ---------------------------------------------------------------------++-- Copied over from MissingH, the dependency cause travis to fail++{- | Merge two sorted lists using into a single, sorted whole,+allowing the programmer to specify the comparison function.++QuickCheck test property:++prop_mergeBy xs ys =+ mergeBy cmp (sortBy cmp xs) (sortBy cmp ys) == sortBy cmp (xs ++ ys)+ where types = xs :: [ (Int, Int) ]+ cmp (x1,_) (x2,_) = compare x1 x2+-}+mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy _cmp [] ys = ys+mergeBy _cmp xs [] = xs+mergeBy cmp (allx@(x:xs)) (ally@(y:ys))+ -- Ordering derives Eq, Ord, so the comparison below is valid.+ -- Explanation left as an exercise for the reader.+ -- Someone please put this code out of its misery.+ | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally+ | otherwise = y : mergeBy cmp allx ys+++
src/Language/Haskell/GHC/ExactPrint/Print.hs view
@@ -1,35 +1,40 @@-{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.GHC.ExactPrint.Print --+-- This module inverts the process performed by "Delta". Given 'Anns' and+-- a corresponding AST we produce a source file based on this information.+-- ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Print (- Anns- , exactPrintWithAnns+ exactPrintWithAnns , exactPrint ) where import Language.Haskell.GHC.ExactPrint.Types-import Language.Haskell.GHC.ExactPrint.Utils ( debug, undelta, isGoodDelta, showGhc, )+import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Annotate- (AnnotationF(..), Annotated, Annotate(..), markLocated)-import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString)+ (AnnotationF(..), Annotated, Annotate(..), annotate)+import Language.Haskell.GHC.ExactPrint.Lookup (keywordToString, unicodeString) 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 Data.List (sortBy, elemIndex)+import Data.Ord (comparing)+import Data.Maybe (fromMaybe) import Control.Monad.Trans.Free + import qualified GHC ------------------------------------------------------------------------------@@ -48,56 +53,61 @@ => GHC.Located ast -> Anns -> String-exactPrintWithAnns ast an = runEP (markLocated ast) an+exactPrintWithAnns ast an = runEP (annotate 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 EPReader = EPReader+ {+ epAnn :: !Annotation+ } data EPWriter = EPWriter- { output :: Endo String }+ { output :: !(Endo String) } instance Monoid EPWriter where mempty = EPWriter mempty- (EPWriter a) `mappend` (EPWriter c) = EPWriter (a <> c)+ (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b) +data EPState = EPState+ { epPos :: !Pos -- ^ Current output position+ , epAnns :: !Anns+ , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local state with suitable refactoring?+ , epMarkLayout :: Bool+ , epLHS :: LayoutStartCol+ }+ --------------------------------------------------------- -type EP a = RWS EPStack EPWriter EPState a+type EP a = RWS EPReader EPWriter EPState a runEP :: Annotated () -> Anns -> String runEP action ans = flip appEndo "" . output . snd- . (\next -> execRWS next initialEPStack (defaultEPState ans))+ . (\next -> execRWS next initialEPReader (defaultEPState ans)) . printInterpret $ action +-- --------------------------------------------------------------------- +defaultEPState :: Anns -> EPState+defaultEPState as = EPState+ { epPos = (1,1)+ , epAnns = as+ , epAnnKds = []+ , epLHS = 1+ , epMarkLayout = False+ } +initialEPReader :: EPReader+initialEPReader = EPReader+ {+ epAnn = annNone+ } +-- ---------------------------------------------------------------------+ printInterpret :: Annotated a -> EP a printInterpret = iterTM go where@@ -105,83 +115,121 @@ 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+ markPrim (G kwid) mstr >> next+ -- let annString = fromMaybe (keywordToString kwid) mstr in+ -- printStringAtMaybeAnn (G kwid) annString >> next go (MarkOutside _ kwid next) =- printStringAtMaybeAnnAll kwid ";" >> next+ -- markPrim kwid Nothing >> next+ let annString = keywordToString kwid in+ printStringAtMaybeAnnAll kwid annString >> 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+ let annString = fromMaybe (keywordToString (G 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 (WithAST lss action next) =+ exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = countAnnsEP (G kwid) >>= next- go (SetLayoutFlag kwid action next) =- setLayout kwid (printInterpret action) >> next+ go (SetLayoutFlag action next) =+ setLayout (printInterpret action) >> next go (MarkExternal _ akwid s next) = printStringAtMaybeAnn (G akwid) s >> next+ go (StoreOriginalSrcSpan _ next) = storeOriginalSrcSpanPrint >>= next+ go (GetSrcSpanForKw _ next) = return GHC.noSrcSpan >>= next+ go (StoreString _ _ next) =+ printStoredString >> next+ go (AnnotationsToComments _ next) = next+ go (WithSortKey ks next) = withSortKey ks >> next -justOne, allAnns :: GHC.AnnKeywordId -> EP ()-justOne kwid = printStringAtMaybeAnn (G kwid) (keywordToString kwid)-allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString kwid)+------------------------------------------------------------------------- +storeOriginalSrcSpanPrint :: EP AnnKey+storeOriginalSrcSpanPrint = do+ Ann{..} <- asks epAnn+ case annCapturedSpan of+ Nothing -> error "Missing captured SrcSpan"+ Just v -> return v++printStoredString :: EP ()+printStoredString = do+ kd <- gets epAnnKds++ let+ isAnnString (AnnString _,_) = True+ isAnnString _ = False++ case filter isAnnString (ghead "printStoredString" kd) of+ ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) ss+ _ -> return ()++withSortKey :: [(GHC.SrcSpan, Annotated ())] -> EP ()+withSortKey xs = do+ Ann{..} <- asks epAnn+ let ordered = case annSortKey of+ Nothing -> map snd xs+ Just keys -> orderByKey xs keys+ `debug` ("withSortKey:" +++ showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs),+ map fst xs,+ keys)+ )+ mapM_ printInterpret ordered+ -------------------------------------------------------------------------++allAnns :: GHC.AnnKeywordId -> EP ()+allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString (G 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+exactPC :: Data ast => GHC.Located ast -> EP a -> EP a+exactPC ast action =+ do+ return () `debug` ("exactPC entered for:" ++ show (mkAnnKey ast))+ ma <- getAndRemoveAnnotation ast+ let an@Ann{ annEntryDelta=edp+ , annPriorComments=comments+ , annFollowingComments=fcomments+ , annsDP=kds+ } = fromMaybe annNone ma+ r <- withContext kds an+ (mapM_ (uncurry printQueuedComment) comments+ >> advance edp+ >> action+ <* mapM_ (uncurry printQueuedComment) fcomments)+ return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) +advance :: DeltaPos -> EP ()+advance cl = do+ p <- getPos+ colOffset <- getLayoutOffset+ printWhitespace (undelta p cl colOffset)+ 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+getAndRemoveAnnotation a = gets ((getAnnotationEP a) . epAnns) +markPrim :: KeywordId -> Maybe String -> EP ()+markPrim kwid mstr =+ let annString = fromMaybe (keywordToString kwid) mstr+ in printStringAtMaybeAnn kwid annString+ withContext :: [(KeywordId, DeltaPos)] -> Annotation- -> LayoutFlag- -> EP LayoutFlag -> EP LayoutFlag-withContext kds an flag = withKds kds . withOffset an flag+ -> EP a -> EP a+withContext kds an = withKds kds . withOffset an -- --------------------------------------------------------------------- -- -- | 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+withOffset :: Annotation -> (EP a -> EP a)+withOffset a =+ local (\s -> s { epAnn = a }) -- ---------------------------------------------------------------------@@ -196,11 +244,13 @@ ------------------------------------------------------------------------ -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)+setLayout :: EP () -> EP ()+setLayout k = do+ oldLHS <- gets epLHS+ modify (\a -> a { epMarkLayout = True } )+ let reset = modify (\a -> a { epMarkLayout = False+ , epLHS = oldLHS } )+ k <* reset getPos :: EP Pos getPos = gets epPos@@ -210,129 +260,140 @@ -- |Get the current column offset getLayoutOffset :: EP LayoutStartCol-getLayoutOffset = asks epLHS+getLayoutOffset = gets 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))+printStringAtMaybeAnn an str = printStringAtMaybeAnnThen an str (return ()) 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+ go = printStringAtMaybeAnnThen an str go --- ---------------------------------------------------------------------+printStringAtMaybeAnnThen :: KeywordId -> String -> EP () -> EP ()+printStringAtMaybeAnnThen an str next = do+ annFinal <- getAnnFinal an+ case (annFinal, an) of+ -- Could be unicode syntax+ -- TODO: This is a bit fishy, refactor+ (Nothing, G kw) -> do+ res <- getAnnFinal (AnnUnicode kw)+ return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res))+ unless (null res) $ do+ forM_+ res+ (\(comments, ma) -> printStringAtLsDelta comments ma (unicodeString (G kw)))+ next+ (Just (comments, ma),_) -> printStringAtLsDelta comments ma str >> next+ (Nothing, _) -> return () `debug` ("printStringAtMaybeAnn:missed:(an)" ++ show an)+ -- Note: do not call next, nothing to chain+ -- ++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)) +-- --------------------------------------------------------------------- -- |destructive get, hence use an annotation once only-getAnnFinal :: KeywordId -> EP ([DComment], Maybe DeltaPos)+getAnnFinal :: KeywordId -> EP (Maybe ([(Comment, DeltaPos)], 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+ case kd of+ [] -> return Nothing -- Should never be triggered+ (k:kds) -> do+ let (res, kd') = destructiveGetFirst kw ([],k)+ modify (\s -> s { epAnnKds = kd' : kds })+ return res -- | 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 :: KeywordId+ -> ([(KeywordId, v)],[(KeywordId,v)])+ -> (Maybe ([(Comment, v)], 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)+ | k == key = (Just (skippedComments, v), others ++ kvs)+ | otherwise = destructiveGetFirst key (acc ++ [(k,v)], kvs) where- commentsAndOthers kvs' = partition isComment kvs'- isComment (AnnComment _ , _ ) = True- isComment _ = False+ (skippedComments, others) = foldr comments ([], []) acc+ comments (AnnComment comment , dp ) (cs, kws) = ((comment, dp) : cs, kws)+ comments kw (cs, kws) = (cs, kw : kws) + -- --------------------------------------------------------------------- -- |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 ()+printStringAtLsDelta :: [(Comment, DeltaPos)] -> DeltaPos -> String -> EP ()+printStringAtLsDelta cs cl s = do+ p <- getPos+ colOffset <- getLayoutOffset+ if isGoodDeltaWithOffset cl colOffset+ then do+ mapM_ (uncurry 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 (cl,s)) 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+printQueuedComment :: Comment -> DeltaPos -> EP ()+printQueuedComment Comment{commentContents} dp = 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))+ -- do not lose comments against the left margin+ when (isGoodDelta (DP (dr,max 0 dc)))+ (do+ printCommentAt (undelta p dp colOffset) commentContents+ setPos (undelta p (dp `addDP` dpFromString commentContents) colOffset)) -- --------------------------------------------------------------------- -- |non-destructive get peekAnnFinal :: KeywordId -> EP (Maybe DeltaPos) peekAnnFinal kw = do- (_, r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (head . epAnnKds)- return r+ (r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds)+ return (snd <$> r) countAnnsEP :: KeywordId -> EP Int countAnnsEP an = length <$> peekAnnFinal an -- ---------------------------------------------------------------------+++-- --------------------------------------------------------------------- -- Printing functions -printString :: String -> EP ()-printString str = do- (l,c) <- gets epPos+printString :: Bool -> String -> EP ()+printString layout str = do+ EPState{epPos = (l,c), epMarkLayout} <- get+ when (epMarkLayout && layout) (+ modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } )) setPos (l, c + length str) tell (mempty {output = Endo $ showString str }) newLine :: EP () newLine = do (l,_) <- getPos- printString "\n"+ printString False "\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 ()+ if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' '+ | l1 < l -> newLine >> padUntil (l,c)+ | otherwise -> return () printWhitespace :: Pos -> EP () printWhitespace = padUntil +printCommentAt :: Pos -> String -> EP ()+printCommentAt p str = printWhitespace p >> printString False str+ printStringAt :: Pos -> String -> EP ()-printStringAt p str = printWhitespace p >> printString str+printStringAt p str = printWhitespace p >> printString True str
+ src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -0,0 +1,736 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ViewPatterns #-}+-----------------------------------------------------------------------------+-- |+-- Module : Language.Haskell.GHC.ExactPrint.Transform+--+-- This module is currently under heavy development, and no promises are made+-- about API stability. Use with care.+--+-- We weclome any feedback / contributions on this, as it is the main point of+-- the library.+--+-----------------------------------------------------------------------------+module Language.Haskell.GHC.ExactPrint.Transform+ (+ -- * The Transform Monad+ Transform+ , runTransform++ -- * Transform monad operations+ , logTr+ , getAnnsT, putAnnsT, modifyAnnsT+ , uniqueSrcSpanT++ , wrapSigT,wrapDeclT+ , pushDeclAnnT+ , decl2BindT,decl2SigT++ , getEntryDPT+ , addSimpleAnnT++ -- ** Managing lists, Transform monad+ , HasDecls (..)+ , insertAtStart+ , insertAtEnd+ , insertAfter+ , insertBefore++ -- *** Low level operations used in 'HasDecls'+ , balanceComments+ , balanceTrailingComments+ , moveTrailingComments++ -- ** Managing lists, pure functions+ , captureOrder+ , captureOrderAnnKey++ -- * Operations+ , isUniqueSrcSpan+++ -- * Managing decls+ , declFun++ -- * Pure functions+ , mergeAnns+ , mergeAnnList+ , setPrecedingLinesDecl+ , setPrecedingLines+ , getEntryDP++ ) where++import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils++import Control.Monad.RWS+++import qualified Bag as GHC+import qualified FastString as GHC+import qualified GHC as GHC hiding (parseModule)++import qualified Data.Generics as SYB++import Data.Data++import qualified Data.Map as Map++-- import Debug.Trace++------------------------------------------------------------------------------+-- Transformation of source elements++-- | Monad type for updating the AST and managing the annotations at the same+-- time. The W state is used to generate logging information if required.+type Transform a = RWS () [String] (Anns,Int) a++-- | Run a transformation in the 'Transform' monad, returning the updated+-- annotations and any logging generated via 'logTr'+runTransform :: Anns -> Transform a -> (a,(Anns,Int),[String])+runTransform ans f = runRWS f () (ans,0)++-- |Log a string to the output of the Monad+logTr :: String -> Transform ()+logTr str = tell [str]++-- |Access the 'Anns' being modified in this transformation+getAnnsT :: Transform Anns+getAnnsT = gets fst++-- |Replace the 'Anns' after any changes+putAnnsT :: Anns -> Transform ()+putAnnsT ans = do+ (_,col) <- get+ put (ans,col)++-- |Change the stored 'Anns'+modifyAnnsT :: (Anns -> Anns) -> Transform ()+modifyAnnsT f = do+ ans <- getAnnsT+ putAnnsT (f ans)++-- ---------------------------------------------------------------------++-- |Once we have 'Anns', a 'GHC.SrcSpan' is used purely as part of an 'AnnKey'+-- to index into the 'Anns'. If we need to add new elements to the AST, they+-- need their own 'GHC.SrcSpan' for this.+uniqueSrcSpanT :: Transform GHC.SrcSpan+uniqueSrcSpanT = do+ (an,col) <- get+ put (an,col + 1 )+ let pos = GHC.mkSrcLoc (GHC.mkFastString "ghc-exactprint") (-1) col+ return $ GHC.mkSrcSpan pos pos++-- |Test whether a given 'GHC.SrcSpan' was generated by 'uniqueSrcSpanT'+isUniqueSrcSpan :: GHC.SrcSpan -> Bool+isUniqueSrcSpan ss = srcSpanStartLine ss == -1++-- ---------------------------------------------------------------------+{-+-- TODO: I suspect this may be needed in future.++-- |Make a copy of an AST element, replacing the existing SrcSpans with new+-- ones, and duplicating the matching annotations.+cloneT :: GHC.Located a -> Transform (GHC.Located a)+cloneT _ast = do+ error "Transform.cloneT undefined"+-}++-- ---------------------------------------------------------------------++-- |If a list has been re-ordered or had items added, capture the new order in+-- the appropriate 'annSortKey' attached to the 'Annotation' for the first+-- parameter.+captureOrder :: (Data a) => GHC.Located a -> [GHC.Located b] -> Anns -> Anns+captureOrder parent ls ans = captureOrderAnnKey (mkAnnKey parent) ls ans++-- |If a list has been re-ordered or had items added, capture the new order in+-- the appropriate 'annSortKey' item of the supplied 'AnnKey'+captureOrderAnnKey :: AnnKey -> [GHC.Located b] -> Anns -> Anns+captureOrderAnnKey parentKey ls ans = ans'+ where+ newList = map GHC.getLoc ls+ reList = Map.adjust (\an -> an {annSortKey = Just newList }) parentKey+ ans' = reList ans++-- ---------------------------------------------------------------------++-- |Pure function to convert a 'GHC.LHsDecl' to a 'GHC.LHsBind'. This does+-- nothing to any annotations that may be attached to either of the elements.+-- It is used as a utility function in 'replaceDecls'+decl2Bind :: GHC.LHsDecl name -> [GHC.LHsBind name]+decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s]+decl2Bind _ = []++-- |Pure function to convert a 'GHC.LSig' to a 'GHC.LHsBind'. This does+-- nothing to any annotations that may be attached to either of the elements.+-- It is used as a utility function in 'replaceDecls'+decl2Sig :: GHC.LHsDecl name -> [GHC.LSig name]+decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s]+decl2Sig _ = []++-- ---------------------------------------------------------------------++-- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl', duplicating the 'GHC.LSig'+-- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the+-- original annotation is restored after a 'pushDeclAnnT' call.+wrapSigT :: GHC.LSig GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)+wrapSigT d@(GHC.L _ s) = do+ newSpan <- uniqueSrcSpanT+ let+ f ans = case Map.lookup (mkAnnKey d) ans of+ Nothing -> ans+ Just ann ->+ Map.insert (mkAnnKey (GHC.L newSpan s)) ann+ $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.SigD s))) ann ans+ modifyAnnsT f+ return (GHC.L newSpan (GHC.SigD s))++-- ---------------------------------------------------------------------++-- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl', duplicating the 'GHC.LHsBind'+-- annotation for the 'GHC.LHsDecl'. This needs to be set up so that the+-- original annotation is restored after a 'pushDeclAnnT' call.+wrapDeclT :: GHC.LHsBind GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)+wrapDeclT d@(GHC.L _ s) = do+ newSpan <- uniqueSrcSpanT+ let+ f ans = case Map.lookup (mkAnnKey d) ans of+ Nothing -> ans+ Just ann ->+ Map.insert (mkAnnKey (GHC.L newSpan s)) ann+ $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.ValD s))) ann ans+ modifyAnnsT f+ return (GHC.L newSpan (GHC.ValD s))++-- ---------------------------------------------------------------------++-- |Copy the top level annotation to a new SrcSpan and the unwrapped decl. This+-- is required so that 'decl2Sig' and 'decl2Bind' will produce values that have+-- the required annotations.+pushDeclAnnT :: GHC.LHsDecl GHC.RdrName -> Transform (GHC.LHsDecl GHC.RdrName)+pushDeclAnnT ld@(GHC.L l decl) = do+ newSpan <- uniqueSrcSpanT+ let+ blend ann Nothing = ann+ blend ann (Just annd)+ = annd { annEntryDelta = annEntryDelta ann+ , annPriorComments = annPriorComments ann ++ annPriorComments annd+ , annFollowingComments = annFollowingComments annd ++ annFollowingComments ann+ }+ duplicateAnn d ans =+ case Map.lookup (mkAnnKey ld) ans of+ Nothing -> error $ "pushDeclAnnT:no key found for:" ++ show (mkAnnKey ld)+ -- Nothing -> Anns ans+ Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d))+ (blend ann (Map.lookup (mkAnnKey (GHC.L l d)) ans))+ ans+ case decl of+ GHC.TyClD d -> modifyAnnsT (duplicateAnn d)+ GHC.InstD d -> modifyAnnsT (duplicateAnn d)+ GHC.DerivD d -> modifyAnnsT (duplicateAnn d)+ GHC.ValD d -> modifyAnnsT (duplicateAnn d)+ GHC.SigD d -> modifyAnnsT (duplicateAnn d)+ GHC.DefD d -> modifyAnnsT (duplicateAnn d)+ GHC.ForD d -> modifyAnnsT (duplicateAnn d)+ GHC.WarningD d -> modifyAnnsT (duplicateAnn d)+ GHC.AnnD d -> modifyAnnsT (duplicateAnn d)+ GHC.RuleD d -> modifyAnnsT (duplicateAnn d)+ GHC.VectD d -> modifyAnnsT (duplicateAnn d)+ GHC.SpliceD d -> modifyAnnsT (duplicateAnn d)+ GHC.DocD d -> modifyAnnsT (duplicateAnn d)+ GHC.RoleAnnotD d -> modifyAnnsT (duplicateAnn d)+#if __GLASGOW_HASKELL__ < 711+ GHC.QuasiQuoteD d -> modifyAnnsT (duplicateAnn d)+#endif+ return (GHC.L newSpan decl)++-- ---------------------------------------------------------------------++-- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LHsBind', transferring the top+-- level annotation to a new unique 'GHC.SrcSpan' in the process.+decl2BindT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LHsBind GHC.RdrName]+decl2BindT vd@(GHC.L _ (GHC.ValD d)) = do+ newSpan <- uniqueSrcSpanT+ logTr $ "decl2BindT:newSpan=" ++ showGhc newSpan+ let+ duplicateAnn ans =+ case Map.lookup (mkAnnKey vd) ans of+ Nothing -> ans+ Just ann -> Map.insert (mkAnnKey (GHC.L newSpan d)) ann ans+ modifyAnnsT duplicateAnn+ return [GHC.L newSpan d]+decl2BindT _ = return []++-- ---------------------------------------------------------------------++-- |Unwrap a 'GHC.LHsDecl' to its underlying 'GHC.LSig', transferring the top+-- level annotation to a new unique 'GHC.SrcSpan' in the process.+decl2SigT :: GHC.LHsDecl GHC.RdrName -> Transform [GHC.LSig GHC.RdrName]+decl2SigT vs@(GHC.L _ (GHC.SigD s)) = do+ newSpan <- uniqueSrcSpanT+ logTr $ "decl2SigT:newSpan=" ++ showGhc newSpan+ let+ duplicateAnn ans =+ case Map.lookup (mkAnnKey vs) ans of+ Nothing -> ans+ Just ann -> Map.insert (mkAnnKey (GHC.L newSpan s)) ann ans+ modifyAnnsT duplicateAnn+ return [GHC.L newSpan s]+decl2SigT _ = return []++-- ---------------------------------------------------------------------++-- |Create a simple 'Annotation' without comments, and attach it to the first+-- parameter.+addSimpleAnnT :: (Data a) => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> Transform ()+addSimpleAnnT ast dp kds = do+ let ann = annNone { annEntryDelta = dp+ , annsDP = kds+ }+ modifyAnnsT (Map.insert (mkAnnKey ast) ann)++-- ---------------------------------------------------------------------++-- |'Transform' monad version of 'getEntryDP'+getEntryDPT :: (Data a) => GHC.Located a -> Transform DeltaPos+getEntryDPT ast = do+ anns <- getAnnsT+ return (getEntryDP anns ast)++-- ---------------------------------------------------------------------++-- | Left bias pair union+mergeAnns :: Anns -> Anns -> Anns+mergeAnns+ = Map.union++-- |Combine a list of annotations+mergeAnnList :: [Anns] -> Anns+mergeAnnList [] = error "mergeAnnList must have at lease one entry"+mergeAnnList (x:xs) = foldr mergeAnns x xs++-- ---------------------------------------------------------------------++-- |Unwrap a HsDecl and call setPrecedingLines on it+setPrecedingLinesDecl :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Anns -> Anns+setPrecedingLinesDecl ld n c ans =+ declFun (\a -> setPrecedingLines a n c ans) ld++declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b+declFun f (GHC.L l de) =+ case de of+ GHC.TyClD d -> f (GHC.L l d)+ GHC.InstD d -> f (GHC.L l d)+ GHC.DerivD d -> f (GHC.L l d)+ GHC.ValD d -> f (GHC.L l d)+ GHC.SigD d -> f (GHC.L l d)+ GHC.DefD d -> f (GHC.L l d)+ GHC.ForD d -> f (GHC.L l d)+ GHC.WarningD d -> f (GHC.L l d)+ GHC.AnnD d -> f (GHC.L l d)+ GHC.RuleD d -> f (GHC.L l d)+ GHC.VectD d -> f (GHC.L l d)+ GHC.SpliceD d -> f (GHC.L l d)+ GHC.DocD d -> f (GHC.L l d)+ GHC.RoleAnnotD d -> f (GHC.L l d)+#if __GLASGOW_HASKELL__ < 711+ GHC.QuasiQuoteD d -> f (GHC.L l d)+#endif++-- ---------------------------------------------------------------------++-- | Adjust the entry annotations to provide an `n` line preceding gap+setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns+setPrecedingLines ast n c anne =+ Map.alter go (mkAnnKey ast) anne+ where+ go Nothing = Just (annNone { annEntryDelta = (DP (n,c)) })+ go (Just a) = Just (a { annEntryDelta = DP (n, c) } )++-- ---------------------------------------------------------------------++-- |Return the true entry 'DeltaPos' from the annotation for a given AST+-- element. This is the 'DeltaPos' ignoring any comments.+getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos+getEntryDP anns ast =+ case Map.lookup (mkAnnKey ast) anns of+ Nothing -> DP (0,0)+ Just ann -> annTrueEntryDelta ann++-- ---------------------------------------------------------------------++-- |Prior to moving an AST element, make sure any trailing comments belonging to+-- it are attached to it, and not the following element. Of necessity this is a+-- heuristic process, to be tuned later. Possibly a variant should be provided+-- with a passed-in decision function.+balanceComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform ()+balanceComments first second = do+ let+ k1 = mkAnnKey first+ k2 = mkAnnKey second+ moveComments p ans = ans'+ where+ an1 = gfromJust "balanceComments k1" $ Map.lookup k1 ans+ an2 = gfromJust "balanceComments k2" $ Map.lookup k2 ans+ -- cs1b = annPriorComments an1+ cs1f = annFollowingComments an1+ cs2b = annPriorComments an2+ (move,stay) = break p cs2b+ an1' = an1 { annFollowingComments = cs1f ++ move}+ an2' = an2 { annPriorComments = stay}+ ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans++ simpleBreak (_,DP (r,_c)) = r > 0++ modifyAnnsT (moveComments simpleBreak)++-- ---------------------------------------------------------------------++-- |After moving an AST element, make sure any comments that may belong+-- with the following element in fact do. Of necessity this is a heuristic+-- process, to be tuned later. Possibly a variant should be provided with a+-- passed-in decision function.+balanceTrailingComments :: (Data a,Data b) => GHC.Located a -> GHC.Located b -> Transform [(Comment, DeltaPos)]+balanceTrailingComments first second = do+ let+ k1 = mkAnnKey first+ k2 = mkAnnKey second+ moveComments p ans = (ans',move)+ where+ an1 = gfromJust "balanceTrailingComments k1" $ Map.lookup k1 ans+ an2 = gfromJust "balanceTrailingComments k2" $ Map.lookup k2 ans+ cs1f = annFollowingComments an1+ (move,stay) = break p cs1f+ an1' = an1 { annFollowingComments = stay }+ an2' = an2 -- { annPriorComments = move ++ cs2b }+ -- an1' = an1 { annFollowingComments = [] }+ -- an2' = an2 { annPriorComments = cs1f ++ cs2b }+ ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans+ -- ans' = error $ "balanceTrailingComments:(k1,k2)=" ++ showGhc (k1,k2)+ -- ans' = error $ "balanceTrailingComments:(cs1b,cs1f,cs2b,annFollowingComments an2)=" ++ showGhc (cs1b,cs1f,cs2b,annFollowingComments an2)++ simpleBreak (_,DP (r,_c)) = r > 0++ -- modifyAnnsT (modifyKeywordDeltas (moveComments simpleBreak))+ ans <- getAnnsT+ let (ans',mov) = moveComments simpleBreak ans+ putAnnsT ans'+ return mov++-- ---------------------------------------------------------------------++-- |Move any 'annFollowingComments' values from the 'Annotation' associated to+-- the first parameter to that of the second.+moveTrailingComments :: (Data a,Data b)+ => GHC.Located a -> GHC.Located b -> Transform ()+moveTrailingComments first second = do+ let+ k1 = mkAnnKey first+ k2 = mkAnnKey second+ moveComments ans = ans'+ where+ an1 = gfromJust "moveTrailingComments k1" $ Map.lookup k1 ans+ an2 = gfromJust "moveTrailingComments k2" $ Map.lookup k2 ans+ cs1f = annFollowingComments an1+ cs2f = annFollowingComments an2+ an1' = an1 { annFollowingComments = [] }+ an2' = an2 { annFollowingComments = cs1f ++ cs2f }+ ans' = Map.insert k1 an1' $ Map.insert k2 an2' ans++ modifyAnnsT moveComments++-- ---------------------------------------------------------------------++insertAt :: (Data ast, HasDecls (GHC.Located ast))+ => (GHC.SrcSpan -> [GHC.SrcSpan] -> [GHC.SrcSpan])+ -> GHC.Located ast+ -> GHC.LHsDecl GHC.RdrName+ -> Transform (GHC.Located ast)+insertAt f m decl = do+ let newKey = GHC.getLoc decl+ modKey = mkAnnKey m+ newValue a@Ann{..} = a { annSortKey = f newKey <$> annSortKey }+ oldDecls <- hsDecls m+ modifyAnnsT (Map.adjust newValue modKey)++ replaceDecls m (decl : oldDecls )++insertAtStart, insertAtEnd :: (Data ast, HasDecls (GHC.Located ast))+ => GHC.Located ast+ -> GHC.LHsDecl GHC.RdrName+ -> Transform (GHC.Located ast)++insertAtStart = insertAt (:)+insertAtEnd = insertAt (\x xs -> xs ++ [x])++insertAfter, insertBefore :: (Data ast, HasDecls (GHC.Located ast))+ => GHC.Located old+ -> GHC.Located ast+ -> GHC.LHsDecl GHC.RdrName+ -> Transform (GHC.Located ast)+-- insertAfter (mkAnnKey -> k) = insertAt findAfter+insertAfter (GHC.getLoc -> k) = insertAt findAfter+ where+ findAfter x xs =+ let (fs, b:bs) = span (/= k) xs+ in fs ++ (b : x : bs)+insertBefore (GHC.getLoc -> k) = insertAt findBefore+ where+ findBefore x xs =+ let (fs, bs) = span (/= k) xs+ in fs ++ (x : bs)++-- ---------------------------------------------------------------------++class (Data t) => HasDecls t where++ -- | Return the 'GHC.HsDecl's that are directly enclosed in the+ -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl'+ -- form, even if orginating in local decls.+ hsDecls :: t -> Transform [GHC.LHsDecl GHC.RdrName]++ -- | Replace the directly enclosed decl list by the given+ -- decl list. Runs in the 'Transform' monad to be able to update list order+ -- annotations, and rebalance comments and other layout changes as needed.+ --+ -- For example, a call on replaceDecls for a wrapped 'GHC.FunBind' having no+ -- where clause will convert+ --+ -- @+ -- -- |This is a function+ -- foo = x -- comment1+ -- @+ -- in to+ --+ -- @+ -- -- |This is a function+ -- foo = x -- comment1+ -- where+ -- nn = 2+ -- @+ replaceDecls :: t -> [GHC.LHsDecl GHC.RdrName] -> Transform t++-- ---------------------------------------------------------------------++instance HasDecls GHC.ParsedSource where+ hsDecls (GHC.L _ (GHC.HsModule _mn _exps _imps decls _ _)) = return decls+ replaceDecls m@(GHC.L l (GHC.HsModule mn exps imps _decls deps haddocks)) decls+ = do+ modifyAnnsT (captureOrder m decls)+ return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks))++-- ---------------------------------------------------------------------++instance HasDecls (GHC.MatchGroup GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where+ hsDecls (GHC.MG matches _ _ _) = hsDecls matches++ replaceDecls (GHC.MG matches a r o) newDecls+ = do+ matches' <- replaceDecls matches newDecls+ return (GHC.MG matches' a r o)++-- ---------------------------------------------------------------------++instance HasDecls [GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)] where+ hsDecls ms = do+ ds <- mapM hsDecls ms+ return (concat ds)++ replaceDecls [] _ = error "empty match list in replaceDecls [GHC.LMatch GHC.Name]"+ replaceDecls ms newDecls+ = do+ -- ++AZ++: TODO: this one looks dodgy+ m' <- replaceDecls (ghead "replaceDecls" ms) newDecls+ return (m':tail ms)++-- ---------------------------------------------------------------------++instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where+ hsDecls (GHC.L _ (GHC.Match _ _ _ grhs)) = hsDecls grhs++ replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds+ = do+ -- Need to throw in a fresh where clause if the binds were empty,+ -- in the annotations.+ newBinds2 <- case binds of+ GHC.EmptyLocalBinds -> do+ let+ addWhere mkds =+ case Map.lookup (mkAnnKey m) mkds of+ Nothing -> error "wtf"+ Just ann -> Map.insert (mkAnnKey m) ann1 mkds+ where+ ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]+ }+ modifyAnnsT addWhere+ newBinds' <- mapM pushDeclAnnT newBinds+ modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')+ modifyAnnsT (setPrecedingLinesDecl (ghead "LMatch.replaceDecls" newBinds') 1 4)+ return newBinds'++ _ -> do+ -- ++AZ++ TODO: move the duplicate code out of the case statement+ newBinds' <- mapM pushDeclAnnT newBinds+ modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds')+ return newBinds'++ binds' <- replaceDecls binds newBinds2+ return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds')))++-- ---------------------------------------------------------------------++instance HasDecls (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where+ hsDecls (GHC.GRHSs _ lb) = hsDecls lb++ replaceDecls (GHC.GRHSs rhss b) new+ = do+ b' <- replaceDecls b new+ return (GHC.GRHSs rhss b')++-- ---------------------------------------------------------------------++instance HasDecls (GHC.HsLocalBinds GHC.RdrName) where+ hsDecls lb = case lb of+ GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do+ bds <- mapM wrapDeclT (GHC.bagToList bs)+ sds <- mapM wrapSigT sigs+ -- ++AZ++ TODO: return in annotated order+ return (bds ++ sds)+ GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid"+ GHC.HsIPBinds _ -> return []+ GHC.EmptyLocalBinds -> return []++ replaceDecls (GHC.HsValBinds _b) new+ = do+ let decs = GHC.listToBag $ concatMap decl2Bind new+ let sigs = concatMap decl2Sig new+ return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))++ replaceDecls (GHC.HsIPBinds _b) _new = error "undefined replaceDecls HsIPBinds"++ replaceDecls (GHC.EmptyLocalBinds) new+ = do+ let newBinds = map decl2Bind new+ newSigs = map decl2Sig new+ ans <- getAnnsT+ logTr $ "replaceDecls:newBinds=" ++ showAnnData ans 0 newBinds+ let decs = GHC.listToBag $ concat newBinds+ let sigs = concat newSigs+ return (GHC.HsValBinds (GHC.ValBindsIn decs sigs))++-- ---------------------------------------------------------------------++instance HasDecls (GHC.LHsExpr GHC.RdrName) where+ hsDecls (GHC.L _ (GHC.HsLet decls _ex)) = hsDecls decls+ hsDecls _ = return []++ replaceDecls (GHC.L l (GHC.HsLet decls ex)) newDecls+ = do+ decls' <- replaceDecls decls newDecls+ return (GHC.L l (GHC.HsLet decls' ex))+ replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GHC.RdrName) undefined for:" ++ showGhc old++-- ---------------------------------------------------------------------++instance HasDecls (GHC.LHsBinds GHC.RdrName) where+ hsDecls binds = hsDecls $ GHC.bagToList binds+ replaceDecls old _new = error $ "replaceDecls (GHC.LHsBinds name) undefined for:" ++ (showGhc old)++-- ---------------------------------------------------------------------++instance HasDecls [GHC.LHsBind GHC.RdrName] where+ hsDecls bs = mapM wrapDeclT bs++ replaceDecls _bs newDecls+ = do+ return $ concatMap decl2Bind newDecls++-- ---------------------------------------------------------------------++instance HasDecls (GHC.LHsBind GHC.RdrName) where+ hsDecls (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsDecls matches+ hsDecls (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsDecls rhs+ hsDecls (GHC.L _ (GHC.VarBind _ rhs _)) = hsDecls rhs+ hsDecls (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsDecls binds+ hsDecls (GHC.L _ (GHC.PatSynBind _)) = error "hsDecls: PatSynBind to implement"+++ replaceDecls (GHC.L l fn@(GHC.FunBind a b (GHC.MG matches f g h) c d e)) newDecls+ = do+ matches' <- replaceDecls matches newDecls+ case matches' of+ [] -> return () -- Should be impossible+ ms -> do+ case (GHC.grhssLocalBinds $ GHC.m_grhss $ GHC.unLoc $ last matches) of+ GHC.EmptyLocalBinds -> do+ -- only move the comment if the original where clause was empty.+ toMove <- balanceTrailingComments (GHC.L l (GHC.ValD fn)) (last matches')+ insertCommentBefore (mkAnnKey $ last ms) toMove (matchApiAnn GHC.AnnWhere)+ lbs -> do+ decs <- hsDecls lbs+ balanceComments (last decs) (GHC.L l (GHC.ValD fn))+ return (GHC.L l (GHC.FunBind a b (GHC.MG matches' f g h) c d e))++ replaceDecls (GHC.L l (GHC.PatBind a rhs b c d)) newDecls+ = do+ rhs' <- replaceDecls rhs newDecls+ return (GHC.L l (GHC.PatBind a rhs' b c d))+ replaceDecls (GHC.L l (GHC.VarBind a rhs b)) newDecls+ = do+ rhs' <- replaceDecls rhs newDecls+ return (GHC.L l (GHC.VarBind a rhs' b))+ replaceDecls (GHC.L l (GHC.AbsBinds a b c d binds)) newDecls+ = do+ binds' <- replaceDecls binds newDecls+ return (GHC.L l (GHC.AbsBinds a b c d binds'))+ replaceDecls (GHC.L _ (GHC.PatSynBind _)) _ = error "replaceDecls: PatSynBind to implement"++-- ---------------------------------------------------------------------++instance HasDecls (GHC.LHsDecl GHC.RdrName) where+ hsDecls (GHC.L l (GHC.ValD d)) = hsDecls (GHC.L l d)+ -- hsDecls (GHC.L l (GHC.SigD d)) = hsDecls (GHC.L l d)+ hsDecls _ = return []++ replaceDecls (GHC.L l (GHC.ValD d)) newDecls = do+ (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls+ return (GHC.L l1 (GHC.ValD d1))+ -- replaceDecls (GHC.L l (GHC.SigD d)) newDecls = do+ -- (GHC.L l1 d1) <- replaceDecls (GHC.L l d) newDecls+ -- return (GHC.L l1 (GHC.SigD d1))+ replaceDecls _d _ = error $ "LHsDecl.replaceDecls:not implemented"++-- ---------------------------------------------------------------------++matchApiAnn :: GHC.AnnKeywordId -> (KeywordId,DeltaPos) -> Bool+matchApiAnn mkw (kw,_)+ = case kw of+ (G akw) -> mkw == akw+ _ -> False+++-- We comments extracted from annPriorComments or annFollowingComments, which+-- need to move to just before the item identified by the predicate, if it+-- fires, else at the end of the annotations.+insertCommentBefore :: AnnKey -> [(Comment, DeltaPos)]+ -> ((KeywordId, DeltaPos) -> Bool) -> Transform ()+insertCommentBefore key toMove p = do+ let+ doInsert ans =+ case Map.lookup key ans of+ Nothing -> error $ "insertCommentBefore:no AnnKey for:" ++ showGhc key+ Just ann -> Map.insert key ann' ans+ where+ (before,after) = break p (annsDP ann)+ -- ann' = error $ "insertCommentBefore:" ++ showGhc (before,after)+ ann' = ann { annsDP = before ++ (map comment2dp toMove) ++ after}++ modifyAnnsT doInsert
src/Language/Haskell/GHC/ExactPrint/Types.hs view
@@ -1,36 +1,32 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE UndecidableInstances #-} -- for GHC.DataId+{-# LANGUAGE NamedFieldPuns #-} module Language.Haskell.GHC.ExactPrint.Types- (- Comment(..)- , DComment(..)- , Pos- , Span- , PosToken- , DeltaPos(..)- , LayoutStartCol(..) , ColDelta(..)+ ( -- * Core Types+ Anns+ , emptyAnns , Annotation(..)- , combineAnns , annNone- , Anns,AnnKey(..)+ , KeywordId(..)+ , Comment(..)+ -- * Positions+ , Pos+ , DeltaPos(..)+ , deltaRow, deltaColumn+ -- * AnnKey+ , AnnKey(..) , mkAnnKey , AnnConName(..) , annGetConstr-- , ResTyGADTHook(..)-- , getAnnotationEP- , getAndRemoveAnnotationEP-- , LayoutFlag(..)+ -- * Internal Types+ , LayoutStartCol(..) ) where import Data.Data (Data, Typeable, toConstr) +import qualified DynFlags as GHC import qualified GHC import qualified Outputable as GHC @@ -38,100 +34,131 @@ -- --------------------------------------------------------------------- --- | A Haskell comment.-data Comment = Comment Span String- deriving (Eq,Show,Typeable,Data)+-- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted+-- from an @AnnKeywordId@ because the annotation must be interleaved into the+-- stream and does not have a well-defined position+data Comment = Comment+ {+ commentContents :: !String -- ^ The contents of the comment including separators+ , commentIdentifier :: !GHC.SrcSpan -- ^ Needed to uniquely identify two comments with the same contents+ , commentOrigin :: !(Maybe GHC.AnnKeywordId) -- ^ We sometimes turn syntax into comments in order to process them properly.+ }+ deriving (Eq,Show,Typeable,Data, Ord) instance GHC.Outputable Comment where ppr x = GHC.text (show x) --- |Delta version of the comment.-data DComment = DComment (DeltaPos,DeltaPos) String- deriving (Eq,Show,Typeable,Data,Ord)--instance Ord Comment where- compare (Comment p1 _) (Comment p2 _) = compare p1 p2--type PosToken = (GHC.Located GHC.Token, String)- type Pos = (Int,Int)-type Span = (Pos,Pos) +-- | A relative positions, row then column newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Typeable,Data) +deltaRow, deltaColumn :: DeltaPos -> Int+deltaRow (DP (r, _)) = r+deltaColumn (DP (_, c)) = c++ -- | 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)+ deriving (Eq, Num) -annNone :: Annotation-annNone = Ann (DP (0,0)) 0 []+instance Show LayoutStartCol where+ show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" -combineAnns :: Annotation -> Annotation -> Annotation-combineAnns (Ann ed1 c1 dps1) (Ann _ed2 _c2 dps2)- = Ann ed1 c1 (dps1 ++ dps2) +annNone :: Annotation+annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing+ data Annotation = Ann {- 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.+ annEntryDelta :: !DeltaPos+ -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior+ -- output was, including all annPriorComments (field below).+ , annPriorComments :: ![(Comment, DeltaPos)]+ -- ^ Comments coming after the last non-comment output of the preceding+ -- element but before the SrcSpan being annotated by this Annotation. If+ -- these are changed then annEntryDelta (field above) must also change to+ -- match.+ , annFollowingComments :: ![(Comment, DeltaPos)]+ -- ^ Comments coming after the last output for the element subject to this+ -- Annotation. These will only be added by AST transformations, and care+ -- must be taken not to disturb layout of following elements.+ , annsDP :: ![(KeywordId, DeltaPos)]+ -- ^ Annotations associated with this element.+ , annSortKey :: !(Maybe [GHC.SrcSpan])+ -- ^ Captures the sort order of sub elements. This is needed when the+ -- sub-elements have been split (as in a HsLocalBind which holds separate+ -- binds and sigs) or for infix patterns where the order has been+ -- re-arranged. It is captured explicitly so that after the Delta phase a+ -- SrcSpan is used purely as an index into the annotations, allowing+ -- transformations of the AST including the introduction of new Located+ -- items or re-arranging existing ones.+ , annCapturedSpan :: !(Maybe AnnKey)+ -- ^ Occasionally we must calculate a SrcSpan for an unlocated list of+ -- elements which we must remember for the Print phase. e.g. the statements+ -- in a HsLet or HsDo. These must be managed as a group because they all+ -- need eo be vertically aligned for the Haskell layout rules, and this+ -- guarantees this property in the presence of AST edits. } deriving (Typeable,Eq) instance Show Annotation where- show (Ann dp c ans) = "(Ann (" ++ show dp ++ ") " ++ show c ++ " " ++ " " ++ show ans ++ ")"+ show (Ann dp comments fcomments ans sk csp)+ = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " "+ ++ show fcomments ++ " "+ ++ show ans ++ " " ++ showGhc sk ++ " "+ ++ showGhc csp ++ ")" -instance Monoid Annotation where- mempty = annNone- mappend = combineAnns +-- | This structure holds a complete set of annotations for an AST type Anns = Map.Map AnnKey Annotation +emptyAnns :: Anns+emptyAnns = Map.empty+ -- | For every @Located a@, use the @SrcSpan@ and constructor name of -- a as the key, to store the standard annotation. -- These are used to maintain context in the AP and EP monads data AnnKey = AnnKey GHC.SrcSpan AnnConName- deriving (Eq, Show, Ord)+ deriving (Eq, Ord) +-- More compact Show instance+instance Show AnnKey where+ show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn+ mkAnnKey :: (Data a) => GHC.Located a -> AnnKey mkAnnKey (GHC.L l a) = AnnKey l (annGetConstr a) + -- Holds the name of a constructor data AnnConName = CN { unConName :: String }- deriving (Eq,Show,Ord)+ deriving (Eq,Ord) +-- More compact show instance+instance Show AnnConName where+ show (CN s) = "CN " ++ show s+ annGetConstr :: (Data a) => a -> AnnConName annGetConstr a = CN (show $ toConstr a) --- |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.-data KeywordId = G GHC.AnnKeywordId- | AnnSemiSep- | AnnComment DComment- | AnnList GHC.SrcSpan -- ^ In some circumstances we- -- need to annotate a list of- -- statements (e.g. HsDo) and- -- must synthesise a SrcSpan to- -- hang the annotations off. This- -- needs to be preserved so that- -- exactPC can find it, after- -- potential AST edits.- deriving (Eq,Show,Ord)--data LayoutFlag = LayoutRules | NoLayoutRules deriving (Show, Eq)+-- | The different syntactic elements which are not represented in the+-- AST.+data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword+ | AnnSemiSep -- ^ A seperating comma+ | AnnComment Comment+ | AnnString String -- ^ Used to pass information from+ -- Delta to Print when we have to work+ -- out details from the original+ -- SrcSpan.+ | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible.+ deriving (Eq,Ord) -instance Monoid LayoutFlag where- mempty = NoLayoutRules- LayoutRules `mappend` _ = LayoutRules- _ `mappend` LayoutRules = LayoutRules- _ `mappend` _ = NoLayoutRules+instance Show KeywordId where+ show (G gc) = "(G " ++ show gc ++ ")"+ show AnnSemiSep = "AnnSemiSep"+ show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")"+ show (AnnString s) = "(AnnString " ++ s ++ ")"+ show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")" -- --------------------------------------------------------------------- @@ -152,28 +179,12 @@ -- --------------------------------------------------------------------- --- ResTyGADT has a SrcSpan for the original sigtype, we need to create--- a type for exactPC and annotatePC-data ResTyGADTHook name = ResTyGADTHook [GHC.LHsTyVarBndr name]- deriving (Typeable)-deriving instance (GHC.DataId name) => Data (ResTyGADTHook name)-deriving instance (Show (GHC.LHsTyVarBndr name)) => Show (ResTyGADTHook name) -instance (GHC.OutputableBndr name) => GHC.Outputable (ResTyGADTHook name) where- ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs- -- --------------------------------------------------------------------- -getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation-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) annotations- = let key = AnnKey ss (annGetConstr a) in- case Map.lookup key annotations of- Nothing -> (Nothing, annotations)- Just av -> (Just av, Map.delete key annotations)+-- Duplicated here so it can be used in show instances+showGhc :: (GHC.Outputable a) => a -> String+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags -- ---------------------------------------------------------------------+
src/Language/Haskell/GHC/ExactPrint/Utils.hs view
@@ -1,46 +1,66 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-} module Language.Haskell.GHC.ExactPrint.Utils (+ -- * Manipulating Positons+ ss2pos+ , ss2posEnd+ , undelta+ , isPointSrcSpan+ , pos2delta+ , ss2delta+ , addDP+ , spanLength+ , isGoodDelta - srcSpanStartLine+ -- * Manipulating Comments+ , mkComment+ , mkKWComment+ , dpFromString+ , comment2dp++ -- * GHC Functions+ , srcSpanStartLine , srcSpanEndLine , srcSpanStartColumn , srcSpanEndColumn-- , ss2span- , ss2pos- , ss2posEnd- , span2ss- , undelta , rdrName2String , isSymbolRdrName- , deltaFromSrcSpans- , ghcCommentText- , isPointSrcSpan- , ss2deltaP- , isGoodDelta-+ , tokComment , isListComp - , showGhc- , showAnnData + -- * Manipulating Annotations+ , getAnnotationEP+ , annTrueEntryDelta + -- * General Utility+ , orderByKey+++ -- * For tests , debug , debugM , warn+ , showGhc+ , showAnnData + -- AZ's baggage+ , ghead,glast,gtail,gfromJust ) where -import Control.Monad (when)+import Control.Monad.State import Data.Data (Data, toConstr, showConstr, cast) import Data.Generics (extQ, ext1Q, ext2Q, gmapQ)-import Data.List (intercalate)+import Data.List (intercalate, sortBy, elemIndex)+import Data.Ord (comparing) import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Lookup + import qualified GHC import qualified Bag as GHC import qualified DynFlags as GHC@@ -53,6 +73,12 @@ import qualified OccName(occNameString) +import Control.Arrow++--import qualified Data.Generics as SYB++import qualified Data.Map as Map+ import Debug.Trace -- ---------------------------------------------------------------------@@ -72,27 +98,30 @@ debugM :: Monad m => String -> m () debugM s = when debugEnabledFlag $ traceM s +-- | Show a GHC.Outputable structure+showGhc :: (GHC.Outputable a) => a -> String+showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags+ -- --------------------------------------------------------------------- warn :: c -> String -> c -- warn = flip trace warn c _ = c +-- | A good delta has no negative values. 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 +-- | Create a delta from the current position to the start of the given+-- @SrcSpan@. ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos-ss2delta ref ss = ss2deltaP ref (ss2pos ss)+ss2delta ref ss = pos2delta 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)+pos2delta :: Pos -> Pos -> DeltaPos+pos2delta (refl,refc) (l,c) = DP (lo,co) where lo = l - refl co = if lo == 0 then c - refc@@ -106,6 +135,15 @@ fl = l + dl fc = if dl == 0 then c + dc else co + dc+-- | Add together two @DeltaPos@ taking into account newlines+--+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0,3)+-- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5)+-- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3)+addDP :: DeltaPos -> DeltaPos -> DeltaPos+addDP (DP (a, b)) (DP (c, d)) =+ if c >= 1 then DP (a+c, d)+ else DP (a, b + d) -- --------------------------------------------------------------------- @@ -115,9 +153,6 @@ 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@@ -134,19 +169,26 @@ srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s srcSpanStartLine _ = 0 --- ---------------------------------------------------------------------+spanLength :: GHC.SrcSpan -> Int+spanLength = (-) <$> srcSpanEndColumn <*> srcSpanStartColumn -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)+-- ---------------------------------------------------------------------+-- | Checks whether a SrcSpan has zero length.+isPointSrcSpan :: GHC.SrcSpan -> Bool+isPointSrcSpan = (== 0 ) . spanLength -- --------------------------------------------------------------------- -isPointSrcSpan :: GHC.SrcSpan -> Bool-isPointSrcSpan ss = s == e where (s,e) = ss2span ss+-- |Given a list of items and a list of keys, returns a list of items+-- ordered by their position in the list of keys.+orderByKey :: [(GHC.SrcSpan,a)] -> [GHC.SrcSpan] -> [a]+orderByKey keys order+ -- AZ:TODO: if performance becomes a problem, consider a Map of the order+ -- SrcSpan to an index, and do a lookup instead of elemIndex. + -- Items not in the ordering are placed to the start+ = map snd (sortBy (comparing (flip elemIndex order . fst)) keys)+ -- --------------------------------------------------------------------- isListComp :: GHC.HsStmtContext name -> Bool@@ -174,8 +216,41 @@ 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 ++ "-}"+ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = s +tokComment :: GHC.Located GHC.AnnotationComment -> Comment+tokComment t@(GHC.L lt _) = mkComment (ghcCommentText t) lt++mkComment :: String -> GHC.SrcSpan -> Comment+mkComment c ss = Comment c ss Nothing++-- | Makes a comment which originates from a specific keyword.+mkKWComment :: GHC.AnnKeywordId -> GHC.SrcSpan -> Comment+mkKWComment kw ss = Comment (keywordToString $ G kw) ss (Just kw)++comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos)+comment2dp = first AnnComment++getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation+getAnnotationEP la as =+ Map.lookup (mkAnnKey la) as++-- | The "true entry" is the distance from the last concrete element to the+-- start of the current element.+annTrueEntryDelta :: Annotation -> DeltaPos+annTrueEntryDelta Ann{annEntryDelta, annPriorComments} =+ foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments )+ `addDP` annEntryDelta++-- | Calculates the distance from the start of a string to the end of+-- a string.+dpFromString :: String -> DeltaPos+dpFromString xs = dpFromString' xs 0 0+ where+ dpFromString' "" line col = DP (line, col)+ dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0+ dpFromString' (_:cs) line col = dpFromString' cs line (col + 1)+ -- --------------------------------------------------------------------- isSymbolRdrName :: GHC.RdrName -> Bool@@ -187,23 +262,18 @@ 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"+ GHC.Unqual occ -> GHC.occNameString occ+ GHC.Qual modname occ -> GHC.moduleNameString modname ++ "."+ ++ GHC.occNameString occ+ GHC.Orig _ occ -> GHC.occNameString occ+ GHC.Exact _ -> error $ "GHC.Exact introduced after renaming" ++ showGhc r 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.+-- | Show a GHC AST with interleaved Annotation information. showAnnData :: Data a => Anns -> Int -> a -> String showAnnData anns n = generic -- `ext1Q` located@@ -269,7 +339,28 @@ -- --------------------------------------------------------------------- ++ -- ---------------------------------------------------------------------+ 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 :: String -> Maybe a -> a+gfromJust _info (Just h) = h+gfromJust info Nothing = error $ "gfromJust " ++ info ++ " Nothing"
+ tests/Roundtrip.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import System.FilePath++import Data.List hiding (find)++import System.Exit++import System.Directory++import Test.HUnit++import System.FilePath.Find++import Debug.Trace+import Control.Monad+import System.Environment++import qualified Data.Set as S++import Test.Common++import System.IO.Temp+import System.IO (hClose, hPutStr)+++data Verbosity = Debug | Status | None deriving (Eq, Show, Ord, Enum)++verb :: Verbosity+verb = Debug++cppFile, parseFailFile, processed :: String+cppFile = "cpp.txt"+parseFailFile = "pfail.txt"+processed = "processed.txt"++writeCPP :: FilePath -> IO ()+writeCPP fp = appendFile cppFile (('\n' : fp))++writeParseFail :: FilePath -> String -> IO ()+writeParseFail fp s = appendFile parseFailFile (('\n' : (fp ++ " " ++ s)))++writeProcessed :: FilePath -> IO ()+writeProcessed fp = appendFile processed (('\n' : fp))++++main :: IO ()+main = do+ as <- getArgs+ case as of+ [] -> putStrLn "Must enter directory to process"+ ["failures"] -> do+ fs <- lines <$> readFile "origfailures.txt"+ () <$ runTests (TestList (map mkParserTest fs))+ ["clean"] -> do+ putStrLn "Cleaning..."+ writeFile "processed.txt" ""+ writeFile "pfail.txt" ""+ writeFile "cpp.txt" ""+ removeDirectoryRecursive "tests/roundtrip"+ createDirectory "tests/roundtrip"+ putStrLn "Done."+ ds -> () <$ (runTests =<< (TestList <$> mapM tests ds))++runTests :: Test -> IO Counts+runTests t = do+ let n = testCaseCount t+ putStrLn $ "Running " ++ show n ++ " tests."+ putStrLn $ "Verbosity: " ++ show verb+ runTestTT t++tests :: FilePath -> IO Test+tests dir = do+ done <- S.fromList . lines <$> readFile processed+ roundTripHackage done dir++-- Selection:++-- Given base directory finds all haskell source files+findSrcFiles :: FilePath -> IO [FilePath]+findSrcFiles = find filterDirectory filterFilename++filterDirectory :: FindClause Bool+filterDirectory =+ p <$> fileName+ where+ p x+ | "." `isPrefixOf` x = False+ | otherwise = True++filterFilename :: FindClause Bool+filterFilename = do+ ext <- extension+ fname <- fileName+ return (ext == ".hs" && p fname)+ where+ p x+ | "refactored" `isInfixOf` x = False+ | "Setup.hs" `isInfixOf` x = False+ | "HLint.hs" `isInfixOf` x = False -- HLint config files+ | otherwise = True++-- Hackage dir+roundTripHackage :: S.Set String -> FilePath -> IO Test+roundTripHackage done hackageDir = do+ packageDirs <- drop 2 <$> getDirectoryContents hackageDir+ when (verb <= Debug) (traceShowM packageDirs)+ TestList <$> mapM (roundTripPackage done) (zip [0..] (map (hackageDir </>) packageDirs))+++roundTripPackage :: S.Set String -> (Int, FilePath) -> IO Test+roundTripPackage done (n, dir) = do+ putStrLn (show n)+ when (verb <= Status) (traceM dir)+ hsFiles <- filter (flip S.notMember done) <$> findSrcFiles dir++ return (TestLabel (dropFileName dir) (TestList $ map mkParserTest hsFiles))++mkParserTest :: FilePath -> Test+mkParserTest fp =+ TestCase (do r <- either (\(ParseFailure _ s) -> exitFailure) return+ =<< roundTripTest fp+ writeProcessed fp+ unless (status r == Success) (writeFailure fp (debugTxt r))+ assertBool fp (status r == Success))+++writeFailure :: FilePath -> String -> IO ()+writeFailure fp db = do+ let outdir = "tests" </> "roundtrip"+ outname = takeFileName fp <.> "out"+ (fname, handle) <- openTempFile outdir outname+ (hPutStr handle db >> hClose handle)
+ tests/Static.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE ViewPatterns #-}+module Main where++-- Static site generator for failing tests+import Data.Algorithm.Diff (getDiff)+import Data.Algorithm.DiffOutput (ppDiff)++import System.Directory+import System.FilePath++import Control.Monad++import Debug.Trace++import Data.List+import System.Environment+import Data.Maybe+import Text.Read++main :: IO ()+main = do+ n <- getArgs+ case readMaybe =<< listToMaybe n of+ Nothing -> site 100+ Just k -> site k++site :: Int -> IO ()+site n = do+ putStrLn $ "Generating site for first: " ++ show n+ failPaths <- filterM doesFileExist =<< (map ("tests/roundtrip" </>) . take n <$> getDirectoryContents "tests/roundtrip")+ traceShowM failPaths+ fails <- mapM parseFail failPaths+ writeFile "origfailures.txt" (intercalate "\n" (map getfname fails))+ writeFile "failures/failures.html" (makeIndex failPaths)+ let padded = "failures.html" : (map makeFailLink failPaths ++ ["failures.html"])+ let resolved = zipWith (\x (y,z) -> (x, y, z)) padded (zip (tail padded) (tail (tail padded)))+ mapM_ (uncurry page) (zip resolved fails)++makeFailLink :: FilePath -> String+makeFailLink fp = takeFileName fp <.> "html"++makeIndex :: [FilePath] -> String+makeIndex files =+ intercalate "</br>" (map mkIndexLink files)+ where+ mkIndexLink f = mkLink (takeFileName f <.> "html") f++++page :: (FilePath, FilePath, FilePath) -> Failure -> IO ()+page (prev, out, next) (Failure res fname) = do+-- traceM out+ original <- readFile fname+ let diff = getDiff (tokenize original) (tokenize res)+ let l = length (lines res)+ if (l > 50000)+ then putStrLn ("Skipping: " ++ fname) >> print l+ else+ writeFile ("failures" </> out) (mkPage (ppDiff diff) prev next original res)+ where+ tokenize :: String -> [[String]]+ tokenize s = map (:[]) . lines $ s++mkPage :: String -> String -> String -> String -> String -> String+mkPage diff prev next original printed =+ intercalate "</br>"+ [mkLink prev "prev"+ , mkLink "failures.html" "home"+ , mkLink next "next"+ , ""+ , "<pre>" ++ diff ++ "</pre>"+ , "<h2>original</h2>"+ , "<pre>" ++ original ++ "</pre>"+ , "<h2>printed</h2>"+ , "<pre>" ++ printed ++ "</pre>"+ ]++mkLink :: String -> String -> String+mkLink s label =+ "<a href=\"" ++ s ++ "\">" ++ label ++ "</a>"++data Failure = Failure String FilePath++getfname (Failure _ fp) = fp++parseFail :: FilePath -> IO Failure+parseFail fp = do+ res <- lines <$> readFile fp+ let (finalres, head . tail -> fname) = break (=="==============") res+ return (Failure (unlines finalres) fname)+
tests/Test.hs view
@@ -1,188 +1,282 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# 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.Utils-import Language.Haskell.GHC.ExactPrint.Types---import GHC.Paths ( libdir )-+import Language.Haskell.GHC.ExactPrint.Utils (showGhc) -import qualified DynFlags as GHC-import qualified FastString as GHC-import qualified GHC as GHC-import qualified HscTypes as GHC-import qualified MonadUtils as GHC-import qualified OccName as GHC-import qualified Outputable as GHC-import qualified RdrName as GHC-import qualified StringBuffer as GHC+import qualified FastString as GHC+import qualified GHC as GHC -import qualified Data.Generics as SYB-import qualified GHC.SYB.Utils as SYB+-- import qualified Data.Generics as SYB+-- import qualified GHC.SYB.Utils as SYB -import Data.IORef-import Control.Exception import Control.Monad import System.Directory import System.FilePath import System.IO import System.Exit-import qualified Data.Map as Map +import Data.List++import System.IO.Silently++import Test.Common+import Test.Transform+ import Test.HUnit -import Control.Applicative-import Data.List (partition) --- ---------------------------------------------------------------------+-- import Debug.Trace -ghead :: String -> [a] -> a-ghead s [] = error ("Empty list at: " ++ s)-ghead s (x:xs) = x+-- --------------------------------------------------------------------- main :: IO ()-main = do- cnts <- runTestTT tests+main = hSilence [stderr] $ do+ cnts <- fst <$> runTestText (putTextToHandle stdout True) tests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure else return () -- exitSuccess --- tests = TestCase (do r <- manipulateAstTest "examples/LetStmt.hs" "Layout.LetStmt"--- assertBool "test" r )+-- --------------------------------------------------------------------- tests :: Test-tests = TestList+tests = TestList $ [- mkTestMod "LetStmt.hs" "Layout.LetStmt"- , mkTestMod "LetExpr.hs" "LetExpr"- , mkTestMod "ExprPragmas.hs" "ExprPragmas"- , mkTestMod "ListComprehensions.hs" "Main"- , mkTestMod "MonadComprehensions.hs" "Main"- , mkTestMod "FunDeps.hs" "Main"- , mkTestMod "ImplicitParams.hs" "Main"- , mkTestMod "RecursiveDo.hs" "Main"- , mkTestMod "TypeFamilies.hs" "Main"- , mkTestMod "MultiParamTypeClasses.hs" "Main"+ mkTestMod "AddAndOr3.hs" "AddAndOr3"+ , mkTestMod "AltsSemis.hs" "Main"+ , mkTestMod "Ann01.hs" "Ann01"+ , mkTestMod "Annotations.hs" "Annotations"+ , mkTestMod "Arrow.hs" "Arrow"+ , mkParserTest "Arrows.hs"+ , mkTestMod "Associated.hs" "Main"+ , mkTestMod "B.hs" "Main"+ , mkTestMod "C.hs" "C"+ , mkTestMod "BCase.hs" "Main"+ , mkTestMod "BangPatterns.hs" "Main"+ , mkTestMod "Cg008.hs" "Cg008"+ , mkTestMod "DataDecl.hs" "Main" , mkTestMod "DataFamilies.hs" "DataFamilies"- , mkTestMod "Deriving.hs" "Main"+ , mkTestMod "Dead1.hs" "Dead1" , mkTestMod "Default.hs" "Main"- , mkTestMod "ForeignDecl.hs" "ForeignDecl"- , mkTestMod "Warning.hs" "Warning"- , mkTestMod "Annotations.hs" "Annotations"+ , mkTestMod "Deriving.hs" "Main"+ , mkParserTest "DerivingOC.hs" , mkTestMod "DocDecls.hs" "DocDecls"- , mkTestModTH "QuasiQuote.hs" "QuasiQuote"- , mkTestMod "Roles.hs" "Roles"- , mkTestMod "Splice.hs" "Splice"+ , mkTestMod "DocDecls.hs" "DocDecls"+ , mkTestMod "EmptyMostly.hs" "EmptyMostly"+ , mkTestMod "EmptyMostlyInst.hs" "EmptyMostlyInst"+ , mkTestMod "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"+ , mkTestMod "Existential.hs" "Main"+ , mkTestMod "ExprPragmas.hs" "ExprPragmas"+ , mkTestMod "ExtraConstraints1.hs" "ExtraConstraints1"+ , mkTestMod "ForAll.hs" "ForAll"+ , mkTestMod "ForeignDecl.hs" "ForeignDecl"+ , mkTestMod "FromUtils.hs" "Main"+ , mkTestMod "FunDeps.hs" "Main"+ , mkTestMod "FunctionalDeps.hs" "Main"+ , mkTestMod "GenericDeriving.hs" "Main"+ , mkTestMod "Guards.hs" "Main"+ , mkTestMod "HsDo.hs" "HsDo"+ , mkTestMod "IfThenElse1.hs" "Main"+ , mkTestMod "IfThenElse2.hs" "Main"+ , mkTestMod "IfThenElse3.hs" "Main"+ , mkTestMod "ImplicitParams.hs" "Main" , mkTestMod "ImportsSemi.hs" "ImportsSemi"- , mkTestMod "Stmts.hs" "Stmts"+ , mkTestMod "Infix.hs" "Main"+ , mkTestMod "LayoutIn1.hs" "LayoutIn1"+ , mkTestMod "LayoutIn3.hs" "LayoutIn3"+ , mkTestMod "LayoutIn3a.hs" "LayoutIn3a"+ , mkTestMod "LayoutIn3b.hs" "LayoutIn3b"+ , mkTestMod "LayoutIn4.hs" "LayoutIn4"+ , mkTestMod "LayoutLet.hs" "Main"+ , mkTestMod "LayoutLet2.hs" "LayoutLet2"+ , mkTestMod "LayoutLet3.hs" "LayoutLet3"+ , mkTestMod "LayoutLet4.hs" "LayoutLet4"+ , mkTestMod "LayoutWhere.hs" "Main"+ , mkTestMod "LetExpr.hs" "LetExpr"+ , mkTestMod "LetExprSemi.hs" "LetExprSemi"+ , mkTestMod "LetIn1.hs" "LetIn1"+ , mkTestMod "LetStmt.hs" "Layout.LetStmt"+ , mkTestMod "ListComprehensions.hs" "Main"+ , mkTestMod "LocToName.hs" "LocToName" , mkTestMod "Mixed.hs" "Main"- , mkTestMod "Arrow.hs" "Arrow"- , mkTestMod "PatSynBind.hs" "Main"- , mkTestMod "HsDo.hs" "HsDo"- , mkTestMod "ForAll.hs" "ForAll"- , mkTestMod "PArr.hs" "PArr"- , mkTestMod "ViewPatterns.hs" "Main"- , mkTestMod "BangPatterns.hs" "Main"- , mkTestMod "Associated.hs" "Main"+ , mkTestMod "MonadComprehensions.hs" "Main" , mkTestMod "Move1.hs" "Move1"- , mkTestMod "Rules.hs" "Rules"- , mkTestMod "TypeOperators.hs" "Main"+ , mkTestMod "MultiParamTypeClasses.hs" "Main" , mkTestMod "NullaryTypeClasses.hs" "Main"- , mkTestMod "FunctionalDeps.hs" "Main"- , mkTestMod "DerivingOC.hs" "Main"- , mkTestMod "GenericDeriving.hs" "Main" , mkTestMod "OverloadedStrings.hs" "Main"+ , mkTestMod "PArr.hs" "PArr"+ , mkTestMod "PatSynBind.hs" "Main"+ , mkTestMod "ParensAroundContext.hs" "ParensAroundContext" , mkTestMod "RankNTypes.hs" "Main"- , mkTestMod "Existential.hs" "Main"+ , mkTestMod "RdrNames.hs" "RdrNames"+ , mkTestMod "RebindableSyntax.hs" "Main"+ , mkTestMod "RecordUpdate.hs" "Main"+ , mkParserTest "RecursiveDo.hs"+ , mkTestMod "Roles.hs" "Roles"+ , mkTestMod "Rules.hs" "Rules" , mkTestMod "ScopedTypeVariables.hs" "Main"- , mkTestMod "Arrows.hs" "Main"- , mkTestMod "TH.hs" "Main"+ , mkTestMod "Sigs.hs" "Sigs"+ , mkTestMod "Simple.hs" "Main"+ , mkTestMod "Splice.hs" "Splice" , mkTestMod "StaticPointers.hs" "Main"- , mkTestMod "DataDecl.hs" "Main"- , mkTestMod "Guards.hs" "Main"- , mkTestMod "RebindableSyntax.hs" "Main"- , mkTestMod "RdrNames.hs" "RdrNames"- , mkTestMod "Vect.hs" "Vect"- , mkTestMod "Tuple.hs" "Main"- , mkTestMod "ExtraConstraints1.hs" "ExtraConstraints1"- , mkTestMod "AddAndOr3.hs" "AddAndOr3"- , mkTestMod "Ann01.hs" "Ann01"+ , mkTestMod "Stmts.hs" "Stmts"+ , mkTestMod "Stream.hs" "Stream" , mkTestMod "StrictLet.hs" "Main"- , mkTestMod "Cg008.hs" "Cg008" , mkTestMod "T2388.hs" "T2388" , mkTestMod "T3132.hs" "T3132"- , mkTestMod "Stream.hs" "Stream"+ , mkTestMod "TH.hs" "Main" , mkTestMod "Trit.hs" "Trit"- , mkTestMod "DataDecl.hs" "Main"- , mkTestMod "Zipper.hs" "Zipper"- , mkTestMod "Sigs.hs" "Sigs"+ , mkTestMod "TransformListComp.hs" "Main"+ , mkTestMod "Tuple.hs" "Main"+ , mkTestMod "TypeFamilies.hs" "Main"+ , mkTestMod "TypeOperators.hs" "Main" , mkTestMod "Utils2.hs" "Utils2"- , mkTestMod "EmptyMostlyInst.hs" "EmptyMostlyInst"- , mkTestMod "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"- , mkTestMod "Dead1.hs" "Dead1"- , mkTestMod "EmptyMostly.hs" "EmptyMostly"- , mkTestMod "FromUtils.hs" "Main"- , mkTestMod "DocDecls.hs" "DocDecls"- , mkTestMod "RecordUpdate.hs" "Main"- -- , mkTestMod "Unicode.hs" "Main"- , 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"- , mkTestMod "BCase.hs" "Main"- , mkTestMod "AltsSemis.hs" "Main"- , mkTestMod "LetExprSemi.hs" "LetExprSemi"+ , mkTestMod "Vect.hs" "Vect"+ , mkTestMod "ViewPatterns.hs" "Main"+ , mkTestMod "Warning.hs" "Warning" , mkTestMod "WhereIn4.hs" "WhereIn4"- , mkTestMod "LocToName.hs" "LocToName"- , mkTestMod "IfThenElse1.hs" "Main"- , mkTestMod "IfThenElse2.hs" "Main"- , mkTestMod "IfThenElse3.hs" "Main"+ , mkTestMod "Zipper.hs" "Zipper"+ , mkTestMod "QuasiQuote.hs" "QuasiQuote"+ , mkTestMod "Pseudonym.hs" "Main"+ , mkTestMod "Obscure.hs" "Main"+ , mkTestMod "Remorse.hs" "Main"+ , mkTestMod "Jon.hs" "Main"+ , mkTestMod "RSA.hs" "Main"+ , mkTestMod "WhereIn3.hs" "WhereIn3"+ , mkTestMod "Backquote.hs" "Main"+ , mkTestMod "PatternGuards.hs" "Main"+ , mkParserTest "Minimal.hs"+ , mkParserTest "Undefined2.hs"+ , mkParserTest "Undefined3.hs"+ , mkParserTest "Undefined4.hs"+ , mkParserTest "Undefined5.hs"+ , mkParserTest "Undefined6.hs"+ , mkParserTest "Undefined7.hs"+ , mkParserTest "Undefined8.hs"+ , mkParserTest "Undefined9.hs"+ , mkParserTest "Undefined10.hs"+ , mkParserTest "Undefined11.hs"+ , mkParserTest "Undefined13.hs"+ , mkParserTest "TypeSynOperator.hs"+ , mkParserTest "TemplateHaskell.hs"+ , mkParserTest "TypeBrackets.hs"+ , mkParserTest "SlidingDoClause.hs"+ , mkParserTest "SlidingListComp.hs"+ , mkParserTest "LiftedConstructors.hs"+ , mkParserTest "LambdaCase.hs"+ , mkParserTest "PuncFunctions.hs"+ , mkParserTest "TupleSections.hs"+ , mkParserTest "TypeSynParens.hs"+ , mkParserTest "SlidingRecordSetter.hs"+ , mkParserTest "MultiLineCommentWithPragmas.hs"+ , mkParserTest "GHCOrig.hs"+ , mkParserTest "DoubleForall.hs"+ , mkParserTest "AnnPackageName.hs"+ , mkParserTest "NestedLambda.hs"+ , mkParserTest "DefaultTypeInstance.hs"+ , mkParserTest "RecordWildcard.hs"+ , mkParserTest "MagicHash.hs"+ , mkParserTest "GADTRecords.hs"+ , mkParserTest "MangledSemiLet.hs"+ , mkParserTest "MultiImplicitParams.hs"+ , mkParserTest "UnicodeSyntaxFailure.hs" - , 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"+ , mkParserTest "HangingRecord.hs"+ , mkParserTest "InfixPatternSynonyms.hs"+ , mkParserTest "LiftedInfixConstructor.hs"+ , mkParserTest "MultiWayIf.hs"+ , mkParserTest "OptSig.hs"+ , mkParserTest "StrangeTypeClass.hs"+ , mkParserTest "TypeSignatureParens.hs"+ , mkParserTest "Cpp.hs" + , mkParserTest "Shebang.hs"+ , mkParserTest "PatSigBind.hs"+ , mkParserTest "ProcNotation.hs"+ , mkParserTest "DroppedDoSpace.hs"+ , mkParserTest "IndentedDo.hs"+ , mkParserTest "BracesSemiDataDecl.hs"+ , mkParserTest "SpacesSplice.hs"+ , mkParserTest "SemiWorkout.hs"+ , mkParserTest "ShiftingLambda.hs"+ , mkParserTest "NestedDoLambda.hs"+ , mkParserTest "DoPatBind.hs"++ , mkParserTest "LinePragma.hs"+ , mkParserTest "Hang.hs"++ , mkParserTest "HashQQ.hs"+ , mkParserTest "TypeBrackets2.hs"+ , mkParserTest "ExplicitNamespaces.hs"+ , mkParserTest "CorePragma.hs"+ , mkParserTest "GADTContext.hs"+ , mkParserTest "THMonadInstance.hs"+-- , mkParserTest "TypeBrackets3.hs" -- I think this test is junk but it parses?+ , mkParserTest "TypeBrackets4.hs"+ , mkParserTest "SlidingTypeSyn.hs"+ , mkParserTest "RecordSemi.hs"+ , mkParserTest "SlidingLambda.hs"+ , mkParserTest "DroppedComma.hs"+ , mkParserTest "TypeInstance.hs"+ , mkParserTest "ImplicitTypeSyn.hs"+ , mkParserTest "OveridingPrimitives.hs"+ , mkParserTest "SlidingDataClassDecl.hs"+ , mkParserTest "SemiInstance.hs"+ , mkParserTest "ImplicitSemi.hs"+ , mkParserTest "RulesSemi.hs"+ , mkParserTest "InlineSemi.hs"+ , mkParserTest "SpliceSemi.hs"+ , mkParserTest "Imports.hs"+ , mkParserTest "Internals.hs"+ , mkParserTest "Control.hs"+ , mkParserTest "T10196.hs"+ , mkParserTest "StringGap.hs" ] -mkTestMain :: FilePath -> Test-mkTestMain fileName = TestCase (do r <- manipulateAstTest fileName "Main"- assertBool fileName r )+ ++ transformTests -mkTestMod :: FilePath -> String -> Test-mkTestMod fileName modName- = TestCase (do r <- manipulateAstTest fileName modName- assertBool fileName r )+ ++ failingTests -mkTestModChange :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> Test-mkTestModChange change fileName modName- = TestCase (do r <- manipulateAstTestWithMod change fileName modName- assertBool fileName r ) -mkTestModTH :: FilePath -> String -> Test-mkTestModTH fileName modName- = TestCase (do r <- manipulateAstTestTH fileName modName- assertBool fileName r )+-- Tests that will fail until https://phabricator.haskell.org/D907 lands in a+-- future GHC+failingTests :: [Test]+failingTests =+ [+ -- Require current master #10313 / Phab:D907+ mkTestModBad "Deprecation.hs" "Deprecation"+ , mkTestModBad "MultiLineWarningPragma.hs" "Main"+ , mkTestModBad "UnicodeRules.hs" "Main" + -- Tests requiring future GHC modifications+ , mkTestModBad "UnicodeSyntax.hs" "Tutorial"+ , mkTestModBad "InfixOperator.hs" "Main"+ ]+++mkParserTest :: FilePath -> Test+mkParserTest fp =+ let basename = "tests" </> "examples" </> fp+ writeFailure = writeFile (basename <.> "out")+ writeHsPP = writeFile (basename <.> "hspp")+ writeIncons s = writeFile (basename <.> "incons") (showGhc s)+ in+ TestCase (do r <- either (\(ParseFailure _ s) -> error s) id+ <$> roundTripTest ("tests" </> "examples" </> fp)+ writeFailure (debugTxt r)+ forM_ (inconsistent r) writeIncons+ forM_ (cppStatus r) writeHsPP+ assertBool fp (status r == Success))++++mkTestMod :: FilePath -> String -> Test+mkTestMod fileName _modName+ = mkParserTest fileName++ -- --------------------------------------------------------------------- formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO ()@@ -195,213 +289,211 @@ putStrLn "Fail" mapM_ (putStrLn . fst) fs) -tt :: IO ()-tt = formatTT =<< partition snd <$> sequence [ return ("", True)- {-- , manipulateAstTestWFname "LetExpr.hs" "LetExpr"- -}+tt' :: IO ()+tt' = formatTT =<< partition snd <$> sequence [ return ("", True) -- , 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 "MonadComprehensions.hs" "Main"+ -- , manipulateAstTestWFname "RecursiveDo.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"- -}+ -- -- , manipulateAstTestWFnameTH "QuasiQuote.hs" "QuasiQuote"+ -- , manipulateAstTestWFname "Roles.hs" "Roles"+ -- , manipulateAstTestWFname "ImportsSemi.hs" "ImportsSemi"+ -- , manipulateAstTestWFname "Stmts.hs" "Stmts" -- , manipulateAstTestWFname "Mixed.hs" "Main"- {-- , manipulateAstTestWFname "Arrow.hs" "Arrow"- , manipulateAstTestWFname "PatSynBind.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 "ForAll.hs" "ForAll"+ -- , manipulateAstTestWFname "BangPatterns.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 "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 "Arrows.hs" "Main"+ -- , manipulateAstTestWFname "TH.hs" "Main"+ -- , manipulateAstTestWFname "StaticPointers.hs" "Main"+ -- , manipulateAstTestWFname "Guards.hs" "Main" -- , manipulateAstTestWFname "Vect.hs" "Vect"- {-- , manipulateAstTestWFname "Tuple.hs" "Main"- , manipulateAstTestWFname "ExtraConstraints1.hs" "ExtraConstraints1"- , manipulateAstTestWFname "AddAndOr3.hs" "AddAndOr3"- -}+ -- , 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 "Cg008.hs" "Cg008"+ -- , manipulateAstTestWFname "T2388.hs" "T2388"+ -- , manipulateAstTestWFname "T3132.hs" "T3132"+ -- , manipulateAstTestWFname "Stream.hs" "Stream"+ -- , manipulateAstTestWFname "Trit.hs" "Trit"+ -- , 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 "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 "UnicodeRules.hs" "Main"+ -- , manipulateAstTestWFname "Infix.hs" "Main"+ -- , manipulateAstTestWFname "BCase.hs" "Main"+ -- , manipulateAstTestWFname "LetExprSemi.hs" "LetExprSemi"+ -- , manipulateAstTestWFname "LetExpr2.hs" "Main"+ -- , manipulateAstTestWFname "LetStmt.hs" "Layout.LetStmt"+ -- , manipulateAstTestWFname "RebindableSyntax.hs" "Main"+ -- -- , manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"+ -- -- , manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5"+ -- , manipulateAstTestWFname "EmptyMostly2.hs" "EmptyMostly2" -- , 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 "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 "AltsSemis.hs" "Main"+ -- , manipulateAstTestWFname "LetExpr.hs" "LetExpr" -- , 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"+ -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a"+ -- , manipulateAstTestWFname "LetIn1.hs" "LetIn1"+ -- -- , manipulateAstTestWFnameMod changeLetIn1 "LetIn1.hs" "LetIn1"+ -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b"+ -- -- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3" -- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2"+ -- , manipulateAstTestWFname "LayoutLet.hs" "Main"+ -- , manipulateAstTestWFname "Simple.hs" "Main"+ -- , manipulateAstTestWFname "FunDeps.hs" "Main"+ -- , manipulateAstTestWFname "IfThenElse3.hs" "Main"+ -- , manipulateAstTestWFname "ImplicitParams.hs" "Main"+ -- , manipulateAstTestWFname "ListComprehensions.hs" "Main"+ -- , manipulateAstTestWFname "TransformListComp.hs" "Main"+ -- , manipulateAstTestWFname "PArr.hs" "PArr"+ -- , manipulateAstTestWFname "DataDecl.hs" "Main"+ -- , manipulateAstTestWFname "WhereIn4.hs" "WhereIn4"+ -- , manipulateAstTestWFname "Pseudonym.hs" "Main"+ -- , manipulateAstTestWFname "Obscure.hs" "Main"+ -- , manipulateAstTestWFname "Remorse.hs" "Main"+ -- , manipulateAstTestWFname "Jon.hs" "Main"+ -- , manipulateAstTestWFname "RSA.hs" "Main"+ -- , manipulateAstTestWFname "CExpected.hs" "CExpected"+ -- , manipulateAstTestWFname "C.hs" "C"+ -- -- , manipulateAstTestWFnameMod changeCifToCase "C.hs" "C"+ -- -- , manipulateAstTestWFnameMod changeWhereIn3 "WhereIn3.hs" "WhereIn3"+ -- , manipulateAstTestWFname "DoParens.hs" "Main"+ -- , manipulateAstTestWFname "SimpleComplexTuple.hs" "Main"+ -- , manipulateAstTestWFname "Backquote.hs" "Main"+ -- , manipulateAstTestWFname "HangingRecord.hs" "Main"+ -- , manipulateAstTestWFname "PatternGuards.hs" "Main"+ -- -- , manipulateAstTestWFnameMod (changeWhereIn3 2) "WhereIn3.hs" "WhereIn3"+ -- -- , manipulateAstTestWFnameMod (changeWhereIn3 2) "WhereIn3.hs" "WhereIn3"+ -- , manipulateAstTestWFname "DoParens.hs" "Main"++ -- -- Future tests to pass, after appropriate dev is done+ -- -- , manipulateAstTestWFname "MultipleInferredContexts.hs" "Main"+ -- -- , manipulateAstTestWFname "ArgPuncParens.hs" "Main"+ -- -- , manipulateAstTestWFname "SimpleComplexTuple.hs" "Main"+ -- -- , manipulateAstTestWFname "DoPatBind.hs" "Main"+ -- , manipulateAstTestWFname "DroppedDoSpace.hs" "Main"+ -- , manipulateAstTestWFname "DroppedDoSpace2.hs" "Main"+ -- , manipulateAstTestWFname "GHCOrig.hs" "GHC.Tuple"++ -- , manipulateAstTestWFname "Cpp.hs" "Main"+ -- , manipulateAstTestWFname "MangledSemiLet.hs" "Main"+ -- , manipulateAstTestWFname "ListComprehensions.hs" "Main"+ -- , manipulateAstTestWFname "ParensAroundContext.hs" "ParensAroundContext"+ -- , manipulateAstTestWFname "TypeFamilies.hs" "Main"+ -- , manipulateAstTestWFname "Associated.hs" "Main"+ -- , manipulateAstTestWFname "RdrNames.hs" "RdrNames"+ -- , manipulateAstTestWFname "StrangeTypeClass.hs" "Main"+ -- , manipulateAstTestWFname "TypeSignatureParens.hs" "Main"+ -- , manipulateAstTestWFname "DoubleForall.hs" "Main"+ -- , manipulateAstTestWFname "GADTRecords.hs" "Main"+ -- , manipulateAstTestWFname "Existential.hs" "Main"+ -- , manipulateAstTestWFname "ScopedTypeVariables.hs" "Main"+ -- , manipulateAstTestWFname "T5951.hs" "T5951"+ -- , manipulateAstTestWFname "Zipper2.hs" "Zipper2"+ -- , manipulateAstTestWFname "RdrNames2.hs" "RdrNames2"+ -- , manipulateAstTestWFname "Unicode.hs" "Unicode"+ -- , manipulateAstTestWFname "OptSig2.hs" "Main"+ -- , manipulateAstTestWFname "Minimal.hs" "Main"+ -- , manipulateAstTestWFname "DroppedComma.hs" "Main"+ -- , manipulateAstTestWFname "SlidingTypeSyn.hs" "Main"+ -- , manipulateAstTestWFname "TupleSections.hs" "Main"+ -- , manipulateAstTestWFname "CorePragma.hs" "Main"+ -- , manipulateAstTestWFname "Splice.hs" "Splice"+ -- , manipulateAstTestWFname "TemplateHaskell.hs" "Main"+ -- , manipulateAstTestWFname "GADTContext.hs" "Main"+ -- , manipulateAstTestWFnameBad "UnicodeSyntax.hs" "Tutorial"+ -- , manipulateAstTestWFname "DataDecl.hs" "Main"++ -- , manipulateAstTestWFname "TypeBrackets.hs" "Main"+ -- , manipulateAstTestWFname "TypeBrackets2.hs" "Main"+ -- , manipulateAstTestWFname "TypeBrackets4.hs" "Main"+ -- , manipulateAstTestWFname "NestedLambda.hs" "Main"+ -- , manipulateAstTestWFname "ShiftingLambda.hs" "Main"+ -- , manipulateAstTestWFname "SlidingLambda.hs" "Main"+-- , manipulateAstTestWFnameMod changeAddDecl "AddDecl.hs" "AddDecl"+ -- , manipulateAstTestWFnameMod changeLocalDecls "LocalDecls.hs" "LocalDecls"+ -- , manipulateAstTestWFname "LocalDecls2Expected.hs" "LocalDecls2Expected"+ -- , manipulateAstTestWFname "LocalDecls2.hs" "LocalDecls2"+ -- , manipulateAstTestWFnameMod changeLocalDecls2 "LocalDecls2.hs" "LocalDecls2"+ -- , manipulateAstTestWFname "WhereIn3.hs" "WhereIn3"+ -- , manipulateAstTestWFnameMod changeWhereIn3a "WhereIn3a.hs" "WhereIn3a"+ -- , manipulateAstTestWFname "Imports.hs" "Imports"+ , manipulateAstTestWFname "T10196.hs" "T10196"+ , manipulateAstTestWFnameMod addLocaLDecl1 "AddLocalDecl1.hs" "AddLocaLDecl1"+ , manipulateAstTestWFnameMod addLocaLDecl2 "AddLocalDecl2.hs" "AddLocaLDecl2"+ , manipulateAstTestWFnameMod addLocaLDecl3 "AddLocalDecl3.hs" "AddLocaLDecl3"+ , manipulateAstTestWFnameMod rmDecl1 "RmDecl1.hs" "RmDecl1"+ -- , manipulateAstTestWFname "RmDecl2.hs" "RmDecl2"+ , manipulateAstTestWFnameMod rmDecl2 "RmDecl2.hs" "RmDecl2"+ , manipulateAstTestWFnameMod rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"+ , manipulateAstTestWFname "StringGap.hs" "StringGap" {-- , manipulateAstTestWFname "ParensAroundContext.hs" "ParensAroundContext"- , manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4"- , manipulateAstTestWFname "Cpp.hs" "Main" , manipulateAstTestWFname "Lhs.lhs" "Main" , manipulateAstTestWFname "Foo.hs" "Main"--}+ -} ] --- -----------------------------------------------------------------------changeLayoutLet2 :: GHC.ParsedSource -> GHC.ParsedSource-changeLayoutLet2 parsed = rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed--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--changeLayoutIn1 :: GHC.ParsedSource -> GHC.ParsedSource-changeLayoutIn1 parsed = rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed--changeRename1 :: GHC.ParsedSource -> GHC.ParsedSource-changeRename1 parsed = rename "bar2" [((3,1),(3,4))] parsed--changeLayoutLet3 :: GHC.ParsedSource -> GHC.ParsedSource-changeLayoutLet3 parsed = rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed--changeLayoutLet5 :: GHC.ParsedSource -> GHC.ParsedSource-changeLayoutLet5 parsed = rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed--rename :: (SYB.Data a) => String -> [Span] -> a -> a-rename newNameStr spans a- = SYB.everywhere ( SYB.mkT replaceRdr- `SYB.extT` replaceHsVar- `SYB.extT` replacePat- ) a- where- newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr)-- cond :: GHC.SrcSpan -> Bool- cond ln = any (\ss -> ss2span ln == ss) spans-- replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName- replaceRdr (GHC.L ln _)- | cond ln = GHC.L ln newName- replaceRdr x = x-- replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName- replaceHsVar (GHC.L ln (GHC.HsVar _))- | cond ln = GHC.L ln (GHC.HsVar newName)- replaceHsVar x = x-- replacePat (GHC.L ln (GHC.VarPat _))- | cond ln = GHC.L ln (GHC.VarPat newName)- replacePat x = x+testsTT :: Test+testsTT = TestList+ [+ mkParserTest "Cpp.hs"+ , mkParserTest "DroppedDoSpace.hs"+ ] +tt :: IO ()+-- tt = hSilence [stderr] $ do+tt = do+ cnts <- fst <$> runTestText (putTextToHandle stdout True) testsTT+ putStrLn $ show cnts+ if errors cnts > 0 || failures cnts > 0+ then exitFailure+ else return () -- exitSuccess --- -----------------------------------------------------------------------changeWhereIn4 :: GHC.ParsedSource -> GHC.ParsedSource-changeWhereIn4 parsed- = SYB.everywhere (SYB.mkT replace) parsed- where- replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName- replace (GHC.L ln _n)- | ss2span ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2"))- replace x = x---- ---------------------------------------------------------------------- -- | Where all the tests are to be found examplesDir :: FilePath examplesDir = "tests" </> "examples"@@ -409,133 +501,10 @@ examplesDir2 :: FilePath examplesDir2 = "examples" -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--manipulateAstTest' :: Maybe (GHC.ParsedSource -> GHC.ParsedSource) -> Bool -> FilePath -> String -> IO Bool-manipulateAstTest' mchange useTH file' modname = do- let testpath = "./tests/examples/"- file = testpath </> file'- out = file <.> "out"- expected = file <.> "expected"-- contents <- case mchange of- Nothing -> readUTF8File file- Just _ -> readUTF8File expected- (ghcAnns,t) <- parsedFileGhc file modname useTH- let- parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t- parsedAST = SYB.showData SYB.Parser 0 parsed- -- parsedAST = showGhc parsed- -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule)))- -- try to pretty-print; summarize the test result- ann = relativiseApiAnns parsed ghcAnns- `debug` ("ghcAnns:" ++ showGhc ghcAnns)-- parsed' = case mchange of- Nothing -> parsed- Just change -> change parsed- printed = exactPrintWithAnns parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))- result =- if printed == contents- then "Match\n"- else printed ++ "\n==============\n"- ++ "lengths:" ++ show (length printed,length contents) ++ "\n"- ++ parsedAST- ++ "\n========================\n"- ++ showAnnData ann 0 parsed'- 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)-- -- ------------------------------------------------------------------------ |Result of parsing a Haskell source file. It is simply the--- TypeCheckedModule produced by GHC.-type ParseResult = GHC.TypecheckedModule -parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult)-parsedFileGhc fileName modname useTH = do- -- putStrLn $ "parsedFileGhc:" ++ show fileName- GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do- GHC.runGhc (Just libdir) $ do- dflags <- GHC.getSessionDynFlags- let dflags'' = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/",- "./src/","../src/"] }-- tgt = if useTH then GHC.HscInterpreted- else GHC.HscNothing -- allows FFI- dflags''' = dflags'' { GHC.hscTarget = tgt,- GHC.ghcLink = GHC.LinkInMemory- , GHC.packageFlags = [GHC.ExposePackage (GHC.PackageArg "ghc") (GHC.ModRenaming False [])]- }-- dflags4 = if False -- useHaddock- then GHC.gopt_set (GHC.gopt_set dflags''' GHC.Opt_Haddock)- GHC.Opt_KeepRawTokenStream- else GHC.gopt_set dflags'''- GHC.Opt_KeepRawTokenStream- -- else GHC.gopt_set (GHC.gopt_unset dflags''' GHC.Opt_Haddock)- -- GHC.Opt_KeepRawTokenStream-- (dflags5,_args,_warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"]- -- GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc args,map GHC.unLoc warns)- void $ GHC.setSessionDynFlags dflags5- -- GHC.liftIO $ putStrLn $ "dflags set"-- target <- GHC.guessTarget fileName Nothing- GHC.setTargets [target]- -- GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target)- void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make- -- GHC.liftIO $ putStrLn $ "targets loaded"- -- g <- GHC.getModuleGraph- -- let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms)- -- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g))-- modSum <- GHC.getModSummary $ GHC.mkModuleName modname- -- GHC.liftIO $ putStrLn $ "got modSum"- -- let modSum = head g-{-- (sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum)- strSrcBuf <- getPreprocessedSrc sourceFile- GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n"--}- p <- GHC.parseModule modSum- -- GHC.liftIO $ putStrLn $ "got parsedModule"- t <- GHC.typecheckModule p- -- GHC.liftIO $ putStrLn $ "typechecked"- -- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum)- -- GHC.liftIO $ putStrLn $ "toks" ++ show toks- let anns = GHC.pm_annotations p- -- GHC.liftIO $ putStrLn $ "anns"- return (anns,t)--readUTF8File :: FilePath -> IO String-readUTF8File fp = openFile fp ReadMode >>= \h -> do- hSetEncoding h utf8- hGetContents h---- ---------------------------------------------------------------------- pwd :: IO FilePath pwd = getCurrentDirectory @@ -548,73 +517,5 @@ mkSs (sr,sc) (er,ec) = GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") sr sc) (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") er ec)--- --------------------------------------------------------------------- --- | The preprocessed files are placed in a temporary directory, with--- a temporary name, and extension .hscpp. Each of these files has--- three lines at the top identifying the original origin of the--- files, which is ignored by the later stages of compilation except--- to contextualise error messages.-getPreprocessedSrc ::- -- GHC.GhcMonad m => FilePath -> m GHC.StringBuffer- GHC.GhcMonad m => FilePath -> m String-getPreprocessedSrc srcFile = do- df <- GHC.getSessionDynFlags- d <- GHC.liftIO $ getTempDir df- fileList <- GHC.liftIO $ getDirectoryContents d- let suffix = "hscpp"-- let cppFiles = filter (\f -> getSuffix f == suffix) fileList- origNames <- GHC.liftIO $ mapM getOriginalFile $ map (\f -> d </> f) cppFiles- let tmpFile = ghead "getPreprocessedSrc" $ filter (\(o,_) -> o == srcFile) origNames- -- buf <- GHC.liftIO $ GHC.hGetStringBuffer $ snd tmpFile- -- return buf- GHC.liftIO $ readUTF8File (snd tmpFile)- -- -----------------------------------------------------------------------getSuffix :: FilePath -> String-getSuffix fname = reverse $ fst $ break (== '.') $ reverse fname---- | A GHC preprocessed file has the following comments at the top--- @--- # 1 "./test/testdata/BCpp.hs"--- # 1 "<command-line>"--- # 1 "./test/testdata/BCpp.hs"--- @--- This function reads the first line of the file and returns the--- string in it.--- NOTE: no error checking, will blow up if it fails-getOriginalFile :: FilePath -> IO (FilePath,FilePath)-getOriginalFile fname = do- fcontents <- readFile fname- let firstLine = ghead "getOriginalFile" $ lines fcontents- let (_,originalFname) = break (== '"') firstLine- return $ (tail $ init $ originalFname,fname)----- ------------------------------------------------------------------------ Copied from the GHC source, since not exported--getModuleSourceAndFlags :: GHC.GhcMonad m => GHC.Module -> m (String, GHC.StringBuffer, GHC.DynFlags)-getModuleSourceAndFlags modu = do- m <- GHC.getModSummary (GHC.moduleName modu)- case GHC.ml_hs_file $ GHC.ms_location m of- Nothing ->- do dflags <- GHC.getDynFlags- GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr modu)- Just sourceFile -> do- source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile- return (sourceFile, source, GHC.ms_hspp_opts m)----- return our temporary directory within tmp_dir, creating one if we--- don't have one yet-getTempDir :: GHC.DynFlags -> IO FilePath-getTempDir dflags- = do let ref = GHC.dirsToClean dflags- tmp_dir = GHC.tmpDir dflags- mapping <- readIORef ref- case Map.lookup tmp_dir mapping of- Nothing -> error "should already be a tmpDir"- Just d -> return d
+ tests/Test/Common.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Common (+ RoundtripReport (..)+ , Report+ , ParseFailure(..)+ , ReportType(..)+ , roundTripTest+ , getModSummaryForFile+ ) where++++import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Preprocess++import GHC.Paths (libdir)++import qualified ApiAnnotation as GHC+import qualified DynFlags as GHC+import qualified FastString as GHC+import qualified GHC as GHC hiding (parseModule)+import qualified HeaderInfo as GHC+import qualified Lexer as GHC+import qualified MonadUtils as GHC+import qualified Outputable as GHC+import qualified Parser as GHC+import qualified SrcLoc as GHC+import qualified StringBuffer as GHC++import qualified Data.Map as Map++import Data.List hiding (find)++import Control.Monad+import System.Directory++import Test.Consistency++import Control.Arrow (first)++-- import Debug.Trace++-- ---------------------------------------------------------------------+-- Roundtrip machinery++type Report = Either ParseFailure RoundtripReport++data RoundtripReport =+ Report+ { debugTxt :: String+ , status :: ReportType+ , cppStatus :: Maybe String -- Result of CPP if invoked+ , inconsistent :: Maybe [(GHC.SrcSpan, (GHC.AnnKeywordId, [GHC.SrcSpan]))]+ }++data ParseFailure = ParseFailure GHC.SrcSpan String++data ReportType =+ Success+ | RoundTripFailure deriving (Eq, Show)++runParser :: GHC.P a -> GHC.DynFlags -> FilePath -> String -> GHC.ParseResult a+runParser parser flags filename str = GHC.unP parser parseState+ where+ location = GHC.mkRealSrcLoc (GHC.mkFastString filename) 1 1+ buffer = GHC.stringToStringBuffer str+ parseState = GHC.mkPState flags buffer location++parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.RdrName))+parseFile = runParser GHC.parseModule++mkApiAnns :: GHC.PState -> GHC.ApiAnns+mkApiAnns pstate = (Map.fromListWith (++) . GHC.annotations $ pstate+ , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : (GHC.annotations_comments pstate)))++removeSpaces :: String -> String+removeSpaces = map (\case {'\160' -> ' '; s -> s})++initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags+initDynFlags file = do+ dflags0 <- GHC.getSessionDynFlags+ let dflags1 = GHC.gopt_set dflags0 GHC.Opt_KeepRawTokenStream+ src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags1 file+ (!dflags2, _, _)+ <- GHC.parseDynamicFilePragma dflags1 src_opts+ void $ GHC.setSessionDynFlags dflags2+ return dflags2++roundTripTest :: FilePath -> IO Report+roundTripTest file =+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $+ GHC.runGhc (Just libdir) $ do+ dflags <- initDynFlags file+ let useCpp = GHC.xopt GHC.Opt_Cpp dflags+ (fileContents, injectedComments) <-+ if useCpp+ then do+ contents <- getPreprocessedSrcDirect defaultCppOptions file+ cppComments <- getCppTokensAsComments defaultCppOptions file+ return (contents,cppComments)+ else do+ txt <- GHC.liftIO $ readFile file+ let (contents1,lp) = stripLinePragmas txt+ return (contents1,lp)++ orig <- GHC.liftIO $ readFile file+ let origContents = removeSpaces fileContents+ pristine = removeSpaces orig+ return $+ case parseFile dflags file origContents of+ GHC.PFailed ss m -> Left $ ParseFailure ss (GHC.showSDoc dflags m)+ GHC.POk (mkApiAnns -> apianns) pmod ->+ let (printed, anns) = first trimPrinted $ runRoundTrip apianns pmod injectedComments+ -- Clang cpp adds an extra newline character+ -- Do not remove this line!+ trimPrinted p = if useCpp+ then unlines $ take (length (lines pristine)) (lines p)+ else p+ debugTxt = mkDebugOutput file printed pristine apianns anns pmod+ consistency = checkConsistency apianns pmod+ inconsistent = if null consistency then Nothing else Just consistency+ status = if printed == pristine then Success else RoundTripFailure+ cppStatus = if useCpp then Just origContents else Nothing+ in+ Right Report {..}+++mkDebugOutput :: FilePath -> String -> String+ -> GHC.ApiAnns+ -> Anns+ -> GHC.Located (GHC.HsModule GHC.RdrName) -> String+mkDebugOutput filename printed original apianns anns parsed =+ intercalate sep [ printed+ , filename+ , "lengths:" ++ show (length printed,length original) ++ "\n"+ , showAnnData anns 0 parsed+ , showGhc anns+ , showGhc apianns+ ]+ where+ sep = "\n==============\n"++++runRoundTrip :: GHC.ApiAnns -> GHC.Located (GHC.HsModule GHC.RdrName)+ -> [Comment]+ -> (String, Anns)+runRoundTrip !anns !parsedOrig cs =+ let+ !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns+ !printed = exactPrintWithAnns parsedOrig relAnns+ in (printed, relAnns)++-- ---------------------------------------------------------------------`++canonicalizeGraph ::+ [GHC.ModSummary] -> IO [(Maybe (FilePath), GHC.ModSummary)]+canonicalizeGraph graph = do+ let mm = map (\m -> (GHC.ml_hs_file $ GHC.ms_location m, m)) graph+ canon ((Just fp),m) = do+ fp' <- canonicalizePath fp+ return $ (Just fp',m)+ canon (Nothing,m) = return (Nothing,m)++ mm' <- mapM canon mm++ return mm'++-- ---------------------------------------------------------------------++getModSummaryForFile :: (GHC.GhcMonad m) => FilePath -> m (Maybe GHC.ModSummary)+getModSummaryForFile fileName = do+ cfileName <- GHC.liftIO $ canonicalizePath fileName++ graph <- GHC.getModuleGraph+ cgraph <- GHC.liftIO $ canonicalizeGraph graph++ let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph+ case mm of+ [] -> return Nothing+ fs -> return (Just (snd $ head fs))
+ tests/Test/Consistency.hs view
@@ -0,0 +1,27 @@+module Test.Consistency where++import Data.Data+import GHC+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Generics (everything, mkQ)++import Language.Haskell.GHC.ExactPrint.Utils (isPointSrcSpan)++-- import Debug.Trace++checkConsistency :: Data a => GHC.ApiAnns -> a -> [(SrcSpan, (AnnKeywordId, [SrcSpan]))]+checkConsistency anns ast =+ let srcspans = Set.fromList $ getAllSrcSpans ast+ cons (s, (_, vs)) = Set.member s srcspans || (all (isPointSrcSpan) vs)+ in filter (\s -> not (cons s)) (getAnnSrcSpans anns)++getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(AnnKeywordId,[SrcSpan]))]+getAnnSrcSpans (anns,_) = map (\((ss,k),v) -> (ss,(k,v))) $ Map.toList anns++getAllSrcSpans :: (Data t) => t -> [SrcSpan]+getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast+ where+ getSrcSpan :: SrcSpan -> [SrcSpan]+ getSrcSpan ss = [ss]+
+ tests/Test/Transform.hs view
@@ -0,0 +1,683 @@+{-# LANGUAGE TupleSections #-}+module Test.Transform where++import Language.Haskell.GHC.ExactPrint+import Language.Haskell.GHC.ExactPrint.Preprocess+import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Utils+import Language.Haskell.GHC.ExactPrint.Parsers++import GHC.Paths ( libdir )++import qualified Bag as GHC+import qualified DynFlags as GHC+import qualified GHC as GHC+import qualified OccName as GHC+import qualified RdrName as GHC+import qualified SrcLoc as GHC+import qualified FastString as GHC++import qualified Data.Generics as SYB++import Control.Monad+import System.FilePath+import System.IO+import qualified Data.Map as Map+import Data.Maybe++import System.IO.Silently++import Test.Common++import Test.HUnit++transformTests :: [Test]+transformTests =+ [+ TestLabel "Low level transformations"+ (TestList transformLowLevelTests)+ , TestLabel "High level transformations"+ (TestList transformHighLevelTests)+ ]++transformLowLevelTests :: [Test]+transformLowLevelTests = [+ 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"+ , mkTestModChange changeLetIn1 "LetIn1.hs" "LetIn1"+ , mkTestModChange changeWhereIn4 "WhereIn4.hs" "WhereIn4"+ , mkTestModChange changeAddDecl "AddDecl.hs" "AddDecl"+ , mkTestModChange changeLocalDecls "LocalDecls.hs" "LocalDecls"+ , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" "LocalDecls2"+ , mkTestModChange changeWhereIn3a "WhereIn3a.hs" "WhereIn3a"+-- , mkTestModChange changeCifToCase "C.hs" "C"+ ]++mkTestModChange :: Changer -> FilePath -> String -> Test+mkTestModChange change fileName modName+ = TestCase (do r <- manipulateAstTestWithMod change "expected" fileName modName+ assertBool fileName r )++type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource))++-- ---------------------------------------------------------------------++changeWhereIn3a :: Changer+changeWhereIn3a ans (GHC.L l p) = do+ let decls = GHC.hsmodDecls p+ -- (GHC.L _ (GHC.SigD sig)) = head $ drop 1 decls+ d1 = head $ drop 2 decls+ d2 = head $ drop 3 decls+ let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2)+ let p2 = p { GHC.hsmodDecls = d2:d1:decls}+ return (ans',GHC.L l p2)++-- ---------------------------------------------------------------------++-- | Add a local declaration with signature to LocalDecl, where there was no+-- prior local decl. So it adds a "where" annotation.+changeLocalDecls2 :: Changer+changeLocalDecls2 ans (GHC.L l p) = do+ Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+ Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")+ let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns+ let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns+ -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns+ -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns+ -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'+ let (p',(ans',_),_w) = runTransform ans doAddLocal+ doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p+ replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+ -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do+ newSpan <- uniqueSrcSpanT+ let+ newAnnKey = AnnKey newSpan (CN "HsValBinds")+ addWhere mkds =+ case Map.lookup (mkAnnKey m) mkds of+ Nothing -> error "wtf"+ Just ann -> Map.insert newAnnKey ann2 mkds2+ where+ ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))]+ , annCapturedSpan = Just newAnnKey+ , annSortKey = Just [ls, ld]+ }+ mkds2 = Map.insert (mkAnnKey m) ann1 mkds+ ann2 = annNone+ { annEntryDelta = DP (1,0) }+ modifyAnnsT addWhere+ let decls = [s,d]+ logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)+ modifyAnnsT (captureOrderAnnKey newAnnKey decls)+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs+ (GHC.HsValBinds+ (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl])+ [GHC.L ls sig])))))+ replaceLocalBinds x = return x+ -- putStrLn $ "log:" ++ intercalate "\n" w+ return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')++-- ---------------------------------------------------------------------++-- | Add a local declaration with signature to LocalDecl+changeLocalDecls :: Changer+changeLocalDecls ans (GHC.L l p) = do+ Right (declAnns, d@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+ Right (sigAnns, s@(GHC.L ls (GHC.SigD sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int")+ let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns+ let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns+ -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns+ -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns+ -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns'+ let (p',(ans',_),_w) = runTransform ans doAddLocal+ doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p+ replaceLocalBinds :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)+ -> Transform (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))+ replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do+ a1 <- getAnnsT+ a' <- case sigs of+ [] -> return a1+ (s1:_) -> do+ let a2 = setPrecedingLines s1 2 0 a1+ return a2+ putAnnsT a'+ let wrapDecl (GHC.L l' w) = GHC.L l' (GHC.ValD w)+ wrapSig (GHC.L l' w) = GHC.L l' (GHC.SigD w)+ let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs+ let decls = s:d:oldDecls+ logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls)+ modifyAnnsT (captureOrder m decls)+ return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs+ (GHC.HsValBinds+ (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds)+ (GHC.L ls sig:sigs))))))+ replaceLocalBinds x = return x+ -- putStrLn $ "log:" ++ intercalate "\n" w+ return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p')++-- ---------------------------------------------------------------------++-- | Add a declaration to AddDecl+changeAddDecl :: Changer+changeAddDecl ans top = do+ Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "<interactive>" "nn = n2")+ -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl)+ let declAnns' = setPrecedingLines decl 2 0 declAnns+ -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl)++ let (p',(ans',_),_) = runTransform ans doAddDecl+ doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top+ replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource)+ replaceTopLevelDecls m = insertAtStart m decl+ return (mergeAnns declAnns' ans',p')++-- ---------------------------------------------------------------------++-- |Remove a decl with a trailing comment, and remove the trailing comment too+changeWhereIn3 :: Int -> Changer+changeWhereIn3 declIndex ans p = return (ans',p')+ where+ (p',(ans',_),_) = runTransform ans doTransform+ doTransform = doRmDecl p++ doRmDecl (GHC.L l (GHC.HsModule mmn mexp imps decls mdepr haddock)) = do+ let+ -- declIndex = 2 -- zero based+ decls1 = take declIndex decls+ decls2 = drop (declIndex + 1) decls+ decls' = decls1 ++ decls2+ return (GHC.L l (GHC.HsModule mmn mexp imps decls' mdepr haddock))+ -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2)++-- ---------------------------------------------------------------------+{-+-- |Convert the if statement in C.hs to a case, adjusting layout appropriately.+changeCifToCase :: Changer+changeCifToCase ans p = return (ans',p')+ where+ (p',(ans',_),_) = runTransform ans doTransform+ doTransform = SYB.everywhereM (SYB.mkM ifToCaseTransform) p++ ifToCaseTransform :: GHC.Located (GHC.HsExpr GHC.RdrName)+ -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName))+ ifToCaseTransform li@(GHC.L l (GHC.HsIf _se e1 e2 e3)) = do+ caseLoc <- uniqueSrcSpanT -- HaRe:-1:1+ trueMatchLoc <- uniqueSrcSpanT -- HaRe:-1:2+ trueLoc1 <- uniqueSrcSpanT -- HaRe:-1:3+ trueLoc <- uniqueSrcSpanT -- HaRe:-1:4+ trueRhsLoc <- uniqueSrcSpanT -- HaRe:-1:5+ falseLoc1 <- uniqueSrcSpanT -- HaRe:-1:6+ falseLoc <- uniqueSrcSpanT -- HaRe:-1:7+ falseMatchLoc <- uniqueSrcSpanT -- HaRe:-1:8+ falseRhsLoc <- uniqueSrcSpanT -- HaRe:-1:9+ caseVirtualLoc <- uniqueSrcSpanT -- HaRe:-1:10+ let trueName = mkRdrName "True"+ let falseName = mkRdrName "False"+ let ret = GHC.L caseLoc (GHC.HsCase e1+ (GHC.MG+ [+ (GHC.L trueMatchLoc $ GHC.Match+ Nothing+ [+ GHC.L trueLoc1 $ GHC.ConPatIn (GHC.L trueLoc trueName) (GHC.PrefixCon [])+ ]+ Nothing+ (GHC.GRHSs+ [+ GHC.L trueRhsLoc $ GHC.GRHS [] e2+ ] GHC.EmptyLocalBinds)+ )+ , (GHC.L falseMatchLoc $ GHC.Match+ Nothing+ [+ GHC.L falseLoc1 $ GHC.ConPatIn (GHC.L falseLoc falseName) (GHC.PrefixCon [])+ ]+ Nothing+ (GHC.GRHSs+ [+ GHC.L falseRhsLoc $ GHC.GRHS [] e3+ ] GHC.EmptyLocalBinds)+ )+ ] [] GHC.placeHolderType GHC.FromSource))++ oldAnns <- getAnnsT+ let annIf = gfromJust "Case.annIf" $ getAnnotationEP li NotNeeded oldAnns+ let annCond = gfromJust "Case.annCond" $ getAnnotationEP e1 NotNeeded oldAnns+ let annThen = gfromJust "Case.annThen" $ getAnnotationEP e2 NotNeeded oldAnns+ let annElse = gfromJust "Case.annElse" $ getAnnotationEP e3 NotNeeded oldAnns+ logTr $ "Case:annIf=" ++ show annIf+ logTr $ "Case:annThen=" ++ show annThen+ logTr $ "Case:annElse=" ++ show annElse++ -- let ((_ifr, ifc), ifDP) = getOriginalPos oldAnns li (G GHC.AnnIf)+ -- let ((_thenr,thenc),thenDP) = getOriginalPos oldAnns li (G GHC.AnnThen)+ -- let ((_elser,elsec),elseDP) = getOriginalPos oldAnns li (G GHC.AnnElse)+ -- let newCol = ifc + 2+ let newCol = 6++ -- AZ:TODO: under some circumstances the GRHS annotations need LineSame, in others LineChanged.+ let ifDelta = gfromJust "Case.ifDelta" $ lookup (G GHC.AnnIf) (annsDP annIf)+ -- let ifSpanEntry = gfromJust "Case.ifSpanEntry" $ lookup AnnSpanEntry (annsDP annIf)+ -- let ifSpanEntry = annEntryDelta annIf+ let anne2' =+ [ ( AnnKey caseLoc (CN "HsCase") NotNeeded, annIf { annsDP = [ (G GHC.AnnCase, ifDelta)+ , (G GHC.AnnOf, DP (0,1))]+ , annCapturedSpan = Just (AnnKey caseVirtualLoc (CN "(:)") NotNeeded)+ } )+ , ( AnnKey caseVirtualLoc (CN "(:)") NotNeeded, Ann (DP (1,newCol)) (ColDelta newCol) (DP (1,newCol)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing)+ , ( AnnKey trueMatchLoc (CN "Match") NotNeeded, annNone )+ , ( AnnKey trueLoc1 (CN "ConPatIn") NotNeeded, annNone )+ , ( AnnKey trueLoc (CN "Unqual") NotNeeded, annNone )+ , ( AnnKey trueRhsLoc (CN "GRHS") NotNeeded, Ann (DP (0,2)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,2)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing )++ , ( AnnKey falseMatchLoc (CN "Match") NotNeeded, Ann (DP (1,0)) 0 (DP (0,0)) [] [] [(AnnSpanEntry,DP (1,0))] Nothing Nothing )+ , ( AnnKey falseLoc1 (CN "ConPatIn") NotNeeded, annNone )+ , ( AnnKey falseLoc (CN "Unqual") NotNeeded, annNone )+ , ( AnnKey falseRhsLoc (CN "GRHS") NotNeeded, Ann (DP (0,1)) 6 (DP (0,0)) [] [] [(AnnSpanEntry,DP (0,1)),(G GHC.AnnRarrow, DP (0,0))] Nothing Nothing )+ ]++ let annThen' = adjustAnnOffset (ColDelta 6) annThen+ let anne1 = modifyKeywordDeltas (Map.delete (AnnKey l (CN "HsIf") NotNeeded)) oldAnns+ final = modifyKeywordDeltas (\s -> Map.union s (Map.fromList anne2')) anne1+ anne3 = setLocatedAnns final+ [ (e1, annCond)+ , (e2, annThen')+ , (e3, annElse)+ ]+ putAnnsT anne3+ return ret+ ifToCaseTransform x = return x++ mkRdrName :: String -> GHC.RdrName+ mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s)+-}+-- ---------------------------------------------------------------------++noChange :: Changer+noChange ans parsed = return (ans,parsed)++changeLayoutLet2 :: Changer+changeLayoutLet2 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed)++changeLocToName :: Changer+changeLocToName ans parsed = return (ans,rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed)++changeLayoutIn3 :: Changer+changeLayoutIn3 ans parsed = return (ans,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 :: Changer+changeLayoutIn4 ans parsed = return (ans,rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed)++changeLayoutIn1 :: Changer+changeLayoutIn1 ans parsed = return (ans,rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed)++changeRename1 :: Changer+changeRename1 ans parsed = return (ans,rename "bar2" [((3,1),(3,4))] parsed)++changeLayoutLet3 :: Changer+changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed)++changeLayoutLet5 :: Changer+changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed)++rename :: (SYB.Data a) => String -> [(Pos, Pos)] -> a -> a+rename newNameStr spans a+ = SYB.everywhere ( SYB.mkT replaceRdr+ `SYB.extT` replaceHsVar+ `SYB.extT` replacePat+ ) a+ where+ newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr)++ cond :: GHC.SrcSpan -> Bool+ cond ln = ln `elem` srcSpans+ where+ srcSpans = map (\(start, end) -> GHC.mkSrcSpan (f start) (f end)) spans+ fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)+ f = uncurry (GHC.mkSrcLoc fname)+++ replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName+ replaceRdr (GHC.L ln _)+ | cond ln = GHC.L ln newName+ replaceRdr x = x++ replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName+ replaceHsVar (GHC.L ln (GHC.HsVar _))+ | cond ln = GHC.L ln (GHC.HsVar newName)+ replaceHsVar x = x++ replacePat (GHC.L ln (GHC.VarPat _))+ | cond ln = GHC.L ln (GHC.VarPat newName)+ replacePat x = x++++-- ---------------------------------------------------------------------++changeWhereIn4 :: Changer+changeWhereIn4 ans parsed+ = return (ans,SYB.everywhere (SYB.mkT replace) parsed)+ where+ replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName+ replace (GHC.L ln _n)+ | ln == (g (12,16) (12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2"))+ where+ g start end = GHC.mkSrcSpan (f start) (f end)+ fname = fromMaybe (GHC.mkFastString "f") (GHC.srcSpanFileName_maybe ln)+ f = uncurry (GHC.mkSrcLoc fname)+ replace x = x++-- ---------------------------------------------------------------------++changeLetIn1 :: Changer+changeLetIn1 ans parsed+ = return (ans,SYB.everywhere (SYB.mkT replace) parsed)+ where+ replace :: GHC.HsExpr GHC.RdrName -> GHC.HsExpr GHC.RdrName+ replace (GHC.HsLet localDecls expr@(GHC.L _ _))+ =+ let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls+ bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls+ in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr)++ replace x = x++-- ---------------------------------------------------------------------+++manipulateAstTestWithMod :: Changer -> String -> FilePath -> String -> IO Bool+manipulateAstTestWithMod change suffix file modname = manipulateAstTest' (Just (change, suffix)) False file modname++manipulateAstTestWFnameMod :: Changer -> FilePath -> String -> IO (FilePath,Bool)+manipulateAstTestWFnameMod change fileName modname+ = do r <- manipulateAstTestWithMod change "expected" fileName modname+ return (fileName,r)++manipulateAstTestWFnameBad :: FilePath -> String -> IO (FilePath,Bool)+manipulateAstTestWFnameBad fileName modname+ = do r <- manipulateAstTestWithMod noChange "bad" 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+++mkTestModBad :: FilePath -> String -> Test+mkTestModBad fileName modName+ = TestCase (do r <- manipulateAstTestWithMod noChange "bad" fileName modName+ assertBool fileName r )++manipulateAstTest' :: Maybe (Changer, String)+ -> Bool -> FilePath -> String -> IO Bool+manipulateAstTest' mchange useTH file' modname = do+ let testpath = "./tests/examples/"+ file = testpath </> file'+ out = file <.> "out"++ contents <- case mchange of+ Nothing -> readFile file+ Just (_,expectedSuffix) -> readFile (file <.> expectedSuffix)+ (ghcAnns',p,cppComments) <- hSilence [stderr] $ parsedFileGhc file modname useTH+ -- (ghcAnns',p,cppComments) <- parsedFileGhc file modname useTH+ let+ parsedOrig = GHC.pm_parsed_source $ p+ (ghcAnns,parsed) = (ghcAnns', parsedOrig)+ parsedAST = showAnnData emptyAnns 0 parsed+ -- cppComments = map (tokComment . commentToAnnotation . fst) cppCommentToks+ -- parsedAST = showGhc parsed+ -- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule)))+ -- try to pretty-print; summarize the test result+ ann = relativiseApiAnnsWithComments cppComments parsedOrig ghcAnns'+ `debug` ("ghcAnns:" ++ showGhc ghcAnns)++ (ann',parsed') <- case mchange of+ Nothing -> return (ann,parsed)+ Just (change,_) -> change ann parsed++ let+ printed = exactPrintWithAnns parsed' ann' -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))+ outcome = if printed == contents+ then "Match\n"+ else "Fail\n"+ result = printed ++ "\n==============\n"+ ++ outcome ++ "\n==============\n"+ ++ "lengths:" ++ show (length printed,length contents) ++ "\n"+ ++ showAnnData ann' 0 parsed'+ ++ "\n========================\n"+ ++ showGhc ann'+ ++ "\n========================\n"+ ++ showGhc ghcAnns+ ++ "\n========================\n"+ ++ parsedAST+ ++ "\n========================\n"+ ++ showGhc ann+ -- putStrLn $ "Test:ann :" ++ showGhc ann+ writeFile out $ result+ -- putStrLn $ "Test:contents' :" ++ contents+ -- putStrLn $ "Test:parsed=" ++ parsedAST+ -- putStrLn $ "Test:showdata:parsedOrig" ++ SYB.showData SYB.Parser 0 parsedOrig+ -- putStrLn $ "Test:ann :" ++ showGhc ann+ -- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns+ -- 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'+ -- putStrLn $ "Test:outcome' :" ++ outcome+ return (printed == contents)+++-- ---------------------------------------------------------------------+-- |Result of parsing a Haskell source file. It is simply the+-- TypeCheckedModule produced by GHC.+type ParseResult = GHC.ParsedModule++parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult,[Comment])+parsedFileGhc fileName _modname useTH = do+ -- putStrLn $ "parsedFileGhc:" ++ show fileName+ GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do+ GHC.runGhc (Just libdir) $ do+ dflags <- GHC.getSessionDynFlags+ let dflags2 = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/",+ "./src/","../src/"] }+ tgt = if useTH then GHC.HscInterpreted+ else GHC.HscNothing -- allows FFI+ dflags3 = dflags2 { GHC.hscTarget = tgt+ , GHC.ghcLink = GHC.LinkInMemory+ }++ dflags4 = GHC.gopt_set dflags3 GHC.Opt_KeepRawTokenStream++ (dflags5,_args,_warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"]+ -- GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc _args,map GHC.unLoc _warns)+ void $ GHC.setSessionDynFlags dflags5+ -- GHC.liftIO $ putStrLn $ "dflags set"++ -- hsc_env <- GHC.getSession+ -- (dflags6,fn_pp) <- GHC.liftIO $ GHC.preprocess hsc_env (fileName,Nothing)+ -- GHC.liftIO $ putStrLn $ "preprocess got:" ++ show fn_pp+++ target <- GHC.guessTarget fileName Nothing+ GHC.setTargets [target]+ -- GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target)+ void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make+ -- GHC.liftIO $ putStrLn $ "targets loaded"+ -- g <- GHC.getModuleGraph+ -- let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms)+ -- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g))++ -- modSum <- GHC.getModSummary $ GHC.mkModuleName modname+ Just modSum <- getModSummaryForFile fileName+ -- GHC.liftIO $ putStrLn $ "got modSum"+ -- let modSum = head g+ cppComments <- if (GHC.xopt GHC.Opt_Cpp dflags5)+ then getCppTokensAsComments defaultCppOptions fileName+ else return []+ -- let cppComments = [] :: [(GHC.Located GHC.Token, String)]+-- GHC.liftIO $ putStrLn $ "\ncppTokensAsComments for:" ++ fileName ++ "=========\n"+-- ++ showGhc cppComments ++ "\n================\n"+{-+ (sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum)+ strSrcBuf <- getPreprocessedSrc sourceFile+ GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n"+-}+ p <- GHC.parseModule modSum+ -- GHC.liftIO $ putStrLn $ "got parsedModule"+-- t <- GHC.typecheckModule p+ -- GHC.liftIO $ putStrLn $ "typechecked"+ -- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum)+ -- GHC.liftIO $ putStrLn $ "toks" ++ show toks+ let anns = GHC.pm_annotations p+ -- GHC.liftIO $ putStrLn $ "anns"+ return (anns,p,cppComments)++-- ---------------------------------------------------------------------++transformHighLevelTests :: [Test]+transformHighLevelTests =+ [+ mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" "AddLocalDecl1"+ , mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" "AddLocalDecl2"+ , mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" "AddLocalDecl3"++ , mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1"+ , mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2"++ , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1"+ ]++-- ---------------------------------------------------------------------++addLocaLDecl1 :: Changer+addLocaLDecl1 ans lp = do+ Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+ let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns++ doAddLocal = do+ tlDecs <- hsDecls lp+ let parent = head tlDecs+ decls <- hsDecls parent+ balanceComments parent (head $ tail tlDecs)++ modifyAnnsT (setPrecedingLines newDecl 1 4)++ parent' <- replaceDecls parent (newDecl:decls)+ replaceDecls lp (parent':tail tlDecs)++ let (lp',(ans',_),_w) = runTransform ans doAddLocal+ return (mergeAnnList [declAnns',ans'],lp')++-- ---------------------------------------------------------------------++addLocaLDecl2 :: Changer+addLocaLDecl2 ans lp = do+ Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+ let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns++ doAddLocal = do+ tlDecs <- hsDecls lp+ let parent = head tlDecs+ decls <- hsDecls parent+ balanceComments parent (head $ tail tlDecs)++ DP (r,c) <- getEntryDPT (head decls)+ modifyAnnsT (setPrecedingLines newDecl r c)+ modifyAnnsT (setPrecedingLines (head decls) 1 0)++ parent' <- replaceDecls parent (newDecl:decls)+ replaceDecls lp (parent':tail tlDecs)++ let (lp',(ans',_),_w) = runTransform ans doAddLocal+ return (mergeAnnList [declAnns',ans'],lp')++-- ---------------------------------------------------------------------++addLocaLDecl3 :: Changer+addLocaLDecl3 ans lp = do+ Right (declAnns, newDecl@(GHC.L ld (GHC.ValD decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2")+ let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns++ doAddLocal = do+ tlDecs <- hsDecls lp+ let parent = head tlDecs+ decls <- hsDecls parent+ balanceComments parent (head $ tail tlDecs)++ modifyAnnsT (setPrecedingLines newDecl 1 0)++ moveTrailingComments parent (last decls)+ parent' <- replaceDecls parent (decls++[newDecl])+ replaceDecls lp (parent':tail tlDecs)++ let (lp',(ans',_),_w) = runTransform ans doAddLocal+ return (mergeAnnList [declAnns',ans'],lp')++-- ---------------------------------------------------------------------++rmDecl1 :: Changer+rmDecl1 ans lp = do+ let doRmDecl = do+ tlDecs <- hsDecls lp+ let (d1:s1:d2:ds) = tlDecs++ -- First delete the decl only+ balanceComments d2 (head ds)+ lp1 <- replaceDecls lp (d1:s1:ds)++ -- Then delete the sig separately+ tlDecs1 <- hsDecls lp1+ let (d1':s1':ds') = tlDecs1+ balanceComments d1' s1'+ balanceComments s1' (head ds')+ replaceDecls lp (d1':ds')++ let (lp',(ans',_),_w) = runTransform ans doRmDecl+ return (ans',lp')++-- ---------------------------------------------------------------------++rmDecl2 :: Changer+rmDecl2 ans lp = do+ let+ doRmDecl = do+ let+ go :: GHC.HsExpr GHC.RdrName -> Transform (GHC.HsExpr GHC.RdrName)+ go (GHC.HsLet lb expr) = do+ decs <- hsDecls lb+ lb' <- replaceDecls lb (init decs)+ return (GHC.HsLet lb' expr)+ go x = return x++ SYB.everywhereM (SYB.mkM go) lp++ let (lp',(ans',_),_w) = runTransform ans doRmDecl+ return (ans',lp')++-- ---------------------------------------------------------------------++rmTypeSig1 :: Changer+rmTypeSig1 ans lp = do+ let doRmDecl = do+ tlDecs <- hsDecls lp+ let (s1:d1:d2) = tlDecs+ (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1+ s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p)))+ replaceDecls lp (s1':d1:d2)++ let (lp',(ans',_),_w) = runTransform ans doRmDecl+ return (ans',lp')++-- ---------------------------------------------------------------------
+ tests/examples/AddDecl.hs view
@@ -0,0 +1,9 @@+module AddDecl where++-- Adding a declaration to an existing file++-- | Do foo+foo a b = a + b++-- | Do bar+bar x y = foo (x+y) x
+ tests/examples/AddDecl.hs.expected view
@@ -0,0 +1,11 @@+module AddDecl where++nn = n2++-- Adding a declaration to an existing file++-- | Do foo+foo a b = a + b++-- | Do bar+bar x y = foo (x+y) x
+ tests/examples/AddLocalDecl1.hs view
@@ -0,0 +1,9 @@+module AddLocalDecl1 where++-- |This is a function+foo = x -- comment1++-- |Another fun+x = a -- comment2+ where+ a = 3
+ tests/examples/AddLocalDecl1.hs.expected view
@@ -0,0 +1,11 @@+module AddLocalDecl1 where++-- |This is a function+foo = x -- comment1+ where+ nn = 2++-- |Another fun+x = a -- comment2+ where+ a = 3
+ tests/examples/AddLocalDecl2.hs view
@@ -0,0 +1,10 @@+module AddLocalDecl2 where++-- |This is a function+foo = x -- comment 0+ where p = 2 -- comment 1++-- |Another fun+bar = a -- comment 2+ where nn = 2+ p = 2 -- comment 3
+ tests/examples/AddLocalDecl2.hs.expected view
@@ -0,0 +1,11 @@+module AddLocalDecl2 where++-- |This is a function+foo = x -- comment 0+ where nn = 2+ p = 2 -- comment 1++-- |Another fun+bar = a -- comment 2+ where nn = 2+ p = 2 -- comment 3
+ tests/examples/AddLocalDecl3.hs view
@@ -0,0 +1,10 @@+module AddLocalDecl2 where++-- |This is a function+foo = x -- comment 0+ where p = 2 -- comment 1++-- |Another fun+bar = a -- comment 2+ where p = 2 -- comment 3+ nn = 2
+ tests/examples/AddLocalDecl3.hs.expected view
@@ -0,0 +1,11 @@+module AddLocalDecl2 where++-- |This is a function+foo = x -- comment 0+ where p = 2 -- comment 1+ nn = 2++-- |Another fun+bar = a -- comment 2+ where p = 2 -- comment 3+ nn = 2
+ tests/examples/AnnPackageName.hs view
@@ -0,0 +1,4 @@+++import "base" Prelude+import "base" Data.Data
+ tests/examples/AssociatedType.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+class Foldable t where+ type FoldableConstraint t x :: *+ type FoldableConstraint t x = ()+
+ tests/examples/Backquote.hs view
@@ -0,0 +1,11 @@+import Data.List++foo = do+ let genOut (f,st) = putStrLn (f ++ "\t"++go [e`div`4,e`div`2,3*e`div`4] (scanl1 (+) $ sort st))+ Just 5++f = undefined+go = undefined+e = undefined++
+ tests/examples/BracesSemiDataDecl.hs view
@@ -0,0 +1,7 @@+++data Nat (t :: NatKind) where+{+ ZeroNat :: Nat Zero;+ SuccNat :: Nat t -> Nat (Succ t);+};
+ tests/examples/C.hs view
@@ -0,0 +1,12 @@+module C where+-- Test for refactor of if to case+-- The comments on the then and else legs should be preserved++foo x = if (odd x)+ then -- This is an odd result+ bob x 1+ else -- This is an even result+ bob x 2++bob x y = x + y+
+ tests/examples/C.hs.expected view
@@ -0,0 +1,12 @@+module C where+-- Test for refactor of if to case+-- The comments on the then and else legs should be preserved++foo x = case (odd x) of+ True -> -- This is an odd result+ bob x 1+ False -> -- This is an even result+ bob x 2++bob x y = x + y+
+ tests/examples/CExpected.hs view
@@ -0,0 +1,12 @@+module CExpected where+-- Test for refactor of if to case+-- The comments on the then and else legs should be preserved++foo x = case (odd x) of+ True -> -- This is an odd result+ bob x 1+ False -> -- This is an even result+ bob x 2++bob x y = x + y+
+ tests/examples/Commands.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE QuasiQuotes #-}++commands :: [Command]+commands = [+ command "help" "display a list of all commands, and their current keybindings" $ do+ macroGuesses <- Macro.guessCommands commandNames <$> getMacros+ addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose++ , command "log" "show the error log" $ do+ messages <- gets logMessages+ let widget = ListWidget.moveLast (ListWidget.new $ reverse messages)+ addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose++ , command "map" "display a list of all commands that are currently bound to keys" $ do+ showMappings++ , command "map" "display the command that is currently bound to the key {name}" $ do+ showMapping++ , command "map" [help|+ Bind the command {expansion} to the key {name}. The same command may+ be bound to different keys.+ |] $ do+ addMapping++ , command "unmap" "remove the binding currently bound to the key {name}" $ do+ \(MacroName m) -> removeMacro m++ , command "mapclear" "" $ do+ clearMacros++ , command "exit" "exit vimus" $ do+ eval "quit"++ , command "quit" "exit vimus" $ do+ liftIO exitSuccess :: Vimus ()++ , command "close" "close the current window (not all windows can be closed)" $ do+ void closeTab++ , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do+ \(Path p) -> liftIO (expandHome p) >>= either printError source_++ , command "runtime" "" $+ \(Path p) -> liftIO (getDataFileName p) >>= source_++ , command "color" "define the fore- and background color for a thing on the screen." $ do+ \color fg bg -> liftIO (defineColor color fg bg) :: Vimus ()++ , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do+ MPD.repeat True :: Vimus ()++ , command "norepeat" "Unset the playlist option *repeat*." $ do+ MPD.repeat False :: Vimus ()++ , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do+ MPD.consume True :: Vimus ()++ , command "noconsume" "Unset the playlist option *consume*." $ do+ MPD.consume False :: Vimus ()++ , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do+ MPD.random True :: Vimus ()++ , command "norandom" "Unset the playlist option *random*." $ do+ MPD.random False :: Vimus ()++ , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do+ MPD.single True :: Vimus ()++ , command "nosingle" "Unset the playlist option *single*." $ do+ MPD.single False :: Vimus ()++ , command "autotitle" "Set the *autotitle* option. When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do+ setAutoTitle True++ , command "noautotitle" "Unset the *autotitle* option." $ do+ setAutoTitle False++ , command "volume" "[+-] set volume to or adjust by [+-] num" $ do+ volume :: Volume -> Vimus ()++ , command "toggle-repeat" "Toggle the *repeat* option." $ do+ MPD.status >>= MPD.repeat . not . MPD.stRepeat :: Vimus ()++ , command "toggle-consume" "Toggle the *consume* option." $ do+ MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus ()++ , command "toggle-random" "Toggle the *random* option." $ do+ MPD.status >>= MPD.random . not . MPD.stRandom :: Vimus ()++ , command "toggle-single" "Toggle the *single* option." $ do+ MPD.status >>= MPD.single . not . MPD.stSingle :: Vimus ()++ , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do+ \(Path p) -> setLibraryPath p++ , command "next" "stop playing the current song, and starts the next one" $ do+ MPD.next :: Vimus ()++ , command "previous" "stop playing the current song, and starts the previous one" $ do+ MPD.previous :: Vimus ()++ , command "toggle" "toggle between play and pause" $ do+ MPDE.toggle :: Vimus ()++ , command "stop" "stop playback" $ do+ MPD.stop :: Vimus ()++ , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song. MPD will only rescan a file already in the database if its modification time has changed." $ do+ void (MPD.update Nothing) :: Vimus ()++ , command "rescan" "" $ do+ void (MPD.rescan Nothing) :: Vimus ()++ , command "clear" "delete all songs from the playlist" $ do+ MPD.clear :: Vimus ()++ , command "search-next" "jump to the next occurrence of the search string in the current window"+ searchNext++ , command "search-prev" "jump to the previous occurrence of the search string in the current window"+ searchPrev+++ , command "window-library" "open the *Library* window" $+ selectTab Library++ , command "window-playlist" "open the *Playlist* window" $+ selectTab Playlist++ , command "window-search" "open the *SearchResult* window" $+ selectTab SearchResult++ , command "window-browser" "open the *Browser* window" $+ selectTab Browser++ , command "window-next" "open the window to the right of the current one"+ nextTab++ , command "window-prev" "open the window to the left of the current one"+ previousTab++ , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example."+ runShellCommand++ , command "seek" "jump to the given position in the current song"+ seek++ , command "visual" "start visual selection" $+ sendEventCurrent EvVisual++ , command "novisual" "cancel visual selection" $+ sendEventCurrent EvNoVisual++ -- Remove current song from playlist+ , command "remove" "remove the song under the cursor from the playlist" $+ sendEventCurrent EvRemove++ , command "paste" "add the last deleted song after the selected song in the playlist" $+ sendEventCurrent EvPaste++ , command "paste-prev" "" $+ sendEventCurrent EvPastePrevious++ , command "copy" "" $+ sendEventCurrent EvCopy++ , command "shuffle" "shuffle the current playlist" $ do+ MPD.shuffle Nothing :: Vimus ()++ , command "add" "append selected songs to the end of the playlist" $ do+ sendEventCurrent EvAdd++ -- insert a song right after the current song+ , command "insert" [help|+ inserts a song to the playlist. The song is inserted after the currently+ playing song.+ |] $ do+ st <- MPD.status+ case MPD.stSongPos st of+ Just n -> do+ -- there is a current song, insert after+ sendEventCurrent (EvInsert (n + 1))+ _ -> do+ -- there is no current song, just add+ sendEventCurrent EvAdd++ -- Playlist: play selected song+ -- Library: add song to playlist and play it+ -- Browse: either add song to playlist and play it, or :move-in+ , command "default-action" [help|+ depending on the item under the cursor, somthing different happens:++ - *Playlist* start playing the song under the cursor++ - *Library* append the song under the cursor to the playlist and start playing it++ - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory.+ |] $ do+ sendEventCurrent EvDefaultAction++ , command "add-album" "add all songs of the album of the selected song to the playlist" $ do+ songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track]+ maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs++ , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do+ songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track]+ maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs++ -- movement+ , command "move-up" "move the cursor one line up" $+ sendEventCurrent EvMoveUp++ , command "move-down" "move the cursor one line down" $+ sendEventCurrent EvMoveDown++ , command "move-album-prev" "move the cursor up to the first song of an album" $+ sendEventCurrent EvMoveAlbumPrev++ , command "move-album-next" "move the cursor down to the first song of an album" $+ sendEventCurrent EvMoveAlbumNext++ , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $+ sendEventCurrent EvMoveIn++ , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $+ sendEventCurrent EvMoveOut++ , command "move-first" "go to the first line in the current window" $+ sendEventCurrent EvMoveFirst++ , command "move-last" "go to the last line in the current window" $+ sendEventCurrent EvMoveLast++ , command "scroll-up" "scroll the contents of the current window up one line" $+ sendEventCurrent (EvScroll (-1))++ , command "scroll-down" "scroll the contents of the current window down one line" $+ sendEventCurrent (EvScroll 1)++ , command "scroll-page-up" "scroll the contents of the current window up one page" $+ pageScroll >>= sendEventCurrent . EvScroll . negate++ , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $+ pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2)++ , command "scroll-page-down" "scroll the contents of the current window down one page" $+ pageScroll >>= sendEventCurrent . EvScroll++ , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $+ pageScroll >>= sendEventCurrent . EvScroll . (`div` 2)++ , command "song-format" "set song rendering format" $+ sendEvent . EvChangeSongFormat+ ]+
+ tests/examples/Control.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE CPP+ , NoImplicitPrelude+ , ScopedTypeVariables+ , BangPatterns+ #-}++module GHC.Event.Control+ (+ -- * Managing the IO manager+ Signal+ , ControlMessage(..)+ , Control+ , newControl+ , closeControl+ -- ** Control message reception+ , readControlMessage+ -- *** File descriptors+ , controlReadFd+ , controlWriteFd+ , wakeupReadFd+ -- ** Control message sending+ , sendWakeup+ , sendDie+ -- * Utilities+ , setNonBlockingFD+ ) where++#include "EventConfig.h"++import Foreign.ForeignPtr (ForeignPtr)+import GHC.Base+import GHC.Conc.Signal (Signal)+import GHC.Real (fromIntegral)+import GHC.Show (Show)+import GHC.Word (Word8)+import Foreign.C.Error (throwErrnoIfMinus1_)+import Foreign.C.Types (CInt(..), CSize(..))+import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)+import Foreign.Marshal (alloca, allocaBytes)+import Foreign.Marshal.Array (allocaArray)+import Foreign.Ptr (castPtr)+import Foreign.Storable (peek, peekElemOff, poke)+import System.Posix.Internals (c_close, c_pipe, c_read, c_write,+ setCloseOnExec, setNonBlockingFD)+import System.Posix.Types (Fd)++#if defined(HAVE_EVENTFD)+import Foreign.C.Error (throwErrnoIfMinus1)+import Foreign.C.Types (CULLong(..))+#else+import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)+#endif++data ControlMessage = CMsgWakeup+ | CMsgDie+ | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)+ {-# UNPACK #-} !Signal+ deriving (Eq, Show)++-- | The structure used to tell the IO manager thread what to do.+data Control = W {+ controlReadFd :: {-# UNPACK #-} !Fd+ , controlWriteFd :: {-# UNPACK #-} !Fd+#if defined(HAVE_EVENTFD)+ , controlEventFd :: {-# UNPACK #-} !Fd+#else+ , wakeupReadFd :: {-# UNPACK #-} !Fd+ , wakeupWriteFd :: {-# UNPACK #-} !Fd+#endif+ , didRegisterWakeupFd :: !Bool+ } deriving (Show)++#if defined(HAVE_EVENTFD)+wakeupReadFd :: Control -> Fd+wakeupReadFd = controlEventFd+{-# INLINE wakeupReadFd #-}+#endif++-- | Create the structure (usually a pipe) used for waking up the IO+-- manager thread from another thread.+newControl :: Bool -> IO Control+newControl shouldRegister = allocaArray 2 $ \fds -> do+ let createPipe = do+ throwErrnoIfMinus1_ "pipe" $ c_pipe fds+ rd <- peekElemOff fds 0+ wr <- peekElemOff fds 1+ -- The write end must be non-blocking, since we may need to+ -- poke the event manager from a signal handler.+ setNonBlockingFD wr True+ setCloseOnExec rd+ setCloseOnExec wr+ return (rd, wr)+ (ctrl_rd, ctrl_wr) <- createPipe+#if defined(HAVE_EVENTFD)+ ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0+ setNonBlockingFD ev True+ setCloseOnExec ev+ when shouldRegister $ c_setIOManagerWakeupFd ev+#else+ (wake_rd, wake_wr) <- createPipe+ when shouldRegister $ c_setIOManagerWakeupFd wake_wr+#endif+ return W { controlReadFd = fromIntegral ctrl_rd+ , controlWriteFd = fromIntegral ctrl_wr+#if defined(HAVE_EVENTFD)+ , controlEventFd = fromIntegral ev+#else+ , wakeupReadFd = fromIntegral wake_rd+ , wakeupWriteFd = fromIntegral wake_wr+#endif+ , didRegisterWakeupFd = shouldRegister+ }++-- | Close the control structure used by the IO manager thread.+-- N.B. If this Control is the Control whose wakeup file was registered with+-- the RTS, then *BEFORE* the wakeup file is closed, we must call+-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup+-- file after it has been closed.+closeControl :: Control -> IO ()+closeControl w = do+ _ <- c_close . fromIntegral . controlReadFd $ w+ _ <- c_close . fromIntegral . controlWriteFd $ w+ when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)+#if defined(HAVE_EVENTFD)+ _ <- c_close . fromIntegral . controlEventFd $ w+#else+ _ <- c_close . fromIntegral . wakeupReadFd $ w+ _ <- c_close . fromIntegral . wakeupWriteFd $ w+#endif+ return ()++io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8+io_MANAGER_WAKEUP = 0xff+io_MANAGER_DIE = 0xfe++foreign import ccall "__hscore_sizeof_siginfo_t"+ sizeof_siginfo_t :: CSize++readControlMessage :: Control -> Fd -> IO ControlMessage+readControlMessage ctrl fd+ | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do+ throwErrnoIfMinus1_ "readWakeupMessage" $+ c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)+ return CMsgWakeup+ | otherwise =+ alloca $ \p -> do+ throwErrnoIfMinus1_ "readControlMessage" $+ c_read (fromIntegral fd) p 1+ s <- peek p+ case s of+ -- Wakeup messages shouldn't be sent on the control+ -- file descriptor but we handle them anyway.+ _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup+ _ | s == io_MANAGER_DIE -> return CMsgDie+ _ -> do -- Signal+ fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)+ withForeignPtr fp $ \p_siginfo -> do+ r <- c_read (fromIntegral fd) (castPtr p_siginfo)+ sizeof_siginfo_t+ when (r /= fromIntegral sizeof_siginfo_t) $+ error "failed to read siginfo_t"+ let !s' = fromIntegral s+ return $ CMsgSignal fp s'++ where wakeupBufferSize =+#if defined(HAVE_EVENTFD)+ 8+#else+ 4096+#endif++sendWakeup :: Control -> IO ()+#if defined(HAVE_EVENTFD)+sendWakeup c =+ throwErrnoIfMinus1_ "sendWakeup" $+ c_eventfd_write (fromIntegral (controlEventFd c)) 1+#else+sendWakeup c = do+ n <- sendMessage (wakeupWriteFd c) CMsgWakeup+ case n of+ _ | n /= -1 -> return ()+ | otherwise -> do+ errno <- getErrno+ when (errno /= eAGAIN && errno /= eWOULDBLOCK) $+ throwErrno "sendWakeup"+#endif++sendDie :: Control -> IO ()+sendDie c = throwErrnoIfMinus1_ "sendDie" $+ sendMessage (controlWriteFd c) CMsgDie++sendMessage :: Fd -> ControlMessage -> IO Int+sendMessage fd msg = alloca $ \p -> do+ case msg of+ CMsgWakeup -> poke p io_MANAGER_WAKEUP+ CMsgDie -> poke p io_MANAGER_DIE+ CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"+ fromIntegral `fmap` c_write (fromIntegral fd) p 1++#if defined(HAVE_EVENTFD)+foreign import ccall unsafe "sys/eventfd.h eventfd"+ c_eventfd :: CInt -> CInt -> IO CInt++foreign import ccall unsafe "sys/eventfd.h eventfd_write"+ c_eventfd_write :: CInt -> CULLong -> IO CInt+#endif++foreign import ccall unsafe "setIOManagerWakeupFd"+ c_setIOManagerWakeupFd :: CInt -> IO ()
+ tests/examples/CorePragma.hs view
@@ -0,0 +1,6 @@+{-# INLINE strictStream #-}+strictStream (Bitstream l v)+ = {-# CORE "Strict Bitstream stream" #-}+ S.concatMap stream (GV.stream v)+ `S.sized`+ Exact l
tests/examples/Cpp.hs view
@@ -7,3 +7,11 @@ #endif foo = 3 +bar :: (+#if __GLASGOW_HASKELL__ > 704+ Int)+#else+ Integer)+#endif+bar = 4+
tests/examples/Dead1.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-}+{-# OPTIONS -O -ddump-stranal #-} module Dead1(foo) where
+ tests/examples/DefaultTypeInstance.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE TypeFamilies #-}+++class Foldable t where+ type FoldableConstraint t x :: Constraint+ type FoldableConstraint t x = ()
tests/examples/Deprecation.hs view
@@ -1,7 +1,8 @@ module Deprecation {-# Deprecated ["This is a module \"deprecation\"",- "multi-line"] #-}+ "multi-line",+ "with unicode: Frère" ] #-} ( foo ) where @@ -12,3 +13,4 @@ foo :: Int foo = 4 +{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
+ tests/examples/DoParens.hs view
@@ -0,0 +1,4 @@++foo = do+ (-) <- Just 5+ return ()
+ tests/examples/DoPatBind.hs view
@@ -0,0 +1,4 @@+module Main where++bar = do+ foo :: String <- baz
+ tests/examples/DoubleForall.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE ScopedTypeVariables #-}+++extremumNewton :: (Eq a, Fractional a) =>+ (forall tag. forall tag1.+ Tower tag1 (Tower tag a)+ -> Tower tag1 (Tower tag a))+ -> a -> [a]+extremumNewton f x0 = zeroNewton (diffUU f) x0
+ tests/examples/DroppedComma.hs view
@@ -0,0 +1,5 @@+++foo =+ let (xs, ys) = ([1,2..3], [4,5..6]) in+ bar
+ tests/examples/DroppedDoSpace.hs view
@@ -0,0 +1,26 @@+import FooBarBaz -- non-existent import, check that we can still parse++save :: C -> IO ()+save state = saveFileDialog "Save file " (maybe Nothing (Just . (++) "*.") (filesuffix state)) $+ do \fileName ->+ case onSaveCB state of+ Nothing ->+ return ()+ Just callback ->+ do+ c <- callback+ case c of+ Nothing ->+ return ()+ Just c' ->+ let realfn = maybe+ fileName+ (extendFileName fileName)+ (filesuffix state)+ in do+ L.writeFile realfn c'+ postGUIAsync $ labelSetText (View.statusL $ gui state) $ realfn ++ " Saved."+ where+ extendFileName fileName suffix = if isSuffixOf suffix fileName+ then fileName+ else fileName ++ "." ++ suffix
+ tests/examples/DroppedDoSpace2.hs view
@@ -0,0 +1,6 @@+++save state = do \fileName ->+ 4++
+ tests/examples/ExplicitNamespaces.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++module CLaSH.Prelude.BitIndex where++import GHC.TypeLits (KnownNat, type (+), type (-))
− tests/examples/Foo.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE RecursiveDo #-}--bar :: IO ()-bar = do- rec {}- return ()-
tests/examples/ForeignDecl.hs view
@@ -46,6 +46,8 @@ foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 +foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ();+ foreign import ccall unsafe "kitchen" sink :: Ptr a -> ByteArray#@@ -83,3 +85,23 @@ -- exports foreign export ccall "plusInt" (+) :: Int -> Int -> Int++listToJSArray :: ToJSRef a => [a] -> IO (JSArray a)+listToJSArray = toJSArray deconstr+ where deconstr (x : xs) = Just (x, xs)+ deconstr [] = Nothing++foreign import javascript unsafe "$r = new Float32Array($1);"+ float32Array :: JSArray Float -> IO Float32Array++foreign import javascript unsafe "$r = new Int32Array($1);"+ int32Array :: JSArray Int32 -> IO Int32Array++foreign import javascript unsafe "$r = new Uint16Array($1);"+ uint16Array :: JSArray Word16 -> IO Uint16Array++foreign import javascript unsafe "$r = new Uint8Array($1);"+ uint8Array :: JSArray Word8 -> IO Uint8Array++foreign import javascript unsafe "$r = $1.getContext(\"webgl\");"+ getCtx :: JSRef a -> IO Ctx
+ tests/examples/GADTContext.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}++data StackItem a where+ Snum :: forall a. Fractional a => a -> StackItem a+ Sop :: OpDesc -> StackItem a+deriving instance Show a => Show (StackItem a)++-- AZ added to test Trac #10399+data MaybeDefault v where+ SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v+ SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v -> a -> MaybeDefault [a])
+ tests/examples/GADTRecords.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE GADTs #-}+module GADTRecords (H1(..)) where++-- | h1+data H1 a b where+ C1 :: H1 a b+ C2 :: Ord a => [a] -> H1 a a+ C3 :: { field :: Int -- ^ hello docs+ } -> H1 Int Int+ C4 :: { field2 :: a -- ^ hello2 docs+ } -> H1 Int a++ FwdDataflowAnalysis :: (Eq f, Monad m) => { analysisTop :: f+ , analysisMeet :: f -> f -> f+ , analysisTransfer :: f -> Instruction -> m f+ , analysisFwdEdgeTransfer :: Maybe (f -> Instruction -> m [(BasicBlock, f)])+ } -> DataflowAnalysis m f++data GADT :: * -> * where+ Ctor :: { gadtField :: A } -> GADT A
+ tests/examples/GADTRecords2.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE GADTs #-}+module GADTRecords2 (H1(..)) where++-- | h1+data H1 a b where+ C3 :: (Num a) => { field :: a -- ^ hello docs+ } -> H1 Int Int
+ tests/examples/GHCOrig.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE NoImplicitPrelude, DeriveGeneric #-}+-----------------------------------------------------------------------------+-- |+-- Module : GHC.Tuple+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file libraries/ghc-prim/LICENSE)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- The tuple data types+--+-----------------------------------------------------------------------------++module GHC.Tuple where+++default () -- Double and Integer aren't available yet++-- | The unit datatype @()@ has one non-undefined member, the nullary+-- constructor @()@.+data () = ()++data (,) a b = (,) a b+data (,,) a b c = (,,) a b c+data (,,,) a b c d = (,,,) a b c d+data (,,,,) a b c d e = (,,,,) a b c d e+data (,,,,,) a b c d e f = (,,,,,) a b c d e f+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i+data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j+data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k+data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l+data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m+data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n+data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o+data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p+data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q+ = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q+data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r+ = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r+data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s+ = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s+data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t+ = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t+data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u+ = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u+data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v+ = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v+data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w+ = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w+data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x+ = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x+data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y+ = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y+data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z+ = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z+data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__++{- Manuel says: Including one more declaration gives a segmentation fault.+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___+-}
+ tests/examples/Hang.hs view
@@ -0,0 +1,1 @@+(~>) = forall
+ tests/examples/HangingRecord.hs view
@@ -0,0 +1,5 @@++data Foo = Foo+ { r1 :: Int+ , r2 :: Int+ }
+ tests/examples/HashQQ.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Maid.ApacheMimeTypes where+++import qualified Data.Text as T+import Air.TH++++apache_mime_types :: T.Text+apache_mime_types = [here|++# This file maps Internet media types to unique file extension(s).+# Although created for httpd, this file is used by many software systems+# and has been placed in the public domain for unlimited redisribution.+#+# The table below contains both registered and (common) unregistered types.+# A type that has no unique extension can be ignored -- they are listed+# here to guide configurations toward known types and to make it easier to+# identify "new" types. File extensions are also commonly used to indicate+# content languages and encodings, so choose them carefully.+#+# Internet media types should be registered as described in RFC 4288.+# The registry is at .+#+# MIME type (lowercased) Extensions+# ============================================ ==========+# application/1d-interleaved-parityfec+# application/3gpp-ims+xml+# application/activemessage+application/andrew-inset ez |]+++testComplex = assertBool "" ([$istr|+ ok+#{Foo 4 "Great!" : [Foo 3 "Scott!"]}+ then+|] == ("\n" +++ " ok\n" +++ "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" +++ " then\n"))+
+ tests/examples/ImplicitSemi.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE ImplicitParams #-}++explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b+explicit x ab be = x where ?above = ab; ?below = be
+ tests/examples/ImplicitTypeSyn.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}++type MPI = ?mpi_secret :: MPISecret
+ tests/examples/Imports.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ExplicitNamespaces #-}+module Imports( f, type (+), pattern Single ) where++import GHC.TypeLits++pattern Single x = [x]++f = undefined
+ tests/examples/IndentedDo.hs view
@@ -0,0 +1,12 @@++++foo =+ parseTestFile "gitlogo-double.ppm" "a multi-image file" $ do+ \res -> case res of+ Right ([ PPM { ppmHeader = h1 }+ , PPM { ppmHeader = h2 }], rest) -> do h1 `shouldBe` PPMHeader P6 220 92+ h2 `shouldBe` PPMHeader P6 220 92+ rest `shouldBe` Nothing+ Right r -> assertFailure $ "parsed unexpected: " ++ show r+ Left e -> assertFailure $ "did not parse: " ++ e
+ tests/examples/InfixOperator.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE BangPatterns, CPP, OverloadedStrings #-}++#define BACKSLASH 92+#define CLOSE_CURLY 125+#define CLOSE_SQUARE 93+#define COMMA 44+#define DOUBLE_QUOTE 34+#define OPEN_CURLY 123+#define OPEN_SQUARE 91+#define C_0 48+#define C_9 57+#define C_A 65+#define C_F 70+#define C_a 97+#define C_f 102+#define C_n 110+#define C_t 116++json_ :: Parser Value -> Parser Value -> Parser Value+json_ obj ary = do+ w <- skipSpace *> A.satisfy (\w -> w == OPEN_CURLY || w == OPEN_SQUARE)+ if w == OPEN_CURLY+ then obj+ else ary+{-# INLINE json_ #-}+
+ tests/examples/InfixPatternSynonyms.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE PatternSynonyms #-}++-- | The pattern synonym equivalent of 'destIff'.+pattern l :<=> r <- Comb (Comb (Const "=" (TyBool :-> TyBool :-> TyBool)) l) r++-- | Destructor for boolean conjunctions.+destConj :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destConj = destBinary "/\\"++-- | The pattern synonym equivalent of 'destConj'.+pattern l :/\ r <- Binary "/\\" l r++-- | Destructor for boolean implications.+destImp :: HOLTerm -> Maybe (HOLTerm, HOLTerm)+destImp = destBinary "==>"++-- | The pattern synonym equivalent of 'destImp'.+pattern l :==> r <- Binary "==>" l r
+ tests/examples/InlineSemi.hs view
@@ -0,0 +1,1 @@+{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i
+ tests/examples/Internals.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,+ CPP #-}+#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE RoleAnnotations #-}+#endif++{-# OPTIONS_HADDOCK hide #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Array.IO.Internal+-- Copyright : (c) The University of Glasgow 2001-2012+-- License : BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : non-portable (uses Data.Array.Base)+--+-- Mutable boxed and unboxed arrays in the IO monad.+--+-----------------------------------------------------------------------------++module Data.Array.IO.Internals (+ IOArray(..), -- instance of: Eq, Typeable+ IOUArray(..), -- instance of: Eq, Typeable+ castIOUArray, -- :: IOUArray ix a -> IO (IOUArray ix b)+ unsafeThawIOUArray,+ ) where++import Data.Int+import Data.Word+import Data.Typeable++import Control.Monad.ST ( RealWorld, stToIO )+import Foreign.Ptr ( Ptr, FunPtr )+import Foreign.StablePtr ( StablePtr )++#if __GLASGOW_HASKELL__ < 711+import Data.Ix+#endif+import Data.Array.Base++import GHC.IOArray (IOArray(..))++-----------------------------------------------------------------------------+-- Flat unboxed mutable arrays (IO monad)++-- | Mutable, unboxed, strict arrays in the 'IO' monad. The type+-- arguments are as follows:+--+-- * @i@: the index type of the array (should be an instance of 'Ix')+--+-- * @e@: the element type of the array. Only certain element types+-- are supported: see "Data.Array.MArray" for a list of instances.+--+newtype IOUArray i e = IOUArray (STUArray RealWorld i e)+ deriving Typeable+#if __GLASGOW_HASKELL__ >= 708+-- Both parameters have class-based invariants. See also #9220.+type role IOUArray nominal nominal+#endif++instance Eq (IOUArray i e) where+ IOUArray s1 == IOUArray s2 = s1 == s2++instance MArray IOUArray Bool IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Char IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Int IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Word IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray (Ptr a) IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray (FunPtr a) IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Float IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Double IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray (StablePtr a) IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Int8 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Int16 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Int32 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Int64 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Word8 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Word16 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Word32 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++instance MArray IOUArray Word64 IO where+ {-# INLINE getBounds #-}+ getBounds (IOUArray arr) = stToIO $ getBounds arr+ {-# INLINE getNumElements #-}+ getNumElements (IOUArray arr) = stToIO $ getNumElements arr+ {-# INLINE newArray #-}+ newArray lu initialValue = stToIO $ do+ marr <- newArray lu initialValue; return (IOUArray marr)+ {-# INLINE unsafeNewArray_ #-}+ unsafeNewArray_ lu = stToIO $ do+ marr <- unsafeNewArray_ lu; return (IOUArray marr)+ {-# INLINE newArray_ #-}+ newArray_ = unsafeNewArray_+ {-# INLINE unsafeRead #-}+ unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)+ {-# INLINE unsafeWrite #-}+ unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)++-- | Casts an 'IOUArray' with one element type into one with a+-- different element type. All the elements of the resulting array+-- are undefined (unless you know what you\'re doing...).+castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)+castIOUArray (IOUArray marr) = stToIO $ do+ marr' <- castSTUArray marr+ return (IOUArray marr')++{-# INLINE unsafeThawIOUArray #-}+#if __GLASGOW_HASKELL__ >= 711+unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e)+#else+unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)+#endif+unsafeThawIOUArray arr = stToIO $ do+ marr <- unsafeThawSTUArray arr+ return (IOUArray marr)++{-# RULES+"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray+ #-}++#if __GLASGOW_HASKELL__ >= 711+thawIOUArray :: UArray ix e -> IO (IOUArray ix e)+#else+thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)+#endif+thawIOUArray arr = stToIO $ do+ marr <- thawSTUArray arr+ return (IOUArray marr)++{-# RULES+"thaw/IOUArray" thaw = thawIOUArray+ #-}++{-# INLINE unsafeFreezeIOUArray #-}+#if __GLASGOW_HASKELL__ >= 711+unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e)+#else+unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)+#endif+unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)++{-# RULES+"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray+ #-}++#if __GLASGOW_HASKELL__ >= 711+freezeIOUArray :: IOUArray ix e -> IO (UArray ix e)+#else+freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)+#endif+freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)++{-# RULES+"freeze/IOUArray" freeze = freezeIOUArray+ #-}
+ tests/examples/Jon.hs view
@@ -0,0 +1,4 @@+{- ___ -}import Data.Char;main=putStr$do{c<-"/1 AA A A;9+ )11929 )1191A 2C9A ";e+{- | -} .(`divMod`8).(+(-32)).ord$c};e(0,0)="\n";e(m,n)=m?" "++n?"_/"+{- | -}n?x=do{[1..n];x} --- obfuscated+{-\_/ on Fairbairn, with apologies to Chris Brown. Above is / Haskell 98 -}
+ tests/examples/LambdaCase.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE LambdaCase #-}++foo = f >>= \case+ Just h -> loadTestDB (h ++ "/.testdb")+ Nothing -> fmap S.Right initTestDB++{-| Is the alarm set - i.e. will it go off at some point in the future even if `setAlarm` is not called? -}+isAlarmSetSTM :: AlarmClock -> STM Bool+isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting+ >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }
+ tests/examples/LetIn1.hs view
@@ -0,0 +1,19 @@+module LetIn1 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 local 'pow' to 'sq'+--This example also aims to test the demoting a local declaration in 'let'.++sumSquares x y = let sq 0=0+ sq z=z^pow+ pow=2+ in sq x + sq y+++anotherFun 0 y = sq y+ where sq x = x^2++
+ tests/examples/LetIn1.hs.expected view
@@ -0,0 +1,18 @@+module LetIn1 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 local 'pow' to 'sq'+--This example also aims to test the demoting a local declaration in 'let'.++sumSquares x y = let sq 0=0+ sq z=z^pow+ in sq x + sq y+++anotherFun 0 y = sq y+ where sq x = x^2++
+ tests/examples/LiftedConstructors.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DataKinds, TypeOperators, GADTs #-}++give :: b -> Pattern '[b] a+give b = Pattern (const (Just $ oneT b))+++pfail :: Pattern '[] a+pfail = is (const False)++(/\) :: Pattern vs1 a -> Pattern vs2 a -> Pattern (vs1 :++: vs2) a+(/\) = mk2 (\a -> Just (a,a))++data Pattern :: [*] -> * where+ Nil :: Pattern '[]+ Cons :: Maybe h -> Pattern t -> Pattern (h ': t)++type Pos = '("vpos", V3 GLfloat)+type Tag = '("tagByte", V1 Word8)++-- | Alias for the 'In' type from the 'Direction' kind, allows users to write+-- the 'BroadcastChan In a' type without enabling DataKinds.+type In = 'In+-- | Alias for the 'Out' type from the 'Direction' kind, allows users to write+-- the 'BroadcastChan Out a' type without enabling DataKinds.+type Out = 'Out
+ tests/examples/LiftedInfixConstructor.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DataKinds, TemplateHaskell #-}++applicate :: Bool -> [Stmt] -> ExpQ+applicate rawPatterns stmt = do+ return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g)+ (VarE 'pure `AppE` f')+ es++tuple :: Int -> ExpQ+tuple n = do+ ns <- replicateM n (newName "x")+ lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)
+ tests/examples/LinePragma.hs view
@@ -0,0 +1,36 @@+module UHC.Light.Compiler.Core.SysF.AsTy+( Ty+, ty2TySysfWithEnv, ty2TyC+, ty2TyCforFFI )+where+import UHC.Light.Compiler.Base.Common+import UHC.Light.Compiler.Opts.Base+import UHC.Light.Compiler.Error+import qualified UHC.Light.Compiler.Core as C+import qualified UHC.Light.Compiler.Ty as T+import UHC.Light.Compiler.FinalEnv++{-# LINE 50 "src/ehc/Core/SysF/AsTy.chs" #-}+-- | The type, represented by a term CExpr+type Ty = C.SysfTy -- base ty++-- | Binding the bound+type TyBind = C.SysfTyBind+type TyBound = C.SysfTyBound++-- | A sequence of parameters (for now just a single type)+type TySeq = C.SysfTySeq+++{-# LINE 67 "src/ehc/Core/SysF/AsTy.chs" #-}+ty2TySysfWithEnv :: ToSysfEnv -> T.Ty -> Ty+ty2TySysfWithEnv _ t = t++-- | Construct a type for use by AbstractCore+ty2TyC :: EHCOpts -> ToSysfEnv -> T.Ty -> C.CTy+ty2TyC o env t = C.mkCTy o t (ty2TySysfWithEnv env t)++{-# LINE 93 "src/ehc/Core/SysF/AsTy.chs" #-}+-- | Construct a type for use by AbstractCore, specifically for use by FFI+ty2TyCforFFI :: EHCOpts -> T.Ty -> C.CTy+ty2TyCforFFI o t = C.mkCTy o t t
tests/examples/ListComprehensions.hs view
@@ -74,3 +74,26 @@ , then group by birthYear using groupByLargest ] +uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs+ , let d' = ppDir d+ , then group by Down (p,d') using groupWith ]++legendres :: [Poly Rational]+legendres = one : x :+ [ multPoly+ (poly LE [recip (n' + 1)])+ (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n)+ (poly LE [-n'] `multPoly` p_nm1)+ )+ | n <- [1..], let n' = fromInteger n+ | p_n <- tail legendres+ | p_nm1 <- legendres+ ]++fromGroups' :: (Ord k) => a -> [a] -> Maybe (W.Stack k) -> Groups k -> [a]+ -> [(Bool,(a, W.Stack k))]+fromGroups' defl defls st gs sls =+ [ (isNew,fromMaybe2 (dl, single w) (l, M.lookup w gs))+ | l <- map Just sls ++ repeat Nothing, let isNew = isNothing l+ | dl <- defls ++ repeat defl+ | w <- W.integrate' $ W.filter (`notElem` unfocs) =<< st ]
+ tests/examples/LocalDecls.hs view
@@ -0,0 +1,8 @@+module LocalDecls where++foo a = bar a+ where+ bar :: Int -> Int+ bar x = x + 2++ baz = 4
+ tests/examples/LocalDecls.hs.expected view
@@ -0,0 +1,11 @@+module LocalDecls where++foo a = bar a+ where+ nn :: Int+ nn = 2++ bar :: Int -> Int+ bar x = x + 2++ baz = 4
+ tests/examples/LocalDecls2.hs view
@@ -0,0 +1,3 @@+module LocalDecls2 where++foo a = bar a
+ tests/examples/LocalDecls2.hs.expected view
@@ -0,0 +1,6 @@+module LocalDecls2 where++foo a = bar a+ where+ nn :: Int+ nn = 2
+ tests/examples/LocalDecls2Expected.hs view
@@ -0,0 +1,6 @@+module LocalDecls2Expected where++foo a = bar a+ where+ nn :: Int+ nn = 2
+ tests/examples/MagicHash.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE MagicHash #-}++module Data.Text.Internal.Builder.Functions+ (+ (<>)+ , i2d+ ) where++import Data.Monoid (mappend)+import Data.Text.Lazy.Builder (Builder)+import GHC.Base++-- | Unsafe conversion for decimal digits.+{-# INLINE i2d #-}+i2d :: Int -> Char+i2d (I# i#) = C# (chr# (ord# '0'# +# i#))++main =+ print (F# (expFloat# 3.45#))++-- | The normal 'mappend' function with right associativity instead of+-- left.+(<>) :: Builder -> Builder -> Builder+(<>) = mappend+{-# INLINE (<>) #-}++infixr 4 <>++
+ tests/examples/MangledSemiLet.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE+ BangPatterns+ #-}+++mtGamma a b =+ let !x_2 = x*x; !x_4 = x_2*x_2+ v3 = v*v*v+ dv = d * v3+ in 5
+ tests/examples/Minimal.hs view
@@ -0,0 +1,37 @@+class AwsType a where+ toText :: a -> b+++ {-# MINIMAL toText #-}++class Minimal a where+ toText :: a -> b+ {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-}++class Minimal a where+ toText :: a -> b+ {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}++class Minimal a where+ toText :: a -> b+ {-# MINIMAL (toSample | toSamples) #-}++class ManyOps a where+ aOp :: a -> a -> Bool+ bOp :: a -> a -> Bool+ cOp :: a -> a -> Bool+ dOp :: a -> a -> Bool+ eOp :: a -> a -> Bool+ fOp :: a -> a -> Bool+ {-# MINIMAL ( aOp)+ | ( bOp , cOp)+ | ((dOp | eOp) , fOp)+ #-}++class Foo a where+ bar :: a -> a -> Bool+ foo :: a -> a -> Bool+ baq :: a -> a -> Bool+ baz :: a -> a -> Bool+ quux :: a -> a -> Bool+ {-# MINIMAL bar, (foo, baq | foo, quux) #-}
+ tests/examples/MultiImplicitParams.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ImplicitParams #-}++foo = do+ ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos+ ?buttonChanges = _button+ in sink+ return baz
+ tests/examples/MultiLineCommentWithPragmas.hs view
@@ -0,0 +1,18 @@++{-+-- this is ugly too: can't use Data.Complex because the qd bindings do+-- not implement some low-level functions properly, leading to obscure+-- crashes inside various Data.Complex functions...+data Complex c = {-# UNPACK #-} !c :+ {-# UNPACK #-} !c deriving (Read, Show, Eq)++-- complex number arithmetic, with extra strictness and cost-centres+instance Num c => Num (Complex c) where+ (!(a :+ b)) + (!(c :+ d)) = {-# SCC "C+" #-} ((a + c) :+ (b + d))+ (!(a :+ b)) - (!(c :+ d)) = {-# SCC "C-" #-} ((a - c) :+ (b - d))+ (!(a :+ b)) * (!(c :+ d)) = {-# SCC "C*" #-} ((a * c - b * d) :+ (a * d + b * c))+ negate !(a :+ b) = (-a) :+ (-b)+ abs x = error $ "Complex.abs: " ++ show x+ signum x = error $ "Complex.signum: " ++ show x+ fromInteger !x = fromInteger x :+ 0+-}+
+ tests/examples/MultiLineWarningPragma.hs view
@@ -0,0 +1,18 @@++{-# WARNING Logic+ , mkSolver+ , mkSimpleSolver+ , mkSolverForLogic+ , solverSetParams+ , solverPush+ , solverPop+ , solverReset+ , solverGetNumScopes+ , solverAssertCnstr+ , solverAssertAndTrack+ , solverCheck+ , solverCheckAndGetModel+ , solverGetReasonUnknown+ "New Z3 API support is still incomplete and fragile: \+ \you may experience segmentation faults!"+ #-}
+ tests/examples/MultiWayIf.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE MultiWayIf #-}+++instance Animatable Double where+ interpolate ease from to t =+ if | t <= 0 -> from+ | t >= 1 -> to+ | otherwise -> from + easeDouble ease t * (to - from)+ animAdd = (+)+ animSub = (-)+ animZero = 0
+ tests/examples/MultipleInferredContexts.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE PartialTypeSignatures #-}++f :: (Eq a, _, _) => a -> a -> Bool+f x y = x == y
+ tests/examples/NestedDoLambda.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE Arrows #-}++operator = describe "Operators on ProcessA"$+ do+ describe "feedback" $+ do+ it "acts like local variable with hold." $+ do+ let+ pa = proc evx ->+ do+ (\evy -> hold 10 -< evy)+ `feedback` \y ->+ do+ returnA -< ((+y) <$> evx, (y+1) <$ evx)+ run pa [1, 2, 3] `shouldBe` [11, 13, 15]++ it "correctly handles stream end." $+ do+ let+ pa = proc x ->+ (\asx -> returnA -< asx)+ `feedback`+ (\asy -> returnA -< (asy::Event Int, x))+ comp = mkProc (PgPush PgStop) >>> pa+ stateProc comp [0, 0] `shouldBe` ([], [0])++ it "correctly handles stream end.(2)" $+ do+ pendingWith "now many utilities behave incorrectly at the end of stream."+
+ tests/examples/NestedLambda.hs view
@@ -0,0 +1,8 @@++++getPath :: [String] -> Filter+getPath names elms =+ let follow = foldl (\f n -> \els-> subElems n $ f els) id' names :: Filter+ id' = id :: Filter+ in follow elms
+ tests/examples/Obscure.hs view
@@ -0,0 +1,29 @@+type A = Integer+data B = B { u :: !B, j :: B, r :: !A, i :: [A] } | Y+c=head+k=tail+b x y=x(y)y+n=map(snd)h+m=2:3:5:[7]+f=s(flip(a))t+s x y z=x(y(z))+e=filter(v)[2..221]+z=s(s(s((s)b)(s(s)flip)))s+main=mapM_(print)(m++map(fst)h)+v=s(flip(all)m)(s((.)(/=0))mod)+t=(s(s(s(b))flip)((s)s))(s(B(Y)Y)c)k+g=z(:)(z(,)c(b(s((s)map(*))c)))(s(g)k)+h=c(q):c(k(q)):d(p(t((c)n))(k(n)))(k((k)q))+q=g(scanl1(+)(11:cycle(zipWith(-)((k)e)e)))+a x Y = x+a Y x = x+a x y = case compare((r)x)(r(y)) of+ GT -> a(y)x+ _ -> B(a((j)x)y)(u(x))((r)x)(i(x))+p x y = case compare((r)x)(c(c(y))) of+ GT -> p(f((c)y)x)(k(y))+ _ -> r(x):p(f((i)x)(a(u(x))(j(x))))y+d x y = case compare((c)x)(fst(c(y))) of+ GT -> c(y):(d)x((k)y)+ LT -> d(k(x))y+ EQ -> d((k)x)(k(y))
+ tests/examples/OptSig.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE ScopedTypeVariables #-}++errors= do+ let ls :: [[String ]]= runR readp $ pack "[" `append` (B.tail log) `append` pack "]"+ return ()++-- This can be seen as the definition of accumFilter+accumFilter2 :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b)+accumFilter2 f c_init =+ switch (never &&& attach c_init) afAux+ where+ afAux (c, a) =+ case f c a of+ (c', Nothing) -> switch (never &&& (notYet>>>attach c')) afAux+ (c', Just b) -> switch (now b &&& (notYet>>>attach c')) afAux++ attach :: b -> SF (Event a) (Event (b, a))+ attach c = arr (fmap (\a -> (c, a)))
+ tests/examples/OptSig2.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}++errors= do+ let ls :: Int = undefined+ return ()
+ tests/examples/OveridingPrimitives.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}++(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts)+(~#) = cascadeW+infixr 0 ~#
+ tests/examples/PatSigBind.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE ScopedTypeVariables #-}++runCoreRunIO+ :: EHCOpts -- ^ options, e.g. for turning on tracing (if supported by runner)+ -> Mod -- ^ the module to run+ -> IO (Either Err RVal)+runCoreRunIO opts mod = do+ catch+ (runCoreRun opts [] mod $ cmodRun opts mod)+ (\(e :: SomeException) -> hFlush stdout >> (return $ Left $ strMsg $ "runCoreRunIO: " ++ show e))+++foo = do+ (a :: Int) <- baz+ return grue
+ tests/examples/PatternGuards.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE PatternGuards #-}++match n+ | Just 5 <- Just n+ , Just 6 <- Nothing+ , Just 7 <- Just 9+ = Just 8
+ tests/examples/ProcNotation.hs view
@@ -0,0 +1,12 @@+{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts,+ TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-}++valForm initVal vtor label = withInput $+ proc ((),nm,fi) -> do+ s_curr <- keepState initVal -< fi+ valid <- vtor -< s_curr+ case valid of+ Left err -> returnA -< (textField label (Just err) s_curr nm,+ Nothing)+ Right x -> returnA -< (textField label Nothing s_curr nm,+ Just x)
+ tests/examples/Pseudonym.hs view
@@ -0,0 +1,41 @@+default(Int);q s=s++ss s;ss ""=" \"\"";ss s=" "++show(take 50 s)++"++\n"+++ ss(dd 50 s);t3=" ";z n=t3++" xo"!!n:t3;zl n = z(l n);j=head$[m|+ (m,0)<-zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=+ "default(Int);q s=s++ss s;ss \"\"=\" \\\"\\\"\";ss s=\" \"++s"+++ "how(take 50 s)++\"++\\n\"++\n ss(dd 50 s);t3=\" \";z n"+++ "=t3++\" xo\"!!n:t3;zl n = z(l n);j=head$[m|\n (m,0)<-"+++ "zip[0..]p]++[-1];l s = if j==s then 2 else p!!s;m=\n"+vv="\n "++z0++";z0=z"++z0++"0 ;a=\n "++zl 4++"-0;b="++zl 7++"-0;c="++zl 1+++ "\n "++z0++"-0;ms"++z0++"=[[4,\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\n ,0,8],[1, 5,3],[4,0,3],[1,0,2]]\n ;main=putStr(unlines[q m,q y,vv\n "++z0++"]);x="+ ++z0++"1; d=\n "++zl 6++"-0;e="++zl 0++"-0;f="++zl 5++"\n "++z0++"-0"+ ++";o="++z0++"2;p=[\n e,c,g,i,a,f,d,b,h];r=[\"\",\"You \"\n ++\"win\",\"I win\"]!!head([w|w<-[1\n ,2],x<-ms,all(\\x->w==l x)x]++[0\n "++z0++"]);n="++z0++"1"+ ++"9;g=\n "++zl 2++"-0;h="++zl 8++"-0;i="++zl 3++"\n "++z0++"-0;dd"++z0+++ "=drop\n\n"++r+;y= "vv=\"\\n \"++z0++\";z0=z\"++z0++\"0 ;a=\\n \"++zl 4++\"-0;b"+++ "=\"++zl 7++\"-0;c=\"++zl 1++\n \"\\n \"++z0++\"-0;ms\"++z0+"+++ "+\"=[[4,\\n 7,1],[6,0,5],[2,8,3],[4,6,2],[7\\n ,0,8],"+++ "[1, 5,3],[4,0,3],[1,0,2]]\\n ;main=putStr(unlines[q"+++ " m,q y,vv\\n \"++z0++\"]);x=\"\n ++z0++\"1; d=\\n \"++zl 6"+++ "++\"-0;e=\"++zl 0++\"-0;f=\"++zl 5++\"\\n \"++z0++\"-0\"\n +"+++ "+\";o=\"++z0++\"2;p=[\\n e,c,g,i,a,f,d,b,h];r=[\\\"\\\",\\\""+++ "You \\\"\\n ++\\\"win\\\",\\\"I win\\\"]!!head([w|w<-[1\\n ,2]"+++ ",x<-ms,all(\\\\x->w==l x)x]++[0\\n \"++z0++\"]);n=\"++z0"+++ "++\"1\"\n ++\"9;g=\\n \"++zl 2++\"-0;h=\"++zl 8++\"-0;i=\"++"+++ "zl 3++\"\\n \"++z0++\"-0;dd\"++z0++\n \"=drop\\n\\n\"++r\n;y="++ ;z0=z 0 ;a=+ -0;b= -0;c=+ -0;ms =[[4,+ 7,1],[6,0,5],[2,8,3],[4,6,2],[7+ ,0,8],[1, 5,3],[4,0,3],[1,0,2]]+ ;main=putStr(unlines[q m,q y,vv+ ]);x= 1; d=+ -0;e= -0;f=+ -0;o= 2;p=[+ e,c,g,i,a,f,d,b,h];r=["","You "+ ++"win","I win"]!!head([w|w<-[1+ ,2],x<-ms,all(\x->w==l x)x]++[0+ ]);n= 19;g=+ -0;h= -0;i=+ -0;dd =drop+
+ tests/examples/PuncFunctions.hs view
@@ -0,0 +1,25 @@+-- | Compares two functions taking one container+(=*=) :: (Eq' a b) => (f -> a) -> (g -> b)+ -> SameAs f g r -> r -> Property+(f =*= g) sa i = f (toF sa i) =^= g (toG sa i)++-- | Compares two functions taking one scalar and one container+(=?*=) :: (Eq' a b) => (t -> f -> a) -> (t -> g -> b)+ -> SameAs f g r -> r -> t -> Property+(f =?*= g) sa i t = (f t =*= g t) sa i++-- | Compares functions taking two scalars and one container+(=??*=) :: (Eq' a b) => (t -> s -> f -> a) -> (t -> s -> g -> b)+ -> SameAs f g r -> r -> t -> s -> Property+(f =??*= g) sa i t s = (f t s =*= g t s) sa i++-- | Compares two functions taking two containers+(=**=) :: (Eq' a b) => (f -> f -> a) -> (g -> g -> b)+ -> SameAs f g r -> r -> r -> Property+(f =**= g) sa i = (f (toF sa i) =*= g (toG sa i)) sa++-- | Compares two functions taking one container with preprocessing+(=*==) :: (Eq' f g) => (z -> f) -> (z -> g) -> (p -> z)+ -> SameAs f g r -> p -> Property+(f =*== g) p _ i = f i' =^= g i'+ where i' = p i
tests/examples/QuasiQuote.hs view
@@ -17,3 +17,15 @@ px2 [qq|p2|] = undefined px3 [qq|p3|] = undefined px4 [qq|p4|] = undefined++{-# LANGUAGE QuasiQuotes #-}++testComplex = assertBool "" ([$istr|+ ok+#{Foo 4 "Great!" : [Foo 3 "Scott!"]}+ then+|] == ("\n" +++ " ok\n" +++ "[Foo 4 \"Great!\",Foo 3 \"Scott!\"]\n" +++ " then\n"))+
+ tests/examples/RSA.hs view
@@ -0,0 +1,19 @@+import Data.Char+e=181021504832735228091659724090293195791121747536890433++u(f,m)x=i(m(x), [],let(a,b)=f(x) in(a:u(f,m)b))+(v,h)=(foldr(\x(y )->00+128*y+x)0,u( sp(25),((==)"")))+p::(Integer,Integer )->Integer -> Integer --NotInt+p(n,m)x =i(n==0 ,1,i(z n ,q(n,m)x, r(n,m)x))+i(n,e,d )=if(n) then(e) else (d) --23+3d4f+(g,main ,s,un)= (\x->x, y(j),\x->x*x,unlines)--)+j(o)=i(take(2)o== "e=","e="++t (drop(4-2)o),i(d>e,k,l)o)+l=un.map (show.p (e,n).v.map( fromIntegral{-g-}.ord)).h+k=co.map(map(chr .fromIntegral ).w.p(d,n). read).lines+(t,y)=(\ (o:q)-> i(o=='-' ,'1','-' ): q,interact)+q(n,m)x= mod(s( p( div(n)2, m{-jl-})x) )m--hd&&gdb+(r,z,co) =(\(n, m)x->mod(x*p(n-1, m)x)m,even ,concat)--6+(w,sp)=( u(\x->( mod(x)128,div(x )128),(==0 )),splitAt)++d=563347325936+1197371806136556985877790097-563347325936+n=351189532146914946493104395525009571831256157560461451
tests/examples/RdrNames.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-} module RdrNames where import Data.Monoid@@ -81,6 +82,9 @@ ft :: (->) a b ft = undefined +fp :: ( -> ) a b+fp = undefined+ type family F a :: * -> * -> * type instance F Int = (->) type instance F Char = ( , )@@ -107,6 +111,14 @@ -- primitive type? -- Refl Int :: ~# * Int Int -- Refl Maybe :: ~# (* -> *) Maybe Maybe++-- | A data constructor used to box up all unlifted equalities+--+-- The type constructor is special in that GHC pretends that it+-- has kind (? -> ? -> Fact) rather than (* -> * -> *)+data (~) a b = Eq# ((~#) a b)++data Coercible a b = MkCoercible ((~#) a b) -- ---------------------------------------------------------------------
+ tests/examples/RecordSemi.hs view
@@ -0,0 +1,15 @@+-- | Generate a generate statement for the builtin function "fst"+genFst :: BuiltinBuilder+genFst = genNoInsts genFst'+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]+genFst' res f args@[(arg,argType)] = do {+ ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType+ ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]+ ; let {+ ; labels = getFieldLabels arg_htype 0+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)+ ; assign = mkUncondAssign res argexprA+ } ;+ -- Return the generate functions+ ; return [assign]+ }
+ tests/examples/RecordWildcard.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+++parseArgs =+ Args+ { equalProb = E `elem` opts+ , ..+ }
tests/examples/RecursiveDo.hs view
@@ -52,3 +52,6 @@ ti = impureMin budget inviteTree +simplemdo = mdo+ return 5+
+ tests/examples/Remorse.hs view
@@ -0,0 +1,88 @@+import Prelude as P;import Data.Char as C;import Data.List;import System.Environment as S;+main = do+ (.--.)<-(--.|.--.+);(.-)<-(--.|.-+)+ case (.-) of ["+",(.-)]->(-|---|--+) (.-);["-",(.-)]->(..-.|.-.|--+) (.-);_->(.|.-.)("Usage: "++(.--.)++" (+/-) F.hs")+ where+ (-|---|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--).(--.).(-..-))(..-.))+ (..-.|.-.|--+) (.-)=do (..-.)<-(.-.|..-.+) (.-);(.--.|...+)(((-.-.|--+) (.--|=).(--.|=).(-..-))(..-.))++-- | (--| ): (-.-.|---|-.|...-|.|.-.|-) (-.-.|....|.-|.-.) -> (--|---|.-.|...|.)+_--| 'a'=".-";_--| 'b'="-...";_--| 'c'="-.-.";_--| 'd'= "-..";_--| 'e'=".";+_--| 'f'="..-.";_--| 'g'="--.";_--| 'h'="....";_--| 'i'="..";_--| 'j'=".---";+_--| 'k'="-.-";_--| 'l'=".-..";_--| 'm'="--";_--| 'n'="-.";_--| 'o'="---";+_--| 'p'=".--.";_--| 'q'="--.-";_--| 'r'=".-.";_--| 's'="...";_--| 't'="-";+_--| 'u'="..-";_--| 'v'="...-";_--| 'w'=".--";_--| 'x'="-..-";_--| 'y'="-.--";+_--| 'z'="--..";_--| '0'="-----";_--| '1'=".----";_--| '2'="..---";+_--| '3'="...--";_--| '4'="....-";_--| '5'=".....";_--| '6'="-....";+_--| '7'="--...";_--| '8'="---..";_--| '9'="----.";_--| '_'="!";_--| '\''="=";+_--| (-.-.)+ |'A'<=(-.-.)&&(-.-.)<='Z'=(()--| (-|.-..+) (-.-.))++"+"+ |(-..|.|..-.)=[(-.-.)]++-- | (--|=): (..|-.|...-) of (--| )+(--|=) (...)=(..-.)[(-.-.)|(-.-.)<-['a'..'z']++['0'..'9']++['A'..'Z']++['_','\''],()--| (-.-.)==(...)]+ where (..-.)[]=(....|-..) (...);(..-.) (-.-.|...)=(....|-..) (-.-.|...)++-- | (.--): (-.-.|---|-.|...-|.|.-.|-) (.--|---|.-.|-..)+(.--) (...)+ |(...).|.-..["e","i","m","o","t"]=(.--)((...)++" ") -- (...|---|--|.) (..-|-.|-|..|-..|-.--) (.|-..-|-.-.|.|.--.|-|..|---|-.|...):+ -- .=(-.-.|---|--|.--.|---|...|..|-|..|---|-.), ..=(-.|..-|--|.|.-.|..|-.-.) (.-.|.-|-.|--.|.), --/---=(.|-.|-..)-of-(.-..|..|-.|.) (-.-.|---|--|--|.|-.|-), -=(...|..-|-...|-|.-.|.-|-.-.|-|..|---|-.)+ |(...).|.-..(-.-|.|-.--|...)=(...)+ |(..|-..) (...)=(('(':).(++")").(-.-.|-.-.).(..|.--.) "|".(--|.--.)((--| )()))(...)+ |(..|-.|..-.|-..-) (...)=((-|.-..).(..|-).(.--).(-|.-..).(..|-))(...)+ |(-..|.|..-.)=(...)+ where+ (..|-..)((-..-):_)=(..|.-..+) (-..-)||(-..-)=='_'+ (..|-.|..-.|-..-)((-..-):_)=(-..-)=='`'++-- | (.--|=): do (..|-.|...-) of (.--)+(.--|=) (...)+ |(...)=="|"="|"+ |(..|-..) (...)=((--|.--.) (--|=).(-.-.|....|.-.|...).(-|.-..).(..|-))(...)+ |(---|-.|.) (...)='`':((--|=).(..|-))(...):"`"+ |(..|-.|..-.|-..-) (...)='`':((--|.--.) (--|=).(-.-.|....|.-.|...))(...)++"`"+ |(-..|.|..-.)=(...)+ where+ (..|-..)('(':(....):(-| ))=(.--.|.-.|.) (....)&&(.-..|.-) (-| )==')'&&(.-|.-..)(??)((..|-) (-| ))+ (..|-..) _=False+ (.--.|.-.|.) (-.-.)=(-.-.).|.-..".-"+ (..|-.|..-.|-..-) (...)=(.--.|.-.|.) ((....|-..) (...))&&(.-|.-..)(??)((-|.-..) (...))&&(.-|-.)(=='|')(...)+ (---|-.|.) (...)=(.-|.-..) (.--.|.-.|.) ((..|-) (...))&&(.-..|.-) (...)=='|'+ (-.-.|....|.-.|...) (...)=case (-..|.--+)(=='|')(...) of []->[];(...)->let ((.--),(...|...))=(-...|.-.)(=='|')(...) in (.--):(-.-.|....|.-.|...) (...|...)++-- | (.--.|.-.|.|-..) (---|-.) (-.-.|....|.-|.-.|...)+(??)(-.-.)=(-.-.).|.-..".-+/=!|"++-- | (.-..|.|-..-) (...|.-.|-.-.) -> (-|---|-.-) (...|-|.-.|.|.-|--)+(-..-)[]=[]+(-..-)((-.-.):(...))|(..|...+) (-.-.)=((-.-.):(...|...)):(-..-) (.-.|--) where ((...|...),(.-.|--))=(...|.--.) (..|...+) (...)+(-..-) (...)=(-|---|-.-):(-..-) (.-.|--) where ((-|---|-.-),(.-.|--))=(....|-..)((.--.|.-..|.|-..-) (...))++-- | (--.): (--.|.-..|..-|.) (...|.|--.-) (-|---|-.-|...) -> (...|..|-.|--.|.-..|.) (-|---|-.-)+(--.)((--.-):".":(-.):(.-.|--))|(..|..-+)((....|-..) (--.-))=(--.)(((--.-)++"."++(-.)):(.-.|--))+(--.)("`":(.-.|--))=case (--.) (.-.|--) of ((--.-|-.):"`":(.-.|--))->("`"++(--.-|-.)++"`"):(--.) (.-.|--);_->("`":(.-.|--))+(--.)((...):(...|...))=(...):(--.) (...|...)+(--.)[]=[]++-- | (--.|=): (.-..|..|-.-|.) (--.) in (.-.|.|...-)+(--.|=)("(":(-.):")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--)+(--.|=)("(":(-.):" ":")":(.-.|--))|(.-|.-..)(??)(-.)=("("++(-.)++")"):(--.|=) (.-.|--)+(--.|=)("|":(.-.|--))="|":(--.|=) (.-.|--)+(--.|=)((-.):(...|...):(.-.|--))|(.-|.-..)(.|.-..".-")((..|-) (-.))&&(.-..|.-) (-.)=='|'&&(.-|.-..) (..|...+) (...|...)=(-.):(--.|=) (.-.|--)+(--.|=)((-.):(.-.|--))=(-.):(--.|=) (.-.|--)+(--.|=)[]=[]++-- | (....|.-|...|-.-|.|.-..|.-..) (-.-|.|-.--|.--|---|.-.|-..|...)+(-.-|.|-.--|...)=+ ["case","class","data","default","deriving","do","else"+ ,"if","import","in","infix","infixl","infixr","instance","let","module"+ ,"newtype","of","then","type","where","_","main","foreign","ccall","as"]++-- | (.-|-...|-...|.-.|.|...-) (.-..|..|-...) (..-.|-.|...)+(-.-.|-.-.)=P.concat;(.|.-..) (-..-)=P.elem (-..-);(--|.--.)=P.map;(-.-.|--+)=P.concatMap;+(...|.--.)=P.span;(-...|.-.)=P.break;(..|.--.)=intersperse;(-..|.--+)=P.dropWhile;+(....|-..)=P.head;(-|.-..)=P.tail;(..|-)=P.init;(.-..|.-)=P.last;+(-|.-..+)=C.toLower;(..|.-..+)=C.isLower;(..|...+)=C.isSpace;(..|..-+)=C.isUpper;+(.-.|..-.+)=P.readFile;(.--.|...+)=P.putStr;(.|.-.)=P.error;+(--.|.-+)=S.getArgs;(--.|.--.+)=S.getProgName;+(.-|.-..)=P.all;(.-|-.)=P.any;(-..|.|..-.)=P.otherwise;(.--.|.-..|.|-..-)=P.lex;
+ tests/examples/RmDecl1.hs view
@@ -0,0 +1,12 @@+module RmDecl1 where++sumSquares x = x * p+ where p=2 {-There is a comment-}++sq :: Int -> Int -> Int+sq pow 0 = 0+sq pow z = z^pow --there is a comment++{- foo bar -}+anotherFun 0 y = sq y+ where sq x = x^2
+ tests/examples/RmDecl1.hs.expected view
@@ -0,0 +1,8 @@+module RmDecl1 where++sumSquares x = x * p+ where p=2 {-There is a comment-}++{- foo bar -}+anotherFun 0 y = sq y+ where sq x = x^2
+ tests/examples/RmDecl2.hs view
@@ -0,0 +1,10 @@+module RmDecl2 where++sumSquares x y = let sq 0=0+ sq z=z^pow+ pow=2+ in sq x + sq y++anotherFun 0 y = sq y+ where sq x = x^2+
+ tests/examples/RmDecl2.hs.expected view
@@ -0,0 +1,9 @@+module RmDecl2 where++sumSquares x y = let sq 0=0+ sq z=z^pow+ in sq x + sq y++anotherFun 0 y = sq y+ where sq x = x^2+
+ tests/examples/RmTypeSig1.hs view
@@ -0,0 +1,7 @@+module RmTypeSig1 where++sq,anotherFun :: Int -> Int+sq 0 = 0+sq z = z^2++anotherFun x = x^2
+ tests/examples/RmTypeSig1.hs.expected view
@@ -0,0 +1,7 @@+module RmTypeSig1 where++anotherFun :: Int -> Int+sq 0 = 0+sq z = z^2++anotherFun x = x^2
tests/examples/Rules.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Rules where import Data.Char
+ tests/examples/RulesSemi.hs view
@@ -0,0 +1,9 @@++{-# RULES+ "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;+ "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x;+ "cFloatConv/Float->CFloat" forall (x::Float). cFloatConv x = CFloat x;+ "cFloatConv/CFloat->Float" forall (x::Float). cFloatConv CFloat x = x;+ "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x;+ "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x+ #-};
+ tests/examples/SemiInstance.hs view
@@ -0,0 +1,11 @@++instance ArrowTransformer (AbortT v) where {+ lift = AbortT . (>>> arr Right);+ tmap f = AbortT . f . unwrapAbortT;+};++instance MakeValueTuple Float where type ValueTuple Float = Value Float ; valueTupleOf = valueOf++instance Foo where {+ type ListElement Zero (a,r) = a;+}
+ tests/examples/SemiWorkout.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE KindSignatures+ , GADTs+ , ScopedTypeVariables+ , PatternSignatures+ , MultiParamTypeClasses+ , FunctionalDependencies+ , FlexibleInstances+ , UndecidableInstances+ , TypeFamilies+ , FlexibleContexts+ #-}++instance forall init prog prog' fromO fromI progOut progIn+ sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem+ keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem current current' invertedSessionsMe invertedSessionsThem .+ ( ProgramToMVarsOutgoingT prog prog ~ progOut+ , ProgramToMVarsOutgoingT prog' prog' ~ progIn+ , SWellFormedConfig init (D0 E) prog+ , SWellFormedConfig init (D0 E) prog'+ , TyListIndex progOut init (MVar (ProgramCell (Cell fromO)))+ , TyListIndex progIn init (MVar (ProgramCell (Cell fromI)))+ , TyListIndex prog init current'+ , Expand prog current' current+ , MapLookup (TyMap sessionsToIdxMe idxsToPairStructsMe) init+ (MVar (Map (RawPid, RawPid) (MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))))))+ , TyListMember invertedSessionsThem init True+ , MapSize (TyMap keyToIdxMe idxToValueMe) idxOfThem+ , MapInsert (TyMap keyToIdxMe idxToValueMe) idxOfThem+ (SessionState prog prog' (current, fromO, fromI)) (TyMap keyToIdxMe' idxToValueMe')+ ) =>+ CreateSession False init prog prog'+ sessionsToIdxMe sessionsToIdxThem idxsToPairStructsMe idxsToPairStructsThem+ keyToIdxMe idxToValueMe keyToIdxMe' idxToValueMe' idxOfThem invertedSessionsMe invertedSessionsThem where+ createSession init FF (Pid remotePid _) =+ InterleavedChain $+ \ipid@(IPid (Pid localPid localSTMap) _) mp ->+ do { let pidFuncMapMVar :: MVar (Map (RawPid, RawPid)+ (MVar (PairStruct init prog prog'+ ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))))+ = mapLookup localSTMap init+ ; pidFuncMap <- takeMVar pidFuncMapMVar+ ; emptyMVar :: MVar (TyMap keyToIdxMe' idxToValueMe') <- newEmptyMVar+ ; psMVar :: MVar (PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil)))+ <- case Map.lookup (localPid, remotePid) pidFuncMap of+ Nothing+ -> do { empty <- newEmptyMVar+ ; putMVar pidFuncMapMVar (Map.insert (localPid, remotePid) empty pidFuncMap)+ ; return empty+ }+ (Just mv)+ -> do { putMVar pidFuncMapMVar pidFuncMap+ ; return mv+ }+ ; let idxOfThem :: idxOfThem = mapSize mp+ ps :: PairStruct init prog prog' ((Cons (Jump init) Nil), (Cons (Jump init) Nil), (Cons (Jump init) Nil))+ = PS localPid (f idxOfThem mp emptyMVar)+ ; putMVar psMVar ps+ ; mp' <- takeMVar emptyMVar+ ; return (idxOfThem, mp', ipid)+ }
+ tests/examples/Shebang.hs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE OverloadedStrings #-}+import Aws.SSSP.App++main = web
+ tests/examples/ShiftingLambda.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}+spec :: Spec+spec = do+ describe "split4'8" $ do+ it "0xabc" $ do+ split4'8 0xabc `shouldBe` (0x0a, 0xbc)+ it "0xfff" $ do+ split4'8 0xfff `shouldBe` (0x0f, 0xff)++ describe "(x, y) = split4'8 z" $ do+ prop "x <= 0x0f" $+ \z -> let (x, _) = split4'8 z in x <= 0x0f+ prop "x << 8 | y == z" $ do+ \z -> let (x, y) = split4'8 z in+ fromIntegral x `shiftL` 8 .|. fromIntegral y == z++match s@Status{ pos, flips, captureAt, captureLen }+ | isOne ?pat = ite (pos .>= strLen) __FAIL__ one+ | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of+ POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps++foo = 1
tests/examples/Simple.hs view
@@ -1,6 +1,4 @@--- A simple let statement, to ensure the layout is detected --- module Layout.Simple where-+-- blah x = 1
+ tests/examples/SimpleComplexTuple.hs view
@@ -0,0 +1,3 @@+++foo ((-),(.))= (5,6)
+ tests/examples/SlidingDataClassDecl.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+++instance HasTrie R2Basis where+ data R2Basis :->: x = R2Trie x x+ trie f = R2Trie (f XB) (f YB)+ untrie (R2Trie x _y) XB = x+ untrie (R2Trie _x y) YB = y+ enumerate (R2Trie x y) = [(XB,x),(YB,y)]
+ tests/examples/SlidingDoClause.hs view
@@ -0,0 +1,13 @@+++-- :bounds narrowing 35+bndCom tenv args =+ do { (bound,size) <- getBounds fail args+ ; let get (s,m,ref) = do { n <- readRef ref; return(s++" = "++show n++ m)}+ ; if bound == ""+ then do { xs <- mapM get boundRef; warnM [Dl xs "\n"]}+ else case find (\ (nm,info,ref) -> nm==bound) boundRef of+ Just (_,_,ref) -> writeRef ref size+ Nothing -> fail ("Unknown bound '"++bound++"'")+ ; return tenv+ }
+ tests/examples/SlidingLambda.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE ImplicitParams #-}++foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps
+ tests/examples/SlidingListComp.hs view
@@ -0,0 +1,8 @@+++foo =+ [concatMap (\(n, f) -> [findPath copts v >>= f (listArg "ghc" as) | v <- listArg n as]) [+ ("project", Update.scanProject),+ ("file", Update.scanFile),+ ("path", Update.scanDirectory)],+ map (Update.scanCabal (listArg "ghc" as)) cabals]
+ tests/examples/SlidingRecordSetter.hs view
@@ -0,0 +1,4 @@++selfQualify mod rsets = let defs = Set.fromList (map rs_name rsets)+ in map (descend (f defs))+ (map (\RS{..} -> RS{rs_name = qualify mod rs_name, ..}) rsets)
+ tests/examples/SlidingTypeSyn.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+++type ( f :-> g) (r :: * -> *) ix = f r ix -> g r ix++type ( f :--> g) b ix = f b ix -> g b ix++type ((f :---> g)) b ix = f b ix -> g b ix
+ tests/examples/SpacesSplice.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE TemplateHaskell #-}++makeLenses '' PostscriptFont
+ tests/examples/SpliceSemi.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE TemplateHaskell #-}+++$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType)
+ tests/examples/StrangeTypeClass.hs view
@@ -0,0 +1,18 @@++++instance+ (+ ) => Elms Z ix where+ data Elm Z ix = ElmZ !ix+ type Arg Z = Z+ getArg !(ElmZ _) = Z+ getIdx !(ElmZ ix) = ix+ {-# INLINE getArg #-}+ {-# INLINE getIdx #-}++foo :: (Eq a) => a-> Bool+foo = undefined++bar :: ( ) => a-> Bool+bar = undefined
+ tests/examples/StringGap.hs view
@@ -0,0 +1,8 @@+module StringGap where++-- based on https://www.reddit.com/r/haskelltil/comments/3duhdf/haskell_ignores_all_whitespace_enclosed_in/++foo = "lorem ipsum \+ \dolor sit amet"++bar = "lorem ipsum \ \dolor sit amet"
+ tests/examples/T10196.hs view
@@ -0,0 +1,13 @@+module T10196 where++data X = Xᵦ | Xᵤ | Xᵩ | Xᵢ | Xᵪ | Xᵣ++f :: Int+f =+ let xᵦ = 1+ xᵤ = xᵦ+ xᵩ = xᵤ+ xᵢ = xᵩ+ xᵪ = xᵢ+ xᵣ = xᵪ+ in xᵣ
+ tests/examples/T5951.hs view
@@ -0,0 +1,11 @@+module T5951 where++class A a+class B b+class C c++instance+ A =>+ B =>+ C where+ foo = undefined
+ tests/examples/THMonadInstance.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE+ TemplateHaskell,+ MultiParamTypeClasses,+ FunctionalDependencies,+ UndecidableInstances+ #-}+++genCodingInstance :: (Data c, Data h) => TypeQ -> Name -> [(c, h)] -> Q [Dec]+genCodingInstance ht ctn chs = do+ let n = const Nothing+ [d|+ instance Monad m => EncodeM m $(ht) $(conT ctn) where+ encodeM h = return $ $(+ caseE [| h |] [ match (dataToPatQ n h) (normalB (dataToExpQ n c)) [] | (c,h) <- chs ]+ )++ instance Monad m => DecodeM m $(ht) $(conT ctn) where+ decodeM c = return $ $(+ caseE [| c |] [ match (dataToPatQ n c) (normalB (dataToExpQ n h)) [] | (c,h) <- chs ]+ )+ |]
+ tests/examples/TemplateHaskell.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++foo = $footemplate++makeSplices ''Foo++old = $(old)++bar = $$bartemplate++bar = [e| quasi |]++bar = [| quasi |]++baz = [quoter| quasi |]++[t| Map.Map T.Text $tc |]++{-# ANN module $([| 1 :: Int |]) #-}++foo = [t| HT.HashTable $(varT s) Int+ (Result $(varT str) $tt) |]++objc_emit++objc_import [""]+++$(do+ return $ foreignDecl cName ("build" ++ a) ([[t| Ptr Builder |]] ++ ats ++ [[t| CString |]]) [t| Ptr $(rt) |]+ )++foo = do+ let elemSize = [|sizeOf (undefined :: $(elemType))|]+ alignment _ = alignment (undefined :: $(elemType))+ return bar++class QQExp a b where+ qqExp x = [||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]
+ tests/examples/TooManyAnnVal.hs view
@@ -0,0 +1,518 @@+++-- UUAGC 0.9.38.6 (./src/SistemaL.ag)+module SistemaL where+{-# LINE 3 "./src/SistemaL.ag" #-}++import Data.List+{-# LINE 9 "./src/SistemaL.hs" #-}++{-# LINE 69 "./src/SistemaL.ag" #-}++addIdentProds prods alfa+ = let prods' = map (\(Simbolo e,_) -> e) prods+ resto = alfa \\ prods'+ iprods = map (\e -> (Simbolo e, [Simbolo e])) resto+ in prods ++ iprods++myElem _ [] = False+myElem e1 ((Simbolo e2,_):xs) = if e1 == e2+ then True+ else myElem e1 xs+{-# LINE 23 "./src/SistemaL.hs" #-}++{-# LINE 125 "./src/SistemaL.ag" #-}++ejemplo1 = SistemaL "Koch" alfaK initK prodK+alfaK = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK = [Simbolo "F", Simbolo "a"]+prodK = [ (Simbolo "F", [Simbolo "F", Simbolo "g"])+ , (Simbolo "F", [])+ ]++ejemplo2 = SistemaL "Koch" alfaK2 initK2 prodK2+alfaK2 = [Simbolo "F", Simbolo "f", Simbolo "+", Simbolo "-"]+initK2 = [Simbolo "F", Simbolo "f"]+prodK2 = [ (Simbolo "F", [Simbolo "F", Simbolo "+"])+ , (Simbolo "f", [])+ ]++getNombre (SistemaL nm _ _ _) = nm++testSistemaL :: SistemaL -> Either [String] SistemaL+testSistemaL = sem_SistemaL+{-# LINE 45 "./src/SistemaL.hs" #-}+-- Alfabeto ----------------------------------------------------+type Alfabeto = [Simbolo ]+-- cata+sem_Alfabeto :: Alfabeto ->+ T_Alfabeto+sem_Alfabeto list =+ (Prelude.foldr sem_Alfabeto_Cons sem_Alfabeto_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Alfabeto = ([String]) ->+ ( ([String]),([String]),Alfabeto )+sem_Alfabeto_Cons :: T_Simbolo ->+ T_Alfabeto ->+ T_Alfabeto+sem_Alfabeto_Cons hd_ tl_ =+ (\ _lhsIalf ->+ (let _tlOalf :: ([String])+ _lhsOalf :: ([String])+ _lhsOerrores :: ([String])+ _lhsOself :: Alfabeto+ _hdIself :: Simbolo+ _hdIsimb :: String+ _tlIalf :: ([String])+ _tlIerrores :: ([String])+ _tlIself :: Alfabeto+ _verificar =+ ({-# LINE 31 "./src/SistemaL.ag" #-}+ elem _hdIsimb _lhsIalf+ {-# LINE 73 "./src/SistemaL.hs" #-}+ )+ _tlOalf =+ ({-# LINE 32 "./src/SistemaL.ag" #-}+ if _verificar+ then _lhsIalf+ else _hdIsimb : _lhsIalf+ {-# LINE 80 "./src/SistemaL.hs" #-}+ )+ _lhsOalf =+ ({-# LINE 35 "./src/SistemaL.ag" #-}+ _tlIalf+ {-# LINE 85 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 93 "./src/SistemaL.ag" #-}+ if _verificar+ then ("El simbolo: '" ++ _hdIsimb ++ "' esta repetido mas de una ves en el alfabeto.") : _tlIerrores+ else _tlIerrores+ {-# LINE 92 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 97 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 102 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_+ ( _tlIalf,_tlIerrores,_tlIself) =+ tl_ _tlOalf+ in ( _lhsOalf,_lhsOerrores,_lhsOself)))+sem_Alfabeto_Nil :: T_Alfabeto+sem_Alfabeto_Nil =+ (\ _lhsIalf ->+ (let _lhsOalf :: ([String])+ _lhsOerrores :: ([String])+ _lhsOself :: Alfabeto+ _lhsOalf =+ ({-# LINE 36 "./src/SistemaL.ag" #-}+ _lhsIalf+ {-# LINE 118 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 96 "./src/SistemaL.ag" #-}+ []+ {-# LINE 123 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 128 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 133 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOalf,_lhsOerrores,_lhsOself)))+-- Inicio ------------------------------------------------------+type Inicio = [Simbolo ]+-- cata+sem_Inicio :: Inicio ->+ T_Inicio+sem_Inicio list =+ (Prelude.foldr sem_Inicio_Cons sem_Inicio_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Inicio = ([String]) ->+ ( ([String]),Inicio )+sem_Inicio_Cons :: T_Simbolo ->+ T_Inicio ->+ T_Inicio+sem_Inicio_Cons hd_ tl_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Inicio+ _tlOalfabeto :: ([String])+ _hdIself :: Simbolo+ _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIself :: Inicio+ _lhsOerrores =+ ({-# LINE 99 "./src/SistemaL.ag" #-}+ if elem _hdIsimb _lhsIalfabeto+ then _tlIerrores+ else ("El simbolo de inicio: '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores+ {-# LINE 163 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 168 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 173 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 178 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_+ ( _tlIerrores,_tlIself) =+ tl_ _tlOalfabeto+ in ( _lhsOerrores,_lhsOself)))+sem_Inicio_Nil :: T_Inicio+sem_Inicio_Nil =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Inicio+ _lhsOerrores =+ ({-# LINE 102 "./src/SistemaL.ag" #-}+ []+ {-# LINE 193 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 198 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 203 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOself)))+-- Produccion --------------------------------------------------+type Produccion = ( Simbolo ,Succesor )+-- cata+sem_Produccion :: Produccion ->+ T_Produccion+sem_Produccion ( x1,x2) =+ (sem_Produccion_Tuple (sem_Simbolo x1 ) (sem_Succesor x2 ) )+-- semantic domain+type T_Produccion = ([String]) ->+ ( ([String]),Produccion ,String)+sem_Produccion_Tuple :: T_Simbolo ->+ T_Succesor ->+ T_Produccion+sem_Produccion_Tuple x1_ x2_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Produccion+ _lhsOsimb :: String+ _x2Oalfabeto :: ([String])+ _x1Iself :: Simbolo+ _x1Isimb :: String+ _x2Ierrores :: ([String])+ _x2Iself :: Succesor+ _lhsOerrores =+ ({-# LINE 114 "./src/SistemaL.ag" #-}+ if elem _x1Isimb _lhsIalfabeto+ then _x2Ierrores+ else ("El simbolo de la produccion (izq): '" ++ _x1Isimb ++ "' no se encuentra en el alfabeto.") : _x2Ierrores+ {-# LINE 234 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (_x1Iself,_x2Iself)+ {-# LINE 239 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 244 "./src/SistemaL.hs" #-}+ )+ _lhsOsimb =+ ({-# LINE 45 "./src/SistemaL.ag" #-}+ _x1Isimb+ {-# LINE 249 "./src/SistemaL.hs" #-}+ )+ _x2Oalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 254 "./src/SistemaL.hs" #-}+ )+ ( _x1Iself,_x1Isimb) =+ x1_+ ( _x2Ierrores,_x2Iself) =+ x2_ _x2Oalfabeto+ in ( _lhsOerrores,_lhsOself,_lhsOsimb)))+-- Producciones ------------------------------------------------+type Producciones = [Produccion ]+-- cata+sem_Producciones :: Producciones ->+ T_Producciones+sem_Producciones list =+ (Prelude.foldr sem_Producciones_Cons sem_Producciones_Nil (Prelude.map sem_Produccion list) )+-- semantic domain+type T_Producciones = ([String]) ->+ Producciones ->+ ( ([String]),Producciones)+sem_Producciones_Cons :: T_Produccion ->+ T_Producciones ->+ T_Producciones+sem_Producciones_Cons hd_ tl_ =+ (\ _lhsIalfabeto+ _lhsIprods ->+ (let _tlOprods :: Producciones+ _lhsOprods :: Producciones+ _lhsOerrores :: ([String])+ _hdOalfabeto :: ([String])+ _tlOalfabeto :: ([String])+ _hdIerrores :: ([String])+ _hdIself :: Produccion+ _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIprods :: Producciones+ _verificar =+ ({-# LINE 60 "./src/SistemaL.ag" #-}+ myElem _hdIsimb _lhsIprods+ {-# LINE 291 "./src/SistemaL.hs" #-}+ )+ _tlOprods =+ ({-# LINE 61 "./src/SistemaL.ag" #-}+ if _verificar+ then _lhsIprods+ else _hdIself : _lhsIprods+ {-# LINE 298 "./src/SistemaL.hs" #-}+ )+ _lhsOprods =+ ({-# LINE 64 "./src/SistemaL.ag" #-}+ _tlIprods+ {-# LINE 303 "./src/SistemaL.hs" #-}+ )+ _lhsOerrores =+ ({-# LINE 105 "./src/SistemaL.ag" #-}+ if _verificar+ then let error = "La produccion con el simb. izq.:'"+ ++ _hdIsimb+ ++ "' esta repetida mas de una ves en la lista de producciones."+ in (error : _hdIerrores) ++ _tlIerrores+ else _hdIerrores ++ _tlIerrores+ {-# LINE 313 "./src/SistemaL.hs" #-}+ )+ _hdOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 318 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 323 "./src/SistemaL.hs" #-}+ )+ ( _hdIerrores,_hdIself,_hdIsimb) =+ hd_ _hdOalfabeto+ ( _tlIerrores,_tlIprods) =+ tl_ _tlOalfabeto _tlOprods+ in ( _lhsOerrores,_lhsOprods)))+sem_Producciones_Nil :: T_Producciones+sem_Producciones_Nil =+ (\ _lhsIalfabeto+ _lhsIprods ->+ (let _lhsOerrores :: ([String])+ _lhsOprods :: Producciones+ _lhsOerrores =+ ({-# LINE 111 "./src/SistemaL.ag" #-}+ []+ {-# LINE 339 "./src/SistemaL.hs" #-}+ )+ _lhsOprods =+ ({-# LINE 58 "./src/SistemaL.ag" #-}+ _lhsIprods+ {-# LINE 344 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOprods)))+-- Simbolo -----------------------------------------------------+data Simbolo = Simbolo (String)+ deriving ( Eq,Show)+-- cata+sem_Simbolo :: Simbolo ->+ T_Simbolo+sem_Simbolo (Simbolo _string ) =+ (sem_Simbolo_Simbolo _string )+-- semantic domain+type T_Simbolo = ( Simbolo ,String)+sem_Simbolo_Simbolo :: String ->+ T_Simbolo+sem_Simbolo_Simbolo string_ =+ (let _lhsOsimb :: String+ _lhsOself :: Simbolo+ _lhsOsimb =+ ({-# LINE 47 "./src/SistemaL.ag" #-}+ string_+ {-# LINE 365 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ Simbolo string_+ {-# LINE 370 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 375 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOself,_lhsOsimb))+-- SistemaL ----------------------------------------------------+data SistemaL = SistemaL (String) (Alfabeto ) (Inicio ) (Producciones )+ deriving ( Show)+-- cata+sem_SistemaL :: SistemaL ->+ T_SistemaL+sem_SistemaL (SistemaL _nombre _alfabeto _inicio _producciones ) =+ (sem_SistemaL_SistemaL _nombre (sem_Alfabeto _alfabeto ) (sem_Inicio _inicio ) (sem_Producciones _producciones ) )+-- semantic domain+type T_SistemaL = ( (Either [String] SistemaL))+sem_SistemaL_SistemaL :: String ->+ T_Alfabeto ->+ T_Inicio ->+ T_Producciones ->+ T_SistemaL+sem_SistemaL_SistemaL nombre_ alfabeto_ inicio_ producciones_ =+ (let _alfabetoOalf :: ([String])+ _inicioOalfabeto :: ([String])+ _produccionesOalfabeto :: ([String])+ _lhsOresultado :: (Either [String] SistemaL)+ _produccionesOprods :: Producciones+ _alfabetoIalf :: ([String])+ _alfabetoIerrores :: ([String])+ _alfabetoIself :: Alfabeto+ _inicioIerrores :: ([String])+ _inicioIself :: Inicio+ _produccionesIerrores :: ([String])+ _produccionesIprods :: Producciones+ _alfabetoOalf =+ ({-# LINE 28 "./src/SistemaL.ag" #-}+ []+ {-# LINE 409 "./src/SistemaL.hs" #-}+ )+ _inicioOalfabeto =+ ({-# LINE 41 "./src/SistemaL.ag" #-}+ _alfabetoIalf+ {-# LINE 414 "./src/SistemaL.hs" #-}+ )+ _produccionesOalfabeto =+ ({-# LINE 42 "./src/SistemaL.ag" #-}+ _alfabetoIalf+ {-# LINE 419 "./src/SistemaL.hs" #-}+ )+ _lhsOresultado =+ ({-# LINE 52 "./src/SistemaL.ag" #-}+ if null _errores+ then let producciones = addIdentProds _produccionesIprods _alfabetoIalf+ in Right (SistemaL nombre_ _alfabetoIself _inicioIself producciones)+ else Left _errores+ {-# LINE 427 "./src/SistemaL.hs" #-}+ )+ _produccionesOprods =+ ({-# LINE 67 "./src/SistemaL.ag" #-}+ []+ {-# LINE 432 "./src/SistemaL.hs" #-}+ )+ _errores =+ ({-# LINE 85 "./src/SistemaL.ag" #-}+ let inicioErr = if null _inicioIself+ then "La lista de simbolos de inicio no puede ser vacia" : _inicioIerrores+ else _inicioIerrores+ errores = map (\err -> nombre_ ++ ": " ++ err) (_alfabetoIerrores ++ inicioErr ++ _produccionesIerrores)+ in errores+ {-# LINE 441 "./src/SistemaL.hs" #-}+ )+ ( _alfabetoIalf,_alfabetoIerrores,_alfabetoIself) =+ alfabeto_ _alfabetoOalf+ ( _inicioIerrores,_inicioIself) =+ inicio_ _inicioOalfabeto+ ( _produccionesIerrores,_produccionesIprods) =+ producciones_ _produccionesOalfabeto _produccionesOprods+ in ( _lhsOresultado))+-- Succesor ----------------------------------------------------+type Succesor = [Simbolo ]+-- cata+sem_Succesor :: Succesor ->+ T_Succesor+sem_Succesor list =+ (Prelude.foldr sem_Succesor_Cons sem_Succesor_Nil (Prelude.map sem_Simbolo list) )+-- semantic domain+type T_Succesor = ([String]) ->+ ( ([String]),Succesor )+sem_Succesor_Cons :: T_Simbolo ->+ T_Succesor ->+ T_Succesor+sem_Succesor_Cons hd_ tl_ =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Succesor+ _tlOalfabeto :: ([String])+ _hdIself :: Simbolo+ _hdIsimb :: String+ _tlIerrores :: ([String])+ _tlIself :: Succesor+ _lhsOerrores =+ ({-# LINE 119 "./src/SistemaL.ag" #-}+ if elem _hdIsimb _lhsIalfabeto+ then _tlIerrores+ else ("El simbolo de la produccion (der): '" ++ _hdIsimb ++ "' no se encuentra en el alfabeto.") : _tlIerrores+ {-# LINE 477 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ (:) _hdIself _tlIself+ {-# LINE 482 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 487 "./src/SistemaL.hs" #-}+ )+ _tlOalfabeto =+ ({-# LINE 39 "./src/SistemaL.ag" #-}+ _lhsIalfabeto+ {-# LINE 492 "./src/SistemaL.hs" #-}+ )+ ( _hdIself,_hdIsimb) =+ hd_+ ( _tlIerrores,_tlIself) =+ tl_ _tlOalfabeto+ in ( _lhsOerrores,_lhsOself)))+sem_Succesor_Nil :: T_Succesor+sem_Succesor_Nil =+ (\ _lhsIalfabeto ->+ (let _lhsOerrores :: ([String])+ _lhsOself :: Succesor+ _lhsOerrores =+ ({-# LINE 122 "./src/SistemaL.ag" #-}+ []+ {-# LINE 507 "./src/SistemaL.hs" #-}+ )+ _self =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ []+ {-# LINE 512 "./src/SistemaL.hs" #-}+ )+ _lhsOself =+ ({-# LINE 57 "./src/SistemaL.ag" #-}+ _self+ {-# LINE 517 "./src/SistemaL.hs" #-}+ )+ in ( _lhsOerrores,_lhsOself)))
+ tests/examples/TransformListComp.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE TransformListComp #-}++oldest :: [Int] -> [String]+oldest tbl = [ "str"+ | n <- tbl+ , then id+ ]
+ tests/examples/TupleSections.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TupleSections #-}++foo = do+ liftIO $ atomicModifyIORef ciTokens ((,()) . f)+ liftIO $ atomicModifyIORef ciTokens (((),) . f)+ liftIO $ atomicModifyIORef ciTokens ((,) . f)++-- | Make bilateral dictionary from PoliMorf.+mkPoli :: [P.Entry] -> Poli+mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)++foo = baz+ where+ _1 = ((,Nothing,Nothing,Nothing,Nothing,Nothing) . Just <$>)+ _2 = ((Nothing,,Nothing,Nothing,Nothing,Nothing) . Just <$>)+ _3 = ((Nothing,Nothing,,Nothing,Nothing,Nothing) . Just <$>)+ _4 = ((Nothing,Nothing,Nothing,,Nothing,Nothing) . Just <$>)+ _5 = ((Nothing,Nothing,Nothing,Nothing,,Nothing) . Just <$>)+ _6 = ((Nothing,Nothing,Nothing,Nothing,Nothing,) . Just <$>)++foo = (,,(),,,())
+ tests/examples/TypeBrackets.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE ScopedTypeVariables #-}++foo (f :: (Maybe t -> Int)) =+ undefined++type (((f `ObjectsFUnder` a))) = ConstF f a :/\: f+type (f `ObjectsFOver` a) = f :/\: ConstF f a++type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a+type (c `ObjectsOver` a) = Id c `ObjectsFOver` a+
+ tests/examples/TypeBrackets2.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleInstances #-}+++-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the+-- previously applied style. Or be a specific value.+data MaybeDefault v where+ Default :: MaybeDefault v+ KeepCurrent :: MaybeDefault v+ SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v+ SetTo2 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v++bar :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a])+baz :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v++instance Dsp (S n) where+ data (ASig (S n)) = S_A CVar+ data (KSig (S n)) = S_K CVar+ data (INum (S n)) = S_I CVar+ getSr = fst <$> ask+ getKsmps = snd <$> ask
+ tests/examples/TypeBrackets3.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}++module Network.Routing.Dict+ ( -- * store+ Store+ , emptyStore+ , type ( Members ["foo" := Int, "bar" := Double] prms == (Member "foo" Int prms, Member "bar" Double prms)+--+type family Members (kvs :: [KV *]) (prms :: [KV *]) :: Constraint+type instance Members '[] prms = ()+type instance Members (k := v ': kvs) prms = (Member k v prms, Members kvs prms)
+ tests/examples/TypeBrackets4.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}+++type family ((a :: Bool) || (b :: Bool)) :: Bool+type instance 'True || a = 'True+type instance a || 'True = 'True+type instance 'False || a = a+type instance a || 'False = a
tests/examples/TypeFamilies.hs view
@@ -61,3 +61,17 @@ put store (x : old) return store +type family (++) (a :: [k]) (b :: [k]) :: [k] where+ '[] ++ b = b+ (a ': as) ++ b = a ': (as ++ b)++type family (f :: * -> *) |> (s :: * -> *) :: * -> *++type instance f |> Union s = Union (f :> s)++type family Compare (a :: k) (b :: k') :: Ordering where+ Compare '() '() = EQ++type family (r1 :++: r2); infixr 5 :++:+type instance r :++: Nil = r+type instance r1 :++: r2 :> a = (r1 :++: r2) :> a
+ tests/examples/TypeFamilies2.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++type family (++) (a :: [k]) (b :: [k]) :: [k] where+ '[] ++ b = b+ (a ': as) ++ b = a ': (as ++ b)++type family F a :: * -> * -> *+type instance F Int = (->)+type instance F Char = ( , )
+ tests/examples/TypeInstance.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-}++class TrieKey k where+ type instance TrieRep k = TrieRepDefault k
+ tests/examples/TypeSignatureParens.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE ScopedTypeVariables #-}++pTokenCost :: forall loc state a .((Show a, Eq a, loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str a state loc) [a])+pTokenCost as cost = 5++pTokenCostStr :: forall a .((Show a) => [a] -> Int -> String)+pTokenCostStr as cost = "5"
+ tests/examples/TypeSynOperator.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE TypeOperators #-}++type a :-> t = a
+ tests/examples/TypeSynParens.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TypeFamilies #-}++class Compilable a where+ type CompileResult a :: *++instance Compilable a => Compilable [a] where+ type CompileResult [a] = [CompileResult a]++instance Compilable a => Compilable (Maybe a) where+ type CompileResult (Maybe a) = Maybe (CompileResult a)++instance Compilable InterpreterStmt where+ type CompileResult InterpreterStmt = [Hask.Stmt]++instance Compilable ModuleSpan where+ type CompileResult ModuleSpan = Hask.Module++instance Compilable StatementSpan where+ type (CompileResult StatementSpan) = [Stmt]
+ tests/examples/Undefined10.hs view
@@ -0,0 +1,643 @@+{-+ Copyright 2013-2015 Mario Blazevic++ License: BSD3 (see BSD3-LICENSE.txt file)+-}++-- | This module defines the 'FactorialMonoid' class and some of its instances.+--++{-# LANGUAGE Haskell2010, Trustworthy #-}++module Data.Monoid.Factorial (+ -- * Classes+ FactorialMonoid(..), StableFactorialMonoid,+ -- * Monad function equivalents+ mapM, mapM_+ )+where++import Prelude hiding (break, drop, dropWhile, foldl, foldMap, foldr, last, length, map, mapM, mapM_, max, min,+ null, reverse, span, splitAt, take, takeWhile)++import Control.Arrow (first)+import qualified Control.Monad as Monad+import Data.Monoid (Monoid (..), Dual(..), Sum(..), Product(..), Endo(Endo, appEndo))+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as LazyByteString+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Sequence as Sequence+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Data.Int (Int64)+import Data.Numbers.Primes (primeFactors)++import Data.Monoid.Null (MonoidNull(null), PositiveMonoid)++-- | Class of monoids that can be split into irreducible (/i.e./, atomic or prime) 'factors' in a unique way. Factors of+-- a 'Product' are literally its prime factors:+--+-- prop> factors (Product 12) == [Product 2, Product 2, Product 3]+--+-- Factors of a list are /not/ its elements but all its single-item sublists:+--+-- prop> factors "abc" == ["a", "b", "c"]+--+-- The methods of this class satisfy the following laws:+--+-- > mconcat . factors == id+-- > null == List.null . factors+-- > List.all (\prime-> factors prime == [prime]) . factors+-- > factors == unfoldr splitPrimePrefix == List.reverse . unfoldr (fmap swap . splitPrimeSuffix)+-- > reverse == mconcat . List.reverse . factors+-- > primePrefix == maybe mempty fst . splitPrimePrefix+-- > primeSuffix == maybe mempty snd . splitPrimeSuffix+-- > inits == List.map mconcat . List.tails . factors+-- > tails == List.map mconcat . List.tails . factors+-- > foldl f a == List.foldl f a . factors+-- > foldl' f a == List.foldl' f a . factors+-- > foldr f a == List.foldr f a . factors+-- > span p m == (mconcat l, mconcat r) where (l, r) = List.span p (factors m)+-- > List.all (List.all (not . pred) . factors) . split pred+-- > mconcat . intersperse prime . split (== prime) == id+-- > splitAt i m == (mconcat l, mconcat r) where (l, r) = List.splitAt i (factors m)+-- > spanMaybe () (const $ bool Nothing (Maybe ()) . p) m == (takeWhile p m, dropWhile p m, ())+-- > spanMaybe s0 (\s m-> Just $ f s m) m0 == (m0, mempty, foldl f s0 m0)+-- > let (prefix, suffix, s') = spanMaybe s f m+-- > foldMaybe = foldl g (Just s)+-- > g s m = s >>= flip f m+-- > in all ((Nothing ==) . foldMaybe) (inits prefix)+-- > && prefix == last (filter (isJust . foldMaybe) $ inits m)+-- > && Just s' == foldMaybe prefix+-- > && m == prefix <> suffix+--+-- A minimal instance definition must implement 'factors' or 'splitPrimePrefix'. Other methods are provided and should+-- be implemented only for performance reasons.+class MonoidNull m => FactorialMonoid m where+ -- | Returns a list of all prime factors; inverse of mconcat.+ factors :: m -> [m]+ -- | The prime prefix, 'mempty' if none.+ primePrefix :: m -> m+ -- | The prime suffix, 'mempty' if none.+ primeSuffix :: m -> m+ -- | Splits the argument into its prime prefix and the remaining suffix. Returns 'Nothing' for 'mempty'.+ splitPrimePrefix :: m -> Maybe (m, m)+ -- | Splits the argument into its prime suffix and the remaining prefix. Returns 'Nothing' for 'mempty'.+ splitPrimeSuffix :: m -> Maybe (m, m)+ -- | Returns the list of all prefixes of the argument, 'mempty' first.+ inits :: m -> [m]+ -- | Returns the list of all suffixes of the argument, 'mempty' last.+ tails :: m -> [m]+ -- | Like 'List.foldl' from "Data.List" on the list of 'primes'.+ foldl :: (a -> m -> a) -> a -> m -> a+ -- | Like 'List.foldl'' from "Data.List" on the list of 'primes'.+ foldl' :: (a -> m -> a) -> a -> m -> a+ -- | Like 'List.foldr' from "Data.List" on the list of 'primes'.+ foldr :: (m -> a -> a) -> a -> m -> a+ -- | The 'length' of the list of 'primes'.+ length :: m -> Int+ -- | Generalizes 'foldMap' from "Data.Foldable", except the function arguments are prime factors rather than the+ -- structure elements.+ foldMap :: Monoid n => (m -> n) -> m -> n+ -- | Like 'List.span' from "Data.List" on the list of 'primes'.+ span :: (m -> Bool) -> m -> (m, m)+ -- | Equivalent to 'List.break' from "Data.List".+ break :: (m -> Bool) -> m -> (m, m)+ -- | Splits the monoid into components delimited by prime separators satisfying the given predicate. The primes+ -- satisfying the predicate are not a part of the result.+ split :: (m -> Bool) -> m -> [m]+ -- | Equivalent to 'List.takeWhile' from "Data.List".+ takeWhile :: (m -> Bool) -> m -> m+ -- | Equivalent to 'List.dropWhile' from "Data.List".+ dropWhile :: (m -> Bool) -> m -> m+ -- | A stateful variant of 'span', threading the result of the test function as long as it returns 'Just'.+ spanMaybe :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)+ -- | Strict version of 'spanMaybe'.+ spanMaybe' :: s -> (s -> m -> Maybe s) -> m -> (m, m, s)+ -- | Like 'List.splitAt' from "Data.List" on the list of 'primes'.+ splitAt :: Int -> m -> (m, m)+ -- | Equivalent to 'List.drop' from "Data.List".+ drop :: Int -> m -> m+ -- | Equivalent to 'List.take' from "Data.List".+ take :: Int -> m -> m+ -- | Equivalent to 'List.reverse' from "Data.List".+ reverse :: m -> m++ factors = List.unfoldr splitPrimePrefix+ primePrefix = maybe mempty fst . splitPrimePrefix+ primeSuffix = maybe mempty snd . splitPrimeSuffix+ splitPrimePrefix x = case factors x+ of [] -> Nothing+ prefix : rest -> Just (prefix, mconcat rest)+ splitPrimeSuffix x = case factors x+ of [] -> Nothing+ fs -> Just (mconcat (List.init fs), List.last fs)+ inits = foldr (\m l-> mempty : List.map (mappend m) l) [mempty]+ tails m = m : maybe [] (tails . snd) (splitPrimePrefix m)+ foldl f f0 = List.foldl f f0 . factors+ foldl' f f0 = List.foldl' f f0 . factors+ foldr f f0 = List.foldr f f0 . factors+ length = List.length . factors+ foldMap f = foldr (mappend . f) mempty+ span p m0 = spanAfter id m0+ where spanAfter f m = case splitPrimePrefix m+ of Just (prime, rest) | p prime -> spanAfter (f . mappend prime) rest+ _ -> (f mempty, m)+ break = span . (not .)+ spanMaybe s0 f m0 = spanAfter id s0 m0+ where spanAfter g s m = case splitPrimePrefix m+ of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, m, s)+ Nothing -> (m0, m, s)+ spanMaybe' s0 f m0 = spanAfter id s0 m0+ where spanAfter g s m = seq s $+ case splitPrimePrefix m+ of Just (prime, rest) | Just s' <- f s prime -> spanAfter (g . mappend prime) s' rest+ | otherwise -> (g mempty, m, s)+ Nothing -> (m0, m, s)+ split p m = prefix : splitRest+ where (prefix, rest) = break p m+ splitRest = case splitPrimePrefix rest+ of Nothing -> []+ Just (_, tl) -> split p tl+ takeWhile p = fst . span p+ dropWhile p = snd . span p+ splitAt n0 m0 | n0 <= 0 = (mempty, m0)+ | otherwise = split' n0 id m0+ where split' 0 f m = (f mempty, m)+ split' n f m = case splitPrimePrefix m+ of Nothing -> (f mempty, m)+ Just (prime, rest) -> split' (pred n) (f . mappend prime) rest+ drop n p = snd (splitAt n p)+ take n p = fst (splitAt n p)+ reverse = mconcat . List.reverse . factors+ {-# MINIMAL factors | splitPrimePrefix #-}++-- | A subclass of 'FactorialMonoid' whose instances satisfy this additional law:+--+-- > factors (a <> b) == factors a <> factors b+class (FactorialMonoid m, PositiveMonoid m) => StableFactorialMonoid m++instance FactorialMonoid () where+ factors () = []+ primePrefix () = ()+ primeSuffix () = ()+ splitPrimePrefix () = Nothing+ splitPrimeSuffix () = Nothing+ length () = 0+ reverse = id++instance FactorialMonoid a => FactorialMonoid (Dual a) where+ factors (Dual a) = fmap Dual (reverse $ factors a)+ length (Dual a) = length a+ primePrefix (Dual a) = Dual (primeSuffix a)+ primeSuffix (Dual a) = Dual (primePrefix a)+ splitPrimePrefix (Dual a) = case splitPrimeSuffix a+ of Nothing -> Nothing+ Just (p, s) -> Just (Dual s, Dual p)+ splitPrimeSuffix (Dual a) = case splitPrimePrefix a+ of Nothing -> Nothing+ Just (p, s) -> Just (Dual s, Dual p)+ inits (Dual a) = fmap Dual (reverse $ tails a)+ tails (Dual a) = fmap Dual (reverse $ inits a)+ reverse (Dual a) = Dual (reverse a)++instance (Integral a, Eq a) => FactorialMonoid (Sum a) where+ primePrefix (Sum a) = Sum (signum a )+ primeSuffix = primePrefix+ splitPrimePrefix (Sum 0) = Nothing+ splitPrimePrefix (Sum a) = Just (Sum (signum a), Sum (a - signum a))+ splitPrimeSuffix (Sum 0) = Nothing+ splitPrimeSuffix (Sum a) = Just (Sum (a - signum a), Sum (signum a))+ length (Sum a) = abs (fromIntegral a)+ reverse = id++instance Integral a => FactorialMonoid (Product a) where+ factors (Product a) = List.map Product (primeFactors a)+ reverse = id++instance FactorialMonoid a => FactorialMonoid (Maybe a) where+ factors Nothing = []+ factors (Just a) | null a = [Just a]+ | otherwise = List.map Just (factors a)+ length Nothing = 0+ length (Just a) | null a = 1+ | otherwise = length a+ reverse = fmap reverse++instance (FactorialMonoid a, FactorialMonoid b) => FactorialMonoid (a, b) where+ factors (a, b) = List.map (\a1-> (a1, mempty)) (factors a) ++ List.map ((,) mempty) (factors b)+ primePrefix (a, b) | null a = (a, primePrefix b)+ | otherwise = (primePrefix a, mempty)+ primeSuffix (a, b) | null b = (primeSuffix a, b)+ | otherwise = (mempty, primeSuffix b)+ splitPrimePrefix (a, b) = case (splitPrimePrefix a, splitPrimePrefix b)+ of (Just (ap, as), _) -> Just ((ap, mempty), (as, b))+ (Nothing, Just (bp, bs)) -> Just ((a, bp), (a, bs))+ (Nothing, Nothing) -> Nothing+ splitPrimeSuffix (a, b) = case (splitPrimeSuffix a, splitPrimeSuffix b)+ of (_, Just (bp, bs)) -> Just ((a, bp), (mempty, bs))+ (Just (ap, as), Nothing) -> Just ((ap, b), (as, b))+ (Nothing, Nothing) -> Nothing+ inits (a, b) = List.map (flip (,) mempty) (inits a) ++ List.map ((,) a) (List.tail $ inits b)+ tails (a, b) = List.map (flip (,) b) (tails a) ++ List.map ((,) mempty) (List.tail $ tails b)+ foldl f a0 (x, y) = foldl f2 (foldl f1 a0 x) y+ where f1 a = f a . fromFst+ f2 a = f a . fromSnd+ foldl' f a0 (x, y) = a' `seq` foldl' f2 a' y+ where f1 a = f a . fromFst+ f2 a = f a . fromSnd+ a' = foldl' f1 a0 x+ foldr f a (x, y) = foldr (f . fromFst) (foldr (f . fromSnd) a y) x+ foldMap f (x, y) = foldMap (f . fromFst) x `mappend` foldMap (f . fromSnd) y+ length (a, b) = length a + length b+ span p (x, y) = ((xp, yp), (xs, ys))+ where (xp, xs) = span (p . fromFst) x+ (yp, ys) | null xs = span (p . fromSnd) y+ | otherwise = (mempty, y)+ spanMaybe s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)+ | otherwise = ((xp, mempty), (xs, y), s1)+ where (xp, xs, s1) = spanMaybe s0 (\s-> f s . fromFst) x+ (yp, ys, s2) = spanMaybe s1 (\s-> f s . fromSnd) y+ spanMaybe' s0 f (x, y) | null xs = ((xp, yp), (xs, ys), s2)+ | otherwise = ((xp, mempty), (xs, y), s1)+ where (xp, xs, s1) = spanMaybe' s0 (\s-> f s . fromFst) x+ (yp, ys, s2) = spanMaybe' s1 (\s-> f s . fromSnd) y+ split p (x0, y0) = fst $ List.foldr combine (ys, False) xs+ where xs = List.map fromFst $ split (p . fromFst) x0+ ys = List.map fromSnd $ split (p . fromSnd) y0+ combine x (~(y:rest), False) = (mappend x y : rest, True)+ combine x (rest, True) = (x:rest, True)+ splitAt n (x, y) = ((xp, yp), (xs, ys))+ where (xp, xs) = splitAt n x+ (yp, ys) | null xs = splitAt (n - length x) y+ | otherwise = (mempty, y)+ reverse (a, b) = (reverse a, reverse b)++{-# INLINE fromFst #-}+fromFst :: Monoid b => a -> (a, b)+fromFst a = (a, mempty)++{-# INLINE fromSnd #-}+fromSnd :: Monoid a => b -> (a, b)+fromSnd b = (mempty, b)++instance FactorialMonoid [x] where+ factors xs = List.map (:[]) xs+ primePrefix [] = []+ primePrefix (x:_) = [x]+ primeSuffix [] = []+ primeSuffix xs = [List.last xs]+ splitPrimePrefix [] = Nothing+ splitPrimePrefix (x:xs) = Just ([x], xs)+ splitPrimeSuffix [] = Nothing+ splitPrimeSuffix xs = Just (splitLast id xs)+ where splitLast f last@[_] = (f [], last)+ splitLast f ~(x:rest) = splitLast (f . (x:)) rest+ inits = List.inits+ tails = List.tails+ foldl _ a [] = a+ foldl f a (x:xs) = foldl f (f a [x]) xs+ foldl' _ a [] = a+ foldl' f a (x:xs) = let a' = f a [x] in a' `seq` foldl' f a' xs+ foldr _ f0 [] = f0+ foldr f f0 (x:xs) = f [x] (foldr f f0 xs)+ length = List.length+ foldMap f = mconcat . List.map (f . (:[]))+ break f = List.break (f . (:[]))+ span f = List.span (f . (:[]))+ dropWhile f = List.dropWhile (f . (:[]))+ takeWhile f = List.takeWhile (f . (:[]))+ spanMaybe s0 f l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = (prefix . (x:), id, s2, True)+ | otherwise = (prefix, suffix . (x:), s1, False)+ spanMaybe' s0 f l = (prefix' [], suffix' [], s')+ where (prefix', suffix', s', _) = List.foldl' g (id, id, s0, True) l+ g (prefix, suffix, s1, live) x | live, Just s2 <- f s1 [x] = seq s2 $ (prefix . (x:), id, s2, True)+ | otherwise = (prefix, suffix . (x:), s1, False)+ splitAt = List.splitAt+ drop = List.drop+ take = List.take+ reverse = List.reverse++instance FactorialMonoid ByteString.ByteString where+ factors x = factorize (ByteString.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = ByteString.splitAt 1 xs+ primePrefix = ByteString.take 1+ primeSuffix x = ByteString.drop (ByteString.length x - 1) x+ splitPrimePrefix x = if ByteString.null x then Nothing else Just (ByteString.splitAt 1 x)+ splitPrimeSuffix x = if ByteString.null x then Nothing else Just (ByteString.splitAt (ByteString.length x - 1) x)+ inits = ByteString.inits+ tails = ByteString.tails+ foldl f = ByteString.foldl f'+ where f' a byte = f a (ByteString.singleton byte)+ foldl' f = ByteString.foldl' f'+ where f' a byte = f a (ByteString.singleton byte)+ foldr f = ByteString.foldr (f . ByteString.singleton)+ break f = ByteString.break (f . ByteString.singleton)+ span f = ByteString.span (f . ByteString.singleton)+ spanMaybe s0 f b = case ByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case ByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- ByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s) | Just s' <- f s (ByteString.singleton w) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ dropWhile f = ByteString.dropWhile (f . ByteString.singleton)+ takeWhile f = ByteString.takeWhile (f . ByteString.singleton)+ length = ByteString.length+ split f = ByteString.splitWith f'+ where f' = f . ByteString.singleton+ splitAt = ByteString.splitAt+ drop = ByteString.drop+ take = ByteString.take+ reverse = ByteString.reverse++instance FactorialMonoid LazyByteString.ByteString where+ factors x = factorize (LazyByteString.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = LazyByteString.splitAt 1 xs+ primePrefix = LazyByteString.take 1+ primeSuffix x = LazyByteString.drop (LazyByteString.length x - 1) x+ splitPrimePrefix x = if LazyByteString.null x then Nothing+ else Just (LazyByteString.splitAt 1 x)+ splitPrimeSuffix x = if LazyByteString.null x then Nothing+ else Just (LazyByteString.splitAt (LazyByteString.length x - 1) x)+ inits = LazyByteString.inits+ tails = LazyByteString.tails+ foldl f = LazyByteString.foldl f'+ where f' a byte = f a (LazyByteString.singleton byte)+ foldl' f = LazyByteString.foldl' f'+ where f' a byte = f a (LazyByteString.singleton byte)+ foldr f = LazyByteString.foldr f'+ where f' byte a = f (LazyByteString.singleton byte) a+ length = fromIntegral . LazyByteString.length+ break f = LazyByteString.break (f . LazyByteString.singleton)+ span f = LazyByteString.span (f . LazyByteString.singleton)+ spanMaybe s0 f b = case LazyByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s) | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case LazyByteString.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- LazyByteString.splitAt i b -> (prefix, suffix, s')+ where g w cont (i, s)+ | Just s' <- f s (LazyByteString.singleton w) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ dropWhile f = LazyByteString.dropWhile (f . LazyByteString.singleton)+ takeWhile f = LazyByteString.takeWhile (f . LazyByteString.singleton)+ split f = LazyByteString.splitWith f'+ where f' = f . LazyByteString.singleton+ splitAt = LazyByteString.splitAt . fromIntegral+ drop n = LazyByteString.drop (fromIntegral n)+ take n = LazyByteString.take (fromIntegral n)+ reverse = LazyByteString.reverse++instance FactorialMonoid Text.Text where+ factors = Text.chunksOf 1+ primePrefix = Text.take 1+ primeSuffix x = if Text.null x then Text.empty else Text.singleton (Text.last x)+ splitPrimePrefix = fmap (first Text.singleton) . Text.uncons+ splitPrimeSuffix x = if Text.null x then Nothing else Just (Text.init x, Text.singleton (Text.last x))+ inits = Text.inits+ tails = Text.tails+ foldl f = Text.foldl f'+ where f' a char = f a (Text.singleton char)+ foldl' f = Text.foldl' f'+ where f' a char = f a (Text.singleton char)+ foldr f = Text.foldr f'+ where f' char a = f (Text.singleton char) a+ length = Text.length+ span f = Text.span (f . Text.singleton)+ break f = Text.break (f . Text.singleton)+ dropWhile f = Text.dropWhile (f . Text.singleton)+ takeWhile f = Text.takeWhile (f . Text.singleton)+ spanMaybe s0 f t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f t = case Text.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- Text.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (Text.singleton c) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ split f = Text.split f'+ where f' = f . Text.singleton+ splitAt = Text.splitAt+ drop = Text.drop+ take = Text.take+ reverse = Text.reverse++instance FactorialMonoid LazyText.Text where+ factors = LazyText.chunksOf 1+ primePrefix = LazyText.take 1+ primeSuffix x = if LazyText.null x then LazyText.empty else LazyText.singleton (LazyText.last x)+ splitPrimePrefix = fmap (first LazyText.singleton) . LazyText.uncons+ splitPrimeSuffix x = if LazyText.null x+ then Nothing+ else Just (LazyText.init x, LazyText.singleton (LazyText.last x))+ inits = LazyText.inits+ tails = LazyText.tails+ foldl f = LazyText.foldl f'+ where f' a char = f a (LazyText.singleton char)+ foldl' f = LazyText.foldl' f'+ where f' a char = f a (LazyText.singleton char)+ foldr f = LazyText.foldr f'+ where f' char a = f (LazyText.singleton char) a+ length = fromIntegral . LazyText.length+ span f = LazyText.span (f . LazyText.singleton)+ break f = LazyText.break (f . LazyText.singleton)+ dropWhile f = LazyText.dropWhile (f . LazyText.singleton)+ takeWhile f = LazyText.takeWhile (f . LazyText.singleton)+ spanMaybe s0 f t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f t = case LazyText.foldr g id t (0, s0)+ of (i, s') | (prefix, suffix) <- LazyText.splitAt i t -> (prefix, suffix, s')+ where g c cont (i, s) | Just s' <- f s (LazyText.singleton c) = let i' = succ i :: Int64 in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ split f = LazyText.split f'+ where f' = f . LazyText.singleton+ splitAt = LazyText.splitAt . fromIntegral+ drop n = LazyText.drop (fromIntegral n)+ take n = LazyText.take (fromIntegral n)+ reverse = LazyText.reverse++instance Ord k => FactorialMonoid (Map.Map k v) where+ factors = List.map (uncurry Map.singleton) . Map.toAscList+ primePrefix map | Map.null map = map+ | otherwise = uncurry Map.singleton $ Map.findMin map+ primeSuffix map | Map.null map = map+ | otherwise = uncurry Map.singleton $ Map.findMax map+ splitPrimePrefix = fmap singularize . Map.minViewWithKey+ where singularize ((k, v), rest) = (Map.singleton k v, rest)+ splitPrimeSuffix = fmap singularize . Map.maxViewWithKey+ where singularize ((k, v), rest) = (rest, Map.singleton k v)+ foldl f = Map.foldlWithKey f'+ where f' a k v = f a (Map.singleton k v)+ foldl' f = Map.foldlWithKey' f'+ where f' a k v = f a (Map.singleton k v)+ foldr f = Map.foldrWithKey f'+ where f' k v a = f (Map.singleton k v) a+ length = Map.size+ reverse = id++instance FactorialMonoid (IntMap.IntMap a) where+ factors = List.map (uncurry IntMap.singleton) . IntMap.toAscList+ primePrefix map | IntMap.null map = map+ | otherwise = uncurry IntMap.singleton $ IntMap.findMin map+ primeSuffix map | IntMap.null map = map+ | otherwise = uncurry IntMap.singleton $ IntMap.findMax map+ splitPrimePrefix = fmap singularize . IntMap.minViewWithKey+ where singularize ((k, v), rest) = (IntMap.singleton k v, rest)+ splitPrimeSuffix = fmap singularize . IntMap.maxViewWithKey+ where singularize ((k, v), rest) = (rest, IntMap.singleton k v)+ foldl f = IntMap.foldlWithKey f'+ where f' a k v = f a (IntMap.singleton k v)+ foldl' f = IntMap.foldlWithKey' f'+ where f' a k v = f a (IntMap.singleton k v)+ foldr f = IntMap.foldrWithKey f'+ where f' k v a = f (IntMap.singleton k v) a+ length = IntMap.size+ reverse = id++instance FactorialMonoid IntSet.IntSet where+ factors = List.map IntSet.singleton . IntSet.toAscList+ primePrefix set | IntSet.null set = set+ | otherwise = IntSet.singleton $ IntSet.findMin set+ primeSuffix set | IntSet.null set = set+ | otherwise = IntSet.singleton $ IntSet.findMax set+ splitPrimePrefix = fmap singularize . IntSet.minView+ where singularize (min, rest) = (IntSet.singleton min, rest)+ splitPrimeSuffix = fmap singularize . IntSet.maxView+ where singularize (max, rest) = (rest, IntSet.singleton max)+ foldl f = IntSet.foldl f'+ where f' a b = f a (IntSet.singleton b)+ foldl' f = IntSet.foldl' f'+ where f' a b = f a (IntSet.singleton b)+ foldr f = IntSet.foldr f'+ where f' a b = f (IntSet.singleton a) b+ length = IntSet.size+ reverse = id++instance FactorialMonoid (Sequence.Seq a) where+ factors = List.map Sequence.singleton . Foldable.toList+ primePrefix = Sequence.take 1+ primeSuffix q = Sequence.drop (Sequence.length q - 1) q+ splitPrimePrefix q = case Sequence.viewl q+ of Sequence.EmptyL -> Nothing+ hd Sequence.:< rest -> Just (Sequence.singleton hd, rest)+ splitPrimeSuffix q = case Sequence.viewr q+ of Sequence.EmptyR -> Nothing+ rest Sequence.:> last -> Just (rest, Sequence.singleton last)+ inits = Foldable.toList . Sequence.inits+ tails = Foldable.toList . Sequence.tails+ foldl f = Foldable.foldl f'+ where f' a b = f a (Sequence.singleton b)+ foldl' f = Foldable.foldl' f'+ where f' a b = f a (Sequence.singleton b)+ foldr f = Foldable.foldr f'+ where f' a b = f (Sequence.singleton a) b+ span f = Sequence.spanl (f . Sequence.singleton)+ break f = Sequence.breakl (f . Sequence.singleton)+ dropWhile f = Sequence.dropWhileL (f . Sequence.singleton)+ takeWhile f = Sequence.takeWhileL (f . Sequence.singleton)+ spanMaybe s0 f b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ cont (i', s')+ | otherwise = (i, s)+ spanMaybe' s0 f b = case Foldable.foldr g id b (0, s0)+ of (i, s') | (prefix, suffix) <- Sequence.splitAt i b -> (prefix, suffix, s')+ where g x cont (i, s) | Just s' <- f s (Sequence.singleton x) = let i' = succ i :: Int in seq i' $ seq s' $ cont (i', s')+ | otherwise = (i, s)+ splitAt = Sequence.splitAt+ drop = Sequence.drop+ take = Sequence.take+ length = Sequence.length+ reverse = Sequence.reverse++instance Ord a => FactorialMonoid (Set.Set a) where+ factors = List.map Set.singleton . Set.toAscList+ primePrefix set | Set.null set = set+ | otherwise = Set.singleton $ Set.findMin set+ primeSuffix set | Set.null set = set+ | otherwise = Set.singleton $ Set.findMax set+ splitPrimePrefix = fmap singularize . Set.minView+ where singularize (min, rest) = (Set.singleton min, rest)+ splitPrimeSuffix = fmap singularize . Set.maxView+ where singularize (max, rest) = (rest, Set.singleton max)+ foldl f = Foldable.foldl f'+ where f' a b = f a (Set.singleton b)+ foldl' f = Foldable.foldl' f'+ where f' a b = f a (Set.singleton b)+ foldr f = Foldable.foldr f'+ where f' a b = f (Set.singleton a) b+ length = Set.size+ reverse = id++instance FactorialMonoid (Vector.Vector a) where+ factors x = factorize (Vector.length x) x+ where factorize 0 _ = []+ factorize n xs = xs1 : factorize (pred n) xs'+ where (xs1, xs') = Vector.splitAt 1 xs+ primePrefix = Vector.take 1+ primeSuffix x = Vector.drop (Vector.length x - 1) x+ splitPrimePrefix x = if Vector.null x then Nothing else Just (Vector.splitAt 1 x)+ splitPrimeSuffix x = if Vector.null x then Nothing else Just (Vector.splitAt (Vector.length x - 1) x)+ inits x0 = initsWith x0 []+ where initsWith x rest | Vector.null x = x:rest+ | otherwise = initsWith (Vector.unsafeInit x) (x:rest)+ tails x = x : if Vector.null x then [] else tails (Vector.unsafeTail x)+ foldl f = Vector.foldl f'+ where f' a byte = f a (Vector.singleton byte)+ foldl' f = Vector.foldl' f'+ where f' a byte = f a (Vector.singleton byte)+ foldr f = Vector.foldr f'+ where f' byte a = f (Vector.singleton byte) a+ break f = Vector.break (f . Vector.singleton)+ span f = Vector.span (f . Vector.singleton)+ dropWhile f = Vector.dropWhile (f . Vector.singleton)+ takeWhile f = Vector.takeWhile (f . Vector.singleton)+ spanMaybe s0 f v = case Vector.ifoldr g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i x cont s | Just s' <- f s (Vector.singleton x) = cont s'+ | otherwise = Right (i, s)+ spanMaybe' s0 f v = case Vector.ifoldr' g Left v s0+ of Left s' -> (v, Vector.empty, s')+ Right (i, s') | (prefix, suffix) <- Vector.splitAt i v -> (prefix, suffix, s')+ where g i x cont s | Just s' <- f s (Vector.singleton x) = seq s' (cont s')+ | otherwise = Right (i, s)+ splitAt = Vector.splitAt+ drop = Vector.drop+ take = Vector.take+ length = Vector.length+ reverse = Vector.reverse++instance StableFactorialMonoid ()+instance StableFactorialMonoid a => StableFactorialMonoid (Dual a)+instance StableFactorialMonoid [x]+instance StableFactorialMonoid ByteString.ByteString+instance StableFactorialMonoid LazyByteString.ByteString+instance StableFactorialMonoid Text.Text+instance StableFactorialMonoid LazyText.Text+instance StableFactorialMonoid (Sequence.Seq a)+instance StableFactorialMonoid (Vector.Vector a)++-- | A 'Monad.mapM' equivalent.+mapM :: (FactorialMonoid a, Monoid b, Monad m) => (a -> m b) -> a -> m b+mapM f = ($ return mempty) . appEndo . foldMap (Endo . Monad.liftM2 mappend . f)++-- | A 'Monad.mapM_' equivalent.+mapM_ :: (FactorialMonoid a, Monad m) => (a -> m b) -> a -> m ()+mapM_ f = foldr ((>>) . f) (return ())
+ tests/examples/Undefined11.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE NoImplicitPrelude #-}+module Algebra.Additive (+ -- * Class+ C,+ zero,+ (+), (-),+ negate, subtract,++ -- * Complex functions+ sum, sum1,+ sumNestedAssociative,+ sumNestedCommutative,++ -- * Instance definition helpers+ elementAdd, elementSub, elementNeg,+ (<*>.+), (<*>.-), (<*>.-$),++ -- * Instances for atomic types+ propAssociative,+ propCommutative,+ propIdentity,+ propInverse,+ ) where++import qualified Algebra.Laws as Laws++import Data.Int (Int, Int8, Int16, Int32, Int64, )+import Data.Word (Word, Word8, Word16, Word32, Word64, )++import qualified NumericPrelude.Elementwise as Elem+import Control.Applicative (Applicative(pure, (<*>)), )+import Data.Tuple.HT (fst3, snd3, thd3, )+import qualified Data.List.Match as Match++import qualified Data.Complex as Complex98+import qualified Data.Ratio as Ratio98+import qualified Prelude as P+import Prelude (Integer, Float, Double, fromInteger, )+import NumericPrelude.Base+++infixl 6 +, -++{- |+Additive a encapsulates the notion of a commutative group, specified+by the following laws:++@+ a + b === b + a+ (a + b) + c === a + (b + c)+ zero + a === a+ a + negate a === 0+@++Typical examples include integers, dollars, and vectors.++Minimal definition: '+', 'zero', and ('negate' or '(-)')+-}++class C a where+ {-# MINIMAL zero, (+), ((-) | negate) #-}+ -- | zero element of the vector space+ zero :: a+ -- | add and subtract elements+ (+), (-) :: a -> a -> a+ -- | inverse with respect to '+'+ negate :: a -> a++ {-# INLINE negate #-}+ negate a = zero - a+ {-# INLINE (-) #-}+ a - b = a + negate b++{- |+'subtract' is @(-)@ with swapped operand order.+This is the operand order which will be needed in most cases+of partial application.+-}+subtract :: C a => a -> a -> a+subtract = flip (-)+++++{- |+Sum up all elements of a list.+An empty list yields zero.++This function is inappropriate for number types like Peano.+Maybe we should make 'sum' a method of Additive.+This would also make 'lengthLeft' and 'lengthRight' superfluous.+-}+sum :: (C a) => [a] -> a+sum = foldl (+) zero++{- |+Sum up all elements of a non-empty list.+This avoids including a zero which is useful for types+where no universal zero is available.+-}+sum1 :: (C a) => [a] -> a+sum1 = foldl1 (+)+++{- |+Sum the operands in an order,+such that the dependencies are minimized.+Does this have a measurably effect on speed?++Requires associativity.+-}+sumNestedAssociative :: (C a) => [a] -> a+sumNestedAssociative [] = zero+sumNestedAssociative [x] = x+sumNestedAssociative xs = sumNestedAssociative (sum2 xs)++{-+Make sure that the last entries in the list+are equally often part of an addition.+Maybe this can reduce rounding errors.+The list that sum2 computes is a breadth-first-flattened binary tree.++Requires associativity and commutativity.+-}+sumNestedCommutative :: (C a) => [a] -> a+sumNestedCommutative [] = zero+sumNestedCommutative xs@(_:rs) =+ let ys = xs ++ Match.take rs (sum2 ys)+ in last ys++_sumNestedCommutative :: (C a) => [a] -> a+_sumNestedCommutative [] = zero+_sumNestedCommutative xs@(_:rs) =+ let ys = xs ++ take (length rs) (sum2 ys)+ in last ys++{-+[a,b,c, a+b,c+(a+b)]+[a,b,c,d, a+b,c+d,(a+b)+(c+d)]+[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)]+[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))]+-}++sum2 :: (C a) => [a] -> [a]+sum2 (x:y:rest) = (x+y) : sum2 rest+sum2 xs = xs++++{- |+Instead of baking the add operation into the element function,+we could use higher rank types+and pass a generic @uncurry (+)@ to the run function.+We do not do so in order to stay Haskell 98+at least for parts of NumericPrelude.+-}+{-# INLINE elementAdd #-}+elementAdd ::+ (C x) =>+ (v -> x) -> Elem.T (v,v) x+elementAdd f =+ Elem.element (\(x,y) -> f x + f y)++{-# INLINE elementSub #-}+elementSub ::+ (C x) =>+ (v -> x) -> Elem.T (v,v) x+elementSub f =+ Elem.element (\(x,y) -> f x - f y)++{-# INLINE elementNeg #-}+elementNeg ::+ (C x) =>+ (v -> x) -> Elem.T v x+elementNeg f =+ Elem.element (negate . f)+++-- like <*>+infixl 4 <*>.+, <*>.-, <*>.-$++{- |+> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b)+> addPair = Elem.run2 $ Elem.with (,) <*>.+ fst <*>.+ snd+-}+{-# INLINE (<*>.+) #-}+(<*>.+) ::+ (C x) =>+ Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a+(<*>.+) f acc =+ f <*> elementAdd acc++{-# INLINE (<*>.-) #-}+(<*>.-) ::+ (C x) =>+ Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a+(<*>.-) f acc =+ f <*> elementSub acc++{-# INLINE (<*>.-$) #-}+(<*>.-$) ::+ (C x) =>+ Elem.T v (x -> a) -> (v -> x) -> Elem.T v a+(<*>.-$) f acc =+ f <*> elementNeg acc+++-- * Instances for atomic types++instance C Integer where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Float where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Double where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)+++instance C Int where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Int8 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Int16 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Int32 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Int64 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)+++instance C Word where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Word8 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Word16 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Word32 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)++instance C Word64 where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ negate = P.negate+ (+) = (P.+)+ (-) = (P.-)+++++-- * Instances for composed types++instance (C v0, C v1) => C (v0, v1) where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = (,) zero zero+ (+) = Elem.run2 $ pure (,) <*>.+ fst <*>.+ snd+ (-) = Elem.run2 $ pure (,) <*>.- fst <*>.- snd+ negate = Elem.run $ pure (,) <*>.-$ fst <*>.-$ snd++instance (C v0, C v1, C v2) => C (v0, v1, v2) where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = (,,) zero zero zero+ (+) = Elem.run2 $ pure (,,) <*>.+ fst3 <*>.+ snd3 <*>.+ thd3+ (-) = Elem.run2 $ pure (,,) <*>.- fst3 <*>.- snd3 <*>.- thd3+ negate = Elem.run $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3+++instance (C v) => C [v] where+ zero = []+ negate = map negate+ (+) (x:xs) (y:ys) = (+) x y : (+) xs ys+ (+) xs [] = xs+ (+) [] ys = ys+ (-) (x:xs) (y:ys) = (-) x y : (-) xs ys+ (-) xs [] = xs+ (-) [] ys = negate ys+++instance (C v) => C (b -> v) where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero _ = zero+ (+) f g x = (+) (f x) (g x)+ (-) f g x = (-) (f x) (g x)+ negate f x = negate (f x)++-- * Properties++propAssociative :: (Eq a, C a) => a -> a -> a -> Bool+propCommutative :: (Eq a, C a) => a -> a -> Bool+propIdentity :: (Eq a, C a) => a -> Bool+propInverse :: (Eq a, C a) => a -> Bool++propCommutative = Laws.commutative (+)+propAssociative = Laws.associative (+)+propIdentity = Laws.identity (+) zero+propInverse = Laws.inverse (+) negate zero++++-- legacy++instance (P.Integral a) => C (Ratio98.Ratio a) where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ (+) = (P.+)+ (-) = (P.-)+ negate = P.negate++instance (P.RealFloat a) => C (Complex98.Complex a) where+ {-# INLINE zero #-}+ {-# INLINE negate #-}+ {-# INLINE (+) #-}+ {-# INLINE (-) #-}+ zero = P.fromInteger 0+ (+) = (P.+)+ (-) = (P.-)+ negate = P.negate
+ tests/examples/Undefined13.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Network.TigHTTP.Papillon (+ ContentType(..), Type(..), Subtype(..), Parameter(..), Charset(..),+ parseContentType, showContentType,+) where++import Data.Char+import Text.Papillon++import Data.ByteString (ByteString)+import Data.ByteString.Char8 (pack)+import qualified Data.ByteString as BS++import Network.TigHTTP.Token++data ContentType = ContentType Type Subtype [Parameter]+ deriving (Show, Eq)++parseContentType :: BS.ByteString -> ContentType+parseContentType ct = case runError . contentType $ parse ct of+ Left _ -> error "parseContentType"+ Right (r, _) -> r++showContentType :: ContentType -> BS.ByteString+showContentType (ContentType t st ps) = showType t+ `BS.append` "/"+ `BS.append` showSubtype st+ `BS.append` showParameters ps++data Type+ = Text+ | TypeRaw BS.ByteString+ deriving (Show, Eq)++mkType :: BS.ByteString -> Type+mkType "text" = Text+mkType t = TypeRaw t++showType :: Type -> BS.ByteString+showType Text = "text"+showType (TypeRaw t) = t++data Subtype+ = Plain+ | Html+ | Css+ | SubtypeRaw BS.ByteString+ deriving (Show, Eq)++mkSubtype :: BS.ByteString -> Subtype+mkSubtype "html" = Html+mkSubtype "plain" = Plain+mkSubtype "css" = Css+mkSubtype s = SubtypeRaw s++showSubtype :: Subtype -> BS.ByteString+showSubtype Plain = "plain"+showSubtype Html = "html"+showSubtype Css = "css"+showSubtype (SubtypeRaw s) = s++data Parameter+ = Charset Charset+ | ParameterRaw BS.ByteString BS.ByteString+ deriving (Show, Eq)++mkParameter :: BS.ByteString -> BS.ByteString -> Parameter+mkParameter "charset" "UTF-8" = Charset Utf8+mkParameter "charset" v = Charset $ CharsetRaw v+mkParameter a v = ParameterRaw a v++showParameters :: [Parameter] -> BS.ByteString+showParameters [] = ""+showParameters (Charset v : ps) = "; " `BS.append` "charset"+ `BS.append` "=" `BS.append` showCharset v `BS.append` showParameters ps+showParameters (ParameterRaw a v : ps) = "; " `BS.append` a+ `BS.append` "=" `BS.append` v `BS.append` showParameters ps++data Charset+ = Utf8+ | CharsetRaw BS.ByteString+ deriving (Show, Eq)++showCharset :: Charset -> BS.ByteString+showCharset Utf8 = "UTF-8"+showCharset (CharsetRaw cs) = cs++bsconcat :: [ByteString] -> ByteString+bsconcat = BS.concat++[papillon|++source: ByteString++contentType :: ContentType+ = c:token '/' sc:token ps:(';' ' '* p:parameter { p })*+ { ContentType (mkType c) (mkSubtype sc) ps }++token :: ByteString+ = t:<isTokenChar>+ { pack t }++quotedString :: ByteString+ = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"'+ { bsconcat t }++quotedPair :: Char+ = '\\' c:<isAscii> { c }++crlf :: () = '\r' '\n'++lws :: () = _:crlf _:(' ' / '\t')+++-- text :: ByteString+-- = ts:(cs:<isTextChar>+ { cs } / _:lws { " " })+ { pack $ concat ts }++qdtext :: ByteString+ = ts:(cs:<isQdtextChar>+ { cs } / _:lws { " " })+ { pack $ concat ts }++parameter :: Parameter+ = a:attribute '=' v:value { mkParameter a v }++attribute :: ByteString = t:token { t }++value :: ByteString+ = t:token { t }+ / qs:quotedString { qs }++|]
+ tests/examples/Undefined2.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE Safe #-}++-----------------------------------------------------------------------------+-- |+-- Module : Control.Monad.Zip+-- Copyright : (c) Nils Schweinsberg 2011,+-- (c) George Giorgidze 2011+-- (c) University Tuebingen 2011+-- License : BSD-style (see the file libraries/base/LICENSE)+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Monadic zipping (used for monad comprehensions)+--+-----------------------------------------------------------------------------++module Control.Monad.Zip where++import Prelude+import Control.Monad (liftM)++-- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith`+--+-- Instances should satisfy the laws:+--+-- * Naturality :+--+-- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb)+--+-- * Information Preservation:+--+-- > liftM (const ()) ma = liftM (const ()) mb+-- > ==>+-- > munzip (mzip ma mb) = (ma, mb)+--+class Monad m => MonadZip m where++ mzip :: m a -> m b -> m (a,b)+ mzip = mzipWith (,)++ mzipWith :: (a -> b -> c) -> m a -> m b -> m c+ mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)++ munzip :: m (a,b) -> (m a, m b)+ munzip mab = (liftM fst mab, liftM snd mab)+ -- munzip is a member of the class because sometimes+ -- you can implement it more efficiently than the+ -- above default code. See Trac #4370 comment by giorgidze+ {-# MINIMAL mzip | mzipWith #-}++instance MonadZip [] where+ mzip = zip+ mzipWith = zipWith+ munzip = unzip+
+ tests/examples/Undefined3.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Foldable+-- Copyright : Ross Paterson 2005+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Class of data structures that can be folded to a summary value.+--+-- Many of these functions generalize "Prelude", "Control.Monad" and+-- "Data.List" functions of the same names from lists to any 'Foldable'+-- functor. To avoid ambiguity, either import those modules hiding+-- these names or qualify uses of these function names with an alias+-- for this module.+--+-----------------------------------------------------------------------------++module Data.Foldable (+ -- * Folds+ Foldable(..),+ -- ** Special biased folds+ foldrM,+ foldlM,+ -- ** Folding actions+ -- *** Applicative actions+ traverse_,+ for_,+ sequenceA_,+ asum,+ -- *** Monadic actions+ mapM_,+ forM_,+ sequence_,+ msum,+ -- ** Specialized folds+ toList,+ concat,+ concatMap,+ and,+ or,+ any,+ all,+ sum,+ product,+ maximum,+ maximumBy,+ minimum,+ minimumBy,+ -- ** Searches+ elem,+ notElem,+ find+ ) where++import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_,+ elem, notElem, concat, concatMap, and, or, any, all,+ sum, product, maximum, minimum)+import qualified Prelude (foldl, foldr, foldl1, foldr1)+import qualified Data.List as List (foldl')+import Control.Applicative+import Control.Monad (MonadPlus(..))+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Monoid+import Data.Proxy++import GHC.Exts (build)+import GHC.Arr++-- | Data structures that can be folded.+--+-- Minimal complete definition: 'foldMap' or 'foldr'.+--+-- For example, given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Foldable Tree where+-- > foldMap f Empty = mempty+-- > foldMap f (Leaf x) = f x+-- > foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r+--+-- This is suitable even for abstract types, as the monoid is assumed+-- to satisfy the monoid laws. Alternatively, one could define @foldr@:+--+-- > instance Foldable Tree where+-- > foldr f z Empty = z+-- > foldr f z (Leaf x) = f x z+-- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l+--+class Foldable t where+ -- | Combine the elements of a structure using a monoid.+ fold :: Monoid m => t m -> m+ fold = foldMap id++ -- | Map each element of the structure to a monoid,+ -- and combine the results.+ foldMap :: Monoid m => (a -> m) -> t a -> m+ foldMap f = foldr (mappend . f) mempty++ -- | Right-associative fold of a structure.+ --+ -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@+ foldr :: (a -> b -> b) -> b -> t a -> b+ foldr f z t = appEndo (foldMap (Endo . f) t) z++ -- | Right-associative fold of a structure,+ -- but with strict application of the operator.+ foldr' :: (a -> b -> b) -> b -> t a -> b+ foldr' f z0 xs = foldl f' id xs z0+ where f' k x z = k $! f x z++ -- | Left-associative fold of a structure.+ --+ -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@+ foldl :: (b -> a -> b) -> b -> t a -> b+ foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z++ -- | Left-associative fold of a structure.+ -- but with strict application of the operator.+ --+ -- @'foldl' f z = 'List.foldl'' f z . 'toList'@+ foldl' :: (b -> a -> b) -> b -> t a -> b+ foldl' f z0 xs = foldr f' id xs z0+ where f' x k z = k $! f z x++ -- | A variant of 'foldr' that has no base case,+ -- and thus may only be applied to non-empty structures.+ --+ -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@+ foldr1 :: (a -> a -> a) -> t a -> a+ foldr1 f xs = fromMaybe (error "foldr1: empty structure")+ (foldr mf Nothing xs)+ where+ mf x Nothing = Just x+ mf x (Just y) = Just (f x y)++ -- | A variant of 'foldl' that has no base case,+ -- and thus may only be applied to non-empty structures.+ --+ -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@+ foldl1 :: (a -> a -> a) -> t a -> a+ foldl1 f xs = fromMaybe (error "foldl1: empty structure")+ (foldl mf Nothing xs)+ where+ mf Nothing y = Just y+ mf (Just x) y = Just (f x y)+ {-# MINIMAL foldMap | foldr #-}++-- instances for Prelude types++instance Foldable Maybe where+ foldr _ z Nothing = z+ foldr f z (Just x) = f x z++ foldl _ z Nothing = z+ foldl f z (Just x) = f z x++instance Foldable [] where+ foldr = Prelude.foldr+ foldl = Prelude.foldl+ foldl' = List.foldl'+ foldr1 = Prelude.foldr1+ foldl1 = Prelude.foldl1++instance Foldable (Either a) where+ foldMap _ (Left _) = mempty+ foldMap f (Right y) = f y++ foldr _ z (Left _) = z+ foldr f z (Right y) = f y z++instance Foldable ((,) a) where+ foldMap f (_, y) = f y++ foldr f z (_, y) = f y z++instance Ix i => Foldable (Array i) where+ foldr f z = Prelude.foldr f z . elems+ foldl f z = Prelude.foldl f z . elems+ foldr1 f = Prelude.foldr1 f . elems+ foldl1 f = Prelude.foldl1 f . elems++instance Foldable Proxy where+ foldMap _ _ = mempty+ {-# INLINE foldMap #-}+ fold _ = mempty+ {-# INLINE fold #-}+ foldr _ z _ = z+ {-# INLINE foldr #-}+ foldl _ z _ = z+ {-# INLINE foldl #-}+ foldl1 _ _ = error "foldl1: Proxy"+ {-# INLINE foldl1 #-}+ foldr1 _ _ = error "foldr1: Proxy"+ {-# INLINE foldr1 #-}++instance Foldable (Const m) where+ foldMap _ _ = mempty++-- | Monadic fold over the elements of a structure,+-- associating to the right, i.e. from right to left.+foldrM :: (Foldable t, Monad m) => (a -> b -> m b) -> b -> t a -> m b+foldrM f z0 xs = foldl f' return xs z0+ where f' k x z = f x z >>= k++-- | Monadic fold over the elements of a structure,+-- associating to the left, i.e. from left to right.+foldlM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b+foldlM f z0 xs = foldr f' return xs z0+ where f' x k z = f z x >>= k++-- | Map each element of a structure to an action, evaluate+-- these actions from left to right, and ignore the results.+traverse_ :: (Foldable t, Applicative f) => (a -> f b) -> t a -> f ()+traverse_ f = foldr ((*>) . f) (pure ())++-- | 'for_' is 'traverse_' with its arguments flipped.+for_ :: (Foldable t, Applicative f) => t a -> (a -> f b) -> f ()+{-# INLINE for_ #-}+for_ = flip traverse_++-- | Map each element of a structure to a monadic action, evaluate+-- these actions from left to right, and ignore the results.+mapM_ :: (Foldable t, Monad m) => (a -> m b) -> t a -> m ()+mapM_ f = foldr ((>>) . f) (return ())++-- | 'forM_' is 'mapM_' with its arguments flipped.+forM_ :: (Foldable t, Monad m) => t a -> (a -> m b) -> m ()+{-# INLINE forM_ #-}+forM_ = flip mapM_++-- | Evaluate each action in the structure from left to right,+-- and ignore the results.+sequenceA_ :: (Foldable t, Applicative f) => t (f a) -> f ()+sequenceA_ = foldr (*>) (pure ())++-- | Evaluate each monadic action in the structure from left to right,+-- and ignore the results.+sequence_ :: (Foldable t, Monad m) => t (m a) -> m ()+sequence_ = foldr (>>) (return ())++-- | The sum of a collection of actions, generalizing 'concat'.+asum :: (Foldable t, Alternative f) => t (f a) -> f a+{-# INLINE asum #-}+asum = foldr (<|>) empty++-- | The sum of a collection of actions, generalizing 'concat'.+msum :: (Foldable t, MonadPlus m) => t (m a) -> m a+{-# INLINE msum #-}+msum = foldr mplus mzero++-- These use foldr rather than foldMap to avoid repeated concatenation.++-- | List of elements of a structure.+toList :: Foldable t => t a -> [a]+{-# INLINE toList #-}+toList t = build (\ c n -> foldr c n t)++-- | The concatenation of all the elements of a container of lists.+concat :: Foldable t => t [a] -> [a]+concat = fold++-- | Map a function over all the elements of a container and concatenate+-- the resulting lists.+concatMap :: Foldable t => (a -> [b]) -> t a -> [b]+concatMap = foldMap++-- | 'and' returns the conjunction of a container of Bools. For the+-- result to be 'True', the container must be finite; 'False', however,+-- results from a 'False' value finitely far from the left end.+and :: Foldable t => t Bool -> Bool+and = getAll . foldMap All++-- | 'or' returns the disjunction of a container of Bools. For the+-- result to be 'False', the container must be finite; 'True', however,+-- results from a 'True' value finitely far from the left end.+or :: Foldable t => t Bool -> Bool+or = getAny . foldMap Any++-- | Determines whether any element of the structure satisfies the predicate.+any :: Foldable t => (a -> Bool) -> t a -> Bool+any p = getAny . foldMap (Any . p)++-- | Determines whether all elements of the structure satisfy the predicate.+all :: Foldable t => (a -> Bool) -> t a -> Bool+all p = getAll . foldMap (All . p)++-- | The 'sum' function computes the sum of the numbers of a structure.+sum :: (Foldable t, Num a) => t a -> a+sum = getSum . foldMap Sum++-- | The 'product' function computes the product of the numbers of a structure.+product :: (Foldable t, Num a) => t a -> a+product = getProduct . foldMap Product++-- | The largest element of a non-empty structure.+maximum :: (Foldable t, Ord a) => t a -> a+maximum = foldr1 max++-- | The largest element of a non-empty structure with respect to the+-- given comparison function.+maximumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+maximumBy cmp = foldr1 max'+ where max' x y = case cmp x y of+ GT -> x+ _ -> y++-- | The least element of a non-empty structure.+minimum :: (Foldable t, Ord a) => t a -> a+minimum = foldr1 min++-- | The least element of a non-empty structure with respect to the+-- given comparison function.+minimumBy :: Foldable t => (a -> a -> Ordering) -> t a -> a+minimumBy cmp = foldr1 min'+ where min' x y = case cmp x y of+ GT -> y+ _ -> x++-- | Does the element occur in the structure?+elem :: (Foldable t, Eq a) => a -> t a -> Bool+elem = any . (==)++-- | 'notElem' is the negation of 'elem'.+notElem :: (Foldable t, Eq a) => a -> t a -> Bool+notElem x = not . elem x++-- | The 'find' function takes a predicate and a structure and returns+-- the leftmost element of the structure matching the predicate, or+-- 'Nothing' if there is no such element.+find :: Foldable t => (a -> Bool) -> t a -> Maybe a+find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])+
+ tests/examples/Undefined4.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE Trustworthy #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Traversable+-- Copyright : Conor McBride and Ross Paterson 2005+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : libraries@haskell.org+-- Stability : experimental+-- Portability : portable+--+-- Class of data structures that can be traversed from left to right,+-- performing an action on each element.+--+-- See also+--+-- * \"Applicative Programming with Effects\",+-- by Conor McBride and Ross Paterson,+-- /Journal of Functional Programming/ 18:1 (2008) 1-13, online at+-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.+--+-- * \"The Essence of the Iterator Pattern\",+-- by Jeremy Gibbons and Bruno Oliveira,+-- in /Mathematically-Structured Functional Programming/, 2006, online at+-- <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.+--+-- * \"An Investigation of the Laws of Traversals\",+-- by Mauro Jaskelioff and Ondrej Rypacek,+-- in /Mathematically-Structured Functional Programming/, 2012, online at+-- <http://arxiv.org/pdf/1202.2919>.+--+-- Note that the functions 'mapM' and 'sequence' generalize "Prelude"+-- functions of the same names from lists to any 'Traversable' functor.+-- To avoid ambiguity, either import the "Prelude" hiding these names+-- or qualify uses of these function names with an alias for this module.+--+-----------------------------------------------------------------------------++module Data.Traversable (+ -- * The 'Traversable' class+ Traversable(..),+ -- * Utility functions+ for,+ forM,+ mapAccumL,+ mapAccumR,+ -- * General definitions for superclass methods+ fmapDefault,+ foldMapDefault,+ ) where++import Prelude hiding (mapM, sequence, foldr)+import qualified Prelude (mapM, foldr)+import Control.Applicative+import Data.Foldable (Foldable())+import Data.Monoid (Monoid)+import Data.Proxy++import GHC.Arr++-- | Functors representing data structures that can be traversed from+-- left to right.+--+-- Minimal complete definition: 'traverse' or 'sequenceA'.+--+-- A definition of 'traverse' must satisfy the following laws:+--+-- [/naturality/]+-- @t . 'traverse' f = 'traverse' (t . f)@+-- for every applicative transformation @t@+--+-- [/identity/]+-- @'traverse' Identity = Identity@+--+-- [/composition/]+-- @'traverse' (Compose . 'fmap' g . f) = Compose . 'fmap' ('traverse' g) . 'traverse' f@+--+-- A definition of 'sequenceA' must satisfy the following laws:+--+-- [/naturality/]+-- @t . 'sequenceA' = 'sequenceA' . 'fmap' t@+-- for every applicative transformation @t@+--+-- [/identity/]+-- @'sequenceA' . 'fmap' Identity = Identity@+--+-- [/composition/]+-- @'sequenceA' . 'fmap' Compose = Compose . 'fmap' 'sequenceA' . 'sequenceA'@+--+-- where an /applicative transformation/ is a function+--+-- @t :: (Applicative f, Applicative g) => f a -> g a@+--+-- preserving the 'Applicative' operations, i.e.+--+-- * @t ('pure' x) = 'pure' x@+--+-- * @t (x '<*>' y) = t x '<*>' t y@+--+-- and the identity functor @Identity@ and composition of functors @Compose@+-- are defined as+--+-- > newtype Identity a = Identity a+-- >+-- > instance Functor Identity where+-- > fmap f (Identity x) = Identity (f x)+-- >+-- > instance Applicative Indentity where+-- > pure x = Identity x+-- > Identity f <*> Identity x = Identity (f x)+-- >+-- > newtype Compose f g a = Compose (f (g a))+-- >+-- > instance (Functor f, Functor g) => Functor (Compose f g) where+-- > fmap f (Compose x) = Compose (fmap (fmap f) x)+-- >+-- > instance (Applicative f, Applicative g) => Applicative (Compose f g) where+-- > pure x = Compose (pure (pure x))+-- > Compose f <*> Compose x = Compose ((<*>) <$> f <*> x)+--+-- (The naturality law is implied by parametricity.)+--+-- Instances are similar to 'Functor', e.g. given a data type+--+-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)+--+-- a suitable instance would be+--+-- > instance Traversable Tree where+-- > traverse f Empty = pure Empty+-- > traverse f (Leaf x) = Leaf <$> f x+-- > traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r+--+-- This is suitable even for abstract types, as the laws for '<*>'+-- imply a form of associativity.+--+-- The superclass instances should satisfy the following:+--+-- * In the 'Functor' instance, 'fmap' should be equivalent to traversal+-- with the identity applicative functor ('fmapDefault').+--+-- * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be+-- equivalent to traversal with a constant applicative functor+-- ('foldMapDefault').+--+class (Functor t, Foldable t) => Traversable t where+ -- | Map each element of a structure to an action, evaluate+ -- these actions from left to right, and collect the results.+ traverse :: Applicative f => (a -> f b) -> t a -> f (t b)+ traverse f = sequenceA . fmap f++ -- | Evaluate each action in the structure from left to right,+ -- and collect the results.+ sequenceA :: Applicative f => t (f a) -> f (t a)+ sequenceA = traverse id++ -- | Map each element of a structure to a monadic action, evaluate+ -- these actions from left to right, and collect the results.+ mapM :: Monad m => (a -> m b) -> t a -> m (t b)+ mapM f = unwrapMonad . traverse (WrapMonad . f)++ -- | Evaluate each monadic action in the structure from left to right,+ -- and collect the results.+ sequence :: Monad m => t (m a) -> m (t a)+ sequence = mapM id+ {-# MINIMAL traverse | sequenceA #-}++-- instances for Prelude types++instance Traversable Maybe where+ traverse _ Nothing = pure Nothing+ traverse f (Just x) = Just <$> f x++instance Traversable [] where+ {-# INLINE traverse #-} -- so that traverse can fuse+ traverse f = Prelude.foldr cons_f (pure [])+ where cons_f x ys = (:) <$> f x <*> ys++ mapM = Prelude.mapM++instance Traversable (Either a) where+ traverse _ (Left x) = pure (Left x)+ traverse f (Right y) = Right <$> f y++instance Traversable ((,) a) where+ traverse f (x, y) = (,) x <$> f y++instance Ix i => Traversable (Array i) where+ traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)++instance Traversable Proxy where+ traverse _ _ = pure Proxy+ {-# INLINE traverse #-}+ sequenceA _ = pure Proxy+ {-# INLINE sequenceA #-}+ mapM _ _ = return Proxy+ {-# INLINE mapM #-}+ sequence _ = return Proxy+ {-# INLINE sequence #-}++instance Traversable (Const m) where+ traverse _ (Const m) = pure $ Const m++-- general functions++-- | 'for' is 'traverse' with its arguments flipped.+for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)+{-# INLINE for #-}+for = flip traverse++-- | 'forM' is 'mapM' with its arguments flipped.+forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)+{-# INLINE forM #-}+forM = flip mapM++-- left-to-right state transformer+newtype StateL s a = StateL { runStateL :: s -> (s, a) }++instance Functor (StateL s) where+ fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v)++instance Applicative (StateL s) where+ pure x = StateL (\ s -> (s, x))+ StateL kf <*> StateL kv = StateL $ \ s ->+ let (s', f) = kf s+ (s'', v) = kv s'+ in (s'', f v)++-- |The 'mapAccumL' function behaves like a combination of 'fmap'+-- and 'foldl'; it applies a function to each element of a structure,+-- passing an accumulating parameter from left to right, and returning+-- a final value of this accumulator together with the new structure.+mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s++-- right-to-left state transformer+newtype StateR s a = StateR { runStateR :: s -> (s, a) }++instance Functor (StateR s) where+ fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v)++instance Applicative (StateR s) where+ pure x = StateR (\ s -> (s, x))+ StateR kf <*> StateR kv = StateR $ \ s ->+ let (s', v) = kv s+ (s'', f) = kf s'+ in (s'', f v)++-- |The 'mapAccumR' function behaves like a combination of 'fmap'+-- and 'foldr'; it applies a function to each element of a structure,+-- passing an accumulating parameter from right to left, and returning+-- a final value of this accumulator together with the new structure.+mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)+mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s++-- | This function may be used as a value for `fmap` in a `Functor`+-- instance, provided that 'traverse' is defined. (Using+-- `fmapDefault` with a `Traversable` instance defined only by+-- 'sequenceA' will result in infinite recursion.)+fmapDefault :: Traversable t => (a -> b) -> t a -> t b+{-# INLINE fmapDefault #-}+fmapDefault f = getId . traverse (Id . f)++-- | This function may be used as a value for `Data.Foldable.foldMap`+-- in a `Foldable` instance.+foldMapDefault :: (Traversable t, Monoid m) => (a -> m) -> t a -> m+foldMapDefault f = getConst . traverse (Const . f)++-- local instances++newtype Id a = Id { getId :: a }++instance Functor Id where+ fmap f (Id x) = Id (f x)++instance Applicative Id where+ pure = Id+ Id f <*> Id x = Id (f x)+
+ tests/examples/Undefined5.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+module Algebra.Ring.Polynomial.Parser ( monomial, expression, variable, variableWithPower+ , number, integer, natural, parsePolyn) where+import Algebra.Ring.Polynomial.Monomorphic+import Control.Applicative hiding (many)+import qualified Data.Map as M+import Data.Ratio+import qualified Numeric.Algebra as NA+import Text.Peggy++[peggy|+expression :: Polynomial Rational+ = expr !.++letter :: Char+ = [a-zA-Z]++variable :: Variable+ = letter ('_' integer)? { Variable $1 (fromInteger <$> $2) }++variableWithPower :: (Variable, Integer)+ = variable "^" natural { ($1, $2) }+ / variable { ($1, 1) }++expr :: Polynomial Rational+ = expr "+" term { $1 + $2 }+ / expr "-" term { $1 - $2 }+ / term++term :: Polynomial Rational+ = number space* monoms { injectCoeff $1 * $3 }+ / number { injectCoeff $1 }+ / monoms++monoms :: Polynomial Rational+ = monoms space * fact { $1 * $3 }+ / fact++fact :: Polynomial Rational+ = fact "^" natural { $1 ^ $2 }+ / "(" expr ")"+ / monomial { toPolyn [($1, 1)] }++monomial :: Monomial+ = variableWithPower+ { M.fromListWith (+) $1 }++number :: Rational+ = integer "/" integer { $1 % $2 }+ / integer '.' [0-9]+ { realToFrac (read (show $1 ++ '.' : $2) :: Double) }+ / integer { fromInteger $1 }++integer :: Integer+ = "-" natural { negate $1 }+ / natural++natural :: Integer+ = [1-9] [0-9]* { read ($1 : $2) }++|]++toPolyn :: [(Monomial, Ratio Integer)] -> Polynomial (Ratio Integer)+toPolyn = normalize . Polynomial . M.fromList++parsePolyn :: String -> Either ParseError (Polynomial Rational)+parsePolyn = parseString expression "polynomial"
+ tests/examples/Undefined6.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, MultiParamTypeClasses+ , TypeFamilies #-}++module Vision.Image.Class (+ -- * Classes+ Pixel (..), MaskedImage (..), Image (..), ImageChannel, FromFunction (..)+ , FunctorImage (..)+ -- * Functions+ , (!), (!?), nChannels, pixel+ -- * Conversion+ , Convertible (..), convert+ ) where++import Data.Convertible (Convertible (..), convert)+import Data.Int+import Data.Vector.Storable (Vector, generate, unfoldr)+import Data.Word+import Foreign.Storable (Storable)+import Prelude hiding (map, read)++import Vision.Primitive (+ Z (..), (:.) (..), Point, Size+ , fromLinearIndex, toLinearIndex, shapeLength+ )++-- Classes ---------------------------------------------------------------------++-- | Determines the number of channels and the type of each pixel of the image+-- and how images are represented.+class Pixel p where+ type PixelChannel p++ -- | Returns the number of channels of the pixel.+ --+ -- Must not consume 'p' (could be 'undefined').+ pixNChannels :: p -> Int++ pixIndex :: p -> Int -> PixelChannel p++instance Pixel Int16 where+ type PixelChannel Int16 = Int16+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Int32 where+ type PixelChannel Int32 = Int32+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Int where+ type PixelChannel Int = Int+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word8 where+ type PixelChannel Word8 = Word8+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word16 where+ type PixelChannel Word16 = Word16+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word32 where+ type PixelChannel Word32 = Word32+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Word where+ type PixelChannel Word = Word+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Float where+ type PixelChannel Float = Float+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Double where+ type PixelChannel Double = Double+ pixNChannels _ = 1+ pixIndex p _ = p++instance Pixel Bool where+ type PixelChannel Bool = Bool+ pixNChannels _ = 1+ pixIndex p _ = p++-- | Provides an abstraction for images which are not defined for each of their+-- pixels. The interface is similar to 'Image' except that indexing functions+-- don't always return.+--+-- Image origin (@'ix2' 0 0@) is located in the upper left corner.+class Storable (ImagePixel i) => MaskedImage i where+ type ImagePixel i++ shape :: i -> Size++ -- | Returns the pixel\'s value at 'Z :. y, :. x'.+ maskedIndex :: i -> Point -> Maybe (ImagePixel i)+ maskedIndex img = (img `maskedLinearIndex`) . toLinearIndex (shape img)+ {-# INLINE maskedIndex #-}++ -- | Returns the pixel\'s value as if the image was a single dimension+ -- vector (row-major representation).+ maskedLinearIndex :: i -> Int -> Maybe (ImagePixel i)+ maskedLinearIndex img = (img `maskedIndex`) . fromLinearIndex (shape img)+ {-# INLINE maskedLinearIndex #-}++ -- | Returns the non-masked values of the image.+ values :: i -> Vector (ImagePixel i)+ values !img =+ unfoldr step 0+ where+ !n = shapeLength (shape img)++ step !i | i >= n = Nothing+ | Just p <- img `maskedLinearIndex` i = Just (p, i + 1)+ | otherwise = step (i + 1)+ {-# INLINE values #-}++ {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}++type ImageChannel i = PixelChannel (ImagePixel i)++-- | Provides an abstraction over the internal representation of an image.+--+-- Image origin is located in the lower left corner.+class MaskedImage i => Image i where+ -- | Returns the pixel value at 'Z :. y :. x'.+ index :: i -> Point -> ImagePixel i+ index img = (img `linearIndex`) . toLinearIndex (shape img)+ {-# INLINE index #-}++ -- | Returns the pixel value as if the image was a single dimension vector+ -- (row-major representation).+ linearIndex :: i -> Int -> ImagePixel i+ linearIndex img = (img `index`) . fromLinearIndex (shape img)+ {-# INLINE linearIndex #-}++ -- | Returns every pixel values as if the image was a single dimension+ -- vector (row-major representation).+ vector :: i -> Vector (ImagePixel i)+ vector img = generate (shapeLength $ shape img) (img `linearIndex`)+ {-# INLINE vector #-}++ {-# MINIMAL index | linearIndex #-}++-- | Provides ways to construct an image from a function.+class FromFunction i where+ type FromFunctionPixel i++ -- | Generates an image by calling the given function for each pixel of the+ -- constructed image.+ fromFunction :: Size -> (Point -> FromFunctionPixel i) -> i++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The first function is called for each line, generating a line invariant+ -- value.+ --+ -- This function is faster for some image representations as some recurring+ -- computation can be cached.+ fromFunctionLine :: Size -> (Int -> a)+ -> (a -> Point -> FromFunctionPixel i) -> i+ fromFunctionLine size line f =+ fromFunction size (\pt@(Z :. y :. _) -> f (line y) pt)+ {-# INLINE fromFunctionLine #-}++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The first function is called for each column, generating a column+ -- invariant value.+ --+ -- This function *can* be faster for some image representations as some+ -- recurring computations can be cached. However, it may requires a vector+ -- allocation for these values. If the column invariant is cheap to+ -- compute, prefer 'fromFunction'.+ fromFunctionCol :: Storable b => Size -> (Int -> b)+ -> (b -> Point -> FromFunctionPixel i) -> i+ fromFunctionCol size col f =+ fromFunction size (\pt@(Z :. _ :. x) -> f (col x) pt)+ {-# INLINE fromFunctionCol #-}++ -- | Generates an image by calling the last function for each pixel of the+ -- constructed image.+ --+ -- The two first functions are called for each line and for each column,+ -- respectively, generating common line and column invariant values.+ --+ -- This function is faster for some image representations as some recurring+ -- computation can be cached. However, it may requires a vector+ -- allocation for column values. If the column invariant is cheap to+ -- compute, prefer 'fromFunctionLine'.+ fromFunctionCached :: Storable b => Size+ -> (Int -> a) -- ^ Line function+ -> (Int -> b) -- ^ Column function+ -> (a -> b -> Point+ -> FromFunctionPixel i) -- ^ Pixel function+ -> i+ fromFunctionCached size line col f =+ fromFunction size (\pt@(Z :. y :. x) -> f (line y) (col x) pt)+ {-# INLINE fromFunctionCached #-}++ {-# MINIMAL fromFunction #-}++-- | Defines a class for images on which a function can be applied. The class is+-- different from 'Functor' as there could be some constraints and+-- transformations the pixel and image types.+class (MaskedImage src, MaskedImage res) => FunctorImage src res where+ map :: (ImagePixel src -> ImagePixel res) -> src -> res++-- Functions -------------------------------------------------------------------++-- | Alias of 'maskedIndex'.+(!?) :: MaskedImage i => i -> Point -> Maybe (ImagePixel i)+(!?) = maskedIndex+{-# INLINE (!?) #-}++-- | Alias of 'index'.+(!) :: Image i => i -> Point -> ImagePixel i+(!) = index+{-# INLINE (!) #-}++-- | Returns the number of channels of an image.+nChannels :: (Pixel (ImagePixel i), MaskedImage i) => i -> Int+nChannels img = pixNChannels (pixel img)+{-# INLINE nChannels #-}++-- | Returns an 'undefined' instance of a pixel of the image. This is sometime+-- useful to satisfy the type checker as in a call to 'pixNChannels' :+--+-- > nChannels img = pixNChannels (pixel img)+pixel :: MaskedImage i => i -> ImagePixel i+pixel _ = undefined
+ tests/examples/Undefined7.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, StandaloneDeriving, DeriveDataTypeable #-}++module Test where++import Control.Applicative+import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.Map as M+import Data.Generics++import Data.Binary.ISO8583+import Data.Binary.ISO8583.TH++[binary|+ Message+ 2 pan embedded 2+ 4 amount int 12+ 11 stan int 6+ 43 termAddress TermAddress 222+|]++deriving instance Eq Message+deriving instance Show Message++data TermAddress = TermAddress {+ tOwner :: B.ByteString,+ tCity :: B.ByteString,+ tOther :: L.ByteString }+ deriving (Eq, Show, Typeable)++instance Binary TermAddress where+ -- NB: this implementation is smth odd and usable only for this testcase.+ get =+ TermAddress+ <$> B.filter (/= 0x20) `fmap` getByteString 30+ <*> B.filter (/= 0x20) `fmap` getByteString 30+ <*> L.filter (/= 0x20) `fmap` getRemainingLazyByteString++ put (TermAddress owner city other) = do+ putByteStringPad 30 owner+ putByteStringPad 30 city+ putLazyByteStringPad 162 other++instance Binary Message where+ get = do+ m <- getBitmap getMessage+ return $ constructMessage m++ put msg = do+ putBitmap' (putMessage msg)++testMsg :: Message+testMsg = Message {+ pan = Just $ toBS "12345678",+ amount = Just $ 100500,+ stan = Just $ 123456,+ termAddress = Just $ TermAddress {+ tOwner = toBS "TestBank",+ tCity = toBS "Magnitogorsk",+ tOther = L.empty }+}++test :: IO ()+test = do+ let bstr = encode testMsg+ msg = decode bstr+ if msg /= testMsg+ then fail $ "Encode/decode mismatch:\n" +++ show testMsg ++ "\n /= \n" +++ show msg+ else putStrLn "passed."+
+ tests/examples/Undefined8.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies, PackageImports #-}++module Text.Markdown.Pap.Parser (+ parseMrd+) where++import Control.Arrow+import "monads-tf" Control.Monad.State+import "monads-tf" Control.Monad.Error+import Data.Maybe+import Data.Char+import Text.Papillon++import Text.Markdown.Pap.Text++parseMrd :: String -> Maybe [Text]+parseMrd src = case flip runState (0, [- 1]) $ runErrorT $ markdown $ parse src of+ (Right (r, _), _) -> Just r+ _ -> Nothing++clear :: State (Int, [Int]) Bool+clear = put (0, [- 1]) >> return True++reset :: State (Int, [Int]) Bool+reset = modify (first $ const 0) >> return True++count :: State (Int, [Int]) ()+count = modify $ first (+ 1)++deeper :: State (Int, [Int]) Bool+deeper = do+ (n, n0 : ns) <- get+ if n > n0 then put (n, n : n0 : ns) >> return True else return False++same :: State (Int, [Int]) Bool+same = do+ (n, n0 : _) <- get+ return $ n == n0++shallow :: State (Int, [Int]) Bool+shallow = do+ (n, n0 : ns) <- get+ if n < n0 then put (n, ns) >> return True else return False++[papillon|++monad: State (Int, [Int])++markdown :: [Text]+ = md:(m:markdown1 _:dmmy[clear] { return m })* { return md }++markdown1 :: Text+ = h:header { return h }+ / l:link '\n'* { return l }+ / i:image '\n'* { return i }+ / l:list '\n'* { return $ List l }+ / c:code { return $ Code c }+ / p:paras { return $ Paras p }++header :: Text+ = n:sharps _:<isSpace>* l:line '\n'+ { return $ Header n l }+ / l:line '\n' _:equals '\n'+ { return $ Header 1 l }+ / l:line '\n' _:hyphens '\n'+ { return $ Header 2 l }++sharps :: Int+ = '#' n:sharps { return $ n + 1 }+ / '#' { return 1 }++equals :: ()+ = '=' _:equals+ / '='++hyphens :: ()+ = '-' _:hyphens+ / '-'++line :: String+ = l:<(`notElem` "#\n")>+ { return l }++line' :: String+ = l:<(`notElem` "\n")>+ { return l }++code :: String+ = l:fourSpacesLine c:code { return $ l ++ c }+ / l:fourSpacesLine { return l }++fourSpacesLine :: String+ = _:fourSpaces l:line' ns:('\n' { return '\n' })+ { return $ l ++ ns }++fourSpaces :: ()+ = ' ' ' ' ' ' ' '++list :: List = _:cnt _:dmmy[deeper] l:list1 ls:list1'* _:shllw { return $ l : ls }++cnt :: () = _:dmmy[reset] _:(' ' { count })*++list1' :: List1+ = _:cnt _:dmmy[same] l:list1 { return l }++list1 :: List1+ = _:listHead ' ' l:line '\n' ls:list?+ { return $ BulItem l $ fromMaybe [] ls }+ / _:nListHead ' ' l:line '\n' ls:list?+ { return $ OrdItem l $ fromMaybe [] ls }++listHead :: ()+ = '*' / '-' / '+'++nListHead :: ()+ = _:<isDigit>+ '.'++paras :: [String]+ = ps:para+ { return ps }++para :: String+ = ls:(!_:('!') !_:listHead !_:nListHead !_:header !_:fourSpaces l:line '\n' { return l })+ _:('\n' / !_ / !_:para)+ { return $ unwords ls }++shllw :: ()+ = _:dmmy[shallow]+ / !_+ / !_:list++dmmy :: () =++link :: Text+ = '[' t:<(/= ']')>+ ']' ' '* '(' a:<(/= ')')>+ ')' { return $ Link t a "" }++image :: Text+ = '!' '[' alt:<(/= ']')>+ ']' ' '* '(' addrs:<(`notElem` ")\" ")>+ ' '*+ '"' t:<(/= '"')>+ '"' ')'+ { return $ Image alt addrs t }++|]
+ tests/examples/Undefined9.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE QuasiQuotes, TypeFamilies #-}++module Image.PNG (isPNG, pngSize) where++import Data.Maybe+import File.Binary.PNG+import File.Binary+import File.Binary.Instances+import File.Binary.Instances.BigEndian++isPNG :: String -> Bool+isPNG img = isJust (fromBinary () img :: Maybe (PNGHeader, String))++pngSize :: String -> Maybe (Double, Double)+pngSize src = case getChunks src of+ Right cs -> Just+ (fromIntegral $ width $ ihdr cs, fromIntegral $ height $ ihdr cs)+ _ -> Nothing++[binary|++PNGHeader deriving Show++1: 0x89+3: "PNG"+2: "\r\n"+1: "\SUB"+1: "\n"++|]
+ tests/examples/Unicode.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE UnicodeSyntax #-}++module Unicode where++import Control.Monad.Trans.State.Strict++-- | We'll start off with a monad in which to manipulate ABTs; we'll need some+-- state for fresh variable generation.+--+newtype M α+ = M+ { _M ∷ State Int α+ }++-- | We'll run an ABT computation by starting the variable counter at @0@.+--+runM ∷ M α → α+runM (M m) = evalState m 0+++-- | To indicate that a term is in normal form.+--+stepsExhausted+ ∷ Applicative m+ ⇒ StepT m α+stepsExhausted = StepT . MaybeT $ pure Nothing++stepsExhausted2+ ∷ Applicative m+ => m α+stepsExhausted2 = undefined
+ tests/examples/UnicodeRules.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE+ BangPatterns+ , FlexibleContexts+ , FlexibleInstances+ , ScopedTypeVariables+ , UnboxedTuples+ , UndecidableInstances+ , UnicodeSyntax+ #-}++strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool+{-# RULES "head → strictHead" [1]+ ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d).+ head v = strictHead v #-}+{-# INLINE strictHead #-}+strictHead (Bitstream _ v) = head (SV.head v)
+ tests/examples/UnicodeSyntax.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE Arrows #-}++module Tutorial where++-- import Abt.Class+-- import Abt.Types+-- import Abt.Concrete.LocallyNameless++import Control.Applicative+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Except+-- import Data.Vinyl+import Prelude hiding (pi)++-- | We'll start off with a monad in which to manipulate ABTs; we'll need some+-- state for fresh variable generation.+--+newtype M α+ = M+ { _M ∷ State Int α+ } deriving (Functor, Applicative, Monad)++-- | We'll run an ABT computation by starting the variable counter at @0@.+--+runM ∷ M α → α+runM (M m) = evalState m 0++-- | Check out the source to see fresh variable generation.+--+instance MonadVar Var M where+ fresh = M $ do+ n ← get+ let n' = n + 1+ put n'+ return $ Var Nothing n'++ named a = do+ v ← fresh+ return $ v { _varName = Just a }++-- | Next, we'll define the operators for a tiny lambda calculus as a datatype+-- indexed by arities.+--+data Lang ns where+ LAM ∷ Lang '[S Z]+ APP ∷ Lang '[Z, Z]+ PI ∷ Lang '[Z, S Z]+ UNIT ∷ Lang '[]+ AX ∷ Lang '[]++instance Show1 Lang where+ show1 = \case+ LAM → "lam"+ APP → "ap"+ PI → "pi"+ UNIT → "unit"+ AX → "<>"++instance HEq1 Lang where+ heq1 LAM LAM = Just Refl+ heq1 APP APP = Just Refl+ heq1 PI PI = Just Refl+ heq1 UNIT UNIT = Just Refl+ heq1 AX AX = Just Refl+ heq1 _ _ = Nothing++lam ∷ Tm Lang (S Z) → Tm0 Lang+lam e = LAM $$ e :& RNil++app ∷ Tm0 Lang → Tm0 Lang → Tm0 Lang+app m n = APP $$ m :& n :& RNil++ax ∷ Tm0 Lang+ax = AX $$ RNil++unit ∷ Tm0 Lang+unit = UNIT $$ RNil++pi ∷ Tm0 Lang → Tm Lang (S Z) → Tm0 Lang+pi α xβ = PI $$ α :& xβ :& RNil++-- | A monad transformer for small step operational semantics.+--+newtype StepT m α+ = StepT+ { runStepT ∷ MaybeT m α+ } deriving (Monad, Functor, Applicative, Alternative)++-- | To indicate that a term is in normal form.+--+stepsExhausted+ ∷ Applicative m+ ⇒ StepT m α+stepsExhausted = StepT . MaybeT $ pure Nothing++instance MonadVar Var m ⇒ MonadVar Var (StepT m) where+ fresh = StepT . MaybeT $ Just <$> fresh+ named str = StepT . MaybeT $ Just <$> named str++-- | A single evaluation step.+--+step+ ∷ Tm0 Lang+ → StepT M (Tm0 Lang)+step tm =+ out tm >>= \case+ APP :$ m :& n :& RNil →+ out m >>= \case+ LAM :$ xe :& RNil → xe // n+ _ → app <$> step m <*> pure n <|> app <$> pure m <*> step n+ PI :$ α :& xβ :& RNil → pi <$> step α <*> pure xβ+ _ → stepsExhausted++-- | The reflexive-transitive closure of a small-step operational semantics.+--+star+ ∷ Monad m+ ⇒ (α → StepT m α)+ → (α → m α)+star f a =+ runMaybeT (runStepT $ f a) >>=+ return a `maybe` star f++-- | Evaluate a term to normal form+--+eval ∷ Tm0 Lang → Tm0 Lang+eval = runM . star step++newtype JudgeT m α+ = JudgeT+ { runJudgeT ∷ ExceptT String m α+ } deriving (Monad, Functor, Applicative, Alternative)++instance MonadVar Var m ⇒ MonadVar Var (JudgeT m) where+ fresh = JudgeT . ExceptT $ Right <$> fresh+ named str = JudgeT . ExceptT $ Right <$> named str++type Ctx = [(Var, Tm0 Lang)]++raise ∷ Monad m ⇒ String → JudgeT m α+raise = JudgeT . ExceptT . return . Left++checkTy+ ∷ Ctx+ → Tm0 Lang+ → Tm0 Lang+ → JudgeT M ()+checkTy g tm ty = do+ let ntm = eval tm+ nty = eval ty+ (,) <$> out ntm <*> out nty >>= \case+ (LAM :$ xe :& RNil, PI :$ α :& yβ :& RNil) → do+ z ← fresh+ ez ← xe // var z+ βz ← yβ // var z+ checkTy ((z,α):g) ez βz+ (AX :$ RNil, UNIT :$ RNil) → return ()+ _ → do+ ty' ← inferTy g tm+ if ty' === nty+ then return ()+ else raise "Type error"++inferTy+ ∷ Ctx+ → Tm0 Lang+ → JudgeT M (Tm0 Lang)+inferTy g tm = do+ out (eval tm) >>= \case+ V v | Just (eval → ty) ← lookup v g → return ty+ | otherwise → raise "Ill-scoped variable"+ APP :$ m :& n :& RNil → do+ inferTy g m >>= out >>= \case+ PI :$ α :& xβ :& RNil → do+ checkTy g n α+ eval <$> xβ // n+ _ → raise "Expected pi type for lambda abstraction"+ _ → raise "Only infer neutral terms"++-- | @λx.x@+--+identityTm ∷ M (Tm0 Lang)+identityTm = do+ x ← fresh+ return $ lam (x \\ var x)++-- | @(λx.x)(λx.x)@+--+appTm ∷ M (Tm0 Lang)+appTm = do+ tm ← identityTm+ return $ app tm tm++-- | A demonstration of evaluating (and pretty-printing). Output:+--+-- @+-- ap[lam[\@2.\@2];lam[\@3.\@3]] ~>* lam[\@4.\@4]+-- @+--+main ∷ IO ()+main = do+ -- Try out the type checker+ either fail print . runM . runExceptT . runJudgeT $ do+ x ← fresh+ checkTy [] (lam (x \\ var x)) (pi unit (x \\ unit))++ print . runM $ do+ mm ← appTm+ mmStr ← toString mm+ mmStr' ← toString $ eval mm+ return $ mmStr ++ " ~>* " ++ mmStr'++doMap ∷ FilePath → IOSArrow XmlTree TiledMap+doMap mapPath = proc m → do+ mapWidth ← getAttrR "width" ⤙ m+ returnA -< baz++-- ^ An opaque ESD handle for recording data from the soundcard via ESD.+data Recorder fr ch (r ∷ ★ → ★)+ = Recorder {+ reRate ∷ !Int+ , reHandle ∷ !Handle+ , reCloseH ∷ !(FinalizerHandle r)+ }+
+ tests/examples/UnicodeSyntaxFailure.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE UnicodeSyntax #-}++foo x = addToEnv (∀)
tests/examples/Utils2.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} module Utils2 where@@ -13,7 +12,7 @@ import Data.Monoid -- import Language.Haskell.GHC.ExactPrint.Utils-import Language.Haskell.GHC.ExactPrint.Types+import Language.Haskell.GHC.ExactPrint.Types hiding (showGhc) import qualified Bag as GHC import qualified BasicTypes as GHC
+ tests/examples/WhereIn3.hs view
@@ -0,0 +1,19 @@+module WhereIn3 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 are multi matches), the parameters are not folded after demoting.++sumSquares x y = sq p x + sq p y+ where p=2 {-There is a comment-}++sq :: Int -> Int -> Int+sq pow 0 = 0 --prior comment+sq pow {- blah -} z = z^pow --there is a comment++-- A leading comment+anotherFun 0 y = sq y+ where sq x = x^2
+ tests/examples/WhereIn3.hs.expected view
@@ -0,0 +1,16 @@+module WhereIn3 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 are multi matches), the parameters are not folded after demoting.++sumSquares x y = sq p x + sq p y+ where p=2 {-There is a comment-}++sq :: Int -> Int -> Int++anotherFun 0 y = sq y+ where sq x = x^2
+ tests/examples/WhereIn3a.hs view
@@ -0,0 +1,19 @@+module WhereIn3a 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 are multi matches), the parameters are not folded after demoting.++sumSquares x y = sq p x + sq p y+ where p=2 {-There is a comment-}++sq :: Int -> Int -> Int+sq pow 0 = 0 -- prior comment+sq pow z = z^pow --there is a comment++-- A leading comment+anotherFun 0 y = sq y+ where sq x = x^2
+ tests/examples/WhereIn3a.hs.expected view
@@ -0,0 +1,25 @@+module WhereIn3a where++-- A leading comment+anotherFun 0 y = sq y+ where sq x = x^2+sq pow 0 = 0 -- prior comment+sq pow z = z^pow --there is a comment++--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 are multi matches), the parameters are not folded after demoting.++sumSquares x y = sq p x + sq p y+ where p=2 {-There is a comment-}++sq :: Int -> Int -> Int+sq pow 0 = 0 -- prior comment+sq pow z = z^pow --there is a comment++-- A leading comment+anotherFun 0 y = sq y+ where sq x = x^2