summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ChangeLog18
-rw-r--r--ghc-exactprint.cabal95
-rw-r--r--src/Language/Haskell/GHC/ExactPrint.hs17
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Annotate.hs1107
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Delta.hs591
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs19
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Lookup.hs205
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Parsers.hs192
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Preprocess.hs258
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Print.hs375
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Transform.hs736
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Types.hs203
-rw-r--r--src/Language/Haskell/GHC/ExactPrint/Utils.hs185
-rw-r--r--tests/Roundtrip.hs137
-rw-r--r--tests/Static.hs91
-rw-r--r--tests/Test.hs913
-rw-r--r--tests/Test/Common.hs188
-rw-r--r--tests/Test/Consistency.hs27
-rw-r--r--tests/Test/Transform.hs683
-rw-r--r--tests/examples/AddDecl.hs9
-rw-r--r--tests/examples/AddDecl.hs.expected11
-rw-r--r--tests/examples/AddLocalDecl1.hs9
-rw-r--r--tests/examples/AddLocalDecl1.hs.expected11
-rw-r--r--tests/examples/AddLocalDecl2.hs10
-rw-r--r--tests/examples/AddLocalDecl2.hs.expected11
-rw-r--r--tests/examples/AddLocalDecl3.hs10
-rw-r--r--tests/examples/AddLocalDecl3.hs.expected11
-rw-r--r--tests/examples/AnnPackageName.hs4
-rw-r--r--tests/examples/AssociatedType.hs5
-rw-r--r--tests/examples/Backquote.hs11
-rw-r--r--tests/examples/BracesSemiDataDecl.hs7
-rw-r--r--tests/examples/C.hs12
-rw-r--r--tests/examples/C.hs.expected12
-rw-r--r--tests/examples/CExpected.hs12
-rw-r--r--tests/examples/Commands.hs257
-rw-r--r--tests/examples/Control.hs210
-rw-r--r--tests/examples/CorePragma.hs6
-rw-r--r--tests/examples/Cpp.hs8
-rw-r--r--tests/examples/Dead1.hs2
-rw-r--r--tests/examples/DefaultTypeInstance.hs6
-rw-r--r--tests/examples/Deprecation.hs4
-rw-r--r--tests/examples/DoParens.hs4
-rw-r--r--tests/examples/DoPatBind.hs4
-rw-r--r--tests/examples/DoubleForall.hs9
-rw-r--r--tests/examples/DroppedComma.hs5
-rw-r--r--tests/examples/DroppedDoSpace.hs26
-rw-r--r--tests/examples/DroppedDoSpace2.hs6
-rw-r--r--tests/examples/ExplicitNamespaces.hs9
-rw-r--r--tests/examples/Foo.hs7
-rw-r--r--tests/examples/ForeignDecl.hs22
-rw-r--r--tests/examples/GADTContext.hs13
-rw-r--r--tests/examples/GADTRecords.hs20
-rw-r--r--tests/examples/GADTRecords2.hs7
-rw-r--r--tests/examples/GHCOrig.hs211
-rw-r--r--tests/examples/Hang.hs1
-rw-r--r--tests/examples/HangingRecord.hs5
-rw-r--r--tests/examples/HashQQ.hs44
-rw-r--r--tests/examples/ImplicitSemi.hs4
-rw-r--r--tests/examples/ImplicitTypeSyn.hs17
-rw-r--r--tests/examples/Imports.hs9
-rw-r--r--tests/examples/IndentedDo.hs12
-rw-r--r--tests/examples/InfixOperator.hs26
-rw-r--r--tests/examples/InfixPatternSynonyms.hs18
-rw-r--r--tests/examples/InlineSemi.hs1
-rw-r--r--tests/examples/Internals.hs427
-rw-r--r--tests/examples/Jon.hs4
-rw-r--r--tests/examples/LambdaCase.hs10
-rw-r--r--tests/examples/LetIn1.hs19
-rw-r--r--tests/examples/LetIn1.hs.expected18
-rw-r--r--tests/examples/LiftedConstructors.hs25
-rw-r--r--tests/examples/LiftedInfixConstructor.hs12
-rw-r--r--tests/examples/LinePragma.hs36
-rw-r--r--tests/examples/ListComprehensions.hs23
-rw-r--r--tests/examples/LocalDecls.hs8
-rw-r--r--tests/examples/LocalDecls.hs.expected11
-rw-r--r--tests/examples/LocalDecls2.hs3
-rw-r--r--tests/examples/LocalDecls2.hs.expected6
-rw-r--r--tests/examples/LocalDecls2Expected.hs6
-rw-r--r--tests/examples/MagicHash.hs29
-rw-r--r--tests/examples/MangledSemiLet.hs10
-rw-r--r--tests/examples/Minimal.hs37
-rw-r--r--tests/examples/MultiImplicitParams.hs7
-rw-r--r--tests/examples/MultiLineCommentWithPragmas.hs18
-rw-r--r--tests/examples/MultiLineWarningPragma.hs18
-rw-r--r--tests/examples/MultiWayIf.hs11
-rw-r--r--tests/examples/MultipleInferredContexts.hs4
-rw-r--r--tests/examples/NestedDoLambda.hs31
-rw-r--r--tests/examples/NestedLambda.hs8
-rw-r--r--tests/examples/Obscure.hs29
-rw-r--r--tests/examples/OptSig.hs18
-rw-r--r--tests/examples/OptSig2.hs5
-rw-r--r--tests/examples/OveridingPrimitives.hs6
-rw-r--r--tests/examples/PatSigBind.hs15
-rw-r--r--tests/examples/PatternGuards.hs7
-rw-r--r--tests/examples/ProcNotation.hs12
-rw-r--r--tests/examples/Pseudonym.hs41
-rw-r--r--tests/examples/PuncFunctions.hs25
-rw-r--r--tests/examples/QuasiQuote.hs12
-rw-r--r--tests/examples/RSA.hs19
-rw-r--r--tests/examples/RdrNames.hs12
-rw-r--r--tests/examples/RecordSemi.hs15
-rw-r--r--tests/examples/RecordWildcard.hs8
-rw-r--r--tests/examples/RecursiveDo.hs3
-rw-r--r--tests/examples/Remorse.hs88
-rw-r--r--tests/examples/RmDecl1.hs12
-rw-r--r--tests/examples/RmDecl1.hs.expected8
-rw-r--r--tests/examples/RmDecl2.hs10
-rw-r--r--tests/examples/RmDecl2.hs.expected9
-rw-r--r--tests/examples/RmTypeSig1.hs7
-rw-r--r--tests/examples/RmTypeSig1.hs.expected7
-rw-r--r--tests/examples/Rules.hs1
-rw-r--r--tests/examples/RulesSemi.hs9
-rw-r--r--tests/examples/SemiInstance.hs11
-rw-r--r--tests/examples/SemiWorkout.hs60
-rw-r--r--tests/examples/Shebang.hs5
-rw-r--r--tests/examples/ShiftingLambda.hs22
-rw-r--r--tests/examples/Simple.hs4
-rw-r--r--tests/examples/SimpleComplexTuple.hs3
-rw-r--r--tests/examples/SlidingDataClassDecl.hs14
-rw-r--r--tests/examples/SlidingDoClause.hs13
-rw-r--r--tests/examples/SlidingLambda.hs3
-rw-r--r--tests/examples/SlidingListComp.hs8
-rw-r--r--tests/examples/SlidingRecordSetter.hs4
-rw-r--r--tests/examples/SlidingTypeSyn.hs14
-rw-r--r--tests/examples/SpacesSplice.hs3
-rw-r--r--tests/examples/SpliceSemi.hs4
-rw-r--r--tests/examples/StrangeTypeClass.hs18
-rw-r--r--tests/examples/StringGap.hs8
-rw-r--r--tests/examples/T10196.hs13
-rw-r--r--tests/examples/T5951.hs11
-rw-r--r--tests/examples/THMonadInstance.hs22
-rw-r--r--tests/examples/TemplateHaskell.hs40
-rw-r--r--tests/examples/TooManyAnnVal.hs518
-rw-r--r--tests/examples/TransformListComp.hs7
-rw-r--r--tests/examples/TupleSections.hs21
-rw-r--r--tests/examples/TypeBrackets.hs11
-rw-r--r--tests/examples/TypeBrackets2.hs23
-rw-r--r--tests/examples/TypeBrackets3.hs15
-rw-r--r--tests/examples/TypeBrackets4.hs8
-rw-r--r--tests/examples/TypeFamilies.hs14
-rw-r--r--tests/examples/TypeFamilies2.hs10
-rw-r--r--tests/examples/TypeInstance.hs11
-rw-r--r--tests/examples/TypeSignatureParens.hs7
-rw-r--r--tests/examples/TypeSynOperator.hs3
-rw-r--r--tests/examples/TypeSynParens.hs19
-rw-r--r--tests/examples/Undefined10.hs643
-rw-r--r--tests/examples/Undefined11.hs423
-rw-r--r--tests/examples/Undefined13.hs130
-rw-r--r--tests/examples/Undefined2.hs56
-rw-r--r--tests/examples/Undefined3.hs340
-rw-r--r--tests/examples/Undefined4.hs280
-rw-r--r--tests/examples/Undefined5.hs66
-rw-r--r--tests/examples/Undefined6.hs238
-rw-r--r--tests/examples/Undefined7.hs76
-rw-r--r--tests/examples/Undefined8.hs134
-rw-r--r--tests/examples/Undefined9.hs30
-rw-r--r--tests/examples/Unicode.hs31
-rw-r--r--tests/examples/UnicodeRules.hs16
-rw-r--r--tests/examples/UnicodeSyntax.hs236
-rw-r--r--tests/examples/UnicodeSyntaxFailure.hs3
-rw-r--r--tests/examples/Utils2.hs3
-rw-r--r--tests/examples/WhereIn3.hs19
-rw-r--r--tests/examples/WhereIn3.hs.expected16
-rw-r--r--tests/examples/WhereIn3a.hs19
-rw-r--r--tests/examples/WhereIn3a.hs.expected25
165 files changed, 10568 insertions, 1480 deletions
diff --git a/ChangeLog b/ChangeLog
index faa5efa..9c749d9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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.
diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal
index 63b4221..11a7116 100644
--- a/ghc-exactprint.cabal
+++ b/ghc-exactprint.cabal
@@ -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.
+ .
+ It does this with a phased approach
+ .
+ * Delta - converts GHC API Annotations into relative
+ offsets, indexed by SrcSpan
.
- * any currently excludes anything using CPP or lhs.
+ * Transform - functions to facilitate changes to
+ the AST, adjusting the annotations generated in the
+ Delta phase to suit the changes.
.
- The dependency footprint is deliberately kept small so that
- it can easily be tested against GHC HEAD
+ * Print - converts an AST and its annotations to
+ properly formatted source text.
.
- Note: requires GHC 7.10 RC2 or later
+ .
+ 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 @@ source-repository head
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 @@ Test-Suite test
, 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
diff --git a/src/Language/Haskell/GHC/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint.hs
index e699428..5dbc67a 100644
--- a/src/Language/Haskell/GHC/ExactPrint.hs
+++ b/src/Language/Haskell/GHC/ExactPrint.hs
@@ -1,7 +1,20 @@
+{-# 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
@@ -9,6 +22,8 @@ module Language.Haskell.GHC.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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
index 26543d0..152abc6 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
@@ -5,21 +6,36 @@
{-# 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
(
- markLocated
+ annotate
, 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 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 (rdrName2String, showGhc, isListComp, debug)
+import Language.Haskell.GHC.ExactPrint.Utils
import qualified Bag as GHC
import qualified BasicTypes as GHC
@@ -29,39 +45,86 @@ 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 qualified SrcLoc 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
- 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
+ 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
-type Annotated = Free AnnotationF
-- ---------------------------------------------------------------------
-makeFreeCon 'OutputKD
makeFreeCon 'MarkEOF
makeFreeCon 'MarkPrim
makeFreeCon 'MarkOutside
@@ -69,9 +132,41 @@ makeFreeCon 'MarkInside
makeFreeCon 'MarkExternal
makeFreeCon 'MarkMany
makeFreeCon 'MarkOffsetPrim
-makeFreeCon 'MarkAfter
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
@@ -87,56 +182,59 @@ 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
+markLocated a = withLocated a 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)
+withLocated a@(GHC.L l ast) action =
+ withAST a (action l ast)
-markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated ()
-markMaybe Nothing = return ()
-markMaybe (Just ast) = markLocated 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)
+
+-- ---------------------------------------------------------------------
-markList :: (Annotate ast) => [GHC.Located ast] -> Annotated ()
-markList xs = mapM_ markLocated xs
+-- |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)
--- | 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)
+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.L l _) -> (l,markLocated b)) ls
+prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls
applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated ()
-applyListAnnotations ls
- = mapM_ snd $ sortBy (\(a,_) (b,_) -> compare a b) ls
+applyListAnnotations ls = withSortKey ls
+
+#if __GLASGOW_HASKELL__ <= 710
+lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a]
+lexicalSortLocated = sortBy (comparing GHC.getLoc)
+#endif
-- ---------------------------------------------------------------------
@@ -148,7 +246,6 @@ class Data ast => Annotate ast where
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
@@ -168,7 +265,7 @@ instance Annotate (GHC.HsModule GHC.RdrName) where
markMany GHC.AnnSemi -- possible leading semis
mapM_ markLocated imps
- markList decs
+ mapM_ markLocated decs
mark GHC.AnnCloseC -- Possible '}'
@@ -192,6 +289,10 @@ instance Annotate GHC.WarningTxt where
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
@@ -211,9 +312,24 @@ instance (GHC.DataId name,Annotate name)
mark GHC.AnnType
markLocated ln
- (GHC.IEThingAbs ln) -> do
- 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
@@ -239,41 +355,94 @@ instance (GHC.DataId name,Annotate name)
(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
- 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
+ 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
- markMany GHC.AnnCommaTuple -- For '(,,,)'
- cnt <- countAnns GHC.AnnVal
+ cnt <- countAnns GHC.AnnVal
cntT <- countAnns GHC.AnnCommaTuple
- cntR <- countAnns GHC.AnnRarrow
+ markMany GHC.AnnCommaTuple -- For '(,,,)'
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
+ 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 -- ')'
+ 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
-- ---------------------------------------------------------------------
@@ -286,7 +455,7 @@ instance Annotate GHC.Name where
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
+ 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
@@ -296,9 +465,15 @@ instance (GHC.DataId name,Annotate name)
>> markWithString GHC.AnnClose "#-}")
when safeflag (mark GHC.AnnSafe)
mark GHC.AnnQualified
- mark GHC.AnnPackageName
+ 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
- markExternal ln GHC.AnnVal (GHC.moduleNameString $ GHC.unLoc $ GHC.ideclName imp)
+ markLocated modname
case GHC.ideclAs imp of
Nothing -> return ()
@@ -311,28 +486,34 @@ instance (GHC.DataId name,Annotate name)
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,Annotate name)
+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 -> 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
+ 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
-- ---------------------------------------------------------------------
@@ -350,26 +531,24 @@ instance Annotate (Maybe GHC.Role) where
-- ---------------------------------------------------------------------
-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)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName 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 "$$("
+ markAST _ (GHC.SpliceDecl e _flag) = do
+ mark GHC.AnnOpenPE
markLocated e
- markWithString GHC.AnnClose ")"
+ 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,Annotate name)
+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"
@@ -391,7 +570,8 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markMaybe mln
markWithString GHC.AnnClose "#-}" -- "#-}"
- markAST _ (GHC.HsVectTypeOut {}) = error $ "markP.HsVectTypeOut: only valid after type checker"
+ markAST _ (GHC.HsVectTypeOut {}) =
+ traceM "warning: HsVectTypeOut appears after renaming"
markAST _ (GHC.HsVectClassIn src ln) = do
markWithString GHC.AnnOpen src -- "{-# VECTORISE"
@@ -399,22 +579,26 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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?"
+ 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,Annotate name)
+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,Annotate name)
+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
@@ -434,10 +618,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markLocated lhs
mark GHC.AnnEqual
markLocated rhs
+ markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -449,7 +634,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -484,11 +669,13 @@ instance (Annotate name)
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,Annotate name)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.ForeignDecl name) where
markAST _ (GHC.ForeignImport ln typ _
@@ -500,17 +687,18 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
then return ()
else markLocated safety
-- markMaybe mh
- markExternal ls GHC.AnnVal ("\"" ++ src ++ "\"")
+ 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 ("\"" ++ src ++ "\"")
+ markExternal ls GHC.AnnVal (show src)
markLocated ln
mark GHC.AnnDcolon
markLocated typ
@@ -519,7 +707,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
-- ---------------------------------------------------------------------
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
-- ---------------------------------------------------------------------
@@ -539,7 +731,7 @@ instance (Annotate GHC.Safety) where
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DerivDecl name) where
markAST _ (GHC.DerivDecl typ mov) = do
@@ -550,7 +742,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.DefaultDecl name) where
markAST _ (GHC.DefaultDecl typs) = do
@@ -558,10 +750,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnOpenP -- '('
mapM_ markLocated typs
mark GHC.AnnCloseP -- ')'
+ markOutside GHC.AnnSemi (G GHC.AnnSemi)
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -593,7 +786,7 @@ instance Annotate GHC.OverlapMode where
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -604,8 +797,6 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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
@@ -613,38 +804,46 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
)
mark GHC.AnnCloseC -- '}'
+ markOutside GHC.AnnSemi (AnnSemiSep)
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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,Annotate name)
+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
- markLocated ln
- mapM_ markLocated pats
+ 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,Annotate name) =>
- Annotate (GHC.HsBind name) where
+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
@@ -653,8 +852,8 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>
mapM_ markLocated grhs
mark GHC.AnnWhere
- -- TODO: Store the following SrcSpan in an AnnList instance for exactPC
- markLocated (GHC.L (getLocalBindsSrcSpan lb) lb)
+ markLocalBindsWithLayout lb
+ markOutside GHC.AnnSemi (G GHC.AnnSemi)
markAST _ (GHC.VarBind _n rhse _) =
-- Note: this bind is introduced by the typechecker
@@ -662,12 +861,13 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>
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 ln
markLocated lb
GHC.PrefixPatSyn ns -> do
+ markLocated ln
mapM_ markLocated ns
mark GHC.AnnEqual
mark GHC.AnnLarrow
@@ -680,21 +880,24 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>
mark GHC.AnnWhere
mark GHC.AnnOpenC -- '{'
mark GHC.AnnCloseC -- '}'
+ markOutside GHC.AnnSemi (G GHC.AnnSemi)
-- Introduced after renaming.
- markAST _ (GHC.AbsBinds _ _ _ _ _) = return ()
+ markAST _ (GHC.AbsBinds _ _ _ _ _) =
+ traceM "warning: AbsBind introduced after renaming"
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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 -> error $ "markP.IPBind:should not happen"
+ Right _i -> return ()
mark GHC.AnnEqual
markLocated e
+ markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
@@ -703,7 +906,7 @@ instance Annotate GHC.HsIPName where
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,
Annotate body)
=> Annotate (GHC.Match name (GHC.Located body)) where
@@ -712,21 +915,22 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
get_infix Nothing = False
get_infix (Just (_,f)) = f
case (get_infix mln,pats) of
- (True,[a,b]) -> do
+ (True, (a:b:xs)) -> do
+ mark GHC.AnnOpenP
markLocated a
case mln of
- Nothing -> do
- markWithString GHC.AnnOpen "`" -- possible '`'
- mark GHC.AnnFunId
- markWithString GHC.AnnClose "`"-- possible '`'
+ 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
@@ -735,31 +939,34 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
mark GHC.AnnWhere
mark GHC.AnnOpenC -- '{'
markInside GHC.AnnSemi
- markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)
+ markLocalBindsWithLayout lb
mark GHC.AnnCloseC -- '}'
+ markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
- Annotate body)
+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
-
- mark GHC.AnnVbar
- mapM_ markLocated guards
+ case guards of
+ [] -> return ()
+ (_:_) -> mark GHC.AnnVbar >> mapM_ markLocated guards
mark GHC.AnnEqual
- mark GHC.AnnRarrow -- in case alts
+ cntL <- countAnns GHC.AnnLam
+ when (cntL == 0) $ mark GHC.AnnRarrow -- For HsLam
markLocated expr
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -784,7 +991,8 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnDcolon
markLocated typ
- markAST _ (GHC.IdSig _) = return ()
+ markAST _ (GHC.IdSig _) =
+ traceM "warning: Introduced after renaming"
-- FixSig (FixitySig name)
markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do
@@ -795,6 +1003,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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 '#-}'
@@ -811,19 +1020,20 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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 -- ~
- markWithString GHC.AnnVal "TODO: What here"
mark GHC.AnnCloseS -- ']'
markLocated ln
mark GHC.AnnDcolon -- '::'
mapM_ markLocated typs
markWithString GHC.AnnClose "#-}" -- '#-}'
+ markOutside GHC.AnnSemi AnnSemiSep
-- '{-# SPECIALISE' 'instance' inst_type '#-}'
@@ -832,24 +1042,40 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnInstance
markLocated typ
markWithString GHC.AnnClose "#-}" -- '#-}'
+ markOutside GHC.AnnSemi AnnSemiSep
+
-- MinimalSig (BooleanFormula (Located name))
- markAST _ (GHC.MinimalSig src formula) = do
+ markAST l (GHC.MinimalSig src formula) = do
markWithString GHC.AnnOpen src
- markBooleanFormula formula
+ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar]
+ markAST l formula
markWithString GHC.AnnClose "#-}"
+ markOutside GHC.AnnSemi AnnSemiSep
--- ---------------------------------------------------------------------
+-- --------------------------------------------------------------------
-markBooleanFormula :: GHC.BooleanFormula (GHC.Located name) -> Annotated ()
-markBooleanFormula = assert False undefined
+-- 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,Annotate name) =>
- Annotate (GHC.HsTyVarBndr name) where
+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
@@ -862,7 +1088,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -873,15 +1099,27 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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)))
+ 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 n) = do
+ markAST l (GHC.HsTyVar name) = do
mark GHC.AnnDcolon -- for HsKind, alias for HsType
- markAST l n
+ 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
@@ -915,6 +1153,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST _ (GHC.HsOpTy t1 (_,lo) t2) = do
markLocated t1
+ mark GHC.AnnSimpleQuote
markLocated lo
markLocated t2
@@ -923,6 +1162,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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))
@@ -941,17 +1181,10 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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 l (GHC.HsSpliceTy s _) = do
+ mark GHC.AnnOpenPE
+ markAST l s
+ mark GHC.AnnCloseP
markAST _ (GHC.HsDocTy t ds) = do
markLocated t
@@ -976,18 +1209,20 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnCloseC -- '}'
-- HsCoreTy Type
- markAST _ (GHC.HsCoreTy _t) = return ()
+ markAST _ (GHC.HsCoreTy _t) =
+ traceM "warning: HsCoreTy Introduced after renaming"
markAST _ (GHC.HsExplicitListTy _ ts) = do
- -- TODO: what about SIMPLEQUOTE?
- markWithString GHC.AnnOpen "'[" -- "'["
+ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenS -- "["
mapM_ markLocated ts
mark GHC.AnnCloseS -- ']'
markAST _ (GHC.HsExplicitTupleTy _ ts) = do
- markWithString GHC.AnnOpen "'(" -- "'("
+ mark GHC.AnnSimpleQuote
+ mark GHC.AnnOpenP
mapM_ markLocated ts
- markWithString GHC.AnnClose ")" -- ')'
+ mark GHC.AnnCloseP
-- HsTyLit HsTyLit
markAST l (GHC.HsTyLit lit) = do
@@ -998,18 +1233,78 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markExternal l GHC.AnnVal s
-- HsWrapTy HsTyAnnotated (HsType name)
- markAST _ (GHC.HsWrapTy _ _) = return ()
+ markAST _ (GHC.HsWrapTy _ _) =
+ traceM "warning: HsWrapTyy Introduced after renaming"
+#if __GLASGOW_HASKELL__ <= 710
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)
+#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,Annotate name) =>
+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
@@ -1024,12 +1319,11 @@ instance Annotate GHC.HsDocString where
markExternal l GHC.AnnVal (GHC.unpackFS s)
-- ---------------------------------------------------------------------
-
-instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
+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 "_"
- -- TODO: probably wrong
- markAST l (GHC.VarPat n) = markExternal l GHC.AnnVal (showGhc n)
+ markAST l (GHC.VarPat n) = do
+ markAST l n
markAST _ (GHC.LazyPat p) = do
mark GHC.AnnTilde
markLocated p
@@ -1068,7 +1362,8 @@ instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
markAST _ (GHC.ConPatIn n dets) = do
markHsConPatDetails n dets
- markAST _ (GHC.ConPatOut {}) = return ()
+ markAST _ (GHC.ConPatOut {}) =
+ traceM "warning: ConPatOut Introduced after renaming"
-- ViewPat (LHsExpr id) (LPat id) (PostTc id Type)
markAST _ (GHC.ViewPat e pat _) = do
@@ -1077,16 +1372,10 @@ instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
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) ++ "|]")
+ 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)
@@ -1102,22 +1391,31 @@ instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
markWithString GHC.AnnVal "+" -- "+"
markLocated ol
- markAST l (GHC.SigPatIn pat ty) = do
+
+ markAST _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do
markLocated pat
mark GHC.AnnDcolon
- markAST l ty
+ markLocated ty
- markAST _ (GHC.SigPatOut {}) = return ()
+ markAST _ (GHC.SigPatOut {}) =
+ traceM "warning: SigPatOut introduced after renaming"
-- CoPat HsAnnotated (Pat id) Type
- markAST _ (GHC.CoPat {}) = return ()
+ 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
- GHC.HsCharPrim 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
@@ -1127,10 +1425,10 @@ hsLit2String lit =
GHC.HsWord64Prim src _ -> src
GHC.HsInteger src _ _ -> src
GHC.HsRat (GHC.FL src _) _ -> src
- GHC.HsFloatPrim (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)
+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
@@ -1148,7 +1446,7 @@ markHsConPatDetails ln dets = do
markLocated ln
markLocated a2
-markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -1164,13 +1462,14 @@ markHsConDeclDetails lns dets = do
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
-- ---------------------------------------------------------------------
@@ -1187,12 +1486,14 @@ instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where
instance (GHC.DataId name,Annotate arg)
=> Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where
- markAST _ (GHC.HsWB thing _ _ _) = markLocated thing
+ markAST _ (GHC.HsWB thing _ _ _) = do
+ markLocated thing
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) =>
- Annotate (GHC.Stmt name (GHC.Located body)) where
+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
@@ -1201,20 +1502,29 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) =
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 -- '{'
- markWithLayout (GHC.L (getLocalBindsSrcSpan lb) lb)
+ --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 _ (GHC.ParStmt pbs _ _) = do
- mapM_ markParStmtBlock pbs
+ 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
@@ -1222,19 +1532,19 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) =
GHC.ThenForm -> do
mark GHC.AnnThen
markLocated using
- mark GHC.AnnBy
case by of
- Just b -> markLocated b
+ Just b -> mark GHC.AnnBy >> markLocated b
Nothing -> return ()
GHC.GroupForm -> do
mark GHC.AnnThen
mark GHC.AnnGroup
- mark GHC.AnnBy
case by of
- Just b -> markLocated b
+ 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
@@ -1242,85 +1552,55 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,Annotate body) =
markInside GHC.AnnSemi
mapM_ markLocated stmts
mark GHC.AnnCloseC
+ mark GHC.AnnVbar -- possible in list comprehension
+ markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
-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,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,Annotate name)
+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,Annotate name)
+markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> (GHC.HsLocalBinds name) -> Annotated ()
-markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = do
+markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) =
applyListAnnotations (prepareListAnnotation (GHC.bagToList binds)
++ prepareListAnnotation sigs
)
markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsOut {}))
- = error $ "markHsLocalBinds: only valid after type checking"
+ = traceM "warning: ValBindsOut introduced after renaming"
-markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated binds
+markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = mapM_ markLocated (reverse binds)
markHsLocalBinds (GHC.EmptyLocalBinds) = return ()
-- ---------------------------------------------------------------------
-markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
+markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name,
Annotate body)
- => GHC.SrcSpan -> (GHC.MatchGroup name (GHC.Located body))
+ => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body)
-> Annotated ()
-markMatchGroup l (GHC.MG matches _ _ _)
- = markListWithLayout l matches
+markMatchGroup _ (GHC.MG matches _ _ _)
+ = markListWithLayout matches
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name,
+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,Annotate name)
+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)) =
@@ -1328,11 +1608,17 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST l (GHC.HsOverLit ov) = markAST l ov
markAST l (GHC.HsLit lit) = markAST l lit
- markAST l (GHC.HsLam match) = do
+ markAST _ (GHC.HsLam match) = do
mark GHC.AnnLam
- markMatchGroup l match
+ -- TODO: Change this, HsLam binds do not need obey layout rules.
+ mapM_ markLocated (GHC.mg_alts match)
- markAST l (GHC.HsLamCase _ match) = markMatchGroup l 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
@@ -1393,17 +1679,18 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mapM_ markLocated rhs
markAST _ (GHC.HsLet binds e) = do
- mark GHC.AnnLet
- setLayoutFlag GHC.AnnLet (do -- Make sure the 'in' gets indented too
+ setLayoutFlag (do -- Make sure the 'in' gets indented too
+ mark GHC.AnnLet
mark GHC.AnnOpenC
markInside GHC.AnnSemi
- markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)
+ markLocalBindsWithLayout binds
mark GHC.AnnCloseC
mark GHC.AnnIn
markLocated e)
- markAST l (GHC.HsDo cts es _) = do
+ markAST _ (GHC.HsDo cts es _) = do
mark GHC.AnnDo
+ mark GHC.AnnMdo
let (ostr,cstr,_isComp) =
if isListComp cts
then case cts of
@@ -1421,7 +1708,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnVbar
mapM_ markLocated (init es)
else do
- markListWithLayout l es
+ markListWithLayout es
mark GHC.AnnCloseS
mark GHC.AnnCloseC
markWithString GHC.AnnClose cstr
@@ -1439,15 +1726,15 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST _ (GHC.RecordCon n _ (GHC.HsRecFields fs _)) = do
markLocated n
mark GHC.AnnOpenC
- mark GHC.AnnDotdot
mapM_ markLocated fs
+ mark GHC.AnnDotdot
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.AnnDotdot
mark GHC.AnnCloseC
markAST _ (GHC.ExprWithTySig e typ _) = do
@@ -1508,23 +1795,30 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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"
- markWithString GHC.AnnVal (GHC.unpackFS csFStr)
+#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 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.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
@@ -1532,9 +1826,16 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
mark GHC.AnnCloseC
markWithString GHC.AnnClose "|]"
-- Introduced after the renamer
- markAST _ (GHC.HsBracket (GHC.DecBrG _)) = return ()
+ markAST _ (GHC.HsBracket (GHC.DecBrG _)) =
+ traceM "warning: DecBrG introduced after renamer"
markAST _ (GHC.HsBracket (GHC.ExpBr e)) = do
- markWithString GHC.AnnOpen "[|"
+-- 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
@@ -1550,23 +1851,25 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markLocated e
markWithString GHC.AnnClose "|]"
- markAST _ (GHC.HsRnBracketOut _ _) = return ()
- markAST _ (GHC.HsTcBracketOut _ _) = return ()
+ markAST _ (GHC.HsRnBracketOut _ _) =
+ traceM "warning: HsRnBracketOut introduced after renamer"
+ markAST _ (GHC.HsTcBracketOut _ _) =
+ traceM "warning: HsTcBracketOut introduced after renamer"
- 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) ++ "|]")
+#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
@@ -1600,7 +1903,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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
@@ -1630,8 +1937,10 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST _ (GHC.HsType ty) = markLocated ty
- markAST _ (GHC.HsWrap _ _) = return ()
- markAST _ (GHC.HsUnboundVar _) = return ()
+ 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)
@@ -1639,13 +1948,13 @@ instance Annotate GHC.HsLit where
-- |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)
+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,Annotate name)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate (GHC.HsTupArg name) where
markAST _ (GHC.Present e) = do
markLocated e
@@ -1655,11 +1964,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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,Annotate name)
+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
@@ -1673,8 +1982,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST _ (GHC.HsCmdArrForm e _mf cs) = do
markWithString GHC.AnnOpen "(|"
- markLocated e
- mapM_ markLocated cs
+ -- 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
@@ -1711,40 +2023,48 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
markAST _ (GHC.HsCmdLet binds e) = do
mark GHC.AnnLet
mark GHC.AnnOpenC
- markWithLayout (GHC.L (getLocalBindsSrcSpan binds) binds)
+ markLocalBindsWithLayout binds
mark GHC.AnnCloseC
mark GHC.AnnIn
markLocated e
- markAST l (GHC.HsCmdDo es _) = do
+ markAST _ (GHC.HsCmdDo es _) = do
mark GHC.AnnDo
mark GHC.AnnOpenC
- -- mapM_ markLocated es
- markListWithLayout l es
+ markListWithLayout es
mark GHC.AnnCloseC
- markAST _ (GHC.HsCmdCast {}) = error $ "markP.HsCmdCast: only valid after type checker"
+ markAST _ (GHC.HsCmdCast {}) =
+ traceM "warning: HsCmdCast introduced after renaming"
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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,Annotate name)
+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
- markLocated ln
- mapM_ markLocated tyvars
+ -- 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
@@ -1758,8 +2078,11 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
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)
-- -----------------------------------
@@ -1782,6 +2105,7 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
++ prepareListAnnotation docs
)
mark GHC.AnnCloseC -- '}'
+ markOutside (GHC.AnnSemi) AnnSemiSep
-- ---------------------------------------------------------------------
@@ -1796,42 +2120,49 @@ markTyClass ln tyVars = do
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,Annotate name, GHC.OutputableBndr name)
+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
- markLocated ln
- mapM_ markLocated tyvars
+ 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
- _ -> return ()
- case info of
- GHC.ClosedTypeFamily eqns -> mapM_ markLocated eqns
+#endif
_ -> return ()
mark GHC.AnnCloseC -- }
+ markOutside GHC.AnnSemi AnnSemiSep
-- ---------------------------------------------------------------------
-instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
- => Annotate (GHC.TyFamInstEqn name) where
+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
- markLocated ln
- mapM_ markLocated pats
+ 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)
+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
@@ -1853,7 +2184,7 @@ instance Annotate GHC.DocDecl where
-- ---------------------------------------------------------------------
-markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+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
@@ -1867,31 +2198,31 @@ markDataDefn _ (GHC.HsDataDefn _ ctx typ mk cons mderivs) = do
-- ---------------------------------------------------------------------
-- Note: GHC.HsContext name aliases to here too
-instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name)
+instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name)
=> Annotate [GHC.LHsType name] where
- markAST l ts = do
- return () `debug` ("markP.HsContext:l=" ++ showGhc l)
+ markAST _ ts = do
mark GHC.AnnDeriving
- mark GHC.AnnOpenP
+ markMany GHC.AnnOpenP -- may be nested parens around context
mapM_ markLocated ts
- mark GHC.AnnCloseP
- mark GHC.AnnDarrow
+ 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)
+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 _ _) = do
+ 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
@@ -1904,24 +2235,58 @@ instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name)
GHC.InfixCon _ _ -> return ()
_ -> mapM_ markLocated lns
- markHsConDeclDetails lns dets
+ 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 )
- mark GHC.AnnDcolon
+ markLocated ty
- markLocated (GHC.L ls (ResTyGADTHook bndrs))
+ markMany GHC.AnnCloseP
- markLocated ctx
- mark GHC.AnnDarrow
- markLocated ty
+ mark GHC.AnnVbar
+ markOutside GHC.AnnSemi (G GHC.AnnSemi)
- mark GHC.AnnVbar
+-- 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,Annotate name) =>
- Annotate (ResTyGADTHook name) where
+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
@@ -1929,8 +2294,16 @@ instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name) =>
-- ---------------------------------------------------------------------
-instance (Annotate name,Annotate a)
- => Annotate (GHC.HsRecField name (GHC.Located a)) where
+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
@@ -1953,9 +2326,15 @@ instance Annotate (GHC.CType) where
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 "#-}"
-- ---------------------------------------------------------------------
diff --git a/src/Language/Haskell/GHC/ExactPrint/Delta.hs b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
index 35bb260..33b4148 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Delta.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Delta.hs
@@ -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 Data.Ord
-import Language.Haskell.GHC.ExactPrint.Types
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
- }
-
-data DeltaStack = DeltaStack
- { -- | Current `SrcSpan`
- curSrcSpan :: GHC.SrcSpan
- -- | Constuctor of current AST element, useful for
- -- debugging
- , annConName :: AnnConName
- -- | Start column of the current layout block
- , layoutStart :: LayoutStartCol
- }
-
-initialDeltaStack :: DeltaStack
-initialDeltaStack =
- DeltaStack
+ { -- | Position reached when processing the last element
+ priorEndPosition :: !Pos
+
+ -- | Ordered list of comments still to be allocated
+ , apComments :: ![Comment]
+
+ -- | 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,69 +177,111 @@ defaultDeltaState priorEnd ga =
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
-
-
--- | 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
+ 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
+
+
+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 @@ withSrcSpanDelta (GHC.L l a) =
})
-
getUnallocatedComments :: Delta [Comment]
getUnallocatedComments = gets apComments
@@ -175,48 +303,80 @@ putUnallocatedComments cs = modify (\s -> s { apComments = cs } )
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 })
+
+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}))
-setLayoutOffset :: LayoutStartCol -> Delta a -> Delta a
-setLayoutOffset lhs = local (\s -> s { layoutStart = lhs })
-- -------------------------------------
-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,85 +385,142 @@ addAnnDeltaPos kw dp = tellKd (kw, dp)
-- -------------------------------------
-
-- | Enter a new AST element. Maintain SrcSpan stack
-withAST :: Data a => GHC.Located a -> LayoutFlag -> Delta b -> Delta b
-withAST lss@(GHC.L ss _) layout action = do
+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 }
-
- (res, w) <- censor maskWriter (listen action)
+ , sortKeys = Nothing
+ , dwCapturedSpan = mempty }
+
+ -- 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
-- ---------------------------------------------------------------------
@@ -312,35 +529,23 @@ addDeltaComment (Comment paspan str) = do
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 :: GHC.AnnKeywordId -> Delta ()
addDeltaAnnotations ann = do
ma <- getAnnotationDelta ann
let do_one ap' = addAnnotationWorker (G ann) ap'
- -- `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann))
+ `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 @@ addDeltaAnnotations ann = do
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 @@ addDeltaAnnotationsInside ann = do
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 @@ addEofAnnotation = do
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)
-
-
diff --git a/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs b/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs
new file mode 100644
index 0000000..1f3d5d4
--- /dev/null
+++ b/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs
@@ -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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
index 433330a..14b21f5 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs
@@ -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)
+
+-}
diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
new file mode 100644
index 0000000..f3f33e2
--- /dev/null
+++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs
@@ -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)))
diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
new file mode 100644
index 0000000..cf45a1a
--- /dev/null
+++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs
@@ -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
+
+
+
diff --git a/src/Language/Haskell/GHC/ExactPrint/Print.hs b/src/Language/Haskell/GHC/ExactPrint/Print.hs
index 397a99a..3c912fa 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Print.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Print.hs
@@ -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,55 +53,60 @@ exactPrintWithAnns :: Annotate ast
=> 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
@@ -105,83 +115,121 @@ printInterpret = iterTM go
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
+
+-------------------------------------------------------------------------
+
+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
-justOne, allAnns :: GHC.AnnKeywordId -> EP ()
-justOne kwid = printStringAtMaybeAnn (G kwid) (keywordToString kwid)
-allAnns kwid = printStringAtMaybeAnnAll (G kwid) (keywordToString kwid)
+-------------------------------------------------------------------------
+
+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 @@ withKds kd action = do
------------------------------------------------------------------------
-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 @@ setPos l = modify (\s -> s {epPos = l})
-- |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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
new file mode 100644
index 0000000..68399a7
--- /dev/null
+++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs
@@ -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
diff --git a/src/Language/Haskell/GHC/ExactPrint/Types.hs b/src/Language/Haskell/GHC/ExactPrint/Types.hs
index 800e014..4172939 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Types.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Types.hs
@@ -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 @@ import qualified Data.Map as Map
-- ---------------------------------------------------------------------
--- | 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)
+
+instance Show LayoutStartCol where
+ show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")"
-annNone :: Annotation
-annNone = Ann (DP (0,0)) 0 []
-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)
-
-instance Monoid LayoutFlag where
- mempty = NoLayoutRules
- LayoutRules `mappend` _ = LayoutRules
- _ `mappend` LayoutRules = LayoutRules
- _ `mappend` _ = NoLayoutRules
+-- | 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 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 @@ instance GHC.Outputable DeltaPos where
-- ---------------------------------------------------------------------
--- 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
-- ---------------------------------------------------------------------
+
diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
index a53dfb8..b02193d 100644
--- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs
+++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs
@@ -1,45 +1,65 @@
{-# 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
@@ -53,6 +73,12 @@ import qualified Var as GHC
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 @@ debug c s = if debugEnabledFlag
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 @@ undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc)
fl = l + dl
fc = if dl == 0 then c + dc
else co + dc
+-- | Add together two @DeltaPos@ taking into account newlines
+--
+-- > DP (0, 1) `addDP` DP (0, 2) == DP (0,3)
+-- > DP (0, 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 @@ ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss)
ss2posEnd :: GHC.SrcSpan -> Pos
ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss)
-ss2span :: GHC.SrcSpan -> Span
-ss2span ss = (ss2pos ss,ss2posEnd ss)
-
srcSpanEndColumn :: GHC.SrcSpan -> Int
srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s
srcSpanEndColumn _ = 0
@@ -134,18 +169,25 @@ srcSpanStartLine :: GHC.SrcSpan -> Int
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)
-- ---------------------------------------------------------------------
@@ -174,7 +216,40 @@ ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s
ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s
ghcCommentText (GHC.L _ (GHC.AnnLineComment s)) = s
-ghcCommentText (GHC.L _ (GHC.AnnBlockComment s)) = "{-" ++ s ++ "-}"
+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)
-- ---------------------------------------------------------------------
@@ -187,23 +262,18 @@ rdrName2String r =
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 @@ showAnnData anns n =
-- ---------------------------------------------------------------------
+
+ -- ---------------------------------------------------------------------
+
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"
diff --git a/tests/Roundtrip.hs b/tests/Roundtrip.hs
new file mode 100644
index 0000000..235f6c3
--- /dev/null
+++ b/tests/Roundtrip.hs
@@ -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)
diff --git a/tests/Static.hs b/tests/Static.hs
new file mode 100644
index 0000000..bdeb671
--- /dev/null
+++ b/tests/Static.hs
@@ -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)
+
diff --git a/tests/Test.hs b/tests/Test.hs
index 185b950..3991eee 100644
--- a/tests/Test.hs
+++ b/tests/Test.hs
@@ -1,187 +1,281 @@
+{-# 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 Language.Haskell.GHC.ExactPrint.Utils (showGhc)
+import qualified FastString as GHC
+import qualified GHC as GHC
-import GHC.Paths ( libdir )
+-- import qualified Data.Generics as SYB
+-- import qualified GHC.SYB.Utils as SYB
-
-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 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"
+
+ , 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"
+ ]
+
+ ++ transformTests
- , 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"
+ ++ failingTests
+
+-- 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"
]
-mkTestMain :: FilePath -> Test
-mkTestMain fileName = TestCase (do r <- manipulateAstTest fileName "Main"
- assertBool fileName r )
-mkTestMod :: FilePath -> String -> Test
-mkTestMod fileName modName
- = TestCase (do r <- manipulateAstTest fileName modName
- assertBool fileName r )
+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))
+
-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 )
+mkTestMod :: FilePath -> String -> Test
+mkTestMod fileName _modName
+ = mkParserTest fileName
+
-- ---------------------------------------------------------------------
@@ -195,212 +289,210 @@ formatTT (ts, fs) = do
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"
+ ]
-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
+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
--- ---------------------------------------------------------------------
-- | Where all the tests are to be found
examplesDir :: FilePath
@@ -409,130 +501,7 @@ examplesDir = "tests" </> "examples"
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
-- ---------------------------------------------------------------------
@@ -548,73 +517,5 @@ mkSs :: (Int,Int) -> (Int,Int) -> GHC.SrcSpan
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
diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs
new file mode 100644
index 0000000..eba3758
--- /dev/null
+++ b/tests/Test/Common.hs
@@ -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))
diff --git a/tests/Test/Consistency.hs b/tests/Test/Consistency.hs
new file mode 100644
index 0000000..c3dfcb3
--- /dev/null
+++ b/tests/Test/Consistency.hs
@@ -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]
+
diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs
new file mode 100644
index 0000000..e72726a
--- /dev/null
+++ b/tests/Test/Transform.hs
@@ -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')
+
+-- ---------------------------------------------------------------------
diff --git a/tests/examples/AddDecl.hs b/tests/examples/AddDecl.hs
new file mode 100644
index 0000000..803129e
--- /dev/null
+++ b/tests/examples/AddDecl.hs
@@ -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
diff --git a/tests/examples/AddDecl.hs.expected b/tests/examples/AddDecl.hs.expected
new file mode 100644
index 0000000..d376900
--- /dev/null
+++ b/tests/examples/AddDecl.hs.expected
@@ -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
diff --git a/tests/examples/AddLocalDecl1.hs b/tests/examples/AddLocalDecl1.hs
new file mode 100644
index 0000000..d35d74f
--- /dev/null
+++ b/tests/examples/AddLocalDecl1.hs
@@ -0,0 +1,9 @@
+module AddLocalDecl1 where
+
+-- |This is a function
+foo = x -- comment1
+
+-- |Another fun
+x = a -- comment2
+ where
+ a = 3
diff --git a/tests/examples/AddLocalDecl1.hs.expected b/tests/examples/AddLocalDecl1.hs.expected
new file mode 100644
index 0000000..7909bca
--- /dev/null
+++ b/tests/examples/AddLocalDecl1.hs.expected
@@ -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
diff --git a/tests/examples/AddLocalDecl2.hs b/tests/examples/AddLocalDecl2.hs
new file mode 100644
index 0000000..7609f65
--- /dev/null
+++ b/tests/examples/AddLocalDecl2.hs
@@ -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
diff --git a/tests/examples/AddLocalDecl2.hs.expected b/tests/examples/AddLocalDecl2.hs.expected
new file mode 100644
index 0000000..ff25b79
--- /dev/null
+++ b/tests/examples/AddLocalDecl2.hs.expected
@@ -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
diff --git a/tests/examples/AddLocalDecl3.hs b/tests/examples/AddLocalDecl3.hs
new file mode 100644
index 0000000..df30f58
--- /dev/null
+++ b/tests/examples/AddLocalDecl3.hs
@@ -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
diff --git a/tests/examples/AddLocalDecl3.hs.expected b/tests/examples/AddLocalDecl3.hs.expected
new file mode 100644
index 0000000..b8bd3e2
--- /dev/null
+++ b/tests/examples/AddLocalDecl3.hs.expected
@@ -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
diff --git a/tests/examples/AnnPackageName.hs b/tests/examples/AnnPackageName.hs
new file mode 100644
index 0000000..500ecf3
--- /dev/null
+++ b/tests/examples/AnnPackageName.hs
@@ -0,0 +1,4 @@
+
+
+import "base" Prelude
+import "base" Data.Data
diff --git a/tests/examples/AssociatedType.hs b/tests/examples/AssociatedType.hs
new file mode 100644
index 0000000..fec9e48
--- /dev/null
+++ b/tests/examples/AssociatedType.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+class Foldable t where
+ type FoldableConstraint t x :: *
+ type FoldableConstraint t x = ()
+
diff --git a/tests/examples/Backquote.hs b/tests/examples/Backquote.hs
new file mode 100644
index 0000000..cb3ed68
--- /dev/null
+++ b/tests/examples/Backquote.hs
@@ -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
+
+
diff --git a/tests/examples/BracesSemiDataDecl.hs b/tests/examples/BracesSemiDataDecl.hs
new file mode 100644
index 0000000..4e06aed
--- /dev/null
+++ b/tests/examples/BracesSemiDataDecl.hs
@@ -0,0 +1,7 @@
+
+
+data Nat (t :: NatKind) where
+{
+ ZeroNat :: Nat Zero;
+ SuccNat :: Nat t -> Nat (Succ t);
+};
diff --git a/tests/examples/C.hs b/tests/examples/C.hs
new file mode 100644
index 0000000..8854139
--- /dev/null
+++ b/tests/examples/C.hs
@@ -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
+
diff --git a/tests/examples/C.hs.expected b/tests/examples/C.hs.expected
new file mode 100644
index 0000000..8aa2273
--- /dev/null
+++ b/tests/examples/C.hs.expected
@@ -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
+
diff --git a/tests/examples/CExpected.hs b/tests/examples/CExpected.hs
new file mode 100644
index 0000000..6bd5248
--- /dev/null
+++ b/tests/examples/CExpected.hs
@@ -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
+
diff --git a/tests/examples/Commands.hs b/tests/examples/Commands.hs
new file mode 100644
index 0000000..74e739a
--- /dev/null
+++ b/tests/examples/Commands.hs
@@ -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
+ ]
+
diff --git a/tests/examples/Control.hs b/tests/examples/Control.hs
new file mode 100644
index 0000000..5dcc66e
--- /dev/null
+++ b/tests/examples/Control.hs
@@ -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 ()
diff --git a/tests/examples/CorePragma.hs b/tests/examples/CorePragma.hs
new file mode 100644
index 0000000..531c07e
--- /dev/null
+++ b/tests/examples/CorePragma.hs
@@ -0,0 +1,6 @@
+{-# INLINE strictStream #-}
+strictStream (Bitstream l v)
+ = {-# CORE "Strict Bitstream stream" #-}
+ S.concatMap stream (GV.stream v)
+ `S.sized`
+ Exact l
diff --git a/tests/examples/Cpp.hs b/tests/examples/Cpp.hs
index 93bccfb..decd365 100644
--- a/tests/examples/Cpp.hs
+++ b/tests/examples/Cpp.hs
@@ -7,3 +7,11 @@ foo :: Integer
#endif
foo = 3
+bar :: (
+#if __GLASGOW_HASKELL__ > 704
+ Int)
+#else
+ Integer)
+#endif
+bar = 4
+
diff --git a/tests/examples/Dead1.hs b/tests/examples/Dead1.hs
index 274fa5d..b34b147 100644
--- a/tests/examples/Dead1.hs
+++ b/tests/examples/Dead1.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-}
+{-# OPTIONS -O -ddump-stranal #-}
module Dead1(foo) where
diff --git a/tests/examples/DefaultTypeInstance.hs b/tests/examples/DefaultTypeInstance.hs
new file mode 100644
index 0000000..3f46a4f
--- /dev/null
+++ b/tests/examples/DefaultTypeInstance.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+
+
+class Foldable t where
+ type FoldableConstraint t x :: Constraint
+ type FoldableConstraint t x = ()
diff --git a/tests/examples/Deprecation.hs b/tests/examples/Deprecation.hs
index c61889c..63c555e 100644
--- a/tests/examples/Deprecation.hs
+++ b/tests/examples/Deprecation.hs
@@ -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 @@ module Deprecation
foo :: Int
foo = 4
+{-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}
diff --git a/tests/examples/DoParens.hs b/tests/examples/DoParens.hs
new file mode 100644
index 0000000..58172db
--- /dev/null
+++ b/tests/examples/DoParens.hs
@@ -0,0 +1,4 @@
+
+foo = do
+ (-) <- Just 5
+ return ()
diff --git a/tests/examples/DoPatBind.hs b/tests/examples/DoPatBind.hs
new file mode 100644
index 0000000..c3aadb7
--- /dev/null
+++ b/tests/examples/DoPatBind.hs
@@ -0,0 +1,4 @@
+module Main where
+
+bar = do
+ foo :: String <- baz
diff --git a/tests/examples/DoubleForall.hs b/tests/examples/DoubleForall.hs
new file mode 100644
index 0000000..5934baa
--- /dev/null
+++ b/tests/examples/DoubleForall.hs
@@ -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
diff --git a/tests/examples/DroppedComma.hs b/tests/examples/DroppedComma.hs
new file mode 100644
index 0000000..0a0b85c
--- /dev/null
+++ b/tests/examples/DroppedComma.hs
@@ -0,0 +1,5 @@
+
+
+foo =
+ let (xs, ys) = ([1,2..3], [4,5..6]) in
+ bar
diff --git a/tests/examples/DroppedDoSpace.hs b/tests/examples/DroppedDoSpace.hs
new file mode 100644
index 0000000..47b12d5
--- /dev/null
+++ b/tests/examples/DroppedDoSpace.hs
@@ -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
diff --git a/tests/examples/DroppedDoSpace2.hs b/tests/examples/DroppedDoSpace2.hs
new file mode 100644
index 0000000..1c83bc6
--- /dev/null
+++ b/tests/examples/DroppedDoSpace2.hs
@@ -0,0 +1,6 @@
+
+
+save state = do \fileName ->
+ 4
+
+
diff --git a/tests/examples/ExplicitNamespaces.hs b/tests/examples/ExplicitNamespaces.hs
new file mode 100644
index 0000000..cd49102
--- /dev/null
+++ b/tests/examples/ExplicitNamespaces.hs
@@ -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 (-))
diff --git a/tests/examples/Foo.hs b/tests/examples/Foo.hs
deleted file mode 100644
index f63553e..0000000
--- a/tests/examples/Foo.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-{-# LANGUAGE RecursiveDo #-}
-
-bar :: IO ()
-bar = do
- rec {}
- return ()
-
diff --git a/tests/examples/ForeignDecl.hs b/tests/examples/ForeignDecl.hs
index 4a8e95f..c61fd7d 100644
--- a/tests/examples/ForeignDecl.hs
+++ b/tests/examples/ForeignDecl.hs
@@ -46,6 +46,8 @@ foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16
foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32
foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64
+foreign import ccall unsafe "safe_qd.h safe_qd_add" c_qd_add :: Ptr CDouble -> Ptr CDouble -> Ptr CDouble -> IO ();
+
foreign import ccall unsafe "kitchen"
sink :: Ptr a
-> ByteArray#
@@ -83,3 +85,23 @@ foreign import ccall unsafe "dynamic"
-- exports
foreign export ccall "plusInt" (+) :: Int -> Int -> Int
+
+listToJSArray :: ToJSRef a => [a] -> IO (JSArray a)
+listToJSArray = toJSArray deconstr
+ where deconstr (x : xs) = Just (x, xs)
+ deconstr [] = Nothing
+
+foreign import javascript unsafe "$r = new Float32Array($1);"
+ float32Array :: JSArray Float -> IO Float32Array
+
+foreign import javascript unsafe "$r = new Int32Array($1);"
+ int32Array :: JSArray Int32 -> IO Int32Array
+
+foreign import javascript unsafe "$r = new Uint16Array($1);"
+ uint16Array :: JSArray Word16 -> IO Uint16Array
+
+foreign import javascript unsafe "$r = new Uint8Array($1);"
+ uint8Array :: JSArray Word8 -> IO Uint8Array
+
+foreign import javascript unsafe "$r = $1.getContext(\"webgl\");"
+ getCtx :: JSRef a -> IO Ctx
diff --git a/tests/examples/GADTContext.hs b/tests/examples/GADTContext.hs
new file mode 100644
index 0000000..02b92ac
--- /dev/null
+++ b/tests/examples/GADTContext.hs
@@ -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])
diff --git a/tests/examples/GADTRecords.hs b/tests/examples/GADTRecords.hs
new file mode 100644
index 0000000..23e6232
--- /dev/null
+++ b/tests/examples/GADTRecords.hs
@@ -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
diff --git a/tests/examples/GADTRecords2.hs b/tests/examples/GADTRecords2.hs
new file mode 100644
index 0000000..fa79500
--- /dev/null
+++ b/tests/examples/GADTRecords2.hs
@@ -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
diff --git a/tests/examples/GHCOrig.hs b/tests/examples/GHCOrig.hs
new file mode 100644
index 0000000..9121d20
--- /dev/null
+++ b/tests/examples/GHCOrig.hs
@@ -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___
+-}
diff --git a/tests/examples/Hang.hs b/tests/examples/Hang.hs
new file mode 100644
index 0000000..a8042f9
--- /dev/null
+++ b/tests/examples/Hang.hs
@@ -0,0 +1 @@
+(~>) = forall
diff --git a/tests/examples/HangingRecord.hs b/tests/examples/HangingRecord.hs
new file mode 100644
index 0000000..0a14bdd
--- /dev/null
+++ b/tests/examples/HangingRecord.hs
@@ -0,0 +1,5 @@
+
+data Foo = Foo
+ { r1 :: Int
+ , r2 :: Int
+ }
diff --git a/tests/examples/HashQQ.hs b/tests/examples/HashQQ.hs
new file mode 100644
index 0000000..2b347b3
--- /dev/null
+++ b/tests/examples/HashQQ.hs
@@ -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"))
+
diff --git a/tests/examples/ImplicitSemi.hs b/tests/examples/ImplicitSemi.hs
new file mode 100644
index 0000000..630045c
--- /dev/null
+++ b/tests/examples/ImplicitSemi.hs
@@ -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
diff --git a/tests/examples/ImplicitTypeSyn.hs b/tests/examples/ImplicitTypeSyn.hs
new file mode 100644
index 0000000..4602ee9
--- /dev/null
+++ b/tests/examples/ImplicitTypeSyn.hs
@@ -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
diff --git a/tests/examples/Imports.hs b/tests/examples/Imports.hs
new file mode 100644
index 0000000..091ffee
--- /dev/null
+++ b/tests/examples/Imports.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+module Imports( f, type (+), pattern Single ) where
+
+import GHC.TypeLits
+
+pattern Single x = [x]
+
+f = undefined
diff --git a/tests/examples/IndentedDo.hs b/tests/examples/IndentedDo.hs
new file mode 100644
index 0000000..ed7a9dd
--- /dev/null
+++ b/tests/examples/IndentedDo.hs
@@ -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
diff --git a/tests/examples/InfixOperator.hs b/tests/examples/InfixOperator.hs
new file mode 100644
index 0000000..160aace
--- /dev/null
+++ b/tests/examples/InfixOperator.hs
@@ -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_ #-}
+
diff --git a/tests/examples/InfixPatternSynonyms.hs b/tests/examples/InfixPatternSynonyms.hs
new file mode 100644
index 0000000..0bdac06
--- /dev/null
+++ b/tests/examples/InfixPatternSynonyms.hs
@@ -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
diff --git a/tests/examples/InlineSemi.hs b/tests/examples/InlineSemi.hs
new file mode 100644
index 0000000..437bd16
--- /dev/null
+++ b/tests/examples/InlineSemi.hs
@@ -0,0 +1 @@
+{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i
diff --git a/tests/examples/Internals.hs b/tests/examples/Internals.hs
new file mode 100644
index 0000000..c934cc5
--- /dev/null
+++ b/tests/examples/Internals.hs
@@ -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
+ #-}
diff --git a/tests/examples/Jon.hs b/tests/examples/Jon.hs
new file mode 100644
index 0000000..791b96e
--- /dev/null
+++ b/tests/examples/Jon.hs
@@ -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 -}
diff --git a/tests/examples/LambdaCase.hs b/tests/examples/LambdaCase.hs
new file mode 100644
index 0000000..891be49
--- /dev/null
+++ b/tests/examples/LambdaCase.hs
@@ -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 }
diff --git a/tests/examples/LetIn1.hs b/tests/examples/LetIn1.hs
new file mode 100644
index 0000000..f1109b8
--- /dev/null
+++ b/tests/examples/LetIn1.hs
@@ -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
+
+
diff --git a/tests/examples/LetIn1.hs.expected b/tests/examples/LetIn1.hs.expected
new file mode 100644
index 0000000..d233115
--- /dev/null
+++ b/tests/examples/LetIn1.hs.expected
@@ -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
+
+
diff --git a/tests/examples/LiftedConstructors.hs b/tests/examples/LiftedConstructors.hs
new file mode 100644
index 0000000..af14b4a
--- /dev/null
+++ b/tests/examples/LiftedConstructors.hs
@@ -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
diff --git a/tests/examples/LiftedInfixConstructor.hs b/tests/examples/LiftedInfixConstructor.hs
new file mode 100644
index 0000000..9d57907
--- /dev/null
+++ b/tests/examples/LiftedInfixConstructor.hs
@@ -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)
diff --git a/tests/examples/LinePragma.hs b/tests/examples/LinePragma.hs
new file mode 100644
index 0000000..222d9da
--- /dev/null
+++ b/tests/examples/LinePragma.hs
@@ -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
diff --git a/tests/examples/ListComprehensions.hs b/tests/examples/ListComprehensions.hs
index 76c046d..d4e0ccb 100644
--- a/tests/examples/ListComprehensions.hs
+++ b/tests/examples/ListComprehensions.hs
@@ -74,3 +74,26 @@ bestBirthYears tbl = [ (the birthYear, firstName)
, 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 ]
diff --git a/tests/examples/LocalDecls.hs b/tests/examples/LocalDecls.hs
new file mode 100644
index 0000000..ebb774a
--- /dev/null
+++ b/tests/examples/LocalDecls.hs
@@ -0,0 +1,8 @@
+module LocalDecls where
+
+foo a = bar a
+ where
+ bar :: Int -> Int
+ bar x = x + 2
+
+ baz = 4
diff --git a/tests/examples/LocalDecls.hs.expected b/tests/examples/LocalDecls.hs.expected
new file mode 100644
index 0000000..7c41178
--- /dev/null
+++ b/tests/examples/LocalDecls.hs.expected
@@ -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
diff --git a/tests/examples/LocalDecls2.hs b/tests/examples/LocalDecls2.hs
new file mode 100644
index 0000000..92a8649
--- /dev/null
+++ b/tests/examples/LocalDecls2.hs
@@ -0,0 +1,3 @@
+module LocalDecls2 where
+
+foo a = bar a
diff --git a/tests/examples/LocalDecls2.hs.expected b/tests/examples/LocalDecls2.hs.expected
new file mode 100644
index 0000000..f015e95
--- /dev/null
+++ b/tests/examples/LocalDecls2.hs.expected
@@ -0,0 +1,6 @@
+module LocalDecls2 where
+
+foo a = bar a
+ where
+ nn :: Int
+ nn = 2
diff --git a/tests/examples/LocalDecls2Expected.hs b/tests/examples/LocalDecls2Expected.hs
new file mode 100644
index 0000000..5f2fb73
--- /dev/null
+++ b/tests/examples/LocalDecls2Expected.hs
@@ -0,0 +1,6 @@
+module LocalDecls2Expected where
+
+foo a = bar a
+ where
+ nn :: Int
+ nn = 2
diff --git a/tests/examples/MagicHash.hs b/tests/examples/MagicHash.hs
new file mode 100644
index 0000000..a5912e5
--- /dev/null
+++ b/tests/examples/MagicHash.hs
@@ -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 <>
+
+
diff --git a/tests/examples/MangledSemiLet.hs b/tests/examples/MangledSemiLet.hs
new file mode 100644
index 0000000..902a118
--- /dev/null
+++ b/tests/examples/MangledSemiLet.hs
@@ -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
diff --git a/tests/examples/Minimal.hs b/tests/examples/Minimal.hs
new file mode 100644
index 0000000..7291854
--- /dev/null
+++ b/tests/examples/Minimal.hs
@@ -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) #-}
diff --git a/tests/examples/MultiImplicitParams.hs b/tests/examples/MultiImplicitParams.hs
new file mode 100644
index 0000000..4d07a85
--- /dev/null
+++ b/tests/examples/MultiImplicitParams.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE ImplicitParams #-}
+
+foo = do
+ ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos
+ ?buttonChanges = _button
+ in sink
+ return baz
diff --git a/tests/examples/MultiLineCommentWithPragmas.hs b/tests/examples/MultiLineCommentWithPragmas.hs
new file mode 100644
index 0000000..e900f31
--- /dev/null
+++ b/tests/examples/MultiLineCommentWithPragmas.hs
@@ -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
+-}
+
diff --git a/tests/examples/MultiLineWarningPragma.hs b/tests/examples/MultiLineWarningPragma.hs
new file mode 100644
index 0000000..970f9ea
--- /dev/null
+++ b/tests/examples/MultiLineWarningPragma.hs
@@ -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!"
+ #-}
diff --git a/tests/examples/MultiWayIf.hs b/tests/examples/MultiWayIf.hs
new file mode 100644
index 0000000..585157e
--- /dev/null
+++ b/tests/examples/MultiWayIf.hs
@@ -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
diff --git a/tests/examples/MultipleInferredContexts.hs b/tests/examples/MultipleInferredContexts.hs
new file mode 100644
index 0000000..3a21e86
--- /dev/null
+++ b/tests/examples/MultipleInferredContexts.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+
+f :: (Eq a, _, _) => a -> a -> Bool
+f x y = x == y
diff --git a/tests/examples/NestedDoLambda.hs b/tests/examples/NestedDoLambda.hs
new file mode 100644
index 0000000..8b8deef
--- /dev/null
+++ b/tests/examples/NestedDoLambda.hs
@@ -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."
+
diff --git a/tests/examples/NestedLambda.hs b/tests/examples/NestedLambda.hs
new file mode 100644
index 0000000..79f811c
--- /dev/null
+++ b/tests/examples/NestedLambda.hs
@@ -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
diff --git a/tests/examples/Obscure.hs b/tests/examples/Obscure.hs
new file mode 100644
index 0000000..1c2eef6
--- /dev/null
+++ b/tests/examples/Obscure.hs
@@ -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))
diff --git a/tests/examples/OptSig.hs b/tests/examples/OptSig.hs
new file mode 100644
index 0000000..649129e
--- /dev/null
+++ b/tests/examples/OptSig.hs
@@ -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)))
diff --git a/tests/examples/OptSig2.hs b/tests/examples/OptSig2.hs
new file mode 100644
index 0000000..8f3a837
--- /dev/null
+++ b/tests/examples/OptSig2.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+errors= do
+ let ls :: Int = undefined
+ return ()
diff --git a/tests/examples/OveridingPrimitives.hs b/tests/examples/OveridingPrimitives.hs
new file mode 100644
index 0000000..212e9da
--- /dev/null
+++ b/tests/examples/OveridingPrimitives.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts)
+(~#) = cascadeW
+infixr 0 ~#
diff --git a/tests/examples/PatSigBind.hs b/tests/examples/PatSigBind.hs
new file mode 100644
index 0000000..f6e5901
--- /dev/null
+++ b/tests/examples/PatSigBind.hs
@@ -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
diff --git a/tests/examples/PatternGuards.hs b/tests/examples/PatternGuards.hs
new file mode 100644
index 0000000..5ace1e3
--- /dev/null
+++ b/tests/examples/PatternGuards.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE PatternGuards #-}
+
+match n
+ | Just 5 <- Just n
+ , Just 6 <- Nothing
+ , Just 7 <- Just 9
+ = Just 8
diff --git a/tests/examples/ProcNotation.hs b/tests/examples/ProcNotation.hs
new file mode 100644
index 0000000..8c9e7dd
--- /dev/null
+++ b/tests/examples/ProcNotation.hs
@@ -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)
diff --git a/tests/examples/Pseudonym.hs b/tests/examples/Pseudonym.hs
new file mode 100644
index 0000000..e5113f1
--- /dev/null
+++ b/tests/examples/Pseudonym.hs
@@ -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
+
diff --git a/tests/examples/PuncFunctions.hs b/tests/examples/PuncFunctions.hs
new file mode 100644
index 0000000..64285f4
--- /dev/null
+++ b/tests/examples/PuncFunctions.hs
@@ -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
diff --git a/tests/examples/QuasiQuote.hs b/tests/examples/QuasiQuote.hs
index 1ca4508..e29fad7 100644
--- a/tests/examples/QuasiQuote.hs
+++ b/tests/examples/QuasiQuote.hs
@@ -17,3 +17,15 @@ px1 [qq|p1|] = undefined
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"))
+
diff --git a/tests/examples/RSA.hs b/tests/examples/RSA.hs
new file mode 100644
index 0000000..db6a01f
--- /dev/null
+++ b/tests/examples/RSA.hs
@@ -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
diff --git a/tests/examples/RdrNames.hs b/tests/examples/RdrNames.hs
index a5d578e..211edf2 100644
--- a/tests/examples/RdrNames.hs
+++ b/tests/examples/RdrNames.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-}
module RdrNames where
import Data.Monoid
@@ -81,6 +82,9 @@ ng = undefined
ft :: (->) a b
ft = undefined
+fp :: ( -> ) a b
+fp = undefined
+
type family F a :: * -> * -> *
type instance F Int = (->)
type instance F Char = ( , )
@@ -108,6 +112,14 @@ lt = undefined
-- 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)
+
-- ---------------------------------------------------------------------
diff --git a/tests/examples/RecordSemi.hs b/tests/examples/RecordSemi.hs
new file mode 100644
index 0000000..e06c049
--- /dev/null
+++ b/tests/examples/RecordSemi.hs
@@ -0,0 +1,15 @@
+-- | Generate a generate statement for the builtin function "fst"
+genFst :: BuiltinBuilder
+genFst = genNoInsts genFst'
+genFst' :: (Either CoreSyn.CoreBndr AST.VHDLName) -> CoreSyn.CoreBndr -> [(Either CoreSyn.CoreExpr AST.Expr, Type.Type)] -> TranslatorSession [AST.ConcSm]
+genFst' res f args@[(arg,argType)] = do {
+ ; arg_htype <- MonadState.lift tsType $ mkHType "\nGenerate.genFst: Invalid argument type" argType
+ ; [AST.PrimName argExpr] <- argsToVHDLExprs [arg]
+ ; let {
+ ; labels = getFieldLabels arg_htype 0
+ ; argexprA = vhdlNameToVHDLExpr $ mkSelectedName argExpr (labels!!0)
+ ; assign = mkUncondAssign res argexprA
+ } ;
+ -- Return the generate functions
+ ; return [assign]
+ }
diff --git a/tests/examples/RecordWildcard.hs b/tests/examples/RecordWildcard.hs
new file mode 100644
index 0000000..b437608
--- /dev/null
+++ b/tests/examples/RecordWildcard.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE RecordWildCards #-}
+
+
+parseArgs =
+ Args
+ { equalProb = E `elem` opts
+ , ..
+ }
diff --git a/tests/examples/RecursiveDo.hs b/tests/examples/RecursiveDo.hs
index e4f631a..458fb9b 100644
--- a/tests/examples/RecursiveDo.hs
+++ b/tests/examples/RecursiveDo.hs
@@ -52,3 +52,6 @@ inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" []
ti = impureMin budget inviteTree
+simplemdo = mdo
+ return 5
+
diff --git a/tests/examples/Remorse.hs b/tests/examples/Remorse.hs
new file mode 100644
index 0000000..1e424e8
--- /dev/null
+++ b/tests/examples/Remorse.hs
@@ -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;
diff --git a/tests/examples/RmDecl1.hs b/tests/examples/RmDecl1.hs
new file mode 100644
index 0000000..f2350ad
--- /dev/null
+++ b/tests/examples/RmDecl1.hs
@@ -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
diff --git a/tests/examples/RmDecl1.hs.expected b/tests/examples/RmDecl1.hs.expected
new file mode 100644
index 0000000..f9d1af2
--- /dev/null
+++ b/tests/examples/RmDecl1.hs.expected
@@ -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
diff --git a/tests/examples/RmDecl2.hs b/tests/examples/RmDecl2.hs
new file mode 100644
index 0000000..2f0dbd3
--- /dev/null
+++ b/tests/examples/RmDecl2.hs
@@ -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
+
diff --git a/tests/examples/RmDecl2.hs.expected b/tests/examples/RmDecl2.hs.expected
new file mode 100644
index 0000000..d77b760
--- /dev/null
+++ b/tests/examples/RmDecl2.hs.expected
@@ -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
+
diff --git a/tests/examples/RmTypeSig1.hs b/tests/examples/RmTypeSig1.hs
new file mode 100644
index 0000000..250267f
--- /dev/null
+++ b/tests/examples/RmTypeSig1.hs
@@ -0,0 +1,7 @@
+module RmTypeSig1 where
+
+sq,anotherFun :: Int -> Int
+sq 0 = 0
+sq z = z^2
+
+anotherFun x = x^2
diff --git a/tests/examples/RmTypeSig1.hs.expected b/tests/examples/RmTypeSig1.hs.expected
new file mode 100644
index 0000000..42507c7
--- /dev/null
+++ b/tests/examples/RmTypeSig1.hs.expected
@@ -0,0 +1,7 @@
+module RmTypeSig1 where
+
+anotherFun :: Int -> Int
+sq 0 = 0
+sq z = z^2
+
+anotherFun x = x^2
diff --git a/tests/examples/Rules.hs b/tests/examples/Rules.hs
index 65a0c0f..6827a5d 100644
--- a/tests/examples/Rules.hs
+++ b/tests/examples/Rules.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
module Rules where
import Data.Char
diff --git a/tests/examples/RulesSemi.hs b/tests/examples/RulesSemi.hs
new file mode 100644
index 0000000..f3f832a
--- /dev/null
+++ b/tests/examples/RulesSemi.hs
@@ -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
+ #-};
diff --git a/tests/examples/SemiInstance.hs b/tests/examples/SemiInstance.hs
new file mode 100644
index 0000000..5944f7b
--- /dev/null
+++ b/tests/examples/SemiInstance.hs
@@ -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;
+}
diff --git a/tests/examples/SemiWorkout.hs b/tests/examples/SemiWorkout.hs
new file mode 100644
index 0000000..3dcb9d3
--- /dev/null
+++ b/tests/examples/SemiWorkout.hs
@@ -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)
+ }
diff --git a/tests/examples/Shebang.hs b/tests/examples/Shebang.hs
new file mode 100644
index 0000000..13e5b9c
--- /dev/null
+++ b/tests/examples/Shebang.hs
@@ -0,0 +1,5 @@
+#!/usr/bin/env runhaskell
+{-# LANGUAGE OverloadedStrings #-}
+import Aws.SSSP.App
+
+main = web
diff --git a/tests/examples/ShiftingLambda.hs b/tests/examples/ShiftingLambda.hs
new file mode 100644
index 0000000..b31896a
--- /dev/null
+++ b/tests/examples/ShiftingLambda.hs
@@ -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
diff --git a/tests/examples/Simple.hs b/tests/examples/Simple.hs
index 806fa8e..911857f 100644
--- a/tests/examples/Simple.hs
+++ b/tests/examples/Simple.hs
@@ -1,6 +1,4 @@
--- A simple let statement, to ensure the layout is detected
-
--- module Layout.Simple where
+-- blah
x = 1
diff --git a/tests/examples/SimpleComplexTuple.hs b/tests/examples/SimpleComplexTuple.hs
new file mode 100644
index 0000000..e1e5948
--- /dev/null
+++ b/tests/examples/SimpleComplexTuple.hs
@@ -0,0 +1,3 @@
+
+
+foo ((-),(.))= (5,6)
diff --git a/tests/examples/SlidingDataClassDecl.hs b/tests/examples/SlidingDataClassDecl.hs
new file mode 100644
index 0000000..94e2e07
--- /dev/null
+++ b/tests/examples/SlidingDataClassDecl.hs
@@ -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)]
diff --git a/tests/examples/SlidingDoClause.hs b/tests/examples/SlidingDoClause.hs
new file mode 100644
index 0000000..6e03ff9
--- /dev/null
+++ b/tests/examples/SlidingDoClause.hs
@@ -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
+ }
diff --git a/tests/examples/SlidingLambda.hs b/tests/examples/SlidingLambda.hs
new file mode 100644
index 0000000..1003aa8
--- /dev/null
+++ b/tests/examples/SlidingLambda.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE ImplicitParams #-}
+
+foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps
diff --git a/tests/examples/SlidingListComp.hs b/tests/examples/SlidingListComp.hs
new file mode 100644
index 0000000..7d9f0c8
--- /dev/null
+++ b/tests/examples/SlidingListComp.hs
@@ -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]
diff --git a/tests/examples/SlidingRecordSetter.hs b/tests/examples/SlidingRecordSetter.hs
new file mode 100644
index 0000000..b51d120
--- /dev/null
+++ b/tests/examples/SlidingRecordSetter.hs
@@ -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)
diff --git a/tests/examples/SlidingTypeSyn.hs b/tests/examples/SlidingTypeSyn.hs
new file mode 100644
index 0000000..1a60d1f
--- /dev/null
+++ b/tests/examples/SlidingTypeSyn.hs
@@ -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
diff --git a/tests/examples/SpacesSplice.hs b/tests/examples/SpacesSplice.hs
new file mode 100644
index 0000000..62f5cd6
--- /dev/null
+++ b/tests/examples/SpacesSplice.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+makeLenses '' PostscriptFont
diff --git a/tests/examples/SpliceSemi.hs b/tests/examples/SpliceSemi.hs
new file mode 100644
index 0000000..9c7e868
--- /dev/null
+++ b/tests/examples/SpliceSemi.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+
+$(makePredicates ''TheType) ; $(makePredicatesNot ''TheType)
diff --git a/tests/examples/StrangeTypeClass.hs b/tests/examples/StrangeTypeClass.hs
new file mode 100644
index 0000000..374cc53
--- /dev/null
+++ b/tests/examples/StrangeTypeClass.hs
@@ -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
diff --git a/tests/examples/StringGap.hs b/tests/examples/StringGap.hs
new file mode 100644
index 0000000..6f5d44f
--- /dev/null
+++ b/tests/examples/StringGap.hs
@@ -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"
diff --git a/tests/examples/T10196.hs b/tests/examples/T10196.hs
new file mode 100644
index 0000000..f809118
--- /dev/null
+++ b/tests/examples/T10196.hs
@@ -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ᵣ
diff --git a/tests/examples/T5951.hs b/tests/examples/T5951.hs
new file mode 100644
index 0000000..ea0e2c4
--- /dev/null
+++ b/tests/examples/T5951.hs
@@ -0,0 +1,11 @@
+module T5951 where
+
+class A a
+class B b
+class C c
+
+instance
+ A =>
+ B =>
+ C where
+ foo = undefined
diff --git a/tests/examples/THMonadInstance.hs b/tests/examples/THMonadInstance.hs
new file mode 100644
index 0000000..723227a
--- /dev/null
+++ b/tests/examples/THMonadInstance.hs
@@ -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 ]
+ )
+ |]
diff --git a/tests/examples/TemplateHaskell.hs b/tests/examples/TemplateHaskell.hs
new file mode 100644
index 0000000..1186ab1
--- /dev/null
+++ b/tests/examples/TemplateHaskell.hs
@@ -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]))||]
diff --git a/tests/examples/TooManyAnnVal.hs b/tests/examples/TooManyAnnVal.hs
new file mode 100644
index 0000000..1132675
--- /dev/null
+++ b/tests/examples/TooManyAnnVal.hs
@@ -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)))
diff --git a/tests/examples/TransformListComp.hs b/tests/examples/TransformListComp.hs
new file mode 100644
index 0000000..9bf2591
--- /dev/null
+++ b/tests/examples/TransformListComp.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TransformListComp #-}
+
+oldest :: [Int] -> [String]
+oldest tbl = [ "str"
+ | n <- tbl
+ , then id
+ ]
diff --git a/tests/examples/TupleSections.hs b/tests/examples/TupleSections.hs
new file mode 100644
index 0000000..aa58be0
--- /dev/null
+++ b/tests/examples/TupleSections.hs
@@ -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 = (,,(),,,())
diff --git a/tests/examples/TypeBrackets.hs b/tests/examples/TypeBrackets.hs
new file mode 100644
index 0000000..ed14bfb
--- /dev/null
+++ b/tests/examples/TypeBrackets.hs
@@ -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
+
diff --git a/tests/examples/TypeBrackets2.hs b/tests/examples/TypeBrackets2.hs
new file mode 100644
index 0000000..dbd52f2
--- /dev/null
+++ b/tests/examples/TypeBrackets2.hs
@@ -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
diff --git a/tests/examples/TypeBrackets3.hs b/tests/examples/TypeBrackets3.hs
new file mode 100644
index 0000000..e8827ba
--- /dev/null
+++ b/tests/examples/TypeBrackets3.hs
@@ -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)
diff --git a/tests/examples/TypeBrackets4.hs b/tests/examples/TypeBrackets4.hs
new file mode 100644
index 0000000..d1fc8c7
--- /dev/null
+++ b/tests/examples/TypeBrackets4.hs
@@ -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
diff --git a/tests/examples/TypeFamilies.hs b/tests/examples/TypeFamilies.hs
index 819877e..31d3c37 100644
--- a/tests/examples/TypeFamilies.hs
+++ b/tests/examples/TypeFamilies.hs
@@ -61,3 +61,17 @@ storePresents xs = do
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
diff --git a/tests/examples/TypeFamilies2.hs b/tests/examples/TypeFamilies2.hs
new file mode 100644
index 0000000..277475c
--- /dev/null
+++ b/tests/examples/TypeFamilies2.hs
@@ -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 = ( , )
diff --git a/tests/examples/TypeInstance.hs b/tests/examples/TypeInstance.hs
new file mode 100644
index 0000000..76bc845
--- /dev/null
+++ b/tests/examples/TypeInstance.hs
@@ -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
diff --git a/tests/examples/TypeSignatureParens.hs b/tests/examples/TypeSignatureParens.hs
new file mode 100644
index 0000000..beb29ea
--- /dev/null
+++ b/tests/examples/TypeSignatureParens.hs
@@ -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"
diff --git a/tests/examples/TypeSynOperator.hs b/tests/examples/TypeSynOperator.hs
new file mode 100644
index 0000000..77c5832
--- /dev/null
+++ b/tests/examples/TypeSynOperator.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE TypeOperators #-}
+
+type a :-> t = a
diff --git a/tests/examples/TypeSynParens.hs b/tests/examples/TypeSynParens.hs
new file mode 100644
index 0000000..c0e5b64
--- /dev/null
+++ b/tests/examples/TypeSynParens.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TypeFamilies #-}
+
+class Compilable a where
+ type CompileResult a :: *
+
+instance Compilable a => Compilable [a] where
+ type CompileResult [a] = [CompileResult a]
+
+instance Compilable a => Compilable (Maybe a) where
+ type CompileResult (Maybe a) = Maybe (CompileResult a)
+
+instance Compilable InterpreterStmt where
+ type CompileResult InterpreterStmt = [Hask.Stmt]
+
+instance Compilable ModuleSpan where
+ type CompileResult ModuleSpan = Hask.Module
+
+instance Compilable StatementSpan where
+ type (CompileResult StatementSpan) = [Stmt]
diff --git a/tests/examples/Undefined10.hs b/tests/examples/Undefined10.hs
new file mode 100644
index 0000000..af377c0
--- /dev/null
+++ b/tests/examples/Undefined10.hs
@@ -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 ())
diff --git a/tests/examples/Undefined11.hs b/tests/examples/Undefined11.hs
new file mode 100644
index 0000000..c16e0bf
--- /dev/null
+++ b/tests/examples/Undefined11.hs
@@ -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
diff --git a/tests/examples/Undefined13.hs b/tests/examples/Undefined13.hs
new file mode 100644
index 0000000..bb561e7
--- /dev/null
+++ b/tests/examples/Undefined13.hs
@@ -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 }
+
+|]
diff --git a/tests/examples/Undefined2.hs b/tests/examples/Undefined2.hs
new file mode 100644
index 0000000..ec13eed
--- /dev/null
+++ b/tests/examples/Undefined2.hs
@@ -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
+
diff --git a/tests/examples/Undefined3.hs b/tests/examples/Undefined3.hs
new file mode 100644
index 0000000..3ddf0cc
--- /dev/null
+++ b/tests/examples/Undefined3.hs
@@ -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 [])
+
diff --git a/tests/examples/Undefined4.hs b/tests/examples/Undefined4.hs
new file mode 100644
index 0000000..e69d2b3
--- /dev/null
+++ b/tests/examples/Undefined4.hs
@@ -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)
+
diff --git a/tests/examples/Undefined5.hs b/tests/examples/Undefined5.hs
new file mode 100644
index 0000000..960739b
--- /dev/null
+++ b/tests/examples/Undefined5.hs
@@ -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"
diff --git a/tests/examples/Undefined6.hs b/tests/examples/Undefined6.hs
new file mode 100644
index 0000000..cd5a64d
--- /dev/null
+++ b/tests/examples/Undefined6.hs
@@ -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
diff --git a/tests/examples/Undefined7.hs b/tests/examples/Undefined7.hs
new file mode 100644
index 0000000..32f7c0c
--- /dev/null
+++ b/tests/examples/Undefined7.hs
@@ -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."
+
diff --git a/tests/examples/Undefined8.hs b/tests/examples/Undefined8.hs
new file mode 100644
index 0000000..8ed5ba5
--- /dev/null
+++ b/tests/examples/Undefined8.hs
@@ -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 }
+
+|]
diff --git a/tests/examples/Undefined9.hs b/tests/examples/Undefined9.hs
new file mode 100644
index 0000000..816ff29
--- /dev/null
+++ b/tests/examples/Undefined9.hs
@@ -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"
+
+|]
diff --git a/tests/examples/Unicode.hs b/tests/examples/Unicode.hs
new file mode 100644
index 0000000..d5015d9
--- /dev/null
+++ b/tests/examples/Unicode.hs
@@ -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
diff --git a/tests/examples/UnicodeRules.hs b/tests/examples/UnicodeRules.hs
new file mode 100644
index 0000000..6add832
--- /dev/null
+++ b/tests/examples/UnicodeRules.hs
@@ -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)
diff --git a/tests/examples/UnicodeSyntax.hs b/tests/examples/UnicodeSyntax.hs
new file mode 100644
index 0000000..c661b8c
--- /dev/null
+++ b/tests/examples/UnicodeSyntax.hs
@@ -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)
+ }
+
diff --git a/tests/examples/UnicodeSyntaxFailure.hs b/tests/examples/UnicodeSyntaxFailure.hs
new file mode 100644
index 0000000..c40d06a
--- /dev/null
+++ b/tests/examples/UnicodeSyntaxFailure.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE UnicodeSyntax #-}
+
+foo x = addToEnv (∀)
diff --git a/tests/examples/Utils2.hs b/tests/examples/Utils2.hs
index 48d0251..64065ef 100644
--- a/tests/examples/Utils2.hs
+++ b/tests/examples/Utils2.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
module Utils2 where
@@ -13,7 +12,7 @@ import Data.Maybe
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
diff --git a/tests/examples/WhereIn3.hs b/tests/examples/WhereIn3.hs
new file mode 100644
index 0000000..e9a3a65
--- /dev/null
+++ b/tests/examples/WhereIn3.hs
@@ -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
diff --git a/tests/examples/WhereIn3.hs.expected b/tests/examples/WhereIn3.hs.expected
new file mode 100644
index 0000000..03913b0
--- /dev/null
+++ b/tests/examples/WhereIn3.hs.expected
@@ -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
diff --git a/tests/examples/WhereIn3a.hs b/tests/examples/WhereIn3a.hs
new file mode 100644
index 0000000..0657422
--- /dev/null
+++ b/tests/examples/WhereIn3a.hs
@@ -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
diff --git a/tests/examples/WhereIn3a.hs.expected b/tests/examples/WhereIn3a.hs.expected
new file mode 100644
index 0000000..9b16bf0
--- /dev/null
+++ b/tests/examples/WhereIn3a.hs.expected
@@ -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