ghc-exactprint-0.6.2/0000755000000000000000000000000007346545000012630 5ustar0000000000000000ghc-exactprint-0.6.2/ChangeLog0000755000000000000000000001411507346545000014407 0ustar00000000000000002019-08-28 v0.6.2 * Support GHC 8.8.1 (release candidate) 2019-05-27 v0.6.1 * Support GHC 8.8 (alpha1) 2019-03-01 v0.6 * Remove orphan MonadFail Identity instance * MonadFail TransformT instance is defined unconditionally * Generalise HasTransform (TransformT Identity) to Monad m => HasTransform (TransformT m) * Add hoistTransform function The 0.6 changes are all thanks to @phadej 2018-10-27 v0.5.8.2 * Support GHC 8.4.4 by selecting correct source directory 2018-09-23 v0.5.8.1 * Sort out MonadFail usage for GHC 8.6.1 2018-09-12 v0.5.8.0 * Disable use of .ghc.env files when parsing. By @lspitzner 2018-08-11 v0.5.7.0 * Include support for GHC 8.6.1 beta 1 2018-07-11 v0.5.7.0 * Include support for GHC 8.6.1 alpha 1 2018-03-11 v0.5.6.1 * Relax base constraints so tests can configure with GHC 8.4.1 2018-01-27 v0.5.6.0 * Support GHC 8.4 alpha2 * Include test examples for GHC 8.2 * Fix parseModuleFromString to correctly handle the sheband case (@lspitzner) 2017-07-23 v0.5.5.0 * Support GHC 8.2.1 2017-05-17 v0.5.4.0 * Support GHC 8.2 (rc2) 2017-05-05 v0.5.3.1 * Fix bug roundtripping optional semicolons on if statements. 2017-02-07 v0.5.3.0 * Support GHC 8.0.2 * Correct the logic around RigidLayout to function as originally intended. * Introduce Pretty module to add default annotations to a bare AST fragment, so that it can be printed correctly via exactprint. In this case, "correct" is defined as generating the same AST if parsed again, it may not be beautiful layout. * Expose some additional internal parsing options (@lspitzner) 2016-07-24 v0.5.2.1 * Remove additional files from release tarball 2016-07-24 v0.5.2 * Move annotations from the `RdrName` to `HsVar` and `PatVar` for consistency. 2016-06-03 v0.5.1.1 * Fix haddocks for GHC 8.0 (@phadej) * Add test files for ghc710-only to dist tarball (#41) 2016-06-02 v0.5.1.0 * Support for GHC 8.0.1 * Add graftT to the Transform module, courtesy of @xich * Add semi-pure parsing function, courtesy of @lspitzner 2015-12-13 v0.5.0.1 * Fix a bug (#34) where quasiquote values would not roundtrip. 2015-11-21 v0.5 * Add new options to enable "rigid" layout rules. This makes the annotations more rigid in the sense that if you move AST fragments around it is more likely that their internal components will remain in the same position relative to each other. * Fix a bug where files failed to parse if the file started with comments. * Fix a bug where "[e||" was turned into "[||" 2015-11-15 v0.4.2 * Fix round tripping of arrow notation using ">-" and ">>-". 2015-09-28 v0.4.1 * Revert removing cast from markLocated until further inspection in HaRe. 2015-09-28 v0.4.0.0 * Rework HasDecls so that there are only instances for which it is idempotent. Provide functions for managing an LHsBind which is not idempotent, and performing general transformations on an AST including FunBinds. * Manage LHsDecl instances so that the Annotation always attaches to the wrapped item, so that they can be seamlessly used in a top level (wrapped) or local (unwrapped) context. * Tweak transformations based on HaRe integration. * This release supports the HaRe 8.0 release, which finally works with GHC 7.10.2 * Rename `exactPrintWithAnns` to `exactPrint`. This will possibly break earlier client libraries, but is a simple rename. * Bring in semanticPrintM which allows wrapper functions to be provided for the generated output, for use when emitting e.g. HTML marked up source. 2015-08-13 v0.3.1.1 * Add missing test files to sdist, closes #23 2015-08-02 v0.3.1 * Mark LHS at the beginning of HsCase and HsIf expressions * Mark trailing semi colons on ANN pragmas * Correctly mark trailing semi colons distinctly from internal semicolons * setPrecedingLinesDecl applies the setting to both the Decl and the item wrapped in the Decl. 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. The external interface has also changed significantly. A description is omitted. # Top-level changes The most notable change is that the common structor of the modules known as `ExactPrint` and `Annotate` has been factored out into a common module (`Annotate`). The aforementioned modules are now known as `Delta` and `Print` and contain functions to interpret this common structure. The top level module `ExactPrint` now just reexports a consistent interface from the base modules. Introduced a new module `Lookup` which contains a mapping from AnnKeywordId to their String representation. # Internal Changes `Annotate` contains all the information about which annotations appear on each AST element. This is achieved by building up a syntax tree (using a free monad) which can then be interpreted by programs requiring access to this information. # Layout compensation The method which compensates for layout rules has been clarified. 1. When the Layout Flag is activated in `Annotate`, we mark the current column as the start of the layout block. 2. This is important when we move to a new line. We take the offset at that current point to be the baseline and calculate the correct next position based on this. 3. This method is very general as one can think of a entire source file as obeying layout rules where the offset is equal to zero. 2015-03-11 v0.1.1.0 Handles indentation when the AST is edited Major rework of internal monads by @mpickering 2015-01-28 v0.1.0.1 Update cabal to prevent building with GHC 7.70,thanks @peti 2015-01-24 v0.1.0.0 Initial release, for GHC 7.10 RC 2 ghc-exactprint-0.6.2/LICENSE0000644000000000000000000000276607346545000013650 0ustar0000000000000000Copyright (c) 2014, Alan Zimmerman All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Alan Zimmerman nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ghc-exactprint-0.6.2/Setup.hs0000644000000000000000000000005607346545000014265 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-exactprint-0.6.2/ghc-exactprint.cabal0000644000000000000000000002026007346545000016534 0ustar0000000000000000name: ghc-exactprint version: 0.6.2 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can 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 . * Transform - functions to facilitate changes to the AST, adjusting the annotations generated in the Delta phase to suit the changes. . * Print - converts an AST and its annotations to properly formatted source text. . * Pretty - adds annotations to an AST (fragment) so that the output can be parsed back to the same AST. . . Note: requires GHC 7.10.2 or later license: BSD3 license-file: LICENSE author: Alan Zimmerman, Matthew Pickering maintainer: alan.zimm@gmail.com category: Development build-type: Simple tested-with: GHC == 7.10.3 , GHC == 8.0.1 , GHC == 8.0.2 , GHC == 8.2.2 , GHC == 8.4.2 , GHC == 8.4.3 , GHC == 8.4.4 , GHC == 8.6.1 , GHC == 8.6.2 , GHC == 8.6.4 , GHC == 8.6.5 extra-source-files: ChangeLog src-ghc710/Language/Haskell/GHC/ExactPrint/*.hs tests/examples/failing/*.hs tests/examples/ghc710/*.hs tests/examples/ghc710-only/*.hs tests/examples/ghc80/*.hs tests/examples/ghc82/*.hs tests/examples/ghc84/*.hs tests/examples/ghc86/*.hs tests/examples/ghc88/*.hs tests/examples/pre-ghc86/*.hs tests/examples/vect/*.hs tests/examples/transform/*.hs tests/examples/failing/*.hs.bad tests/examples/transform/*.hs.expected tests/examples/ghc710/*.hs-boot cabal-version: >=1.10 source-repository head type: git location: https://github.com/alanz/ghc-exactprint.git Flag roundtrip { Description: Build roundtripping executables Default: False } Flag dev { Description: Development mode, do not use ghc-exactprint lib in the tests Default: False } library exposed-modules: Language.Haskell.GHC.ExactPrint , Language.Haskell.GHC.ExactPrint.Annotate , Language.Haskell.GHC.ExactPrint.AnnotateTypes , Language.Haskell.GHC.ExactPrint.Annotater , Language.Haskell.GHC.ExactPrint.Delta , Language.Haskell.GHC.ExactPrint.Lookup , Language.Haskell.GHC.ExactPrint.Parsers , Language.Haskell.GHC.ExactPrint.Preprocess , Language.Haskell.GHC.ExactPrint.Pretty , Language.Haskell.GHC.ExactPrint.Print , Language.Haskell.GHC.ExactPrint.Transform , Language.Haskell.GHC.ExactPrint.Types , Language.Haskell.GHC.ExactPrint.Utils if impl (ghc <= 8.0.2) exposed-modules: Language.Haskell.GHC.ExactPrint.GhcInterim -- other-modules: -- other-extensions: GHC-Options: -Wall build-depends: base >=4.8 && <4.14 , bytestring >= 0.10.6 , containers >= 0.5 , directory >= 1.2 , filepath >= 1.4 , ghc >= 7.10.2 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 , free >= 4.12 if !impl (ghc >= 8.0) build-depends: fail >= 4.9 && <4.10 if impl (ghc >= 7.11) build-depends: ghc-boot hs-source-dirs: src if impl (ghc > 8.6.5) hs-source-dirs: src-ghc88 else if impl (ghc > 8.4.4) hs-source-dirs: src-ghc86 else if impl (ghc > 8.2.2) hs-source-dirs: src-ghc84 else if impl (ghc > 8.0.3) hs-source-dirs: src-ghc82 else if impl (ghc > 7.10.3) hs-source-dirs: src-ghc80 else hs-source-dirs: src-ghc710 default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False Test-Suite test type: exitcode-stdio-1.0 if flag (dev) hs-source-dirs: tests src else hs-source-dirs: tests if impl (ghc > 8.6.5) hs-source-dirs: src-ghc88 else if impl (ghc > 8.4.4) hs-source-dirs: src-ghc86 else if impl (ghc > 8.2.2) hs-source-dirs: src-ghc84 else if impl (ghc > 8.0.3) hs-source-dirs: src-ghc82 else if impl (ghc > 7.10.3) hs-source-dirs: src-ghc80 else hs-source-dirs: src-ghc710 main-is: Test.hs other-modules: Test.Common , Test.Consistency , Test.NoAnnotations , Test.Transform GHC-Options: -threaded -Wall Default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False Build-depends: HUnit >= 1.2 , base < 4.14 , bytestring , containers >= 0.5 , Diff , directory >= 1.2 , filepath >= 1.4 , ghc >= 7.10.2 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 , silently >= 1.2 , filemanip >= 0.3 -- for the lib only if !impl (ghc >= 8.0) build-depends: fail >= 4.9 && <4.10 if flag (dev) build-depends: free else build-depends: ghc-exactprint if impl (ghc >= 7.11) build-depends: ghc-boot executable roundtrip main-is: Roundtrip.hs hs-source-dirs: tests other-modules: Test.Common Test.CommonUtils Test.Consistency 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 , time if impl (ghc >= 7.11) build-depends: ghc-boot buildable: True else buildable: False ghc-options: -threaded -Wall executable static main-is: Static.hs hs-source-dirs: tests default-language: Haskell2010 if flag (roundtrip) build-depends: base , directory , filemanip , filepath , ghc , Diff buildable: True if impl (ghc >= 7.11) build-depends: ghc-boot else buildable: False ghc-options: -threaded -Wall executable prepare-hackage main-is: PrepareHackage.hs hs-source-dirs: tests default-language: Haskell2010 if flag (roundtrip) build-depends: base , containers , directory , filemanip , filepath , ghc >= 7.10.2 , ghc-paths >= 0.1 , HUnit , text >= 1.2.2 , turtle >= 1.3.0 buildable: True if impl (ghc >= 7.11) build-depends: ghc-boot else buildable: False GHC-Options: -threaded ghc-exactprint-0.6.2/src-ghc710/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022176 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000026202107346545000024470 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.RdrName) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,_fs) = do markExternal l GHC.AnnVal src -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LIE name] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance (GHC.DataId name,GHC.HasOccName name, Annotate name) => Annotate (GHC.IE name) where markAST _ ie = do case ie of (GHC.IEVar ln) -> do -- TODO: I am pretty sure this criterion is inadequate if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln then mark GHC.AnnPattern else markOptional GHC.AnnPattern setContext (Set.fromList [PrefixOp,InIE]) $ 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. -} if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n) then do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln else setContext (Set.singleton PrefixOp) $ markLocated ln (GHC.IEThingWith ln ns) -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnCloseP (GHC.IEThingAll ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup _ _) -> return () (GHC.IEDoc _) -> return () (GHC.IEDocNamed _) -> return () ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- {- -- 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) -} isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n canParen = isSym && rdrName2String n /= "$" doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType markOptional GHC.AnnType let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> markExternal l GHC.AnnVal str GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' "~" -> do mark GHC.AnnOpenP mark GHC.AnnTilde mark GHC.AnnCloseP _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- -- TODO: What is this used for? Not in ExactPrint instance Annotate GHC.Name where markAST l n = do markExternal l GHC.AnnVal (showGhc n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ImportDecl name) where markAST _ imp@(GHC.ImportDecl msrc modname mpkg src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) >> markWithString GHC.AnnClose "#-}") when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Nothing -> return () Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markWithString GHC.AnnVal (GHC.moduleNameString mn) case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsDecl name -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD d -> markLocated (GHC.L l d) GHC.InstD d -> markLocated (GHC.L l d) 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) GHC.QuasiQuoteD d -> markLocated (GHC.L l d) instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsDecl name) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.RoleAnnotDecl name) where markAST _ (GHC.RoleAnnotDecl ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.SpliceDecl name) where markAST _ (GHC.SpliceDecl e flag) = do case flag of GHC.ExplicitSplice -> mark GHC.AnnOpenPE GHC.ImplicitSplice -> return () setContext (Set.singleton InSpliceDecl) $ markLocated e case flag of GHC.ExplicitSplice -> mark GHC.AnnCloseP GHC.ImplicitSplice -> return () markTrailingSemi {- - data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) - ImplicitSplice -- <=> f x y, i.e. a naked - top level expression - -} -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.VectDecl name) where markAST _ (GHC.HsVect src ln e) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" markLocated ln mark GHC.AnnEqual markLocated e markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsNoVect src ln) = do markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsVectTypeIn src _b ln mln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" mark GHC.AnnType markLocated ln case mln of Nothing -> return () Just lnn -> do mark GHC.AnnEqual markLocated lnn markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectTypeOut {} = traceM "warning: HsVectTypeOut appears after renaming" markAST _ (GHC.HsVectClassIn src ln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" mark GHC.AnnClass markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectClassOut {} = traceM "warning: HsVecClassOut appears after renaming" markAST _ GHC.HsVectInstIn {} = traceM "warning: HsVecInstsIn appears after renaming" markAST _ GHC.HsVectInstOut {} = traceM "warning: HsVecInstOut appears after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.RuleDecls name) where markAST _ (GHC.HsRules src rules) = do markWithString GHC.AnnOpen src setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- 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 setContext (Set.singleton ExplicitNeverActive) $ markActivation act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi -- --------------------------------------------------------------------- markActivation :: GHC.Activation -> Annotated () markActivation act = do case act of GHC.ActiveBefore n -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markWithString GHC.AnnVal (show n) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter n -> do mark GHC.AnnOpenS -- '[' markWithString GHC.AnnVal (show n) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.RuleBndr name) where markAST _ (GHC.RuleBndr ln) = markLocated ln markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLocated thing mark GHC.AnnCloseP -- ")" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.AnnDecl name) where markAST _ (GHC.HsAnnotation src prov e) = do markWithString GHC.AnnOpen src case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate name => Annotate (GHC.WarnDecls name) where markAST _ (GHC.Warnings src warns) = do markWithString GHC.AnnOpen src mapM_ markLocated warns markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.WarnDecl name) where markAST _ (GHC.Warning lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ForeignDecl name) where markAST _ (GHC.ForeignImport ln typ _ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternal ls GHC.AnnVal (show src) markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (show src) setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DerivDecl name) where markAST _ (GHC.DerivDecl typ mov) = do mark GHC.AnnDeriving mark GHC.AnnInstance markMaybe mov markLocated typ markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DefaultDecl name) where markAST _ (GHC.DefaultDecl typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.InstDecl name) where markAST l (GHC.ClsInstD cid) = markAST l cid markAST l (GHC.DataFamInstD dfid) = markAST l dfid markAST l (GHC.TyFamInstD tfid) = markAST l tfid -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where markAST _ (GHC.NoOverlap src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ClsInstDecl name) where markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- 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 inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional markLocated eqn markTrailingSemi -- --------------------------------------------------------------------- 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@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance markLocated ctx markTyClass ln pats if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsBind name) where markAST _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere markOptional GHC.AnnWhere markLocalBindsWithLayout lb markTrailingSemi markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixPatSyn la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixPatSyn ns -> do markLocated ln mapM_ markLocated ns case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- Introduced after renaming. markAST _ (GHC.AbsBinds _ _ _ _ _) = traceM "warning: AbsBinds introduced after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.IPBind name) where markAST _ (GHC.IPBind en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate (GHC.Match name (GHC.Located body)) where markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do let get_infix Nothing = False get_infix (Just (_,f)) = f isFunBind = isJust case (get_infix mln,pats) of (True, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of Nothing -> return () Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of -- Nothing -> mark GHC.AnnFunId Nothing -> markListNoPrecedingSpace False pats Just (n,_) -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n mapM_ markLocated pats -- markListNoPrecedingSpace pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, Annotate name, Annotate body) => Annotate (GHC.GRHS name (GHC.Located body)) where markAST _ (GHC.GRHS guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.Sig name) where markAST _ (GHC.TypeSig lns typ _) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLocated typ markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do mark GHC.AnnPattern markLocated ln mark GHC.AnnDcolon -- Note: The 'forall' bndrs '.' may occur multiple times unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1 markOffset GHC.AnnDarrow 0 when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2 markOffset GHC.AnnDarrow 1 markLocated typ markTrailingSemi markAST _ (GHC.GenericSig ns typ) = do mark GHC.AnnDefault -- markListIntercalate ns setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig _) = traceM "warning: Introduced after renaming" -- FixSig (FixitySig name) markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markWithString GHC.AnnVal (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi -- InlineSig (Located name) InlinePragma -- '{-# INLINE' activation qvar '#-}' markAST _ (GHC.InlineSig ln inl) = do markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' markActivation (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecSig ln typs inl) = do markWithString GHC.AnnOpen (GHC.inl_src inl) markActivation (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalate typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- '{-# SPECIALISE' 'instance' inst_type '#-}' markAST _ (GHC.SpecInstSig src typ) = do markWithString GHC.AnnOpen src mark GHC.AnnInstance markLocated typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- MinimalSig (BooleanFormula (Located name)) markAST _l (GHC.MinimalSig src formula) = do markWithString GHC.AnnOpen src annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] markAST _l formula finalizeBF _l markWithString GHC.AnnClose "#-}" markTrailingSemi -- -------------------------------------------------------------------- -- 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 _ (GHC.Var x) = setContext (Set.singleton PrefixOp) $ markLocated x markAST l (GHC.Or ls) = mapM_ (markAST l) ls markAST l (GHC.And ls) = mapM_ (markAST l) ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTyVarBndr name) where markAST _l (GHC.UserTyVar n) = do markAST _l n markAST _ (GHC.KindedTyVar n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsType name) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do unless (null tvs) $ do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot case mwc of Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx Just lwc -> do let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) markLocated (GHC.L lc sorted) markLocated typ -- mark GHC.AnnCloseP -- ")" markType _l (GHC.HsTyVar name) = do if GHC.isDataOcc $ GHC.occName name then do mark GHC.AnnSimpleQuote markLocatedFromKw GHC.AnnName (GHC.L _l name) else unsetContext Intercalate $ markAST _l name markType _ (GHC.HsAppTy t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 markType _ (GHC.HsListTy t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsPArrTy t) = do markWithString GHC.AnnOpen "[:" -- '[:' markLocated t markWithString GHC.AnnClose ":]" -- ':]' markType _ (GHC.HsTupleTy tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsOpTy t1 (_,lo) t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) mark GHC.AnnDcolon markLocated t markType _ (GHC.HsEqTy t1 t2) = do markLocated t1 mark GHC.AnnTilde markLocated t2 markType _ (GHC.HsKindSig t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy s _) = do mark GHC.AnnOpenPE markAST l s mark GHC.AnnCloseP markType _ (GHC.HsDocTy t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy b t) = do case b of (GHC.HsSrcBang ms (Just True) _) -> do markWithString GHC.AnnOpen (fromMaybe "{-# UNPACK" ms) markWithString GHC.AnnClose "#-}" (GHC.HsSrcBang ms (Just False) _) -> do markWithString GHC.AnnOpen (fromMaybe "{-# NOUNPACK" ms) markWithString GHC.AnnClose "#-}" _ -> return () mark GHC.AnnBang markLocated t markType _ (GHC.HsRecTy cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' -- HsCoreTy Type markType _ (GHC.HsCoreTy _t) = traceM "warning: HsCoreTy Introduced after renaming" markType _ (GHC.HsExplicitListTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP -- HsTyLit HsTyLit markType l (GHC.HsTyLit lit) = do case lit of (GHC.HsNumTy s _) -> markExternal l GHC.AnnVal s (GHC.HsStrTy s _) -> markExternal l GHC.AnnVal s -- HsWrapTy HsTyAnnotated (HsType name) markType _ (GHC.HsWrapTy _ _) = traceM "warning: HsWrapTyy Introduced after renaming" markType l GHC.HsWildcardTy = do markExternal l GHC.AnnVal "_" markType l (GHC.HsNamedWildcardTy n) = do markExternal l GHC.AnnVal (showGhc n) markType l (GHC.HsQuasiQuoteTy n) = do markAST l n -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsSplice name) where markAST _ c = case c of GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do -- TODO: We do not seem to have any way to distinguish between which of -- the next two lines will emit output. If AnnThIdSplice is there, the markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) markLocated b GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do markLocated b GHC.HsSplice _n b -> do markLocated b 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 ++ "|]") -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ConDeclField name) where markAST _ (GHC.ConDeclField ns ty mdoc) = do {- data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_names :: [LFieldOcc name], -- ^ See Note [ConDeclField names] cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } -} unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l (GHC.HsDocString s) = do markExternal l GHC.AnnVal (GHC.unpackFS s) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.Pat name) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l n markPat _ (GHC.LazyPat p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat ps _ _) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat pats b _) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.PArrPat ps _) = do markWithString GHC.AnnOpen "[:" mapM_ markLocated ps markWithString GHC.AnnClose ":]" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) markPat _ (GHC.ViewPat e pat _) = do markLocated e mark GHC.AnnRarrow markLocated pat -- SplicePat (HsSplice id) markPat l (GHC.SplicePat s) = do mark GHC.AnnOpenPE markAST l s mark GHC.AnnCloseP -- LitPat HsLit markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) markPat _ (GHC.NPat ol mn _) = do -- markOptional GHC.AnnMinus when (isJust mn) $ mark GHC.AnnMinus markLocated ol -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) markPat _ (GHC.NPlusKPat ln ol _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do markLocated pat mark GHC.AnnDcolon markLocated ty markPat _ GHC.SigPatOut {} = traceM "warning: SigPatOut introduced after renaming" -- CoPat HsAnnotated (Pat id) Type markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" markPat l (GHC.QuasiQuotePat p) = markAST l p -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit -> GHC.SourceText hsLit2String lit = case lit of GHC.HsChar src _ -> src -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src _ -> src ++ "#" GHC.HsString src _ -> src GHC.HsStringPrim src _ -> src GHC.HsInt src _ -> src GHC.HsIntPrim src _ -> src GHC.HsWordPrim src _ -> src GHC.HsInt64Prim src _ -> src GHC.HsWord64Prim src _ -> src GHC.HsInteger src _ _ -> src GHC.HsRat (GHC.FL src _) _ -> src GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LConDeclField name] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral src _ -> src GHC.HsFractional l2 -> GHC.fl_text l2 GHC.HsIsString src _ -> src in markExternal l GHC.AnnVal str -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate arg) => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where markAST _ (GHC.HsWB thing _ _ _) = do markLocated thing -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name ,GHC.HasOccName name,Annotate body) => Annotate (GHC.Stmt name (GHC.Located body)) where markAST _ (GHC.LastStmt body _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt pat body _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ (GHC.BodyStmt body _ _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt lb) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt pbs _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ParStmtBlock name name) where markAST _ (GHC.ParStmtBlock stmts _ns _) = do markListIntercalate stmts -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsLocalBinds name) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) = traceM "warning: ValBindsOut introduced after renaming" markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) markHsLocalBinds GHC.EmptyLocalBinds = return () -- --------------------------------------------------------------------- markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG matches _ _ _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsExpr name) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr l (GHC.HsVar n) = unsetContext Intercalate $ markAST l n markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) markExpr l (GHC.HsOverLit ov) = markAST l ov markExpr l (GHC.HsLit lit) = markAST l lit markExpr _ (GHC.HsLam (GHC.MG [match] _ _ _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase _ match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp e1 e2) = do -- markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e1 -- markLocated e2 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp e1 e2 _ e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar _) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet binds e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo cts es _) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then case cts of GHC.PArrComp -> ("[:",":]") _ -> ("[", "]") else ("{","}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.ExplicitPArr _ es) = do markWithString GHC.AnnOpen "[:" markListIntercalate es markWithString GHC.AnnClose ":]" markExpr _ (GHC.RecordCon n _ (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig e typ _) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLocated typ markExpr _ (GHC.ExprWithTySigOut e typ) = do markLocated e mark GHC.AnnDcolon markLocated typ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.PArrSeq _ seqInfo) = do markWithString GHC.AnnOpen "[:" -- '[:' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 markWithString GHC.AnnClose ":]" -- ':]' markExpr _ (GHC.HsSCC src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# SCC" markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr) markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# CORE" markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"") markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC markWithString GHC.AnnClose "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do -- This exists like this as the lexer collapses [e| and [| into the -- same construtor workOutString _l GHC.AnnOpen (\ss -> if spanLength ss == 2 then "[|" else "[e|") markLocated e markWithString GHC.AnnClose "|]" markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do -- This exists like this as the lexer collapses [e|| and [|| into the -- same construtor workOutString _l GHC.AnnOpen (\ss -> if spanLength ss == 3 then "[||" else "[e||") markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do markWithString GHC.AnnOpen "[t|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do markWithString GHC.AnnOpen "[p|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsRnBracketOut _ _) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut _ _) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr _ (GHC.HsSpliceE isTyped e) = do case e of GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do if isTyped then do mark GHC.AnnOpenPTE markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else do mark GHC.AnnOpenPE markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) markLocated b mark GHC.AnnCloseP GHC.HsSplice _n b -> do if isTyped then do markOptional GHC.AnnThIdSplice mark GHC.AnnOpenPTE else mark GHC.AnnOpenPE markLocated b mark GHC.AnnCloseP markExpr l (GHC.HsQuasiQuoteE e) = do markAST l e markExpr _ (GHC.HsProc p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpen "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnClose "|)" markExpr _ (GHC.HsTick _ _) = return () markExpr _ (GHC.HsBinTick _ _ _) = return () markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markWithString GHC.AnnOpen src markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER mark GHC.AnnMinus -- '-' markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l GHC.EWildPat = do markExternal l GHC.AnnVal "_" markExpr _ (GHC.EAsPat ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsType ty) = markLocated ty markExpr _ (GHC.HsWrap _ _) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar _) = traceM "warning: HsUnboundVar introduced after renaming" -- --------------------------------------------------------------------- instance Annotate GHC.HsLit where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.ExprLStmt name] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTupArg name) where markAST _ (GHC.Present (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmdTop name) where markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmd name) where markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm e _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm -- TODO: This test assumes no auto-generated SrcSpans let isPrefixOp = case cs of [] -> True (GHC.L h _:_) -> GHC.getLoc e < h when isPrefixOp $ markWithString GHC.AnnOpen "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ markWithString GHC.AnnClose "|)" markAST _ (GHC.HsCmdApp e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet binds e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo es _) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ GHC.HsCmdCast {} = traceM "warning: HsCmdCast introduced after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.TyClDecl name) where markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi 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 markTyClass ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow markLocated ctx markTyClass ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markMaybe mderivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds sigs meths ats atdefs docs _) = do mark GHC.AnnClass markLocated ctx markTyClass ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass ln tyVars = do markManyOptional GHC.AnnOpenP let parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 lnFun = do ifInContext (Set.singleton CtxMiddle) (setContext (Set.singleton InfixOp) $ markLocated ln) (markLocated ln) listFun b = do if parensNeeded then ifInContext (Set.singleton (CtxPos 0)) (markMany GHC.AnnOpenP) (return ()) else ifInContext (Set.singleton (CtxPos 0)) (markManyOptional GHC.AnnOpenP) (return ()) markLocated b if parensNeeded then ifInContext (Set.singleton (CtxPos 2)) (markMany GHC.AnnCloseP) (return ()) else ifInContext (Set.singleton (CtxPos 2)) (markManyOptional GHC.AnnCloseP) (return ()) prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls unsetContext CtxMiddle $ applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) (Set.singleton CtxMiddle) (Set.singleton CtxLast)) ([(GHC.getLoc ln,lnFun)] ++ prepareListFun tyVars) markManyOptional GHC.AnnCloseP -- --------------------------------------------------------------------- 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 case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass ln tyvars case mkind of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k case info of GHC.ClosedTypeFamily eqns -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } _ -> return () markTrailingSemi -- --------------------------------------------------------------------- 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 markTyClass ln pats -- let -- fun = ifInContext (Set.singleton (CtxPos 0)) -- (setContext (Set.singleton PrefixOp) $ markLocated ln) -- (markLocated ln) -- markOptional GHC.AnnOpenP -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) -- ([(GHC.getLoc ln, fun)] -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) -- markOptional GHC.AnnCloseP mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.TyFamDefltEqn name) where markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do mark GHC.AnnType mark GHC.AnnInstance applyListAnnotations (prepareListAnnotation [ln] ++ prepareListAnnotation bndrs ) mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs in markExternal l GHC.AnnVal str >> markTrailingSemi -- --------------------------------------------------------------------- markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do markLocated ctx markMaybe typ markMaybe _mk if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons case mderivs of Nothing -> return () Just d -> setContext (Set.singleton Deriving) $ markLocated d -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LHsType name] where markAST l ts = do inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving -- Mote: A single item in parens in a deriving clause is parsed as a -- HsSigType, which is always a HsForAllTy. Without parens it is always a -- HsVar. So for round trip pretty printing we need to take this into -- account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.ConDecl name) where markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx dets res _ depc_syntax) = do case res of GHC.ResTyH98 -> do unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot unless (null $ GHC.unLoc ctx) $ do setContext (Set.fromList [NoDarrow]) $ markLocated ctx mark GHC.AnnDarrow case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns markHsConDeclDetails False False lns dets GHC.ResTyGADT ls ty -> do -- only print names if not infix case dets of GHC.InfixCon _ _ -> return () _ -> markListIntercalate lns if depc_syntax then do markHsConDeclDetails True False lns dets mark GHC.AnnCloseC mark GHC.AnnDcolon markManyOptional GHC.AnnOpenP else do mark GHC.AnnDcolon markLocated (GHC.L ls (ResTyGADTHook bndrs)) markManyOptional GHC.AnnOpenP unless (null $ GHC.unLoc ctx) $ do markLocated ctx markHsConDeclDetails False True lns dets markLocated ty markManyOptional GHC.AnnCloseP case res of GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar _ -> return () markTrailingSemi -- 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 -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (ResTyGADTHook name) where markAST _ (ResTyGADTHook bndrs) = do markManyOptional GHC.AnnOpenP unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- --------------------------------------------------------------------- instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.HsRecField name (GHC.LPat name)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma 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 punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.FunDep (GHC.Located name)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do markWithString GHC.AnnOpen src case mh of Nothing -> return () Just (GHC.Header h) -> markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"") markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"") markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/src-ghc710/Language/Haskell/GHC/ExactPrint/Annotater.hs0000755000000000000000000026202107346545000024473 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.RdrName) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,_fs) = do markExternal l GHC.AnnVal src -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LIE name] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance (GHC.DataId name,GHC.HasOccName name, Annotate name) => Annotate (GHC.IE name) where markAST _ ie = do case ie of (GHC.IEVar ln) -> do -- TODO: I am pretty sure this criterion is inadequate if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln then mark GHC.AnnPattern else markOptional GHC.AnnPattern setContext (Set.fromList [PrefixOp,InIE]) $ 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. -} if GHC.isTcOcc (GHC.occName n) && GHC.isSymOcc (GHC.occName n) then do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocatedFromKw GHC.AnnVal ln else setContext (Set.singleton PrefixOp) $ markLocated ln (GHC.IEThingWith ln ns) -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnCloseP (GHC.IEThingAll ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup _ _) -> return () (GHC.IEDoc _) -> return () (GHC.IEDocNamed _) -> return () ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- {- -- 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) -} isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n canParen = isSym && rdrName2String n /= "$" doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str when (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) $ inContext (Set.singleton InIE) $ mark GHC.AnnType markOptional GHC.AnnType let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> markExternal l GHC.AnnVal str GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' "~" -> do mark GHC.AnnOpenP mark GHC.AnnTilde mark GHC.AnnCloseP _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- -- TODO: What is this used for? Not in ExactPrint instance Annotate GHC.Name where markAST l n = do markExternal l GHC.AnnVal (showGhc n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ImportDecl name) where markAST _ imp@(GHC.ImportDecl msrc modname mpkg src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) >> markWithString GHC.AnnClose "#-}") when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Nothing -> return () Just pkg -> markWithString GHC.AnnPackageName (show (GHC.unpackFS pkg)) markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markWithString GHC.AnnVal (GHC.moduleNameString mn) case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsDecl name -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD d -> markLocated (GHC.L l d) GHC.InstD d -> markLocated (GHC.L l d) 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) GHC.QuasiQuoteD d -> markLocated (GHC.L l d) instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsDecl name) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.RoleAnnotDecl name) where markAST _ (GHC.RoleAnnotDecl ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.SpliceDecl name) where markAST _ (GHC.SpliceDecl e flag) = do case flag of GHC.ExplicitSplice -> mark GHC.AnnOpenPE GHC.ImplicitSplice -> return () setContext (Set.singleton InSpliceDecl) $ markLocated e case flag of GHC.ExplicitSplice -> mark GHC.AnnCloseP GHC.ImplicitSplice -> return () markTrailingSemi {- - data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) - ImplicitSplice -- <=> f x y, i.e. a naked - top level expression - -} -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.VectDecl name) where markAST _ (GHC.HsVect src ln e) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" markLocated ln mark GHC.AnnEqual markLocated e markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsNoVect src ln) = do markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsVectTypeIn src _b ln mln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" mark GHC.AnnType markLocated ln case mln of Nothing -> return () Just lnn -> do mark GHC.AnnEqual markLocated lnn markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectTypeOut {} = traceM "warning: HsVectTypeOut appears after renaming" markAST _ (GHC.HsVectClassIn src ln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" mark GHC.AnnClass markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectClassOut {} = traceM "warning: HsVecClassOut appears after renaming" markAST _ GHC.HsVectInstIn {} = traceM "warning: HsVecInstsIn appears after renaming" markAST _ GHC.HsVectInstOut {} = traceM "warning: HsVecInstOut appears after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.RuleDecls name) where markAST _ (GHC.HsRules src rules) = do markWithString GHC.AnnOpen src setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- 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 setContext (Set.singleton ExplicitNeverActive) $ markActivation act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi -- --------------------------------------------------------------------- markActivation :: GHC.Activation -> Annotated () markActivation act = do case act of GHC.ActiveBefore n -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markWithString GHC.AnnVal (show n) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter n -> do mark GHC.AnnOpenS -- '[' markWithString GHC.AnnVal (show n) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.RuleBndr name) where markAST _ (GHC.RuleBndr ln) = markLocated ln markAST _ (GHC.RuleBndrSig ln (GHC.HsWB thing _ _ _)) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLocated thing mark GHC.AnnCloseP -- ")" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.AnnDecl name) where markAST _ (GHC.HsAnnotation src prov e) = do markWithString GHC.AnnOpen src case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate name => Annotate (GHC.WarnDecls name) where markAST _ (GHC.Warnings src warns) = do markWithString GHC.AnnOpen src mapM_ markLocated warns markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.WarnDecl name) where markAST _ (GHC.Warning lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ForeignDecl name) where markAST _ (GHC.ForeignImport ln typ _ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternal ls GHC.AnnVal (show src) markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (show src) setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DerivDecl name) where markAST _ (GHC.DerivDecl typ mov) = do mark GHC.AnnDeriving mark GHC.AnnInstance markMaybe mov markLocated typ markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DefaultDecl name) where markAST _ (GHC.DefaultDecl typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.InstDecl name) where markAST l (GHC.ClsInstD cid) = markAST l cid markAST l (GHC.DataFamInstD dfid) = markAST l dfid markAST l (GHC.TyFamInstD tfid) = markAST l tfid -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where markAST _ (GHC.NoOverlap src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ClsInstDecl name) where markAST _ (GHC.ClsInstDecl poly binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- 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 inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional markLocated eqn markTrailingSemi -- --------------------------------------------------------------------- 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@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance markLocated ctx markTyClass ln pats if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsBind name) where markAST _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs unless (GHC.isEmptyLocalBinds lb) $ mark GHC.AnnWhere markOptional GHC.AnnWhere markLocalBindsWithLayout lb markTrailingSemi markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixPatSyn la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixPatSyn ns -> do markLocated ln mapM_ markLocated ns case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- Introduced after renaming. markAST _ (GHC.AbsBinds _ _ _ _ _) = traceM "warning: AbsBinds introduced after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.IPBind name) where markAST _ (GHC.IPBind en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate (GHC.Match name (GHC.Located body)) where markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs lb)) = do let get_infix Nothing = False get_infix (Just (_,f)) = f isFunBind = isJust case (get_infix mln,pats) of (True, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of Nothing -> return () Just (n,_) -> setContext (Set.singleton InfixOp) $ markLocated n markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of -- Nothing -> mark GHC.AnnFunId Nothing -> markListNoPrecedingSpace False pats Just (n,_) -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n mapM_ markLocated pats -- markListNoPrecedingSpace pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, Annotate name, Annotate body) => Annotate (GHC.GRHS name (GHC.Located body)) where markAST _ (GHC.GRHS guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.Sig name) where markAST _ (GHC.TypeSig lns typ _) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLocated typ markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do mark GHC.AnnPattern markLocated ln mark GHC.AnnDcolon -- Note: The 'forall' bndrs '.' may occur multiple times unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot when (GHC.getLoc ctx1 /= GHC.noSrcSpan) $ do setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx1 markOffset GHC.AnnDarrow 0 when (GHC.getLoc ctx2 /= GHC.noSrcSpan) $ do setContext (Set.fromList [Parens,NoDarrow]) $ markLocated ctx2 markOffset GHC.AnnDarrow 1 markLocated typ markTrailingSemi markAST _ (GHC.GenericSig ns typ) = do mark GHC.AnnDefault -- markListIntercalate ns setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig _) = traceM "warning: Introduced after renaming" -- FixSig (FixitySig name) markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markWithString GHC.AnnVal (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi -- InlineSig (Located name) InlinePragma -- '{-# INLINE' activation qvar '#-}' markAST _ (GHC.InlineSig ln inl) = do markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' markActivation (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecSig ln typs inl) = do markWithString GHC.AnnOpen (GHC.inl_src inl) markActivation (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalate typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- '{-# SPECIALISE' 'instance' inst_type '#-}' markAST _ (GHC.SpecInstSig src typ) = do markWithString GHC.AnnOpen src mark GHC.AnnInstance markLocated typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- MinimalSig (BooleanFormula (Located name)) markAST _l (GHC.MinimalSig src formula) = do markWithString GHC.AnnOpen src annotationsToCommentsBF formula [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] markAST _l formula finalizeBF _l markWithString GHC.AnnClose "#-}" markTrailingSemi -- -------------------------------------------------------------------- -- 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 _ (GHC.Var x) = setContext (Set.singleton PrefixOp) $ markLocated x markAST l (GHC.Or ls) = mapM_ (markAST l) ls markAST l (GHC.And ls) = mapM_ (markAST l) ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTyVarBndr name) where markAST _l (GHC.UserTyVar n) = do markAST _l n markAST _ (GHC.KindedTyVar n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsType name) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType _ (GHC.HsForAllTy _f mwc (GHC.HsQTvs _kvs tvs) ctx@(GHC.L lc ctxs) typ) = do unless (null tvs) $ do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot case mwc of Nothing -> when (lc /= GHC.noSrcSpan) $ markLocated ctx Just lwc -> do let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildcardTy:ctxs) markLocated (GHC.L lc sorted) markLocated typ -- mark GHC.AnnCloseP -- ")" markType _l (GHC.HsTyVar name) = do if GHC.isDataOcc $ GHC.occName name then do mark GHC.AnnSimpleQuote markLocatedFromKw GHC.AnnName (GHC.L _l name) else unsetContext Intercalate $ markAST _l name markType _ (GHC.HsAppTy t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 markType _ (GHC.HsListTy t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsPArrTy t) = do markWithString GHC.AnnOpen "[:" -- '[:' markLocated t markWithString GHC.AnnClose ":]" -- ':]' markType _ (GHC.HsTupleTy tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsOpTy t1 (_,lo) t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) mark GHC.AnnDcolon markLocated t markType _ (GHC.HsEqTy t1 t2) = do markLocated t1 mark GHC.AnnTilde markLocated t2 markType _ (GHC.HsKindSig t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy s _) = do mark GHC.AnnOpenPE markAST l s mark GHC.AnnCloseP markType _ (GHC.HsDocTy t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy b t) = do case b of (GHC.HsSrcBang ms (Just True) _) -> do markWithString GHC.AnnOpen (fromMaybe "{-# UNPACK" ms) markWithString GHC.AnnClose "#-}" (GHC.HsSrcBang ms (Just False) _) -> do markWithString GHC.AnnOpen (fromMaybe "{-# NOUNPACK" ms) markWithString GHC.AnnClose "#-}" _ -> return () mark GHC.AnnBang markLocated t markType _ (GHC.HsRecTy cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' -- HsCoreTy Type markType _ (GHC.HsCoreTy _t) = traceM "warning: HsCoreTy Introduced after renaming" markType _ (GHC.HsExplicitListTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP -- HsTyLit HsTyLit markType l (GHC.HsTyLit lit) = do case lit of (GHC.HsNumTy s _) -> markExternal l GHC.AnnVal s (GHC.HsStrTy s _) -> markExternal l GHC.AnnVal s -- HsWrapTy HsTyAnnotated (HsType name) markType _ (GHC.HsWrapTy _ _) = traceM "warning: HsWrapTyy Introduced after renaming" markType l GHC.HsWildcardTy = do markExternal l GHC.AnnVal "_" markType l (GHC.HsNamedWildcardTy n) = do markExternal l GHC.AnnVal (showGhc n) markType l (GHC.HsQuasiQuoteTy n) = do markAST l n -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsSplice name) where markAST _ c = case c of GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do -- TODO: We do not seem to have any way to distinguish between which of -- the next two lines will emit output. If AnnThIdSplice is there, the markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) markLocated b GHC.HsSplice _n b@(GHC.L _ (GHC.HsBracket _)) -> do markLocated b GHC.HsSplice _n b -> do markLocated b 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 ++ "|]") -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ConDeclField name) where markAST _ (GHC.ConDeclField ns ty mdoc) = do {- data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_names :: [LFieldOcc name], -- ^ See Note [ConDeclField names] cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } -} unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l (GHC.HsDocString s) = do markExternal l GHC.AnnVal (GHC.unpackFS s) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.Pat name) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l n markPat _ (GHC.LazyPat p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat ps _ _) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat pats b _) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.PArrPat ps _) = do markWithString GHC.AnnOpen "[:" mapM_ markLocated ps markWithString GHC.AnnClose ":]" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) markPat _ (GHC.ViewPat e pat _) = do markLocated e mark GHC.AnnRarrow markLocated pat -- SplicePat (HsSplice id) markPat l (GHC.SplicePat s) = do mark GHC.AnnOpenPE markAST l s mark GHC.AnnCloseP -- LitPat HsLit markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) markPat _ (GHC.NPat ol mn _) = do -- markOptional GHC.AnnMinus when (isJust mn) $ mark GHC.AnnMinus markLocated ol -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) markPat _ (GHC.NPlusKPat ln ol _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPatIn pat (GHC.HsWB ty _ _ _)) = do markLocated pat mark GHC.AnnDcolon markLocated ty markPat _ GHC.SigPatOut {} = traceM "warning: SigPatOut introduced after renaming" -- CoPat HsAnnotated (Pat id) Type markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" markPat l (GHC.QuasiQuotePat p) = markAST l p -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit -> GHC.SourceText hsLit2String lit = case lit of GHC.HsChar src _ -> src -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src _ -> src ++ "#" GHC.HsString src _ -> src GHC.HsStringPrim src _ -> src GHC.HsInt src _ -> src GHC.HsIntPrim src _ -> src GHC.HsWordPrim src _ -> src GHC.HsInt64Prim src _ -> src GHC.HsWord64Prim src _ -> src GHC.HsInteger src _ _ -> src GHC.HsRat (GHC.FL src _) _ -> src GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LConDeclField name] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral src _ -> src GHC.HsFractional l2 -> GHC.fl_text l2 GHC.HsIsString src _ -> src in markExternal l GHC.AnnVal str -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate arg) => Annotate (GHC.HsWithBndrs name (GHC.Located arg)) where markAST _ (GHC.HsWB thing _ _ _) = do markLocated thing -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name ,GHC.HasOccName name,Annotate body) => Annotate (GHC.Stmt name (GHC.Located body)) where markAST _ (GHC.LastStmt body _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt pat body _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ (GHC.BodyStmt body _ _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt lb) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt pbs _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ParStmtBlock name name) where markAST _ (GHC.ParStmtBlock stmts _ns _) = do markListIntercalate stmts -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsLocalBinds name) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) = traceM "warning: ValBindsOut introduced after renaming" markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) markHsLocalBinds GHC.EmptyLocalBinds = return () -- --------------------------------------------------------------------- markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG matches _ _ _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsExpr name) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr l (GHC.HsVar n) = unsetContext Intercalate $ markAST l n markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) markExpr l (GHC.HsOverLit ov) = markAST l ov markExpr l (GHC.HsLit lit) = markAST l lit markExpr _ (GHC.HsLam (GHC.MG [match] _ _ _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase _ match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp e1 e2) = do -- markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e1 -- markLocated e2 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp e1 e2 _ e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar _) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet binds e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo cts es _) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then case cts of GHC.PArrComp -> ("[:",":]") _ -> ("[", "]") else ("{","}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.ExplicitPArr _ es) = do markWithString GHC.AnnOpen "[:" markListIntercalate es markWithString GHC.AnnClose ":]" markExpr _ (GHC.RecordCon n _ (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd e (GHC.HsRecFields fs _) _cons _ _) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig e typ _) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLocated typ markExpr _ (GHC.ExprWithTySigOut e typ) = do markLocated e mark GHC.AnnDcolon markLocated typ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.PArrSeq _ seqInfo) = do markWithString GHC.AnnOpen "[:" -- '[:' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 markWithString GHC.AnnClose ":]" -- ':]' markExpr _ (GHC.HsSCC src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# SCC" markWithStringOptional GHC.AnnVal (GHC.unpackFS csFStr) markWithString GHC.AnnValStr ("\"" ++ GHC.unpackFS csFStr ++ "\"") markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# CORE" markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS csFStr ++ "\"") markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC markWithString GHC.AnnClose "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do -- This exists like this as the lexer collapses [e| and [| into the -- same construtor workOutString _l GHC.AnnOpen (\ss -> if spanLength ss == 2 then "[|" else "[e|") markLocated e markWithString GHC.AnnClose "|]" markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do -- This exists like this as the lexer collapses [e|| and [|| into the -- same construtor workOutString _l GHC.AnnOpen (\ss -> if spanLength ss == 3 then "[||" else "[e||") markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do markWithString GHC.AnnOpen "[t|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do markWithString GHC.AnnOpen "[p|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsRnBracketOut _ _) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut _ _) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr _ (GHC.HsSpliceE isTyped e) = do case e of GHC.HsSplice _n b@(GHC.L _ (GHC.HsVar n)) -> do if isTyped then do mark GHC.AnnOpenPTE markWithStringOptional GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else do mark GHC.AnnOpenPE markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) markLocated b mark GHC.AnnCloseP GHC.HsSplice _n b -> do if isTyped then do markOptional GHC.AnnThIdSplice mark GHC.AnnOpenPTE else mark GHC.AnnOpenPE markLocated b mark GHC.AnnCloseP markExpr l (GHC.HsQuasiQuoteE e) = do markAST l e markExpr _ (GHC.HsProc p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpen "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnClose "|)" markExpr _ (GHC.HsTick _ _) = return () markExpr _ (GHC.HsBinTick _ _ _) = return () markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markWithString GHC.AnnOpen src markOffsetWithString GHC.AnnVal 0 (show (GHC.unpackFS str)) -- STRING markOffsetWithString GHC.AnnVal 1 (show v1) -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOffsetWithString GHC.AnnVal 2 (show v2) -- INTEGER mark GHC.AnnMinus -- '-' markOffsetWithString GHC.AnnVal 3 (show v3) -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOffsetWithString GHC.AnnVal 4 (show v4) -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l GHC.EWildPat = do markExternal l GHC.AnnVal "_" markExpr _ (GHC.EAsPat ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsType ty) = markLocated ty markExpr _ (GHC.HsWrap _ _) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar _) = traceM "warning: HsUnboundVar introduced after renaming" -- --------------------------------------------------------------------- instance Annotate GHC.HsLit where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.ExprLStmt name] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTupArg name) where markAST _ (GHC.Present (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmdTop name) where markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmd name) where markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm e _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm -- TODO: This test assumes no auto-generated SrcSpans let isPrefixOp = case cs of [] -> True (GHC.L h _:_) -> GHC.getLoc e < h when isPrefixOp $ markWithString GHC.AnnOpen "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ markWithString GHC.AnnClose "|)" markAST _ (GHC.HsCmdApp e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet binds e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo es _) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ GHC.HsCmdCast {} = traceM "warning: HsCmdCast introduced after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.TyClDecl name) where markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi 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 markTyClass ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow markLocated ctx markTyClass ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markMaybe mderivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars) fds sigs meths ats atdefs docs _) = do mark GHC.AnnClass markLocated ctx markTyClass ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass ln tyVars = do markManyOptional GHC.AnnOpenP let parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 lnFun = do ifInContext (Set.singleton CtxMiddle) (setContext (Set.singleton InfixOp) $ markLocated ln) (markLocated ln) listFun b = do if parensNeeded then ifInContext (Set.singleton (CtxPos 0)) (markMany GHC.AnnOpenP) (return ()) else ifInContext (Set.singleton (CtxPos 0)) (markManyOptional GHC.AnnOpenP) (return ()) markLocated b if parensNeeded then ifInContext (Set.singleton (CtxPos 2)) (markMany GHC.AnnCloseP) (return ()) else ifInContext (Set.singleton (CtxPos 2)) (markManyOptional GHC.AnnCloseP) (return ()) prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls unsetContext CtxMiddle $ applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) (Set.singleton CtxMiddle) (Set.singleton CtxLast)) ([(GHC.getLoc ln,lnFun)] ++ prepareListFun tyVars) markManyOptional GHC.AnnCloseP -- --------------------------------------------------------------------- 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 case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass ln tyvars case mkind of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k case info of GHC.ClosedTypeFamily eqns -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } _ -> return () markTrailingSemi -- --------------------------------------------------------------------- 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 markTyClass ln pats -- let -- fun = ifInContext (Set.singleton (CtxPos 0)) -- (setContext (Set.singleton PrefixOp) $ markLocated ln) -- (markLocated ln) -- markOptional GHC.AnnOpenP -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) -- ([(GHC.getLoc ln, fun)] -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) -- markOptional GHC.AnnCloseP mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.TyFamDefltEqn name) where markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs) typ) = do mark GHC.AnnType mark GHC.AnnInstance applyListAnnotations (prepareListAnnotation [ln] ++ prepareListAnnotation bndrs ) mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs in markExternal l GHC.AnnVal str >> markTrailingSemi -- --------------------------------------------------------------------- markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do markLocated ctx markMaybe typ markMaybe _mk if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons case mderivs of Nothing -> return () Just d -> setContext (Set.singleton Deriving) $ markLocated d -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LHsType name] where markAST l ts = do inContext (Set.singleton Deriving) $ mark GHC.AnnDeriving -- Mote: A single item in parens in a deriving clause is parsed as a -- HsSigType, which is always a HsForAllTy. Without parens it is always a -- HsVar. So for round trip pretty printing we need to take this into -- account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.ConDecl name) where markAST _ (GHC.ConDecl lns _expr (GHC.HsQTvs _ns bndrs) ctx dets res _ depc_syntax) = do case res of GHC.ResTyH98 -> do unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot unless (null $ GHC.unLoc ctx) $ do setContext (Set.fromList [NoDarrow]) $ markLocated ctx mark GHC.AnnDarrow case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markListIntercalate lns markHsConDeclDetails False False lns dets GHC.ResTyGADT ls ty -> do -- only print names if not infix case dets of GHC.InfixCon _ _ -> return () _ -> markListIntercalate lns if depc_syntax then do markHsConDeclDetails True False lns dets mark GHC.AnnCloseC mark GHC.AnnDcolon markManyOptional GHC.AnnOpenP else do mark GHC.AnnDcolon markLocated (GHC.L ls (ResTyGADTHook bndrs)) markManyOptional GHC.AnnOpenP unless (null $ GHC.unLoc ctx) $ do markLocated ctx markHsConDeclDetails False True lns dets markLocated ty markManyOptional GHC.AnnCloseP case res of GHC.ResTyH98 -> inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar _ -> return () markTrailingSemi -- 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 -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (ResTyGADTHook name) where markAST _ (ResTyGADTHook bndrs) = do markManyOptional GHC.AnnOpenP unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- --------------------------------------------------------------------- instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.HsRecField name (GHC.LPat name)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma 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 punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.FunDep (GHC.Located name)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do markWithString GHC.AnnOpen src case mh of Nothing -> return () Just (GHC.Header h) -> markWithString GHC.AnnHeader ("\"" ++ GHC.unpackFS h ++ "\"") markWithString GHC.AnnVal ("\"" ++ GHC.unpackFS f ++ "\"") markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/src-ghc80/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022116 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc80/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000030201507346545000024406 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.RdrName) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L ls txt) lss) = do markExternal ls GHC.AnnOpen txt mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate GHC.StringLiteral where markAST l (GHC.StringLiteral src _) = do markExternal l GHC.AnnVal src inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,_fs) = do markExternal l GHC.AnnVal src -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LIE name] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance (GHC.DataId name,GHC.HasOccName name, Annotate name) => Annotate (GHC.IE name) where markAST _ ie = do case ie of (GHC.IEVar ln) -> do -- TODO: I am pretty sure this criterion is inadequate if GHC.isDataOcc $ GHC.occName $ GHC.unLoc ln then mark GHC.AnnPattern else markOptional GHC.AnnPattern setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln (GHC.IEThingAbs ln) -> do setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln (GHC.IEThingWith ln wc ns _lfs) -> do setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln mark GHC.AnnOpenP case wc of GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp,InIE]) $ markListIntercalate ns GHC.IEWildcard n -> do setContext (Set.fromList [PrefixOp,Intercalate,InIE]) $ mapM_ markLocated (take n ns) mark GHC.AnnDotdot case drop n ns of [] -> return () ns' -> do mark GHC.AnnComma setContext (Set.fromList [PrefixOp,InIE]) $ mapM_ markLocated ns' mark GHC.AnnCloseP (GHC.IEThingAll ln) -> do setContext (Set.fromList [PrefixOp,InIE]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup _ _) -> return () (GHC.IEDoc _) -> return () (GHC.IEDocNamed _) -> return () ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n -- Horrible hack until GHC 8.2 with https://phabricator.haskell.org/D3016 typeIESym = isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n) && spanLength l - length str > 6 -- length of "type" + 2 parens canParen = isSym && rdrName2String n /= "$" && (not typeIESym) doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str -- when (isSym && (GHC.isTcClsNameSpace $ GHC.rdrNameSpace n)) $ inContext (Set.singleton InIE) $ mark GHC.AnnType when (spanLength l - length str > 4) $ inContext (Set.singleton InIE) $ mark GHC.AnnType let str'' = if typeIESym then "(" ++ str' ++ ")" else str' let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str'' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> if str == "~" then doNormalRdrName else markExternal l GHC.AnnVal str GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- -- TODO: What is this used for? Not in ExactPrint instance Annotate GHC.Name where markAST l n = do markExternal l GHC.AnnVal (showGhc n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ImportDecl name) where markAST _ imp@(GHC.ImportDecl msrc modname mpkg src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" when src (markWithString GHC.AnnOpen (fromMaybe "{-# SOURCE" msrc) >> markWithString GHC.AnnClose "#-}") when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Nothing -> return () Just (GHC.StringLiteral srcPkg _) -> markWithString GHC.AnnPackageName srcPkg markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markWithString GHC.AnnVal (GHC.moduleNameString mn) case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsDecl name -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD d -> markLocated (GHC.L l d) GHC.InstD d -> markLocated (GHC.L l d) 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) instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsDecl name) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.RoleAnnotDecl name) where markAST _ (GHC.RoleAnnotDecl ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.SpliceDecl name) where markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do setContext (Set.singleton InSpliceDecl) $ markLocated e markTrailingSemi markAST _ (GHC.SpliceDecl e flag) = do case flag of GHC.ExplicitSplice -> mark GHC.AnnOpenPE GHC.ImplicitSplice -> return () setContext (Set.singleton InSpliceDecl) $ markLocated e case flag of GHC.ExplicitSplice -> mark GHC.AnnCloseP GHC.ImplicitSplice -> return () markTrailingSemi {- - data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) - ImplicitSplice -- <=> f x y, i.e. a naked - top level expression - -} -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.VectDecl name) where markAST _ (GHC.HsVect src ln e) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" markLocated ln mark GHC.AnnEqual markLocated e markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsNoVect src ln) = do markWithString GHC.AnnOpen src -- "{-# NOVECTORISE" markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsVectTypeIn src _b ln mln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" or "{-# VECTORISE SCALAR" mark GHC.AnnType markLocated ln case mln of Nothing -> return () Just lnn -> do mark GHC.AnnEqual markLocated lnn markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectTypeOut {} = traceM "warning: HsVectTypeOut appears after renaming" markAST _ (GHC.HsVectClassIn src ln) = do markWithString GHC.AnnOpen src -- "{-# VECTORISE" mark GHC.AnnClass markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectClassOut {} = traceM "warning: HsVecClassOut appears after renaming" markAST _ GHC.HsVectInstIn {} = traceM "warning: HsVecInstsIn appears after renaming" markAST _ GHC.HsVectInstOut {} = traceM "warning: HsVecInstOut appears after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.RuleDecls name) where markAST _ (GHC.HsRules src rules) = do markWithString GHC.AnnOpen src setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- 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 setContext (Set.singleton ExplicitNeverActive) $ markActivation act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi -- --------------------------------------------------------------------- markActivation :: GHC.Activation -> Annotated () markActivation act = do case act of GHC.ActiveBefore src _ -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markWithString GHC.AnnVal src mark GHC.AnnCloseS -- ']' GHC.ActiveAfter src _ -> do mark GHC.AnnOpenS -- '[' markWithString GHC.AnnVal src mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- 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 st) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLHsSigWcType st mark GHC.AnnCloseP -- ")" -- --------------------------------------------------------------------- markLHsSigWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsSigWcType name -> Annotated () markLHsSigWcType (GHC.HsIB _ (GHC.HsWC _ mwc ty)) = do case mwc of Nothing -> markLocated ty Just lwc -> do applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] ++ prepareListAnnotation [ty] ) -- --------------------------------------------------------------------- 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 case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate name => Annotate (GHC.WarnDecls name) where markAST _ (GHC.Warnings src warns) = do markWithString GHC.AnnOpen src mapM_ markLocated warns markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.WarnDecl name) where markAST _ (GHC.Warning lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ForeignDecl name) where markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ) _ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do {- = ForeignImport { fd_name :: Located name -- defines this name , fd_sig_ty :: LHsSigType name -- sig_ty , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty , fd_fi :: ForeignImport } -} mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety if GHC.unLoc cconv == GHC.PrimCallConv then markExternal ls GHC.AnnVal src #if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) else markExternal ls GHC.AnnVal src #else else markExternal ls GHC.AnnVal (show src) #endif markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ) _ (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (show src) setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DerivDecl name) where markAST _ (GHC.DerivDecl (GHC.HsIB _ typ) mov) = do mark GHC.AnnDeriving mark GHC.AnnInstance markMaybe mov markLocated typ markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DefaultDecl name) where markAST _ (GHC.DefaultDecl typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.InstDecl name) where markAST l (GHC.ClsInstD cid) = markAST l cid markAST l (GHC.DataFamInstD dfid) = markAST l dfid markAST l (GHC.TyFamInstD tfid) = markAST l tfid -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where markAST _ (GHC.NoOverlap src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ClsInstDecl name) where markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly if null (GHC.bagToList binds) && null sigs && null tyfams && null datafams then markOptional GHC.AnnWhere else do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- 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 inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional markLocated eqn markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.DataFamInstDecl name) where markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats) defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance markLocated ctx markTyClass ln pats case (GHC.dd_kindSig defn) of Just s -> do mark GHC.AnnDcolon markLocated s Nothing -> return () if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsBind name) where markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixPatSyn la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixPatSyn ns -> do markLocated ln mapM_ markLocated ns GHC.RecordPatSyn fs -> do markLocated ln mark GHC.AnnOpenC -- '{' markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs mark GHC.AnnCloseC -- '}' case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- Introduced after renaming. markAST _ (GHC.AbsBinds _ _ _ _ _) = traceM "warning: AbsBinds introduced after renaming" -- Introduced after renaming. markAST _ GHC.AbsBindsSig{} = traceM "warning: AbsBindsSig introduced after renaming" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.IPBind name) where markAST _ (GHC.IPBind en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate (GHC.Match name (GHC.Located body)) where markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do let get_infix GHC.NonFunBindMatch = False get_infix (GHC.FunBindMatch _ f) = f isFunBind GHC.NonFunBindMatch = False isFunBind GHC.FunBindMatch{} = True case (get_infix mln,pats) of (True, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of GHC.NonFunBindMatch -> return () GHC.FunBindMatch n _ -> setContext (Set.singleton InfixOp) $ markLocated n markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of -- GHC.NonFunBindMatch -> mark GHC.AnnFunId GHC.NonFunBindMatch -> markListNoPrecedingSpace False pats GHC.FunBindMatch n _ -> do -- setContext (Set.singleton NoPrecedingSpace) $ markLocated n setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ markLocated n mapM_ markLocated pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name, Annotate name, Annotate body) => Annotate (GHC.GRHS name (GHC.Located body)) where markAST _ (GHC.GRHS guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.Sig name) where markAST _ (GHC.TypeSig lns st) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLHsSigWcType st markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig ln (GHC.HsIB _ typ)) = do mark GHC.AnnPattern markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ)) = do when isDefault $ mark GHC.AnnDefault -- markListIntercalate ns setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig _) = traceM "warning: Introduced after renaming" -- FixSig (FixitySig name) markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src _v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markWithString GHC.AnnVal src setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi -- InlineSig (Located name) InlinePragma -- '{-# INLINE' activation qvar '#-}' markAST _ (GHC.InlineSig ln inl) = do markWithString GHC.AnnOpen (GHC.inl_src inl) -- '{-# INLINE' markActivation (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecSig ln typs inl) = do {- | SpecSig (Located name) -- Specialise a function or datatype ... [LHsSigType name] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE -} markWithString GHC.AnnOpen (GHC.inl_src inl) markActivation (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalateWithFunLevel markLHsSigType 2 typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- '{-# SPECIALISE' 'instance' inst_type '#-}' markAST _ (GHC.SpecInstSig src typ) = do markWithString GHC.AnnOpen src mark GHC.AnnInstance markLHsSigType typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- MinimalSig (BooleanFormula (Located name)) markAST _l (GHC.MinimalSig src formula) = do markWithString GHC.AnnOpen src markLocated formula markWithString GHC.AnnClose "#-}" markTrailingSemi -- -------------------------------------------------------------------- markLHsSigType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsSigType name -> Annotated () markLHsSigType (GHC.HsIB _ typ) = markLocated typ instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LHsSigType name] where markAST _ ls = do mark GHC.AnnDeriving -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it -- is a HsTyVar. So for round trip pretty printing we need to take this into -- account. case ls of [] -> markManyOptional GHC.AnnOpenP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnOpenP [_] -> markManyOptional GHC.AnnOpenP _ -> markMany GHC.AnnOpenP markListIntercalateWithFun markLHsSigType ls case ls of [] -> markManyOptional GHC.AnnCloseP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{})] -> markMany GHC.AnnCloseP [_] -> markManyOptional GHC.AnnCloseP _ -> markMany GHC.AnnCloseP -- -------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where markAST _ (GHC.Var x) = do setContext (Set.singleton PrefixOp) $ markLocated x inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- markAST l (GHC.Or ls) = mapM_ markLocated ls markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls markAST _ (GHC.And ls) = do markListIntercalateWithFunLevel markLocated 2 ls inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Parens x) = do mark GHC.AnnOpenP -- '(' markLocated x mark GHC.AnnCloseP -- ')' inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTyVarBndr name) where markAST _l (GHC.UserTyVar n) = do markLocated n markAST _ (GHC.KindedTyVar n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsType name) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType _ (GHC.HsForAllTy tvs typ) = do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot markLocated typ {- = HsForAllTy -- See Note [HsType binders] { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' , hst_body :: LHsType name -- body type } -} markType _ (GHC.HsQualTy cxt typ) = do markLocated cxt markLocated typ {- | HsQualTy -- See Note [HsType binders] { hst_ctxt :: LHsContext name -- Context C => blah , hst_body :: LHsType name } -} markType _l (GHC.HsTyVar name) = do -- TODO: Should the isExactName test move into the RdrName Annotate instanced? if ((GHC.isDataOcc $ GHC.occName $ GHC.unLoc name) && ((not $ isExactName $ GHC.unLoc name))) || (showGhc name == "()") then do mark GHC.AnnSimpleQuote markLocatedFromKw GHC.AnnName name else markLocated name markType _ (GHC.HsAppsTy ts) = do mapM_ markLocated ts markType _ (GHC.HsAppTy t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 markType _ (GHC.HsListTy t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsPArrTy t) = do markWithString GHC.AnnOpen "[:" -- '[:' markLocated t markWithString GHC.AnnClose ":]" -- ':]' markType _ (GHC.HsTupleTy tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsOpTy t1 lo t2) = do -- HsOpTy (LHsType name) (Located name) (LHsType name) markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy (GHC.HsIPName n) t) = do markWithString GHC.AnnVal ("?" ++ (GHC.unpackFS n)) mark GHC.AnnDcolon markLocated t markType _ (GHC.HsEqTy t1 t2) = do markLocated t1 mark GHC.AnnTilde markLocated t2 markType _ (GHC.HsKindSig t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy s _) = do markAST l s markType _ (GHC.HsDocTy t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do case mt of Nothing -> return () Just src -> do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" case str of GHC.SrcLazy -> mark GHC.AnnTilde GHC.SrcStrict -> mark GHC.AnnBang GHC.NoSrcStrict -> return () markLocated t {- | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations data HsSrcBang = HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes SrcUnpackedness SrcStrictness data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' | SrcStrict -- ^ Strict, ie '!' | NoSrcStrict -- ^ no strictness annotation data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified | NoSrcUnpack -- ^ no unpack pragma -} markType _ (GHC.HsRecTy cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' -- HsCoreTy Type markType _ (GHC.HsCoreTy _t) = traceM "warning: HsCoreTy Introduced after renaming" markType _ (GHC.HsExplicitListTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP -- HsTyLit HsTyLit markType l (GHC.HsTyLit lit) = do case lit of (GHC.HsNumTy s _) -> markExternal l GHC.AnnVal s (GHC.HsStrTy s _) -> markExternal l GHC.AnnVal s -- HsWrapTy HsTyAnnotated (HsType name) markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do markExternal l GHC.AnnVal "_" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsAppType name) where markAST _ (GHC.HsAppInfix n) = do when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote setContext (Set.singleton InfixOp) $ markLocated n markAST _ (GHC.HsAppPrefix t) = do markOptional GHC.AnnTilde setContext (Set.singleton PrefixOp) $ markLocated t -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsSplice name) where markAST l c = case c of GHC.HsQuasiQuote _ n _pos fs -> do markExternal l GHC.AnnVal ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") GHC.HsTypedSplice _n (GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) GHC.HsTypedSplice _n b -> do mark GHC.AnnOpenPTE markLocated b mark GHC.AnnCloseP GHC.HsUntypedSplice _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do ifInContext (Set.singleton InSpliceDecl) (return ()) (mark GHC.AnnOpenPE) -- TODO: We do not seem to have any way to distinguish between which of -- the next two lines will emit output. If AnnThIdSplice is there, the -- markLocated b ends up with a negative offset so emits nothing. markWithStringOptional GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) markLocated b ifInContext (Set.singleton InSpliceDecl) (return ()) (mark GHC.AnnCloseP) GHC.HsUntypedSplice _n b -> do -- TODO: when is this not optional? markOptional GHC.AnnThIdSplice ifInContext (Set.singleton InSpliceDecl) (return ()) (mark GHC.AnnOpenPE) markLocated b ifInContext (Set.singleton InSpliceDecl) (return ()) (mark GHC.AnnCloseP) #if defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,0,1,1)) GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" #endif -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ConDeclField name) where markAST _ (GHC.ConDeclField ns ty mdoc) = do {- data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_names :: [LFieldOcc name], -- ^ See Note [ConDeclField names] cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } -} unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.FieldOcc name) where markAST _ (GHC.FieldOcc rn _) = do markLocated rn inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l (GHC.HsDocString s) = do markExternal l GHC.AnnVal (GHC.unpackFS s) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.Pat name) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) markPat _ (GHC.LazyPat p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat ps _ _) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat pats b _) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.PArrPat ps _) = do markWithString GHC.AnnOpen "[:" mapM_ markLocated ps markWithString GHC.AnnClose ":]" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" -- ViewPat (LHsExpr id) (LPat id) (PostTc id Type) markPat _ (GHC.ViewPat e pat _) = do markLocated e mark GHC.AnnRarrow markLocated pat -- SplicePat (HsSplice id) markPat l (GHC.SplicePat s) = do markAST l s -- LitPat HsLit markPat l (GHC.LitPat lp) = markExternal l GHC.AnnVal (hsLit2String lp) -- NPat (HsOverLit id) (Maybe (SyntaxExpr id)) (SyntaxExpr id) markPat _ (GHC.NPat ol mn _ _) = do -- markOptional GHC.AnnMinus when (isJust mn) $ mark GHC.AnnMinus markLocated ol -- NPlusKPat (Located id) (HsOverLit id) (SyntaxExpr id) (SyntaxExpr id) markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPatIn pat ty) = do markLocated pat mark GHC.AnnDcolon markLHsSigWcType ty markPat _ GHC.SigPatOut {} = traceM "warning: SigPatOut introduced after renaming" -- CoPat HsAnnotated (Pat id) Type markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit -> GHC.SourceText hsLit2String lit = case lit of GHC.HsChar src _ -> src -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src _ -> src ++ "#" GHC.HsString src _ -> src GHC.HsStringPrim src _ -> src GHC.HsInt src _ -> src GHC.HsIntPrim src _ -> src GHC.HsWordPrim src _ -> src GHC.HsInt64Prim src _ -> src GHC.HsWord64Prim src _ -> src GHC.HsInteger src _ _ -> src GHC.HsRat (GHC.FL src _) _ -> src GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" markHsConPatDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.Located name -> GHC.HsConPatDetails name -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Bool -> Bool -> [GHC.Located name] -> GHC.HsConDeclDetails name -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LConDeclField name] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral src _ -> src GHC.HsFractional l2 -> GHC.fl_text l2 GHC.HsIsString src _ -> src in markExternal l GHC.AnnVal str -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate arg) => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where markAST _ (GHC.HsIB _ thing) = do markLocated thing -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,Annotate name ,GHC.HasOccName name,Annotate body) => Annotate (GHC.Stmt name (GHC.Located body)) where markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt pat body _ _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ GHC.ApplicativeStmt{} = error "ApplicativeStmt should not appear in ParsedSource" markAST _ (GHC.BodyStmt body _ _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt (GHC.L _ lb)) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt pbs _ _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ParStmtBlock name name) where markAST _ (GHC.ParStmtBlock stmts _ns _) = do markListIntercalate stmts -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsLocalBinds name) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.HsLocalBinds name -> Annotated () markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) = traceM "warning: ValBindsOut introduced after renaming" markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout (reverse binds) markHsLocalBinds GHC.EmptyLocalBinds = return () -- --------------------------------------------------------------------- markMatchGroup :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => GHC.SrcSpan -> GHC.MatchGroup name (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name, Annotate body) => Annotate [GHC.Located (GHC.Match name (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsExpr name) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do ifInContext (Set.singleton PrefixOp) (setContext (Set.singleton PrefixOp) $ markLocated n) (ifInContext (Set.singleton InfixOp) (setContext (Set.singleton InfixOp) $ markLocated n) (markLocated n) ) markExpr l (GHC.HsRecFld f) = markAST l f markExpr l (GHC.HsOverLabel fs) = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) markExpr l (GHC.HsIPVar (GHC.HsIPName v)) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS v) markExpr l (GHC.HsOverLit ov) = markAST l ov markExpr l (GHC.HsLit lit) = markAST l lit markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase _ match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp e1 e2) = do -- markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e1 -- markLocated e2 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp e1 e2 _ e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar _) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then case cts of GHC.PArrComp -> ("[:",":]") _ -> ("[", "]") else ("{","}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.ExplicitPArr _ es) = do markWithString GHC.AnnOpen "[:" markListIntercalate es markWithString GHC.AnnClose ":]" markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig e typ) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ExprWithTySigOut e typ) = do markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.PArrSeq _ seqInfo) = do markWithString GHC.AnnOpen "[:" -- '[:' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 markWithString GHC.AnnClose ":]" -- ':]' markExpr _ (GHC.HsSCC src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# SCC" markWithStringOptional GHC.AnnVal (GHC.sl_st csFStr) markWithString GHC.AnnValStr (GHC.sl_st csFStr) markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn src csFStr e) = do markWithString GHC.AnnOpen src -- "{-# CORE" markWithString GHC.AnnVal (GHC.sl_st csFStr) markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC markWithString GHC.AnnClose "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do markWithString GHC.AnnOpen "[|" markOptional GHC.AnnOpenE -- "[e|" markLocated e markWithString GHC.AnnClose "|]" markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do markWithString GHC.AnnOpen "[||" markWithStringOptional GHC.AnnOpenE "[e||" markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do markWithString GHC.AnnOpen "[t|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do markWithString GHC.AnnOpen "[p|" markLocated e markWithString GHC.AnnClose "|]" markExpr _ (GHC.HsRnBracketOut _ _) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut _ _) = traceM "warning: HsTcBracketOut introduced after renamer" -- -------------------------------- -- markExpr l (GHC.HsSpliceE e@(GHC.HsUntypedSplice _ (GHC.L _ (GHC.HsSpliceE{})))) = do -- mark GHC.AnnOpenPE -- markAST l e -- mark GHC.AnnCloseP markExpr l (GHC.HsSpliceE e) = do markOptional GHC.AnnOpenPE markAST l e markOptional GHC.AnnCloseP -- -------------------------------- markExpr _ (GHC.HsProc p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpen "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnClose "|)" markExpr _ (GHC.HsTick _ _) = return () markExpr _ (GHC.HsBinTick _ _ _) = return () markExpr _ (GHC.HsTickPragma src (str,_,_) ((v1,v2),(v3,v4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markWithString GHC.AnnOpen src markOffsetWithString GHC.AnnVal 0 (GHC.sl_st str) -- STRING markOffsetWithString GHC.AnnVal 1 v1 -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOffsetWithString GHC.AnnVal 2 v2 -- INTEGER mark GHC.AnnMinus -- '-' markOffsetWithString GHC.AnnVal 3 v3 -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOffsetWithString GHC.AnnVal 4 v4 -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l GHC.EWildPat = do markExternal l GHC.AnnVal "_" markExpr _ (GHC.EAsPat ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsAppType e ty) = do markLocated e markInstead GHC.AnnAt AnnTypeApp markLHsWcType ty markExpr _ (GHC.HsAppTypeOut _ _) = traceM "warning: HsAppTypeOut introduced after renaming" markExpr _ (GHC.HsWrap _ _) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar _) = traceM "warning: HsUnboundVar introduced after renaming" -- --------------------------------------------------------------------- markLHsWcType :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.LHsWcType name -> Annotated () markLHsWcType (GHC.HsWC _ mwc ty) = do case mwc of Nothing -> markLocated ty Just lwc -> do -- let sorted = lexicalSortLocated (GHC.L lwc GHC.HsWildCardTy:[ty]) -- markLocated (GHC.L lc sorted) applyListAnnotations ([(lwc,markExternal lwc GHC.AnnVal "_")] ++ prepareListAnnotation [ty] ) -- --------------------------------------------------------------------- instance Annotate GHC.HsLit where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsRecUpdField name) where markAST _ (GHC.HsRecField lbl expr punFlag) = do unsetContext Intercalate $ markLocated lbl when (punFlag == False) $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated expr inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma {- type HsRecUpdField id = HsRecField' (AmbiguousFieldOcc id) (LHsExpr id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', -- -- For details on above see note [Api annotations] in ApiAnnotation data HsRecField' id arg = HsRecField { hsRecFieldLbl :: Located id, hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning hsRecPun :: Bool -- ^ Note [Punning] } deriving (Data, Typeable) -} instance (GHC.DataId name) => Annotate (GHC.AmbiguousFieldOcc name) where markAST _ (GHC.Unambiguous n _) = markLocated n markAST _ (GHC.Ambiguous n _) = markLocated n -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.ExprLStmt name] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsTupArg name) where markAST _ (GHC.Present (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmdTop name) where markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.HsCmd name) where markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm e _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm -- TODO: This test assumes no auto-generated SrcSpans let isPrefixOp = case cs of [] -> True (GHC.L h _:_) -> GHC.getLoc e < h when isPrefixOp $ markWithString GHC.AnnOpen "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ markWithString GHC.AnnClose "|)" markAST _ (GHC.HsCmdApp e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdWrap {}) = traceM "warning: HsCmdWrap introduced after renaming" {- | HsCmdWrap HsWrapper (HsCmd id) -- If cmd :: arg1 --> res -- wrap :: arg1 "->" arg2 -- Then (HsCmdWrap wrap cmd) :: arg2 --> res -} -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.Located (GHC.StmtLR name name (GHC.LHsCmd name))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (GHC.TyClDecl name) where markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi 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 markTyClass ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) (GHC.HsDataDefn nd ctx mctyp mk cons mderivs) _ _) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp when (null (GHC.unLoc ctx)) $ markOptional GHC.AnnDarrow markLocated ctx markTyClass ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markMaybe mderivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fds sigs meths ats atdefs docs _) = do mark GHC.AnnClass markLocated ctx markTyClass ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass ln tyVars = do markManyOptional GHC.AnnOpenP let parensNeeded = GHC.isSymOcc (GHC.occName $ GHC.unLoc ln) && length tyVars > 2 lnFun = do ifInContext (Set.singleton CtxMiddle) (setContext (Set.singleton InfixOp) $ markLocated ln) (markLocated ln) listFun b = do if parensNeeded then ifInContext (Set.singleton (CtxPos 0)) (markMany GHC.AnnOpenP) (return ()) else ifInContext (Set.singleton (CtxPos 0)) (markManyOptional GHC.AnnOpenP) (return ()) markLocated b if parensNeeded then ifInContext (Set.singleton (CtxPos 2)) (markMany GHC.AnnCloseP) (return ()) else ifInContext (Set.singleton (CtxPos 2)) (markManyOptional GHC.AnnCloseP) (return ()) prepareListFun ls = map (\b -> (GHC.getLoc b, listFun b )) ls unsetContext CtxMiddle $ applyListAnnotationsContexts (LC (Set.fromList [CtxOnly,PrefixOp]) (Set.fromList [CtxFirst,PrefixOp]) (Set.singleton CtxMiddle) (Set.singleton CtxLast)) ([(GHC.getLoc ln,lnFun)] ++ prepareListFun tyVars) markManyOptional GHC.AnnCloseP -- --------------------------------------------------------------------- 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 _) rsig minj) = do {- data FamilyDecl name = FamilyDecl { fdInfo :: FamilyInfo name -- type/data, closed/open , fdLName :: Located name -- type constructor , fdTyVars :: LHsQTyVars name -- type variables , fdResultSig :: LFamilyResultSig name -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann } -} case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType -- ifInContext (Set.singleton InClassDecl) (return ()) (mark GHC.AnnFamily) mark GHC.AnnFamily markTyClass ln tyvars case GHC.unLoc rsig of GHC.NoSig -> return () GHC.KindSig _ -> do mark GHC.AnnDcolon markLocated rsig GHC.TyVarSig _ -> do mark GHC.AnnEqual markLocated rsig case minj of Nothing -> return () Just inj -> do mark GHC.AnnVbar markLocated inj case info of GHC.ClosedTypeFamily (Just eqns) -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } GHC.ClosedTypeFamily Nothing -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- { mark GHC.AnnDotdot mark GHC.AnnCloseC -- } _ -> return () markTrailingSemi -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.FamilyResultSig name) where markAST _ (GHC.NoSig) = return () markAST _ (GHC.KindSig k) = markLocated k markAST _ (GHC.TyVarSig ltv) = markLocated ltv -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.InjectivityAnn name) where markAST _ (GHC.InjectivityAnn ln lns) = do markLocated ln mark GHC.AnnRarrow mapM_ markLocated lns -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.TyFamInstEqn name) where markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats) typ) = do markTyClass ln pats -- let -- fun = ifInContext (Set.singleton (CtxPos 0)) -- (setContext (Set.singleton PrefixOp) $ markLocated ln) -- (markLocated ln) -- markOptional GHC.AnnOpenP -- applyListAnnotationsContexts (LC Set.empty Set.empty Set.empty Set.empty) -- ([(GHC.getLoc ln, fun)] -- ++ prepareListAnnotationWithContext (Set.singleton PrefixOp) pats) -- markOptional GHC.AnnCloseP mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.TyFamDefltEqn name) where markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) typ) = do mark GHC.AnnType mark GHC.AnnInstance applyListAnnotations (prepareListAnnotation [ln] ++ prepareListAnnotation bndrs ) mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs in markExternal l GHC.AnnVal str >> markTrailingSemi -- --------------------------------------------------------------------- markDataDefn :: (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => GHC.SrcSpan -> GHC.HsDataDefn name -> Annotated () markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons mderivs) = do markLocated ctx markMaybe typ if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons case mderivs of Nothing -> return () Just d -> setContext (Set.singleton Deriving) $ markLocated d -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LHsType name] where markAST l ts = do -- Mote: A single item in parens in a deriving clause is parsed as a -- HsSigType, which is always a HsForAllTy. Without parens it is always a -- HsVar. So for round trip pretty printing we need to take this into -- account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name,GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.ConDecl name) where markAST _ (GHC.ConDeclH98 ln mqtvs mctx dets _ ) = do {- | ConDeclH98 { con_name :: Located name , con_qvars :: Maybe (LHsQTyVars name) -- User-written forall (if any), and its implicit -- kind variables -- Non-Nothing needs -XExistentialQuantification -- e.g. data T a = forall b. MkT b (b->a) -- con_qvars = {b} , con_cxt :: Maybe (LHsContext name) -- ^ User-written context (if any) , con_details :: HsConDeclDetails name -- ^ Arguments , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. -} case mqtvs of Nothing -> return () Just (GHC.HsQTvs _ns bndrs _) -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot case mctx of Just ctx -> do setContext (Set.fromList [NoDarrow]) $ markLocated ctx unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow Nothing -> return () case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markLocated ln markHsConDeclDetails False False [ln] dets inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar markTrailingSemi markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ) _) = do setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi -- 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 -- 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 "_" -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.OutputableBndr name,GHC.HasOccName name,Annotate name) => Annotate (ResTyGADTHook name) where markAST _ (ResTyGADTHook bndrs) = do unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- --------------------------------------------------------------------- instance (Annotate name, GHC.DataId name, GHC.OutputableBndr name,GHC.HasOccName name) => Annotate (GHC.HsRecField name (GHC.LPat name)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma 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 punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.FunDep (GHC.Located name)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do markWithString GHC.AnnOpen src case mh of Nothing -> return () Just (GHC.Header srcH _h) -> markWithString GHC.AnnHeader srcH markWithString GHC.AnnVal (fst f) markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/src-ghc82/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022120 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc82/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000026645607346545000024432 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.RdrName) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.RdrName -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.RdrName) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# WARNING" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do -- markExternal ls GHC.AnnOpen txt markAnnOpen txt "{-# DEPRECATED" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate GHC.StringLiteral where markAST l (GHC.StringLiteral src fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate [GHC.LIE name] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance (GHC.DataId name,GHC.HasOccName name, Annotate name) => Annotate (GHC.IE name) where markAST _ ie = do case ie of GHC.IEVar ln -> markLocated ln GHC.IEThingAbs ln -> do setContext (Set.singleton PrefixOp) $ markLocated ln GHC.IEThingWith ln wc ns _lfs -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP case wc of GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns GHC.IEWildcard n -> do setContext (Set.fromList [PrefixOp,Intercalate]) $ mapM_ markLocated (take n ns) mark GHC.AnnDotdot case drop n ns of [] -> return () ns' -> do mark GHC.AnnComma setContext (Set.singleton PrefixOp) $ mapM_ markLocated ns' mark GHC.AnnCloseP (GHC.IEThingAll ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup _ _) -> return () (GHC.IEDoc _) -> return () (GHC.IEDocNamed _) -> return () ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name, Annotate name) => Annotate (GHC.IEWrappedName name) where markAST _ (GHC.IEName ln) = do unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEPattern ln) = do mark GHC.AnnPattern setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEType ln) = do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma {- data IEWrappedName name = IEName (Located name) -- ^ no extra | IEPattern (Located name) -- ^ pattern X | IEType (Located name) -- ^ type (:+:) deriving (Eq,Data) -} -- --------------------------------------------------------------------- {- -- 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) -} isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n canParen = isSym && rdrName2String n /= "$" doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> if str == "~" then doNormalRdrName else markExternal l GHC.AnnVal str GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- -- TODO: What is this used for? Not in ExactPrint instance Annotate GHC.Name where markAST l n = do markExternal l GHC.AnnVal (showGhc n) -- --------------------------------------------------------------------- instance (GHC.DataId name,GHC.HasOccName name,Annotate name) => Annotate (GHC.ImportDecl name) where markAST _ imp@(GHC.ImportDecl msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" case msrc of GHC.SourceText _txt -> do markAnnOpen msrc "{-# SOURCE" markWithString GHC.AnnClose "#-}" GHC.NoSourceText -> return () when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> markWithString GHC.AnnPackageName srcPkg _ -> return () markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markLocated mn case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: GHC.LHsDecl GHC.RdrName -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD d -> markLocated (GHC.L l d) GHC.InstD d -> markLocated (GHC.L l d) 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) instance Annotate (GHC.HsDecl GHC.RdrName) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.RoleAnnotDecl name) where markAST _ (GHC.RoleAnnotDecl ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance Annotate (GHC.SpliceDecl GHC.RdrName) where markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do markLocated e markTrailingSemi markAST _ (GHC.SpliceDecl e _flag) = do markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.VectDecl GHC.RdrName) where markAST _ (GHC.HsVect src ln e) = do markAnnOpen src "{-# VECTORISE" markLocated ln mark GHC.AnnEqual markLocated e markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsNoVect src ln) = do markAnnOpen src "{-# NOVECTORISE" markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsVectTypeIn src _b ln mln) = do markAnnOpen src "{-# VECTORISE" -- or "{-# VECTORISE SCALAR" mark GHC.AnnType markLocated ln case mln of Nothing -> return () Just lnn -> do mark GHC.AnnEqual markLocated lnn markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectTypeOut {} = traceM "warning: HsVectTypeOut appears after renaming" markAST _ (GHC.HsVectClassIn src ln) = do markAnnOpen src "{-# VECTORISE" mark GHC.AnnClass markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectClassOut {} = traceM "warning: HsVecClassOut appears after renaming" markAST _ GHC.HsVectInstIn {} = traceM "warning: HsVecInstsIn appears after renaming" markAST _ GHC.HsVectInstOut {} = traceM "warning: HsVecInstOut appears after renaming" -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecls GHC.RdrName) where markAST _ (GHC.HsRules src rules) = do markAnnOpen src "{-# RULES" setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecl GHC.RdrName) where markAST l (GHC.HsRule ln act bndrs lhs _ rhs _) = do markLocated ln setContext (Set.singleton ExplicitNeverActive) $ markActivation l act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi -- --------------------------------------------------------------------- markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () markActivation _ act = do case act of GHC.ActiveBefore src phase -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter src phase -> do mark GHC.AnnOpenS -- '[' markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance Annotate (GHC.RuleBndr GHC.RdrName) where markAST _ (GHC.RuleBndr ln) = markLocated ln markAST _ (GHC.RuleBndrSig ln st) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLHsSigWcType st mark GHC.AnnCloseP -- ")" -- --------------------------------------------------------------------- markLHsSigWcType :: GHC.LHsSigWcType GHC.RdrName -> Annotated () markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do markLocated ty -- --------------------------------------------------------------------- instance Annotate (GHC.AnnDecl GHC.RdrName) where markAST _ (GHC.HsAnnotation src prov e) = do markAnnOpen src "{-# ANN" case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate name => Annotate (GHC.WarnDecls name) where markAST _ (GHC.Warnings src warns) = do markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED mapM_ markLocated warns markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.WarnDecl name) where markAST _ (GHC.Warning lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.ForeignDecl GHC.RdrName) where markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ _) _ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternalSourceText ls src "" markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ _) _ (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (sourceTextToString src "") setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivDecl GHC.RdrName) where markAST _ (GHC.DerivDecl typ ms mov) = do mark GHC.AnnDeriving markMaybe ms mark GHC.AnnInstance markMaybe mov markLHsSigType typ markTrailingSemi {- stand_alone_deriving :: { LDerivDecl RdrName } : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type {% do { let { err = text "in the stand-alone deriving instance" <> colon <+> quotes (ppr $5) } ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4)) [mj AnnDeriving $1, mj AnnInstance $3] } } data DerivDecl name = DerivDecl { deriv_type :: LHsSigType name , deriv_strategy :: Maybe (Located DerivStrategy) , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation } -} -- --------------------------------------------------------------------- instance Annotate GHC.DerivStrategy where markAST _ GHC.StockStrategy = mark GHC.AnnStock markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype -- --------------------------------------------------------------------- instance Annotate (GHC.DefaultDecl GHC.RdrName) where markAST _ (GHC.DefaultDecl typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.InstDecl GHC.RdrName) where markAST l (GHC.ClsInstD cid) = markAST l cid markAST l (GHC.DataFamInstD dfid) = markAST l dfid markAST l (GHC.TyFamInstD tfid) = markAST l tfid -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where -- NOTE: NoOverlap is only used in the typechecker markAST _ (GHC.NoOverlap src) = do markAnnOpen src "{-# NO_OVERLAP" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markAnnOpen src "{-# OVERLAPPABLE" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markAnnOpen src "{-# OVERLAPPING" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markAnnOpen src "{-# OVERLAPS" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markAnnOpen src "{-# INCOHERENT" markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.ClsInstDecl GHC.RdrName) where markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly _) binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstDecl GHC.RdrName) where markAST _ (GHC.TyFamInstDecl eqn _) = do mark GHC.AnnType inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance -- Note: this keyword is optional markLocated eqn markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.DataFamInstDecl GHC.RdrName) where markAST l (GHC.DataFamInstDecl ln (GHC.HsIB _ pats _) fixity defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) _) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData inContext (Set.singleton TopLevel) $ mark GHC.AnnInstance markLocated ctx markTyClass fixity ln pats case (GHC.dd_kindSig defn) of Just s -> do mark GHC.AnnDcolon markLocated s Nothing -> return () if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.HsBind GHC.RdrName) where markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs -- TODO: extract this common code case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixPatSyn la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixPatSyn ns -> do markLocated ln mapM_ markLocated ns GHC.RecordPatSyn fs -> do markLocated ln mark GHC.AnnOpenC -- '{' markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs mark GHC.AnnCloseC -- '}' case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- Introduced after renaming. markAST _ (GHC.AbsBinds _ _ _ _ _) = traceM "warning: AbsBinds introduced after renaming" -- Introduced after renaming. markAST _ GHC.AbsBindsSig{} = traceM "warning: AbsBindsSig introduced after renaming" -- --------------------------------------------------------------------- instance Annotate (GHC.IPBind GHC.RdrName) where markAST _ (GHC.IPBind en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Match GHC.RdrName (GHC.Located body)) where markAST _ (GHC.Match mln pats _typ (GHC.GRHSs grhs (GHC.L _ lb))) = do let get_infix (GHC.FunRhs _ f _) = f get_infix _ = GHC.Prefix isFunBind GHC.FunRhs{} = True isFunBind _ = False case (get_infix mln,pats) of (GHC.Infix, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n _ -> return () markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of GHC.FunRhs n _ s -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do when (s == GHC.SrcStrict) $ mark GHC.AnnBang markLocated n mapM_ markLocated pats _ -> markListNoPrecedingSpace False pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.GRHS GHC.RdrName (GHC.Located body)) where markAST _ (GHC.GRHS guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr -- --------------------------------------------------------------------- instance Annotate (GHC.Sig GHC.RdrName) where markAST _ (GHC.TypeSig lns st) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLHsSigWcType st markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig lns (GHC.HsIB _ typ _)) = do mark GHC.AnnPattern markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ _)) = do when isDefault $ mark GHC.AnnDefault setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig _) = traceM "warning: Introduced after renaming" markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markSourceText src (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi markAST l (GHC.InlineSig ln inl) = do markAnnOpen (GHC.inl_src inl) "{-# INLINE" markActivation l (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST l (GHC.SpecSig ln typs inl) = do markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE markActivation l (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalateWithFunLevel markLHsSigType 2 typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecInstSig src typ) = do markAnnOpen src "{-# SPECIALISE" mark GHC.AnnInstance markLHsSigType typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.MinimalSig src formula) = do markAnnOpen src "{-# MINIMAL" markLocated formula markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.SCCFunSig src ln ml) = do markAnnOpen src "{-# SCC" markLocated ln markMaybe ml markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.CompleteMatchSig src (GHC.L _ ns) mlns) = do markAnnOpen src "{-# COMPLETE" markListIntercalate ns case mlns of Nothing -> return () Just _ -> do mark GHC.AnnDcolon markMaybe mlns markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- -------------------------------------------------------------------- markLHsSigType :: GHC.LHsSigType GHC.RdrName -> Annotated () markLHsSigType (GHC.HsIB _ typ _) = markLocated typ instance Annotate [GHC.LHsSigType GHC.RdrName] where markAST _ ls = do mark GHC.AnnDeriving -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it -- is a HsTyVar. So for round trip pretty printing we need to take this into -- account. case ls of [] -> markManyOptional GHC.AnnOpenP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP [_] -> markManyOptional GHC.AnnOpenP _ -> markMany GHC.AnnOpenP markListIntercalateWithFun markLHsSigType ls case ls of [] -> markManyOptional GHC.AnnCloseP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP [_] -> markManyOptional GHC.AnnCloseP _ -> markMany GHC.AnnCloseP -- -------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where markAST _ (GHC.Var x) = do setContext (Set.singleton PrefixOp) $ markLocated x inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls markAST _ (GHC.And ls) = do markListIntercalateWithFunLevel markLocated 2 ls inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Parens x) = do mark GHC.AnnOpenP -- '(' markLocated x mark GHC.AnnCloseP -- ')' inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsTyVarBndr GHC.RdrName) where markAST _l (GHC.UserTyVar n) = do markLocated n markAST _ (GHC.KindedTyVar n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' -- --------------------------------------------------------------------- instance Annotate (GHC.HsType GHC.RdrName) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType _ (GHC.HsForAllTy tvs typ) = do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot markLocated typ markType _ (GHC.HsQualTy cxt typ) = do markLocated cxt markLocated typ markType _ (GHC.HsTyVar promoted name) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote markLocated name markType _ (GHC.HsAppsTy ts) = do mapM_ markLocated ts inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar markType _ (GHC.HsAppTy t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 markType _ (GHC.HsListTy t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsPArrTy t) = do markWithString GHC.AnnOpen "[:" -- '[:' markLocated t markWithString GHC.AnnClose ":]" -- ':]' markType _ (GHC.HsTupleTy tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsSumTy tys) = do markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys markWithString GHC.AnnClose "#)" markType _ (GHC.HsOpTy t1 lo t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy n t) = do markLocated n mark GHC.AnnDcolon markLocated t markType _ (GHC.HsEqTy t1 t2) = do markLocated t1 mark GHC.AnnTilde markLocated t2 markType _ (GHC.HsKindSig t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy s _) = do markAST l s markType _ (GHC.HsDocTy t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do case mt of GHC.NoSourceText -> return () GHC.SourceText src -> do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" case str of GHC.SrcLazy -> mark GHC.AnnTilde GHC.SrcStrict -> mark GHC.AnnBang GHC.NoSrcStrict -> return () markLocated t markType _ (GHC.HsRecTy cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' markType _ (GHC.HsCoreTy _t) = traceM "warning: HsCoreTy Introduced after renaming" markType _ (GHC.HsExplicitListTy promoted _ ts) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP markType l (GHC.HsTyLit lit) = do case lit of (GHC.HsNumTy s v) -> markExternalSourceText l s (show v) (GHC.HsStrTy s v) -> markExternalSourceText l s (show v) markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do markExternal l GHC.AnnVal "_" -- --------------------------------------------------------------------- instance Annotate (GHC.HsAppType GHC.RdrName) where markAST _ (GHC.HsAppInfix n) = do when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote setContext (Set.singleton InfixOp) $ markLocated n markAST _ (GHC.HsAppPrefix t) = do markOptional GHC.AnnTilde setContext (Set.singleton PrefixOp) $ markLocated t -- --------------------------------------------------------------------- instance Annotate (GHC.HsSplice GHC.RdrName) where markAST l c = case c of GHC.HsQuasiQuote _ n _pos fs -> do markExternal l GHC.AnnVal -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") GHC.HsTypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsTypedSplice hasParens _n b -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP -- ------------------------------- GHC.HsUntypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsUntypedSplice hasParens _n b -> do case hasParens of GHC.HasParens -> mark GHC.AnnOpenPE GHC.HasDollar -> mark GHC.AnnThIdSplice GHC.NoParens -> return () markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" -- --------------------------------------------------------------------- instance Annotate (GHC.ConDeclField GHC.RdrName) where markAST _ (GHC.ConDeclField ns ty mdoc) = do unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.FieldOcc name) where markAST _ (GHC.FieldOcc rn _) = do markLocated rn inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l (GHC.HsDocString s) = do markExternal l GHC.AnnVal (GHC.unpackFS s) -- --------------------------------------------------------------------- instance Annotate (GHC.Pat GHC.RdrName) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) markPat _ (GHC.LazyPat p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat ps _ _) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat pats b _) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.SumPat pat alt arity _) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated pat replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markPat _ (GHC.PArrPat ps _) = do markWithString GHC.AnnOpen "[:" mapM_ markLocated ps markWithString GHC.AnnClose ":]" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" markPat _ (GHC.ViewPat e pat _) = do markLocated e mark GHC.AnnRarrow markLocated pat markPat l (GHC.SplicePat s) = do markAST l s markPat l (GHC.LitPat lp) = markAST l lp markPat _ (GHC.NPat ol mn _ _) = do when (isJust mn) $ mark GHC.AnnMinus markLocated ol markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPatIn pat ty) = do markLocated pat mark GHC.AnnDcolon markLHsSigWcType ty markPat _ GHC.SigPatOut {} = traceM "warning: SigPatOut introduced after renaming" markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit -> String hsLit2String lit = case lit of GHC.HsChar src v -> toSourceTextWithSuffix src v "" -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" GHC.HsString src v -> toSourceTextWithSuffix src v "" GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt src v -> toSourceTextWithSuffix src v "" GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" GHC.HsRat (GHC.FL src _) _ -> src GHC.HsFloatPrim (GHC.FL src _) -> src ++ "#" GHC.HsDoublePrim (GHC.FL src _) -> src ++ "##" toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix -- -------------------------------------------------------------------- markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.RdrName -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.RdrName -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance Annotate [GHC.LConDeclField GHC.RdrName] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.HsOverLit name) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral src _ -> src GHC.HsFractional l2 -> GHC.SourceText $ GHC.fl_text l2 GHC.HsIsString src _ -> src in markExternalSourceText l str "" -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate arg) => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where markAST _ (GHC.HsIB _ thing _) = do markLocated thing -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Stmt GHC.RdrName (GHC.Located body)) where markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt pat body _ _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ GHC.ApplicativeStmt{} = error "ApplicativeStmt should not appear in ParsedSource" markAST _ (GHC.BodyStmt body _ _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt (GHC.L _ lb)) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt pbs _ _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance Annotate (GHC.ParStmtBlock GHC.RdrName GHC.RdrName) where markAST _ (GHC.ParStmtBlock stmts _ns _) = do markListIntercalate stmts -- --------------------------------------------------------------------- instance Annotate (GHC.HsLocalBinds GHC.RdrName) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: GHC.HsLocalBinds GHC.RdrName -> Annotated () markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) = traceM "warning: ValBindsOut introduced after renaming" markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds markHsLocalBinds GHC.EmptyLocalBinds = return () -- --------------------------------------------------------------------- markMatchGroup :: (Annotate body) => GHC.SrcSpan -> GHC.MatchGroup GHC.RdrName (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -- --------------------------------------------------------------------- instance (Annotate body) => Annotate [GHC.Located (GHC.Match GHC.RdrName (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsExpr GHC.RdrName) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do ifInContext (Set.singleton PrefixOp) (setContext (Set.singleton PrefixOp) $ markLocated n) (ifInContext (Set.singleton InfixOp) (setContext (Set.singleton InfixOp) $ markLocated n) (markLocated n) ) markExpr l (GHC.HsRecFld f) = markAST l f markExpr l (GHC.HsOverLabel _ fs) = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) markExpr l (GHC.HsIPVar n@(GHC.HsIPName _v)) = markAST l n markExpr l (GHC.HsOverLit ov) = markAST l ov markExpr l (GHC.HsLit lit) = markAST l lit markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp e1 e2) = do setContext (Set.singleton PrefixOp) $ markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp e1 e2 _ e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar _) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr _ (GHC.ExplicitSum alt arity e _) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated e replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then case cts of GHC.PArrComp -> ("[:",":]") _ -> ("[", "]") else ("{","}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.ExplicitPArr _ es) = do markWithString GHC.AnnOpen "[:" markListIntercalateWithFunLevel markLocated 2 es markWithString GHC.AnnClose ":]" markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig e typ) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ExprWithTySigOut _e _typ) = error "ExprWithTySigOut only occurs after renamer" markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.PArrSeq _ seqInfo) = do markWithString GHC.AnnOpen "[:" -- '[:' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 markWithString GHC.AnnClose ":]" -- ':]' markExpr _ (GHC.HsSCC src csFStr e) = do markAnnOpen src "{-# SCC" let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithStringOptional GHC.AnnVal txt markWithString GHC.AnnValStr txt markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn src csFStr e) = do -- markWithString GHC.AnnOpen src -- "{-# CORE" markAnnOpen src "{-# CORE" -- markWithString GHC.AnnVal (GHC.sl_st csFStr) markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC mark GHC.AnnCloseQ -- "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do mark GHC.AnnOpenEQ -- "[|" markOptional GHC.AnnOpenE -- "[e|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do markWithString GHC.AnnOpen "[||" markWithStringOptional GHC.AnnOpenE "[e||" markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do markWithString GHC.AnnOpen "[t|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do markWithString GHC.AnnOpen "[p|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsRnBracketOut _ _) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut _ _) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr l (GHC.HsSpliceE e) = markAST l e markExpr _ (GHC.HsProc p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic _ e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpen "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnClose "|)" markExpr _ (GHC.HsTick _ _) = return () markExpr _ (GHC.HsBinTick _ _ _) = return () markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markAnnOpen src "{-# GENERATED" markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING let markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s markOne 1 v1 s1 -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOne 2 v2 s2 -- INTEGER mark GHC.AnnMinus -- '-' markOne 3 v3 s3 -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOne 4 v4 s4 -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l GHC.EWildPat = do ifInContext (Set.fromList [InfixOp]) (do mark GHC.AnnBackquote markWithString GHC.AnnVal "_" mark GHC.AnnBackquote) (markExternal l GHC.AnnVal "_") markExpr _ (GHC.EAsPat ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsAppType e ty) = do markLocated e markInstead GHC.AnnAt AnnTypeApp markLHsWcType ty markExpr _ (GHC.HsAppTypeOut _ _) = traceM "warning: HsAppTypeOut introduced after renaming" markExpr _ (GHC.HsWrap _ _) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar _) = traceM "warning: HsUnboundVar introduced after renaming" markExpr _ (GHC.HsConLikeOut{}) = traceM "warning: HsConLikeOut introduced after type checking" -- --------------------------------------------------------------------- markLHsWcType :: GHC.LHsWcType GHC.RdrName -> Annotated () markLHsWcType (GHC.HsWC _ ty) = do markLocated ty -- --------------------------------------------------------------------- instance Annotate GHC.HsLit where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecUpdField GHC.RdrName) where markAST _ (GHC.HsRecField lbl expr punFlag) = do unsetContext Intercalate $ markLocated lbl when (punFlag == False) $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated expr inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance (GHC.DataId name) => Annotate (GHC.AmbiguousFieldOcc name) where markAST _ (GHC.Unambiguous n _) = markLocated n markAST _ (GHC.Ambiguous n _) = markLocated n -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance Annotate [GHC.ExprLStmt GHC.RdrName] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsTupArg GHC.RdrName) where markAST _ (GHC.Present (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsCmdTop GHC.RdrName) where markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd instance Annotate (GHC.HsCmd GHC.RdrName) where markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm e fixity _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm let isPrefixOp = case fixity of GHC.Infix -> False GHC.Prefix -> True when isPrefixOp $ mark GHC.AnnOpenB -- "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ mark GHC.AnnCloseB -- "|)" markAST _ (GHC.HsCmdApp e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdWrap {}) = traceM "warning: HsCmdWrap introduced after renaming" -- --------------------------------------------------------------------- instance Annotate [GHC.Located (GHC.StmtLR GHC.RdrName GHC.RdrName (GHC.LHsCmd GHC.RdrName))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.TyClDecl GHC.RdrName) where markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) fixity 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 markTyClass fixity ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) fixity (GHC.HsDataDefn nd ctx mctyp mk cons derivs) _ _) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp markLocated ctx markTyClass fixity ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fixity fds sigs meths ats atdefs docs _) = do mark GHC.AnnClass markLocated ctx markTyClass fixity ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass fixity ln tyVars = do let markParens = if fixity == GHC.Infix && length tyVars > 2 then markMany else markManyOptional if fixity == GHC.Prefix then do markManyOptional GHC.AnnOpenP setContext (Set.singleton PrefixOp) $ markLocated ln setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars when (length tyVars >= 2) $ do markParens GHC.AnnCloseP setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars markManyOptional GHC.AnnCloseP else do case tyVars of (x:y:xs) -> do markParens GHC.AnnOpenP markLocated x setContext (Set.singleton InfixOp) $ markLocated ln markLocated y markParens GHC.AnnCloseP mapM_ markLocated xs markManyOptional GHC.AnnCloseP _ -> error $ "markTyClass: Infix op without operands" -- --------------------------------------------------------------------- instance Annotate [GHC.LHsDerivingClause GHC.RdrName] where markAST _ ds = mapM_ markLocated ds -- --------------------------------------------------------------------- instance Annotate (GHC.HsDerivingClause GHC.RdrName) where markAST _ (GHC.HsDerivingClause mstrategy (GHC.L _ typs)) = do let needsParens = case typs of [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False _ -> True mark GHC.AnnDeriving markMaybe mstrategy if needsParens then mark GHC.AnnOpenP else markOptional GHC.AnnOpenP markListIntercalateWithFunLevel markLHsSigType 2 typs if needsParens then mark GHC.AnnCloseP else markOptional GHC.AnnCloseP -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyDecl GHC.RdrName) where markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) fixity rsig minj) = do case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass fixity ln tyvars case GHC.unLoc rsig of GHC.NoSig -> return () GHC.KindSig _ -> do mark GHC.AnnDcolon markLocated rsig GHC.TyVarSig _ -> do mark GHC.AnnEqual markLocated rsig case minj of Nothing -> return () Just inj -> do mark GHC.AnnVbar markLocated inj case info of GHC.ClosedTypeFamily (Just eqns) -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } GHC.ClosedTypeFamily Nothing -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- { mark GHC.AnnDotdot mark GHC.AnnCloseC -- } _ -> return () markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyResultSig GHC.RdrName) where markAST _ (GHC.NoSig) = return () markAST _ (GHC.KindSig k) = markLocated k markAST _ (GHC.TyVarSig ltv) = markLocated ltv -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.InjectivityAnn name) where markAST _ (GHC.InjectivityAnn ln lns) = do markLocated ln mark GHC.AnnRarrow mapM_ markLocated lns -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstEqn GHC.RdrName) where markAST _ (GHC.TyFamEqn ln (GHC.HsIB _ pats _) fixity typ) = do markTyClass fixity ln pats mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamDefltEqn GHC.RdrName) where markAST _ (GHC.TyFamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do mark GHC.AnnType mark GHC.AnnInstance markTyClass fixity ln bndrs mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs in markExternal l GHC.AnnVal str >> markTrailingSemi -- --------------------------------------------------------------------- markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.RdrName -> Annotated () markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons derivs) = do markLocated ctx markMaybe typ if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons setContext (Set.singleton Deriving) $ markLocated derivs -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance Annotate [GHC.LHsType GHC.RdrName] where markAST l ts = do -- Mote: A single item in parens in a deriving clause is parsed as a -- HsSigType, which is always a HsForAllTy. Without parens it is always a -- HsVar. So for round trip pretty printing we need to take this into -- account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.RdrName) where markAST _ (GHC.ConDeclH98 ln mqtvs mctx dets _ ) = do case mqtvs of Nothing -> return () Just (GHC.HsQTvs _ns bndrs _) -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot case mctx of Just ctx -> do setContext (Set.fromList [NoDarrow]) $ markLocated ctx unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow Nothing -> return () case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markLocated ln markHsConDeclDetails False False [ln] dets inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar markTrailingSemi markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi -- 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.OutputableBndrId name) => GHC.Outputable (ResTyGADTHook name) where ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs -- 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 "_" -- --------------------------------------------------------------------- instance Annotate (ResTyGADTHook GHC.RdrName) where markAST _ (ResTyGADTHook bndrs) = do unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecField GHC.RdrName (GHC.LPat GHC.RdrName)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.HsRecField GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate name) => Annotate (GHC.FunDep (GHC.Located name)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do -- markWithString GHC.AnnOpen src markAnnOpen src "" case mh of Nothing -> return () Just (GHC.Header srcH _h) -> -- markWithString GHC.AnnHeader srcH markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") -- markWithString GHC.AnnVal (fst f) markSourceText (fst f) (GHC.unpackFS $ snd f) markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- stringLiteralToString :: GHC.StringLiteral -> String stringLiteralToString (GHC.StringLiteral st fs) = case st of GHC.NoSourceText -> GHC.unpackFS fs GHC.SourceText src -> src ghc-exactprint-0.6.2/src-ghc84/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022122 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc84/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000026155407346545000024426 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.GhcPs) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# WARNING" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# DEPRECATED" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate GHC.StringLiteral where markAST l (GHC.StringLiteral src fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) -- --------------------------------------------------------------------- instance Annotate [GHC.LIE GHC.GhcPs] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance Annotate (GHC.IE GHC.GhcPs) where markAST _ ie = do case ie of GHC.IEVar ln -> markLocated ln GHC.IEThingAbs ln -> do setContext (Set.singleton PrefixOp) $ markLocated ln GHC.IEThingWith ln wc ns _lfs -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP case wc of GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns GHC.IEWildcard n -> do setContext (Set.fromList [PrefixOp,Intercalate]) $ mapM_ markLocated (take n ns) mark GHC.AnnDotdot case drop n ns of [] -> return () ns' -> do mark GHC.AnnComma unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns' mark GHC.AnnCloseP (GHC.IEThingAll ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup _ _) -> return () (GHC.IEDoc _) -> return () (GHC.IEDocNamed _) -> return () ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- instance Annotate (GHC.IEWrappedName GHC.RdrName) where markAST _ (GHC.IEName ln) = do unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEPattern ln) = do mark GHC.AnnPattern setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEType ln) = do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n canParen = isSym doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> if str == "~" then doNormalRdrName else markExternal l GHC.AnnVal str GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- instance Annotate (GHC.ImportDecl GHC.GhcPs) where markAST _ imp@(GHC.ImportDecl msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" case msrc of GHC.SourceText _txt -> do markAnnOpen msrc "{-# SOURCE" markWithString GHC.AnnClose "#-}" GHC.NoSourceText -> return () when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> markWithString GHC.AnnPackageName srcPkg _ -> return () markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markLocated mn case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD d -> markLocated (GHC.L l d) GHC.InstD d -> markLocated (GHC.L l d) 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) instance Annotate (GHC.HsDecl GHC.GhcPs) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where markAST _ (GHC.RoleAnnotDecl ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance Annotate (GHC.SpliceDecl GHC.GhcPs) where markAST _ (GHC.SpliceDecl e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do markLocated e markTrailingSemi markAST _ (GHC.SpliceDecl e _flag) = do markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.VectDecl GHC.GhcPs) where markAST _ (GHC.HsVect src ln e) = do markAnnOpen src "{-# VECTORISE" markLocated ln mark GHC.AnnEqual markLocated e markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsNoVect src ln) = do markAnnOpen src "{-# NOVECTORISE" markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ (GHC.HsVectTypeIn src _b ln mln) = do markAnnOpen src "{-# VECTORISE" -- or "{-# VECTORISE SCALAR" mark GHC.AnnType markLocated ln case mln of Nothing -> return () Just lnn -> do mark GHC.AnnEqual markLocated lnn markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectTypeOut {} = traceM "warning: HsVectTypeOut appears after renaming" markAST _ (GHC.HsVectClassIn src ln) = do markAnnOpen src "{-# VECTORISE" mark GHC.AnnClass markLocated ln markWithString GHC.AnnClose "#-}" -- "#-}" markAST _ GHC.HsVectClassOut {} = traceM "warning: HsVecClassOut appears after renaming" markAST _ GHC.HsVectInstIn {} = traceM "warning: HsVecInstsIn appears after renaming" markAST _ GHC.HsVectInstOut {} = traceM "warning: HsVecInstOut appears after renaming" -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecls GHC.GhcPs) where markAST _ (GHC.HsRules src rules) = do markAnnOpen src "{-# RULES" setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecl GHC.GhcPs) where markAST l (GHC.HsRule ln act bndrs lhs _ rhs _) = do markLocated ln setContext (Set.singleton ExplicitNeverActive) $ markActivation l act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi -- --------------------------------------------------------------------- markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () markActivation _ act = do case act of GHC.ActiveBefore src phase -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter src phase -> do mark GHC.AnnOpenS -- '[' markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance Annotate (GHC.RuleBndr GHC.GhcPs) where markAST _ (GHC.RuleBndr ln) = markLocated ln markAST _ (GHC.RuleBndrSig ln st) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLHsSigWcType st mark GHC.AnnCloseP -- ")" -- --------------------------------------------------------------------- markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty _)) = do markLocated ty -- --------------------------------------------------------------------- instance Annotate (GHC.AnnDecl GHC.GhcPs) where markAST _ (GHC.HsAnnotation src prov e) = do markAnnOpen src "{-# ANN" case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecls GHC.GhcPs) where markAST _ (GHC.Warnings src warns) = do markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED mapM_ markLocated warns markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecl GHC.GhcPs) where markAST _ (GHC.Warning lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.ForeignDecl GHC.GhcPs) where markAST _ (GHC.ForeignImport ln (GHC.HsIB _ typ _) _ (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternalSourceText ls src "" markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport ln (GHC.HsIB _ typ _) _ (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (sourceTextToString src "") setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivDecl GHC.GhcPs) where markAST _ (GHC.DerivDecl typ ms mov) = do mark GHC.AnnDeriving markMaybe ms mark GHC.AnnInstance markMaybe mov markLHsSigType typ markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.DerivStrategy where markAST _ GHC.StockStrategy = mark GHC.AnnStock markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype -- --------------------------------------------------------------------- instance Annotate (GHC.DefaultDecl GHC.GhcPs) where markAST _ (GHC.DefaultDecl typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.InstDecl GHC.GhcPs) where markAST l (GHC.ClsInstD cid) = markAST l cid markAST l (GHC.DataFamInstD dfid) = markAST l dfid markAST l (GHC.TyFamInstD tfid) = markAST l tfid -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where -- NOTE: NoOverlap is only used in the typechecker markAST _ (GHC.NoOverlap src) = do markAnnOpen src "{-# NO_OVERLAP" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markAnnOpen src "{-# OVERLAPPABLE" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markAnnOpen src "{-# OVERLAPPING" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markAnnOpen src "{-# OVERLAPS" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markAnnOpen src "{-# INCOHERENT" markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where markAST _ (GHC.ClsInstDecl (GHC.HsIB _ poly _) binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn _)) = do mark GHC.AnnType mark GHC.AnnInstance -- Note: this keyword is optional markFamEqn eqn markTrailingSemi -- --------------------------------------------------------------------- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) -> Annotated () markFamEqn (GHC.FamEqn ln pats fixity rhs) = do markTyClass fixity ln pats mark GHC.AnnEqual markLocated rhs -- --------------------------------------------------------------------- instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn ln pats fixity defn@(GHC.HsDataDefn nd ctx typ _mk cons mderivs) ) _ )) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData mark GHC.AnnInstance markLocated ctx markTyClass fixity ln pats case (GHC.dd_kindSig defn) of Just s -> do mark GHC.AnnDcolon markLocated s Nothing -> return () if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.HsBind GHC.GhcPs) where markAST _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun -- ----------------------------------- markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs (GHC.L _ lb)) _typ _fvs _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs -- TODO: extract this common code case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse -- ----------------------------------- -- Introduced after renaming. markAST _ (GHC.AbsBinds {}) = traceM "warning: AbsBinds introduced after renaming" -- ----------------------------------- markAST l (GHC.PatSynBind (GHC.PSB ln _fvs args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixCon la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixCon ns -> do markLocated ln mapM_ markLocated ns GHC.RecCon fs -> do markLocated ln mark GHC.AnnOpenC -- '{' markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs mark GHC.AnnCloseC -- '}' case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.IPBind GHC.GhcPs) where markAST _ (GHC.IPBind en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.Match mln pats (GHC.GRHSs grhs (GHC.L _ lb))) = do let get_infix (GHC.FunRhs _ f _) = f get_infix _ = GHC.Prefix isFunBind GHC.FunRhs{} = True isFunBind _ = False case (get_infix mln,pats) of (GHC.Infix, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n _ -> return () markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of GHC.FunRhs n _ s -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do when (s == GHC.SrcStrict) $ mark GHC.AnnBang markLocated n mapM_ markLocated pats _ -> markListNoPrecedingSpace False pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.GRHS guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr -- --------------------------------------------------------------------- instance Annotate (GHC.Sig GHC.GhcPs) where markAST _ (GHC.TypeSig lns st) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLHsSigWcType st markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig lns (GHC.HsIB _ typ _)) = do mark GHC.AnnPattern markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.ClassOpSig isDefault ns (GHC.HsIB _ typ _)) = do when isDefault $ mark GHC.AnnDefault setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig _) = traceM "warning: Introduced after renaming" markAST _ (GHC.FixSig (GHC.FixitySig lns (GHC.Fixity src v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markSourceText src (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi markAST l (GHC.InlineSig ln inl) = do markAnnOpen (GHC.inl_src inl) "{-# INLINE" markActivation l (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST l (GHC.SpecSig ln typs inl) = do markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE markActivation l (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalateWithFunLevel markLHsSigType 2 typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecInstSig src typ) = do markAnnOpen src "{-# SPECIALISE" mark GHC.AnnInstance markLHsSigType typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.MinimalSig src formula) = do markAnnOpen src "{-# MINIMAL" markLocated formula markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.SCCFunSig src ln ml) = do markAnnOpen src "{-# SCC" markLocated ln markMaybe ml markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.CompleteMatchSig src (GHC.L _ ns) mlns) = do markAnnOpen src "{-# COMPLETE" markListIntercalate ns case mlns of Nothing -> return () Just _ -> do mark GHC.AnnDcolon markMaybe mlns markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- -------------------------------------------------------------------- markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () markLHsSigType (GHC.HsIB _ typ _) = markLocated typ instance Annotate [GHC.LHsSigType GHC.GhcPs] where markAST _ ls = do mark GHC.AnnDeriving -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it -- is a HsTyVar. So for round trip pretty printing we need to take this into -- account. case ls of [] -> markManyOptional GHC.AnnOpenP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnOpenP [_] -> markManyOptional GHC.AnnOpenP _ -> markMany GHC.AnnOpenP markListIntercalateWithFun markLHsSigType ls case ls of [] -> markManyOptional GHC.AnnCloseP [GHC.HsIB _ (GHC.L _ GHC.HsAppsTy{}) _] -> markMany GHC.AnnCloseP [_] -> markManyOptional GHC.AnnCloseP _ -> markMany GHC.AnnCloseP -- -------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where markAST _ (GHC.Var x) = do setContext (Set.singleton PrefixOp) $ markLocated x inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls markAST _ (GHC.And ls) = do markListIntercalateWithFunLevel markLocated 2 ls inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Parens x) = do mark GHC.AnnOpenP -- '(' markLocated x mark GHC.AnnCloseP -- ')' inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where markAST _l (GHC.UserTyVar n) = do markLocated n markAST _ (GHC.KindedTyVar n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' -- --------------------------------------------------------------------- instance Annotate (GHC.HsType GHC.GhcPs) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType _ (GHC.HsForAllTy tvs typ) = do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot markLocated typ markType _ (GHC.HsQualTy cxt typ) = do markLocated cxt markLocated typ markType _ (GHC.HsTyVar promoted name) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote markLocated name markType _ (GHC.HsAppsTy ts) = do mapM_ markLocated ts inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar markType _ (GHC.HsAppTy t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 markType _ (GHC.HsListTy t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsPArrTy t) = do markWithString GHC.AnnOpen "[:" -- '[:' markLocated t markWithString GHC.AnnClose ":]" -- ':]' markType _ (GHC.HsTupleTy tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsSumTy tys) = do markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys markWithString GHC.AnnClose "#)" markType _ (GHC.HsOpTy t1 lo t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy n t) = do markLocated n mark GHC.AnnDcolon markLocated t markType _ (GHC.HsEqTy t1 t2) = do markLocated t1 mark GHC.AnnTilde markLocated t2 markType _ (GHC.HsKindSig t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy s _) = do markAST l s markType _ (GHC.HsDocTy t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy (GHC.HsSrcBang mt _up str) t) = do case mt of GHC.NoSourceText -> return () GHC.SourceText src -> do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" case str of GHC.SrcLazy -> mark GHC.AnnTilde GHC.SrcStrict -> mark GHC.AnnBang GHC.NoSrcStrict -> return () markLocated t markType _ (GHC.HsRecTy cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' markType _ (GHC.HsCoreTy _t) = traceM "warning: HsCoreTy Introduced after renaming" markType _ (GHC.HsExplicitListTy promoted _ ts) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP markType l (GHC.HsTyLit lit) = do case lit of (GHC.HsNumTy s v) -> markExternalSourceText l s (show v) (GHC.HsStrTy s v) -> markExternalSourceText l s (show v) markType l (GHC.HsWildCardTy (GHC.AnonWildCard _)) = do markExternal l GHC.AnnVal "_" -- --------------------------------------------------------------------- instance Annotate (GHC.HsAppType GHC.GhcPs) where markAST _ (GHC.HsAppInfix n) = do when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote setContext (Set.singleton InfixOp) $ markLocated n markAST _ (GHC.HsAppPrefix t) = do markOptional GHC.AnnTilde setContext (Set.singleton PrefixOp) $ markLocated t -- --------------------------------------------------------------------- instance Annotate (GHC.HsSplice GHC.GhcPs) where markAST l c = case c of GHC.HsQuasiQuote _ n _pos fs -> do markExternal l GHC.AnnVal -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") GHC.HsTypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsTypedSplice hasParens _n b -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP -- ------------------------------- GHC.HsUntypedSplice hasParens _n b@(GHC.L _ (GHC.HsVar (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsUntypedSplice hasParens _n b -> do case hasParens of GHC.HasParens -> mark GHC.AnnOpenPE GHC.HasDollar -> mark GHC.AnnThIdSplice GHC.NoParens -> return () markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" -- --------------------------------------------------------------------- instance Annotate (GHC.ConDeclField GHC.GhcPs) where markAST _ (GHC.ConDeclField ns ty mdoc) = do unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance (GHC.DataId name) => Annotate (GHC.FieldOcc name) where markAST _ (GHC.FieldOcc rn _) = do markLocated rn inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l (GHC.HsDocString s) = do markExternal l GHC.AnnVal (GHC.unpackFS s) -- --------------------------------------------------------------------- instance Annotate (GHC.Pat GHC.GhcPs) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) markPat _ (GHC.LazyPat p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat ps _ _) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat pats b _) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.SumPat pat alt arity _) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated pat replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markPat _ (GHC.PArrPat ps _) = do markWithString GHC.AnnOpen "[:" mapM_ markLocated ps markWithString GHC.AnnClose ":]" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" markPat _ (GHC.ViewPat e pat _) = do markLocated e mark GHC.AnnRarrow markLocated pat markPat l (GHC.SplicePat s) = do markAST l s markPat l (GHC.LitPat lp) = markAST l lp markPat _ (GHC.NPat ol mn _ _) = do when (isJust mn) $ mark GHC.AnnMinus markLocated ol markPat _ (GHC.NPlusKPat ln ol _ _ _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPatIn pat ty) = do markLocated pat mark GHC.AnnDcolon markLHsSigWcType ty markPat _ GHC.SigPatOut {} = traceM "warning: SigPatOut introduced after renaming" markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit GHC.GhcPs -> String hsLit2String lit = case lit of GHC.HsChar src v -> toSourceTextWithSuffix src v "" -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" GHC.HsString src v -> toSourceTextWithSuffix src v "" GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix -- -------------------------------------------------------------------- markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance Annotate [GHC.LConDeclField GHC.GhcPs] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance Annotate (GHC.HsOverLit GHC.GhcPs) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral (GHC.IL src _ _) -> src GHC.HsFractional (GHC.FL src _ _) -> src GHC.HsIsString src _ -> src in markExternalSourceText l str "" -- --------------------------------------------------------------------- instance (GHC.DataId name,Annotate arg) => Annotate (GHC.HsImplicitBndrs name (GHC.Located arg)) where markAST _ (GHC.HsIB _ thing _) = do markLocated thing -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.LastStmt body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt pat body _ _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ GHC.ApplicativeStmt{} = error "ApplicativeStmt should not appear in ParsedSource" markAST _ (GHC.BodyStmt body _ _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt (GHC.L _ lb)) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt pbs _ _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where markAST _ (GHC.ParStmtBlock stmts _ns _) = do markListIntercalate stmts -- --------------------------------------------------------------------- instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markHsLocalBinds (GHC.HsValBinds (GHC.ValBindsIn binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsValBinds GHC.ValBindsOut {}) = traceM "warning: ValBindsOut introduced after renaming" markHsLocalBinds (GHC.HsIPBinds (GHC.IPBinds binds _)) = markListWithLayout binds markHsLocalBinds GHC.EmptyLocalBinds = return () -- --------------------------------------------------------------------- markMatchGroup :: (Annotate body) => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG (GHC.L _ matches) _ _ _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches -- --------------------------------------------------------------------- instance (Annotate body) => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsExpr GHC.GhcPs) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr _ (GHC.HsVar n) = unsetContext Intercalate $ do ifInContext (Set.singleton PrefixOp) (setContext (Set.singleton PrefixOp) $ markLocated n) (ifInContext (Set.singleton InfixOp) (setContext (Set.singleton InfixOp) $ markLocated n) (markLocated n) ) markExpr l (GHC.HsRecFld f) = markAST l f markExpr l (GHC.HsOverLabel _ fs) = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) markExpr l (GHC.HsIPVar n@(GHC.HsIPName _v)) = markAST l n markExpr l (GHC.HsOverLit ov) = markAST l ov markExpr l (GHC.HsLit lit) = markAST l lit markExpr _ (GHC.HsLam (GHC.MG (GHC.L _ [match]) _ _ _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp e1 e2) = do setContext (Set.singleton PrefixOp) $ markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp e1 e2 _ e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar _) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr _ (GHC.ExplicitSum alt arity e _) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated e replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet (GHC.L _ binds) e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo cts (GHC.L _ es) _) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then case cts of GHC.PArrComp -> ("[:",":]") _ -> ("[", "]") else ("{","}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.ExplicitPArr _ es) = do markWithString GHC.AnnOpen "[:" markListIntercalateWithFunLevel markLocated 2 es markWithString GHC.AnnClose ":]" markExpr _ (GHC.RecordCon n _ _ (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd e fs _cons _ _ _) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig e typ) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ExprWithTySigOut _e _typ) = error "ExprWithTySigOut only occurs after renamer" markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.PArrSeq _ seqInfo) = do markWithString GHC.AnnOpen "[:" -- '[:' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 markWithString GHC.AnnClose ":]" -- ':]' markExpr _ (GHC.HsSCC src csFStr e) = do markAnnOpen src "{-# SCC" let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithStringOptional GHC.AnnVal txt markWithString GHC.AnnValStr txt markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn src csFStr e) = do -- markWithString GHC.AnnOpen src -- "{-# CORE" markAnnOpen src "{-# CORE" -- markWithString GHC.AnnVal (GHC.sl_st csFStr) markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket (GHC.VarBr True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket (GHC.VarBr False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket (GHC.DecBrL ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC mark GHC.AnnCloseQ -- "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket (GHC.DecBrG _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket (GHC.ExpBr e)) = do mark GHC.AnnOpenEQ -- "[|" markOptional GHC.AnnOpenE -- "[e|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _l (GHC.HsBracket (GHC.TExpBr e)) = do markWithString GHC.AnnOpen "[||" markWithStringOptional GHC.AnnOpenE "[e||" markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket (GHC.TypBr e)) = do markWithString GHC.AnnOpen "[t|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsBracket (GHC.PatBr e)) = do markWithString GHC.AnnOpen "[p|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsRnBracketOut _ _) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut _ _) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr l (GHC.HsSpliceE e) = markAST l e markExpr _ (GHC.HsProc p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic _ e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm e _ cs) = do markWithString GHC.AnnOpenB "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnCloseB "|)" markExpr _ (GHC.HsTick _ _) = return () markExpr _ (GHC.HsBinTick _ _ _) = return () markExpr _ (GHC.HsTickPragma src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markAnnOpen src "{-# GENERATED" markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING let markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s markOne 1 v1 s1 -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOne 2 v2 s2 -- INTEGER mark GHC.AnnMinus -- '-' markOne 3 v3 s3 -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOne 4 v4 s4 -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l GHC.EWildPat = do ifInContext (Set.fromList [InfixOp]) (do mark GHC.AnnBackquote markWithString GHC.AnnVal "_" mark GHC.AnnBackquote) (markExternal l GHC.AnnVal "_") markExpr _ (GHC.EAsPat ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsAppType e ty) = do markLocated e markInstead GHC.AnnAt AnnTypeApp markLHsWcType ty markExpr _ (GHC.HsAppTypeOut _ _) = traceM "warning: HsAppTypeOut introduced after renaming" markExpr _ (GHC.HsWrap _ _) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar _) = traceM "warning: HsUnboundVar introduced after renaming" markExpr _ (GHC.HsConLikeOut{}) = traceM "warning: HsConLikeOut introduced after type checking" -- --------------------------------------------------------------------- markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () markLHsWcType (GHC.HsWC _ ty) = do markLocated ty -- --------------------------------------------------------------------- instance Annotate (GHC.HsLit GHC.GhcPs) where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where markAST _ (GHC.HsRecField lbl expr punFlag) = do unsetContext Intercalate $ markLocated lbl when (punFlag == False) $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated expr inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance (GHC.DataId name) => Annotate (GHC.AmbiguousFieldOcc name) where markAST _ (GHC.Unambiguous n _) = markLocated n markAST _ (GHC.Ambiguous n _) = markLocated n -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance Annotate [GHC.ExprLStmt GHC.GhcPs] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsTupArg GHC.GhcPs) where markAST _ (GHC.Present (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsCmdTop GHC.GhcPs) where markAST _ (GHC.HsCmdTop cmd _ _ _) = markLocated cmd instance Annotate (GHC.HsCmd GHC.GhcPs) where markAST _ (GHC.HsCmdArrApp e1 e2 _ o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm e fixity _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm let isPrefixOp = case fixity of GHC.Infix -> False GHC.Prefix -> True when isPrefixOp $ mark GHC.AnnOpenB -- "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ mark GHC.AnnCloseB -- "|)" markAST _ (GHC.HsCmdApp e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet (GHC.L _ binds) e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo (GHC.L _ es) _) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdWrap {}) = traceM "warning: HsCmdWrap introduced after renaming" -- --------------------------------------------------------------------- instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.TyClDecl GHC.GhcPs) where markAST l (GHC.FamDecl famdecl) = markAST l famdecl >> markTrailingSemi markAST _ (GHC.SynDecl ln (GHC.HsQTvs _ tyvars _) fixity 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 markTyClass fixity ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars _) fixity (GHC.HsDataDefn nd ctx mctyp mk cons derivs) _ _) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp markLocated ctx markTyClass fixity ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl ctx ln (GHC.HsQTvs _ns tyVars _) fixity fds sigs meths ats atdefs docs _) = do mark GHC.AnnClass markLocated ctx markTyClass fixity ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass fixity ln tyVars = do -- There may be arbitrary parens around parts of the constructor -- Turn these into comments so that they feed into the right place automatically annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] let markParens = if fixity == GHC.Infix && length tyVars > 2 then markMany else markManyOptional if fixity == GHC.Prefix then do markManyOptional GHC.AnnOpenP setContext (Set.singleton PrefixOp) $ markLocated ln -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars when (length tyVars >= 2) $ do markParens GHC.AnnCloseP setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars markManyOptional GHC.AnnCloseP else do case tyVars of (x:y:xs) -> do markParens GHC.AnnOpenP markLocated x setContext (Set.singleton InfixOp) $ markLocated ln markLocated y markParens GHC.AnnCloseP mapM_ markLocated xs markManyOptional GHC.AnnCloseP _ -> error $ "markTyClass: Infix op without operands" -- --------------------------------------------------------------------- instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where markAST _ ds = mapM_ markLocated ds -- --------------------------------------------------------------------- instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where markAST _ (GHC.HsDerivingClause mstrategy (GHC.L _ typs)) = do let needsParens = case typs of [(GHC.HsIB _ (GHC.L _ (GHC.HsTyVar _ _)) _)] -> False _ -> True mark GHC.AnnDeriving markMaybe mstrategy if needsParens then mark GHC.AnnOpenP else markOptional GHC.AnnOpenP markListIntercalateWithFunLevel markLHsSigType 2 typs if needsParens then mark GHC.AnnCloseP else markOptional GHC.AnnCloseP -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyDecl GHC.GhcPs) where markAST _ (GHC.FamilyDecl info ln (GHC.HsQTvs _ tyvars _) fixity rsig minj) = do case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass fixity ln tyvars case GHC.unLoc rsig of GHC.NoSig -> return () GHC.KindSig _ -> do mark GHC.AnnDcolon markLocated rsig GHC.TyVarSig _ -> do mark GHC.AnnEqual markLocated rsig case minj of Nothing -> return () Just inj -> do mark GHC.AnnVbar markLocated inj case info of GHC.ClosedTypeFamily (Just eqns) -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } GHC.ClosedTypeFamily Nothing -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- { mark GHC.AnnDotdot mark GHC.AnnCloseC -- } _ -> return () markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where markAST _ (GHC.NoSig) = return () markAST _ (GHC.KindSig k) = markLocated k markAST _ (GHC.TyVarSig ltv) = markLocated ltv -- --------------------------------------------------------------------- instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where markAST _ (GHC.InjectivityAnn ln lns) = do markLocated ln mark GHC.AnnRarrow mapM_ markLocated lns -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where markAST _ (GHC.HsIB _ eqn _) = do markFamEqn eqn markTrailingSemi -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where markAST _ (GHC.FamEqn ln (GHC.HsQTvs _ns bndrs _) fixity typ) = do mark GHC.AnnType mark GHC.AnnInstance markTyClass fixity ln bndrs mark GHC.AnnEqual markLocated typ -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentPrev (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocCommentNamed _s (GHC.HsDocString fs)) -> GHC.unpackFS fs (GHC.DocGroup _i (GHC.HsDocString fs)) -> GHC.unpackFS fs in markExternal l GHC.AnnVal str >> markTrailingSemi -- --------------------------------------------------------------------- markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () markDataDefn _ (GHC.HsDataDefn _ ctx typ _mk cons derivs) = do markLocated ctx markMaybe typ if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons setContext (Set.singleton Deriving) $ markLocated derivs -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance Annotate [GHC.LHsType GHC.GhcPs] where markAST l ts = do -- Mote: A single item in parens in a deriving clause is parsed as a -- HsSigType, which is always a HsForAllTy. Without parens it is always a -- HsVar. So for round trip pretty printing we need to take this into -- account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where markAST _ (GHC.ConDeclH98 ln mqtvs mctx dets _ ) = do case mqtvs of Nothing -> return () Just (GHC.HsQTvs _ns bndrs _) -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot case mctx of Just ctx -> do setContext (Set.fromList [NoDarrow]) $ markLocated ctx unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow Nothing -> return () case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markLocated ln markHsConDeclDetails False False [ln] dets inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar markTrailingSemi markAST _ (GHC.ConDeclGADT lns (GHC.HsIB _ typ _) _) = do setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi -- 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.Outputable (ResTyGADTHook GHC.GhcPs) where ppr (ResTyGADTHook bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr bs -- 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 "_" -- --------------------------------------------------------------------- instance Annotate (ResTyGADTHook GHC.GhcPs) where markAST _ (ResTyGADTHook bndrs) = do unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do -- markWithString GHC.AnnOpen src markAnnOpen src "" case mh of Nothing -> return () Just (GHC.Header srcH _h) -> -- markWithString GHC.AnnHeader srcH markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") -- markWithString GHC.AnnVal (fst f) markSourceText (fst f) (GHC.unpackFS $ snd f) markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- stringLiteralToString :: GHC.StringLiteral -> String stringLiteralToString (GHC.StringLiteral st fs) = case st of GHC.NoSourceText -> GHC.unpackFS fs GHC.SourceText src -> src ghc-exactprint-0.6.2/src-ghc86/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022124 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc86/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000030430407346545000024417 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC -- import qualified HsDoc as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast) => GHC.Located ast -> Annotated () annotate = markLocated -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Annotate ast) => GHC.Located ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: Annotate ast => Bool -> [GHC.Located ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: Annotate ast => [GHC.Located ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.GhcPs) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# WARNING" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# DEPRECATED" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate GHC.StringLiteral where markAST l (GHC.StringLiteral src fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) -- --------------------------------------------------------------------- instance Annotate [GHC.LIE GHC.GhcPs] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance Annotate (GHC.IE GHC.GhcPs) where markAST _ ie = do case ie of GHC.IEVar _ ln -> markLocated ln GHC.IEThingAbs _ ln -> do setContext (Set.singleton PrefixOp) $ markLocated ln GHC.IEThingWith _ ln wc ns _lfs -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP case wc of GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns GHC.IEWildcard n -> do setContext (Set.fromList [PrefixOp,Intercalate]) $ mapM_ markLocated (take n ns) mark GHC.AnnDotdot case drop n ns of [] -> return () ns' -> do mark GHC.AnnComma unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns' mark GHC.AnnCloseP (GHC.IEThingAll _ ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents _ (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup {}) -> return () (GHC.IEDoc {}) -> return () (GHC.IEDocNamed {}) -> return () GHC.XIE x -> error $ "got XIE for :" ++ showGhc x ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- instance Annotate (GHC.IEWrappedName GHC.RdrName) where markAST _ (GHC.IEName ln) = do unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEPattern ln) = do mark GHC.AnnPattern setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEType ln) = do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n canParen = isSym doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if canParen then ifInContext (Set.singleton PrefixOp) (mark pa) -- '(' (markOptional pa) else if isSym then ifInContext (Set.singleton PrefixOpDollar) (mark pa) (markOptional pa) else markOptional pa markOptional GHC.AnnSimpleQuote markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> if str == "~" then doNormalRdrName -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) else markExternal l GHC.AnnVal str -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- instance Annotate (GHC.ImportDecl GHC.GhcPs) where markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" case msrc of GHC.SourceText _txt -> do markAnnOpen msrc "{-# SOURCE" markWithString GHC.AnnClose "#-}" GHC.NoSourceText -> return () when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> markWithString GHC.AnnPackageName srcPkg _ -> return () markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markLocated mn case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD _ d -> markLocated (GHC.L l d) GHC.InstD _ d -> markLocated (GHC.L l d) 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.SpliceD _ d -> markLocated (GHC.L l d) GHC.DocD _ d -> markLocated (GHC.L l d) GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x instance Annotate (GHC.HsDecl GHC.GhcPs) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where markAST _ (GHC.RoleAnnotDecl _ ln mr) = do mark GHC.AnnType mark GHC.AnnRole markLocated ln mapM_ markLocated mr markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance Annotate (GHC.SpliceDecl GHC.GhcPs) where markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do markLocated e markTrailingSemi markAST _ (GHC.SpliceDecl _ e _flag) = do markLocated e markTrailingSemi markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecls GHC.GhcPs) where markAST _ (GHC.HsRules _ src rules) = do markAnnOpen src "{-# RULES" setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecl GHC.GhcPs) where markAST l (GHC.HsRule _ ln act bndrs lhs rhs) = do markLocated ln setContext (Set.singleton ExplicitNeverActive) $ markActivation l act unless (null bndrs) $ do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x -- --------------------------------------------------------------------- markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () markActivation _ act = do case act of GHC.ActiveBefore src phase -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter src phase -> do mark GHC.AnnOpenS -- '[' markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance Annotate (GHC.RuleBndr GHC.GhcPs) where markAST _ (GHC.RuleBndr _ ln) = markLocated ln markAST _ (GHC.RuleBndrSig _ ln st) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLHsSigWcType st mark GHC.AnnCloseP -- ")" markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x -- --------------------------------------------------------------------- markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do markLocated ty markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" -- --------------------------------------------------------------------- instance Annotate (GHC.AnnDecl GHC.GhcPs) where markAST _ (GHC.HsAnnotation _ src prov e) = do markAnnOpen src "{-# ANN" case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecls GHC.GhcPs) where markAST _ (GHC.Warnings _ src warns) = do markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED mapM_ markLocated warns markWithString GHC.AnnClose "#-}" markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecl GHC.GhcPs) where markAST _ (GHC.Warning _ lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.ForeignDecl GHC.GhcPs) where markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternalSourceText ls src "" markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (sourceTextToString src "") setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivDecl GHC.GhcPs) where markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do mark GHC.AnnDeriving markMaybe ms mark GHC.AnnInstance markMaybe mov markLocated typ markTrailingSemi {- data DerivDecl pass = DerivDecl { deriv_ext :: XCDerivDecl pass , deriv_type :: LHsSigWcType pass -- ^ The instance type to derive. -- -- It uses an 'LHsSigWcType' because the context is allowed to be a -- single wildcard: -- -- > deriving instance _ => Eq (Foo a) -- -- Which signifies that the context should be inferred. -- See Note [Inferring the instance context] in TcDerivInfer. , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both data HsWildCardBndrs pass thing -- See Note [HsType binders] -- See Note [The wildcard story for types] = HsWC { hswc_ext :: XHsWC pass thing -- after the renamer -- Wild cards, both named and anonymous , hswc_body :: thing -- Main payload (type or list of types) -- If there is an extra-constraints wildcard, -- it's still there in the hsc_body. } -} markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivStrategy GHC.GhcPs) where markAST _ GHC.StockStrategy = mark GHC.AnnStock markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do mark GHC.AnnVia markLocated ty markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) = error $ "got XHsImplicitBndrs in AnnDerivStrategy" -- --------------------------------------------------------------------- instance Annotate (GHC.DefaultDecl GHC.GhcPs) where markAST _ (GHC.DefaultDecl _ typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.InstDecl GHC.GhcPs) where markAST l (GHC.ClsInstD _ cid) = markAST l cid markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where -- NOTE: NoOverlap is only used in the typechecker markAST _ (GHC.NoOverlap src) = do markAnnOpen src "{-# NO_OVERLAP" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markAnnOpen src "{-# OVERLAPPABLE" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markAnnOpen src "{-# OVERLAPPING" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markAnnOpen src "{-# OVERLAPS" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markAnnOpen src "{-# INCOHERENT" markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do mark GHC.AnnType mark GHC.AnnInstance -- Note: this keyword is optional markFamEqn eqn markTrailingSemi markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" -- --------------------------------------------------------------------- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) -> Annotated () markFamEqn (GHC.FamEqn _ ln pats fixity rhs) = do markTyClass fixity ln pats mark GHC.AnnEqual markLocated rhs markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" -- --------------------------------------------------------------------- instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln pats fixity defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData mark GHC.AnnInstance markLocated ctx markTyClass fixity ln pats case (GHC.dd_kindSig defn) of Just s -> do mark GHC.AnnDcolon markLocated s Nothing -> return () if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi {- newtype DataFamInstDecl pass = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) data FamEqn pass pats rhs = FamEqn { feqn_ext :: XCFamEqn pass pats rhs , feqn_tycon :: Located (IdP pass) , feqn_pats :: pats , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -} markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ _ _ _ (GHC.XHsDataDefn _)))) = error "extension hit for DataFamInstDecl" markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) = error "extension hit for DataFamInstDecl" markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for DataFamInstDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.HsBind GHC.GhcPs) where markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun -- ----------------------------------- markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs -- TODO: extract this common code case lb of GHC.EmptyLocalBinds{} -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.VarBind _ _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse -- ----------------------------------- -- Introduced after renaming. markAST _ (GHC.AbsBinds {}) = traceM "warning: AbsBinds introduced after renaming" -- ----------------------------------- markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixCon la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixCon ns -> do markLocated ln mapM_ markLocated ns GHC.RecCon fs -> do markLocated ln mark GHC.AnnOpenC -- '{' markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs mark GHC.AnnCloseC -- '}' case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) = error "extension hit for HsBind" markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) = error "extension hit for HsBind" markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) = error "extension hit for HsBind" markAST _ (GHC.XHsBindsLR _) = error "extension hit for HsBind" -- --------------------------------------------------------------------- instance Annotate (GHC.IPBind GHC.GhcPs) where markAST _ (GHC.IPBind _ en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do let get_infix (GHC.FunRhs _ f _) = f get_infix _ = GHC.Prefix isFunBind GHC.FunRhs{} = True isFunBind _ = False case (get_infix mln,pats) of (GHC.Infix, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n _ -> return () markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of GHC.FunRhs n _ s -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do when (s == GHC.SrcStrict) $ mark GHC.AnnBang markLocated n mapM_ markLocated pats _ -> markListNoPrecedingSpace False pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds{} -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) = error "hit extension for Match" markAST _ (GHC.XMatch _) = error "hit extension for Match" -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.GRHS _ guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.Sig GHC.GhcPs) where markAST _ (GHC.TypeSig _ lns st) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLHsSigWcType st markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do mark GHC.AnnPattern markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do when isDefault $ mark GHC.AnnDefault setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig {}) = traceM "warning: Introduced after renaming" markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markSourceText src (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi markAST l (GHC.InlineSig _ ln inl) = do markAnnOpen (GHC.inl_src inl) "{-# INLINE" markActivation l (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST l (GHC.SpecSig _ ln typs inl) = do markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE markActivation l (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalateWithFunLevel markLHsSigType 2 typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecInstSig _ src typ) = do markAnnOpen src "{-# SPECIALISE" mark GHC.AnnInstance markLHsSigType typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.MinimalSig _ src formula) = do markAnnOpen src "{-# MINIMAL" markLocated formula markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.SCCFunSig _ src ln ml) = do markAnnOpen src "{-# SCC" markLocated ln markMaybe ml markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do markAnnOpen src "{-# COMPLETE" markListIntercalate ns case mlns of Nothing -> return () Just _ -> do mark GHC.AnnDcolon markMaybe mlns markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) = error "hit extension for Sig" markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) = error "hit extension for Sig" markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) = error "hit extension for Sig" markAST _ (GHC.XSig _) = error "hit extension for Sig" -- -------------------------------------------------------------------- markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () markLHsSigType (GHC.HsIB _ typ) = markLocated typ markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x instance Annotate [GHC.LHsSigType GHC.GhcPs] where markAST _ ls = do -- mark GHC.AnnDeriving -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it -- is a HsTyVar. So for round trip pretty printing we need to take this into -- account. let marker = case ls of [] -> markManyOptional [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) then markMany else markManyOptional _ -> markMany -- Need parens if more than one entry marker GHC.AnnOpenP markListIntercalateWithFun markLHsSigType ls marker GHC.AnnCloseP -- -------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where markAST _ (GHC.Var x) = do setContext (Set.singleton PrefixOp) $ markLocated x inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls markAST _ (GHC.And ls) = do markListIntercalateWithFunLevel markLocated 2 ls inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Parens x) = do mark GHC.AnnOpenP -- '(' markLocated x mark GHC.AnnCloseP -- ')' inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where markAST _l (GHC.UserTyVar _ n) = do markLocated n markAST _ (GHC.KindedTyVar _ n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsType GHC.GhcPs) where markAST loc ty = do markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () markType _ (GHC.HsForAllTy _ tvs typ) = do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot markLocated typ markType _ (GHC.HsQualTy _ cxt typ) = do markLocated cxt markLocated typ markType _ (GHC.HsTyVar _ promoted name) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name markType _ (GHC.HsAppTy _ t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsFunTy _ t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT markType _ (GHC.HsListTy _ t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsTupleTy _ tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsSumTy _ tys) = do markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys markWithString GHC.AnnClose "#)" markType _ (GHC.HsOpTy _ t1 lo t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy _ t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy _ n t) = do markLocated n mark GHC.AnnDcolon markLocated t markType l (GHC.HsStarTy _ isUnicode) = do if isUnicode then markExternal l GHC.AnnVal "\x2605" -- Unicode star else markExternal l GHC.AnnVal "*" markType _ (GHC.HsKindSig _ t k) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k mark GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy _ s) = do markAST l s markType _ (GHC.HsDocTy _ t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do case mt of GHC.NoSourceText -> return () GHC.SourceText src -> do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" case str of GHC.SrcLazy -> mark GHC.AnnTilde GHC.SrcStrict -> mark GHC.AnnBang GHC.NoSrcStrict -> return () markLocated t markType _ (GHC.HsRecTy _ cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' markType _ (GHC.HsExplicitListTy _ promoted ts) = do when (promoted == GHC.Promoted) $ mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP markType l (GHC.HsTyLit _ lit) = do case lit of (GHC.HsNumTy s v) -> markExternalSourceText l s (show v) (GHC.HsStrTy s v) -> markExternalSourceText l s (show v) markType l (GHC.HsWildCardTy _) = do markExternal l GHC.AnnVal "_" markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x -- --------------------------------------------------------------------- -- instance Annotate (GHC.HsAppType GHC.GhcPs) where -- markAST _ (GHC.HsAppInfix _ n) = do -- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote -- setContext (Set.singleton InfixOp) $ markLocated n -- markAST _ (GHC.HsAppPrefix _ t) = do -- markOptional GHC.AnnTilde -- setContext (Set.singleton PrefixOp) $ markLocated t -- --------------------------------------------------------------------- instance Annotate (GHC.HsSplice GHC.GhcPs) where markAST l c = case c of GHC.HsQuasiQuote _ _ n _pos fs -> do markExternal l GHC.AnnVal -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsTypedSplice _ hasParens _n b -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP -- ------------------------------- GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsUntypedSplice _ hasParens _n b -> do case hasParens of GHC.HasParens -> mark GHC.AnnOpenPE GHC.HasDollar -> mark GHC.AnnThIdSplice GHC.NoParens -> return () markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" -- ------------------------------- (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.ConDeclField GHC.GhcPs) where markAST _ (GHC.ConDeclField _ ns ty mdoc) = do unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.FieldOcc GHC.GhcPs) where markAST _ (GHC.FieldOcc _ rn) = do markLocated rn inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l s = do markExternal l GHC.AnnVal (GHC.unpackHDS s) -- --------------------------------------------------------------------- instance Annotate (GHC.Pat GHC.GhcPs) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat _ n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) markPat _ (GHC.LazyPat _ p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat _ ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat _ p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat _ p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat _ ps) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat _ pats b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.SumPat _ pat alt arity) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated pat replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" markPat _ (GHC.ViewPat _ e pat) = do markLocated e mark GHC.AnnRarrow markLocated pat markPat l (GHC.SplicePat _ s) = do markAST l s markPat l (GHC.LitPat _ lp) = markAST l lp markPat _ (GHC.NPat _ ol mn _) = do when (isJust mn) $ mark GHC.AnnMinus markLocated ol markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPat ty pat) = do markLocated pat mark GHC.AnnDcolon markLHsSigWcType ty markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit GHC.GhcPs -> String hsLit2String lit = case lit of GHC.HsChar src v -> toSourceTextWithSuffix src v "" -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" GHC.HsString src v -> toSourceTextWithSuffix src v "" GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix -- -------------------------------------------------------------------- markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args -- GHC.RecCon fs -> markLocated fs GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance Annotate [GHC.LConDeclField GHC.GhcPs] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance Annotate (GHC.HsOverLit GHC.GhcPs) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral (GHC.IL src _ _) -> src GHC.HsFractional (GHC.FL src _ _) -> src GHC.HsIsString src _ -> src in markExternalSourceText l str "" -- --------------------------------------------------------------------- instance (Annotate arg) => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where markAST _ (GHC.HsIB _ thing) = do markLocated thing markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.LastStmt _ body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt _ pat body _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ GHC.ApplicativeStmt{} = error "ApplicativeStmt should not appear in ParsedSource" markAST _ (GHC.BodyStmt _ body _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt _ pbs _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi mapM_ markLocated stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do markListIntercalate stmts markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds markHsLocalBinds GHC.EmptyLocalBinds{} = return () markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" -- --------------------------------------------------------------------- markMatchGroup :: (Annotate body) => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x -- --------------------------------------------------------------------- instance (Annotate body) => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsExpr GHC.GhcPs) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do ifInContext (Set.singleton PrefixOp) (setContext (Set.singleton PrefixOp) $ markLocated n) (ifInContext (Set.singleton InfixOp) (setContext (Set.singleton InfixOp) $ markLocated n) (markLocated n) ) markExpr l (GHC.HsRecFld _ f) = markAST l f markExpr l (GHC.HsOverLabel _ _ fs) = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = markAST l n markExpr l (GHC.HsOverLit _ ov) = markAST l ov markExpr l (GHC.HsLit _ lit) = markAST l lit markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase _ match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp _ e1 e2) = do setContext (Set.singleton PrefixOp) $ markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e2 markExpr _ (GHC.OpApp _ e1 e2 e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar{}) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 markExpr _ (GHC.NegApp _ e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar _ e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL _ e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR _ e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple _ args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr _ (GHC.ExplicitSum _ alt arity e) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated e replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then ("[", "]") else ("{", "}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd _ e fs) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig typ e) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.HsSCC _ src csFStr e) = do markAnnOpen src "{-# SCC" let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithStringOptional GHC.AnnVal txt markWithString GHC.AnnValStr txt markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do -- markWithString GHC.AnnOpen src -- "{-# CORE" markAnnOpen src "{-# CORE" -- markWithString GHC.AnnVal (GHC.sl_st csFStr) markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC mark GHC.AnnCloseQ -- "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do mark GHC.AnnOpenEQ -- "[|" markOptional GHC.AnnOpenE -- "[e|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do markWithString GHC.AnnOpen "[||" markWithStringOptional GHC.AnnOpenE "[e||" markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do markWithString GHC.AnnOpen "[t|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do markWithString GHC.AnnOpen "[p|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsRnBracketOut {}) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut {}) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr l (GHC.HsSpliceE _ e) = markAST l e markExpr _ (GHC.HsProc _ p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic _ e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm _ e _ cs) = do markWithString GHC.AnnOpenB "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnCloseB "|)" markExpr _ (GHC.HsTick {}) = return () markExpr _ (GHC.HsBinTick {}) = return () markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markAnnOpen src "{-# GENERATED" markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING let markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s markOne 1 v1 s1 -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOne 2 v2 s2 -- INTEGER mark GHC.AnnMinus -- '-' markOne 3 v3 s3 -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOne 4 v4 s4 -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l (GHC.EWildPat _) = do ifInContext (Set.fromList [InfixOp]) (do mark GHC.AnnBackquote markWithString GHC.AnnVal "_" mark GHC.AnnBackquote) (markExternal l GHC.AnnVal "_") markExpr _ (GHC.EAsPat _ ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat _ e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat _ e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsAppType ty e) = do markLocated e markInstead GHC.AnnAt AnnTypeApp markLHsWcType ty markExpr _ (GHC.HsWrap {}) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar {}) = traceM "warning: HsUnboundVar introduced after renaming" markExpr _ (GHC.HsConLikeOut{}) = traceM "warning: HsConLikeOut introduced after type checking" markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" markExpr _ (GHC.XExpr _) = error "markExpr got extension" -- --------------------------------------------------------------------- markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () markLHsWcType (GHC.HsWC _ ty) = do markLocated ty markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsLit GHC.GhcPs) where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where markAST _ (GHC.HsRecField lbl expr punFlag) = do unsetContext Intercalate $ markLocated lbl when (punFlag == False) $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated expr inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where markAST _ (GHC.Unambiguous _ n) = markLocated n markAST _ (GHC.Ambiguous _ n) = markLocated n markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance Annotate [GHC.ExprLStmt GHC.GhcPs] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsTupArg GHC.GhcPs) where markAST _ (GHC.Present _ (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsCmdTop GHC.GhcPs) where markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x instance Annotate (GHC.HsCmd GHC.GhcPs) where markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm let isPrefixOp = case fixity of GHC.Infix -> False GHC.Prefix -> True when isPrefixOp $ mark GHC.AnnOpenB -- "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ mark GHC.AnnCloseB -- "|)" markAST _ (GHC.HsCmdApp _ e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam _ match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar _ e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase _ e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdWrap {}) = traceM "warning: HsCmdWrap introduced after renaming" markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.TyClDecl GHC.GhcPs) where markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity 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 markTyClass fixity ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp markLocated ctx markTyClass fixity ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds sigs meths ats atdefs docs) = do mark GHC.AnnClass markLocated ctx markTyClass fixity ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi {- | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs tcdCtxt :: LHsContext pass, -- ^ Context... tcdLName :: Located (IdP pass), -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [Located (FunDep (Located (IdP pass)))], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } -} markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) = error "extension hit for TyClDecl" markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) = error "extension hit for TyClDecl" markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) = error "extension hit for TyClDecl" markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) = error "extension hit for TyClDecl" markAST _ (GHC.XTyClDecl _) = error "extension hit for TyClDecl" -- --------------------------------------------------------------------- markTyClass :: (Annotate a, Annotate ast,GHC.HasOccName a) => GHC.LexicalFixity -> GHC.Located a -> [GHC.Located ast] -> Annotated () markTyClass fixity ln tyVars = do -- There may be arbitrary parens around parts of the constructor -- Turn these into comments so that they feed into the right place automatically annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] let markParens = if fixity == GHC.Infix && length tyVars > 2 then markMany else markManyOptional if fixity == GHC.Prefix then do markManyOptional GHC.AnnOpenP setContext (Set.singleton PrefixOp) $ markLocated ln -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ take 2 tyVars when (length tyVars >= 2) $ do markParens GHC.AnnCloseP setContext (Set.singleton PrefixOp) $ mapM_ markLocated $ drop 2 tyVars markManyOptional GHC.AnnCloseP else do case tyVars of (x:y:xs) -> do markParens GHC.AnnOpenP markLocated x setContext (Set.singleton InfixOp) $ markLocated ln markLocated y markParens GHC.AnnCloseP mapM_ markLocated xs markManyOptional GHC.AnnCloseP _ -> error $ "markTyClass: Infix op without operands" -- --------------------------------------------------------------------- instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where markAST _ ds = mapM_ markLocated ds -- --------------------------------------------------------------------- instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do mark GHC.AnnDeriving case mstrategy of Nothing -> return () Just (GHC.L _ (GHC.ViaStrategy{})) -> return () Just s -> markLocated s markLocated typs case mstrategy of Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s _ -> return () markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x {- = HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause pass , deriv_clause_strategy :: Maybe (LDerivStrategy pass) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] -- ^ The types to derive. -- -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, -- we can mention type variables that aren't bound by the datatype, e.g. -- -- > data T b = ... deriving (C [a]) -- -- should produce a derived instance for @C [a] (T b)@. } -} -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyDecl GHC.GhcPs) where markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass fixity ln tyvars case GHC.unLoc rsig of GHC.NoSig _ -> return () GHC.KindSig _ _ -> do mark GHC.AnnDcolon markLocated rsig GHC.TyVarSig _ _ -> do mark GHC.AnnEqual markLocated rsig (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x case minj of Nothing -> return () Just inj -> do mark GHC.AnnVbar markLocated inj case info of GHC.ClosedTypeFamily (Just eqns) -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } GHC.ClosedTypeFamily Nothing -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- { mark GHC.AnnDotdot mark GHC.AnnCloseC -- } _ -> return () markTrailingSemi markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) = error "got extension for FamilyDecl" markAST _ (GHC.XFamilyDecl _) = error "got extension for FamilyDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where markAST _ (GHC.NoSig _) = return () markAST _ (GHC.KindSig _ k) = markLocated k markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where markAST _ (GHC.InjectivityAnn ln lns) = do markLocated ln mark GHC.AnnRarrow mapM_ markLocated lns -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where markAST _ (GHC.HsIB _ eqn) = do markFamEqn eqn markTrailingSemi markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where markAST _ (GHC.FamEqn _ ln (GHC.HsQTvs _ bndrs) fixity typ) = do mark GHC.AnnType mark GHC.AnnInstance markTyClass fixity ln bndrs mark GHC.AnnEqual markLocated typ markAST _ (GHC.FamEqn _ _ (GHC.XLHsQTyVars _) _ _) = error "TyFamDefltEqn hit extension point" markAST _ (GHC.XFamEqn _) = error "TyFamDefltEqn hit extension point" -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext ds) -> GHC.unpackHDS ds (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds (GHC.DocGroup _i ds) -> GHC.unpackHDS ds in markExternal l GHC.AnnVal str >> markTrailingSemi {- data DocDecl = DocCommentNext HsDocString | DocCommentPrev HsDocString | DocCommentNamed String HsDocString | DocGroup Int HsDocString -} -- --------------------------------------------------------------------- markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do markLocated ctx markMaybe typ if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons setContext (Set.singleton Deriving) $ markLocated derivs markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance Annotate [GHC.LHsType GHC.GhcPs] where markAST l ts = do -- Note: A single item in parens in a standalone deriving clause -- is parsed as a HsSigType, which is always a HsForAllTy or -- HsQualTy. Without parens it is always a HsVar. So for round -- trip pretty printing we need to take this into account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [GHC.L _ GHC.HsQualTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx dets _) = do case mqtvs of [] -> return () bndrs -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot case mctx of Just ctx -> do setContext (Set.fromList [NoDarrow]) $ markLocated ctx unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow Nothing -> return () case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markLocated ln markHsConDeclDetails False False [ln] dets inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar markTrailingSemi {- | ConDeclH98 { con_ext :: XConDeclH98 pass , con_name :: Located (IdP pass) , con_forall :: Bool -- ^ True <=> explicit user-written forall -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} -- False => con_ex_tvs is empty , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -} markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon annotationsToComments [GHC.AnnOpenP] markLocated (GHC.L l (ResTyGADTHook forall qvars)) markMaybe mbCxt markHsConDeclDetails False True lns args markLocated typ markManyOptional GHC.AnnCloseP markTrailingSemi {- = ConDeclGADT { con_g_ext :: XConDeclGADT pass , con_names :: [Located (IdP pass)] -- The next four fields describe the type after the '::' -- See Note [GADT abstract syntax] , con_forall :: Located Bool -- ^ True <=> explicit forall -- False => hsq_explicit is empty , con_qvars :: LHsQTyVars pass -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon , con_res_ty :: LHsType pass -- ^ Result type , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -} markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) = error "hit extension point in ConDecl" markAST _ (GHC.XConDecl _) = error "hit extension point in ConDecl" -- ResTyGADT has a SrcSpan for the original sigtype, we need to create -- a type for exactPC and annotatePC data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] deriving (Typeable) deriving instance Data (ResTyGADTHook) instance GHC.Outputable ResTyGADTHook where ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs -- 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 "_" -- --------------------------------------------------------------------- instance Annotate ResTyGADTHook where markAST _ (ResTyGADTHook forall bndrs) = do unless (null bndrs) $ do when forall $ mark GHC.AnnForall mapM_ markLocated bndrs when forall $ mark GHC.AnnDot -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do -- markWithString GHC.AnnOpen src markAnnOpen src "" case mh of Nothing -> return () Just (GHC.Header srcH _h) -> -- markWithString GHC.AnnHeader srcH markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") -- markWithString GHC.AnnVal (fst f) markSourceText (fst f) (GHC.unpackFS $ snd f) markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- stringLiteralToString :: GHC.StringLiteral -> String stringLiteralToString (GHC.StringLiteral st fs) = case st of GHC.NoSourceText -> GHC.unpackFS fs GHC.SourceText src -> src ghc-exactprint-0.6.2/src-ghc88/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000022126 5ustar0000000000000000ghc-exactprint-0.6.2/src-ghc88/Language/Haskell/GHC/ExactPrint/Annotater.hs0000644000000000000000000031651707346545000024432 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} -- | '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.Annotater ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.AnnotateTypes import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC -- import qualified HsDoc as GHC import qualified Name as GHC import qualified RdrName as GHC import qualified Outputable as GHC import qualified SrcLoc as GHC import Control.Monad.Identity import Data.Data import Data.Maybe import qualified Data.Set as Set import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- class Data ast => Annotate ast where markAST :: GHC.SrcSpan -> ast -> Annotated () -- --------------------------------------------------------------------- -- | Construct a syntax tree which represent which KeywordIds must appear -- where. annotate :: (Annotate ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast) => ast -> Annotated () annotate = markLocated -- instance Annotate (GHC.SrcSpanLess ast) where -- markAST s ast = undefined instance (Data ast, Annotate ast) => Annotate (GHC.Located ast) where markAST l (GHC.L _ ast) = markAST l ast -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which -- annotations are required by each element. markLocated :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => ast -> Annotated () markLocated ast = case cast ast :: Maybe (GHC.LHsDecl GHC.GhcPs) of Just d -> markLHsDecl d Nothing -> withLocated ast markAST -- --------------------------------------------------------------------- -- |When adding missing annotations, do not put a preceding space in front of a list markListNoPrecedingSpace :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => Bool -> [ast] -> Annotated () markListNoPrecedingSpace intercal ls = case ls of [] -> return () (l:ls') -> do if intercal then do if null ls' then setContext (Set.fromList [NoPrecedingSpace ]) $ markLocated l else setContext (Set.fromList [NoPrecedingSpace,Intercalate]) $ markLocated l markListIntercalate ls' else do setContext (Set.singleton NoPrecedingSpace) $ markLocated l mapM_ markLocated ls' -- --------------------------------------------------------------------- -- |Mark a list, with the given keyword as a list item separator markListIntercalate :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => [ast] -> Annotated () markListIntercalate ls = markListIntercalateWithFun markLocated ls -- --------------------------------------------------------------------- markListWithContexts :: Annotate ast => Set.Set AstContext -> Set.Set AstContext -> [GHC.Located ast] -> Annotated () markListWithContexts ctxInitial ctxRest ls = case ls of [] -> return () [x] -> setContextLevel ctxInitial 2 $ markLocated x (x:xs) -> do setContextLevel ctxInitial 2 $ markLocated x setContextLevel ctxRest 2 $ mapM_ markLocated xs -- --------------------------------------------------------------------- -- Context for only if just one, else first item, middle ones, and last one markListWithContexts' :: Annotate ast => ListContexts -> [GHC.Located ast] -> Annotated () markListWithContexts' (LC ctxOnly ctxInitial ctxMiddle ctxLast) ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ markLocated x (x:xs) -> do setContextLevel ctxInitial level $ markLocated x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ markLocated x go (x:xs) = do setContextLevel ctxMiddle level $ markLocated x go xs -- --------------------------------------------------------------------- markListWithLayout :: Annotate ast => [GHC.Located ast] -> Annotated () markListWithLayout ls = setLayoutFlag $ markList ls -- --------------------------------------------------------------------- markList :: Annotate ast => [GHC.Located ast] -> Annotated () markList ls = setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts' ls markLocalBindsWithLayout :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markLocalBindsWithLayout binds = markHsLocalBinds binds -- --------------------------------------------------------------------- -- |This function is used to get around shortcomings in the GHC AST for 7.10.1 markLocatedFromKw :: (Annotate ast) => GHC.AnnKeywordId -> GHC.Located ast -> Annotated () markLocatedFromKw kw (GHC.L l a) = do -- Note: l is needed so that the pretty printer can make something up ss <- getSrcSpanForKw l kw AnnKey ss' _ <- storeOriginalSrcSpan l (mkAnnKey (GHC.L ss a)) markLocated (GHC.L ss' a) -- --------------------------------------------------------------------- markMaybe :: (Annotate ast) => Maybe (GHC.Located ast) -> Annotated () markMaybe Nothing = return () markMaybe (Just ast) = markLocated ast -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds prepareListAnnotation :: Annotate a => [GHC.Located a] -> [(GHC.SrcSpan,Annotated ())] prepareListAnnotation ls = map (\b -> (GHC.getLoc b,markLocated b)) ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsModule GHC.GhcPs) where markAST _ (GHC.HsModule mmn mexp imps decs mdepr _haddock) = do case mmn of Nothing -> return () Just (GHC.L ln mn) -> do mark GHC.AnnModule markExternal ln GHC.AnnVal (GHC.moduleNameString mn) forM_ mdepr markLocated forM_ mexp markLocated mark GHC.AnnWhere markOptional GHC.AnnOpenC -- Possible '{' markManyOptional GHC.AnnSemi -- possible leading semis setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout imps setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout decs markOptional GHC.AnnCloseC -- Possible '}' markEOF -- --------------------------------------------------------------------- instance Annotate GHC.WarningTxt where markAST _ (GHC.WarningTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# WARNING" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" markAST _ (GHC.DeprecatedTxt (GHC.L _ txt) lss) = do markAnnOpen txt "{-# DEPRECATED" mark GHC.AnnOpenS markListIntercalate lss mark GHC.AnnCloseS markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate GHC.StringLiteral where markAST l (GHC.StringLiteral src fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.SourceText,GHC.FastString) where markAST l (src,fs) = do markExternalSourceText l src (show (GHC.unpackFS fs)) -- --------------------------------------------------------------------- instance Annotate [GHC.LIE GHC.GhcPs] where markAST _ ls = do inContext (Set.singleton HasHiding) $ mark GHC.AnnHiding -- in an import decl mark GHC.AnnOpenP -- '(' -- Can't use markListIntercalate, there can be trailing commas, but only in imports. markListIntercalateWithFunLevel markLocated 2 ls mark GHC.AnnCloseP -- ')' instance Annotate (GHC.IE GHC.GhcPs) where markAST _ ie = do case ie of GHC.IEVar _ ln -> markLocated ln GHC.IEThingAbs _ ln -> do setContext (Set.singleton PrefixOp) $ markLocated ln GHC.IEThingWith _ ln wc ns _lfs -> do setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnOpenP case wc of GHC.NoIEWildcard -> unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns GHC.IEWildcard n -> do setContext (Set.fromList [PrefixOp,Intercalate]) $ mapM_ markLocated (take n ns) mark GHC.AnnDotdot case drop n ns of [] -> return () ns' -> do mark GHC.AnnComma unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markListIntercalate ns' mark GHC.AnnCloseP (GHC.IEThingAll _ ln) -> do setContext (Set.fromList [PrefixOp]) $ markLocated ln mark GHC.AnnOpenP mark GHC.AnnDotdot mark GHC.AnnCloseP (GHC.IEModuleContents _ (GHC.L lm mn)) -> do mark GHC.AnnModule markExternal lm GHC.AnnVal (GHC.moduleNameString mn) -- Only used in Haddock mode so we can ignore them. (GHC.IEGroup {}) -> return () (GHC.IEDoc {}) -> return () (GHC.IEDocNamed {}) -> return () GHC.XIE x -> error $ "got XIE for :" ++ showGhc x ifInContext (Set.fromList [Intercalate]) (mark GHC.AnnComma) (markOptional GHC.AnnComma) -- --------------------------------------------------------------------- instance Annotate (GHC.IEWrappedName GHC.RdrName) where markAST _ (GHC.IEName ln) = do unsetContext Intercalate $ setContext (Set.fromList [PrefixOp]) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEPattern ln) = do mark GHC.AnnPattern setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.IEType ln) = do mark GHC.AnnType setContext (Set.singleton PrefixOp) $ markLocated ln inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- isSymRdr :: GHC.RdrName -> Bool isSymRdr n = GHC.isSymOcc (GHC.rdrNameOcc n) || rdrName2String n == "." instance Annotate GHC.RdrName where markAST l n = do let str = rdrName2String n isSym = isSymRdr n doNormalRdrName = do let str' = case str of -- TODO: unicode support? "forall" -> if spanLength l == 1 then "∀" else str _ -> str let markParen :: GHC.AnnKeywordId -> Annotated () markParen pa = do if isSym then ifInContext (Set.fromList [PrefixOp,PrefixOpDollar]) (mark pa) -- '(' (markOptional pa) else markOptional pa markOptional GHC.AnnSimpleQuote markParen GHC.AnnOpenP unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 0 cnt <- countAnns GHC.AnnVal case cnt of 0 -> markExternal l GHC.AnnVal str' 1 -> markWithString GHC.AnnVal str' _ -> traceM $ "Printing RdrName, more than 1 AnnVal:" ++ showGhc (l,n) unless isSym $ inContext (Set.fromList [InfixOp]) $ markOffset GHC.AnnBackquote 1 markParen GHC.AnnCloseP case n of GHC.Unqual _ -> doNormalRdrName GHC.Qual _ _ -> doNormalRdrName GHC.Orig _ _ -> if str == "~" then doNormalRdrName -- then error $ "GHC.orig:(isSym,canParen)=" ++ show (isSym,canParen) else markExternal l GHC.AnnVal str -- GHC.Orig _ _ -> markExternal l GHC.AnnVal str -- GHC.Orig _ _ -> error $ "GHC.orig:str=[" ++ str ++ "]" GHC.Exact n' -> do case str of -- Special handling for Exact RdrNames, which are built-in Names "[]" -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnCloseS -- ']' "()" -> do mark GHC.AnnOpenP -- '(' mark GHC.AnnCloseP -- ')' ('(':'#':_) -> do markWithString GHC.AnnOpen "(#" -- '(#' let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) 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 doNormalRdrName "*" -> do markExternal l GHC.AnnVal str "★" -> do -- Note: unicode star markExternal l GHC.AnnVal str ":" -> do -- Note: The OccName for ":" has the following attributes (via occAttributes) -- (d, Data DataSym Sym Val ) -- consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon doNormalRdrName -- trace ("RdrName.checking :" ++ (occAttributes $ GHC.occName n)) doNormalRdrName ('(':',':_) -> do mark GHC.AnnOpenP let cnt = length $ filter (==',') str replicateM_ cnt (mark GHC.AnnCommaTuple) mark GHC.AnnCloseP -- ')' _ -> do let isSym' = isSymRdr (GHC.nameRdrName n') when isSym' $ mark GHC.AnnOpenP -- '(' markWithString GHC.AnnVal str when isSym $ mark GHC.AnnCloseP -- ')' inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in RdrName") -- --------------------------------------------------------------------- instance Annotate (GHC.ImportDecl GHC.GhcPs) where markAST _ imp@(GHC.ImportDecl _ msrc modname mpkg _src safeflag qualFlag _impl _as hiding) = do -- 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec mark GHC.AnnImport -- "{-# SOURCE" and "#-}" case msrc of GHC.SourceText _txt -> do markAnnOpen msrc "{-# SOURCE" markWithString GHC.AnnClose "#-}" GHC.NoSourceText -> return () when safeflag (mark GHC.AnnSafe) when qualFlag (unsetContext TopLevel $ mark GHC.AnnQualified) case mpkg of Just (GHC.StringLiteral (GHC.SourceText srcPkg) _) -> markWithString GHC.AnnPackageName srcPkg _ -> return () markLocated modname case GHC.ideclAs imp of Nothing -> return () Just mn -> do mark GHC.AnnAs markLocated mn case hiding of Nothing -> return () Just (isHiding,lie) -> do if isHiding then setContext (Set.singleton HasHiding) $ markLocated lie else markLocated lie markTrailingSemi markAST _ (GHC.XImportDecl x) = error $ "got XImportDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where markAST l mname = markExternal l GHC.AnnVal (GHC.moduleNameString mname) -- --------------------------------------------------------------------- markLHsDecl :: GHC.LHsDecl GHC.GhcPs -> Annotated () markLHsDecl (GHC.L l decl) = case decl of GHC.TyClD _ d -> markLocated (GHC.L l d) GHC.InstD _ d -> markLocated (GHC.L l d) 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.SpliceD _ d -> markLocated (GHC.L l d) GHC.DocD _ d -> markLocated (GHC.L l d) GHC.RoleAnnotD _ d -> markLocated (GHC.L l d) GHC.XHsDecl x -> error $ "got XHsDecl for:" ++ showGhc x instance Annotate (GHC.HsDecl GHC.GhcPs) where markAST l d = markLHsDecl (GHC.L l d) -- --------------------------------------------------------------------- instance Annotate (GHC.RoleAnnotDecl GHC.GhcPs) where markAST _ (GHC.RoleAnnotDecl _ ln mr) = do mark GHC.AnnType mark GHC.AnnRole setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated mr markAST _ (GHC.XRoleAnnotDecl x) = error $ "got XRoleAnnotDecl for:" ++ showGhc x instance Annotate (Maybe GHC.Role) where markAST l Nothing = markExternal l GHC.AnnVal "_" markAST l (Just r) = markExternal l GHC.AnnVal (GHC.unpackFS $ GHC.fsFromRole r) -- --------------------------------------------------------------------- instance Annotate (GHC.SpliceDecl GHC.GhcPs) where markAST _ (GHC.SpliceDecl _ e@(GHC.L _ (GHC.HsQuasiQuote{})) _flag) = do markLocated e markTrailingSemi markAST _ (GHC.SpliceDecl _ e _flag) = do markLocated e markTrailingSemi markAST _ (GHC.XSpliceDecl x) = error $ "got XSpliceDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecls GHC.GhcPs) where markAST _ (GHC.HsRules _ src rules) = do markAnnOpen src "{-# RULES" setLayoutFlag $ markListIntercalateWithFunLevel markLocated 2 rules markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.XRuleDecls x) = error $ "got XRuleDecls for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.RuleDecl GHC.GhcPs) where markAST l (GHC.HsRule _ ln act mtybndrs termbndrs lhs rhs) = do markLocated ln setContext (Set.singleton ExplicitNeverActive) $ markActivation l act case mtybndrs of Nothing -> return () Just bndrs -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot mark GHC.AnnForall mapM_ markLocated termbndrs mark GHC.AnnDot markLocated lhs mark GHC.AnnEqual markLocated rhs inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi markTrailingSemi {- = HsRule -- Source rule { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS , rd_name :: Located (SourceText,RuleName) -- ^ Note [Pragma source text] in BasicTypes , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] -- ^ Forall'd type vars , rd_tmvs :: [LRuleBndr pass] -- ^ Forall'd term vars, before typechecking; after typechecking -- this includes all forall'd vars , rd_lhs :: Located (HsExpr pass) , rd_rhs :: Located (HsExpr pass) } -} markAST _ (GHC.XRuleDecl x) = error $ "got XRuleDecl for:" ++ showGhc x -- --------------------------------------------------------------------- markActivation :: GHC.SrcSpan -> GHC.Activation -> Annotated () markActivation _ act = do case act of GHC.ActiveBefore src phase -> do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.ActiveAfter src phase -> do mark GHC.AnnOpenS -- '[' markSourceText src (show phase) mark GHC.AnnCloseS -- ']' GHC.NeverActive -> do inContext (Set.singleton ExplicitNeverActive) $ do mark GHC.AnnOpenS -- '[' mark GHC.AnnTilde -- ~ mark GHC.AnnCloseS -- ']' _ -> return () -- --------------------------------------------------------------------- instance Annotate (GHC.RuleBndr GHC.GhcPs) where markAST _ (GHC.RuleBndr _ ln) = markLocated ln markAST _ (GHC.RuleBndrSig _ ln st) = do mark GHC.AnnOpenP -- "(" markLocated ln mark GHC.AnnDcolon markLHsSigWcType st mark GHC.AnnCloseP -- ")" markAST _ (GHC.XRuleBndr x) = error $ "got XRuleBndr for:" ++ showGhc x -- --------------------------------------------------------------------- markLHsSigWcType :: GHC.LHsSigWcType GHC.GhcPs -> Annotated () markLHsSigWcType (GHC.HsWC _ (GHC.HsIB _ ty)) = do markLocated ty markLHsSigWcType (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) = error "markLHsSigWcType extension hit" markLHsSigWcType (GHC.XHsWildCardBndrs _) = error "markLHsSigWcType extension hit" -- --------------------------------------------------------------------- instance Annotate (GHC.AnnDecl GHC.GhcPs) where markAST _ (GHC.HsAnnotation _ src prov e) = do markAnnOpen src "{-# ANN" case prov of (GHC.ValueAnnProvenance n) -> markLocated n (GHC.TypeAnnProvenance n) -> do mark GHC.AnnType markLocated n GHC.ModuleAnnProvenance -> mark GHC.AnnModule markLocated e markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.XAnnDecl x) = error $ "got XAnnDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecls GHC.GhcPs) where markAST _ (GHC.Warnings _ src warns) = do markAnnOpen src "{-# WARNING" -- Note: might be {-# DEPRECATED mapM_ markLocated warns markWithString GHC.AnnClose "#-}" markAST _ (GHC.XWarnDecls x) = error $ "got XWarnDecls for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.WarnDecl GHC.GhcPs) where markAST _ (GHC.Warning _ lns txt) = do markListIntercalate lns mark GHC.AnnOpenS -- "[" case txt of GHC.WarningTxt _src ls -> markListIntercalate ls GHC.DeprecatedTxt _src ls -> markListIntercalate ls mark GHC.AnnCloseS -- "]" markAST _ (GHC.XWarnDecl x) = error $ "got XWarnDecl for:" ++ showGhc x instance Annotate GHC.FastString where -- TODO: https://ghc.haskell.org/trac/ghc/ticket/10313 applies. markAST l fs = do markExternal l GHC.AnnVal (show (GHC.unpackFS fs)) inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.ForeignDecl GHC.GhcPs) where markAST _ (GHC.ForeignImport _ ln (GHC.HsIB _ typ) (GHC.CImport cconv safety@(GHC.L ll _) _mh _imp (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnImport markLocated cconv unless (ll == GHC.noSrcSpan) $ markLocated safety markExternalSourceText ls src "" markLocated ln mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _l (GHC.ForeignExport _ ln (GHC.HsIB _ typ) (GHC.CExport spec (GHC.L ls src))) = do mark GHC.AnnForeign mark GHC.AnnExport markLocated spec markExternal ls GHC.AnnVal (sourceTextToString src "") setContext (Set.singleton PrefixOp) $ markLocated ln mark GHC.AnnDcolon markLocated typ markAST _ (GHC.ForeignImport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" markAST _ (GHC.ForeignExport _ _ (GHC.XHsImplicitBndrs _) _) = error "markAST ForeignDecl hit extenstion" markAST _ (GHC.XForeignDecl _) = error "markAST ForeignDecl hit extenstion" -- --------------------------------------------------------------------- instance (Annotate GHC.CExportSpec) where markAST l (GHC.CExportStatic _src _ cconv) = markAST l cconv -- --------------------------------------------------------------------- instance (Annotate GHC.CCallConv) where markAST l GHC.StdCallConv = markExternal l GHC.AnnVal "stdcall" markAST l GHC.CCallConv = markExternal l GHC.AnnVal "ccall" markAST l GHC.CApiConv = markExternal l GHC.AnnVal "capi" markAST l GHC.PrimCallConv = markExternal l GHC.AnnVal "prim" markAST l GHC.JavaScriptCallConv = markExternal l GHC.AnnVal "javascript" -- --------------------------------------------------------------------- instance (Annotate GHC.Safety) where markAST l GHC.PlayRisky = markExternal l GHC.AnnVal "unsafe" markAST l GHC.PlaySafe = markExternal l GHC.AnnVal "safe" markAST l GHC.PlayInterruptible = markExternal l GHC.AnnVal "interruptible" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivDecl GHC.GhcPs) where markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.HsIB _ typ)) ms mov) = do mark GHC.AnnDeriving markMaybe ms mark GHC.AnnInstance markMaybe mov markLocated typ markTrailingSemi {- data DerivDecl pass = DerivDecl { deriv_ext :: XCDerivDecl pass , deriv_type :: LHsSigWcType pass -- ^ The instance type to derive. -- -- It uses an 'LHsSigWcType' because the context is allowed to be a -- single wildcard: -- -- > deriving instance _ => Eq (Foo a) -- -- Which signifies that the context should be inferred. -- See Note [Inferring the instance context] in TcDerivInfer. , deriv_strategy :: Maybe (LDerivStrategy pass) , deriv_overlap_mode :: Maybe (Located OverlapMode) type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both data HsWildCardBndrs pass thing -- See Note [HsType binders] -- See Note [The wildcard story for types] = HsWC { hswc_ext :: XHsWC pass thing -- after the renamer -- Wild cards, both named and anonymous , hswc_body :: thing -- Main payload (type or list of types) -- If there is an extra-constraints wildcard, -- it's still there in the hsc_body. } -} markAST _ (GHC.DerivDecl _ (GHC.HsWC _ (GHC.XHsImplicitBndrs _)) _ _) = error "markAST DerivDecl hit extension" markAST _ (GHC.DerivDecl _ (GHC.XHsWildCardBndrs _) _ _) = error "markAST DerivDecl hit extension" markAST _ (GHC.XDerivDecl _) = error "markAST DerivDecl hit extension" -- --------------------------------------------------------------------- instance Annotate (GHC.DerivStrategy GHC.GhcPs) where markAST _ GHC.StockStrategy = mark GHC.AnnStock markAST _ GHC.AnyclassStrategy = mark GHC.AnnAnyclass markAST _ GHC.NewtypeStrategy = mark GHC.AnnNewtype markAST _ (GHC.ViaStrategy (GHC.HsIB _ ty)) = do mark GHC.AnnVia markLocated ty markAST _ (GHC.ViaStrategy (GHC.XHsImplicitBndrs _)) = error $ "got XHsImplicitBndrs in AnnDerivStrategy" -- --------------------------------------------------------------------- instance Annotate (GHC.DefaultDecl GHC.GhcPs) where markAST _ (GHC.DefaultDecl _ typs) = do mark GHC.AnnDefault mark GHC.AnnOpenP -- '(' markListIntercalate typs mark GHC.AnnCloseP -- ')' markTrailingSemi markAST _ (GHC.XDefaultDecl x) = error $ "got XDefaultDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.InstDecl GHC.GhcPs) where markAST l (GHC.ClsInstD _ cid) = markAST l cid markAST l (GHC.DataFamInstD _ dfid) = markAST l dfid markAST l (GHC.TyFamInstD _ tfid) = markAST l tfid markAST _ (GHC.XInstDecl x) = error $ "got XInstDecl for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.OverlapMode where -- NOTE: NoOverlap is only used in the typechecker markAST _ (GHC.NoOverlap src) = do markAnnOpen src "{-# NO_OVERLAP" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlappable src) = do markAnnOpen src "{-# OVERLAPPABLE" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlapping src) = do markAnnOpen src "{-# OVERLAPPING" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Overlaps src) = do markAnnOpen src "{-# OVERLAPS" markWithString GHC.AnnClose "#-}" markAST _ (GHC.Incoherent src) = do markAnnOpen src "{-# INCOHERENT" markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- instance Annotate (GHC.ClsInstDecl GHC.GhcPs) where markAST _ (GHC.ClsInstDecl _ (GHC.HsIB _ poly) binds sigs tyfams datafams mov) = do mark GHC.AnnInstance markMaybe mov markLocated poly mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ++ prepareListAnnotation tyfams ++ prepareListAnnotation datafams ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi markAST _ (GHC.ClsInstDecl _ (GHC.XHsImplicitBndrs _) _ _ _ _ _) = error "extension hit for ClsInstDecl" markAST _ (GHC.XClsInstDecl _) = error "extension hit for ClsInstDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstDecl GHC.GhcPs) where {- newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) -} markAST _ (GHC.TyFamInstDecl (GHC.HsIB _ eqn)) = do mark GHC.AnnType mark GHC.AnnInstance -- Note: this keyword is optional markFamEqn eqn markTrailingSemi markAST _ (GHC.TyFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for TyFamInstDecl" -- --------------------------------------------------------------------- -- markFamEqn :: (GHC.HasOccName (GHC.IdP pass), -- Annotate (GHC.IdP pass), Annotate ast1, Annotate ast2) -- => GHC.FamEqn pass [GHC.Located ast1] (GHC.Located ast2) -- -> Annotated () markFamEqn :: GHC.FamEqn GhcPs [GHC.LHsTypeArg GhcPs] (GHC.LHsType GHC.GhcPs) -> Annotated () markFamEqn (GHC.FamEqn _ ln bndrs pats fixity rhs) = do markTyClassArgs bndrs fixity ln pats mark GHC.AnnEqual markLocated rhs {- data FamEqn pass pats rhs = FamEqn { feqn_ext :: XCFamEqn pass pats rhs , feqn_tycon :: Located (IdP pass) , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars , feqn_pats :: pats , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -} markFamEqn (GHC.XFamEqn _) = error "got XFamEqn" -- --------------------------------------------------------------------- instance Annotate (GHC.DataFamInstDecl GHC.GhcPs) where markAST l (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ ln bndrs pats fixity defn@(GHC.HsDataDefn _ nd ctx typ _mk cons mderivs) ))) = do case GHC.dd_ND defn of GHC.NewType -> mark GHC.AnnNewtype GHC.DataType -> mark GHC.AnnData mark GHC.AnnInstance markLocated ctx markTyClassArgs bndrs fixity ln pats case (GHC.dd_kindSig defn) of Just s -> do mark GHC.AnnDcolon markLocated s Nothing -> return () if isGadt $ GHC.dd_cons defn then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markDataDefn l (GHC.HsDataDefn GHC.noExt nd (GHC.noLoc []) typ _mk cons mderivs) markTrailingSemi markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.FamEqn _ _ _ _ _ (GHC.XHsDataDefn _)))) = error "extension hit for DataFamInstDecl" markAST _ (GHC.DataFamInstDecl (GHC.HsIB _ (GHC.XFamEqn _))) = error "extension hit for DataFamInstDecl" markAST _ (GHC.DataFamInstDecl (GHC.XHsImplicitBndrs _)) = error "extension hit for DataFamInstDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.HsBind GHC.GhcPs) where markAST _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _) = do -- Note: from a layout perspective a FunBind should not exist, so the -- current context is passed through unchanged to the matches. -- TODO: perhaps bring the edp from the first match up to the annotation for -- the FunBind. let tlFun = ifInContext (Set.fromList [CtxOnly,CtxFirst]) (markListWithContexts' listContexts matches) (markListWithContexts (lcMiddle listContexts) (lcLast listContexts) matches) ifInContext (Set.singleton TopLevel) (setContextLevel (Set.singleton TopLevel) 2 tlFun) tlFun -- ----------------------------------- markAST _ (GHC.PatBind _ lhs (GHC.GRHSs _ grhs (GHC.L _ lb)) _ticks) = do markLocated lhs case grhs of (GHC.L _ (GHC.GRHS _ [] _):_) -> mark GHC.AnnEqual -- empty guards _ -> return () markListIntercalateWithFunLevel markLocated 2 grhs -- TODO: extract this common code case lb of GHC.EmptyLocalBinds{} -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.VarBind _ _n rhse _) = -- Note: this bind is introduced by the typechecker markLocated rhse -- ----------------------------------- -- Introduced after renaming. markAST _ (GHC.AbsBinds {}) = traceM "warning: AbsBinds introduced after renaming" -- ----------------------------------- markAST l (GHC.PatSynBind _ (GHC.PSB _ ln args def dir)) = do mark GHC.AnnPattern case args of GHC.InfixCon la lb -> do markLocated la setContext (Set.singleton InfixOp) $ markLocated ln markLocated lb GHC.PrefixCon ns -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated ns GHC.RecCon fs -> do markLocated ln mark GHC.AnnOpenC -- '{' markListIntercalateWithFun (markLocated . GHC.recordPatSynSelectorId) fs mark GHC.AnnCloseC -- '}' case dir of GHC.ImplicitBidirectional -> mark GHC.AnnEqual _ -> mark GHC.AnnLarrow markLocated def case dir of GHC.Unidirectional -> return () GHC.ImplicitBidirectional -> return () GHC.ExplicitBidirectional mg -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' markMatchGroup l mg mark GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.FunBind _ _ (GHC.XMatchGroup _) _ _) = error "extension hit for HsBind" markAST _ (GHC.PatBind _ _ (GHC.XGRHSs _) _) = error "extension hit for HsBind" markAST _ (GHC.PatSynBind _ (GHC.XPatSynBind _)) = error "extension hit for HsBind" markAST _ (GHC.XHsBindsLR _) = error "extension hit for HsBind" -- --------------------------------------------------------------------- instance Annotate (GHC.IPBind GHC.GhcPs) where markAST _ (GHC.IPBind _ en e) = do case en of Left n -> markLocated n Right _i -> return () mark GHC.AnnEqual markLocated e markTrailingSemi -- markAST _ (GHC.XCIPBind x) = error $ "got XIPBind for:" ++ showGhc x markAST _ (GHC.XIPBind x) = error $ "got XIPBind for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.HsIPName where markAST l (GHC.HsIPName n) = markExternal l GHC.AnnVal ("?" ++ GHC.unpackFS n) -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Match GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.Match _ mln pats (GHC.GRHSs _ grhs (GHC.L _ lb))) = do let get_infix (GHC.FunRhs _ f _) = f get_infix _ = GHC.Prefix isFunBind GHC.FunRhs{} = True isFunBind _ = False case (get_infix mln,pats) of (GHC.Infix, a:b:xs) -> do if null xs then markOptional GHC.AnnOpenP else mark GHC.AnnOpenP markLocated a case mln of GHC.FunRhs n _ _ -> setContext (Set.singleton InfixOp) $ markLocated n _ -> return () markLocated b if null xs then markOptional GHC.AnnCloseP else mark GHC.AnnCloseP mapM_ markLocated xs _ -> do annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] inContext (Set.fromList [LambdaExpr]) $ do mark GHC.AnnLam -- For HsLam case mln of GHC.FunRhs n _ s -> do setContext (Set.fromList [NoPrecedingSpace,PrefixOp]) $ do when (s == GHC.SrcStrict) $ mark GHC.AnnBang markLocated n mapM_ markLocated pats _ -> markListNoPrecedingSpace False pats -- TODO: The AnnEqual annotation actually belongs in the first GRHS value case grhs of (GHC.L _ (GHC.GRHS _ [] _):_) -> when (isFunBind mln) $ mark GHC.AnnEqual -- empty guards _ -> return () inContext (Set.fromList [LambdaExpr]) $ mark GHC.AnnRarrow -- For HsLam mapM_ markLocated grhs case lb of GHC.EmptyLocalBinds{} -> return () _ -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.Match _ _ _ (GHC.XGRHSs _)) = error "hit extension for Match" markAST _ (GHC.XMatch _) = error "hit extension for Match" -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.GRHS GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.GRHS _ guards expr) = do case guards of [] -> return () (_:_) -> do mark GHC.AnnVbar unsetContext Intercalate $ setContext (Set.fromList [LeftMost,PrefixOp]) $ markListIntercalate guards ifInContext (Set.fromList [CaseAlt]) (return ()) (mark GHC.AnnEqual) markOptional GHC.AnnEqual -- For apply-refact Structure8.hs test inContext (Set.fromList [CaseAlt]) $ mark GHC.AnnRarrow -- For HsLam setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated expr markAST _ (GHC.XGRHS x) = error $ "got XGRHS for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.Sig GHC.GhcPs) where markAST _ (GHC.TypeSig _ lns st) = do setContext (Set.singleton PrefixOp) $ markListNoPrecedingSpace True lns mark GHC.AnnDcolon markLHsSigWcType st markTrailingSemi tellContext (Set.singleton FollowingLine) markAST _ (GHC.PatSynSig _ lns (GHC.HsIB _ typ)) = do mark GHC.AnnPattern setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.ClassOpSig _ isDefault ns (GHC.HsIB _ typ)) = do when isDefault $ mark GHC.AnnDefault setContext (Set.singleton PrefixOp) $ markListIntercalate ns mark GHC.AnnDcolon markLocated typ markTrailingSemi markAST _ (GHC.IdSig {}) = traceM "warning: Introduced after renaming" markAST _ (GHC.FixSig _ (GHC.FixitySig _ lns (GHC.Fixity src v fdir))) = do let fixstr = case fdir of GHC.InfixL -> "infixl" GHC.InfixR -> "infixr" GHC.InfixN -> "infix" markWithString GHC.AnnInfix fixstr markSourceText src (show v) setContext (Set.singleton InfixOp) $ markListIntercalate lns markTrailingSemi markAST l (GHC.InlineSig _ ln inl) = do markAnnOpen (GHC.inl_src inl) "{-# INLINE" markActivation l (GHC.inl_act inl) setContext (Set.singleton PrefixOp) $ markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST l (GHC.SpecSig _ ln typs inl) = do markAnnOpen (GHC.inl_src inl) "{-# SPECIALISE" -- Note: may be {-# SPECIALISE_INLINE markActivation l (GHC.inl_act inl) markLocated ln mark GHC.AnnDcolon -- '::' markListIntercalateWithFunLevel markLHsSigType 2 typs markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.SpecInstSig _ src typ) = do markAnnOpen src "{-# SPECIALISE" mark GHC.AnnInstance markLHsSigType typ markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi markAST _ (GHC.MinimalSig _ src formula) = do markAnnOpen src "{-# MINIMAL" markLocated formula markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.SCCFunSig _ src ln ml) = do markAnnOpen src "{-# SCC" markLocated ln markMaybe ml markWithString GHC.AnnClose "#-}" markTrailingSemi markAST _ (GHC.CompleteMatchSig _ src (GHC.L _ ns) mlns) = do markAnnOpen src "{-# COMPLETE" markListIntercalate ns case mlns of Nothing -> return () Just _ -> do mark GHC.AnnDcolon markMaybe mlns markWithString GHC.AnnClose "#-}" -- '#-}' markTrailingSemi -- ----------------------------------- markAST _ (GHC.PatSynSig _ _ (GHC.XHsImplicitBndrs _)) = error "hit extension for Sig" markAST _ (GHC.ClassOpSig _ _ _ (GHC.XHsImplicitBndrs _)) = error "hit extension for Sig" markAST _ (GHC.FixSig _ (GHC.XFixitySig _)) = error "hit extension for Sig" markAST _ (GHC.XSig _) = error "hit extension for Sig" -- -------------------------------------------------------------------- markLHsSigType :: GHC.LHsSigType GHC.GhcPs -> Annotated () markLHsSigType (GHC.HsIB _ typ) = markLocated typ markLHsSigType (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x instance Annotate [GHC.LHsSigType GHC.GhcPs] where markAST _ ls = do -- mark GHC.AnnDeriving -- Mote: a single item in parens is parsed as a HsAppsTy. Without parens it -- is a HsTyVar. So for round trip pretty printing we need to take this into -- account. let marker = case ls of [] -> markManyOptional [GHC.HsIB _ t] -> if GHC.hsTypeNeedsParens GHC.appPrec (GHC.unLoc t) then markMany else markManyOptional _ -> markMany -- Need parens if more than one entry marker GHC.AnnOpenP markListIntercalateWithFun markLHsSigType ls marker GHC.AnnCloseP -- -------------------------------------------------------------------- instance (Annotate name) => Annotate (GHC.BooleanFormula (GHC.Located name)) where markAST _ (GHC.Var x) = do setContext (Set.singleton PrefixOp) $ markLocated x inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Or ls) = markListIntercalateWithFunLevelCtx markLocated 2 AddVbar ls markAST _ (GHC.And ls) = do markListIntercalateWithFunLevel markLocated 2 ls inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.Parens x) = do mark GHC.AnnOpenP -- '(' markLocated x mark GHC.AnnCloseP -- ')' inContext (Set.fromList [AddVbar]) $ mark GHC.AnnVbar inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.HsTyVarBndr GHC.GhcPs) where markAST _l (GHC.UserTyVar _ n) = do markLocated n markAST _ (GHC.KindedTyVar _ n ty) = do mark GHC.AnnOpenP -- '(' markLocated n mark GHC.AnnDcolon -- '::' markLocated ty mark GHC.AnnCloseP -- '(' markAST _l (GHC.XTyVarBndr x) = error $ "got XTyVarBndr for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsType GHC.GhcPs) where markAST loc ty = do inContext (Set.fromList [InTypeApp]) $ mark GHC.AnnAt markType loc ty inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) where -- markType :: GHC.SrcSpan -> ast -> Annotated () markType :: GHC.SrcSpan -> (GHC.HsType GHC.GhcPs) -> Annotated () markType _ (GHC.HsForAllTy _ tvs typ) = do mark GHC.AnnForall mapM_ markLocated tvs mark GHC.AnnDot markLocated typ markType _ (GHC.HsQualTy _ cxt typ) = do markLocated cxt markLocated typ markType _ (GHC.HsTyVar _ promoted name) = do when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote unsetContext InfixOp $ setContext (Set.singleton PrefixOp) $ markLocated name markType _ (GHC.HsAppTy _ t1 t2) = do setContext (Set.singleton PrefixOp) $ markLocated t1 markLocated t2 markType _ (GHC.HsAppKindTy l t k) = do setContext (Set.singleton PrefixOp) $ markLocated t markTypeApp l markLocated k markType _ (GHC.HsFunTy _ t1 t2) = do markLocated t1 mark GHC.AnnRarrow markLocated t2 -- markManyOptional GHC.AnnCloseP -- For trailing parens after res_ty in ConDeclGADT markType _ (GHC.HsListTy _ t) = do mark GHC.AnnOpenS -- '[' markLocated t mark GHC.AnnCloseS -- ']' markType _ (GHC.HsTupleTy _ tt ts) = do case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnOpenP -- '(' _ -> markWithString GHC.AnnOpen "(#" -- '(#' markListIntercalateWithFunLevel markLocated 2 ts case tt of GHC.HsBoxedOrConstraintTuple -> mark GHC.AnnCloseP -- ')' _ -> markWithString GHC.AnnClose "#)" -- '#)' markType _ (GHC.HsSumTy _ tys) = do markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevelCtx markLocated 2 AddVbar tys markWithString GHC.AnnClose "#)" markType _ (GHC.HsOpTy _ t1 lo t2) = do markLocated t1 if (GHC.isTcOcc $ GHC.occName $ GHC.unLoc lo) then do markOptional GHC.AnnSimpleQuote else do mark GHC.AnnSimpleQuote unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated lo markLocated t2 markType _ (GHC.HsParTy _ t) = do mark GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnCloseP -- ')' markType _ (GHC.HsIParamTy _ n t) = do markLocated n mark GHC.AnnDcolon markLocated t markType l (GHC.HsStarTy _ isUnicode) = do if isUnicode then markExternal l GHC.AnnVal "\x2605" -- Unicode star else markExternal l GHC.AnnVal "*" markType _ (GHC.HsKindSig _ t k) = do markOptional GHC.AnnOpenP -- '(' markLocated t mark GHC.AnnDcolon -- '::' markLocated k markOptional GHC.AnnCloseP -- ')' markType l (GHC.HsSpliceTy _ s) = do markAST l s markType _ (GHC.HsDocTy _ t ds) = do markLocated t markLocated ds markType _ (GHC.HsBangTy _ (GHC.HsSrcBang mt _up str) t) = do case mt of GHC.NoSourceText -> return () GHC.SourceText src -> do markWithString GHC.AnnOpen src markWithString GHC.AnnClose "#-}" case str of GHC.SrcLazy -> mark GHC.AnnTilde GHC.SrcStrict -> mark GHC.AnnBang GHC.NoSrcStrict -> return () markLocated t markType _ (GHC.HsRecTy _ cons) = do mark GHC.AnnOpenC -- '{' markListIntercalate cons mark GHC.AnnCloseC -- '}' markType _ (GHC.HsExplicitListTy _ promoted ts) = do when (promoted == GHC.IsPromoted) $ mark GHC.AnnSimpleQuote mark GHC.AnnOpenS -- "[" markListIntercalate ts mark GHC.AnnCloseS -- ']' markType _ (GHC.HsExplicitTupleTy _ ts) = do mark GHC.AnnSimpleQuote mark GHC.AnnOpenP markListIntercalate ts mark GHC.AnnCloseP markType l (GHC.HsTyLit _ lit) = do case lit of (GHC.HsNumTy s v) -> markExternalSourceText l s (show v) (GHC.HsStrTy s v) -> markExternalSourceText l s (show v) markType l (GHC.HsWildCardTy _) = do markExternal l GHC.AnnVal "_" markType _ (GHC.XHsType x) = error $ "got XHsType for:" ++ showGhc x -- --------------------------------------------------------------------- -- instance Annotate (GHC.HsAppType GHC.GhcPs) where -- markAST _ (GHC.HsAppInfix _ n) = do -- when (GHC.isDataOcc $ GHC.occName $ GHC.unLoc n) $ mark GHC.AnnSimpleQuote -- setContext (Set.singleton InfixOp) $ markLocated n -- markAST _ (GHC.HsAppPrefix _ t) = do -- markOptional GHC.AnnTilde -- setContext (Set.singleton PrefixOp) $ markLocated t -- --------------------------------------------------------------------- instance Annotate (GHC.HsSplice GHC.GhcPs) where markAST l c = case c of GHC.HsQuasiQuote _ _ n _pos fs -> do markExternal l GHC.AnnVal -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showGhc n) ++ "|" ++ (GHC.unpackFS fs) ++ "|]") GHC.HsTypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdTySplice ("$$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsTypedSplice _ hasParens _n b -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPTE markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP -- ------------------------------- GHC.HsUntypedSplice _ hasParens _n b@(GHC.L _ (GHC.HsVar _ (GHC.L _ n))) -> do when (hasParens == GHC.HasParens) $ mark GHC.AnnOpenPE if (hasParens == GHC.HasDollar) then markWithString GHC.AnnThIdSplice ("$" ++ (GHC.occNameString (GHC.occName n))) else markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsUntypedSplice _ hasParens _n b -> do case hasParens of GHC.HasParens -> mark GHC.AnnOpenPE GHC.HasDollar -> mark GHC.AnnThIdSplice GHC.NoParens -> return () markLocated b when (hasParens == GHC.HasParens) $ mark GHC.AnnCloseP GHC.HsSpliced{} -> error "HsSpliced only exists between renamer and typechecker in GHC" GHC.HsSplicedT{} -> error "HsSplicedT only exists between renamer and typechecker in GHC" -- ------------------------------- (GHC.XSplice x) -> error $ "got XSplice for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.ConDeclField GHC.GhcPs) where markAST _ (GHC.ConDeclField _ ns ty mdoc) = do unsetContext Intercalate $ do markListIntercalate ns mark GHC.AnnDcolon markLocated ty markMaybe mdoc inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XConDeclField x) = error $ "got XConDeclField for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.FieldOcc GHC.GhcPs) where markAST _ (GHC.FieldOcc _ rn) = do markLocated rn inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XFieldOcc x) = error $ "got XFieldOcc for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate GHC.HsDocString where markAST l s = do markExternal l GHC.AnnVal (GHC.unpackHDS s) -- --------------------------------------------------------------------- instance Annotate (GHC.Pat GHC.GhcPs) where markAST loc typ = do markPat loc typ inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma `debug` ("AnnComma in Pat") where markPat l (GHC.WildPat _) = markExternal l GHC.AnnVal "_" markPat l (GHC.VarPat _ n) = do -- The parser inserts a placeholder value for a record pun rhs. This must be -- filtered out until https://ghc.haskell.org/trac/ghc/ticket/12224 is -- resolved, particularly for pretty printing where annotations are added. let pun_RDR = "pun-right-hand-side" when (showGhc n /= pun_RDR) $ unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markAST l (GHC.unLoc n) -- unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated n markPat _ (GHC.LazyPat _ p) = do mark GHC.AnnTilde markLocated p markPat _ (GHC.AsPat _ ln p) = do markLocated ln mark GHC.AnnAt markLocated p markPat _ (GHC.ParPat _ p) = do mark GHC.AnnOpenP markLocated p mark GHC.AnnCloseP markPat _ (GHC.BangPat _ p) = do mark GHC.AnnBang markLocated p markPat _ (GHC.ListPat _ ps) = do mark GHC.AnnOpenS markListIntercalateWithFunLevel markLocated 2 ps mark GHC.AnnCloseS markPat _ (GHC.TuplePat _ pats b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" markListIntercalateWithFunLevel markLocated 2 pats if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markPat _ (GHC.SumPat _ pat alt arity) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated pat replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markPat _ (GHC.ConPatIn n dets) = do markHsConPatDetails n dets markPat _ GHC.ConPatOut {} = traceM "warning: ConPatOut Introduced after renaming" markPat _ (GHC.ViewPat _ e pat) = do markLocated e mark GHC.AnnRarrow markLocated pat markPat l (GHC.SplicePat _ s) = do markAST l s markPat l (GHC.LitPat _ lp) = markAST l lp markPat _ (GHC.NPat _ ol mn _) = do when (isJust mn) $ mark GHC.AnnMinus markLocated ol markPat _ (GHC.NPlusKPat _ ln ol _ _ _) = do markLocated ln markWithString GHC.AnnVal "+" -- "+" markLocated ol markPat _ (GHC.SigPat _ pat ty) = do markLocated pat mark GHC.AnnDcolon markLHsSigWcType ty markPat _ GHC.CoPat {} = traceM "warning: CoPat introduced after renaming" markPat _ (GHC.XPat (GHC.L l p)) = markPat l p -- markPat _ (GHC.XPat x) = error $ "got XPat for:" ++ showGhc x -- --------------------------------------------------------------------- hsLit2String :: GHC.HsLit GHC.GhcPs -> String hsLit2String lit = case lit of GHC.HsChar src v -> toSourceTextWithSuffix src v "" -- It should be included here -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 GHC.HsCharPrim src p -> toSourceTextWithSuffix src p "#" GHC.HsString src v -> toSourceTextWithSuffix src v "" GHC.HsStringPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt _ (GHC.IL src _ v) -> toSourceTextWithSuffix src v "" GHC.HsIntPrim src v -> toSourceTextWithSuffix src v "" GHC.HsWordPrim src v -> toSourceTextWithSuffix src v "" GHC.HsInt64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsWord64Prim src v -> toSourceTextWithSuffix src v "" GHC.HsInteger src v _ -> toSourceTextWithSuffix src v "" GHC.HsRat _ (GHC.FL src _ v) _ -> toSourceTextWithSuffix src v "" GHC.HsFloatPrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "#" GHC.HsDoublePrim _ (GHC.FL src _ v) -> toSourceTextWithSuffix src v "##" (GHC.XLit x) -> error $ "got XLit for:" ++ showGhc x toSourceTextWithSuffix :: (Show a) => GHC.SourceText -> a -> String -> String toSourceTextWithSuffix (GHC.NoSourceText) alt suffix = show alt ++ suffix toSourceTextWithSuffix (GHC.SourceText txt) _alt suffix = txt ++ suffix -- -------------------------------------------------------------------- markHsConPatDetails :: GHC.Located GHC.RdrName -> GHC.HsConPatDetails GHC.GhcPs -> Annotated () markHsConPatDetails ln dets = do case dets of GHC.PrefixCon args -> do setContext (Set.singleton PrefixOp) $ markLocated ln mapM_ markLocated args GHC.RecCon (GHC.HsRecFields fs dd) -> do markLocated ln mark GHC.AnnOpenC -- '{' case dd of Nothing -> markListIntercalateWithFunLevel markLocated 2 fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC -- '}' GHC.InfixCon a1 a2 -> do markLocated a1 unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated ln markLocated a2 markHsConDeclDetails :: Bool -> Bool -> [GHC.Located GHC.RdrName] -> GHC.HsConDeclDetails GHC.GhcPs -> Annotated () markHsConDeclDetails isDeprecated inGadt lns dets = do case dets of GHC.PrefixCon args -> setContext (Set.singleton PrefixOp) $ mapM_ markLocated args -- GHC.RecCon fs -> markLocated fs GHC.RecCon fs -> do mark GHC.AnnOpenC if inGadt then do if isDeprecated then setContext (Set.fromList [InGadt]) $ markLocated fs else setContext (Set.fromList [InGadt,InRecCon]) $ markLocated fs else do if isDeprecated then markLocated fs else setContext (Set.fromList [InRecCon]) $ markLocated fs GHC.InfixCon a1 a2 -> do markLocated a1 setContext (Set.singleton InfixOp) $ mapM_ markLocated lns markLocated a2 -- --------------------------------------------------------------------- instance Annotate [GHC.LConDeclField GHC.GhcPs] where markAST _ fs = do markOptional GHC.AnnOpenC -- '{' markListIntercalate fs markOptional GHC.AnnDotdot inContext (Set.singleton InRecCon) $ mark GHC.AnnCloseC -- '}' inContext (Set.singleton InGadt) $ do mark GHC.AnnRarrow -- --------------------------------------------------------------------- instance Annotate (GHC.HsOverLit GHC.GhcPs) where markAST l ol = let str = case GHC.ol_val ol of GHC.HsIntegral (GHC.IL src _ _) -> src GHC.HsFractional (GHC.FL src _ _) -> src GHC.HsIsString src _ -> src in markExternalSourceText l str "" -- --------------------------------------------------------------------- instance (Annotate arg) => Annotate (GHC.HsImplicitBndrs GHC.GhcPs (GHC.Located arg)) where markAST _ (GHC.HsIB _ thing) = do markLocated thing markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x -- --------------------------------------------------------------------- instance (Annotate body) => Annotate (GHC.Stmt GHC.GhcPs (GHC.Located body)) where markAST _ (GHC.LastStmt _ body _ _) = setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body markAST _ (GHC.BindStmt _ pat body _ _) = do unsetContext Intercalate $ setContext (Set.singleton PrefixOp) $ markLocated pat mark GHC.AnnLarrow unsetContext Intercalate $ setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated body ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST _ GHC.ApplicativeStmt{} = error "ApplicativeStmt should not appear in ParsedSource" markAST _ (GHC.BodyStmt _ body _ _) = do unsetContext Intercalate $ markLocated body inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.LetStmt _ (GHC.L _ lb)) = do mark GHC.AnnLet markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi markLocalBindsWithLayout lb markOptional GHC.AnnCloseC -- '}' ifInContext (Set.singleton Intercalate) (mark GHC.AnnComma) (inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar) markTrailingSemi markAST l (GHC.ParStmt _ pbs _ _) = do -- Within a given parallel list comprehension,one of the sections to be done -- in parallel. It is a normal list comprehension, so has a list of -- ParStmtBlock, one for each part of the sub- list comprehension ifInContext (Set.singleton Intercalate) ( unsetContext Intercalate $ markListWithContextsFunction (LC (Set.singleton Intercalate) -- only Set.empty -- first Set.empty -- middle (Set.singleton Intercalate) -- last ) (markAST l) pbs ) ( unsetContext Intercalate $ markListWithContextsFunction (LC Set.empty -- only (Set.fromList [AddVbar]) -- first (Set.fromList [AddVbar]) -- middle Set.empty -- last ) (markAST l) pbs ) markTrailingSemi markAST _ (GHC.TransStmt _ form stmts _b using by _ _ _) = do setContext (Set.singleton Intercalate) $ mapM_ markLocated stmts case form of GHC.ThenForm -> do mark GHC.AnnThen unsetContext Intercalate $ markLocated using case by of Just b -> do mark GHC.AnnBy unsetContext Intercalate $ markLocated b Nothing -> return () GHC.GroupForm -> do mark GHC.AnnThen mark GHC.AnnGroup case by of Just b -> mark GHC.AnnBy >> markLocated b Nothing -> return () mark GHC.AnnUsing markLocated using inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.RecStmt _ stmts _ _ _ _ _) = do mark GHC.AnnRec markOptional GHC.AnnOpenC markInside GHC.AnnSemi markListWithLayout stmts markOptional GHC.AnnCloseC inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar inContext (Set.singleton Intercalate) $ mark GHC.AnnComma markTrailingSemi markAST _ (GHC.XStmtLR x) = error $ "got XStmtLR for:" ++ showGhc x -- --------------------------------------------------------------------- -- Note: We never have a located ParStmtBlock, so have nothing to hang the -- annotation on. This means there is no pushing of context from the parent ParStmt. instance Annotate (GHC.ParStmtBlock GHC.GhcPs GHC.GhcPs) where markAST _ (GHC.ParStmtBlock _ stmts _ns _) = do markListIntercalate stmts markAST _ (GHC.XParStmtBlock x) = error $ "got XParStmtBlock for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsLocalBinds GHC.GhcPs) where markAST _ lb = markHsLocalBinds lb -- --------------------------------------------------------------------- markHsLocalBinds :: GHC.HsLocalBinds GHC.GhcPs -> Annotated () markHsLocalBinds (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)) = applyListAnnotationsLayout (prepareListAnnotation (GHC.bagToList binds) ++ prepareListAnnotation sigs ) markHsLocalBinds (GHC.HsIPBinds _ (GHC.IPBinds _ binds)) = markListWithLayout binds markHsLocalBinds GHC.EmptyLocalBinds{} = return () markHsLocalBinds (GHC.HsValBinds _ (GHC.XValBindsLR _)) = error "markHsLocalBinds:got extension" markHsLocalBinds (GHC.HsIPBinds _ (GHC.XHsIPBinds _)) = error "markHsLocalBinds:got extension" markHsLocalBinds (GHC.XHsLocalBindsLR _) = error "markHsLocalBinds:got extension" -- --------------------------------------------------------------------- markMatchGroup :: (Annotate body) => GHC.SrcSpan -> GHC.MatchGroup GHC.GhcPs (GHC.Located body) -> Annotated () markMatchGroup _ (GHC.MG _ (GHC.L _ matches) _) = setContextLevel (Set.singleton AdvanceLine) 2 $ markListWithLayout matches markMatchGroup _ (GHC.XMatchGroup x) = error $ "got XMatchGroup for:" ++ showGhc x -- --------------------------------------------------------------------- instance (Annotate body) => Annotate [GHC.Located (GHC.Match GHC.GhcPs (GHC.Located body))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsExpr GHC.GhcPs) where markAST loc expr = do markExpr loc expr inContext (Set.singleton AddVbar) $ mark GHC.AnnVbar -- TODO: If the AnnComma is not needed, revert to markAST inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma where markExpr _ (GHC.HsVar _ n) = unsetContext Intercalate $ do ifInContext (Set.singleton PrefixOp) (setContext (Set.singleton PrefixOp) $ markLocated n) (ifInContext (Set.singleton InfixOp) (setContext (Set.singleton InfixOp) $ markLocated n) (markLocated n) ) markExpr l (GHC.HsRecFld _ f) = markAST l f markExpr l (GHC.HsOverLabel _ _ fs) = markExternal l GHC.AnnVal ("#" ++ GHC.unpackFS fs) markExpr l (GHC.HsIPVar _ n@(GHC.HsIPName _v)) = markAST l n markExpr l (GHC.HsOverLit _ ov) = markAST l ov markExpr l (GHC.HsLit _ lit) = markAST l lit markExpr _ (GHC.HsLam _ (GHC.MG _ (GHC.L _ [match]) _)) = do setContext (Set.singleton LambdaExpr) $ do -- TODO: Change this, HsLam binds do not need obey layout rules. -- And will only ever have a single match markLocated match markExpr _ (GHC.HsLam _ _) = error $ "HsLam with other than one match" markExpr l (GHC.HsLamCase _ match) = do mark GHC.AnnLam mark GHC.AnnCase markOptional GHC.AnnSemi markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l match markOptional GHC.AnnCloseC markExpr _ (GHC.HsApp _ e1 e2) = do setContext (Set.singleton PrefixOp) $ markLocated e1 setContext (Set.singleton PrefixOp) $ markLocated e2 -- ------------------------------- markExpr _ (GHC.OpApp _ e1 e2 e3) = do let isInfix = case e2 of -- TODO: generalise this. Is it a fixity thing? GHC.L _ (GHC.HsVar{}) -> True _ -> False normal = -- When it is the leftmost item in a GRHS, e1 needs to have PrefixOp context ifInContext (Set.singleton LeftMost) (setContextLevel (Set.fromList [LeftMost,PrefixOp]) 2 $ markLocated e1) (markLocated e1) if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 else normal unsetContext PrefixOp $ setContext (Set.singleton InfixOp) $ markLocated e2 if isInfix then setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e3 else markLocated e3 -- ------------------------------- markExpr _ (GHC.NegApp _ e _) = do mark GHC.AnnMinus markLocated e markExpr _ (GHC.HsPar _ e) = do mark GHC.AnnOpenP -- '(' markLocated e mark GHC.AnnCloseP -- ')' markExpr _ (GHC.SectionL _ e1 e2) = do markLocated e1 setContext (Set.singleton InfixOp) $ markLocated e2 markExpr _ (GHC.SectionR _ e1 e2) = do setContext (Set.singleton InfixOp) $ markLocated e1 markLocated e2 markExpr _ (GHC.ExplicitTuple _ args b) = do if b == GHC.Boxed then mark GHC.AnnOpenP else markWithString GHC.AnnOpen "(#" setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 args if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" markExpr _ (GHC.ExplicitSum _ alt arity e) = do markWithString GHC.AnnOpen "(#" replicateM_ (alt - 1) $ mark GHC.AnnVbar markLocated e replicateM_ (arity - alt) $ mark GHC.AnnVbar markWithString GHC.AnnClose "#)" markExpr l (GHC.HsCase _ e1 matches) = setRigidFlag $ do mark GHC.AnnCase setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC markInside GHC.AnnSemi setContext (Set.singleton CaseAlt) $ markMatchGroup l matches markOptional GHC.AnnCloseC -- We set the layout for HsIf even though it need not obey layout rules as -- when moving these expressions it's useful that they maintain "internal -- integrity", that is to say the subparts remain indented relative to each -- other. markExpr _ (GHC.HsIf _ _ e1 e2 e3) = setLayoutFlag $ do -- markExpr _ (GHC.HsIf _ e1 e2 e3) = setRigidFlag $ do mark GHC.AnnIf markLocated e1 markAnnBeforeAnn GHC.AnnSemi GHC.AnnThen mark GHC.AnnThen setContextLevel (Set.singleton ListStart) 2 $ markLocated e2 markAnnBeforeAnn GHC.AnnSemi GHC.AnnElse mark GHC.AnnElse setContextLevel (Set.singleton ListStart) 2 $ markLocated e3 markExpr _ (GHC.HsMultiIf _ rhs) = do mark GHC.AnnIf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do -- mapM_ markLocated rhs markListWithLayout rhs markOptional GHC.AnnCloseC markExpr _ (GHC.HsLet _ (GHC.L _ binds) e) = do setLayoutFlag (do -- Make sure the 'in' gets indented too mark GHC.AnnLet markOptional GHC.AnnOpenC markInside GHC.AnnSemi markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e) -- ------------------------------- markExpr _ (GHC.HsDo _ cts (GHC.L _ es)) = do case cts of GHC.DoExpr -> mark GHC.AnnDo GHC.MDoExpr -> mark GHC.AnnMdo _ -> return () let (ostr,cstr) = if isListComp cts then ("[", "]") else ("{", "}") when (isListComp cts) $ markWithString GHC.AnnOpen ostr markOptional GHC.AnnOpenS markOptional GHC.AnnOpenC markInside GHC.AnnSemi if isListComp cts then do markLocated (last es) mark GHC.AnnVbar setLayoutFlag (markListIntercalate (init es)) else do markListWithLayout es markOptional GHC.AnnCloseS markOptional GHC.AnnCloseC when (isListComp cts) $ markWithString GHC.AnnClose cstr -- ------------------------------- markExpr _ (GHC.ExplicitList _ _ es) = do mark GHC.AnnOpenS setContext (Set.singleton PrefixOp) $ markListIntercalateWithFunLevel markLocated 2 es mark GHC.AnnCloseS markExpr _ (GHC.RecordCon _ n (GHC.HsRecFields fs dd)) = do markLocated n mark GHC.AnnOpenC case dd of Nothing -> markListIntercalate fs Just _ -> do setContext (Set.singleton Intercalate) $ mapM_ markLocated fs mark GHC.AnnDotdot mark GHC.AnnCloseC markExpr _ (GHC.RecordUpd _ e fs) = do markLocated e mark GHC.AnnOpenC markListIntercalate fs mark GHC.AnnCloseC markExpr _ (GHC.ExprWithTySig _ e typ) = do setContextLevel (Set.singleton PrefixOp) 2 $ markLocated e mark GHC.AnnDcolon markLHsSigWcType typ markExpr _ (GHC.ArithSeq _ _ seqInfo) = do mark GHC.AnnOpenS -- '[' case seqInfo of GHC.From e -> do markLocated e mark GHC.AnnDotdot GHC.FromTo e1 e2 -> do markLocated e1 mark GHC.AnnDotdot markLocated e2 GHC.FromThen e1 e2 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot GHC.FromThenTo e1 e2 e3 -> do markLocated e1 mark GHC.AnnComma markLocated e2 mark GHC.AnnDotdot markLocated e3 mark GHC.AnnCloseS -- ']' markExpr _ (GHC.HsSCC _ src csFStr e) = do markAnnOpen src "{-# SCC" let txt = sourceTextToString (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithStringOptional GHC.AnnVal txt markWithString GHC.AnnValStr txt markWithString GHC.AnnClose "#-}" markLocated e markExpr _ (GHC.HsCoreAnn _ src csFStr e) = do -- markWithString GHC.AnnOpen src -- "{-# CORE" markAnnOpen src "{-# CORE" -- markWithString GHC.AnnVal (GHC.sl_st csFStr) markSourceText (GHC.sl_st csFStr) (GHC.unpackFS $ GHC.sl_fs csFStr) markWithString GHC.AnnClose "#-}" markLocated e -- TODO: make monomorphic markExpr l (GHC.HsBracket _ (GHC.VarBr _ True v)) = do mark GHC.AnnSimpleQuote setContext (Set.singleton PrefixOpDollar) $ markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr l (GHC.HsBracket _ (GHC.VarBr _ False v)) = do mark GHC.AnnThTyQuote markLocatedFromKw GHC.AnnName (GHC.L l v) markExpr _ (GHC.HsBracket _ (GHC.DecBrL _ ds)) = do markWithString GHC.AnnOpen "[d|" markOptional GHC.AnnOpenC setContext (Set.singleton NoAdvanceLine) $ setContextLevel (Set.singleton TopLevel) 2 $ markListWithLayout ds markOptional GHC.AnnCloseC mark GHC.AnnCloseQ -- "|]" -- Introduced after the renamer markExpr _ (GHC.HsBracket _ (GHC.DecBrG _ _)) = traceM "warning: DecBrG introduced after renamer" markExpr _l (GHC.HsBracket _ (GHC.ExpBr _ e)) = do mark GHC.AnnOpenEQ -- "[|" markOptional GHC.AnnOpenE -- "[e|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _l (GHC.HsBracket _ (GHC.TExpBr _ e)) = do markWithString GHC.AnnOpen "[||" markWithStringOptional GHC.AnnOpenE "[e||" markLocated e markWithString GHC.AnnClose "||]" markExpr _ (GHC.HsBracket _ (GHC.TypBr _ e)) = do markWithString GHC.AnnOpen "[t|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsBracket _ (GHC.PatBr _ e)) = do markWithString GHC.AnnOpen "[p|" markLocated e mark GHC.AnnCloseQ -- "|]" markExpr _ (GHC.HsRnBracketOut {}) = traceM "warning: HsRnBracketOut introduced after renamer" markExpr _ (GHC.HsTcBracketOut {}) = traceM "warning: HsTcBracketOut introduced after renamer" markExpr l (GHC.HsSpliceE _ e) = markAST l e markExpr _ (GHC.HsProc _ p c) = do mark GHC.AnnProc markLocated p mark GHC.AnnRarrow markLocated c markExpr _ (GHC.HsStatic _ e) = do mark GHC.AnnStatic markLocated e markExpr _ (GHC.HsArrApp _ e1 e2 o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markExpr _ (GHC.HsArrForm _ e _ cs) = do markWithString GHC.AnnOpenB "(|" markLocated e mapM_ markLocated cs markWithString GHC.AnnCloseB "|)" markExpr _ (GHC.HsTick {}) = return () markExpr _ (GHC.HsBinTick {}) = return () markExpr _ (GHC.HsTickPragma _ src (str,(v1,v2),(v3,v4)) ((s1,s2),(s3,s4)) e) = do -- '{-# GENERATED' STRING INTEGER ':' INTEGER '-' INTEGER ':' INTEGER '#-}' markAnnOpen src "{-# GENERATED" markOffsetWithString GHC.AnnVal 0 (stringLiteralToString str) -- STRING let markOne n v GHC.NoSourceText = markOffsetWithString GHC.AnnVal n (show v) markOne n _v (GHC.SourceText s) = markOffsetWithString GHC.AnnVal n s markOne 1 v1 s1 -- INTEGER markOffset GHC.AnnColon 0 -- ':' markOne 2 v2 s2 -- INTEGER mark GHC.AnnMinus -- '-' markOne 3 v3 s3 -- INTEGER markOffset GHC.AnnColon 1 -- ':' markOne 4 v4 s4 -- INTEGER markWithString GHC.AnnClose "#-}" markLocated e markExpr l (GHC.EWildPat _) = do ifInContext (Set.fromList [InfixOp]) (do mark GHC.AnnBackquote markWithString GHC.AnnVal "_" mark GHC.AnnBackquote) (markExternal l GHC.AnnVal "_") markExpr _ (GHC.EAsPat _ ln e) = do markLocated ln mark GHC.AnnAt markLocated e markExpr _ (GHC.EViewPat _ e1 e2) = do markLocated e1 mark GHC.AnnRarrow markLocated e2 markExpr _ (GHC.ELazyPat _ e) = do mark GHC.AnnTilde markLocated e markExpr _ (GHC.HsAppType _ e ty) = do markLocated e markInstead GHC.AnnAt AnnTypeApp markLHsWcType ty markExpr _ (GHC.HsWrap {}) = traceM "warning: HsWrap introduced after renaming" markExpr _ (GHC.HsUnboundVar {}) = traceM "warning: HsUnboundVar introduced after renaming" markExpr _ (GHC.HsConLikeOut{}) = traceM "warning: HsConLikeOut introduced after type checking" markExpr _ (GHC.HsBracket _ (GHC.XBracket _)) = error "markExpr got extension" markExpr _ (GHC.XExpr _) = error "markExpr got extension" -- --------------------------------------------------------------------- markLHsWcType :: GHC.LHsWcType GHC.GhcPs -> Annotated () markLHsWcType (GHC.HsWC _ ty) = do markLocated ty markLHsWcType (GHC.XHsWildCardBndrs x) = error $ "markLHsWcType got :" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsLit GHC.GhcPs) where markAST l lit = markExternal l GHC.AnnVal (hsLit2String lit) -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecUpdField GHC.GhcPs) where markAST _ (GHC.HsRecField lbl expr punFlag) = do unsetContext Intercalate $ markLocated lbl when (punFlag == False) $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated expr inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.AmbiguousFieldOcc GHC.GhcPs) where markAST _ (GHC.Unambiguous _ n) = markLocated n markAST _ (GHC.Ambiguous _ n) = markLocated n markAST _ (GHC.XAmbiguousFieldOcc x) = error $ "got XAmbiguousFieldOcc for:" ++ showGhc x -- --------------------------------------------------------------------- -- |Used for declarations that need to be aligned together, e.g. in a -- do or let .. in statement/expr instance Annotate [GHC.ExprLStmt GHC.GhcPs] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.HsTupArg GHC.GhcPs) where markAST _ (GHC.Present _ (GHC.L l e)) = do markLocated (GHC.L l e) inContext (Set.fromList [Intercalate]) $ markOutside GHC.AnnComma (G GHC.AnnComma) markAST _ (GHC.Missing _) = do inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma markAST _ (GHC.XTupArg x) = error $ "got XTupArg got:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.HsCmdTop GHC.GhcPs) where markAST _ (GHC.HsCmdTop _ cmd) = markLocated cmd markAST _ (GHC.XCmdTop x) = error $ "got XCmdTop for:" ++ showGhc x instance Annotate (GHC.HsCmd GHC.GhcPs) where markAST _ (GHC.HsCmdArrApp _ e1 e2 o isRightToLeft) = do -- isRightToLeft True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) if isRightToLeft then do markLocated e1 case o of GHC.HsFirstOrderApp -> mark GHC.Annlarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnLarrowtail else do markLocated e2 case o of GHC.HsFirstOrderApp -> mark GHC.Annrarrowtail GHC.HsHigherOrderApp -> mark GHC.AnnRarrowtail if isRightToLeft then markLocated e2 else markLocated e1 markAST _ (GHC.HsCmdArrForm _ e fixity _mf cs) = do -- The AnnOpen should be marked for a prefix usage, not for a postfix one, -- due to the way checkCmd maps both HsArrForm and OpApp to HsCmdArrForm let isPrefixOp = case fixity of GHC.Infix -> False GHC.Prefix -> True when isPrefixOp $ mark GHC.AnnOpenB -- "(|" -- This may be an infix operation applyListAnnotationsContexts (LC (Set.singleton PrefixOp) (Set.singleton PrefixOp) (Set.singleton InfixOp) (Set.singleton InfixOp)) (prepareListAnnotation [e] ++ prepareListAnnotation cs) when isPrefixOp $ mark GHC.AnnCloseB -- "|)" markAST _ (GHC.HsCmdApp _ e1 e2) = do markLocated e1 markLocated e2 markAST l (GHC.HsCmdLam _ match) = do setContext (Set.singleton LambdaExpr) $ do markMatchGroup l match markAST _ (GHC.HsCmdPar _ e) = do mark GHC.AnnOpenP markLocated e mark GHC.AnnCloseP -- ')' markAST l (GHC.HsCmdCase _ e1 matches) = do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf markOptional GHC.AnnOpenC setContext (Set.singleton CaseAlt) $ do markMatchGroup l matches markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdIf _ _ e1 e2 e3) = do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 mark GHC.AnnThen markLocated e2 markOffset GHC.AnnSemi 1 mark GHC.AnnElse markLocated e3 markAST _ (GHC.HsCmdLet _ (GHC.L _ binds) e) = do mark GHC.AnnLet markOptional GHC.AnnOpenC markLocalBindsWithLayout binds markOptional GHC.AnnCloseC mark GHC.AnnIn markLocated e markAST _ (GHC.HsCmdDo _ (GHC.L _ es)) = do mark GHC.AnnDo markOptional GHC.AnnOpenC markListWithLayout es markOptional GHC.AnnCloseC markAST _ (GHC.HsCmdWrap {}) = traceM "warning: HsCmdWrap introduced after renaming" markAST _ (GHC.XCmd x) = error $ "got XCmd for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate [GHC.Located (GHC.StmtLR GHC.GhcPs GHC.GhcPs (GHC.LHsCmd GHC.GhcPs))] where markAST _ ls = mapM_ markLocated ls -- --------------------------------------------------------------------- instance Annotate (GHC.TyClDecl GHC.GhcPs) where markAST l (GHC.FamDecl _ famdecl) = markAST l famdecl >> markTrailingSemi {- SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs , tcdLName :: Located (IdP pass) -- ^ Type constructor , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdRhs :: LHsType pass } -- ^ RHS of type declaration -} markAST _ (GHC.SynDecl _ ln (GHC.HsQTvs _ tyvars) fixity 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 markTyClass Nothing fixity ln tyvars mark GHC.AnnEqual markLocated typ markTrailingSemi markAST _ (GHC.DataDecl _ ln (GHC.HsQTvs _ tyVars) fixity (GHC.HsDataDefn _ nd ctx mctyp mk cons derivs)) = do if nd == GHC.DataType then mark GHC.AnnData else mark GHC.AnnNewtype markMaybe mctyp markLocated ctx markTyClass Nothing fixity ln tyVars case mk of Nothing -> return () Just k -> do mark GHC.AnnDcolon markLocated k if isGadt cons then mark GHC.AnnWhere else unless (null cons) $ mark GHC.AnnEqual markOptional GHC.AnnWhere markOptional GHC.AnnOpenC setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ markListWithContexts' listContexts cons markOptional GHC.AnnCloseC setContext (Set.fromList [Deriving,NoDarrow]) $ markLocated derivs markTrailingSemi -- ----------------------------------- markAST _ (GHC.ClassDecl _ ctx ln (GHC.HsQTvs _ tyVars) fixity fds sigs meths ats atdefs docs) = do mark GHC.AnnClass markLocated ctx markTyClass Nothing fixity ln tyVars unless (null fds) $ do mark GHC.AnnVbar markListIntercalateWithFunLevel markLocated 2 fds mark GHC.AnnWhere markOptional GHC.AnnOpenC -- '{' markInside GHC.AnnSemi -- AZ:TODO: we end up with both the tyVars and the following body of the -- class defn in annSortKey for the class. This could cause problems when -- changing things. setContext (Set.singleton InClassDecl) $ applyListAnnotationsLayout (prepareListAnnotation sigs ++ prepareListAnnotation (GHC.bagToList meths) ++ prepareListAnnotation ats ++ prepareListAnnotation atdefs ++ prepareListAnnotation docs ) markOptional GHC.AnnCloseC -- '}' markTrailingSemi {- | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs tcdCtxt :: LHsContext pass, -- ^ Context... tcdLName :: Located (IdP pass), -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [Located (FunDep (Located (IdP pass)))], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures tcdMeths :: LHsBinds pass, -- ^ Default methods tcdATs :: [LFamilyDecl pass], -- ^ Associated types; tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } -} markAST _ (GHC.SynDecl _ _ (GHC.XLHsQTyVars _) _ _) = error "extension hit for TyClDecl" markAST _ (GHC.DataDecl _ _ (GHC.HsQTvs _ _) _ (GHC.XHsDataDefn _)) = error "extension hit for TyClDecl" markAST _ (GHC.DataDecl _ _ (GHC.XLHsQTyVars _) _ _) = error "extension hit for TyClDecl" markAST _ (GHC.ClassDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _ _ _ _ _) = error "extension hit for TyClDecl" markAST _ (GHC.XTyClDecl _) = error "extension hit for TyClDecl" -- --------------------------------------------------------------------- markTypeApp :: GHC.SrcSpan -> Annotated () markTypeApp loc = do let l = GHC.srcSpanFirstCharacter loc markExternal l GHC.AnnVal "@" -- --------------------------------------------------------------------- markTyClassArgs :: (Annotate a, GHC.HasOccName a) => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity -- -> GHC.Located a -> [ast] -> Annotated () -> GHC.Located a -> [GHC.LHsTypeArg GhcPs] -> Annotated () markTyClassArgs mbndrs fixity ln tyVars = do let cvt (GHC.HsValArg val) = markLocated val cvt (GHC.HsTypeArg loc typ) = do markTypeApp loc -- let l = GHC.srcSpanFirstCharacter loc -- markExternal l GHC.AnnVal "@" markLocated typ cvt (GHC.HsArgPar _ss) = undefined markTyClassWorker cvt mbndrs fixity ln tyVars {- type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) data HsArg tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) | HsTypeArg ty -- Argument is a visible type application (f @ty) | HsArgPar SrcSpan -- See Note [HsArgPar] -} -- TODO:AZ: simplify markTyClass :: (Data (GHC.SrcSpanLess ast), Annotate a, GHC.HasOccName a, Annotate ast,GHC.HasSrcSpan ast) => Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity -> GHC.Located a -> [ast] -> Annotated () markTyClass = markTyClassWorker markLocated markTyClassWorker :: (Annotate a, GHC.HasOccName a) => (b -> Annotated ()) -> Maybe [GHC.LHsTyVarBndr GhcPs] -> GHC.LexicalFixity -- -> GHC.Located a -> [ast] -> Annotated () -> GHC.Located a -> [b] -> Annotated () markTyClassWorker markFn mbndrs fixity ln tyVars = do let processBinders = case mbndrs of Nothing -> return () Just bndrs -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot -- There may be arbitrary parens around parts of the constructor -- Turn these into comments so that they feed into the right place automatically annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP] let markParens = if fixity == GHC.Infix && length tyVars > 2 then markMany else markManyOptional if fixity == GHC.Prefix then do markManyOptional GHC.AnnOpenP processBinders setContext (Set.singleton PrefixOp) $ markLocated ln -- setContext (Set.singleton PrefixOp) $ mapM_ markLocated tyVars setContext (Set.singleton PrefixOp) $ mapM_ markFn $ take 2 tyVars when (length tyVars >= 2) $ do markParens GHC.AnnCloseP setContext (Set.singleton PrefixOp) $ mapM_ markFn $ drop 2 tyVars markManyOptional GHC.AnnCloseP else do case tyVars of (x:y:xs) -> do markParens GHC.AnnOpenP processBinders markFn x setContext (Set.singleton InfixOp) $ markLocated ln markFn y markParens GHC.AnnCloseP mapM_ markFn xs markManyOptional GHC.AnnCloseP _ -> error $ "markTyClass: Infix op without operands" -- --------------------------------------------------------------------- instance Annotate [GHC.LHsDerivingClause GHC.GhcPs] where markAST _ ds = mapM_ markLocated ds -- --------------------------------------------------------------------- instance Annotate (GHC.HsDerivingClause GHC.GhcPs) where markAST _ (GHC.HsDerivingClause _ mstrategy typs) = do mark GHC.AnnDeriving case mstrategy of Nothing -> return () Just (GHC.L _ (GHC.ViaStrategy{})) -> return () Just s -> markLocated s markLocated typs case mstrategy of Just s@(GHC.L _ (GHC.ViaStrategy{})) -> markLocated s _ -> return () markAST _ (GHC.XHsDerivingClause x) = error $ "got XHsDerivingClause for:" ++ showGhc x {- = HsDerivingClause { deriv_clause_ext :: XCHsDerivingClause pass , deriv_clause_strategy :: Maybe (LDerivStrategy pass) -- ^ The user-specified strategy (if any) to use when deriving -- 'deriv_clause_tys'. , deriv_clause_tys :: Located [LHsSigType pass] -- ^ The types to derive. -- -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, -- we can mention type variables that aren't bound by the datatype, e.g. -- -- > data T b = ... deriving (C [a]) -- -- should produce a derived instance for @C [a] (T b)@. } -} -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyDecl GHC.GhcPs) where markAST _ (GHC.FamilyDecl _ info ln (GHC.HsQTvs _ tyvars) fixity rsig minj) = do case info of GHC.DataFamily -> mark GHC.AnnData _ -> mark GHC.AnnType mark GHC.AnnFamily markTyClass Nothing fixity ln tyvars case GHC.unLoc rsig of GHC.NoSig _ -> return () GHC.KindSig _ _ -> do mark GHC.AnnDcolon markLocated rsig GHC.TyVarSig _ _ -> do mark GHC.AnnEqual markLocated rsig (GHC.XFamilyResultSig x) -> error $ "FamilyDecl:got XFamilyResultSig for:" ++ showGhc x case minj of Nothing -> return () Just inj -> do mark GHC.AnnVbar markLocated inj case info of GHC.ClosedTypeFamily (Just eqns) -> do mark GHC.AnnWhere markOptional GHC.AnnOpenC -- { markListWithLayout eqns markOptional GHC.AnnCloseC -- } GHC.ClosedTypeFamily Nothing -> do mark GHC.AnnWhere mark GHC.AnnOpenC -- { mark GHC.AnnDotdot mark GHC.AnnCloseC -- } _ -> return () markTrailingSemi markAST _ (GHC.FamilyDecl _ _ _ (GHC.XLHsQTyVars _) _ _ _) = error "got extension for FamilyDecl" markAST _ (GHC.XFamilyDecl _) = error "got extension for FamilyDecl" -- --------------------------------------------------------------------- instance Annotate (GHC.FamilyResultSig GHC.GhcPs) where markAST _ (GHC.NoSig _) = return () markAST _ (GHC.KindSig _ k) = markLocated k markAST _ (GHC.TyVarSig _ ltv) = markLocated ltv markAST _ (GHC.XFamilyResultSig x) = error $ "got XFamilyResultSig for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.InjectivityAnn GHC.GhcPs) where markAST _ (GHC.InjectivityAnn ln lns) = do markLocated ln mark GHC.AnnRarrow mapM_ markLocated lns -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamInstEqn GHC.GhcPs) where {- type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) type HsTyPats pass = [LHsTypeArg pass] -} markAST _ (GHC.HsIB _ eqn) = do markFamEqn eqn markTrailingSemi markAST _ (GHC.XHsImplicitBndrs x) = error $ "got XHsImplicitBndrs for:" ++ showGhc x -- --------------------------------------------------------------------- instance Annotate (GHC.TyFamDefltEqn GHC.GhcPs) where markAST _ (GHC.FamEqn _ ln mbndrs (GHC.HsQTvs _ bndrs) fixity typ) = do mark GHC.AnnType mark GHC.AnnInstance markTyClass mbndrs fixity ln bndrs mark GHC.AnnEqual markLocated typ {- type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass) data LHsQTyVars pass -- See Note [HsType binders] = HsQTvs { hsq_ext :: XHsQTvs pass , hsq_explicit :: [LHsTyVarBndr pass] -- Explicit variables, written by the user -- See Note [HsForAllTy tyvar binders] } data FamEqn pass pats rhs = FamEqn { feqn_ext :: XCFamEqn pass pats rhs , feqn_tycon :: Located (IdP pass) , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars , feqn_pats :: pats , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs } -} markAST _ (GHC.FamEqn _ _ _ (GHC.XLHsQTyVars _) _ _) = error "TyFamDefltEqn hit extension point" markAST _ (GHC.XFamEqn _) = error "TyFamDefltEqn hit extension point" -- --------------------------------------------------------------------- -- TODO: modify lexer etc, in the meantime to not set haddock flag instance Annotate GHC.DocDecl where markAST l v = let str = case v of (GHC.DocCommentNext ds) -> GHC.unpackHDS ds (GHC.DocCommentPrev ds) -> GHC.unpackHDS ds (GHC.DocCommentNamed _s ds) -> GHC.unpackHDS ds (GHC.DocGroup _i ds) -> GHC.unpackHDS ds in markExternal l GHC.AnnVal str >> markTrailingSemi {- data DocDecl = DocCommentNext HsDocString | DocCommentPrev HsDocString | DocCommentNamed String HsDocString | DocGroup Int HsDocString -} -- --------------------------------------------------------------------- markDataDefn :: GHC.SrcSpan -> GHC.HsDataDefn GHC.GhcPs -> Annotated () markDataDefn _ (GHC.HsDataDefn _ _ ctx typ _mk cons derivs) = do markLocated ctx markMaybe typ if isGadt cons then markListWithLayout cons else markListIntercalateWithFunLevel markLocated 2 cons setContext (Set.singleton Deriving) $ markLocated derivs markDataDefn _ (GHC.XHsDataDefn x) = error $ "got XHsDataDefn for:" ++ showGhc x -- --------------------------------------------------------------------- -- Note: GHC.HsContext name aliases to here too instance Annotate [GHC.LHsType GHC.GhcPs] where markAST l ts = do -- Note: A single item in parens in a standalone deriving clause -- is parsed as a HsSigType, which is always a HsForAllTy or -- HsQualTy. Without parens it is always a HsVar. So for round -- trip pretty printing we need to take this into account. let parenIfNeeded' pa = case ts of [] -> if l == GHC.noSrcSpan then markManyOptional pa else markMany pa [GHC.L _ GHC.HsForAllTy{}] -> markMany pa [GHC.L _ GHC.HsQualTy{}] -> markMany pa [_] -> markManyOptional pa _ -> markMany pa parenIfNeeded'' pa = ifInContext (Set.singleton Parens) -- AZ:TODO: this is never set? (markMany pa) (parenIfNeeded' pa) parenIfNeeded pa = case ts of [GHC.L _ GHC.HsParTy{}] -> markOptional pa _ -> parenIfNeeded'' pa -- ------------- parenIfNeeded GHC.AnnOpenP unsetContext Intercalate $ markListIntercalateWithFunLevel markLocated 2 ts parenIfNeeded GHC.AnnCloseP ifInContext (Set.singleton NoDarrow) (return ()) (if null ts && (l == GHC.noSrcSpan) then markOptional GHC.AnnDarrow else mark GHC.AnnDarrow) -- --------------------------------------------------------------------- instance Annotate (GHC.ConDecl GHC.GhcPs) where markAST _ (GHC.ConDeclH98 _ ln _fa mqtvs mctx dets _) = do case mqtvs of [] -> return () bndrs -> do mark GHC.AnnForall mapM_ markLocated bndrs mark GHC.AnnDot case mctx of Just ctx -> do setContext (Set.fromList [NoDarrow]) $ markLocated ctx unless (null $ GHC.unLoc ctx) $ mark GHC.AnnDarrow Nothing -> return () case dets of GHC.InfixCon _ _ -> return () _ -> setContext (Set.singleton PrefixOp) $ markLocated ln markHsConDeclDetails False False [ln] dets inContext (Set.fromList [Intercalate]) $ mark GHC.AnnVbar markTrailingSemi {- | ConDeclH98 { con_ext :: XConDeclH98 pass , con_name :: Located (IdP pass) , con_forall :: Bool -- ^ True <=> explicit user-written forall -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} -- False => con_ex_tvs is empty , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -} markAST _ (GHC.ConDeclGADT _ lns (GHC.L l forall) (GHC.HsQTvs _ qvars) mbCxt args typ _) = do setContext (Set.singleton PrefixOp) $ markListIntercalate lns mark GHC.AnnDcolon annotationsToComments [GHC.AnnOpenP] markLocated (GHC.L l (ResTyGADTHook forall qvars)) markMaybe mbCxt markHsConDeclDetails False True lns args markLocated typ markManyOptional GHC.AnnCloseP markTrailingSemi {- = ConDeclGADT { con_g_ext :: XConDeclGADT pass , con_names :: [Located (IdP pass)] -- The next four fields describe the type after the '::' -- See Note [GADT abstract syntax] , con_forall :: Located Bool -- ^ True <=> explicit forall -- False => hsq_explicit is empty , con_qvars :: LHsQTyVars pass -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon , con_res_ty :: LHsType pass -- ^ Result type , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } -} markAST _ (GHC.ConDeclGADT _ _ (GHC.L _ _) (GHC.XLHsQTyVars _) _ _ _ _) = error "hit extension point in ConDecl" markAST _ (GHC.XConDecl _) = error "hit extension point in ConDecl" -- ResTyGADT has a SrcSpan for the original sigtype, we need to create -- a type for exactPC and annotatePC data ResTyGADTHook = ResTyGADTHook Bool [GHC.LHsTyVarBndr GHC.GhcPs] deriving (Typeable) deriving instance Data (ResTyGADTHook) instance GHC.Outputable ResTyGADTHook where ppr (ResTyGADTHook b bs) = GHC.text "ResTyGADTHook" GHC.<+> GHC.ppr b GHC.<+> GHC.ppr bs -- 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 "_" -- --------------------------------------------------------------------- instance Annotate ResTyGADTHook where markAST _ (ResTyGADTHook forall bndrs) = do unless (null bndrs) $ do when forall $ mark GHC.AnnForall mapM_ markLocated bndrs when forall $ mark GHC.AnnDot -- --------------------------------------------------------------------- instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LPat GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma instance Annotate (GHC.HsRecField GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) where markAST _ (GHC.HsRecField n e punFlag) = do unsetContext Intercalate $ markLocated n unless punFlag $ do mark GHC.AnnEqual unsetContext Intercalate $ markLocated e inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate (GHC.FunDep (GHC.Located GHC.RdrName)) where markAST _ (ls,rs) = do mapM_ markLocated ls mark GHC.AnnRarrow mapM_ markLocated rs inContext (Set.fromList [Intercalate]) $ mark GHC.AnnComma -- --------------------------------------------------------------------- instance Annotate GHC.CType where markAST _ (GHC.CType src mh f) = do -- markWithString GHC.AnnOpen src markAnnOpen src "" case mh of Nothing -> return () Just (GHC.Header srcH _h) -> -- markWithString GHC.AnnHeader srcH markWithString GHC.AnnHeader (toSourceTextWithSuffix srcH "" "") -- markWithString GHC.AnnVal (fst f) markSourceText (fst f) (GHC.unpackFS $ snd f) markWithString GHC.AnnClose "#-}" -- --------------------------------------------------------------------- stringLiteralToString :: GHC.StringLiteral -> String stringLiteralToString (GHC.StringLiteral st fs) = case st of GHC.NoSourceText -> GHC.unpackFS fs GHC.SourceText src -> src ghc-exactprint-0.6.2/src/Language/Haskell/GHC/0000755000000000000000000000000007346545000017126 5ustar0000000000000000ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint.hs0000644000000000000000000000160207346545000021542 0ustar0000000000000000{-# 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 -- * Adding default annotations , addAnnotationsForPretty -- * Printing , exactPrint ) where import Language.Haskell.GHC.ExactPrint.Delta import Language.Haskell.GHC.ExactPrint.Pretty import Language.Haskell.GHC.ExactPrint.Print import Language.Haskell.GHC.ExactPrint.Transform import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/0000755000000000000000000000000007346545000021207 5ustar0000000000000000ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Annotate.hs0000644000000000000000000000234107346545000023314 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook -- | 'annotate' is a function which given a GHC AST fragment, constructs -- a syntax tree which indicates which annotations belong to each specific -- part of the fragment. -- -- "Delta" and "Print" provide two interpreters for this structure. You -- should probably use those unless you know what you're doing! -- -- The functor 'AnnotationF' has a number of constructors which correspond -- to different sitations which annotations can arise. It is hoped that in -- future versions of GHC these can be simplified by making suitable -- modifications to the AST. module Language.Haskell.GHC.ExactPrint.Annotate ( annotate , AnnotationF(..) , Annotated , Annotate(..) , withSortKeyContextsHelper ) where import Language.Haskell.GHC.ExactPrint.Annotater ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/AnnotateTypes.hs0000644000000000000000000003662607346545000024356 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- Needed for the DataId constraint on ResTyGADTHook {-# LANGUAGE ViewPatterns #-} -- | '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.AnnotateTypes -- ( -- AnnotationF(..) -- , Annotated -- , Annotate(..) -- ) where #if __GLASGOW_HASKELL__ <= 710 import Data.Ord ( comparing ) import Data.List ( sortBy ) #endif import Language.Haskell.GHC.ExactPrint.Types #if __GLASGOW_HASKELL__ > 800 import qualified BasicTypes as GHC #endif import qualified GHC as GHC #if __GLASGOW_HASKELL__ <= 710 import qualified BooleanFormula as GHC import qualified Outputable as GHC #endif import Control.Monad.Trans.Free import Control.Monad.Free.TH (makeFreeCon) import Control.Monad.Identity import Data.Data import qualified Data.Set as Set -- import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | ['MarkPrim'] The main constructor. Marks that a specific AnnKeywordId could -- appear with an optional String which is used when printing. -- ['MarkPPOptional'] Used to flag elements, such as optional braces, that are -- not used in the pretty printer. This functions identically to 'MarkPrim' -- for the other interpreters. -- ['MarkEOF'] -- Special constructor which marks the end of file marker. -- ['MarkExternal'] TODO -- ['MarkOutside'] A @AnnKeywordId@ which is precisely located but not inside the -- current context. This is usually used to reassociated located -- @RdrName@ which are more naturally associated with their parent than -- in their own annotation. -- ['MarkInside'] -- The dual of MarkOutside. If we wish to mark a non-separating comma -- or semi-colon then we must use this constructor. -- ['MarkMany'] Some syntax elements allow an arbritary number of puncuation marks -- without reflection in the AST. This construction greedily takes all of -- the specified @AnnKeywordId@. -- ['MarkOffsetPrim'] Some syntax elements have repeated @AnnKeywordId@ which are -- seperated by different @AnnKeywordId@. Thus using MarkMany is -- unsuitable and instead we provide an index to specify which specific -- instance to choose each time. -- ['WithAST'] TODO -- ['CountAnns'] Sometimes the AST does not reflect the concrete source code and the -- only way to tell what the concrete source was is to count a certain -- kind of @AnnKeywordId@. -- ['WithSortKey'] There are many places where the syntactic ordering of elements is -- thrown away by the AST. This constructor captures the original -- ordering and reflects any changes in ordered as specified by the -- @annSortKey@ field in @Annotation@. -- ['SetLayoutFlag'] It is important to know precisely where layout rules apply. This -- constructor wraps a computation to indicate that LayoutRules apply to -- the corresponding construct. -- ['StoreOriginalSrcSpan'] TODO -- ['GetSrcSpanFromKw'] TODO -- ['StoreString'] TODO -- ['AnnotationsToComments'] Used when the AST is sufficiently vague that there is no other -- option but to convert a fragment of source code into a comment. This -- means it is impossible to edit such a fragment but means that -- processing files with such fragments is still possible. data AnnotationF next where MarkPrim :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next MarkPPOptional :: GHC.AnnKeywordId -> Maybe String -> next -> AnnotationF next MarkEOF :: next -> AnnotationF next MarkExternal :: GHC.SrcSpan -> GHC.AnnKeywordId -> String -> next -> AnnotationF next #if __GLASGOW_HASKELL__ >= 800 MarkInstead :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next #endif MarkOutside :: GHC.AnnKeywordId -> KeywordId -> next -> AnnotationF next MarkInside :: GHC.AnnKeywordId -> next -> AnnotationF next MarkMany :: GHC.AnnKeywordId -> next -> AnnotationF next MarkManyOptional :: GHC.AnnKeywordId -> next -> AnnotationF next MarkOffsetPrim :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next MarkOffsetPrimOptional :: GHC.AnnKeywordId -> Int -> Maybe String -> next -> AnnotationF next #if __GLASGOW_HASKELL__ > 806 WithAST :: (Data a,Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Annotated b -> next -> AnnotationF next #else WithAST :: Data a => GHC.Located a -> Annotated b -> next -> AnnotationF next #endif CountAnns :: GHC.AnnKeywordId -> (Int -> next) -> AnnotationF next WithSortKey :: [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next SetLayoutFlag :: Rigidity -> Annotated () -> next -> AnnotationF next MarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> next -> AnnotationF next -- Required to work around deficiencies in the GHC AST StoreOriginalSrcSpan :: GHC.SrcSpan -> AnnKey -> (AnnKey -> next) -> AnnotationF next GetSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> next) -> AnnotationF next #if __GLASGOW_HASKELL__ <= 710 StoreString :: String -> GHC.SrcSpan -> next -> AnnotationF next #endif AnnotationsToComments :: [GHC.AnnKeywordId] -> next -> AnnotationF next #if __GLASGOW_HASKELL__ <= 710 AnnotationsToCommentsBF :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> next -> AnnotationF next FinalizeBF :: GHC.SrcSpan -> next -> AnnotationF next #endif -- AZ experimenting with pretty printing -- Set the context for child element SetContextLevel :: Set.Set AstContext -> Int -> Annotated () -> next -> AnnotationF next UnsetContext :: AstContext -> Annotated () -> next -> AnnotationF next -- Query the context while in a child element IfInContext :: Set.Set AstContext -> Annotated () -> Annotated () -> next -> AnnotationF next WithSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> next -> AnnotationF next -- TellContext :: Set.Set AstContext -> next -> AnnotationF next deriving instance Functor AnnotationF type Annotated = FreeT AnnotationF Identity -- --------------------------------------------------------------------- makeFreeCon 'MarkEOF makeFreeCon 'MarkPrim makeFreeCon 'MarkPPOptional #if __GLASGOW_HASKELL__ >= 800 makeFreeCon 'MarkInstead #endif makeFreeCon 'MarkOutside makeFreeCon 'MarkInside makeFreeCon 'MarkExternal makeFreeCon 'MarkMany makeFreeCon 'MarkManyOptional makeFreeCon 'MarkOffsetPrim makeFreeCon 'MarkOffsetPrimOptional makeFreeCon 'CountAnns makeFreeCon 'StoreOriginalSrcSpan makeFreeCon 'GetSrcSpanForKw #if __GLASGOW_HASKELL__ <= 710 makeFreeCon 'StoreString #endif makeFreeCon 'AnnotationsToComments #if __GLASGOW_HASKELL__ <= 710 makeFreeCon 'AnnotationsToCommentsBF makeFreeCon 'FinalizeBF #endif makeFreeCon 'WithSortKey makeFreeCon 'SetContextLevel makeFreeCon 'UnsetContext makeFreeCon 'IfInContext makeFreeCon 'WithSortKeyContexts makeFreeCon 'TellContext makeFreeCon 'MarkAnnBeforeAnn -- --------------------------------------------------------------------- setContext :: Set.Set AstContext -> Annotated () -> Annotated () setContext ctxt action = liftF (SetContextLevel ctxt 3 action ()) setLayoutFlag :: Annotated () -> Annotated () setLayoutFlag action = liftF (SetLayoutFlag NormalLayout action ()) setRigidFlag :: Annotated () -> Annotated () setRigidFlag action = liftF (SetLayoutFlag RigidLayout action ()) inContext :: Set.Set AstContext -> Annotated () -> Annotated () inContext ctxt action = liftF (IfInContext ctxt action (return ()) ()) -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 workOutString :: GHC.SrcSpan -> GHC.AnnKeywordId -> (GHC.SrcSpan -> String) -> Annotated () workOutString l kw f = do ss <- getSrcSpanForKw l kw storeString (f ss) ss #endif -- --------------------------------------------------------------------- -- |Main driver point for annotations. #if __GLASGOW_HASKELL__ > 806 withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Annotated () -> Annotated () #else withAST :: Data a => GHC.Located a -> Annotated () -> Annotated () #endif withAST lss action = liftF (WithAST lss action ()) -- --------------------------------------------------------------------- -- Additional smart constructors mark :: GHC.AnnKeywordId -> Annotated () mark kwid = markPrim kwid Nothing markOptional :: GHC.AnnKeywordId -> Annotated () markOptional kwid = markPPOptional kwid Nothing markWithString :: GHC.AnnKeywordId -> String -> Annotated () markWithString kwid s = markPrim kwid (Just s) markWithStringOptional :: GHC.AnnKeywordId -> String -> Annotated () markWithStringOptional kwid s = markPPOptional kwid (Just s) markOffsetWithString :: GHC.AnnKeywordId -> Int -> String -> Annotated () markOffsetWithString kwid n s = markOffsetPrim kwid n (Just s) markOffset :: GHC.AnnKeywordId -> Int -> Annotated () markOffset kwid n = markOffsetPrim kwid n Nothing markOffsetOptional :: GHC.AnnKeywordId -> Int -> Annotated () markOffsetOptional kwid n = markOffsetPrimOptional kwid n Nothing markTrailingSemi :: Annotated () markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 806 withLocated :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> (GHC.SrcSpan -> a -> Annotated ()) -> Annotated () withLocated a@(GHC.dL->GHC.L l _) action = withAST a (action l a) #else withLocated :: Data a => GHC.Located a -> (GHC.SrcSpan -> a -> Annotated ()) -> Annotated () withLocated a@(GHC.L l t) action = withAST a (action l t) #endif -- --------------------------------------------------------------------- markListIntercalateWithFun :: (t -> Annotated ()) -> [t] -> Annotated () markListIntercalateWithFun f ls = markListIntercalateWithFunLevel f 2 ls markListIntercalateWithFunLevel :: (t -> Annotated ()) -> Int -> [t] -> Annotated () markListIntercalateWithFunLevel f level ls = markListIntercalateWithFunLevelCtx f level Intercalate ls markListIntercalateWithFunLevelCtx :: (t -> Annotated ()) -> Int -> AstContext -> [t] -> Annotated () markListIntercalateWithFunLevelCtx f level ctx ls = go ls where go [] = return () go [x] = f x go (x:xs) = do setContextLevel (Set.singleton ctx) level $ f x go xs -- --------------------------------------------------------------------- markListWithContextsFunction :: ListContexts -> (t -> Annotated ()) -> [t] -> Annotated () markListWithContextsFunction (LC ctxOnly ctxInitial ctxMiddle ctxLast) f ls = case ls of [] -> return () [x] -> setContextLevel ctxOnly level $ f x (x:xs) -> do setContextLevel ctxInitial level $ f x go xs where level = 2 go [] = return () go [x] = setContextLevel ctxLast level $ f x go (x:xs) = do setContextLevel ctxMiddle level $ f x go xs -- --------------------------------------------------------------------- -- Expects the kws to be ordered already withSortKeyContextsHelper :: (Monad m) => (Annotated () -> m ()) -> ListContexts -> [(GHC.SrcSpan, Annotated ())] -> m () withSortKeyContextsHelper interpret (LC ctxOnly ctxInitial ctxMiddle ctxLast) kws = do case kws of [] -> return () [x] -> interpret (setContextLevel (Set.insert (CtxPos 0) ctxOnly) level $ snd x) (x:xs) -> do interpret (setContextLevel (Set.insert (CtxPos 0) ctxInitial) level $ snd x) go 1 xs where level = 2 go _ [] = return () go n [x] = interpret (setContextLevel (Set.insert (CtxPos n) ctxLast) level $ snd x) go n (x:xs) = do interpret (setContextLevel (Set.insert (CtxPos n) ctxMiddle) level $ snd x) go (n+1) xs -- --------------------------------------------------------------------- -- Managing lists which have been separated, e.g. Sigs and Binds applyListAnnotations :: [(GHC.SrcSpan, Annotated ())] -> Annotated () applyListAnnotations ls = withSortKey ls applyListAnnotationsContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Annotated () applyListAnnotationsContexts ctxt ls = withSortKeyContexts ctxt ls #if __GLASGOW_HASKELL__ <= 710 lexicalSortLocated :: [GHC.Located a] -> [GHC.Located a] lexicalSortLocated = sortBy (comparing GHC.getLoc) #endif applyListAnnotationsLayout :: [(GHC.SrcSpan, Annotated ())] -> Annotated () applyListAnnotationsLayout ls = setLayoutFlag $ setContext (Set.singleton NoPrecedingSpace) $ withSortKeyContexts listContexts ls listContexts :: ListContexts listContexts = LC (Set.fromList [CtxOnly,ListStart]) (Set.fromList [CtxFirst,ListStart,Intercalate]) (Set.fromList [CtxMiddle,ListItem,Intercalate]) (Set.fromList [CtxLast,ListItem]) listContexts' :: ListContexts listContexts' = LC (Set.fromList [CtxOnly, ListStart]) (Set.fromList [CtxFirst, ListStart]) (Set.fromList [CtxMiddle,ListItem]) (Set.fromList [CtxLast, ListItem]) -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 800 markAnnOpen :: GHC.SourceText -> String -> Annotated () markAnnOpen GHC.NoSourceText txt = markWithString GHC.AnnOpen txt markAnnOpen (GHC.SourceText txt) _ = markWithString GHC.AnnOpen txt markSourceText :: GHC.SourceText -> String -> Annotated () markSourceText GHC.NoSourceText txt = markWithString GHC.AnnVal txt markSourceText (GHC.SourceText txt) _ = markWithString GHC.AnnVal txt markExternalSourceText :: GHC.SrcSpan -> GHC.SourceText -> String -> Annotated () markExternalSourceText l GHC.NoSourceText txt = markExternal l GHC.AnnVal txt markExternalSourceText l (GHC.SourceText txt) _ = markExternal l GHC.AnnVal txt sourceTextToString :: GHC.SourceText -> String -> String sourceTextToString GHC.NoSourceText alt = alt sourceTextToString (GHC.SourceText txt) _ = txt #endif -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Delta.hs0000644000000000000000000007617507346545000022614 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns #-} -- | This module converts 'GHC.ApiAnns' into 'Anns' by traversing a -- structure created by the "Annotate" module. -- -- == 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 -- -- In order to properly place syntax nodes and comments properly after -- refactoring them (in such a way that the indentation level changes), their -- position (encoded in the 'addEntryDelta' field) is not expressed as absolute -- but relative to their context. As further motivation, consider the simple -- let-into-where-block refactoring, from: -- -- @ -- foo = do -- let bar = do -- x -- -- comment -- y -- bar -- @ -- -- to -- -- @ -- foo = do -- bar -- where -- bar = do -- x -- -- comment -- y -- @ -- -- Notice how the column of @x@, @y@ and the comment change due to this -- refactoring but certain relative positions (e.g. the comment starting at the -- same column as @x@) remain unchanged. -- -- Now, what does "context" mean exactly? Here we reference the -- "indentation level" as used in the haskell report (see chapter 2.7: -- ): -- 'addEntryDelta' is mostly relative to the current (inner-most) indentation -- level. But in order to get better results, for the purpose of defining -- relative positions a the offside-rule is modified slightly: Normally it -- fires (only) at the first elements after where/let/do/of, introducing a new -- indentation level. In addition, the rule here fires also at the "@let@" -- keyword (when it is part of a "@let-in@" construct) and at the "@if@" keyword. -- -- The effect of this additional applications of the offside-rule is that any -- elements (more or less directly) following the "@let@" ("@if@"") -- keyword have a position relative to the "@let@" ("@if@") -- keyword position, even when the regular offside-rule does apply not yet/not -- anymore. This affects two concrete things: Comments directly following -- "@let@"/"@if@", and the respective follow-up keywords: "@in@" or -- "@then@"/"@else@". -- -- Due to this additional indentation level, it is possible to observe/obtain -- negative delta-positions; consider: -- -- @ -- foo = let x = 1 -- in x -- @ -- -- Here, the @in@ keyword has an 'annEntryDelta' of @DP (1, -4)@ as it appears -- one line below the previous elements and 4 columns /left/ relative to the -- start of the @let@ keyword. -- -- In general, the element that defines such an indentation level (i.e. the -- first element after a where/let/do/of) will have an 'annEntryDelta' relative -- to the previous inner-most indentation level; in other words: a new -- indentation level becomes relevant only after the construct introducing the -- element received its 'annEntryDelta' position. (Otherwise these elements -- always would have a zero horizontal position - relative to itself.) -- -- (This affects comments, too: A comment preceding the first element of a -- layout block will have a position relative to the outer block, not of the -- newly introduced layout block.) -- -- 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 syntactic element (ignoring comments). This is -- different to 'annEntryDelta' which does not ignore comments. -- -- -- module Language.Haskell.GHC.ExactPrint.Delta ( relativiseApiAnns , relativiseApiAnnsWithComments , relativiseApiAnnsWithOptions -- * Configuration , DeltaOptions(drRigidity) , deltaOptions , normalLayout ) where -- import Control.Exception import Control.Monad.RWS import Control.Monad.Trans.Free import Data.Data (Data) import Data.List (sort, nub, partition, sortBy) import Data.Ord import Language.Haskell.GHC.ExactPrint.Utils #if __GLASGOW_HASKELL__ <= 710 import Language.Haskell.GHC.ExactPrint.Lookup #endif import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Annotate import qualified GHC import qualified Data.Map as Map import qualified Data.Set as Set -- import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | Transform concrete annotations into relative annotations which are -- more useful when transforming an AST. #if __GLASGOW_HASKELL__ > 806 relativiseApiAnns :: (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => ast #else relativiseApiAnns :: Annotate ast => GHC.Located ast #endif -> GHC.ApiAnns -> Anns 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 :: #if __GLASGOW_HASKELL__ > 806 (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => [Comment] -> ast #else Annotate ast => [Comment] -> GHC.Located ast #endif -> GHC.ApiAnns -> Anns relativiseApiAnnsWithComments = relativiseApiAnnsWithOptions normalLayout relativiseApiAnnsWithOptions :: #if __GLASGOW_HASKELL__ > 806 (Data (GHC.SrcSpanLess ast), Annotate ast, GHC.HasSrcSpan ast) => DeltaOptions -> [Comment] -> ast #else Annotate ast => DeltaOptions -> [Comment] -> GHC.Located ast #endif -> GHC.ApiAnns -> Anns relativiseApiAnnsWithOptions opts cs modu ghcAnns = runDeltaWithComments opts cs (annotate modu) ghcAnns (ss2pos $ GHC.getLoc modu) -- --------------------------------------------------------------------- -- -- | Type used in the Delta Monad. type Delta a = RWS DeltaOptions DeltaWriter DeltaState a runDeltaWithComments :: DeltaOptions -> [Comment] -> Annotated () -> GHC.ApiAnns -> Pos -> Anns runDeltaWithComments opts cs action ga priorEnd = mkAnns . snd . (\next -> execRWS next opts (defaultDeltaState cs priorEnd ga)) . deltaInterpret $ action where mkAnns :: DeltaWriter -> Anns mkAnns = f . dwAnns f :: Monoid a => Endo a -> a f = ($ mempty) . appEndo -- --------------------------------------------------------------------- -- TODO: rename this, it is the R part of the RWS data DeltaOptions = DeltaOptions { -- | Current `SrcSpan, part of current AnnKey` curSrcSpan :: !GHC.SrcSpan -- | Constuctor of current AST element, part of current AnnKey , annConName :: !AnnConName -- | Whether to use rigid or normal layout rules , drRigidity :: !Rigidity -- | Current higher level context. e.g. whether a Match is part of a -- LambdaExpr or a FunBind , drContext :: !AstContextSet } 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 :: !Pos -- | Ordered list of comments still to be allocated , apComments :: ![Comment] -- | The original GHC Delta Annotations , apAnns :: !GHC.ApiAnns , apMarkLayout :: Bool , apLayoutStart :: LayoutStartCol } -- --------------------------------------------------------------------- deltaOptions :: Rigidity -> DeltaOptions deltaOptions ridigity = DeltaOptions { curSrcSpan = GHC.noSrcSpan , annConName = annGetConstr () , drRigidity = ridigity , drContext = defaultACS } normalLayout :: DeltaOptions normalLayout = deltaOptions NormalLayout defaultDeltaState :: [Comment] -> Pos -> GHC.ApiAnns -> DeltaState defaultDeltaState injectedComments priorEnd ga = DeltaState { priorEndPosition = priorEnd , apComments = cs ++ injectedComments , apAnns = ga , apLayoutStart = 1 , apMarkLayout = False } where cs :: [Comment] cs = extractComments ga -- Writer helpers tellFinalAnn :: (AnnKey, Annotation) -> Delta () tellFinalAnn (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] }) #if __GLASGOW_HASKELL__ >= 804 instance Semigroup DeltaWriter where (<>) = mappend #endif instance Monoid DeltaWriter where 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) ----------------------------------- -- Free Monad Interpretation code 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 (MarkPPOptional kwid _ next) = addDeltaAnnotation kwid >> next #if __GLASGOW_HASKELL__ >= 800 go (MarkInstead akwid kwid next) = addDeltaAnnotationInstead akwid kwid >> next #endif go (MarkOutside akwid kwid next) = addDeltaAnnotationsOutside akwid kwid >> next go (MarkInside akwid next) = addDeltaAnnotationsInside akwid >> next go (MarkMany akwid next) = addDeltaAnnotations akwid >> next go (MarkManyOptional akwid next) = addDeltaAnnotations akwid >> next go (MarkOffsetPrim akwid n _ next) = addDeltaAnnotationLs akwid n >> next go (MarkOffsetPrimOptional 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 r action next) = do rigidity <- asks drRigidity (if r <= rigidity then setLayoutFlag else id) (deltaInterpret action) next go (MarkAnnBeforeAnn ann1 ann2 next) = deltaMarkAnnBeforeAnn ann1 ann2 >> next go (MarkExternal ss akwid _ next) = addDeltaAnnotationExt ss akwid >> next go (StoreOriginalSrcSpan _ key next) = storeOriginalSrcSpanDelta key >>= next go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString s ss next) = storeString s ss >> next #endif go (AnnotationsToComments kws next) = annotationsToCommentsDelta kws >> next #if __GLASGOW_HASKELL__ <= 710 go (AnnotationsToCommentsBF _ kws next) = annotationsToCommentsDelta kws >> next go (FinalizeBF _ next) = next #endif go (WithSortKey kws next) = withSortKey kws >> next go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next go (SetContextLevel ctxt lvl action next) = setContextDelta ctxt lvl (deltaInterpret action) >> next go (UnsetContext _ctxt action next) = deltaInterpret action >> next go (IfInContext ctxt ifAction elseAction next) = ifInContextDelta ctxt ifAction elseAction >> next go (TellContext _ next) = 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 withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Delta () withSortKeyContexts ctxts kws = do tellSortKey (map fst order) withSortKeyContextsHelper deltaInterpret ctxts order where order = sortBy (comparing fst) kws 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 -- --------------------------------------------------------------------- setContextDelta :: Set.Set AstContext -> Int -> Delta () -> Delta () setContextDelta ctxt lvl = local (\s -> s { drContext = setAcsWithLevel ctxt lvl (drContext s) } ) ifInContextDelta :: Set.Set AstContext -> Annotated () -> Annotated () -> Delta () ifInContextDelta ctxt ifAction elseAction = do cur <- asks drContext let inContext = inAcs ctxt cur if inContext then deltaInterpret ifAction else deltaInterpret elseAction -- --------------------------------------------------------------------- storeOriginalSrcSpanDelta :: AnnKey -> Delta AnnKey storeOriginalSrcSpanDelta key = do tellCapturedSpan key return key #if __GLASGOW_HASKELL__ <= 710 storeString :: String -> GHC.SrcSpan -> Delta () storeString s ss = addAnnotationWorker (AnnString s) ss #endif -- --------------------------------------------------------------------- -- |In order to interleave annotations into the stream, we turn them into -- comments. annotationsToCommentsDelta :: [GHC.AnnKeywordId] -> Delta () annotationsToCommentsDelta kws = do ss <- getSrcSpan cs <- gets apComments let doOne :: GHC.AnnKeywordId -> Delta [Comment] doOne kw = do (spans,_) <- getAndRemoveAnnotationDelta ss kw return $ map (mkKWComment kw) spans -- TODO:AZ make sure these are sorted/merged properly when the invariant for -- allocateComments is re-established. newComments <- mapM doOne kws putUnallocatedComments (cs ++ concat newComments) -- --------------------------------------------------------------------- -- | This function exists to overcome a shortcoming in the GHC AST for 7.10.1 getSrcSpanForKw :: GHC.SrcSpan -> 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 #if __GLASGOW_HASKELL__ > 806 withSrcSpanDelta :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b withSrcSpanDelta (GHC.dL->GHC.L l a) = #else withSrcSpanDelta :: Data a => GHC.Located a -> Delta b -> Delta b withSrcSpanDelta (GHC.L l a) = #endif local (\s -> s { curSrcSpan = l , annConName = annGetConstr a , drContext = pushAcs (drContext s) `debug` ("withSrcSpanDelta: (l,annConName,drContext)=" ++ showGhc (l,annGetConstr a, pushAcs (drContext s))) }) getUnallocatedComments :: Delta [Comment] getUnallocatedComments = gets apComments putUnallocatedComments :: [Comment] -> Delta () putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) -- --------------------------------------------------------------------- adjustDeltaForOffsetM :: DeltaPos -> Delta DeltaPos adjustDeltaForOffsetM dp = do 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) -- --------------------------------------------------------------------- getPriorEnd :: Delta Pos getPriorEnd = gets priorEndPosition 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})) -- ------------------------------------- peekAnnotationDelta :: GHC.AnnKeywordId -> Delta [GHC.SrcSpan] peekAnnotationDelta an = do ga <- gets apAnns ss <- getSrcSpan #if __GLASGOW_HASKELL__ <= 710 return $ GHC.getAnnotation ga ss an #else let unicodeAnns = case unicodeEquivalent an of [] -> [] [kw] -> GHC.getAnnotation ga ss kw (kw:_) -> GHC.getAnnotation ga ss kw -- Keep exhaustiveness checker happy return $ unicodeAnns ++ GHC.getAnnotation ga ss an #endif getAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) getAnnotationDelta an = do ss <- getSrcSpan getAndRemoveAnnotationDelta ss an getAndRemoveAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) getAndRemoveAnnotationDelta sp an = do ga <- gets apAnns #if __GLASGOW_HASKELL__ <= 710 let (r,ga') = GHC.getAndRemoveAnnotation ga sp an kw = an #else let (r,ga',kw) = case GHC.getAndRemoveAnnotation ga sp an of ([],_) -> (ss,g,k) where k = GHC.unicodeAnn an (ss,g) = GHC.getAndRemoveAnnotation ga sp k (ss,g) -> (ss,g,an) #endif modify (\s -> s { apAnns = ga' }) return (r,kw) getOneAnnotationDelta :: GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) getOneAnnotationDelta an = do ss <- getSrcSpan getAndRemoveOneAnnotationDelta ss an getAndRemoveOneAnnotationDelta :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta ([GHC.SrcSpan],GHC.AnnKeywordId) getAndRemoveOneAnnotationDelta sp an = do (anns,cs) <- gets apAnns #if __GLASGOW_HASKELL__ <= 710 let (r,ga',kw) = case Map.lookup (sp,an) anns of Nothing -> ([],(anns,cs),an) Just [] -> ([], (Map.delete (sp,an) anns,cs),an) Just (s:ss) -> ([s],(Map.insert (sp,an) ss anns,cs),an) #else let getKw kw = case Map.lookup (sp,kw) anns of Nothing -> ([],(anns,cs),kw) Just [] -> ([], (Map.delete (sp,kw) anns,cs),kw) Just (s:ss) -> ([s],(Map.insert (sp,kw) ss anns,cs),kw) let (r,ga',kw) = case getKw an of ([],_,_) -> getKw (GHC.unicodeAnn an) v -> v #endif modify (\s -> s { apAnns = ga' }) return (r,kw) -- --------------------------------------------------------------------- -- |Add some annotation to the currently active SrcSpan addAnnotationsDelta :: Annotation -> Delta () addAnnotationsDelta ann = do l <- ask tellFinalAnn (getAnnKey l,ann) getAnnKey :: DeltaOptions -> AnnKey getAnnKey DeltaOptions {curSrcSpan, annConName} = AnnKey curSrcSpan annConName -- ------------------------------------- addAnnDeltaPos :: KeywordId -> DeltaPos -> Delta () addAnnDeltaPos kw dp = tellKd (kw, dp) -- ------------------------------------- -- | Enter a new AST element. Maintain SrcSpan stack #if __GLASGOW_HASKELL__ > 806 withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Delta b -> Delta b withAST lss@(GHC.dL->GHC.L ss _) action = do #else withAST :: Data a => GHC.Located a -> Delta b -> Delta b withAST lss@(GHC.L ss _) action = do #endif -- Calculate offset required to get to the start of the SrcSPan off <- gets apLayoutStart (resetAnns . withSrcSpanDelta lss) (do let maskWriter s = s { annKds = [] , 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 -- 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 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 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 = -- 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 = 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 p' <- adjustDeltaForOffsetM p commentAllocation (priorComment (ss2pos pa)) (mapM_ (uncurry addDeltaComment)) #if __GLASGOW_HASKELL__ <= 710 addAnnDeltaPos (checkUnicode ann pa) p' #else addAnnDeltaPos ann p' #endif setPriorEndAST pa `debug` ("addAnnotationWorker:(ss,ss,pe,pa,p,p',ann)=" ++ show (showGhc ss,showGhc ss,pe,showGhc pa,p,p',ann)) #if __GLASGOW_HASKELL__ <= 710 checkUnicode :: KeywordId -> GHC.SrcSpan -> KeywordId checkUnicode gkw@(G kw) ss = if kw `Set.member` unicodeSyntax then let s = keywordToString gkw in if length s /= spanLength ss then AnnUnicode kw else gkw else gkw where unicodeSyntax = Set.fromList [ GHC.AnnDcolon , GHC.AnnDarrow , GHC.AnnForall , GHC.AnnRarrow , GHC.AnnLarrow , GHC.Annlarrowtail , GHC.Annrarrowtail , GHC.AnnLarrowtail , GHC.AnnRarrowtail] checkUnicode kwid _ = kwid #else unicodeEquivalent :: GHC.AnnKeywordId -> [GHC.AnnKeywordId] unicodeEquivalent kw = case Map.lookup kw unicodeSyntax of Nothing -> [] Just kwu -> [kwu] where unicodeSyntax = Map.fromList [ (GHC.AnnDcolon, GHC.AnnDcolonU) , (GHC.AnnDarrow, GHC.AnnDarrowU) , (GHC.AnnForall, GHC.AnnForallU) , (GHC.AnnRarrow, GHC.AnnRarrowU) , (GHC.AnnLarrow, GHC.AnnLarrowU) , (GHC.Annlarrowtail, GHC.AnnlarrowtailU) , (GHC.Annrarrowtail, GHC.AnnrarrowtailU) , (GHC.AnnLarrowtail, GHC.AnnLarrowtailU) , (GHC.AnnRarrowtail, GHC.AnnRarrowtailU) #if __GLASGOW_HASKELL__ > 801 , (GHC.AnnCloseB, GHC.AnnCloseBU) , (GHC.AnnCloseQ, GHC.AnnCloseQU) , (GHC.AnnOpenB, GHC.AnnOpenBU) , (GHC.AnnOpenEQ, GHC.AnnOpenEQU) #endif ] #endif -- --------------------------------------------------------------------- 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 = ss2delta pe pa p' <- adjustDeltaForOffsetM p setPriorEnd (ss2posEnd pa) return (c, p') addDeltaComment :: Comment -> DeltaPos -> Delta () addDeltaComment d p = do addAnnDeltaPos (AnnComment d) p -- --------------------------------------------------------------------- -- |If the first annotation has a smaller SrcSpan than the second, then mark it. deltaMarkAnnBeforeAnn :: GHC.AnnKeywordId -> GHC.AnnKeywordId -> Delta () deltaMarkAnnBeforeAnn annBefore annAfter = do ss <- getSrcSpan mb <- peekAnnotationDelta annBefore ma <- peekAnnotationDelta annAfter let before = sort $ filter (\s -> GHC.isSubspanOf s ss) mb after = sort $ filter (\s -> GHC.isSubspanOf s ss) ma case (before,after) of (b:_, a:_) -> when (b < a) $ addDeltaAnnotation annBefore _ -> return () -- --------------------------------------------------------------------- -- | Look up and add a Delta annotation at the current position, and -- advance the position to the end of the annotation addDeltaAnnotation :: GHC.AnnKeywordId -> Delta () addDeltaAnnotation ann' = do ss <- getSrcSpan (ma,ann) <- getOneAnnotationDelta ann' case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier [] -> 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 ss <- getSrcSpan ma <- peekAnnotationDelta ann let ma' = filter (\s -> GHC.isSubspanOf s ss) ma case drop off ma' of [] -> return () `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 -- position, and advance the position to the end of the annotations addDeltaAnnotations :: GHC.AnnKeywordId -> Delta () addDeltaAnnotations ann = do (ma,kw) <- getAnnotationDelta ann let do_one ap' = addAnnotationWorker (G kw) ap' `debug` ("addDeltaAnnotations:do_one:(ap',ann)=" ++ showGhc (ap',ann)) mapM_ do_one (sort ma) -- | Look up and add possibly multiple Delta annotations enclosed by -- the current SrcSpan at the current position, and advance the -- position to the end of the annotations addDeltaAnnotationsInside :: GHC.AnnKeywordId -> Delta () addDeltaAnnotationsInside ann = do ss <- getSrcSpan ma <- 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 mapM_ do_one filtered -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 800 addDeltaAnnotationInstead :: GHC.AnnKeywordId -> KeywordId -> Delta () addDeltaAnnotationInstead ann' kw = do ss <- getSrcSpan (ma,ann) <- getOneAnnotationDelta ann' case nub ma of -- ++AZ++ TODO: get rid of duplicates earlier [] -> return () `debug` ("addDeltaAnnotation empty ma for:" ++ show (ss,ann)) [pa] -> addAnnotationWorker kw pa (pa:_) -> addAnnotationWorker kw pa `warn` ("addDeltaAnnotationInstead:(ss,ann,kw,ma)=" ++ showGhc (ss,ann,kw,ma)) #endif -- --------------------------------------------------------------------- -- | Look up and add possibly multiple Delta annotations not enclosed by -- the current SrcSpan at the current position, and advance the -- position to the end of the annotations -- The first argument (gann) is the one to look up in the GHC annotations, the -- second is the one to apply in the ghc-exactprint ones. These are different -- for GHC.AnnSemi mapping to AnnSemiSep, to ensure that it reflects the ';' -- outside the current span. addDeltaAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Delta () addDeltaAnnotationsOutside gann ann = do ss <- getSrcSpan (ma,kw) <- getAndRemoveAnnotationDelta ss gann let do_one ap' = if ann == AnnSemiSep then addAnnotationWorker ann ap' else addAnnotationWorker (G kw) ap' mapM_ do_one (sort $ filter (\s -> not (GHC.isSubspanOf s ss)) ma) -- | Add a Delta annotation at the current position, and advance the -- position to the end of the annotation addDeltaAnnotationExt :: GHC.SrcSpan -> GHC.AnnKeywordId -> Delta () addDeltaAnnotationExt s ann = addAnnotationWorker (G ann) s addEofAnnotation :: Delta () addEofAnnotation = do pe <- getPriorEnd (ma,_kw) <- withSrcSpanDelta (GHC.noLoc () :: GHC.GenLocated GHC.SrcSpan ()) (getAnnotationDelta GHC.AnnEofPos) case ma of [] -> return () (pa:pss) -> do commentAllocation (const True) (mapM_ (uncurry addDeltaComment)) let DP (r,c) = ss2delta pe pa addAnnDeltaPos (G GHC.AnnEofPos) (DP (r, c - 1)) setPriorEndAST pa `warn` ("Trailing annotations after Eof: " ++ showGhc pss) -- --------------------------------------------------------------------- countAnnsDelta :: GHC.AnnKeywordId -> Delta Int countAnnsDelta ann = do ma <- peekAnnotationDelta ann return (length ma) ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/GhcInterim.hs0000644000000000000000000000215507346545000023577 0ustar0000000000000000{-# LANGUAGE CPP #-} -- 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 -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 800 #else -- 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) #if __GLASGOW_HASKELL__ < 801 commentToAnnotation (L l (ITdocOptionsOld s)) = L l (AnnDocOptionsOld s) #endif 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 #endif ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Lookup.hs0000644000000000000000000001457607346545000023031 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.GHC.ExactPrint.Lookup ( keywordToString #if __GLASGOW_HASKELL__ <= 710 , unicodeString #endif ) where import Language.Haskell.GHC.ExactPrint.Types import qualified GHC (AnnKeywordId(..)) #if __GLASGOW_HASKELL__ <= 710 import Data.Maybe #endif -- | Maps `AnnKeywordId` to the corresponding String representation. -- There is no specific mapping for the following constructors. -- `AnnOpen`, `AnnClose`, `AnnVal`, `AnnPackageName`, `AnnHeader`, `AnnFunId`, -- `AnnInfix` 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. AnnComment _ -> mkErr kw AnnString _ -> mkErr kw #if __GLASGOW_HASKELL__ <= 710 AnnUnicode kw' -> keywordToString (G kw') #endif AnnSemiSep -> ";" #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnAnyclass) -> "anyclass" #endif (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" #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnCloseB ) -> "|)" (G GHC.AnnCloseBU ) -> "⦈" #endif (G GHC.AnnCloseC ) -> "}" (G GHC.AnnCloseP ) -> ")" #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnCloseQ ) -> "|]" (G GHC.AnnCloseQU ) -> "⟧" #endif (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" #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnOpenB ) -> "(|" (G GHC.AnnOpenBU ) -> "⦇" #endif (G GHC.AnnOpenC ) -> "{" #if __GLASGOW_HASKELL__ > 710 (G GHC.AnnOpenE ) -> "[e|" #endif #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnOpenEQ ) -> "[|" (G GHC.AnnOpenEQU ) -> "⟦" #endif (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 ) -> ";" #if __GLASGOW_HASKELL__ >= 801 (G GHC.AnnSignature) -> "signature" (G GHC.AnnStock ) -> "stock" #endif (G GHC.AnnStatic ) -> "static" (G GHC.AnnThen ) -> "then" (G GHC.AnnTilde ) -> "~" #if __GLASGOW_HASKELL__ <= 804 (G GHC.AnnTildehsh ) -> "~#" #endif (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 ) -> "" #if __GLASGOW_HASKELL__ > 710 (G GHC.AnnDarrowU) -> "⇒" (G GHC.AnnDcolonU) -> "∷" (G GHC.AnnForallU) -> "∀" (G GHC.AnnLarrowU) -> "←" (G GHC.AnnLarrowtailU) -> "⤛" (G GHC.AnnRarrowU) -> "→" (G GHC.AnnRarrowtailU) -> "⤜" (G GHC.AnnlarrowtailU) -> "⤙" (G GHC.AnnrarrowtailU) -> "⤚" #endif #if __GLASGOW_HASKELL__ >= 800 AnnTypeApp -> "@" #endif #if __GLASGOW_HASKELL__ > 804 (G GHC.AnnVia) -> "via" #endif #if __GLASGOW_HASKELL__ <= 710 -- | 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 = -- AZ:TODO:make this a Data.Map, doing linear scan each time [ (G GHC.AnnDarrow, "⇒") , (G GHC.AnnDcolon, "∷") , (G GHC.AnnForall, "∀") , (G GHC.AnnLarrow, "←") , (G GHC.AnnLarrowtail, "⤛") , (G GHC.AnnRarrow, "→") , (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) -} #endif ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Parsers.hs0000644000000000000000000003015407346545000023165 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# 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 , parseModuleFromString , parseModuleWithOptions , parseModuleWithCpp -- * Basic Parsers , parseExpr , parseImport , parseType , parseDecl , parsePattern , parseStmt , parseWith -- * Internal , ghcWrapper , initDynFlags , initDynFlagsPure , parseModuleFromStringInternal , parseModuleApiAnnsWithCpp , parseModuleApiAnnsWithCppInternal , postParseTransform ) 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 #if __GLASGOW_HASKELL__ > 806 import Data.Data (Data) #endif 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 #else import qualified GHC.LanguageExtensions as LangExt #endif import qualified Data.Map as Map {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | Wrapper function which returns Annotations along with the parsed -- element. #if __GLASGOW_HASKELL__ > 806 parseWith :: (Data (GHC.SrcSpanLess w), Annotate w, GHC.HasSrcSpan w) => GHC.DynFlags -> FilePath -> GHC.P w -> String -> Either (GHC.SrcSpan, String) (Anns, w) #else parseWith :: Annotate w => GHC.DynFlags -> FilePath -> GHC.P (GHC.Located w) -> String -> Either (GHC.SrcSpan, String) (Anns, GHC.Located w) #endif parseWith dflags fileName parser s = case runParser parser dflags fileName s of #if __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) #else GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) #endif 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 = ghcWrapper $ do dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags dflags return (action dflags) -- --------------------------------------------------------------------- parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GhcPs)) parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- type Parser a = GHC.DynFlags -> FilePath -> String -> Either (GHC.SrcSpan, String) (Anns, a) parseExpr :: Parser (GHC.LHsExpr GhcPs) parseExpr df fp = parseWith df fp GHC.parseExpression parseImport :: Parser (GHC.LImportDecl GhcPs) parseImport df fp = parseWith df fp GHC.parseImport parseType :: Parser (GHC.LHsType GhcPs) parseType df fp = parseWith df fp GHC.parseType -- safe, see D1007 parseDecl :: Parser (GHC.LHsDecl GhcPs) #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 GhcPs) parseStmt df fp = parseWith df fp GHC.parseStatement parsePattern :: Parser (GHC.LPat GhcPs) 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 'GHC.Located' ('GHC.HsModule' 'GhcPs') parseModule :: FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModule = parseModuleWithCpp defaultCppOptions normalLayout -- | This entry point will work out which language extensions are -- required but will _not_ perform CPP processing. -- In contrast to `parseModoule` the input source is read from the provided -- string; the `FilePath` parameter solely exists to provide a name -- in source location annotations. parseModuleFromString :: FilePath -> String -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleFromString fp s = ghcWrapper $ do dflags <- initDynFlagsPure fp s return $ parseModuleFromStringInternal dflags fp s -- | Internal part of 'parseModuleFromString'. parseModuleFromStringInternal :: GHC.DynFlags -> FilePath -> String -> Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource) parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of #if __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left (ss, GHC.showSDoc dflags m) #else GHC.PFailed ss m -> Left (ss, GHC.showSDoc dflags m) #endif GHC.POk x pmod -> Right $ (mkApiAnns x, lp, dflags, pmod) in postParseTransform res normalLayout parseModuleWithOptions :: DeltaOptions -> FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleWithOptions opts fp = parseModuleWithCpp defaultCppOptions opts fp -- | Parse a module with specific instructions for the C pre-processor. parseModuleWithCpp :: CppOptions -> DeltaOptions -> FilePath -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseModuleWithCpp cpp opts fp = do res <- parseModuleApiAnnsWithCpp cpp fp return $ postParseTransform res opts -- --------------------------------------------------------------------- -- | Low level function which is used in the internal tests. -- It is advised to use 'parseModule' or 'parseModuleWithCpp' instead of -- this function. parseModuleApiAnnsWithCpp :: CppOptions -> FilePath -> IO ( Either (GHC.SrcSpan, String) (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCpp cppOptions file = ghcWrapper $ do dflags <- initDynFlags file parseModuleApiAnnsWithCppInternal cppOptions dflags file -- | Internal function. Default runner of GHC.Ghc action in IO. ghcWrapper :: GHC.Ghc a -> IO a ghcWrapper = GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut . GHC.runGhc (Just libdir) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. parseModuleApiAnnsWithCppInternal :: GHC.GhcMonad m => CppOptions -> GHC.DynFlags -> FilePath -> m ( Either (GHC.SrcSpan, String) (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) ) parseModuleApiAnnsWithCppInternal cppOptions dflags file = do #if __GLASGOW_HASKELL__ <= 710 let useCpp = GHC.xopt GHC.Opt_Cpp dflags #else let useCpp = GHC.xopt LangExt.Cpp dflags #endif (fileContents, injectedComments, dflags') <- if useCpp then do (contents,dflags1) <- getPreprocessedSrcDirect cppOptions file cppComments <- getCppTokensAsComments cppOptions file return (contents,cppComments,dflags1) else do txt <- GHC.liftIO $ readFileGhc file let (contents1,lp) = stripLinePragmas txt return (contents1,lp,dflags) return $ case parseFile dflags' file fileContents of #if __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ ss m -> Left $ (ss, (GHC.showSDoc dflags m)) #else GHC.PFailed ss m -> Left $ (ss, (GHC.showSDoc dflags m)) #endif GHC.POk (mkApiAnns -> apianns) pmod -> Right $ (apianns, injectedComments, dflags', pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. postParseTransform :: Either a (GHC.ApiAnns, [Comment], GHC.DynFlags, GHC.ParsedSource) -> DeltaOptions -> Either a (Anns, GHC.ParsedSource) postParseTransform parseRes opts = either Left mkAnns parseRes where mkAnns (apianns, cs, _, m) = Right (relativiseApiAnnsWithOptions opts cs m apianns, m) -- | Internal function. Initializes DynFlags value for parsing. -- -- Passes "-hide-all-packages" to the GHC API to prevent parsing of -- package environment files. However this only works if there is no -- invocation of `setSessionDynFlags` before calling `initDynFlags`. -- See ghc tickets #15513, #15541. initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags initDynFlags file = do dflags0 <- GHC.getSessionDynFlags src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 return dflags3 -- | Requires GhcMonad constraint because there is -- no pure variant of `parseDynamicFilePragma`. Yet, in constrast to -- `initDynFlags`, it does not (try to) read the file at filepath, but -- solely depends on the module source in the input string. -- -- Passes "-hide-all-packages" to the GHC API to prevent parsing of -- package environment files. However this only works if there is no -- invocation of `setSessionDynFlags` before calling `initDynFlagsPure`. -- See ghc tickets #15513, #15541. initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags initDynFlagsPure fp s = do -- I was told we could get away with using the unsafeGlobalDynFlags. -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream -- Prevent parsing of .ghc.environment.* "package environment files" (dflags3, _, _) <- GHC.parseDynamicFlagsCmdLine dflags2 [GHC.noLoc "-hide-all-packages"] _ <- GHC.setSessionDynFlags dflags3 return dflags3 -- --------------------------------------------------------------------- mkApiAnns :: GHC.PState -> GHC.ApiAnns mkApiAnns pstate = ( Map.fromListWith (++) . GHC.annotations $ pstate , Map.fromList ((GHC.noSrcSpan, GHC.comment_q pstate) : GHC.annotations_comments pstate)) ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs0000644000000000000000000002750207346545000023676 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -- | This module provides support for CPP, interpreter directives and line -- pragmas. module Language.Haskell.GHC.ExactPrint.Preprocess ( stripLinePragmas , getCppTokensAsComments , getPreprocessedSrcDirect , readFileGhc , CppOptions(..) , defaultCppOptions ) where import qualified Bag as GHC import qualified DriverPhases 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 #if __GLASGOW_HASKELL__ <= 800 import Language.Haskell.GHC.ExactPrint.GhcInterim (commentToAnnotation) #endif import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified Data.Set as Set -- import Debug.Trace -- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- 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 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 $ filter goodComment #if __GLASGOW_HASKELL__ > 800 $ map (tokComment . GHC.commentToAnnotation . fst) cppCommentToks #else $ map (tokComment . commentToAnnotation . fst) cppCommentToks #endif #if __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ sspan err -> parseError flags2 sspan err #else GHC.PFailed sspan err -> parseError flags2 sspan err #endif goodComment :: Comment -> Bool goodComment (Comment "" _ _) = False goodComment _ = True -- --------------------------------------------------------------------- -- | 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 #if __GLASGOW_HASKELL__ >= 804 GHC.PFailed _ sspan err -> parseError flags sspan err #else GHC.PFailed sspan err -> parseError flags sspan err #endif -- --------------------------------------------------------------------- -- | 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, GHC.DynFlags) getPreprocessedSrcDirect cppOptions src = (\(s,_,d) -> (s,d)) <$> 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.hsc_dflags hsc_env new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } #if __GLASGOW_HASKELL__ >= 808 -- (dflags', hspp_fn) <- r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of Left err -> error $ showErrorMessages err Right (dflags', hspp_fn) -> do buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') #else (dflags', hspp_fn) <- GHC.liftIO $ GHC.preprocess new_env (src_fn, Just (GHC.Cpp GHC.HsSrcFile)) buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') #endif #if __GLASGOW_HASKELL__ >= 808 showErrorMessages :: GHC.ErrorMessages -> String showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs #endif 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 <- readFileGhc 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) -- --------------------------------------------------------------------- readFileGhc :: FilePath -> IO String readFileGhc file = do buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file return (GHC.lexemeToString buf len) -- --------------------------------------------------------------------- -- 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 ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Pretty.hs0000644000000000000000000005674307346545000023051 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.GHC.ExactPrint.Pretty -- -- This module adds default annotations to an AST fragment that does not have -- them, to be able to exactprint it in a way that preserves the orginal AST -- when re-parsed. -- ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Pretty ( addAnnotationsForPretty ) where import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Annotate import Control.Monad.RWS import Control.Monad.Trans.Free import Data.Generics import Data.List import Data.Ord (comparing) #if __GLASGOW_HASKELL__ <= 710 import qualified BooleanFormula as GHC import qualified Outputable as GHC #endif import qualified GHC import qualified Data.Map as Map import qualified Data.Set as Set {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- |Add any missing annotations so that the full AST element will exactprint -- properly when done. addAnnotationsForPretty :: (Annotate a) => [Comment] -> GHC.Located a -> Anns -> Anns addAnnotationsForPretty cs ast ans = runPrettyWithComments opts cs (annotate ast) ans (0,0) where opts = prettyOptions NormalLayout -- --------------------------------------------------------------------- -- -- | Type used in the Pretty Monad. type Pretty a = RWS PrettyOptions PrettyWriter PrettyState a runPrettyWithComments :: PrettyOptions -> [Comment] -> Annotated () -> Anns -> Pos -> Anns runPrettyWithComments opts cs action ans priorEnd = mkAnns . snd . (\next -> execRWS next opts (defaultPrettyState cs priorEnd ans)) . prettyInterpret $ action where mkAnns :: PrettyWriter -> Anns mkAnns = f . dwAnns f :: Monoid a => Endo a -> a f = ($ mempty) . appEndo -- --------------------------------------------------------------------- -- TODO: rename this, it is the R part of the RWS data PrettyOptions = PrettyOptions { -- | Current `SrcSpan, part of current AnnKey` curSrcSpan :: !GHC.SrcSpan -- | Constuctor of current AST element, part of current AnnKey , annConName :: !AnnConName -- | Whether to use rigid or normal layout rules , drRigidity :: !Rigidity -- | Current higher level context. e.g. whether a Match is part of a -- LambdaExpr or a FunBind , prContext :: !AstContextSet } deriving Show data PrettyWriter = PrettyWriter { -- | 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) , prLayoutContext :: !(ACS' AstContext) } data PrettyState = PrettyState { -- | Position reached when processing the last element priorEndPosition :: !Pos -- | Ordered list of comments still to be allocated , apComments :: ![Comment] , apMarkLayout :: Bool , apLayoutStart :: LayoutStartCol , apNoPrecedingSpace :: Bool } #if __GLASGOW_HASKELL__ >= 804 instance Semigroup PrettyWriter where (<>) = mappend #endif instance Monoid PrettyWriter where mempty = PrettyWriter mempty mempty mempty mempty mempty (PrettyWriter a b e g i) `mappend` (PrettyWriter c d f h j) = PrettyWriter (a <> c) (b <> d) (e <> f) (g <> h) (i <> j) -- --------------------------------------------------------------------- prettyOptions :: Rigidity -> PrettyOptions prettyOptions ridigity = PrettyOptions { curSrcSpan = GHC.noSrcSpan , annConName = annGetConstr () , drRigidity = ridigity , prContext = defaultACS } defaultPrettyState :: [Comment] -> Pos -> Anns -> PrettyState defaultPrettyState injectedComments priorEnd _ans = PrettyState { priorEndPosition = priorEnd , apComments = cs ++ injectedComments , apLayoutStart = 1 , apMarkLayout = False , apNoPrecedingSpace = False } where cs :: [Comment] cs = [] -- --------------------------------------------------------------------- -- Free Monad Interpretation code prettyInterpret :: Annotated a -> Pretty a prettyInterpret = iterTM go where go :: AnnotationF (Pretty a) -> Pretty a go (MarkPrim kwid _ next) = addPrettyAnnotation (G kwid) >> next go (MarkPPOptional _kwid _ next) = next go (MarkEOF next) = addEofAnnotation >> next go (MarkExternal _ss akwid _ next) = addPrettyAnnotation (G akwid) >> next #if __GLASGOW_HASKELL__ >= 800 go (MarkInstead akwid kwid next) = addPrettyAnnotationsInstead akwid kwid >> next #endif go (MarkOutside akwid kwid next) = addPrettyAnnotationsOutside akwid kwid >> next -- go (MarkOutside akwid kwid next) = addPrettyAnnotation kwid >> next go (MarkInside akwid next) = addPrettyAnnotationsInside akwid >> next go (MarkMany akwid next) = addPrettyAnnotation (G akwid) >> next go (MarkManyOptional _akwid next) = next go (MarkOffsetPrim akwid n _ next) = addPrettyAnnotationLs akwid n >> next go (MarkOffsetPrimOptional _akwid _n _ next) = next go (WithAST lss prog next) = withAST lss (prettyInterpret prog) >> next go (CountAnns kwid next) = countAnnsPretty kwid >>= next go (WithSortKey kws next) = withSortKey kws >> next go (WithSortKeyContexts ctx kws next) = withSortKeyContexts ctx kws >> next go (SetLayoutFlag r action next) = do rigidity <- asks drRigidity (if r <= rigidity then setLayoutFlag else id) (prettyInterpret action) next go (StoreOriginalSrcSpan l key next) = storeOriginalSrcSpanPretty l key >>= next go (MarkAnnBeforeAnn _ann1 _ann2 next) = next go (GetSrcSpanForKw ss kw next) = getSrcSpanForKw ss kw >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString s ss next) = storeString s ss >> next #endif go (AnnotationsToComments kws next) = annotationsToCommentsPretty kws >> next #if __GLASGOW_HASKELL__ <= 710 go (AnnotationsToCommentsBF bf kws next) = annotationsToCommentsBFPretty bf kws >> next go (FinalizeBF l next) = finalizeBFPretty l >> next #endif go (SetContextLevel ctxt lvl action next) = setContextPretty ctxt lvl (prettyInterpret action) >> next go (UnsetContext ctxt action next) = unsetContextPretty ctxt (prettyInterpret action) >> next go (IfInContext ctxt ia ea next) = ifInContextPretty ctxt ia ea >> next go (TellContext c next) = tellContext c >> next -- --------------------------------------------------------------------- addEofAnnotation :: Pretty () addEofAnnotation = do tellKd (G GHC.AnnEofPos, DP (1,0)) -- --------------------------------------------------------------------- addPrettyAnnotation :: KeywordId -> Pretty () addPrettyAnnotation ann = do noPrec <- gets apNoPrecedingSpace ctx <- asks prContext _ <- debugP ("Pretty.addPrettyAnnotation:=" ++ showGhc (ann,noPrec,ctx)) $ asks prContext let dp = case ann of (G GHC.AnnAs) -> tellKd (ann,DP (0,1)) (G GHC.AnnAt) -> tellKd (ann,DP (0,0)) #if __GLASGOW_HASKELL__ >= 806 (G GHC.AnnAnyclass) -> tellKd (ann,DP (0,1)) #endif (G GHC.AnnBackquote) -> tellKd (ann,DP (0,1)) (G GHC.AnnBang) -> tellKd (ann,DP (0,1)) (G GHC.AnnBy) -> tellKd (ann,DP (0,1)) (G GHC.AnnCase ) -> tellKd (ann,DP (0,1)) (G GHC.AnnClass) -> tellKd (ann,DP (0,1)) (G GHC.AnnClose) -> tellKd (ann,DP (0,1)) (G GHC.AnnCloseC) -> tellKd (ann,DP (0,0)) #if __GLASGOW_HASKELL__ >= 802 (G GHC.AnnCloseQ) -> tellKd (ann,DP (0,1)) #endif (G GHC.AnnDcolon) -> tellKd (ann,DP (0,1)) (G GHC.AnnDeriving) -> tellKd (ann,DP (0,1)) (G GHC.AnnDo) -> tellKd (ann,DP (0,1)) (G GHC.AnnDotdot) -> tellKd (ann,DP (0,1)) (G GHC.AnnElse) -> tellKd (ann,DP (1,2)) (G GHC.AnnEqual) -> tellKd (ann,DP (0,1)) (G GHC.AnnExport) -> tellKd (ann,DP (0,1)) (G GHC.AnnFamily) -> tellKd (ann,DP (0,1)) (G GHC.AnnForall) -> tellKd (ann,DP (0,1)) (G GHC.AnnGroup) -> tellKd (ann,DP (0,1)) (G GHC.AnnHiding) -> tellKd (ann,DP (0,1)) (G GHC.AnnIf) -> tellKd (ann,DP (0,1)) (G GHC.AnnImport) -> tellKd (ann,DP (0,1)) (G GHC.AnnIn) -> tellKd (ann,DP (1,0)) (G GHC.AnnInstance) -> tellKd (ann,DP (0,1)) (G GHC.AnnLam) -> tellKd (ann,DP (0,1)) (G GHC.AnnLet) -> tellKd (ann,DP (0,1)) (G GHC.AnnMinus) -> tellKd (ann,DP (0,1)) -- need to separate from preceding operator (G GHC.AnnModule) -> tellKd (ann,DP (0,1)) (G GHC.AnnNewtype) -> tellKd (ann,DP (0,1)) (G GHC.AnnOf) -> tellKd (ann,DP (0,1)) (G GHC.AnnOpenC) -> tellKd (ann,DP (0,0)) (G GHC.AnnOpenPE) -> tellKd (ann,DP (0,1)) (G GHC.AnnOpenPTE) -> tellKd (ann,DP (0,1)) (G GHC.AnnQualified) -> tellKd (ann,DP (0,1)) (G GHC.AnnRarrow) -> tellKd (ann,DP (0,1)) (G GHC.AnnRole) -> tellKd (ann,DP (0,1)) (G GHC.AnnSafe) -> tellKd (ann,DP (0,1)) #if __GLASGOW_HASKELL__ >= 806 (G GHC.AnnStock) -> tellKd (ann,DP (0,1)) #endif (G GHC.AnnSimpleQuote) -> tellKd (ann,DP (0,1)) (G GHC.AnnThIdSplice) -> tellKd (ann,DP (0,1)) (G GHC.AnnThIdTySplice) -> tellKd (ann,DP (0,1)) (G GHC.AnnThTyQuote) -> tellKd (ann,DP (0,1)) (G GHC.AnnThen) -> tellKd (ann,DP (1,2)) (G GHC.AnnTilde) -> tellKd (ann,DP (0,1)) (G GHC.AnnType) -> tellKd (ann,DP (0,1)) (G GHC.AnnUsing) -> tellKd (ann,DP (0,1)) (G GHC.AnnVal) -> tellKd (ann,DP (0,1)) (G GHC.AnnValStr) -> tellKd (ann,DP (0,1)) (G GHC.AnnVbar) -> tellKd (ann,DP (0,1)) #if __GLASGOW_HASKELL__ >= 806 (G GHC.AnnVia) -> tellKd (ann,DP (0,1)) #endif (G GHC.AnnWhere) -> tellKd (ann,DP (1,2)) #if __GLASGOW_HASKELL__ >= 800 AnnTypeApp -> tellKd (ann,DP (0,1)) #endif _ -> tellKd (ann,DP (0,0)) fromNoPrecedingSpace (tellKd (ann,DP (0,0))) dp -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 800 addPrettyAnnotationsInstead :: GHC.AnnKeywordId -> KeywordId -> Pretty () addPrettyAnnotationsInstead _akwid AnnSemiSep = return () addPrettyAnnotationsInstead _akwid kwid = addPrettyAnnotation kwid #endif -- --------------------------------------------------------------------- addPrettyAnnotationsOutside :: GHC.AnnKeywordId -> KeywordId -> Pretty () addPrettyAnnotationsOutside _akwid AnnSemiSep = return () addPrettyAnnotationsOutside _akwid kwid = addPrettyAnnotation kwid -- --------------------------------------------------------------------- addPrettyAnnotationsInside :: GHC.AnnKeywordId -> Pretty () addPrettyAnnotationsInside _ann = return () -- --------------------------------------------------------------------- addPrettyAnnotationLs :: GHC.AnnKeywordId -> Int -> Pretty () addPrettyAnnotationLs ann _off = addPrettyAnnotation (G ann) -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 getUnallocatedComments :: Pretty [Comment] getUnallocatedComments = gets apComments putUnallocatedComments :: [Comment] -> Pretty () putUnallocatedComments cs = modify (\s -> s { apComments = cs } ) #endif -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ > 806 withSrcSpanPretty :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b withSrcSpanPretty (GHC.dL->GHC.L l a) action = do #else withSrcSpanPretty :: Data a => GHC.Located a -> Pretty b -> Pretty b withSrcSpanPretty (GHC.L l a) action = do #endif -- peek into the current state of the output, to extract the layout context -- flags passed up from subelements of the AST. (_,w) <- listen (return () :: Pretty ()) _ <- debugP ("withSrcSpanPretty: prLayoutContext w=" ++ show (prLayoutContext w) ) (return ()) local (\s -> s { curSrcSpan = l , annConName = annGetConstr a -- , prContext = pushAcs (prContext s) , prContext = (pushAcs (prContext s)) <> (prLayoutContext w) }) action -- --------------------------------------------------------------------- -- | Enter a new AST element. Maintain SrcSpan stack #if __GLASGOW_HASKELL__ > 806 withAST :: (Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> Pretty b -> Pretty b withAST lss@(GHC.dL->GHC.L ss t) action = do #else withAST :: Data a => GHC.Located a -> Pretty b -> Pretty b withAST lss@(GHC.L ss t) action = do #endif return () `debug` ("Pretty.withAST:enter 1:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) -- Calculate offset required to get to the start of the SrcSPan -- off <- gets apLayoutStart withSrcSpanPretty lss $ do return () `debug` ("Pretty.withAST:enter:(ss)=" ++ showGhc (ss,showConstr (toConstr t))) let maskWriter s = s { annKds = [] , sortKeys = Nothing , dwCapturedSpan = mempty -- , prLayoutContext = pushAcs (prLayoutContext s) } #if __GLASGOW_HASKELL__ <= 710 let spanStart = ss2pos ss cs <- do if GHC.isGoodSrcSpan ss then commentAllocation (priorComment spanStart) return else return [] #else let cs = [] #endif -- ctx <- debugP ("Pretty.withAST:cs:(ss,cs,uncs)=" ++ showGhc (ss,cs,uncs)) $ asks prContext ctx <- asks prContext noPrec <- gets apNoPrecedingSpace edp <- debugP ("Pretty.withAST:enter:(ss,constr,noPrec,ctx)=" ++ showGhc (ss,showConstr (toConstr t),noPrec,ctx)) $ entryDpFor ctx t -- edp <- entryDpFor ctx t let ctx1 = debugP ("Pretty.withAST:edp:(ss,constr,edp)=" ++ showGhc (ss,showConstr (toConstr t),edp)) ctx (res, w) <- if inAcs (Set.fromList [ListItem,TopLevel]) ctx1 then -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ censor maskWriter (listen (setNoPrecedingSpace action)) else -- debugP ("Pretty.withAST:setNoPrecedingSpace") $ censor maskWriter (listen action) let kds = annKds w an = Ann { annEntryDelta = edp , annPriorComments = cs , annFollowingComments = [] -- only used in Transform and Print , annsDP = kds , annSortKey = sortKeys w , annCapturedSpan = getFirst $ dwCapturedSpan w } addAnnotationsPretty an `debug` ("Pretty.withAST:(annkey,an)=" ++ show (mkAnnKey lss,an)) return res -- --------------------------------------------------------------------- entryDpFor :: Typeable a => AstContextSet -> a -> Pretty DeltaPos entryDpFor ctx a = (def `extQ` grhs) a where lineDefault = if inAcs (Set.singleton AdvanceLine) ctx then 1 else 0 noAdvanceLine = inAcs (Set.singleton NoAdvanceLine) ctx && inAcs (Set.singleton ListStart) ctx def :: a -> Pretty DeltaPos def _ = debugP ("entryDpFor:(topLevel,listStart,inList,noAdvanceLine,ctx)=" ++ show (topLevel,listStart,inList,noAdvanceLine,ctx)) $ if noAdvanceLine then return (DP (0,1)) else if listStart then return (DP (1,2)) else if inList then if topLevel then return (DP (2,0)) else return (DP (1,0)) else if topLevel then return (DP (2,0)) else return (DP (lineDefault,0)) topLevel = inAcs (Set.singleton TopLevel) ctx listStart = inAcs (Set.singleton ListStart) ctx && not (inAcs (Set.singleton TopLevel) ctx) inList = inAcs (Set.singleton ListItem) ctx inLambda = inAcs (Set.singleton LambdaExpr) ctx grhs :: GHC.GRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Pretty DeltaPos grhs _ = do if inLambda then return (DP (0,1)) else return (DP (1,2)) -- --------------------------------------------------------------------- fromNoPrecedingSpace :: Pretty a -> Pretty a -> Pretty a fromNoPrecedingSpace def lay = do PrettyState{apNoPrecedingSpace} <- get -- ctx <- asks prContext if apNoPrecedingSpace then do modify (\s -> s { apNoPrecedingSpace = False }) debugP ("fromNoPrecedingSpace:def") def -- def else -- lay debugP ("fromNoPrecedingSpace:lay") lay -- --------------------------------------------------------------------- -- |Add some annotation to the currently active SrcSpan addAnnotationsPretty :: Annotation -> Pretty () addAnnotationsPretty ann = do l <- ask return () `debug` ("addAnnotationsPretty:=" ++ showGhc (curSrcSpan l,prContext l)) tellFinalAnn (getAnnKey l,ann) getAnnKey :: PrettyOptions -> AnnKey getAnnKey PrettyOptions {curSrcSpan, annConName} = AnnKey curSrcSpan annConName -- --------------------------------------------------------------------- countAnnsPretty :: GHC.AnnKeywordId -> Pretty Int countAnnsPretty _ann = return 0 -- --------------------------------------------------------------------- withSortKey :: [(GHC.SrcSpan, Annotated b)] -> Pretty () withSortKey kws = let order = sortBy (comparing fst) kws in do tellSortKey (map fst order) mapM_ (prettyInterpret . snd) order withSortKeyContexts :: ListContexts -> [(GHC.SrcSpan, Annotated ())] -> Pretty () withSortKeyContexts ctxts kws = let order = sortBy (comparing fst) kws in do tellSortKey (map fst order) withSortKeyContextsHelper prettyInterpret ctxts order -- --------------------------------------------------------------------- storeOriginalSrcSpanPretty :: GHC.SrcSpan -> AnnKey -> Pretty AnnKey storeOriginalSrcSpanPretty _s key = do tellCapturedSpan key return key -- --------------------------------------------------------------------- getSrcSpanForKw :: GHC.SrcSpan -> GHC.AnnKeywordId -> Pretty GHC.SrcSpan getSrcSpanForKw ss _kw = return ss -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 storeString :: String -> GHC.SrcSpan -> Pretty () storeString s _ss = addPrettyAnnotation (AnnString s) #endif -- --------------------------------------------------------------------- setLayoutFlag :: Pretty () -> Pretty () setLayoutFlag action = do oldLay <- gets apLayoutStart modify (\s -> s { apMarkLayout = True } ) let reset = modify (\s -> s { apMarkLayout = False , apLayoutStart = oldLay }) action <* reset -- --------------------------------------------------------------------- setNoPrecedingSpace :: Pretty a -> Pretty a setNoPrecedingSpace action = do oldVal <- gets apNoPrecedingSpace modify (\s -> s { apNoPrecedingSpace = True } ) let reset = modify (\s -> s { apNoPrecedingSpace = oldVal }) action <* reset -- --------------------------------------------------------------------- setContextPretty :: Set.Set AstContext -> Int -> Pretty () -> Pretty () setContextPretty ctxt lvl = local (\s -> s { prContext = setAcsWithLevel ctxt lvl (prContext s) } ) unsetContextPretty :: AstContext -> Pretty () -> Pretty () unsetContextPretty ctxt = local (\s -> s { prContext = unsetAcs ctxt (prContext s) } ) ifInContextPretty :: Set.Set AstContext -> Annotated () -> Annotated () -> Pretty () ifInContextPretty ctxt ifAction elseAction = do cur <- asks prContext let inContext = inAcs ctxt cur if inContext then prettyInterpret ifAction else prettyInterpret elseAction -- --------------------------------------------------------------------- annotationsToCommentsPretty :: [GHC.AnnKeywordId] -> Pretty () annotationsToCommentsPretty _kws = return () -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 annotationsToCommentsBFPretty :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [GHC.AnnKeywordId] -> Pretty () annotationsToCommentsBFPretty bf _kws = do -- cs <- gets apComments cs <- debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) $ gets apComments -- return$ debugP ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) () -- error ("annotationsToCommentsBFPretty:" ++ showGhc (bf,makeBooleanFormulaAnns bf)) let kws = makeBooleanFormulaAnns bf newComments = map (uncurry mkKWComment ) kws putUnallocatedComments (cs ++ newComments) finalizeBFPretty :: GHC.SrcSpan -> Pretty () finalizeBFPretty _ss = do commentAllocation (const True) (mapM_ (uncurry addPrettyComment)) return () #endif -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 -- |Split the ordered list of comments into ones that occur prior to -- 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 #endif -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 commentAllocation :: (Comment -> Bool) -> ([(Comment, DeltaPos)] -> Pretty a) -> Pretty a commentAllocation p k = do cs <- getUnallocatedComments let (allocated,cs') = allocateComments p cs putUnallocatedComments cs' k =<< mapM makeDeltaComment (sortBy (comparing commentIdentifier) allocated) makeDeltaComment :: Comment -> Pretty (Comment, DeltaPos) makeDeltaComment c = do return (c, DP (0,1)) addPrettyComment :: Comment -> DeltaPos -> Pretty () addPrettyComment d p = do tellKd (AnnComment d, p) #endif -- --------------------------------------------------------------------- -- Writer helpers tellFinalAnn :: (AnnKey, Annotation) -> Pretty () tellFinalAnn (k, v) = tell (mempty { dwAnns = Endo (Map.insert k v) }) tellCapturedSpan :: AnnKey -> Pretty () tellCapturedSpan key = tell ( mempty { dwCapturedSpan = First $ Just key }) tellKd :: (KeywordId, DeltaPos) -> Pretty () tellKd kd = tell (mempty { annKds = [kd] }) tellSortKey :: [GHC.SrcSpan] -> Pretty () tellSortKey xs = tell (mempty { sortKeys = Just xs } ) tellContext :: Set.Set AstContext -> Pretty () tellContext lc = tell (mempty { prLayoutContext = setAcsWithLevel lc 2 mempty} ) ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Print.hs0000644000000000000000000005172307346545000022647 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- 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 ( exactPrint , exactPrintWithOptions -- * Configuration , PrintOptions(epRigidity, epAstPrint, epTokenPrint, epWhitespacePrint) , stringOptions , printOptions ) where import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Lookup import Control.Monad.Identity import Control.Monad.RWS import Control.Monad.Trans.Free import Data.Data (Data) import Data.List (sortBy, elemIndex) import Data.Maybe (fromMaybe) import Data.Ord (comparing) import qualified Data.Set as Set import qualified GHC {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- Printing of source elements -- | Print an AST with a map of potential modified `Anns`. The usual way to -- generate such a map is by using one of the parsers in -- "Language.Haskell.GHC.ExactPrint.Parsers". exactPrint :: Annotate ast => GHC.Located ast -> Anns -> String exactPrint ast as = runIdentity (exactPrintWithOptions stringOptions ast as) -- | The additional option to specify the rigidity and printing -- configuration. exactPrintWithOptions :: (Annotate ast, Monoid b, Monad m) => PrintOptions m b -> GHC.Located ast -> Anns -> m b exactPrintWithOptions r ast as = runEP r (annotate ast) as ------------------------------------------------------ -- The EP monad and basic combinators data PrintOptions m a = PrintOptions { epAnn :: !Annotation #if __GLASGOW_HASKELL__ > 806 , epAstPrint :: forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a #else , epAstPrint :: forall ast . Data ast => GHC.Located ast -> a -> m a #endif , epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a , epRigidity :: Rigidity , epContext :: !AstContextSet } -- | Helper to create a 'PrintOptions' printOptions :: #if __GLASGOW_HASKELL__ > 806 (forall ast . (Data ast, GHC.HasSrcSpan ast) => ast -> a -> m a) #else (forall ast . Data ast => GHC.Located ast -> a -> m a) #endif -> (String -> m a) -> (String -> m a) -> Rigidity -> PrintOptions m a printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions { epAnn = annNone , epAstPrint = astPrint , epWhitespacePrint = wsPrint , epTokenPrint = tokenPrint , epRigidity = rigidity , epContext = defaultACS } -- | Options which can be used to print as a normal String. stringOptions :: PrintOptions Identity String stringOptions = printOptions (\_ b -> return b) return return NormalLayout data EPWriter a = EPWriter { output :: !a } #if __GLASGOW_HASKELL__ >= 804 instance Monoid w => Semigroup (EPWriter w) where (<>) = mappend #endif instance Monoid w => Monoid (EPWriter w) where mempty = EPWriter mempty (EPWriter a) `mappend` (EPWriter b) = EPWriter (a <> b) data EPState = EPState { epPos :: !Pos -- ^ Current output position , epAnns :: !Anns , epAnnKds :: ![[(KeywordId, DeltaPos)]] -- MP: Could this be moved to the local statE w mith suitable refactoring? , epMarkLayout :: Bool , epLHS :: LayoutStartCol } --------------------------------------------------------- type EP w m a = RWST (PrintOptions m w) (EPWriter w) EPState m a runEP :: (Monad m, Monoid a) => PrintOptions m a -> Annotated () -> Anns -> m a runEP epReader action ans = fmap (output . snd) . (\next -> execRWST next epReader (defaultEPState ans)) . printInterpret $ action -- --------------------------------------------------------------------- defaultEPState :: Anns -> EPState defaultEPState as = EPState { epPos = (1,1) , epAnns = as , epAnnKds = [] , epLHS = 1 , epMarkLayout = False } -- --------------------------------------------------------------------- printInterpret :: forall w m a . (Monad m, Monoid w) => Annotated a -> EP w m a printInterpret m = iterTM go (hoistFreeT (return . runIdentity) m) where go :: AnnotationF (EP w m a) -> EP w m a go (MarkEOF next) = printStringAtMaybeAnn (G GHC.AnnEofPos) (Just "") >> next go (MarkPrim kwid mstr next) = markPrim (G kwid) mstr >> next go (MarkPPOptional kwid mstr next) = markPrim (G kwid) mstr >> next #if __GLASGOW_HASKELL__ >= 800 go (MarkInstead _ kwid next) = printStringAtMaybeAnnAll kwid Nothing >> next #endif go (MarkOutside _ kwid next) = printStringAtMaybeAnnAll kwid Nothing >> next go (MarkInside akwid next) = allAnns akwid >> next go (MarkMany akwid next) = allAnns akwid >> next go (MarkManyOptional akwid next) = allAnns akwid >> next go (MarkOffsetPrim kwid _ mstr next) = printStringAtMaybeAnn (G kwid) mstr >> next go (MarkOffsetPrimOptional kwid _ mstr next) = printStringAtMaybeAnn (G kwid) mstr >> next go (WithAST lss action next) = exactPC lss (printInterpret action) >> next go (CountAnns kwid next) = countAnnsEP (G kwid) >>= next go (SetLayoutFlag r action next) = do rigidity <- asks epRigidity (if r <= rigidity then setLayout else id) (printInterpret action) next go (MarkAnnBeforeAnn ann1 ann2 next) = printMarkAnnBeforeAnn (G ann1) (G ann2) >> next go (MarkExternal _ akwid s next) = printStringAtMaybeAnn (G akwid) (Just s) >> next go (StoreOriginalSrcSpan _ _ next) = storeOriginalSrcSpanPrint >>= next go (GetSrcSpanForKw _ _ next) = return GHC.noSrcSpan >>= next #if __GLASGOW_HASKELL__ <= 710 go (StoreString _ _ next) = printStoredString >> next #endif go (AnnotationsToComments _ next) = next #if __GLASGOW_HASKELL__ <= 710 go (AnnotationsToCommentsBF _ _ next) = next go (FinalizeBF _ next) = next #endif go (WithSortKey ks next) = withSortKey ks >> next go (WithSortKeyContexts ctx ks next) = withSortKeyContexts ctx ks >> next go (SetContextLevel ctxt lvl action next) = setContextPrint ctxt lvl (printInterpret action) >> next go (UnsetContext _ctxt action next) = printInterpret action >> next go (IfInContext ctxt ifAction elseAction next) = ifInContextPrint ctxt ifAction elseAction >> next go (TellContext _ next) = next ------------------------------------------------------------------------- storeOriginalSrcSpanPrint :: (Monad m, Monoid w) => EP w m AnnKey storeOriginalSrcSpanPrint = do Ann{..} <- asks epAnn case annCapturedSpan of Nothing -> error "Missing captured SrcSpan" Just v -> return v #if __GLASGOW_HASKELL__ <= 710 printStoredString :: (Monad m, Monoid w) => EP w m () printStoredString = do kd <- gets epAnnKds let isAnnString (AnnString _,_) = True isAnnString _ = False case filter isAnnString (ghead "printStoredString" kd) of ((AnnString ss,_):_) -> printStringAtMaybeAnn (AnnString ss) (Just ss) _ -> return () #endif withSortKey :: (Monad m, Monoid w) => [(GHC.SrcSpan, Annotated ())] -> EP w m () withSortKey xs = do Ann{..} <- asks epAnn let ordered = case annSortKey of Nothing -> xs Just keys -> orderByKey xs keys `debug` ("withSortKey:" ++ showGhc (map fst (sortBy (comparing (flip elemIndex keys . fst)) xs), map fst xs, keys) ) mapM_ (printInterpret . snd) ordered withSortKeyContexts :: (Monad m, Monoid w) => ListContexts -> [(GHC.SrcSpan, Annotated ())] -> EP w m () withSortKeyContexts ctxts xs = do Ann{..} <- asks epAnn let ordered = case annSortKey of Nothing -> 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 withSortKeyContextsHelper printInterpret ctxts ordered -- --------------------------------------------------------------------- setContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Int -> EP w m () -> EP w m () setContextPrint ctxt lvl = local (\s -> s { epContext = setAcsWithLevel ctxt lvl (epContext s) } ) ifInContextPrint :: (Monad m, Monoid w) => Set.Set AstContext -> Annotated () -> Annotated () -> EP w m () ifInContextPrint ctxt ifAction elseAction = do cur <- asks epContext let inContext = inAcs ctxt cur if inContext then printInterpret ifAction else printInterpret elseAction -- --------------------------------------------------------------------- allAnns :: (Monad m, Monoid w) => GHC.AnnKeywordId -> EP w m () allAnns kwid = printStringAtMaybeAnnAll (G kwid) Nothing ------------------------------------------------------------------------- -- |First move to the given location, then call exactP -- exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a -- exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) #if __GLASGOW_HASKELL__ > 806 exactPC :: (Data ast, Data (GHC.SrcSpanLess ast), GHC.HasSrcSpan ast, Monad m, Monoid w) => ast -> EP w m a -> EP w m a #else exactPC :: (Data ast, Monad m, Monoid w) => GHC.Located ast -> EP w m a -> EP w m a #endif 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 PrintOptions{epAstPrint} <- ask r <- withContext kds an (mapM_ (uncurry printQueuedComment) comments >> advance edp >> censorM (epAstPrint ast) action <* mapM_ (uncurry printQueuedComment) fcomments) return r `debug` ("leaving exactPCfor:" ++ show (mkAnnKey ast)) censorM :: (Monoid w, Monad m) => (w -> m w) -> EP w m a -> EP w m a censorM f m = passM (liftM (\x -> (x,f)) m) passM :: (Monad m) => EP w m (a, w -> m w) -> EP w m a passM m = RWST $ \r s -> do ~((a, f),s', EPWriter w) <- runRWST m r s w' <- f w return (a, s', EPWriter w') advance :: (Monad m, Monoid w) => DeltaPos -> EP w m () advance cl = do p <- getPos colOffset <- getLayoutOffset printWhitespace (undelta p cl colOffset) #if __GLASGOW_HASKELL__ > 806 getAndRemoveAnnotation :: (Monad m, Monoid w, Data a, Data (GHC.SrcSpanLess a), GHC.HasSrcSpan a) => a -> EP w m (Maybe Annotation) #else getAndRemoveAnnotation :: (Monad m, Monoid w, Data a) => GHC.Located a -> EP w m (Maybe Annotation) #endif getAndRemoveAnnotation a = gets (getAnnotationEP a . epAnns) markPrim :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () markPrim kwid mstr = printStringAtMaybeAnn kwid mstr withContext :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> Annotation -> EP w m a -> EP w m a withContext kds an x = withKds kds (withOffset an x) -- --------------------------------------------------------------------- -- -- | Given an annotation associated with a specific SrcSpan, determines a new offset relative to the previous -- offset -- withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) withOffset a = local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) -- --------------------------------------------------------------------- -- -- Necessary as there are destructive gets of Kds across scopes withKds :: (Monad m, Monoid w) => [(KeywordId, DeltaPos)] -> EP w m a -> EP w m a withKds kd action = do modify (\s -> s { epAnnKds = kd : epAnnKds s }) r <- action modify (\s -> s { epAnnKds = tail (epAnnKds s) }) return r ------------------------------------------------------------------------ setLayout :: (Monad m, Monoid w) => EP w m () -> EP w m () setLayout k = do oldLHS <- gets epLHS modify (\a -> a { epMarkLayout = True } ) let reset = modify (\a -> a { epMarkLayout = False , epLHS = oldLHS } ) k <* reset getPos :: (Monad m, Monoid w) => EP w m Pos getPos = gets epPos setPos :: (Monad m, Monoid w) => Pos -> EP w m () setPos l = modify (\s -> s {epPos = l}) -- |Get the current column offset getLayoutOffset :: (Monad m, Monoid w) => EP w m LayoutStartCol getLayoutOffset = gets epLHS -- --------------------------------------------------------------------- -- |If the first annotation has a smaller SrcSpan than the second, then mark it. -- In the printer this means the first appearing before the second in the list -- of annotations remaining printMarkAnnBeforeAnn :: (Monad m, Monoid w) => KeywordId -> KeywordId -> EP w m () printMarkAnnBeforeAnn annBefore annAfter = do kd <- gets epAnnKds case kd of [] -> return () -- Should never be triggered (k:_kds) -> do -- find the first ann, then the second. If found in that order, annotate. let find a = (\(kw,_) -> kw == a) case break (find annBefore) k of (_,[]) -> return () -- annBefore not present (_,rest) -> if null (snd $ break (find annAfter) rest) then return () else markPrim annBefore (Nothing) -- --------------------------------------------------------------------- printStringAtMaybeAnn :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () printStringAtMaybeAnn an mstr = printStringAtMaybeAnnThen an mstr (return ()) printStringAtMaybeAnnAll :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () printStringAtMaybeAnnAll an mstr = go where go = printStringAtMaybeAnnThen an mstr go printStringAtMaybeAnnThen :: (Monad m, Monoid w) => KeywordId -> Maybe String -> EP w m () -> EP w m () printStringAtMaybeAnnThen an mstr next = do let str = fromMaybe (keywordToString an) mstr annFinal <- getAnnFinal an case (annFinal, an) of #if __GLASGOW_HASKELL__ <= 710 -- 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 #else -- Could be unicode syntax -- TODO: This is a bit fishy, refactor (Nothing, G kw') -> do let kw = GHC.unicodeAnn kw' let str' = fromMaybe (keywordToString (G kw)) mstr res <- getAnnFinal (G kw) return () `debug` ("printStringAtMaybeAnn:missed:Unicode:(an,res)" ++ show (an,res)) unless (null res) $ do forM_ res (\(comments, ma) -> printStringAtLsDelta comments ma str') next #endif (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 :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe ([(Comment, DeltaPos)], DeltaPos)) getAnnFinal kw = do kd <- gets epAnnKds 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)]) -> (Maybe ([(Comment, v)], v),[(KeywordId,v)]) destructiveGetFirst _key (acc,[]) = (Nothing, acc) destructiveGetFirst key (acc, (k,v):kvs ) | k == key = (Just (skippedComments, v), others ++ kvs) | otherwise = destructiveGetFirst key (acc ++ [(k,v)], kvs) where (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 :: (Monad m, Monoid w) => [(Comment, DeltaPos)] -> DeltaPos -> String -> EP w m () 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)) printQueuedComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m () printQueuedComment Comment{commentContents} dp = do p <- getPos colOffset <- getLayoutOffset let (dr,dc) = undelta (0,0) dp colOffset -- do not lose comments against the left margin when (isGoodDelta (DP (dr,max 0 dc))) $ printCommentAt (undelta p dp colOffset) commentContents -- --------------------------------------------------------------------- -- |non-destructive get peekAnnFinal :: (Monad m, Monoid w) => KeywordId -> EP w m (Maybe DeltaPos) peekAnnFinal kw = do (r, _) <- (\kd -> destructiveGetFirst kw ([], kd)) <$> gets (ghead "peekAnnFinal" . epAnnKds) return (snd <$> r) countAnnsEP :: (Monad m, Monoid w) => KeywordId -> EP w m Int countAnnsEP an = length <$> peekAnnFinal an -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -- Printing functions printString :: (Monad m, Monoid w) => Bool -> String -> EP w m () printString layout str = do EPState{epPos = (_,c), epMarkLayout} <- get PrintOptions{epTokenPrint, epWhitespacePrint} <- ask when (epMarkLayout && layout) $ modify (\s -> s { epLHS = LayoutStartCol c, epMarkLayout = False } ) -- Advance position, taking care of any newlines in the string let strDP@(DP (cr,_cc)) = dpFromString str p <- getPos colOffset <- getLayoutOffset if cr == 0 then setPos (undelta p strDP colOffset) else setPos (undelta p strDP 1) -- if not layout && c == 0 then lift (epWhitespacePrint str) >>= \s -> tell EPWriter { output = s} else lift (epTokenPrint str) >>= \s -> tell EPWriter { output = s} newLine :: (Monad m, Monoid w) => EP w m () newLine = do (l,_) <- getPos printString False "\n" setPos (l+1,1) padUntil :: (Monad m, Monoid w) => Pos -> EP w m () padUntil (l,c) = do (l1,c1) <- getPos if | l1 == l && c1 <= c -> printString False $ replicate (c - c1) ' ' | l1 < l -> newLine >> padUntil (l,c) | otherwise -> return () printWhitespace :: (Monad m, Monoid w) => Pos -> EP w m () printWhitespace = padUntil printCommentAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () printCommentAt p str = printWhitespace p >> printString False str printStringAt :: (Monad m, Monoid w) => Pos -> String -> EP w m () printStringAt p str = printWhitespace p >> printString True str ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Transform.hs0000644000000000000000000014346407346545000023532 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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 welcome any feedback / contributions on this, as it is the main point of -- the library. -- ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Transform ( -- * The Transform Monad Transform , TransformT(..) , hoistTransform , runTransform , runTransformT , runTransformFrom , runTransformFromT -- * Transform monad operations , logTr , logDataWithAnnsTr , getAnnsT, putAnnsT, modifyAnnsT , uniqueSrcSpanT , cloneT , graftT , getEntryDPT , setEntryDPT , transferEntryDPT , setPrecedingLinesDeclT , setPrecedingLinesT , addSimpleAnnT , addTrailingCommaT , removeTrailingCommaT -- ** Managing declarations, in Transform monad , HasTransform (..) , HasDecls (..) , hasDeclsSybTransform , hsDeclsGeneric , hsDeclsPatBind, hsDeclsPatBindD , replaceDeclsPatBind, replaceDeclsPatBindD , modifyDeclsT , modifyValD -- *** Utility, does not manage layout , hsDeclsValBinds, replaceDeclsValbinds -- ** Managing lists, Transform monad , insertAtStart , insertAtEnd , insertAfter , insertBefore -- *** Low level operations used in 'HasDecls' , balanceComments , balanceTrailingComments , moveTrailingComments -- ** Managing lists, pure functions , captureOrder , captureOrderAnnKey -- * Operations , isUniqueSrcSpan -- * Pure functions , mergeAnns , mergeAnnList , setPrecedingLinesDecl , setPrecedingLines , getEntryDP , setEntryDP , transferEntryDP , addTrailingComma , wrapSig, wrapDecl , decl2Sig, decl2Bind ) where import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import Control.Monad.RWS import qualified Control.Monad.Fail as Fail 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 Data.List import Data.Maybe import qualified Data.Map as Map import Data.Functor.Identity import Control.Monad.State import Control.Monad.Writer -- 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 = TransformT Identity -- |Monad transformer version of 'Transform' monad newtype TransformT m a = TransformT { unTransformT :: RWST () [String] (Anns,Int) m a } deriving (Monad,Applicative,Functor ,MonadReader () ,MonadWriter [String] ,MonadState (Anns,Int) ,MonadTrans ) instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where fail msg = TransformT $ RWST $ \_ _ -> Fail.fail msg -- | 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 = runTransformFrom 0 ans f runTransformT :: Anns -> TransformT m a -> m (a,(Anns,Int),[String]) runTransformT ans f = runTransformFromT 0 ans f -- | Run a transformation in the 'Transform' monad, returning the updated -- annotations and any logging generated via 'logTr', allocating any new -- SrcSpans from the provided initial value. runTransformFrom :: Int -> Anns -> Transform a -> (a,(Anns,Int),[String]) runTransformFrom seed ans f = runRWS (unTransformT f) () (ans,seed) -- |Run a monad transformer stack for the 'TransformT' monad transformer runTransformFromT :: Int -> Anns -> TransformT m a -> m (a,(Anns,Int),[String]) runTransformFromT seed ans f = runRWST (unTransformT f) () (ans,seed) -- | Change inner monad of 'TransformT'. hoistTransform :: (forall x. m x -> n x) -> TransformT m a -> TransformT n a hoistTransform nt (TransformT m) = TransformT (mapRWST nt m) -- |Log a string to the output of the Monad logTr :: (Monad m) => String -> TransformT m () logTr str = tell [str] -- |Log a representation of the given AST with annotations to the output of the -- Monad logDataWithAnnsTr :: (Monad m) => (SYB.Data a) => String -> a -> TransformT m () logDataWithAnnsTr str ast = do anns <- getAnnsT logTr $ str ++ showAnnData anns 0 ast -- |Access the 'Anns' being modified in this transformation getAnnsT :: (Monad m) => TransformT m Anns getAnnsT = gets fst -- |Replace the 'Anns' after any changes putAnnsT :: (Monad m) => Anns -> TransformT m () putAnnsT ans = do (_,col) <- get put (ans,col) -- |Change the stored 'Anns' modifyAnnsT :: (Monad m) => (Anns -> Anns) -> TransformT m () 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 :: (Monad m) => TransformT m 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 -- --------------------------------------------------------------------- -- |Make a copy of an AST element, replacing the existing SrcSpans with new -- ones, and duplicating the matching annotations. cloneT :: (Data a,Monad m) => a -> TransformT m (a, [(GHC.SrcSpan, GHC.SrcSpan)]) cloneT ast = do runWriterT $ SYB.everywhereM (return `SYB.ext2M` replaceLocated) ast where replaceLocated :: forall loc a m. (Typeable loc,Data a,Monad m) => (GHC.GenLocated loc a) -> WriterT [(GHC.SrcSpan, GHC.SrcSpan)] (TransformT m) (GHC.GenLocated loc a) replaceLocated (GHC.L l t) = do case cast l :: Maybe GHC.SrcSpan of Just ss -> do newSpan <- lift uniqueSrcSpanT lift $ modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) anns of Nothing -> anns Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns) tell [(ss, newSpan)] return $ fromJust . cast $ GHC.L newSpan t Nothing -> return (GHC.L l t) -- --------------------------------------------------------------------- -- |Slightly more general form of cloneT graftT :: (Data a,Monad m) => Anns -> a -> TransformT m a graftT origAnns = SYB.everywhereM (return `SYB.ext2M` replaceLocated) where replaceLocated :: forall loc a m. (Typeable loc, Data a, Monad m) => GHC.GenLocated loc a -> TransformT m (GHC.GenLocated loc a) replaceLocated (GHC.L l t) = do case cast l :: Maybe GHC.SrcSpan of Just ss -> do newSpan <- uniqueSrcSpanT modifyAnnsT (\anns -> case Map.lookup (mkAnnKey (GHC.L ss t)) origAnns of Nothing -> anns Just an -> Map.insert (mkAnnKey (GHC.L newSpan t)) an anns) return $ fromJust $ cast $ GHC.L newSpan t Nothing -> return (GHC.L l t) -- --------------------------------------------------------------------- -- |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] #if __GLASGOW_HASKELL__ > 804 decl2Bind (GHC.L l (GHC.ValD _ s)) = [GHC.L l s] #else decl2Bind (GHC.L l (GHC.ValD s)) = [GHC.L l s] #endif 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] #if __GLASGOW_HASKELL__ > 804 decl2Sig (GHC.L l (GHC.SigD _ s)) = [GHC.L l s] #else decl2Sig (GHC.L l (GHC.SigD s)) = [GHC.L l s] #endif decl2Sig _ = [] -- --------------------------------------------------------------------- -- |Convert a 'GHC.LSig' into a 'GHC.LHsDecl' wrapSig :: GHC.LSig GhcPs -> GHC.LHsDecl GhcPs #if __GLASGOW_HASKELL__ > 804 wrapSig (GHC.L l s) = GHC.L l (GHC.SigD GHC.noExt s) #else wrapSig (GHC.L l s) = GHC.L l (GHC.SigD s) #endif -- --------------------------------------------------------------------- -- |Convert a 'GHC.LHsBind' into a 'GHC.LHsDecl' wrapDecl :: GHC.LHsBind GhcPs -> GHC.LHsDecl GhcPs #if __GLASGOW_HASKELL__ > 804 wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD GHC.noExt s) #else wrapDecl (GHC.L l s) = GHC.L l (GHC.ValD s) #endif -- --------------------------------------------------------------------- -- |Create a simple 'Annotation' without comments, and attach it to the first -- parameter. addSimpleAnnT :: (Constraints a,Monad m) #if __GLASGOW_HASKELL__ >= 808 => a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () #else => GHC.Located a -> DeltaPos -> [(KeywordId, DeltaPos)] -> TransformT m () #endif addSimpleAnnT ast dp kds = do let ann = annNone { annEntryDelta = dp , annsDP = kds } modifyAnnsT (Map.insert (mkAnnKey ast) ann) -- --------------------------------------------------------------------- -- |Add a trailing comma annotation, unless there is already one addTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m () addTrailingCommaT ast = do modifyAnnsT (addTrailingComma ast (DP (0,0))) -- --------------------------------------------------------------------- -- |Remove a trailing comma annotation, if there is one one removeTrailingCommaT :: (Data a,Monad m) => GHC.Located a -> TransformT m () removeTrailingCommaT ast = do modifyAnnsT (removeTrailingComma ast) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'getEntryDP' #if __GLASGOW_HASKELL__ >= 808 getEntryDPT :: (Constraints a,Monad m) => a -> TransformT m DeltaPos #else getEntryDPT :: (Data a,Monad m) => GHC.Located a -> TransformT m DeltaPos #endif getEntryDPT ast = do anns <- getAnnsT return (getEntryDP anns ast) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'getEntryDP' #if __GLASGOW_HASKELL__ >= 808 setEntryDPT :: (Constraints a,Monad m) => a -> DeltaPos -> TransformT m () #else setEntryDPT :: (Data a,Monad m) => GHC.Located a -> DeltaPos -> TransformT m () #endif setEntryDPT ast dp = do modifyAnnsT (setEntryDP ast dp) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'transferEntryDP' transferEntryDPT :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () transferEntryDPT a b = modifyAnnsT (transferEntryDP a b) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'setPrecedingLinesDecl' setPrecedingLinesDeclT :: (Monad m) => GHC.LHsDecl GhcPs -> Int -> Int -> TransformT m () setPrecedingLinesDeclT ld n c = modifyAnnsT (setPrecedingLinesDecl ld n c) -- --------------------------------------------------------------------- -- |'Transform' monad version of 'setPrecedingLines' setPrecedingLinesT :: (SYB.Data a,Monad m) => GHC.Located a -> Int -> Int -> TransformT m () setPrecedingLinesT ld n c = modifyAnnsT (setPrecedingLines ld n c) -- --------------------------------------------------------------------- -- | 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 -- ++AZ++ TODO: get rid of this, it is a synonym only setPrecedingLinesDecl :: GHC.LHsDecl GhcPs -> Int -> Int -> Anns -> Anns setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans -- --------------------------------------------------------------------- -- | Adjust the entry annotations to provide an `n` line preceding gap setPrecedingLines :: (SYB.Data a) => GHC.Located a -> Int -> Int -> Anns -> Anns setPrecedingLines ast n c anne = setEntryDP ast (DP (n,c)) anne -- --------------------------------------------------------------------- -- |Return the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. #if __GLASGOW_HASKELL__ >= 808 getEntryDP :: (Constraints a) => Anns -> a -> DeltaPos #else getEntryDP :: (Data a) => Anns -> GHC.Located a -> DeltaPos #endif getEntryDP anns ast = case Map.lookup (mkAnnKey ast) anns of Nothing -> DP (0,0) Just ann -> annTrueEntryDelta ann -- --------------------------------------------------------------------- -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. #if __GLASGOW_HASKELL__ >= 808 setEntryDP :: (Constraints a) => a -> DeltaPos -> Anns -> Anns #else setEntryDP :: (Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns #endif setEntryDP ast dp anns = case Map.lookup (mkAnnKey ast) anns of Nothing -> Map.insert (mkAnnKey ast) (annNone { annEntryDelta = dp}) anns Just ann -> Map.insert (mkAnnKey ast) (ann' { annEntryDelta = annCommentEntryDelta ann' dp}) anns where ann' = setCommentEntryDP ann dp -- --------------------------------------------------------------------- -- |When setting an entryDP, the leading comment needs to be adjusted too setCommentEntryDP :: Annotation -> DeltaPos -> Annotation -- setCommentEntryDP ann dp = error $ "setCommentEntryDP:ann'=" ++ show ann' setCommentEntryDP ann dp = ann' where ann' = case (annPriorComments ann) of [] -> ann [(pc,_)] -> ann { annPriorComments = [(pc,dp)] } ((pc,_):pcs) -> ann { annPriorComments = ((pc,dp):pcs) } -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and associate it with the second. -- Also transfer any comments occuring before it. transferEntryDP :: (SYB.Data a, SYB.Data b) => GHC.Located a -> GHC.Located b -> Anns -> Anns transferEntryDP a b anns = (const anns2) anns where maybeAnns = do -- Maybe monad anA <- Map.lookup (mkAnnKey a) anns anB <- Map.lookup (mkAnnKey b) anns let anB' = Ann { annEntryDelta = DP (0,0) -- Need to adjust for comments after , annPriorComments = annPriorComments anB , annFollowingComments = annFollowingComments anB , annsDP = annsDP anB , annSortKey = annSortKey anB , annCapturedSpan = annCapturedSpan anB } return ((Map.insert (mkAnnKey b) anB' anns),annLeadingCommentEntryDelta anA) (anns',dp) = fromMaybe (error $ "transferEntryDP: lookup failed (a,b)=" ++ show (mkAnnKey a,mkAnnKey b)) maybeAnns anns2 = setEntryDP b dp anns' -- --------------------------------------------------------------------- addTrailingComma :: (SYB.Data a) => GHC.Located a -> DeltaPos -> Anns -> Anns addTrailingComma a dp anns = case Map.lookup (mkAnnKey a) anns of Nothing -> anns Just an -> case find isAnnComma (annsDP an) of Nothing -> Map.insert (mkAnnKey a) (an { annsDP = annsDP an ++ [(G GHC.AnnComma,dp)]}) anns Just _ -> anns where isAnnComma (G GHC.AnnComma,_) = True isAnnComma _ = False -- --------------------------------------------------------------------- removeTrailingComma :: (SYB.Data a) => GHC.Located a -> Anns -> Anns removeTrailingComma a anns = case Map.lookup (mkAnnKey a) anns of Nothing -> anns Just an -> case find isAnnComma (annsDP an) of Nothing -> anns Just _ -> Map.insert (mkAnnKey a) (an { annsDP = filter (not.isAnnComma) (annsDP an) }) anns where isAnnComma (G GHC.AnnComma,_) = True isAnnComma _ = False -- --------------------------------------------------------------------- -- |The relatavise phase puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' -- from the second one to the 'annFollowingComments' of the first if they belong -- to it instead. This is typically required before deleting or duplicating -- either of the AST elements. balanceComments :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () balanceComments first second = do -- ++AZ++ : replace the nested casts with appropriate SYB.gmapM -- logTr $ "balanceComments entered" -- logDataWithAnnsTr "first" first case cast first :: Maybe (GHC.LHsDecl GhcPs) of #if __GLASGOW_HASKELL__ > 804 Just (GHC.L l (GHC.ValD _ fb@(GHC.FunBind{}))) -> do #else Just (GHC.L l (GHC.ValD fb@(GHC.FunBind{}))) -> do #endif balanceCommentsFB (GHC.L l fb) second _ -> case cast first :: Maybe (GHC.LHsBind GhcPs) of Just fb'@(GHC.L _ (GHC.FunBind{})) -> do balanceCommentsFB fb' second _ -> balanceComments' first second -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided -- with a passed-in decision function. balanceComments' :: (Data a,Data b,Monad m) => GHC.Located a -> GHC.Located b -> TransformT m () 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 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) -- |Once 'balanceComments' has been called to move trailing comments to a -- 'GHC.FunBind', these need to be pushed down from the top level to the last -- 'GHC.Match' if that 'GHC.Match' needs to be manipulated. balanceCommentsFB :: (Data b,Monad m) => GHC.LHsBind GhcPs -> GHC.Located b -> TransformT m () #if __GLASGOW_HASKELL__ > 804 balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) second = do #elif __GLASGOW_HASKELL__ > 710 balanceCommentsFB (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) second = do #else balanceCommentsFB (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) second = do #endif -- logTr $ "balanceCommentsFB entered" balanceComments' (last matches) second balanceCommentsFB f s = balanceComments' f s -- --------------------------------------------------------------------- -- |After moving an AST element, make sure any comments that may belong -- with the following element in fact do. Of necessity this is a heuristic -- process, to be tuned later. Possibly a variant should be provided with a -- passed-in decision function. balanceTrailingComments :: (Monad m) => (Data a,Data b) => GHC.Located a -> GHC.Located b -> TransformT m [(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 } ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans simpleBreak (_,DP (r,_c)) = r > 0 ans <- getAnnsT let (ans',mov) = moveComments simpleBreak ans putAnnsT ans' return mov -- --------------------------------------------------------------------- -- ++AZ++ TODO: This needs to be renamed/reworked, based on what it actually gets used for -- |Move any 'annFollowingComments' values from the 'Annotation' associated to -- the first parameter to that of the second. moveTrailingComments :: (Data a,Data b) => 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 -- --------------------------------------------------------------------- -- |Insert a declaration into an AST element having sub-declarations -- (@HasDecls@) according to the given location function. insertAt :: (HasDecls (GHC.Located ast)) => (GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs] -> [GHC.LHsDecl GhcPs]) -> GHC.Located ast -> GHC.LHsDecl GhcPs -> Transform (GHC.Located ast) insertAt f t decl = do oldDecls <- hsDecls t replaceDecls t (f decl oldDecls) -- |Insert a declaration at the beginning or end of the subdecls of the given -- AST item insertAtStart, insertAtEnd :: (HasDecls (GHC.Located ast)) => GHC.Located ast -> GHC.LHsDecl GhcPs -> Transform (GHC.Located ast) insertAtStart = insertAt (:) insertAtEnd = insertAt (\x xs -> xs ++ [x]) -- |Insert a declaration at a specific location in the subdecls of the given -- AST item insertAfter, insertBefore :: (HasDecls (GHC.Located ast)) => GHC.Located old -> GHC.Located ast -> GHC.LHsDecl GhcPs -> Transform (GHC.Located ast) insertAfter (GHC.getLoc -> k) = insertAt findAfter where findAfter x xs = let (fs, b:bs) = span (\(GHC.L l _) -> l /= k) xs in fs ++ (b : x : bs) insertBefore (GHC.getLoc -> k) = insertAt findBefore where findBefore x xs = let (fs, bs) = span (\(GHC.L l _) -> l /= k) xs in fs ++ (x : bs) -- ===================================================================== -- start of HasDecls instances -- ===================================================================== -- |Provide a means to get and process the immediate child declartions of a -- given AST element. class (Data t) => HasDecls t where -- ++AZ++: TODO: add tests to confirm that hsDecls followed by replaceDecls is idempotent -- | Return the 'GHC.HsDecl's that are directly enclosed in the -- given syntax phrase. They are always returned in the wrapped 'GHC.HsDecl' -- form, even if orginating in local decls. This is safe, as annotations -- never attach to the wrapper, only to the wrapped item. hsDecls :: (Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs] -- | 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 :: (Monad m) => t -> [GHC.LHsDecl GhcPs] -> TransformT m 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 logTr "replaceDecls LHsModule" modifyAnnsT (captureOrder m decls) return (GHC.L l (GHC.HsModule mn exps imps decls deps haddocks)) -- --------------------------------------------------------------------- instance HasDecls (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) where #if __GLASGOW_HASKELL__ > 804 hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _ (GHC.L _ lb)))) = do #elif __GLASGOW_HASKELL__ >= 804 hsDecls d@(GHC.L _ (GHC.Match _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do #elif __GLASGOW_HASKELL__ >= 800 hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ (GHC.L _ lb)))) = do #elif __GLASGOW_HASKELL__ >= 710 hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do #else hsDecls d@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ lb))) = do #endif decls <- hsDeclsValBinds lb orderedDecls d decls #if __GLASGOW_HASKELL__ > 804 hsDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) = return [] hsDecls (GHC.L _ (GHC.XMatch _)) = return [] #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) [] #elif __GLASGOW_HASKELL__ >= 804 replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) [] #else replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) [] #endif = do logTr "replaceDecls LMatch" let noWhere (G GHC.AnnWhere,_) = False noWhere _ = True removeWhere mkds = case Map.lookup (mkAnnKey m) mkds of Nothing -> error "wtf" Just ann -> Map.insert (mkAnnKey m) ann1 mkds where ann1 = ann { annsDP = filter noWhere (annsDP ann) } modifyAnnsT removeWhere #if __GLASGOW_HASKELL__ <= 710 binds' <- replaceDeclsValbinds binds [] #else binds'' <- replaceDeclsValbinds (GHC.unLoc binds) [] let binds' = GHC.L (GHC.getLoc binds) binds'' #endif #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) #elif __GLASGOW_HASKELL__ >= 804 return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls m@(GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds))) newBinds #elif __GLASGOW_HASKELL__ >= 804 replaceDecls m@(GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds))) newBinds #else replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds #endif = do logTr "replaceDecls LMatch" -- Need to throw in a fresh where clause if the binds were empty, -- in the annotations. #if __GLASGOW_HASKELL__ <= 710 case binds of #else case GHC.unLoc binds of #endif #if __GLASGOW_HASKELL__ > 804 GHC.EmptyLocalBinds{} -> do #else GHC.EmptyLocalBinds -> do #endif 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 modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) -- only move the comment if the original where clause was empty. toMove <- balanceTrailingComments m m insertCommentBefore (mkAnnKey m) toMove (matchApiAnn GHC.AnnWhere) _ -> return () modifyAnnsT (captureOrderAnnKey (mkAnnKey m) newBinds) #if __GLASGOW_HASKELL__ <= 710 binds' <- replaceDeclsValbinds binds newBinds #else binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newBinds let binds' = GHC.L (GHC.getLoc binds) binds'' #endif -- logDataWithAnnsTr "Match.replaceDecls:binds'" binds' #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.Match xm c p (GHC.GRHSs xr rhs binds'))) #elif __GLASGOW_HASKELL__ >= 804 return (GHC.L l (GHC.Match c p (GHC.GRHSs rhs binds'))) #else return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L _ (GHC.Match _ _ _ (GHC.XGRHSs _))) _ = error "replaceDecls" replaceDecls (GHC.L _ (GHC.XMatch _)) _ = error "replaceDecls" #endif -- --------------------------------------------------------------------- instance HasDecls (GHC.LHsExpr GhcPs) where #if __GLASGOW_HASKELL__ > 804 hsDecls ls@(GHC.L _ (GHC.HsLet _ (GHC.L _ decls) _ex)) = do #elif __GLASGOW_HASKELL__ > 710 hsDecls ls@(GHC.L _ (GHC.HsLet (GHC.L _ decls) _ex)) = do #else hsDecls ls@(GHC.L _ (GHC.HsLet decls _ex)) = do #endif ds <- hsDeclsValBinds decls orderedDecls ls ds hsDecls _ = return [] #if __GLASGOW_HASKELL__ > 804 replaceDecls e@(GHC.L l (GHC.HsLet x decls ex)) newDecls #else replaceDecls e@(GHC.L l (GHC.HsLet decls ex)) newDecls #endif = do logTr "replaceDecls HsLet" modifyAnnsT (captureOrder e newDecls) #if __GLASGOW_HASKELL__ <= 710 decls' <- replaceDeclsValbinds decls newDecls #else decls'' <- replaceDeclsValbinds (GHC.unLoc decls) newDecls let decls' = GHC.L (GHC.getLoc decls) decls'' #endif #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.HsLet x decls' ex)) #else return (GHC.L l (GHC.HsLet decls' ex)) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L l (GHC.HsPar x e)) newDecls #else replaceDecls (GHC.L l (GHC.HsPar e)) newDecls #endif = do logTr "replaceDecls HsPar" e' <- replaceDecls e newDecls #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.HsPar x e')) #else return (GHC.L l (GHC.HsPar e')) #endif replaceDecls old _new = error $ "replaceDecls (GHC.LHsExpr GhcPs) undefined for:" ++ showGhc old -- --------------------------------------------------------------------- -- | Extract the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent. hsDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> TransformT m [GHC.LHsDecl GhcPs] #if __GLASGOW_HASKELL__ > 804 hsDeclsPatBindD (GHC.L l (GHC.ValD _ d)) = hsDeclsPatBind (GHC.L l d) #else hsDeclsPatBindD (GHC.L l (GHC.ValD d)) = hsDeclsPatBind (GHC.L l d) #endif hsDeclsPatBindD x = error $ "hsDeclsPatBindD called for:" ++ showGhc x -- | Extract the immediate declarations for a 'GHC.PatBind'. This -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] #if __GLASGOW_HASKELL__ > 804 hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ _ (GHC.GRHSs _ _grhs (GHC.L _ lb)) _)) = do #elif __GLASGOW_HASKELL__ > 710 hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs (GHC.L _ lb)) _ _ _)) = do #else hsDeclsPatBind d@(GHC.L _ (GHC.PatBind _ (GHC.GRHSs _grhs lb) _ _ _)) = do #endif decls <- hsDeclsValBinds lb orderedDecls d decls hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x -- ------------------------------------- -- | Replace the immediate declarations for a 'GHC.PatBind' wrapped in a 'GHC.ValD'. This -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBindD' \/ 'replaceDeclsPatBindD' is -- idempotent. replaceDeclsPatBindD :: (Monad m) => GHC.LHsDecl GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.LHsDecl GhcPs) #if __GLASGOW_HASKELL__ > 804 replaceDeclsPatBindD (GHC.L l (GHC.ValD x d)) newDecls = do (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls return (GHC.L l (GHC.ValD x d')) #else replaceDeclsPatBindD (GHC.L l (GHC.ValD d)) newDecls = do (GHC.L _ d') <- replaceDeclsPatBind (GHC.L l d) newDecls return (GHC.L l (GHC.ValD d')) #endif replaceDeclsPatBindD x _ = error $ "replaceDeclsPatBindD called for:" ++ showGhc x -- | Replace the immediate declarations for a 'GHC.PatBind'. This -- cannot be a member of 'HasDecls' because a 'GHC.FunBind' is not idempotent -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. replaceDeclsPatBind :: (Monad m) => GHC.LHsBind GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.LHsBind GhcPs) #if __GLASGOW_HASKELL__ > 804 replaceDeclsPatBind p@(GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds) b)) newDecls #else replaceDeclsPatBind p@(GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds) b c d)) newDecls #endif = do logTr "replaceDecls PatBind" -- Need to throw in a fresh where clause if the binds were empty, -- in the annotations. #if __GLASGOW_HASKELL__ <= 710 case binds of #else case GHC.unLoc binds of #endif #if __GLASGOW_HASKELL__ > 804 GHC.EmptyLocalBinds{} -> do #else GHC.EmptyLocalBinds -> do #endif let addWhere mkds = case Map.lookup (mkAnnKey p) mkds of Nothing -> error "wtf" Just ann -> Map.insert (mkAnnKey p) ann1 mkds where ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] } modifyAnnsT addWhere modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newDecls) 1 4) _ -> return () modifyAnnsT (captureOrderAnnKey (mkAnnKey p) newDecls) #if __GLASGOW_HASKELL__ <= 710 binds' <- replaceDeclsValbinds binds newDecls #else binds'' <- replaceDeclsValbinds (GHC.unLoc binds) newDecls let binds' = GHC.L (GHC.getLoc binds) binds'' #endif #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.PatBind x a (GHC.GRHSs xr rhss binds') b)) #else return (GHC.L l (GHC.PatBind a (GHC.GRHSs rhss binds') b c d)) #endif replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x -- --------------------------------------------------------------------- instance HasDecls (GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) where #if __GLASGOW_HASKELL__ > 804 hsDecls ls@(GHC.L _ (GHC.LetStmt _ (GHC.L _ lb))) = do #elif __GLASGOW_HASKELL__ > 710 hsDecls ls@(GHC.L _ (GHC.LetStmt (GHC.L _ lb))) = do #else hsDecls ls@(GHC.L _ (GHC.LetStmt lb)) = do #endif decls <- hsDeclsValBinds lb orderedDecls ls decls #if __GLASGOW_HASKELL__ > 804 hsDecls (GHC.L _ (GHC.LastStmt _ e _ _)) = hsDecls e #elif __GLASGOW_HASKELL__ >= 804 hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e #elif __GLASGOW_HASKELL__ > 800 hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e #elif __GLASGOW_HASKELL__ > 710 hsDecls (GHC.L _ (GHC.LastStmt e _ _)) = hsDecls e #else hsDecls (GHC.L _ (GHC.LastStmt e _)) = hsDecls e #endif #if __GLASGOW_HASKELL__ > 804 hsDecls (GHC.L _ (GHC.BindStmt _ _pat e _ _)) = hsDecls e #elif __GLASGOW_HASKELL__ > 710 hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _ _)) = hsDecls e #else hsDecls (GHC.L _ (GHC.BindStmt _pat e _ _)) = hsDecls e #endif #if __GLASGOW_HASKELL__ > 804 hsDecls (GHC.L _ (GHC.BodyStmt _ e _ _)) = hsDecls e #else hsDecls (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsDecls e #endif hsDecls _ = return [] #if __GLASGOW_HASKELL__ > 804 replaceDecls s@(GHC.L l (GHC.LetStmt x lb)) newDecls #else replaceDecls s@(GHC.L l (GHC.LetStmt lb)) newDecls #endif = do modifyAnnsT (captureOrder s newDecls) #if __GLASGOW_HASKELL__ <= 710 lb' <- replaceDeclsValbinds lb newDecls #else lb'' <- replaceDeclsValbinds (GHC.unLoc lb) newDecls let lb' = GHC.L (GHC.getLoc lb) lb'' #endif #if __GLASGOW_HASKELL__ > 804 return (GHC.L l (GHC.LetStmt x lb')) #else return (GHC.L l (GHC.LetStmt lb')) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L l (GHC.LastStmt x e d se)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.LastStmt x e' d se)) #elif __GLASGOW_HASKELL__ > 710 replaceDecls (GHC.L l (GHC.LastStmt e d se)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.LastStmt e' d se)) #else replaceDecls (GHC.L l (GHC.LastStmt e se)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.LastStmt e' se)) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L l (GHC.BindStmt x pat e a b)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BindStmt x pat e' a b)) #elif __GLASGOW_HASKELL__ > 710 replaceDecls (GHC.L l (GHC.BindStmt pat e a b c)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BindStmt pat e' a b c)) #else replaceDecls (GHC.L l (GHC.BindStmt pat e a b)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BindStmt pat e' a b)) #endif #if __GLASGOW_HASKELL__ > 804 replaceDecls (GHC.L l (GHC.BodyStmt x e a b)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BodyStmt x e' a b)) #else replaceDecls (GHC.L l (GHC.BodyStmt e a b c)) newDecls = do e' <- replaceDecls e newDecls return (GHC.L l (GHC.BodyStmt e' a b c)) #endif replaceDecls x _newDecls = return x -- ===================================================================== -- end of HasDecls instances -- ===================================================================== -- --------------------------------------------------------------------- -- |Do a transformation on an AST fragment by providing a function to process -- the general case and one specific for a 'GHC.LHsBind'. This is required -- because a 'GHC.FunBind' may have multiple 'GHC.Match' items, so we cannot -- gurantee that 'replaceDecls' after 'hsDecls' is idempotent. hasDeclsSybTransform :: (SYB.Data t2,Monad m) => (forall t. HasDecls t => t -> m t) -- ^Worker function for the general case -> (GHC.LHsBind GhcPs -> m (GHC.LHsBind GhcPs)) -- ^Worker function for FunBind/PatBind -> t2 -- ^Item to be updated -> m t2 hasDeclsSybTransform workerHasDecls workerBind t = trf t where trf = SYB.mkM parsedSource `SYB.extM` lmatch `SYB.extM` lexpr `SYB.extM` lstmt `SYB.extM` lhsbind `SYB.extM` lvald parsedSource (p::GHC.ParsedSource) = workerHasDecls p lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = workerHasDecls lm lexpr (le::GHC.LHsExpr GhcPs) = workerHasDecls le lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = workerHasDecls d lhsbind (b@(GHC.L _ GHC.FunBind{}):: GHC.LHsBind GhcPs) = workerBind b lhsbind b@(GHC.L _ GHC.PatBind{}) = workerBind b lhsbind x = return x #if __GLASGOW_HASKELL__ > 804 lvald (GHC.L l (GHC.ValD x d)) = do (GHC.L _ d') <- lhsbind (GHC.L l d) return (GHC.L l (GHC.ValD x d')) #else lvald (GHC.L l (GHC.ValD d)) = do (GHC.L _ d') <- lhsbind (GHC.L l d) return (GHC.L l (GHC.ValD d')) #endif lvald x = return x -- --------------------------------------------------------------------- -- |A 'GHC.FunBind' wraps up one or more 'GHC.Match' items. 'hsDecls' cannot -- return anything for these as there is not meaningful 'replaceDecls' for it. -- This function provides a version of 'hsDecls' that returns the 'GHC.FunBind' -- decls too, where they are needed for analysis only. hsDeclsGeneric :: (SYB.Data t,Monad m) => t -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsGeneric t = q t where q = return [] `SYB.mkQ` parsedSource `SYB.extQ` lmatch `SYB.extQ` lexpr `SYB.extQ` lstmt `SYB.extQ` lhsbind `SYB.extQ` lhsbindd `SYB.extQ` llocalbinds `SYB.extQ` localbinds parsedSource (p::GHC.ParsedSource) = hsDecls p lmatch (lm::GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) = hsDecls lm lexpr (le::GHC.LHsExpr GhcPs) = hsDecls le lstmt (d::GHC.LStmt GhcPs (GHC.LHsExpr GhcPs)) = hsDecls d -- --------------------------------- lhsbind :: (Monad m) => GHC.LHsBind GhcPs -> TransformT m [GHC.LHsDecl GhcPs] #if __GLASGOW_HASKELL__ > 804 lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ matches) _) _ _)) = do #elif __GLASGOW_HASKELL__ > 710 lhsbind (GHC.L _ (GHC.FunBind _ (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)) = do #else lhsbind (GHC.L _ (GHC.FunBind _ _ (GHC.MG matches _ _ _) _ _ _)) = do #endif dss <- mapM hsDecls matches return (concat dss) lhsbind p@(GHC.L _ (GHC.PatBind{})) = do hsDeclsPatBind p lhsbind _ = return [] -- --------------------------------- #if __GLASGOW_HASKELL__ > 804 lhsbindd (GHC.L l (GHC.ValD _ d)) = lhsbind (GHC.L l d) #else lhsbindd (GHC.L l (GHC.ValD d)) = lhsbind (GHC.L l d) #endif lhsbindd _ = return [] -- --------------------------------- llocalbinds :: (Monad m) => GHC.Located (GHC.HsLocalBinds GhcPs) -> TransformT m [GHC.LHsDecl GhcPs] llocalbinds (GHC.L _ ds) = localbinds ds -- --------------------------------- localbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] localbinds d = hsDeclsValBinds d -- --------------------------------------------------------------------- -- |Look up the annotated order and sort the decls accordingly orderedDecls :: (Data a,Monad m) => GHC.Located a -> [GHC.LHsDecl GhcPs] -> TransformT m [GHC.LHsDecl GhcPs] orderedDecls parent decls = do ans <- getAnnsT case getAnnotationEP parent ans of Nothing -> error $ "orderedDecls:no annotation for:" ++ showAnnData emptyAnns 0 parent Just ann -> case annSortKey ann of Nothing -> do return decls Just keys -> do let ds = map (\s -> (GHC.getLoc s,s)) decls ordered = map snd $ orderByKey ds keys return ordered -- --------------------------------------------------------------------- -- | Utility function for extracting decls from 'GHC.HsLocalBinds'. Use with -- care, as this does not necessarily return the declarations in order, the -- ordering should be done by the calling function from the 'GHC.HsLocalBinds' -- context in the AST. hsDeclsValBinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> TransformT m [GHC.LHsDecl GhcPs] hsDeclsValBinds lb = case lb of #if __GLASGOW_HASKELL__ > 804 GHC.HsValBinds _ (GHC.ValBinds _ bs sigs) -> do let bds = map wrapDecl (GHC.bagToList bs) sds = map wrapSig sigs return (bds ++ sds) GHC.HsValBinds _ (GHC.XValBindsLR _) -> error $ "hsDecls.XValBindsLR not valid" GHC.HsIPBinds {} -> return [] GHC.EmptyLocalBinds {} -> return [] GHC.XHsLocalBindsLR {} -> return [] #else GHC.HsValBinds (GHC.ValBindsIn bs sigs) -> do let bds = map wrapDecl (GHC.bagToList bs) sds = map wrapSig sigs return (bds ++ sds) GHC.HsValBinds (GHC.ValBindsOut _ _) -> error $ "hsDecls.ValbindsOut not valid" GHC.HsIPBinds _ -> return [] GHC.EmptyLocalBinds -> return [] #endif -- | Utility function for returning decls to 'GHC.HsLocalBinds'. Use with -- care, as this does not manage the declaration order, the -- ordering should be done by the calling function from the 'GHC.HsLocalBinds' -- context in the AST. replaceDeclsValbinds :: (Monad m) => GHC.HsLocalBinds GhcPs -> [GHC.LHsDecl GhcPs] -> TransformT m (GHC.HsLocalBinds GhcPs) replaceDeclsValbinds _ [] = do #if __GLASGOW_HASKELL__ > 804 return (GHC.EmptyLocalBinds GHC.noExt) #else return (GHC.EmptyLocalBinds) #endif #if __GLASGOW_HASKELL__ > 804 replaceDeclsValbinds (GHC.HsValBinds _ _b) new #else replaceDeclsValbinds (GHC.HsValBinds _b) new #endif = do logTr "replaceDecls HsLocalBinds" let decs = GHC.listToBag $ concatMap decl2Bind new let sigs = concatMap decl2Sig new #if __GLASGOW_HASKELL__ > 804 return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) #endif replaceDeclsValbinds (GHC.HsIPBinds {}) _new = error "undefined replaceDecls HsIPBinds" #if __GLASGOW_HASKELL__ > 804 replaceDeclsValbinds (GHC.EmptyLocalBinds _) new #else replaceDeclsValbinds (GHC.EmptyLocalBinds) new #endif = do logTr "replaceDecls HsLocalBinds" let newBinds = map decl2Bind new newSigs = map decl2Sig new let decs = GHC.listToBag $ concat newBinds let sigs = concat newSigs #if __GLASGOW_HASKELL__ > 804 return (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt decs sigs)) #else return (GHC.HsValBinds (GHC.ValBindsIn decs sigs)) #endif #if __GLASGOW_HASKELL__ > 804 replaceDeclsValbinds (GHC.XHsLocalBindsLR _) _ = error "replaceDeclsValbinds. XHsLocalBindsLR" #endif -- --------------------------------------------------------------------- type Decl = GHC.LHsDecl GhcPs type Match = GHC.LMatch GhcPs (GHC.LHsExpr GhcPs) -- |Modify a 'GHC.LHsBind' wrapped in a 'GHC.ValD'. For a 'GHC.PatBind' the -- declarations are extracted and returned after modification. For a -- 'GHC.FunBind' the supplied 'GHC.SrcSpan' is used to identify the specific -- 'GHC.Match' to be transformed, for when there are multiple of them. modifyValD :: forall m t. (HasTransform m) => GHC.SrcSpan -> Decl -> (Match -> [Decl] -> m ([Decl], Maybe t)) -> m (Decl,Maybe t) #if __GLASGOW_HASKELL__ > 804 modifyValD p pb@(GHC.L ss (GHC.ValD _ (GHC.PatBind {} ))) f = #else modifyValD p pb@(GHC.L ss (GHC.ValD (GHC.PatBind {} ))) f = #endif if ss == p then do ds <- liftT $ hsDeclsPatBindD pb (ds',r) <- f (error "modifyValD.PatBind should not touch Match") ds pb' <- liftT $ replaceDeclsPatBindD pb ds' return (pb',r) else return (pb,Nothing) modifyValD p ast f = do (ast',r) <- runStateT (SYB.everywhereM (SYB.mkM doModLocal) ast) Nothing return (ast',r) where doModLocal :: Match -> StateT (Maybe t) m Match doModLocal (match@(GHC.L ss _) :: Match) = do let if ss == p then do ds <- lift $ liftT $ hsDecls match (ds',r) <- lift $ f match ds put r match' <- lift $ liftT $ replaceDecls match ds' return match' else return match -- --------------------------------------------------------------------- -- |Used to integrate a @Transform@ into other Monad stacks class (Monad m) => (HasTransform m) where liftT :: Transform a -> m a instance Monad m => HasTransform (TransformT m) where liftT = hoistTransform (return . runIdentity) -- --------------------------------------------------------------------- -- | Apply a transformation to the decls contained in @t@ modifyDeclsT :: (HasDecls t,HasTransform m) => ([GHC.LHsDecl GhcPs] -> m [GHC.LHsDecl GhcPs]) -> t -> m t modifyDeclsT action t = do decls <- liftT $ hsDecls t decls' <- action decls liftT $ replaceDecls t decls' -- --------------------------------------------------------------------- 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 :: (Monad m) => AnnKey -> [(Comment, DeltaPos)] -> ((KeywordId, DeltaPos) -> Bool) -> TransformT m () 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' = ann { annsDP = before ++ (map comment2dp toMove) ++ after} modifyAnnsT doInsert ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Types.hs0000644000000000000000000003531207346545000022653 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} module Language.Haskell.GHC.ExactPrint.Types ( -- * Core Types Anns , emptyAnns , Annotation(..) , annNone , KeywordId(..) , Comment(..) -- * Positions , Pos , DeltaPos(..) , deltaRow, deltaColumn -- * AnnKey , AnnKey(..) , mkAnnKey , AnnConName(..) , annGetConstr -- * Other , Rigidity(..) , AstContext(..),AstContextSet,defaultACS , ACS'(..) , ListContexts(..) -- * For managing compatibility , Constraints -- * GHC version compatibility , GhcPs , GhcRn , GhcTc -- * Internal Types , LayoutStartCol(..) , declFun ) where import Data.Data (Data, Typeable, toConstr,cast) -- import Data.Generics import qualified DynFlags as GHC import qualified GHC import qualified Outputable as GHC import qualified Data.Map as Map import qualified Data.Set as Set -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 808 type Constraints a = (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) #else type Constraints a = (Data a) #endif -- --------------------------------------------------------------------- -- | 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 -- AZ:TODO: commentIdentifier is a misnomer, should be commentSrcSpan, it is -- the thing we use to decide where in the output stream the comment should -- go. , 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,Typeable,Data,Ord) instance Show Comment where show (Comment cs ss o) = "(Comment " ++ show cs ++ " " ++ showGhc ss ++ " " ++ show o ++ ")" instance GHC.Outputable Comment where ppr x = GHC.text (show x) type Pos = (Int,Int) -- | 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, Num) instance Show LayoutStartCol where show (LayoutStartCol sc) = "(LayoutStartCol " ++ show sc ++ ")" annNone :: Annotation annNone = Ann (DP (0,0)) [] [] [] Nothing Nothing data Annotation = Ann { -- The first three fields relate to interfacing up into the AST annEntryDelta :: !DeltaPos -- ^ Offset used to get to the start of the SrcSpan, from whatever the prior -- output was, including all annPriorComments (field below). , 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. -- The next three fields relate to interacing down into the AST , 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 comments fcomments ans sk csp) = "(Ann (" ++ show dp ++ ") " ++ show comments ++ " " ++ show fcomments ++ " " ++ show ans ++ " " ++ showGhc sk ++ " " ++ showGhc csp ++ ")" -- | 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, Ord, Data) -- More compact Show instance instance Show AnnKey where show (AnnKey ss cn) = "AnnKey " ++ showGhc ss ++ " " ++ show cn #if __GLASGOW_HASKELL__ > 806 mkAnnKeyPrim :: (Constraints a) => a -> AnnKey mkAnnKeyPrim (GHC.dL->GHC.L l a) = AnnKey l (annGetConstr a) #else mkAnnKeyPrim :: (Data a) => GHC.Located a -> AnnKey mkAnnKeyPrim (GHC.L l a) = AnnKey l (annGetConstr a) #endif #if __GLASGOW_HASKELL__ <= 802 type GhcPs = GHC.RdrName type GhcRn = GHC.Name type GhcTc = GHC.Id #else type GhcPs = GHC.GhcPs type GhcRn = GHC.GhcRn type GhcTc = GHC.GhcTc #endif -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. #if __GLASGOW_HASKELL__ > 806 mkAnnKey :: (Constraints a) => a -> AnnKey #else mkAnnKey :: (Data a) => GHC.Located a -> AnnKey #endif mkAnnKey ld = case cast ld :: Maybe (GHC.LHsDecl GhcPs) of Just d -> declFun mkAnnKeyPrim d Nothing -> mkAnnKeyPrim ld -- Holds the name of a constructor data AnnConName = CN { unConName :: String } deriving (Eq, Ord, Data) -- 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) -- | The different syntactic elements which are not represented in the -- AST. data KeywordId = G GHC.AnnKeywordId -- ^ A normal keyword | AnnSemiSep -- ^ A separating comma #if __GLASGOW_HASKELL__ >= 800 | AnnTypeApp -- ^ Visible type application annotation #endif | AnnComment Comment | AnnString String -- ^ Used to pass information from -- Delta to Print when we have to work -- out details from the original -- SrcSpan. #if __GLASGOW_HASKELL__ <= 710 | AnnUnicode GHC.AnnKeywordId -- ^ Used to indicate that we should print using unicode syntax if possible. #endif deriving (Eq, Ord, Data) instance Show KeywordId where show (G gc) = "(G " ++ show gc ++ ")" show AnnSemiSep = "AnnSemiSep" #if __GLASGOW_HASKELL__ >= 800 show AnnTypeApp = "AnnTypeApp" #endif show (AnnComment dc) = "(AnnComment " ++ show dc ++ ")" show (AnnString s) = "(AnnString " ++ s ++ ")" #if __GLASGOW_HASKELL__ <= 710 show (AnnUnicode gc) = "(AnnUnicode " ++ show gc ++ ")" #endif -- --------------------------------------------------------------------- instance GHC.Outputable KeywordId where ppr k = GHC.text (show k) instance GHC.Outputable AnnConName where ppr tr = GHC.text (show tr) instance GHC.Outputable Annotation where ppr a = GHC.text (show a) instance GHC.Outputable AnnKey where ppr a = GHC.text (show a) instance GHC.Outputable DeltaPos where ppr a = GHC.text (show a) -- --------------------------------------------------------------------- -- -- Flag used to control whether we use rigid or normal layout rules. -- NOTE: check is done via comparison of enumeration order, be careful with any changes data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) {- Rigidity logic. The same type is used for two different things 1. As a flag in Annotate to the "SetLayoutFlag" operation, which specifies NormalLayout - Layout should be captured unconditionally RigidLayout - Layout should be captured or not depending on a parameter kept in the interpreter Read state 2. As the controlling parameter for the optional (Rigid) layout The nett effect is the following, where flag is the hard-coded flag value in Annotate, and param is the interpreter param set when the interpreter is run flag | param | result -------------+--------------+-------------------- NormalLayout | either | layout captured RigidLayout | NormalLayout | layout NOT captured RigidLayout | RigidLayout | layout captured The flag is only used on HsIf and HsCase So state | HsCase | HsIf ----------------------------|-----------+------ before rigidity flag (AZ) | no layout | layout param NormalLayout | no layout | no layout param RigidLayout | layout | layout ----------------------------+-----------+------- desired future HaRe | no layout | layout desired future apply-refact | layout | layout -} -- --------------------------------------------------------------------- data ACS' a = ACS { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should -- propagate down the AST. Removed when it hits zero } deriving (Show) #if __GLASGOW_HASKELL__ >= 804 instance Semigroup (ACS' AstContext) where (<>) = mappend #endif instance Monoid (ACS' AstContext) where mempty = ACS mempty -- ACS a `mappend` ACS b = ACS (a `mappend` b) ACS a `mappend` ACS b = ACS (Map.unionWith max a b) -- For Data.Map, mappend == union, which is a left-biased replace for key collisions type AstContextSet = ACS' AstContext -- data AstContextSet = ACS -- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should -- -- propagate down the AST. Removed when it -- -- hits zero -- } deriving (Show) defaultACS :: AstContextSet defaultACS = ACS Map.empty -- instance GHC.Outputable AstContextSet where instance (Show a) => GHC.Outputable (ACS' a) where ppr x = GHC.text $ show x data AstContext = LambdaExpr | CaseAlt | NoPrecedingSpace | HasHiding | AdvanceLine | NoAdvanceLine | Intercalate -- This item may have a list separator following | InIE -- possible 'type' or 'pattern' | PrefixOp | PrefixOpDollar | InfixOp -- RdrName may be used as an infix operator | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently | ListItem -- Identifies subsequent elements of a list in layout | TopLevel -- top level declaration | NoDarrow | AddVbar | Deriving | Parens -- TODO: Not currently used? | ExplicitNeverActive | InGadt | InRecCon | InClassDecl | InSpliceDecl | LeftMost -- Is this the leftmost operator in a chain of OpApps? | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt -- TODO:AZ: do we actually need this? -- Next four used to identify current list context | CtxOnly | CtxFirst | CtxMiddle | CtxLast | CtxPos Int -- 0 for first, increasing for subsequent -- Next are used in tellContext to push context up the tree | FollowingLine deriving (Eq, Ord, Show) data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } deriving (Eq,Show) -- --------------------------------------------------------------------- -- data LayoutContext = FollowingLine -- ^Indicates that an item such as a SigD -- -- should not have blank lines after it -- deriving (Eq, Ord, Show) -- --------------------------------------------------------------------- declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GhcPs -> b #if __GLASGOW_HASKELL__ > 804 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.SpliceD _ d -> f (GHC.L l d) GHC.DocD _ d -> f (GHC.L l d) GHC.RoleAnnotD _ d -> f (GHC.L l d) GHC.XHsDecl _ -> error "declFun:XHsDecl" #else 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 #endif -- --------------------------------------------------------------------- -- Duplicated here so it can be used in show instances showGhc :: (GHC.Outputable a) => a -> String showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/src/Language/Haskell/GHC/ExactPrint/Utils.hs0000644000000000000000000005345707346545000022661 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Language.Haskell.GHC.ExactPrint.Utils ( -- * Manipulating Positons ss2pos , ss2posEnd , undelta , isPointSrcSpan , pos2delta , ss2delta , addDP , spanLength , isGoodDelta -- * Manipulating Comments , mkComment , mkKWComment , dpFromString , comment2dp , extractComments -- * GHC Functions , srcSpanStartLine , srcSpanEndLine , srcSpanStartColumn , srcSpanEndColumn , rdrName2String , isSymbolRdrName , tokComment , isListComp , isGadt , isExactName -- * Manipulating Annotations , getAnnotationEP , annTrueEntryDelta , annCommentEntryDelta , annLeadingCommentEntryDelta -- * General Utility , orderByKey -- * AST Context management , setAcs, setAcsWithLevel , unsetAcs , inAcs , pushAcs , bumpAcs #if __GLASGOW_HASKELL__ <= 710 -- * for boolean formulas in GHC 7.10.3 -- ,LBooleanFormula, BooleanFormula(..) , makeBooleanFormulaAnns #endif -- * For tests , debug , debugP , debugM , warn , showGhc , showAnnData , occAttributes , showSDoc_, showSDocDebug_ -- AZ's baggage , ghead,glast,gtail,gfromJust ) where import Control.Monad.State import qualified Data.ByteString as B import Data.Generics import Data.Ord (comparing) import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Lookup import qualified Bag as GHC #if __GLASGOW_HASKELL__ <= 710 import qualified BooleanFormula as GHC #endif import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC import qualified Name as GHC import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC import qualified SrcLoc as GHC import qualified Var as GHC import qualified OccName(OccName(..),occNameString,pprNameSpaceBrief) import Control.Arrow import qualified Data.Map as Map import qualified Data.Set as Set import Data.List import Debug.Trace {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- |Global switch to enable debug tracing in ghc-exactprint Delta / Print debugEnabledFlag :: Bool -- debugEnabledFlag = True debugEnabledFlag = False -- |Global switch to enable debug tracing in ghc-exactprint Pretty debugPEnabledFlag :: Bool -- debugPEnabledFlag = True debugPEnabledFlag = False -- |Provide a version of trace that comes at the end of the line, so it can -- easily be commented out when debugging different things. debug :: c -> String -> c debug c s = if debugEnabledFlag then trace s c else c -- |Provide a version of trace for the Pretty module, which can be enabled -- separately from 'debug' and 'debugM' debugP :: String -> c -> c debugP s c = if debugPEnabledFlag then trace s c else c 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 from the current position to the start of the given -- @SrcSpan@. ss2delta :: Pos -> GHC.SrcSpan -> DeltaPos 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@ pos2delta :: Pos -> Pos -> DeltaPos pos2delta (refl,refc) (l,c) = DP (lo,co) where lo = l - refl co = if lo == 0 then c - refc else c -- | Apply the delta to the current position, taking into account the -- current column offset if advancing to a new line undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos undelta (l,c) (DP (dl,dc)) (LayoutStartCol co) = (fl,fc) where fl = l + dl fc = if dl == 0 then c + dc else co + dc -- | 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) -- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the -- remaining delta for the second after the first has been applied. -- invariant : if c = a `addDP` b -- then a `stepDP` c == b -- -- Cases where first DP is <= than second -- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1) -- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0) -- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1) -- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4) -- -- Cases where first DP is > than second -- > DP (0, 3) `addDP` DP (0, 2) == DP (0,1) -- advance one at least -- > DP (3, 3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col -- > DP (3, 3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least -- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col stepDP :: DeltaPos -> DeltaPos -> DeltaPos stepDP (DP (a,b)) (DP (c,d)) | (a,b) == (c,d) = DP (a,b) | a == c = if b < d then DP (0,d - b) else if d == 0 then DP (1,0) -- else DP (0,1) else DP (c,d) | a < c = DP (c - a,d) | otherwise = DP (1,d) -- --------------------------------------------------------------------- ss2pos :: GHC.SrcSpan -> Pos ss2pos ss = (srcSpanStartLine ss,srcSpanStartColumn ss) ss2posEnd :: GHC.SrcSpan -> Pos ss2posEnd ss = (srcSpanEndLine ss,srcSpanEndColumn ss) srcSpanEndColumn :: GHC.SrcSpan -> Int srcSpanEndColumn (GHC.RealSrcSpan s) = GHC.srcSpanEndCol s srcSpanEndColumn _ = 0 srcSpanStartColumn :: GHC.SrcSpan -> Int srcSpanStartColumn (GHC.RealSrcSpan s) = GHC.srcSpanStartCol s srcSpanStartColumn _ = 0 srcSpanEndLine :: GHC.SrcSpan -> Int srcSpanEndLine (GHC.RealSrcSpan s) = GHC.srcSpanEndLine s srcSpanEndLine _ = 0 srcSpanStartLine :: GHC.SrcSpan -> Int srcSpanStartLine (GHC.RealSrcSpan s) = GHC.srcSpanStartLine s srcSpanStartLine _ = 0 spanLength :: GHC.SrcSpan -> Int spanLength = (-) <$> srcSpanEndColumn <*> srcSpanStartColumn -- --------------------------------------------------------------------- -- | Checks whether a SrcSpan has zero length. isPointSrcSpan :: GHC.SrcSpan -> Bool isPointSrcSpan ss = spanLength ss == 0 && srcSpanStartLine ss == srcSpanEndLine 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] -> [(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 = sortBy (comparing (flip elemIndex order . fst)) keys -- --------------------------------------------------------------------- isListComp :: GHC.HsStmtContext name -> Bool isListComp cts = case cts of GHC.ListComp -> True GHC.MonadComp -> True #if __GLASGOW_HASKELL__ <= 804 GHC.PArrComp -> True #endif GHC.DoExpr -> False GHC.MDoExpr -> False GHC.ArrowExpr -> False GHC.GhciStmtCtxt -> False GHC.PatGuard {} -> False GHC.ParStmtCtxt {} -> False GHC.TransStmtCtxt {} -> False -- --------------------------------------------------------------------- isGadt :: [GHC.LConDecl name] -> Bool isGadt [] = False #if __GLASGOW_HASKELL__ <= 710 isGadt (GHC.L _ GHC.ConDecl{GHC.con_res=GHC.ResTyGADT _ _}:_) = True #else isGadt ((GHC.L _ (GHC.ConDeclGADT{})):_) = True #endif isGadt _ = False -- --------------------------------------------------------------------- -- Is a RdrName of type Exact? SYB query, so can be extended to other types too isExactName :: (Data name) => name -> Bool isExactName = False `mkQ` GHC.isExact -- --------------------------------------------------------------------- ghcCommentText :: GHC.Located GHC.AnnotationComment -> String ghcCommentText (GHC.L _ (GHC.AnnDocCommentNext s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocCommentPrev s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocCommentNamed s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocSection _ s)) = s ghcCommentText (GHC.L _ (GHC.AnnDocOptions s)) = s #if __GLASGOW_HASKELL__ < 801 ghcCommentText (GHC.L _ (GHC.AnnDocOptionsOld s)) = s #endif ghcCommentText (GHC.L _ (GHC.AnnLineComment 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 extractComments :: GHC.ApiAnns -> [Comment] extractComments (_,cm) -- cm has type :: Map SrcSpan [Located AnnotationComment] = map tokComment . GHC.sortLocated . concat $ Map.elems cm #if __GLASGOW_HASKELL__ > 806 getAnnotationEP :: (Data a,Data (GHC.SrcSpanLess a),GHC.HasSrcSpan a) => a -> Anns -> Maybe Annotation #else getAnnotationEP :: (Data a) => GHC.Located a -> Anns -> Maybe Annotation #endif 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 -- | Take an annotation and a required "true entry" and calculate an equivalent -- one relative to the last comment in the annPriorComments. annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos annCommentEntryDelta Ann{annPriorComments} trueDP = dp where commentDP = foldr addDP (DP (0,0)) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) dp = stepDP commentDP trueDP -- | Return the DP of the first item that generates output, either a comment or the entry DP annLeadingCommentEntryDelta :: Annotation -> DeltaPos annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp where dp = case annPriorComments of [] -> annEntryDelta ((_,ed):_) -> ed -- | Calculates the distance from the start of a string to the end of -- a string. dpFromString :: String -> DeltaPos dpFromString xs = dpFromString' xs 0 0 where dpFromString' "" line col = DP (line, col) dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0 dpFromString' (_:cs) line col = dpFromString' cs line (col + 1) -- --------------------------------------------------------------------- isSymbolRdrName :: GHC.RdrName -> Bool isSymbolRdrName n = GHC.isSymOcc $ GHC.rdrNameOcc n rdrName2String :: GHC.RdrName -> String rdrName2String r = case GHC.isExact_maybe r of Just n -> name2String n Nothing -> case r of GHC.Unqual occ -> GHC.occNameString occ GHC.Qual modname occ -> GHC.moduleNameString modname ++ "." ++ GHC.occNameString occ GHC.Orig _ occ -> GHC.occNameString occ GHC.Exact n -> GHC.getOccString n name2String :: GHC.Name -> String name2String = showGhc -- --------------------------------------------------------------------- -- | Put the provided context elements into the existing set with fresh level -- counts setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet setAcs ctxt acs = setAcsWithLevel ctxt 3 acs -- | Put the provided context elements into the existing set with given level -- counts -- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet -- setAcsWithLevel ctxt level (ACS a) = ACS a' -- where -- upd s (k,v) = Map.insert k v s -- a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a setAcsWithLevel ctxt level (ACS a) = ACS a' where upd s (k,v) = Map.insert k v s a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) -- --------------------------------------------------------------------- -- | Remove the provided context element from the existing set -- unsetAcs :: AstContext -> AstContextSet -> AstContextSet unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a -- --------------------------------------------------------------------- -- | Are any of the contexts currently active? -- inAcs :: Set.Set AstContext -> AstContextSet -> Bool inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a) -- | propagate the ACS down a level, dropping all values which hit zero -- pushAcs :: AstContextSet -> AstContextSet pushAcs :: ACS' a -> ACS' a pushAcs (ACS a) = ACS $ Map.mapMaybe f a where f n | n <= 1 = Nothing | otherwise = Just (n - 1) -- |Sometimes we have to pass the context down unchanged. Bump each count up by -- one so that it is unchanged after a @pushAcs@ call. -- bumpAcs :: AstContextSet -> AstContextSet bumpAcs :: ACS' a -> ACS' a bumpAcs (ACS a) = ACS $ Map.mapMaybe f a where f n = Just (n + 1) -- --------------------------------------------------------------------- #if __GLASGOW_HASKELL__ <= 710 -- to be called in annotationsToCommentsBF by the pretty printer makeBooleanFormulaAnns :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] makeBooleanFormulaAnns bf = go 1 bf where go :: (GHC.Outputable a) => Int -> GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId,GHC.SrcSpan)] go _ (GHC.Var _) = [] go l v@(GHC.And [a,b]) = go 3 a ++ go 3 b ++ (if l > 3 then addParensIfNeeded v else []) ++ [(GHC.AnnComma, ssAfter (getBoolSrcSpan a))] go l v@(GHC.Or [a,b]) = go 2 a ++ go 2 b ++ (if l > 2 then addParensIfNeeded v else []) ++ [(GHC.AnnVbar, ssAfter (getBoolSrcSpan a) )] go _ x = error $ "makeBooleanFormulaAnns: unexpected case:" ++ showGhc x addParensIfNeeded :: GHC.Outputable a => GHC.BooleanFormula (GHC.Located a) -> [(GHC.AnnKeywordId, GHC.SrcSpan)] addParensIfNeeded (GHC.Var _) = [] addParensIfNeeded a = [(GHC.AnnOpenP,opp),(GHC.AnnCloseP,cpp)] where ss = getBoolSrcSpan a opp = ssBefore ss cpp = ssAfter ss -- ssFor a b = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) -- | Generate a SrcSpan of single char length before the given one ssBefore :: GHC.SrcSpan -> GHC.SrcSpan ssBefore a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) where GHC.RealSrcLoc as = GHC.srcSpanStart a s = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 2) e = GHC.mkRealSrcLoc (GHC.srcLocFile as) (GHC.srcLocLine as) (GHC.srcLocCol as - 1) -- | Generate a SrcSpan of single char length after the given one ssAfter :: GHC.SrcSpan -> GHC.SrcSpan ssAfter a = GHC.mkSrcSpan (GHC.RealSrcLoc s) (GHC.RealSrcLoc e) where GHC.RealSrcLoc ae = GHC.srcSpanEnd a s = ae e = GHC.advanceSrcLoc s ' ' getBoolSrcSpan :: (GHC.Outputable a) => GHC.BooleanFormula (GHC.Located a) -> GHC.SrcSpan getBoolSrcSpan (GHC.Var (GHC.L ss _)) = ss getBoolSrcSpan (GHC.And [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) getBoolSrcSpan (GHC.Or [a,b]) = GHC.combineSrcSpans (getBoolSrcSpan a) (getBoolSrcSpan b) getBoolSrcSpan x = error $ "getBoolSrcSpan: unexpected case:" ++ showGhc x #endif -- --------------------------------------------------------------------- -- | Show a GHC AST with interleaved Annotation information. showAnnData :: Data a => Anns -> Int -> a -> String showAnnData anns n = generic -- `ext1Q` located `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon -- `extQ` overLit `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located where generic :: Data a => a -> String generic t = indent n ++ "(" ++ showConstr (toConstr t) ++ space (unwords (gmapQ (showAnnData anns (n+1)) t)) ++ ")" space "" = "" space s = ' ':s indent i = "\n" ++ replicate i ' ' string = show :: String -> String fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String bytestring = show :: B.ByteString -> String list l = indent n ++ "[" ++ intercalate "," (map (showAnnData anns (n+1)) l) ++ "]" name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String -- occName = ("{OccName: "++) . (++"}") . OccName.occNameString occName o = "{OccName: "++ OccName.occNameString o ++ " " ++ occAttributes o ++ "}" moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String -- srcSpan = ("{"++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.SrcSpan -> String srcSpan :: GHC.SrcSpan -> String srcSpan ss = "{ "++ showSDoc_ (GHC.hang (GHC.ppr ss) (n+2) -- (GHC.ppr (Map.lookup ss anns) (GHC.text "") ) ++"}" var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String -- overLit :: GHC.HsOverLit GHC.RdrName -> String -- overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList bagName :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList #if __GLASGOW_HASKELL__ > 800 nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable #else nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems #endif fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String located :: (Data b,Data loc) => GHC.GenLocated loc b -> String -- located la = show (getAnnotationEP la anns) located (GHC.L ss a) = indent n ++ "(" ++ case cast ss of Just (s :: GHC.SrcSpan) -> srcSpan s ++ indent (n + 1) ++ show (getAnnotationEP (GHC.L s a) anns) -- ++ case showWrappedDeclAnns (GHC.L s a) of -- Nothing -> "" -- Just annStr -> indent (n + 1) ++ annStr Nothing -> "nnnnnnnn" ++ showAnnData anns (n+1) a ++ ")" occAttributes :: OccName.OccName -> String occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" where ns = (GHC.showSDocUnsafe $ OccName.pprNameSpaceBrief $ GHC.occNameSpace o) ++ ", " vo = if GHC.isVarOcc o then "Var " else "" tv = if GHC.isTvOcc o then "Tv " else "" tc = if GHC.isTcOcc o then "Tc " else "" d = if GHC.isDataOcc o then "Data " else "" ds = if GHC.isDataSymOcc o then "DataSym " else "" s = if GHC.isSymOcc o then "Sym " else "" v = if GHC.isValOcc o then "Val " else "" {- data NameSpace = VarName -- Variables, including "real" data constructors | DataName -- "Source" data constructors | TvName -- Type variables | TcClsName -- Type constructors and classes; Haskell has them -- in the same name space for now. -} -- --------------------------------------------------------------------- showSDoc_ :: GHC.SDoc -> String showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags showSDocDebug_ :: GHC.SDoc -> String #if __GLASGOW_HASKELL__ <= 710 showSDocDebug_ = GHC.showSDoc GHC.unsafeGlobalDynFlags #else showSDocDebug_ = GHC.showSDocDebug GHC.unsafeGlobalDynFlags #endif -- --------------------------------------------------------------------- -- 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" ghc-exactprint-0.6.2/tests/0000755000000000000000000000000007346545000013772 5ustar0000000000000000ghc-exactprint-0.6.2/tests/PrepareHackage.hs0000644000000000000000000001273007346545000017173 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- import Data.Char import Data.Monoid import System.Directory import System.FilePath.Posix import System.IO import Test.CommonUtils import Turtle hiding (FilePath,(<.>)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T import qualified GHC.IO.Handle.Text as GHC import Test.HUnit main :: IO () main = do packages <- allCabalPackages -- packages <- allCabalPackagesTest myecho (T.pack $ "number of packages:" ++ (show $ length packages)) packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir let cond c = c == '.' || c == '-' || isDigit c let packageDirs = map (T.dropWhileEnd cond . T.pack) packageDirsFull isBadPackages <- doesFileExist badpackagesFile badPackages <- if isBadPackages then T.lines <$> T.readFile badpackagesFile else return [] let alreadyUnpacked = Set.fromList $ packageDirs ++ badPackages _ <- shell ("mkdir -p " <> (T.pack hackageWorkDir)) empty mapM_ (preparePackage alreadyUnpacked) packages -- --------------------------------------------------------------------- preparePackage :: Set.Set Text -> Text -> IO () preparePackage alreadyUnpacked package = do myecho $ "preparePackage:" <> package if Set.member package alreadyUnpacked then myecho $ "already unpacked:" <> package else preparePackage' package preparePackage' :: Text -> IO () preparePackage' package = do (ec,dir) <- shellStrict ("cabal get --destdir=" <> T.pack hackageWorkDir <> " " <> package) empty -- myecho (T.pack $ "cabal get:" ++ show dir) myecho (T.pack $ show ec) when (ec == ExitSuccess) $ do let bits = T.splitOn " " (head $ T.lines dir) myecho (T.pack $ "cabal get:dir=" ++ show (last bits)) cleanPackage (last bits) return () -- --------------------------------------------------------------------- -- |Clean up whitespace in a package cleanPackage :: Text -> IO () cleanPackage dir = do myecho ("cleaning:" <> dir) fs <- findSrcFiles (T.unpack dir) let doOne :: FilePath -> IO () doOne fn = do myecho ("doOne:" <> T.pack fn) let tmpFn = fn <.> "clean" clean <- cleanupWhiteSpace fn writeFile tmpFn clean removeFile fn renameFile tmpFn fn return () mapM_ doOne fs myecho ("cleaned up:" <> dir) -- --------------------------------------------------------------------- -- | The computation 'writeFile' @file str@ function writes the string @str@, -- to the file @file@. writeFileUtf8 :: FilePath -> String -> IO () writeFileUtf8 ff txt = withFile ff WriteMode (\ hdl -> hSetEncoding hdl utf8 >> GHC.hPutStr hdl txt) -- --------------------------------------------------------------------- allCabalPackagesTest :: IO [Text] allCabalPackagesTest = return ["3d-graphics-examples","3dmodels","4Blocks","AAI","ABList"] -- = return ["airship"] allCabalPackages :: IO [Text] allCabalPackages = do -- let cmd = "cabal list --simple-output | awk '{ print $1 }' | uniq" let cmd = "cabal list --simple-output | awk '{ print $1 }' | sort | uniq" (_ec,r) <- shellStrict cmd empty let packages = T.lines r myecho (T.pack $ show $ take 5 packages) return packages -- --------------------------------------------------------------------- -- |strip trailing whitespace, and turn tabs into spaces cleanupWhiteSpace :: FilePath -> IO String cleanupWhiteSpace file = do contents <- readFileGhc file let cleaned = map cleanupOneLine (lines $ contents) return (unlines cleaned) tabWidth :: Int tabWidth = 8 nonBreakingSpace :: Char nonBreakingSpace = '\xa0' cleanupOneLine :: String -> String cleanupOneLine str = str' where numSpacesForTab n = tabWidth - (n `mod` tabWidth) -- loop over the line, keeping current pos. Where a tab is found, insert -- spaces until the next tab stop. Discard any trailing whitespace. go col res cur = case cur of [] -> res ('\t':cur') -> go (col + toAdd) ((replicate toAdd ' ') ++ res) cur' where toAdd = numSpacesForTab col ('\xa0':cur') -> go (col + 1) (' ':res) cur' -- convert ISO 8859-16 euro symbol to the UTF8 equivalent -- ('\xa4':cur') -> go (col + 1) ('\x20ac':res) cur' (c:cur') ->go (col + 1) (c:res) cur' str1 = go 0 [] str str' = reverse $ dropWhile isSpace str1 -- --------------------------------------------------------------------- tt :: IO Counts tt = runTestTT $ TestList [ testCleanupOneLine , testTabs ] testCleanupOneLine :: Test testCleanupOneLine = do let makeCase n = (show n ,(replicate n ' ') <> "\t|" <> replicate n ' ' <> "\t" ,(replicate 8 ' ' <> "|")) mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp) where (name,inp,outp) = makeCase n testList "cleanupOneLine" $ map mkTest [1..7] testTabs :: Test testTabs = TestCase $ assertEqual "testTabs" t2tabsExpected (cleanupOneLine t2tabs) where t2tabs = "import Data.Foldable\t\t ( foldMap )" t2tabsExpected ="import Data.Foldable ( foldMap )" testList :: String -> [Test] -> Test testList str ts = TestLabel str (TestList ts) -- --------------------------------------------------------------------- myecho :: T.Text -> IO () myecho t = mapM_ echo (textToLines t) -- --------------------------------------------------------------------- pwd :: IO FilePath pwd = getCurrentDirectory mcd :: FilePath -> IO () mcd = setCurrentDirectory ghc-exactprint-0.6.2/tests/Roundtrip.hs0000644000000000000000000001155607346545000016324 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Main where import Control.Exception import Control.Monad import Data.Time.Clock import Data.Time.Format import Debug.Trace import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO -- import System.IO.Temp import Test.Common import Test.CommonUtils import Test.HUnit import qualified Data.Set as S -- --------------------------------------------------------------------- data Verbosity = Debug | Status | None deriving (Eq, Show, Ord, Enum) verb :: Verbosity verb = Debug -- --------------------------------------------------------------------- writeCPP :: FilePath -> IO () writeCPP fp = appendFileFlush cppFile (('\n' : fp)) writeError :: FilePath -> IO () writeError = writeCPP writeParseFail :: FilePath -> String -> IO () writeParseFail fp _s = appendFileFlush parseFailFile (('\n' : fp)) -- writeParseFail fp s = appendFileFlush parseFailFile (('\n' : (fp ++ " " ++ s))) writeProcessed :: FilePath -> IO () writeProcessed fp = appendFileFlush processed (('\n' : fp)) writeFailed :: FilePath -> IO () writeFailed fp = appendFileFlush processedFailFile (('\n' : fp)) writeLog :: String -> IO () writeLog msg = appendFileFlush logFile (('\n' : msg)) getTimeStamp :: IO String getTimeStamp = do t <- getCurrentTime return $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H%M%S")) t writeFailure :: FilePath -> String -> IO () writeFailure fp db = do ts <- getTimeStamp let outname = failuresDir takeFileName fp <.> ts <.> "out" writeFile outname db appendFileFlush :: FilePath -> String -> IO () appendFileFlush f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt >> hFlush hdl) -- --------------------------------------------------------------------- readFileIfPresent :: FilePath -> IO [String] readFileIfPresent fileName = do isPresent <- doesFileExist fileName if isPresent then lines <$> readFile fileName else return [] -- --------------------------------------------------------------------- main :: IO () main = do createDirectoryIfMissing True workDir createDirectoryIfMissing True configDir createDirectoryIfMissing True failuresDir as <- getArgs case as of [] -> putStrLn "Must enter directory to process" ["failures"] -> do fs <- lines <$> readFile origFailuresFile () <$ runTests (TestList (map mkParserTest fs)) ["clean"] -> do putStrLn "Cleaning..." writeFile processed "" writeFile parseFailFile "" writeFile cppFile "" writeFile logFile "" writeFile processedFailFile "" removeDirectoryRecursive failuresDir createDirectory failuresDir putStrLn "Done." -- ds -> () <$ (runTests =<< (TestList <$> mapM tests ds)) ds -> do !blackList <- readFileIfPresent blackListed !knownFailures <- readFileIfPresent knownFailuresFile !processedList <- lines <$> readFile processed !cppList <- lines <$> readFile cppFile !parseFailList <- lines <$> readFile parseFailFile let done = S.fromList (processedList ++ cppList ++ blackList ++ knownFailures ++ parseFailList) tsts <- TestList <$> mapM (tests done) ds _ <- runTests tsts return () runTests :: Test -> IO Counts runTests t = do let n = testCaseCount t putStrLn $ "Running " ++ show n ++ " tests." putStrLn $ "Verbosity: " ++ show verb runTestTT t tests :: S.Set String -> FilePath -> IO Test tests done dir = do roundTripHackage done dir -- Selection: -- Hackage dir roundTripHackage :: S.Set String -> FilePath -> IO Test roundTripHackage done hackageDir = do packageDirs <- drop 2 <$> getDirectoryContents hackageDir when (verb <= Debug) (traceShowM 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 = TestLabel fp $ TestCase (do writeLog $ "starting:" ++ fp r1 <- catchAny (roundTripTest fp) $ \e -> do writeError fp throwIO e case r1 of Left (ParseFailure _ s) -> do writeParseFail fp s exitFailure Right r -> do writeProcessed fp unless (status r == Success) (writeFailure fp (debugTxt r) >> writeFailed fp) assertBool fp (status r == Success)) catchAny :: IO a -> (SomeException -> IO a) -> IO a catchAny = Control.Exception.catch ghc-exactprint-0.6.2/tests/Static.hs0000644000000000000000000000603207346545000015556 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} module Main where -- Static site generator for failing tests import Data.Algorithm.Diff (getGroupedDiff) import Data.Algorithm.DiffOutput (ppDiff) import System.Directory import System.FilePath import Test.CommonUtils import Control.Monad import Debug.Trace import Data.List import System.Environment import Data.Maybe import Text.Read main :: IO () main = do createDirectoryIfMissing True failuresHtmlDir 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 (failuresDir ) . take n <$> getDirectoryContents failuresDir) traceShowM failPaths fails <- mapM parseFail failPaths writeFile origFailuresFile (intercalate "\n" (map getfname fails)) -- writeFile "failures/failures.html" (makeIndex failPaths) writeFile (failuresHtmlDir failuresHtmlFile) (makeIndex failPaths) let padded = failuresHtmlFile : (map makeFailLink failPaths ++ [failuresHtmlFile]) 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 "
" (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 lres = lines res let maxLines = 50000 let diff = getGroupedDiff (lines original) (take maxLines lres) let l = length lres if (l > maxLines) then do -- putStrLn ("Skipping: " ++ fname) >> print l let resTrunc = (intercalate "\n" $ take maxLines lres) ++ "\n*****************TRUNCATED*******" writeFile (failuresHtmlDir out) (mkPage fname (ppDiff diff) prev next original resTrunc) else -- writeFile ("failures" out) (mkPage (ppDiff diff) prev next original res) writeFile (failuresHtmlDir out) (mkPage fname (ppDiff diff) prev next original res) mkPage :: FilePath -> String -> String -> String -> String -> String -> String mkPage filename diff prev next original printed = intercalate "
" [mkLink prev "prev" , mkLink failuresHtmlFile "home" , mkLink next "next" , "" , "
" ++ filename ++ "
" , "" , "
" ++ diff ++ "
" , "

original

" , "
" ++ original ++ "
" , "

printed

" , "
" ++ printed ++ "
" ] mkLink :: String -> String -> String mkLink s label = "" ++ label ++ "" data Failure = Failure String FilePath getfname :: Failure -> 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) ghc-exactprint-0.6.2/tests/Test.hs0000644000000000000000000002075307346545000015254 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests. module Main where -- import Language.Haskell.GHC.ExactPrint.Utils ( showGhc ) import Control.Monad import System.Directory import System.FilePath import System.IO import System.Exit import Data.List import qualified Data.Set as Set import System.IO.Silently import Test.Common import Test.NoAnnotations import Test.Transform import Test.HUnit -- import Debug.Trace -- --------------------------------------------------------------------- data GHCVersion = GHC710 | GHC80 | GHC82 | GHC84 | GHC86 | GHC88 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion ghcVersion = #if __GLASGOW_HASKELL__ > 806 GHC88 #elif __GLASGOW_HASKELL__ > 804 GHC86 #elif __GLASGOW_HASKELL__ > 802 GHC84 #elif __GLASGOW_HASKELL__ > 800 GHC82 #elif __GLASGOW_HASKELL__ >= 711 GHC80 #else GHC710 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of GHC710 -> ["ghc710-only","ghc710", "vect"] GHC80 -> [ "ghc710", "ghc80", "vect"] GHC82 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "vect"] GHC84 -> ["pre-ghc86", "ghc710", "ghc80", "ghc82", "ghc84", "vect" ] GHC86 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86" ] GHC88 -> [ "ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88" ] -- GHC88 -> ["ghc88"] -- GHC88 -> ["ghc88-copied"] -- --------------------------------------------------------------------- main :: IO () main = hSilence [stderr] $ do print ghcVersion tests <- mkTests cnts <- fst <$> runTestText (putTextToHandle stdout True) tests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure else return () -- exitSuccess transform :: IO () transform = hSilence [stderr] $ do cnts <- fst <$> runTestText (putTextToHandle stdout True) transformTests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure else return () -- exitSuccess -- --------------------------------------------------------------------- findTests :: IO Test findTests = testList "Round-trip tests" <$> mapM (findTestsDir id mkParserTest) testDirs findPrettyTests :: IO Test findPrettyTests = testList "Default Annotations round-trip tests" <$> mapM (findTestsDir filterPrettyRoundTrip mkPrettyRoundtrip) testDirs -- | Filter out tests that are known to fail, for particular compilers filterPrettyRoundTrip :: [FilePath] -> [FilePath] filterPrettyRoundTrip fps = sort $ Set.toList $ Set.difference (Set.fromList fps) skipped -- filterPrettyRoundTrip fps = error $ "filterPrettyRoundTrip:fps=" ++ show fps where #if __GLASGOW_HASKELL__ > 800 -- GHC 8.2 skipped = Set.empty #elif __GLASGOW_HASKELL__ >= 711 -- GHC 8.0 skipped = Set.fromList [ -- testPrefix "ghc80" "MultiQuote.hs" "MultiQuote.hs" , "TestUtils.hs" , "T10689a.hs" , "Zwaluw.hs" , "determ004.hs" ] #else -- GHC 7.10 skipped = Set.empty #endif findTestsDir :: ([FilePath] -> [FilePath]) -> (FilePath -> FilePath -> Test) -> FilePath -> IO Test findTestsDir filterFn mkTestFn dir = do let fp = testPrefix dir fs <- getDirectoryContents fp let testFiles = sort $ filter (".hs" `isSuffixOf`) fs return $ testList dir (map (\fn -> TestLabel fn (mkTestFn dir fn)) $ filterFn testFiles) listTests :: IO () listTests = do let ftd dir = do let fp = testPrefix dir fs <- getDirectoryContents fp let testFiles = sort $ filter (".hs" `isSuffixOf`) fs return (zip [0::Integer ..] testFiles) files <- mapM ftd testDirs putStrLn $ "round trip tests:" ++ show (zip testDirs files) mkTests :: IO Test mkTests = do -- listTests roundTripTests <- findTests prettyRoundTripTests <- findPrettyTests return $ TestList [ internalTests, roundTripTests , transformTests , failingTests , noAnnotationTests , prettyRoundTripTests ] -- Tests that will fail until https://phabricator.haskell.org/D907 lands in a -- future GHC failingTests :: Test failingTests = testList "Failing tests" [ -- Tests requiring future GHC modifications mkTestModBad "InfixOperator.hs" #if __GLASGOW_HASKELL__ > 802 #elif __GLASGOW_HASKELL__ > 800 , mkTestModBad "overloadedlabelsrun04.hs" #elif __GLASGOW_HASKELL__ > 710 , mkTestModBad "overloadedlabelsrun04.hs" , mkTestModBad "TensorTests.hs" -- Should be fixed in GHC 8.2 , mkTestModBad "List2.hs" -- Should be fixed in GHC 8.2 #else , mkTestModBad "CtorOp.hs" -- Should be fixed in GHC 8.4 , mkTestModBad "UnicodeSyntax.hs" , mkTestModBad "UnicodeRules.hs" , mkTestModBad "Deprecation.hs" , mkTestModBad "MultiLineWarningPragma.hs" #endif ] mkParserTest :: FilePath -> FilePath -> Test mkParserTest dir fp = mkParsingTest roundTripTest dir fp -- --------------------------------------------------------------------- formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO () formatTT (ts, fs) = do when (not . null $ tail ts) (do putStrLn "Pass" mapM_ (putStrLn . fst) (tail ts) ) when (not . null $ fs) (do putStrLn "Fail" mapM_ (putStrLn . fst) fs) tr :: IO (Counts,Int) tr = hSilence [stderr] $ do prettyRoundTripTests <- findPrettyTests runTestText (putTextToHandle stdout True) prettyRoundTripTests tt' :: IO (Counts,Int) tt' = runTestText (putTextToHandle stdout True) $ TestList [ -- mkPrettyRoundtrip "ghc86" "dynamic-paper.hs" -- mkPrettyRoundtrip "ghc86" "mdo.hs" -- mkParserTest "ghc88" "DumpParsedast.hs" -- mkParserTest "ghc88-copied" "T15365.hs" -- mkPrettyRoundtrip "ghc88-copied" "T15365.hs" -- mkParserTest "ghc88-copied" "T4437.hs" -- mkParserTest "ghc88-copied" "TH_recover_warns.hs" -- mkPrettyRoundtrip "ghc88-copied" "TH_recover_warns.hs" -- mkParserTest "ghc88-copied" "TH_recursiveDoImport.hs" -- mkPrettyRoundtrip "ghc88-copied" "TH_recursiveDoImport.hs" -- mkParserTest "ghc88-copied" "dsrun010.hs" -- mkPrettyRoundtrip "ghc88-copied" "dsrun010.hs" -- mkParserTest "ghc88" "Internal.hs" -- mkParserTest "ghc88" "Main.hs" mkParserTest "ghc88" "PersistUniqueTest.hs" -- --------------------------------------------------------------- -- mkParserTest "ghc710" "Roles.hs" -- --------------------------------------------------------------- -- mkParserTest "ghc86" "deriving-via-compile.hs" -- mkParserTest "ghc88" "ClassParens.hs" -- mkParserTest "pre-ghc86" "TensorTests.hs" -- , mkParserTest "pre-ghc86" "Webhook.hs" -- , mkParserTest "ghc710" "RdrNames.hs" -- mkPrettyRoundtrip "ghc86" "BinDU.hs" -- , mkPrettyRoundtrip "ghc86" "Dial.hs" -- mkParserTest "ghc84" "Types.hs" -- , mkPrettyRoundtrip "ghc80" "export-type.hs" -- Needs GHC changes -- mkParserTest "failing" "CtorOp.hs" -- mkParserTest "failing" "InfixOperator.hs" ] testsTT :: Test testsTT = TestList [ mkParserTest "ghc710" "Cpp.hs" , mkParserTest "ghc710" "DroppedDoSpace.hs" ] tt :: IO () -- tt = hSilence [stderr] $ do tt = do cnts <- fst <$> runTestText (putTextToHandle stdout True) testsTT putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure else return () -- exitSuccess -- --------------------------------------------------------------------- ii :: IO () ii = do cnts <- fst <$> runTestText (putTextToHandle stdout True) internalTests putStrLn $ show cnts if errors cnts > 0 || failures cnts > 0 then exitFailure else return () -- exitSuccess internalTests :: Test internalTests = testList "Internal tests" [ -- testCleanupOneLine ] {- testCleanupOneLine :: Test testCleanupOneLine = do let makeCase n = (show n ,(T.replicate n " ") <> "\t|" <> T.replicate n " " <> "\t" ,(T.replicate 8 " " <> "|")) mkTest n = TestCase $ assertEqual name outp (cleanupOneLine inp) where (name,inp,outp) = makeCase n testList "cleanupOneLine" $ map mkTest [1..7] -} -- --------------------------------------------------------------------- pwd :: IO FilePath pwd = getCurrentDirectory cd :: FilePath -> IO () cd = setCurrentDirectory ghc-exactprint-0.6.2/tests/Test/0000755000000000000000000000000007346545000014711 5ustar0000000000000000ghc-exactprint-0.6.2/tests/Test/Common.hs0000644000000000000000000001633307346545000016503 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Test.Common ( RoundtripReport (..) , Report , ParseFailure(..) , ReportType(..) , roundTripTest , mkParsingTest , getModSummaryForFile , testList , testPrefix , Changer , genTest , noChange , mkDebugOutput ) where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCpp) import Language.Haskell.GHC.ExactPrint.Preprocess import Language.Haskell.GHC.ExactPrint.Types import qualified ApiAnnotation as GHC import qualified DynFlags as GHC -- import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) -- import qualified Lexer as GHC import qualified MonadUtils as GHC -- import qualified Parser as GHC -- import qualified SrcLoc as GHC -- import qualified StringBuffer as GHC #if __GLASGOW_HASKELL__ <= 710 #else import qualified GHC.LanguageExtensions as LangExt #endif -- import qualified Data.Map as Map import Control.Monad import Data.List hiding (find) import System.Directory import Test.Consistency import Test.HUnit import System.FilePath -- import Debug.Trace testPrefix :: FilePath testPrefix = "tests" "examples" testList :: String -> [Test] -> Test testList s ts = TestLabel s (TestList ts) -- --------------------------------------------------------------------- -- 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 GhcPs)) 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}) -} roundTripTest :: FilePath -> IO Report roundTripTest f = genTest noChange f f mkParsingTest :: (FilePath -> IO Report) -> FilePath -> FilePath -> Test mkParsingTest tester dir fp = let basename = testPrefix dir 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 ++ basename)) id <$> tester basename writeFailure (debugTxt r) forM_ (inconsistent r) writeIncons forM_ (cppStatus r) writeHsPP assertBool fp (status r == Success)) type Changer = (Anns -> GHC.ParsedSource -> IO (Anns,GHC.ParsedSource)) noChange :: Changer noChange ans parsed = return (ans,parsed) genTest :: Changer -> FilePath -> FilePath -> IO Report genTest f origFile expectedFile = do res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile expected <- GHC.liftIO $ readFileGhc expectedFile orig <- GHC.liftIO $ readFileGhc origFile -- let pristine = removeSpaces expected let pristine = expected case res of Left (ss, m) -> return . Left $ ParseFailure ss m Right (apianns, injectedComments, dflags, pmod) -> do (printed', anns, pmod') <- GHC.liftIO (runRoundTrip f apianns pmod injectedComments) #if __GLASGOW_HASKELL__ <= 710 let useCpp = GHC.xopt GHC.Opt_Cpp dflags #else let useCpp = GHC.xopt LangExt.Cpp dflags #endif printed = trimPrinted printed' -- 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 origFile 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 orig else Nothing return $ Right Report {..} mkDebugOutput :: FilePath -> String -> String -> GHC.ApiAnns -> Anns -> GHC.ParsedSource -> 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 :: Changer -> GHC.ApiAnns -> GHC.Located (GHC.HsModule GhcPs) -> [Comment] -> IO (String, Anns, GHC.ParsedSource) runRoundTrip f !anns !parsedOrig cs = do let !relAnns = relativiseApiAnnsWithComments cs parsedOrig anns (annsMod, pmod) <- f relAnns parsedOrig let !printed = exactPrint pmod annsMod -- return (printed, relAnns, pmod) return (printed, annsMod, pmod) -- ---------------------------------------------------------------------` 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 #if __GLASGOW_HASKELL__ >= 804 cgraph <- GHC.liftIO $ canonicalizeGraph (GHC.mgModSummaries graph) #else cgraph <- GHC.liftIO $ canonicalizeGraph graph #endif let mm = filter (\(mfn,_ms) -> mfn == Just cfileName) cgraph case mm of [] -> return Nothing fs -> return (Just (snd $ head fs)) ghc-exactprint-0.6.2/tests/Test/CommonUtils.hs0000644000000000000000000000713007346545000017517 0ustar0000000000000000module Test.CommonUtils ( findSrcFiles , readFileGhc -- * File paths and directories , hackageWorkDir , workDir , configDir , failuresDir , failuresHtmlDir , cppFile , parseFailFile , processed , processedFailFile , logFile , origFailuresFile , badpackagesFile , blackListed , knownFailuresFile , failuresHtmlFile ) where import Data.List hiding (find) import System.FilePath import System.FilePath.Find import qualified StringBuffer as GHC -- --------------------------------------------------------------------- -- | Round trip working dir holding current hackage contents, can be deleted hackageWorkDir :: FilePath hackageWorkDir = "./hackage-roundtrip-work" -- --------------------------------------------------------------------- -- | Round trip working dir, can be deleted workDir :: FilePath workDir = "./roundtrip-work" -- | Round trip configuration dir, keept under version control configDir :: FilePath configDir = "./roundtrip-config" -- |Directory where results of failing tests are stored for later analysis failuresDir :: FilePath failuresDir = workDir "failures" -- |Directory where results of failing tests are provided in html format failuresHtmlDir :: FilePath failuresHtmlDir = workDir "html" -- |Generated:files known to fail due to CPP parse failures, caused by an Exception cppFile :: FilePath cppFile = workDir "cpp.txt" -- |Generated:files returning ParseFail status parseFailFile :: FilePath parseFailFile = workDir "pfail.txt" -- |Generated:files successfully processed processed :: FilePath processed = workDir "processed.txt" -- |Generated:files which failed comparison processedFailFile :: FilePath processedFailFile = workDir "failed.txt" -- |log of current file being processed, for knowing what to blacklist logFile :: FilePath logFile = workDir "roundtrip.log" -- |list of original failures, when rerunning tests after static processing origFailuresFile :: FilePath origFailuresFile = workDir "origfailures.txt" -- |name of index html page failuresHtmlFile :: FilePath failuresHtmlFile = "failures.html" -- -- |location and name of index html page -- failuresHtmlFile :: FilePath -- failuresHtmlFile = failuresHtmlDir "failures.html" -- --------------------------------------------------------------------- -- |Hand edited list of files known to segfault badpackagesFile :: FilePath badpackagesFile = configDir "badpackages.txt" -- |Hand edited list of files known to segfault blackListed :: FilePath blackListed = configDir "blacklist.txt" -- |Hand edited list of files known to fail, no fix required/possible knownFailuresFile :: FilePath knownFailuresFile = configDir "knownfailures.txt" -- --------------------------------------------------------------------- -- 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 -- --------------------------------------------------------------------- readFileGhc :: FilePath -> IO String readFileGhc file = do buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file return (GHC.lexemeToString buf len) ghc-exactprint-0.6.2/tests/Test/Consistency.hs0000644000000000000000000000155407346545000017553 0ustar0000000000000000module 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] ghc-exactprint-0.6.2/tests/Test/NoAnnotations.hs0000644000000000000000000002111307346545000020035 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Test.NoAnnotations where -- import Control.Monad.State import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import Data.Data (Data, toConstr, showConstr, cast) import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List -- import Data.Ord (comparing) import qualified Data.ByteString as B import Language.Haskell.GHC.ExactPrint -- import Language.Haskell.GHC.ExactPrint.Annotate import Language.Haskell.GHC.ExactPrint.Parsers -- import Language.Haskell.GHC.ExactPrint.Pretty import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils import qualified ApiAnnotation as GHC import qualified Bag as GHC -- import qualified DynFlags as GHC import qualified FastString as GHC import qualified GHC as GHC hiding (parseModule) -- import qualified Lexer as GHC import qualified MonadUtils as GHC -- import qualified Name as GHC import qualified NameSet as GHC -- import qualified OccName as GHC import qualified Outputable as GHC -- import qualified Parser as GHC -- import qualified RdrName as GHC import qualified SrcLoc as GHC -- import qualified StringBuffer as GHC import qualified Var as GHC import qualified OccName(occNameString) -- import qualified Data.Generics as SYB -- import qualified GHC.SYB.Utils as SYB import System.Directory import System.FilePath -- import System.FilePath.Posix -- import System.IO import qualified Data.Map as Map -- import Data.List -- import Data.Maybe import Test.Common import Test.HUnit {-# ANN module "HLint: ignore Eta reduce" #-} -- --------------------------------------------------------------------- noAnnotationTests :: Test noAnnotationTests = TestLabel "no annotation tests" $ TestList [ TestLabel "no annotations" (TestList noAnnTests) ] noAnnTests :: [Test] noAnnTests = [ ] -- --------------------------------------------------------------------- mkPrettyRoundtrip :: FilePath -> FilePath -> Test mkPrettyRoundtrip dir fp = mkParsingTest prettyRoundtripTest dir fp prettyRoundtripTest :: FilePath -> IO Report prettyRoundtripTest origFile = do res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile case res of Left (ss, m) -> return . Left $ ParseFailure ss m Right (apianns, injectedComments, _dflags, parsed) -> do res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments) case res2 of Left (ss, m) -> return . Left $ ParseFailure ss m Right (_anns', parsed') -> do let originalStructure = astStructure parsed [] roundtripStructure = astStructure parsed' [] (status,debugTxt') = if roundtripStructure == originalStructure then (Success, "ok") else (RoundTripFailure,diffText originalStructure roundtripStructure ++ sep ++ originalStructure ++ sep ++ roundtripStructure) cppStatus = Nothing inconsistent = Nothing !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns debugTxt = intercalate sep [ debugTxt' , originalStructure , roundtripStructure , showAnnData annsOrig 0 parsed ] sep = "\n=====================================\n" return $ Right Report {debugTxt,status,cppStatus,inconsistent} -- --------------------------------------------------------------------- runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource -> [Comment] -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) runPrettyRoundTrip origFile !anns !parsedOrig _cs = do let !newAnns = addAnnotationsForPretty [] parsedOrig mempty let comments = case Map.lookup GHC.noSrcSpan (snd anns) of Nothing -> [] Just cl -> map tokComment $ GHC.sortLocated cl let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments let pragmaStr = intercalate "\n" $ map commentContents pragmas let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig newAnns -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig) parseString origFile printed newAnns parsedOrig parseString :: FilePath -> String -> Anns -> GHC.ParsedSource -> IO (Either (GHC.SrcSpan, String) (Anns, GHC.ParsedSource)) parseString origFile src newAnns origParsed = do tmpDir <- getTemporaryDirectory let workDir = tmpDir "ghc-exactprint" "noannotations" -- putStrLn $ "workDir=" ++ workDir createDirectoryIfMissing True workDir let fileName = workDir takeFileName origFile writeFile (workDir takeFileName origFile <.> ".anns") (showAnnData newAnns 0 origParsed) writeFile fileName src parseModule fileName -- --------------------------------------------------------------------- diffText :: String -> String -> String diffText f1 f2 = diff where d = getGroupedDiff (lines f1) (lines f2) diff = ppDiff d -- --------------------------------------------------------------------- -- |Convert an AST with comments into a string representing the structure only -- (i.e. ignoring locations), to be used for comparisons between the original -- AST and the one after pretty-print roundtripping. -- Based on @showAnnData@ astStructure :: GHC.ParsedSource -> [Comment] -> String astStructure parsed _cs = r where r = showAstData 0 parsed -- | Show a GHC AST with interleaved Annotation information. showAstData :: Data a => Int -> a -> String showAstData n = generic -- `ext1Q` located `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan `extQ` bytestring `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon `extQ` overLit `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `extQ` fixity `ext2Q` located where generic :: Data a => a -> String generic t = indent n ++ "(" ++ showConstr (toConstr t) ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")" space "" = "" space s = ' ':s indent i = "\n" ++ replicate i ' ' string = show :: String -> String fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String bytestring = show :: B.ByteString -> String list l = indent n ++ "[" ++ intercalate "," (map (showAstData (n+1)) l) ++ "]" name = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String occName = ("{OccName: "++) . (++"}") . OccName.occNameString moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String srcSpan :: GHC.SrcSpan -> String srcSpan _ss = "{ "++ "ss" ++"}" var = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String overLit :: GHC.HsOverLit GhcPs -> String overLit = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList bagName :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList bagVar :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList #if __GLASGOW_HASKELL__ > 800 nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable #else nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems #endif fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String located :: (Data b,Data loc) => GHC.GenLocated loc b -> String located (GHC.L ss a) = indent n ++ "(" ++ case cast ss of Just (s :: GHC.SrcSpan) -> srcSpan s Nothing -> "nnnnnnnn" ++ showAstData (n+1) a ++ ")" -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/tests/Test/Transform.hs0000644000000000000000000007673607346545000017243 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Test.Transform where import Language.Haskell.GHC.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers import qualified Bag 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 qualified GHC.SYB.Utils as SYB import System.FilePath import qualified Data.Map as Map -- import Data.List import Data.Maybe import Test.Common import Test.HUnit transformTests :: Test transformTests = TestLabel "transformation tests" $ TestList [ TestLabel "Low level transformations" (TestList transformLowLevelTests) , TestLabel "High level transformations" (TestList transformHighLevelTests) ] transformLowLevelTests :: [Test] transformLowLevelTests = [ mkTestModChange changeRenameCase1 "RenameCase1.hs" , mkTestModChange changeLayoutLet2 "LayoutLet2.hs" , mkTestModChange changeLayoutLet3 "LayoutLet3.hs" , mkTestModChange changeLayoutLet3 "LayoutLet4.hs" , mkTestModChange changeRename1 "Rename1.hs" , mkTestModChange changeRename2 "Rename2.hs" , mkTestModChange changeLayoutIn1 "LayoutIn1.hs" , mkTestModChange changeLayoutIn3 "LayoutIn3.hs" , mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" , mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" , mkTestModChange changeLayoutIn4 "LayoutIn4.hs" , mkTestModChange changeLocToName "LocToName.hs" , mkTestModChange changeLetIn1 "LetIn1.hs" , mkTestModChange changeWhereIn4 "WhereIn4.hs" , mkTestModChange changeAddDecl "AddDecl.hs" , mkTestModChange changeLocalDecls "LocalDecls.hs" , mkTestModChange changeLocalDecls2 "LocalDecls2.hs" , mkTestModChange changeWhereIn3a "WhereIn3a.hs" -- , mkTestModChange changeCifToCase "C.hs" "C" ] mkTestModChange :: Changer -> FilePath -> Test mkTestModChange = mkTestMod "expected" "transform" mkTestModBad :: FilePath -> Test mkTestModBad = mkTestMod "bad" "failing" noChange mkTestMod :: String -> FilePath -> Changer -> FilePath -> Test mkTestMod suffix dir f fp = let basename = testPrefix dir fp expected = basename <.> suffix writeFailure = writeFile (basename <.> "out") in TestCase (do r <- either (\(ParseFailure _ s) -> error (s ++ basename)) id <$> genTest f basename expected writeFailure (debugTxt r) assertBool fp (status r == Success)) -- --------------------------------------------------------------------- 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 #if __GLASGOW_HASKELL__ > 804 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") #else 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") #endif 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 GhcPs (GHC.LHsExpr GhcPs) -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) #if __GLASGOW_HASKELL__ <= 710 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.EmptyLocalBinds)))) = do #elif __GLASGOW_HASKELL__ <= 802 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do #elif __GLASGOW_HASKELL__ <= 804 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L _ GHC.EmptyLocalBinds)))) = do #else replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do #endif 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) #if __GLASGOW_HASKELL__ > 804 let binds = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ [GHC.L ld decl]) [GHC.L ls sig])) #else let binds = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ [GHC.L ld decl]) [GHC.L ls sig])) #endif #if __GLASGOW_HASKELL__ <= 710 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds))) #elif __GLASGOW_HASKELL__ <= 802 bindSpan <- uniqueSrcSpanT return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L bindSpan binds)))) #elif __GLASGOW_HASKELL__ <= 804 bindSpan <- uniqueSrcSpanT return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L bindSpan binds)))) #else bindSpan <- uniqueSrcSpanT return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L bindSpan binds)))) #endif 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 #if __GLASGOW_HASKELL__ > 804 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") #else 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") #endif 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 GhcPs (GHC.LHsExpr GhcPs) -> Transform (GHC.LMatch GhcPs (GHC.LHsExpr GhcPs)) #if __GLASGOW_HASKELL__ <= 710 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.HsValBinds (GHC.ValBindsIn binds sigs))))) = do #elif __GLASGOW_HASKELL__ <= 802 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do #elif __GLASGOW_HASKELL__ <= 804 replaceLocalBinds m@(GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn binds sigs)))))) = do #else replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do #endif a1 <- getAnnsT a' <- case sigs of [] -> return a1 (s1:_) -> do let a2 = setPrecedingLines s1 2 0 a1 return a2 putAnnsT a' 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) #if __GLASGOW_HASKELL__ > 804 let binds' = (GHC.HsValBinds GHC.noExt (GHC.ValBinds GHC.noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) (GHC.L ls sig:sigs))) #else let binds' = (GHC.HsValBinds (GHC.ValBindsIn (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) (GHC.L ls sig:sigs))) #endif #if __GLASGOW_HASKELL__ <= 710 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs binds'))) #elif __GLASGOW_HASKELL__ <= 802 return (GHC.L lm (GHC.Match mln pats typ (GHC.GRHSs rhs (GHC.L lb binds')))) #elif __GLASGOW_HASKELL__ <= 804 return (GHC.L lm (GHC.Match mln pats (GHC.GRHSs rhs (GHC.L lb binds')))) #else return (GHC.L lm (GHC.Match GHC.noExt mln pats (GHC.GRHSs GHC.noExt rhs (GHC.L lb binds')))) #endif 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 "" "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) -- --------------------------------------------------------------------- changeRenameCase1 :: Changer changeRenameCase1 ans parsed = return (ans,rename "bazLonger" [((3,15),(3,18))] parsed) changeRenameCase2 :: Changer changeRenameCase2 ans parsed = return (ans,rename "fooLonger" [((3,1),(3,4))] 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) changeRename2 :: Changer changeRename2 ans parsed = return (ans,rename "joe" [((2,1),(2,5))] parsed) changeLayoutLet3 :: Changer changeLayoutLet3 ans parsed = return (ans,rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed) changeLayoutLet5 :: Changer changeLayoutLet5 ans parsed = return (ans,rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed) -- AZ:TODO: the GHC 8 version only needs to consider Located RdrName 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 GhcPs -> GHC.LHsExpr GhcPs replaceHsVar (GHC.L ln (GHC.HsVar{})) #if __GLASGOW_HASKELL__ <= 710 | cond ln = GHC.L ln (GHC.HsVar newName) #elif __GLASGOW_HASKELL__ <= 804 | cond ln = GHC.L ln (GHC.HsVar (GHC.L ln newName)) #else | cond ln = GHC.L ln (GHC.HsVar GHC.noExt (GHC.L ln newName)) #endif replaceHsVar x = x #if __GLASGOW_HASKELL__ > 806 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.dL->GHC.L ln (GHC.VarPat {})) | cond ln = GHC.cL ln (GHC.VarPat GHC.noExt (GHC.cL ln newName)) #elif __GLASGOW_HASKELL__ > 804 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.L ln (GHC.VarPat {})) | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName)) #elif __GLASGOW_HASKELL__ > 802 replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs replacePat (GHC.L ln (GHC.VarPat {})) | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) #elif __GLASGOW_HASKELL__ >= 800 replacePat (GHC.L ln (GHC.VarPat {})) | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) #else replacePat (GHC.L ln (GHC.VarPat {})) | cond ln = GHC.L ln (GHC.VarPat newName) #endif replacePat x = x -- #if __GLASGOW_HASKELL__ > 802 -- replacePat :: GHC.LPat GhcPs -> GHC.LPat GhcPs -- #endif -- replacePat (GHC.L ln (GHC.VarPat {})) -- #if __GLASGOW_HASKELL__ <= 710 -- | cond ln = GHC.L ln (GHC.VarPat newName) -- #elif __GLASGOW_HASKELL__ <= 804 -- | cond ln = GHC.L ln (GHC.VarPat (GHC.L ln newName)) -- #else -- | cond ln = GHC.L ln (GHC.VarPat GHC.noExt (GHC.L ln newName)) -- #endif -- 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 GhcPs -> GHC.HsExpr GhcPs #if __GLASGOW_HASKELL__ <= 710 replace (GHC.HsLet localDecls expr@(GHC.L _ _)) #elif __GLASGOW_HASKELL__ <= 804 replace (GHC.HsLet (GHC.L lb localDecls) expr@(GHC.L _ _)) #else replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) #endif = #if __GLASGOW_HASKELL__ > 804 let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls #else let (GHC.HsValBinds (GHC.ValBindsIn bagDecls sigs)) = localDecls bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls #endif #if __GLASGOW_HASKELL__ <= 710 in (GHC.HsLet (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs)) expr) #elif __GLASGOW_HASKELL__ <= 802 in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) #elif __GLASGOW_HASKELL__ <= 804 in (GHC.HsLet (GHC.L lb (GHC.HsValBinds (GHC.ValBindsIn bagDecls' sigs))) expr) #else in (GHC.HsLet GHC.noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) #endif replace x = x -- --------------------------------------------------------------------- transformHighLevelTests :: [Test] transformHighLevelTests = [ mkTestModChange addLocaLDecl1 "AddLocalDecl1.hs" , mkTestModChange addLocaLDecl2 "AddLocalDecl2.hs" , mkTestModChange addLocaLDecl3 "AddLocalDecl3.hs" , mkTestModChange addLocaLDecl4 "AddLocalDecl4.hs" , mkTestModChange addLocaLDecl5 "AddLocalDecl5.hs" , mkTestModChange addLocaLDecl6 "AddLocalDecl6.hs" , mkTestModChange rmDecl1 "RmDecl1.hs" , mkTestModChange rmDecl2 "RmDecl2.hs" , mkTestModChange rmDecl3 "RmDecl3.hs" , mkTestModChange rmDecl4 "RmDecl4.hs" , mkTestModChange rmDecl5 "RmDecl5.hs" , mkTestModChange rmDecl6 "RmDecl6.hs" , mkTestModChange rmDecl7 "RmDecl7.hs" , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" , mkTestModChange rmTypeSig2 "RmTypeSig2.hs" , mkTestModChange addHiding1 "AddHiding1.hs" , mkTestModChange addHiding2 "AddHiding2.hs" , mkTestModChange cloneDecl1 "CloneDecl1.hs" ] -- --------------------------------------------------------------------- addLocaLDecl1 :: Changer addLocaLDecl1 ans lp = do Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") let declAnns' = setPrecedingLines newDecl 1 4 declAnns doAddLocal = do (d1:d2:_) <- hsDecls lp balanceComments d1 d2 (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do return ((newDecl : d),Nothing) replaceDecls lp [d1', d2] (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal -- putStrLn $ "log:\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addLocaLDecl2 :: Changer addLocaLDecl2 ans lp = do Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do tlDecs <- hsDecls lp let parent = head tlDecs balanceComments parent (head $ tail tlDecs) (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do transferEntryDPT (head decls) newDecl setEntryDPT (head decls) (DP (1, 0)) return ((newDecl:decls),Nothing) replaceDecls lp (parent':tail tlDecs) let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal -- putStrLn $ "log:\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addLocaLDecl3 :: Changer addLocaLDecl3 ans lp = do Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do -- logDataWithAnnsTr "parsed:" lp logDataWithAnnsTr "newDecl:" newDecl tlDecs <- hsDecls lp let parent = head tlDecs balanceComments parent (head $ tail tlDecs) (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do setPrecedingLinesT newDecl 1 0 moveTrailingComments m (last decls) return ((decls++[newDecl]),Nothing) replaceDecls lp (parent':tail tlDecs) let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal -- putStrLn $ "log\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addLocaLDecl4 :: Changer addLocaLDecl4 ans lp = do Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") Right (sigAnns, newSig) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp let doAddLocal = do tlDecs <- hsDecls lp let parent = head tlDecs setPrecedingLinesT newSig 1 0 setPrecedingLinesT newDecl 1 0 (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do return ((decls++[newSig,newDecl]),Nothing) replaceDecls lp (parent':tail tlDecs) let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal -- putStrLn $ "log\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addLocaLDecl5 :: Changer addLocaLDecl5 ans lp = do let doAddLocal = do [s1,d1,d2,d3] <- hsDecls lp transferEntryDPT d2 d3 (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do return ([d2],Nothing) replaceDecls lp [s1,d1',d3] (lp',(ans',_),_w) <- runTransformT ans doAddLocal -- putStrLn $ "log\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addLocaLDecl6 :: Changer addLocaLDecl6 ans lp = do Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3") let declAnns' = setPrecedingLines newDecl 1 4 declAnns doAddLocal = do [d1,d2] <- hsDecls lp balanceComments d1 d2 #if __GLASGOW_HASKELL__ <= 710 let GHC.L _ (GHC.ValD (GHC.FunBind _ _ (GHC.MG [m1,m2] _ _ _) _ _ _)) = d1 #elif __GLASGOW_HASKELL__ <= 804 let GHC.L _ (GHC.ValD (GHC.FunBind _ (GHC.MG (GHC.L _ [m1,m2]) _ _ _) _ _ _)) = d1 #else let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _ _)) = d1 #endif balanceComments m1 m2 (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do return ((newDecl : decls),Nothing) replaceDecls lp [d1', d2] (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal -- putStrLn $ "log:\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmDecl1 :: Changer rmDecl1 ans lp = do let doRmDecl = do tlDecs <- hsDecls lp let (d1:s1:d2:ds) = tlDecs -- First delete the decl (d2) only balanceComments s1 d2 -- ++AZ++ balanceComments d2 (head ds) lp1 <- replaceDecls lp (d1:s1:ds) -- return lp1 -- Then delete the sig separately tlDecs1 <- hsDecls lp1 let (d1':s1':ds') = tlDecs1 -- transferEntryDPT s1' (head ds') -- required in HaRe. balanceComments d1' s1' balanceComments s1' (head ds') transferEntryDPT s1' (head ds') -- required in HaRe. replaceDecls lp (d1':ds') (lp',(ans',_),_w) <- runTransformT ans doRmDecl return (ans',lp') -- --------------------------------------------------------------------- rmDecl2 :: Changer rmDecl2 ans lp = do let doRmDecl = do let go :: GHC.LHsExpr GhcPs -> Transform (GHC.LHsExpr GhcPs) go e@(GHC.L _ (GHC.HsLet{})) = do decs <- hsDecls e e' <- replaceDecls e (init decs) return e' go x = return x SYB.everywhereM (SYB.mkM go) lp let (lp',(ans',_),_w) = runTransform ans doRmDecl -- putStrLn $ "log:\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmDecl3 :: Changer rmDecl3 ans lp = do let doRmDecl = do [d1,d2] <- hsDecls lp (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do setPrecedingLinesDeclT sd1 2 0 return ([],Just sd1) replaceDecls lp [d1',sd1,d2] (lp',(ans',_),_w) <- runTransformT ans doRmDecl -- putStrLn $ "log:\n" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmDecl4 :: Changer rmDecl4 ans lp = do let doRmDecl = do [d1] <- hsDecls lp (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do -- [sd1,sd2] <- hsDecls d1 transferEntryDPT sd1 sd2 setPrecedingLinesDeclT sd1 2 0 -- d1' <- replaceDecls d1 [sd2] return ([sd2],Just sd1) replaceDecls lp [d1',sd1] (lp',(ans',_),_w) <- runTransformT ans doRmDecl return (ans',lp') -- --------------------------------------------------------------------- rmDecl5 :: Changer rmDecl5 ans lp = do let doRmDecl = do let go :: GHC.HsExpr GhcPs -> Transform (GHC.HsExpr GhcPs) #if __GLASGOW_HASKELL__ <= 710 go (GHC.HsLet lb expr) = do #elif __GLASGOW_HASKELL__ <= 804 go (GHC.HsLet (GHC.L l lb) expr) = do #else go (GHC.HsLet _ (GHC.L l lb) expr) = do #endif decs <- hsDeclsValBinds lb let dec = last decs transferEntryDPT (head decs) dec lb' <- replaceDeclsValbinds lb [dec] #if __GLASGOW_HASKELL__ <= 710 return (GHC.HsLet lb' expr) #elif __GLASGOW_HASKELL__ <= 804 return (GHC.HsLet (GHC.L l lb') expr) #else return (GHC.HsLet GHC.noExt (GHC.L l lb') expr) #endif go x = return x SYB.everywhereM (SYB.mkM go) lp let (lp',(ans',_),_w) = runTransform ans doRmDecl -- putStrLn $ "log:" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmDecl6 :: Changer rmDecl6 ans lp = do let doRmDecl = do [d1] <- hsDecls lp (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do let (ss1:_sd1:sd2:sds) = subDecs transferEntryDPT ss1 sd2 return (sd2:sds,Nothing) replaceDecls lp [d1'] (lp',(ans',_),_w) <- runTransformT ans doRmDecl -- putStrLn $ "log:" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmDecl7 :: Changer rmDecl7 ans lp = do let doRmDecl = do tlDecs <- hsDecls lp let [s1,d1,d2,d3] = tlDecs balanceComments d1 d2 balanceComments d2 d3 transferEntryDPT d2 d3 replaceDecls lp [s1,d1,d3] let (lp',(ans',_),_w) = runTransform ans doRmDecl -- putStrLn $ "log:" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- rmTypeSig1 :: Changer rmTypeSig1 ans lp = do let doRmDecl = do tlDecs <- hsDecls lp let (s1:d1:d2) = tlDecs #if __GLASGOW_HASKELL__ <= 710 (GHC.L l (GHC.SigD (GHC.TypeSig names typ p))) = s1 s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ p))) #elif __GLASGOW_HASKELL__ <= 804 (GHC.L l (GHC.SigD (GHC.TypeSig names typ))) = s1 s1' = (GHC.L l (GHC.SigD (GHC.TypeSig (tail names) typ))) #else (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1 s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) #endif replaceDecls lp (s1':d1:d2) let (lp',(ans',_),_w) = runTransform ans doRmDecl return (ans',lp') -- --------------------------------------------------------------------- rmTypeSig2 :: Changer rmTypeSig2 ans lp = do let doRmDecl = do tlDecs <- hsDecls lp let [d1] = tlDecs (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do transferEntryDPT s d return ([d],Nothing) replaceDecls lp [d1'] let (lp',(ans',_),_w) = runTransform ans doRmDecl -- putStrLn $ "log:" ++ intercalate "\n" _w return (ans',lp') -- --------------------------------------------------------------------- addHiding1 :: Changer addHiding1 ans (GHC.L l p) = do let doTransform = do l0 <- uniqueSrcSpanT l1 <- uniqueSrcSpanT l2 <- uniqueSrcSpanT let [GHC.L li imp1,imp2] = GHC.hsmodImports p n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #if __GLASGOW_HASKELL__ > 804 v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2))) #elif __GLASGOW_HASKELL__ > 800 v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else v1 = GHC.L l1 (GHC.IEVar n1) v2 = GHC.L l2 (GHC.IEVar n2) #endif impHiding = GHC.L l0 [v1,v2] imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)} p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]} addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] return (GHC.L l p') let (lp',(ans',_),_w) = runTransform ans doTransform return (ans',lp') -- --------------------------------------------------------------------- addHiding2 :: Changer addHiding2 ans (GHC.L l p) = do let doTransform = do l1 <- uniqueSrcSpanT l2 <- uniqueSrcSpanT let [GHC.L li imp1] = GHC.hsmodImports p Just (_,GHC.L lh ns) = GHC.ideclHiding imp1 n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) #if __GLASGOW_HASKELL__ > 804 v1 = GHC.L l1 (GHC.IEVar GHC.noExt (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar GHC.noExt (GHC.L l2 (GHC.IEName n2))) #elif __GLASGOW_HASKELL__ > 800 v1 = GHC.L l1 (GHC.IEVar (GHC.L l1 (GHC.IEName n1))) v2 = GHC.L l2 (GHC.IEVar (GHC.L l2 (GHC.IEName n2))) #else v1 = GHC.L l1 (GHC.IEVar n1) v2 = GHC.L l2 (GHC.IEVar n2) #endif imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))} p' = p { GHC.hsmodImports = [GHC.L li imp1']} addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] addTrailingCommaT (last ns) return (GHC.L l p') let (lp',(ans',_),_w) = runTransform ans doTransform return (ans',lp') -- --------------------------------------------------------------------- cloneDecl1 :: Changer cloneDecl1 ans lp = do let doChange = do tlDecs <- hsDecls lp let (d1:d2:ds) = tlDecs d2' <- fst <$> cloneT d2 replaceDecls lp (d1:d2:d2':ds) let (lp',(ans',_),_w) = runTransform ans doChange return (ans',lp') -- --------------------------------------------------------------------- ghc-exactprint-0.6.2/tests/examples/failing/0000755000000000000000000000000007346545000017221 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/failing/CtorOp.hs0000755000000000000000000000024707346545000020771 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} module Decl.CtorOp where data a :+: b = a :+: b data (a :!: b) c = a c :!: b c data ((:-:) a) b = a :-: b data (:*:) a b = a :*: b ghc-exactprint-0.6.2/tests/examples/failing/CtorOp.hs.bad0000755000000000000000000000025107346545000021511 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} module Decl.CtorOp where data a :+: b = a :+: b data (a :!: b) c = a c :!: b c data ((:-:) a b = a :-: b data (:*:) a b = a :*: b ghc-exactprint-0.6.2/tests/examples/failing/Deprecation.hs0000755000000000000000000000070607346545000022020 0ustar0000000000000000 module Deprecation {-# Deprecated ["This is a module \"deprecation\"", "multi-line", "with unicode: Frère" ] #-} ( foo ) where {-# DEPRECATEd foo ["This is a multi-line", "deprecation message", "for foo"] #-} foo :: Int foo = 4 {-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} ghc-exactprint-0.6.2/tests/examples/failing/Deprecation.hs.bad0000755000000000000000000000071007346545000022540 0ustar0000000000000000 module Deprecation {-# Deprecated ["This is a module \"deprecation\"", "multi-line", "with unicode: Fr\232re" ] #-} ( foo ) where {-# DEPRECATEd foo ["This is a multi-line", "deprecation message", "for foo"] #-} foo :: Int foo = 4 {-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} ghc-exactprint-0.6.2/tests/examples/failing/InfixOperator.hs0000755000000000000000000000104707346545000022353 0ustar0000000000000000{-# 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_ #-} ghc-exactprint-0.6.2/tests/examples/failing/InfixOperator.hs.bad0000755000000000000000000000105707346545000023101 0ustar0000000000000000{-# 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 == 123OPEN_CURLY w ==||) == OPEN_SQUARE) if w == 123OPEN_CURLY then obj else ary {-# INLINE json_ #-} ghc-exactprint-0.6.2/tests/examples/failing/List2.hs0000755000000000000000000000222607346545000020557 0ustar0000000000000000{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Type.Family.List -- Copyright : Copyright (C) 2015 Kyle Carter -- License : BSD3 -- -- Maintainer : Kyle Carter -- Stability : experimental -- Portability : RankNTypes -- -- Convenient aliases and type families for working with -- type-level lists. ---------------------------------------------------------------------------- module Type.Family.List where import Type.Family.Constraint import Type.Family.Monoid import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) import Type.Class.Witness type Ø = '[] type (:<) = '(:) infixr 5 :< ghc-exactprint-0.6.2/tests/examples/failing/List2.hs.bad0000755000000000000000000000222607346545000021304 0ustar0000000000000000{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Type.Family.List -- Copyright : Copyright (C) 2015 Kyle Carter -- License : BSD3 -- -- Maintainer : Kyle Carter -- Stability : experimental -- Portability : RankNTypes -- -- Convenient aliases and type families for working with -- type-level lists. ---------------------------------------------------------------------------- module Type.Family.List where import Type.Family.Constraint import Type.Family.Monoid import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) import Type.Class.Witness type Ø = '[] type (:<) = (:) infixr 5 :< ghc-exactprint-0.6.2/tests/examples/failing/MultiLineWarningPragma.hs0000755000000000000000000000077007346545000024144 0ustar0000000000000000 {-# 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!" #-} ghc-exactprint-0.6.2/tests/examples/failing/MultiLineWarningPragma.hs.bad0000755000000000000000000000075307346545000024672 0ustar0000000000000000 {-# 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!" #-} ghc-exactprint-0.6.2/tests/examples/failing/OverloadedLabelsRun04_A.hs0000755000000000000000000000037007346545000024060 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TemplateHaskell #-} module OverloadedLabelsRun04_A where import GHC.OverloadedLabels import Language.Haskell.TH instance IsLabel x (Q [Dec]) where fromLabel _ = [d| main = putStrLn "Ok" |] ghc-exactprint-0.6.2/tests/examples/failing/TensorTests.hs0000755000000000000000000000177407346545000022066 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module TensorTests (tensorTests) where import Apply.Cyc import Tests import Utils import TestTypes import Crypto.Lol import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor import Crypto.Lol.Types import Control.Applicative import Data.Maybe import Data.Singletons import Data.Promotion.Prelude.Eq import Data.Singletons.TypeRepStar () import qualified Test.Framework as TF type TMRParams = ( '(,) <$> Tensors) <*> MRCombos tmrParams :: Proxy TMRParams tmrParams = Proxy --type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos tremParams :: Proxy TrEmParams tremParams = Proxy type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) data Liftable :: TyFun (Factored, *) Bool -> * type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) ghc-exactprint-0.6.2/tests/examples/failing/TensorTests.hs.bad0000755000000000000000000000177407346545000022613 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module TensorTests (tensorTests) where import Apply.Cyc import Tests import Utils import TestTypes import Crypto.Lol import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor import Crypto.Lol.Types import Control.Applicative import Data.Maybe import Data.Singletons import Data.Promotion.Prelude.Eq import Data.Singletons.TypeRepStar () import qualified Test.Framework as TF type TMRParams = ( (,) <$> Tensors) <*> MRCombos tmrParams :: Proxy TMRParams tmrParams = Proxy --type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos type TrEmParams = ( (,) <$> Tensors) <*> MM'RCombos tremParams :: Proxy TrEmParams tremParams = Proxy type NormParams = ( (,) <$> '[RT]) <*> (Filter Liftable MRCombos) data Liftable :: TyFun (Factored, *) Bool -> * type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) ghc-exactprint-0.6.2/tests/examples/failing/UnicodeRules.hs0000755000000000000000000000064507346545000022166 0ustar0000000000000000{-# 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) ghc-exactprint-0.6.2/tests/examples/failing/UnicodeRules.hs.bad0000755000000000000000000000064707346545000022715 0ustar0000000000000000{-# LANGUAGE BangPatterns , FlexibleContexts , FlexibleInstances , ScopedTypeVariables , UnboxedTuples , UndecidableInstances , UnicodeSyntax #-} strictHead ∷ G.Bitstream (Packet d) ⇒ Bitstream d → Bool {-# RULES "head \8594 strictHead" [1] ∀(v ∷ G.Bitstream (Packet d) ⇒ Bitstream d). head v = strictHead v #-} {-# INLINE strictHead #-} strictHead (Bitstream _ v) = head (SV.head v) ghc-exactprint-0.6.2/tests/examples/failing/UnicodeSyntax.hs0000755000000000000000000001300007346545000022347 0ustar0000000000000000{-# 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) } ghc-exactprint-0.6.2/tests/examples/failing/UnicodeSyntax.hs.bad0000755000000000000000000001277407346545000023115 0ustar0000000000000000{-# 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) } ghc-exactprint-0.6.2/tests/examples/failing/dsrun010.hs0000755000000000000000000000107307346545000021135 0ustar0000000000000000-- Check that pattern match failure in do-notation -- is reflected by calling the monadic 'fail', not by a -- runtime exception {-# LANGUAGE NoMonadFailDesugaring #-} {-# OPTIONS -Wno-missing-monadfail-instances #-} import Control.Monad import Data.Maybe test :: (MonadPlus m) => [a] -> m Bool test xs = do (_:_) <- return xs -- Should fail here return True `mplus` -- Failure in LH arg should trigger RH arg do return False main :: IO () main = do let x = fromJust (test []) putStrLn (show x) ghc-exactprint-0.6.2/tests/examples/failing/overloadedlabelsrun04.hs0000755000000000000000000000052107346545000023756 0ustar0000000000000000{-# LANGUAGE OverloadedLabels, TemplateHaskell #-} import OverloadedLabelsRun04_A -- Who knew that there were so many ways that a line could start with -- a # sign in Haskell? None of these are overloaded labels: #line 7 "overloadedlabelsrun04.hs" # 8 "overloadedlabelsrun04.hs" #!notashellscript #pragma foo -- But this one is: #foo ghc-exactprint-0.6.2/tests/examples/failing/overloadedlabelsrun04.hs.bad0000755000000000000000000000030607346545000024504 0ustar0000000000000000{-# LANGUAGE OverloadedLabels, TemplateHaskell #-} import OverloadedLabelsRun04_A #!notashellscript -- But this one is: -- a # sign in Haskell? None of these are overloaded labels: #foo ghc-exactprint-0.6.2/tests/examples/ghc710-only/0000755000000000000000000000000007346545000017560 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc710-only/DataDecl.hs0000755000000000000000000000132507346545000021561 0ustar0000000000000000{-# Language DatatypeContexts #-} {-# Language ExistentialQuantification #-} {-# LAnguage GADTs #-} {-# LAnguage KindSignatures #-} data Foo = A | B | C -- | data_or_newtype capi_ctype tycl_hdr constrs deriving data {-# Ctype "Foo" "bar" #-} F1 = F1 data {-# Ctype "baz" #-} Eq a => F2 a = F2 a data (Eq a,Ord a) => F3 a = F3 Int a data F4 a = forall x y. (Eq x,Eq y) => F4 a x y | forall x y. (Eq x,Eq y) => F4b a x y data G1 a :: * where G1A, G1B :: Int -> G1 a G1C :: Double -> G1 a data G2 a :: * where G2A { g2a :: a, g2b :: Int } :: G2 a G2C :: Double -> G2 a data (Eq a,Ord a) => G3 a = G3 { g3A :: Int , g3B :: Bool , g3a :: a } deriving (Eq,Ord) ghc-exactprint-0.6.2/tests/examples/ghc710-only/HashQQ.hs0000755000000000000000000000245207346545000021247 0ustar0000000000000000{-# 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")) ghc-exactprint-0.6.2/tests/examples/ghc710-only/QuasiQuote.hs0000755000000000000000000000110707346545000022216 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module QuasiQuote where import T7918A ex1 = [qq|e1|] ex2 = [qq|e2|] ex3 = [qq|e3|] ex4 = [qq|e4|] tx1 = undefined :: [qq|t1|] tx2 = undefined :: [qq|t2|] tx3 = undefined :: [qq|t3|] tx4 = undefined :: [qq|t4|] px1 [qq|p1|] = undefined px2 [qq|p2|] = undefined px3 [qq|p3|] = undefined px4 [qq|p4|] = undefined {-# 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")) ghc-exactprint-0.6.2/tests/examples/ghc710-only/TypeFamilies.hs0000755000000000000000000000365107346545000022517 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -- From https://ocharles.org.uk/blog/posts/2014-12-12-type-families.html import Control.Concurrent.STM import Control.Concurrent.MVar import Data.Foldable (forM_) import Data.IORef class IOStore store where newIO :: a -> IO (store a) getIO :: store a -> IO a putIO :: store a -> a -> IO () instance IOStore MVar where newIO = newMVar getIO = readMVar putIO mvar a = modifyMVar_ mvar (return . const a) instance IOStore IORef where newIO = newIORef getIO = readIORef putIO ioref a = modifyIORef ioref (const a) type Present = String storePresentsIO :: IOStore store => [Present] -> IO (store [Present]) storePresentsIO xs = do store <- newIO [] forM_ xs $ \x -> do old <- getIO store putIO store (x : old) return store -- Type family version class Store store where type StoreMonad store :: * -> * new :: a -> (StoreMonad store) (store a) get :: store a -> (StoreMonad store) a put :: store a -> a -> (StoreMonad store) () instance Store IORef where type StoreMonad IORef = IO new = newIORef get = readIORef put ioref a = modifyIORef ioref (const a) instance Store TVar where type StoreMonad TVar = STM new = newTVar get = readTVar put ioref a = modifyTVar ioref (const a) storePresents :: (Store store, Monad (StoreMonad store)) => [Present] -> (StoreMonad store) (store [Present]) storePresents xs = do store <- new [] forM_ xs $ \x -> do old <- get store put store (x : old) return store 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 ghc-exactprint-0.6.2/tests/examples/ghc710/0000755000000000000000000000000007346545000016601 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc710/AddAndOr3.hs0000755000000000000000000000030407346545000020634 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module AddAndOr3 where addAndOr3 :: _ -> _ -> _ addAndOr3 (a, b) (c, d) = (a `plus` d, b || c) where plus :: Int -> Int -> Int x `plus` y = x + y ghc-exactprint-0.6.2/tests/examples/ghc710/AltsSemis.hs0000755000000000000000000000026107346545000021043 0ustar0000000000000000 foo x = case x of { ;;; -- leading 0 -> 'a'; -- case 0 1 -> 'b' -- case 1 ; 2 -> 'c' ; -- case 2 ; 3 -> 'd' -- case 3 ;;; -- case 4 } ghc-exactprint-0.6.2/tests/examples/ghc710/Ann01.hs0000755000000000000000000000202607346545000020015 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Ann01 where {-# ANN module (1 :: Int) #-} {-# ANN module (1 :: Integer) #-} {-# ANN module (1 :: Double) #-} {-# ANN module $([| 1 :: Int |]) #-} {-# ANN module "Hello" #-} {-# ANN module (Just (1 :: Int)) #-} {-# ANN module [1 :: Int, 2, 3] #-} {-# ANN module ([1..10] :: [Integer]) #-} {-# ANN module ''Foo #-} {-# ANN module (-1 :: Int) #-} {-# ANN type Foo (1 :: Int) #-} {-# ANN type Foo (1 :: Integer) #-} {-# ANN type Foo (1 :: Double) #-} {-# ANN type Foo $([| 1 :: Int |]) #-} {-# ANN type Foo "Hello" #-} {-# ANN type Foo (Just (1 :: Int)) #-} {-# ANN type Foo [1 :: Int, 2, 3] #-} {-# ANN type Foo ([1..10] :: [Integer]) #-} {-# ANN type Foo ''Foo #-} {-# ANN type Foo (-1 :: Int) #-} data Foo = Bar Int {-# ANN f (1 :: Int) #-} {-# ANN f (1 :: Integer) #-} {-# ANN f (1 :: Double) #-} {-# ANN f $([| 1 :: Int |]) #-} {-# ANN f "Hello" #-} {-# ANN f (Just (1 :: Int)) #-} {-# ANN f [1 :: Int, 2, 3] #-} {-# ANN f ([1..10] :: [Integer]) #-} {-# ANN f 'f #-} {-# ANN f (-1 :: Int) #-} f x = x ghc-exactprint-0.6.2/tests/examples/ghc710/AnnPackageName.hs0000755000000000000000000000006007346545000021725 0ustar0000000000000000 import "base" Prelude import "base" Data.Data ghc-exactprint-0.6.2/tests/examples/ghc710/Annotations.hs0000755000000000000000000000212307346545000021433 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Annotations where {-# ANN module (1 :: Int) #-} {-# ANN module (1 :: Integer) #-} {-# ANN module (1 :: Double) #-} {-# ANN module $([| 1 :: Int |]) #-} {-# ANN module "Hello" #-} {-# ANN module (Just (1 :: Int)) #-} {-# ANN module [1 :: Int, 2, 3] #-} {-# ANN module ([1..10] :: [Integer]) #-} {-# ANN module ''Foo #-} {-# ANN module (-1 :: Int) #-} {-# ANN type Foo (1 :: Int) #-} {-# ANN type Foo (1 :: Integer) #-} {-# ANN type Foo (1 :: Double) #-} {-# ANN type Foo $([| 1 :: Int |]) #-} {-# ANN type Foo "Hello" #-} {-# ANN type Foo (Just (1 :: Int)) #-} {-# ANN type Foo [1 :: Int, 2, 3] #-} {-# ANN type Foo ([1..10] :: [Integer]) #-} {-# ANN type Foo ''Foo #-} {-# ANN type Foo (-1 :: Int) #-} data Foo = Bar Int {-# ANN f (1 :: Int) #-} {-# ANN f (1 :: Integer) #-} {-# ANN f (1 :: Double) #-} {-# ANN f $([| 1 :: Int |]) #-} {-# ANN f "Hello" #-} {-# ANN f (Just (1 :: Int)) #-} {-# ANN f [1 :: Int, 2, 3] #-} {-# ANN f ([1..10] :: [Integer]) #-} {-# ANN f 'f #-} {-# ANN f (-1 :: Int) #-} f x = x {-# ANN foo "HLint: ignore" #-};foo = map f (map g x) ghc-exactprint-0.6.2/tests/examples/ghc710/Arrow.hs0000755000000000000000000000254507346545000020240 0ustar0000000000000000{-# LANGUAGE Arrows #-} module Arrow where import Control.Arrow import qualified Control.Category as Cat addA :: Arrow a => a b Int -> a b Int -> a b Int addA f g = proc x -> do y <- f -< x z <- g -< x returnA -< y + z newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) } instance Cat.Category Circuit where id = Circuit $ \a -> (Cat.id, a) (.) = dot where (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a -> let (cir1', b) = cir1 a (cir2', c) = cir2 b in (cir2' `dot` cir1', c) instance Arrow Circuit where arr f = Circuit $ \a -> (arr f, f a) first (Circuit cir) = Circuit $ \(b, d) -> let (cir', c) = cir b in (first cir', (c, d)) -- | Accumulator that outputs a value determined by the supplied function. accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b accum acc f = Circuit $ \input -> let (output, acc') = input `f` acc in (accum acc' f, output) -- | Accumulator that outputs the accumulator value. accum' :: b -> (a -> b -> b) -> Circuit a b accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b')) total :: Num a => Circuit a a total = accum' 0 (+) mean3 :: Fractional a => Circuit a a mean3 = proc value -> do (t, n) <- (| (&&&) (total -< value) (total -< 1) |) returnA -< t / n ghc-exactprint-0.6.2/tests/examples/ghc710/Arrows.hs0000755000000000000000000000335107346545000020417 0ustar0000000000000000{-# LANGUAGE Arrows #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-21-arrows.html import Control.Monad (guard) import Control.Monad.Identity (Identity, runIdentity) import Control.Arrow (returnA, Kleisli(Kleisli), runKleisli) f :: Int -> (Int, Int) f = \x -> let y = 2 * x z1 = y + 3 z2 = y - 5 in (z1, z2) -- ghci> f 10 -- (23, 15) fM :: Int -> Identity (Int, Int) fM = \x -> do y <- return (2 * x) z1 <- return (y + 3) z2 <- return (y - 5) return (z1, z2) -- ghci> runIdentity (fM 10) -- (23,15) fA :: Int -> (Int, Int) fA = proc x -> do y <- (2 *) -< x z1 <- (+ 3) -< y z2 <- (subtract 5) -< y returnA -< (z1, z2) -- ghci> fA 10 -- (23,15) range :: Int -> [Int] range r = [-r..r] cM :: Int -> [(Int, Int)] cM = \r -> do x <- range 5 y <- range 5 guard (x*x + y*y <= r*r) return (x, y) -- ghci> take 10 (cM 5) -- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] type K = Kleisli k :: (a -> m b) -> Kleisli m a b k = Kleisli runK :: Kleisli m a b -> (a -> m b) runK = runKleisli cA :: Kleisli [] Int (Int, Int) cA = proc r -> do x <- k range -< 5 y <- k range -< 5 k guard -< (x*x + y*y <= r*r) returnA -< (x, y) -- ghci> take 10 (runK cA 5) -- [(-5,0),(-4,-3),(-4,-2),(-4,-1),(-4,0),(-4,1),(-4,2),(-4,3),(-3,-4),(-3,-3)] getLineM :: String -> IO String getLineM prompt = do print prompt getLine printM :: String -> IO () printM = print writeFileM :: (FilePath, String) -> IO () writeFileM (filePath, string) = writeFile filePath string procedureM :: String -> IO () procedureM = \prompt -> do input <- getLineM prompt if input == "Hello" then printM "You said 'Hello'" else writeFileM ("/tmp/output", "The user said '" ++ input ++ "'") ghc-exactprint-0.6.2/tests/examples/ghc710/Associated.hs0000755000000000000000000000540607346545000021224 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} -- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example import qualified Data.IntMap import Prelude hiding (lookup) import Data.Char (ord) class GMapKey k where data GMap k :: * -> * empty :: GMap k v lookup :: k -> GMap k v -> Maybe v insert :: k -> v -> GMap k v -> GMap k v -- An Int instance instance GMapKey Int where data GMap Int v = GMapInt (Data.IntMap.IntMap v) empty = GMapInt Data.IntMap.empty lookup k (GMapInt m) = Data.IntMap.lookup k m insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m) -- A Char instance instance GMapKey Char where data GMap Char v = GMapChar (GMap Int v) empty = GMapChar empty lookup k (GMapChar m) = lookup (ord k) m insert k v (GMapChar m) = GMapChar (insert (ord k) v m) -- A Unit instance instance GMapKey () where data GMap () v = GMapUnit (Maybe v) empty = GMapUnit Nothing lookup () (GMapUnit v) = v insert () v (GMapUnit _) = GMapUnit $ Just v -- Product and sum instances instance (GMapKey a, GMapKey b) => GMapKey (a, b) where data GMap (a, b) v = GMapPair (GMap a (GMap b v)) empty = GMapPair empty lookup (a, b) (GMapPair gm) = lookup a gm >>= lookup b insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of Nothing -> insert a (insert b v empty) gm Just gm2 -> insert a (insert b v gm2 ) gm instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) empty = GMapEither empty empty lookup (Left a) (GMapEither gm1 _gm2) = lookup a gm1 lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2 insert (Left a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2 insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2) myGMap :: GMap (Int, Either Char ()) String myGMap = insert (5, Left 'c') "(5, Left 'c')" $ insert (4, Right ()) "(4, Right ())" $ insert (5, Right ()) "This is the one!" $ insert (5, Right ()) "This is the two!" $ insert (6, Right ()) "(6, Right ())" $ insert (5, Left 'a') "(5, Left 'a')" $ empty main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap -- (Type) Synonym Family type family Elem c type instance Elem [e] = e -- type instance Elem BitSet = Char data family T a data instance T Int = T1 Int | T2 Bool newtype instance T Char = TC Bool data family G a b data instance G [a] b where G1 :: c -> G [Int] b G2 :: G [a] Bool ghc-exactprint-0.6.2/tests/examples/ghc710/AssociatedType.hs0000755000000000000000000000017407346545000022063 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} class Foldable t where type FoldableConstraint t x :: * type FoldableConstraint t x = () ghc-exactprint-0.6.2/tests/examples/ghc710/B.hs0000755000000000000000000000012007346545000017312 0ustar0000000000000000 foo x = case (odd x) of True -> "Odd" False -> "Even" ghc-exactprint-0.6.2/tests/examples/ghc710/BCase.hs0000755000000000000000000000022707346545000020116 0ustar0000000000000000 main = case 1 > 10 of True -> do putStrLn "hello" putStrLn "there" False -> do putStrLn "blah" putStrLn "blah" ghc-exactprint-0.6.2/tests/examples/ghc710/BIf.hs0000755000000000000000000000020207346545000017572 0ustar0000000000000000 main = if 1 > 10 then do putStrLn "hello" putStrLn "there" else do putStrLn "blah" putStrLn "blah" ghc-exactprint-0.6.2/tests/examples/ghc710/Backquote.hs0000755000000000000000000000026407346545000021060 0ustar0000000000000000import 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 ghc-exactprint-0.6.2/tests/examples/ghc710/BangPatterns.hs0000755000000000000000000000053207346545000021530 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- From https://ocharles.org.uk/blog/posts/2014-12-05-bang-patterns.html import Data.Function (fix) import Data.List (foldl') hello3 :: Bool -> String hello3 !loud = "Hello." mean :: [Double] -> Double mean xs = s / fromIntegral l where (s, l) = foldl' step (0, 0) xs step (!s, !l) a = (s + a, l + 1) ghc-exactprint-0.6.2/tests/examples/ghc710/BootImport.hs0000755000000000000000000000005407346545000021235 0ustar0000000000000000module BootImport where data Foo = Foo Int ghc-exactprint-0.6.2/tests/examples/ghc710/BootImport.hs-boot0000755000000000000000000000004207346545000022173 0ustar0000000000000000module BootImport where data Foo ghc-exactprint-0.6.2/tests/examples/ghc710/BracesSemiDataDecl.hs0000755000000000000000000000014407346545000022536 0ustar0000000000000000 data Nat (t :: NatKind) where { ZeroNat :: Nat Zero; SuccNat :: Nat t -> Nat (Succ t); }; ghc-exactprint-0.6.2/tests/examples/ghc710/CExpected.hs0000755000000000000000000000044407346545000021006 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Case.hs0000755000000000000000000000010107346545000020003 0ustar0000000000000000 foo x = case x of True -> "a" False -> "b" ghc-exactprint-0.6.2/tests/examples/ghc710/Cg008.hs0000755000000000000000000000107507346545000017724 0ustar0000000000000000{-# LANGUAGE MagicHash, BangPatterns #-} {-# OPTIONS_GHC -O0 #-} -- Variant of cgrun066; compilation as a module is different. module Cg008 (hashStr) where import Foreign.C import Data.Word import Foreign.Ptr import GHC.Exts import Control.Exception hashStr :: Ptr Word8 -> Int -> Int hashStr (Ptr a#) (I# len#) = loop 0# 0# where loop h n | isTrue# (n GHC.Exts.==# len#) = I# h | otherwise = loop h2 (n GHC.Exts.+# 1#) where !c = ord# (indexCharOffAddr# a# n) !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091# ghc-exactprint-0.6.2/tests/examples/ghc710/Commands.hs0000755000000000000000000002373407346545000020712 0ustar0000000000000000{-# 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 ] ghc-exactprint-0.6.2/tests/examples/ghc710/Control.hs0000755000000000000000000001543007346545000020563 0ustar0000000000000000{-# 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 () ghc-exactprint-0.6.2/tests/examples/ghc710/CoreIr.hs0000755000000000000000000000102307346545000020317 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} module Llvm.Data.CoreIr ( module Llvm.Data.CoreIr , module Llvm.Data.Shared , module Llvm.Data.IrType , module Data.Word , Label ) where import Llvm.Data.Shared import Llvm.Data.IrType import Compiler.Hoopl (Label) import Data.Int import Data.Word (Word8, Word16, Word32, Word64) import Data.DoubleWord data Conversion s v where { AddrSpaceCast :: T (Type s P) v -> Type s P -> Conversion s v; } deriving (Eq, Ord, Show) ghc-exactprint-0.6.2/tests/examples/ghc710/CorePragma.hs0000755000000000000000000000025307346545000021160 0ustar0000000000000000{-# INLINE strictStream #-} strictStream (Bitstream l v) = {-# CORE "Strict Bitstream stream" #-} S.concatMap stream (GV.stream v) `S.sized` Exact l ghc-exactprint-0.6.2/tests/examples/ghc710/Cpp.hs0000755000000000000000000000026707346545000017667 0ustar0000000000000000{-# Language CPP #-} #if __GLASGOW_HASKELL__ > 704 foo :: Int #else foo :: Integer #endif foo = 3 bar :: ( #if __GLASGOW_HASKELL__ > 704 Int) #else Integer) #endif bar = 4 ghc-exactprint-0.6.2/tests/examples/ghc710/DataDecl.hs0000755000000000000000000000133007346545000020576 0ustar0000000000000000{-# Language DatatypeContexts #-} {-# Language ExistentialQuantification #-} {-# LAnguage GADTs #-} {-# LAnguage KindSignatures #-} data Foo = A | B | C -- | data_or_newtype capi_ctype tycl_hdr constrs deriving data {-# Ctype "Foo" "bar" #-} F1 = F1 data {-# Ctype "baz" #-} Eq a => F2 a = F2 a data (Eq a,Ord a) => F3 a = F3 Int a data F4 a = forall x y. (Eq x,Eq y) => F4 a x y | forall x y. (Eq x,Eq y) => F4b a x y data G1 a :: * where G1A, G1B :: Int -> G1 a G1C :: Double -> G1 a data G2 a :: * where G2A :: { g2a :: a, g2b :: Int } -> G2 a G2C :: Double -> G2 a data (Eq a,Ord a) => G3 a = G3 { g3A :: Int , g3B :: Bool , g3a :: a } deriving (Eq,Ord) ghc-exactprint-0.6.2/tests/examples/ghc710/DataFamilies.hs0000755000000000000000000000226207346545000021465 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} -- Based on https://www.haskell.org/haskellwiki/GHC/Type_families#Detailed_definition_of_data_families module DataFamilies ( GMap , GMapKey(type GMapK) ) where -- Type 1, Top level data family GMap k :: * -> * data family Array e data family ArrayK :: * -> * -- Type 2, associated types class GMapKey k where data GMapK k :: * -> * class C a b c where { data T1 c a :: * } -- OK -- class C a b c where { data T a a :: * } -- Bad: repeated variable -- class D a where { data T a x :: * } -- Bad: x is not a class variable class D a where { data T2 a :: * -> * } -- OK -- Instances data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) data family T3 a data instance T3 Int = A data instance T3 Char = B nonsense :: T3 a -> Int -- nonsense A = 1 -- WRONG: These two equations together... -- nonsense B = 2 -- ...will produce a type error. nonsense = undefined instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMapK (Either a b) v = GMapEitherK (GMap a v) (GMap b v) -- data GMap () v = GMapUnit (Maybe v) -- deriving Show ghc-exactprint-0.6.2/tests/examples/ghc710/Dead1.hs0000755000000000000000000000243007346545000020055 0ustar0000000000000000{-# OPTIONS -O -ddump-stranal #-} module Dead1(foo) where foo :: Int -> Int foo n = baz (n+1) (bar1 n) {-# NOINLINE bar1 #-} bar1 n = 1 + bar n bar :: Int -> Int {-# NOINLINE bar #-} {-# RULES "bar/foo" forall n. bar (foo n) = n #-} bar n = n-1 baz :: Int -> Int -> Int {-# INLINE [0] baz #-} baz m n = m {- Ronam writes (Feb08) Note that bar becomes dead as soon as baz gets inlined. But strangely, the simplifier only deletes it after full laziness and CSE. That is, it is not deleted in the phase in which baz gets inlined. In fact, it is still there after w/w and the subsequent simplifier run. It gets deleted immediately if I comment out the rule. I stumbled over this when I removed one simplifier run after SpecConstr (at the moment, it runs twice at the end but I don't think that should be necessary). With this change, the original version of a specialised loop (the one with the rules) is not longer deleted even if it isn't used any more. I'll reenable the second simplifier run for now but should this really be necessary? No, it should not be necessary. A refactoring in OccurAnal makes this work right. Look at the simplifier output just before strictness analysis; there should be a binding for 'foo', but for nothing else. -} ghc-exactprint-0.6.2/tests/examples/ghc710/Default.hs0000755000000000000000000000020707346545000020523 0ustar0000000000000000default (Integer, Double) -- "default default" mag :: Float -> Float -> Float mag x y = sqrt( x^2 + y^2 ) main = do print $ mag 1 1 ghc-exactprint-0.6.2/tests/examples/ghc710/DefaultTypeInstance.hs0000755000000000000000000000020607346545000023051 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} class Foldable t where type FoldableConstraint t x :: Constraint type FoldableConstraint t x = () ghc-exactprint-0.6.2/tests/examples/ghc710/Deriving.hs0000755000000000000000000000052107346545000020705 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} import Data.Data data Foo = FooA | FooB deriving instance Show Foo deriving instance {-# Overlappable #-} Eq Foo deriving instance {-# Overlapping #-} Ord Foo deriving instance {-# Overlaps #-} Typeable Foo deriving instance {-# Incoherent #-} Data Foo ghc-exactprint-0.6.2/tests/examples/ghc710/DerivingOC.hs0000755000000000000000000000204407346545000021131 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-15-deriving.html import Data.Data import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.State data MiniIoF a = Terminate | PrintLine String a | ReadLine (String -> a) deriving (Functor) -- data List a = Nil | Cons a (List a) -- deriving (Eq, Show, Functor, Foldable, Traversable) data List a = Nil | Cons a (List a) deriving ( Eq, Show , Functor, Foldable, Traversable , Typeable, Data) data Config = C String String data AppState = S Int Bool newtype App a = App { unApp :: ReaderT Config (StateT AppState IO) a } deriving (Monad, MonadReader Config, MonadState AppState, MonadIO, Applicative,Functor) ghc-exactprint-0.6.2/tests/examples/ghc710/DoParens.hs0000755000000000000000000000004607346545000020653 0ustar0000000000000000 foo = do (-) <- Just 5 return () ghc-exactprint-0.6.2/tests/examples/ghc710/DoPatBind.hs0000755000000000000000000000006307346545000020743 0ustar0000000000000000module Main where bar = do foo :: String <- baz ghc-exactprint-0.6.2/tests/examples/ghc710/DocDecls.hs0000755000000000000000000000014307346545000020616 0ustar0000000000000000module DocDecls where -- | A document before data Foo = A Int | B Char deriving (Show) ghc-exactprint-0.6.2/tests/examples/ghc710/DoubleForall.hs0000755000000000000000000000047407346545000021517 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/DroppedComma.hs0000755000000000000000000000006707346545000021515 0ustar0000000000000000 foo = let (xs, ys) = ([1,2..3], [4,5..6]) in bar ghc-exactprint-0.6.2/tests/examples/ghc710/DroppedDoSpace.hs0000755000000000000000000000237007346545000021776 0ustar0000000000000000import 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 ghc-exactprint-0.6.2/tests/examples/ghc710/DroppedDoSpace2.hs0000755000000000000000000000006507346545000022057 0ustar0000000000000000 save state = do \fileName -> 4 ghc-exactprint-0.6.2/tests/examples/ghc710/EmptyMostly.hs0000755000000000000000000000044607346545000021452 0ustar0000000000000000module EmptyMostly where { ;;; ;;x=let{;;;;;y=2;;z=3;;;;}in y; -- ;;;; class Foo a where {;;;;;; (--<>--) :: a -> a -> Int ; infixl 5 --<>-- ; (--<>--) _ _ = 2 ; -- empty decl at the end. }; -- ;;;;;;;;;;;; -- foo = a where {;;;;;;;;;;;;;;;;;;;;;;;a=1;;;;;;;;} -- ;; } ghc-exactprint-0.6.2/tests/examples/ghc710/EmptyMostly2.hs0000755000000000000000000000015007346545000021524 0ustar0000000000000000module EmptyMostly2 where { ;;;;;;;;;;;; ; class Baz a where {;;;;;;;;; ; baz :: a -> Int;;; } } ghc-exactprint-0.6.2/tests/examples/ghc710/EmptyMostlyInst.hs0000755000000000000000000000025007346545000022301 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module EmptyMostlyInst where { ;;;;;;;;;;;; ; instance Eq (Int,Integer) where {;;;;;;;;; ;;;;;;; a == b = False;;;;;;;;;;; } } ghc-exactprint-0.6.2/tests/examples/ghc710/EmptyMostlyNoSemis.hs0000755000000000000000000000024607346545000022746 0ustar0000000000000000module EmptyMostlyNoSemis where x=let{y=2}in y class Foo a where { (--<>--) :: a -> a -> Int; infixl 5 --<>--; (--<>--) _ _ = 2 ; -- empty decl at the end. } ghc-exactprint-0.6.2/tests/examples/ghc710/Existential.hs0000755000000000000000000000253607346545000021437 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html data HashMap k v = HM -- ... -- actual implementation class Hashable v where h :: v -> Int data HashMapM hm = HashMapM { empty :: forall k v . hm k v , lookup :: Hashable k => k -> hm k v -> Maybe v , insert :: Hashable k => k -> v -> hm k v -> hm k v , union :: Hashable k => hm k v -> hm k v -> hm k v } data HashMapE = forall hm . HashMapE (HashMapM hm) -- public mkHashMapE :: Int -> HashMapE mkHashMapE = HashMapE . mkHashMapM -- private mkHashMapM :: Int -> HashMapM HashMap mkHashMapM salt = HashMapM { {- implementation -} } instance Hashable String where type Name = String data Gift = G String giraffe :: Gift giraffe = G "giraffe" addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift addGift mod gifts = let HashMapM{..} = mod in insert "Ollie" giraffe gifts -- ------------------------------- santa'sSecretSalt = undefined sendGiftToOllie = undefined traverse_ = undefined sendGifts = case mkHashMapE santa'sSecretSalt of HashMapE (mod@HashMapM{..}) -> let gifts = addGift mod empty in traverse_ sendGiftToOllie $ lookup "Ollie" gifts ghc-exactprint-0.6.2/tests/examples/ghc710/ExplicitNamespaces.hs0000755000000000000000000000044407346545000022723 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} module CLaSH.Prelude.BitIndex where import GHC.TypeLits (KnownNat, type (+), type (-)) ghc-exactprint-0.6.2/tests/examples/ghc710/Expr.hs0000755000000000000000000000706607346545000020067 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Expr where import Data.Generics import Language.Haskell.TH as TH import Language.Haskell.TH.Quote -- import Text.ParserCombinators.Parsec -- import Text.ParserCombinators.Parsec.Char data Expr = IntExpr Integer | AntiIntExpr String | BinopExpr BinOp Expr Expr | AntiExpr String deriving(Typeable, Data,Show) data BinOp = AddOp | SubOp | MulOp | DivOp deriving(Typeable, Data,Show) eval :: Expr -> Integer eval (IntExpr n) = n eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y) where opToFun AddOp = (+) opToFun SubOp = (-) opToFun MulOp = (*) opToFun DivOp = (div) small = lower <|> char '_' large = upper idchar = small <|> large <|> digit <|> char '\'' lexeme p = do{ x <- p; spaces; return x } symbol name = lexeme (string name) parens p = undefined -- between (symbol "(") (symbol ")") p _expr :: CharParser st Expr _expr = term `chainl1` mulop term :: CharParser st Expr term = factor `chainl1` addop factor :: CharParser st Expr factor = parens _expr <|> integer <|> anti mulop = undefined {- do{ symbol "*"; return $ BinopExpr MulOp } <|> do{ symbol "/"; return $ BinopExpr DivOp } -} addop = undefined {- do{ symbol "+"; return $ BinopExpr AddOp } <|> do{ symbol "-"; return $ BinopExpr SubOp } -} integer :: CharParser st Expr integer = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) } anti = undefined {- lexeme $ do symbol "$" c <- small cs <- many idchar return $ AntiIntExpr (c : cs) -} parseExpr :: Monad m => TH.Loc -> String -> m Expr parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s = case runParser p () "" s of Left err -> fail $ "baz" Right e -> return e where p = do pos <- getPosition setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file spaces e <- _expr eof return e expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat } parseExprExp :: String -> Q Exp parseExprExp s = do loc <- location expr <- parseExpr loc s dataToExpQ (const Nothing `extQ` antiExprExp) expr antiExprExp :: Expr -> Maybe (Q Exp) antiExprExp (AntiIntExpr v) = Just $ appE (conE (mkName "IntExpr")) (varE (mkName v)) antiExprExp (AntiExpr v) = Just $ varE (mkName v) antiExprExp _ = Nothing parseExprPat :: String -> Q Pat parseExprPat s = do loc <- location expr <- parseExpr loc s dataToPatQ (const Nothing `extQ` antiExprPat) expr antiExprPat :: Expr -> Maybe (Q Pat) antiExprPat (AntiIntExpr v) = Just $ conP (mkName "IntExpr") [varP (mkName v)] antiExprPat (AntiExpr v) = Just $ varP (mkName v) antiExprPat _ = Nothing -- keep parser happy runParser = undefined getPosition = undefined setPosition = undefined setSourceName = undefined setSourceLine = undefined setSourceColumn = undefined spaces = undefined eof = undefined many = undefined digit = undefined many1 = undefined data CharParser a b = F a b (<|>) = undefined chainl1 = undefined string = undefined char = undefined lower = undefined upper = undefined between = undefined instance Monad (CharParser a) where instance Applicative (CharParser a) where instance Functor (CharParser a) where ghc-exactprint-0.6.2/tests/examples/ghc710/ExprPragmas.hs0000755000000000000000000000021207346545000021364 0ustar0000000000000000module ExprPragmas where a = {-# SCC "name" #-} 0x5 b = {-# SCC foo #-} 006 c = {-# GENERATED "foobar" 1 : 2 - 3 : 4 #-} 0.00 ghc-exactprint-0.6.2/tests/examples/ghc710/ExtraConstraints1.hs0000755000000000000000000000064407346545000022540 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module ExtraConstraints1 where arbitCs1 :: _ => a -> String arbitCs1 x = show (succ x) ++ show (x == x) arbitCs2 :: (Show a, _) => a -> String arbitCs2 x = arbitCs1 x arbitCs3 :: (Show a, Enum a, _) => a -> String arbitCs3 x = arbitCs1 x arbitCs4 :: (Eq a, _) => a -> String arbitCs4 x = arbitCs1 x arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String arbitCs5 x = arbitCs1 x ghc-exactprint-0.6.2/tests/examples/ghc710/Field1.hs0000755000000000000000000000034507346545000020246 0ustar0000000000000000module Field1 where --Rename field name 'pointx' to 'pointx1' data Point = Pt {pointx, pointy :: Float} deriving Show absPoint :: Point -> Float absPoint p = sqrt (pointx p * pointx p + pointy p * pointy p) ghc-exactprint-0.6.2/tests/examples/ghc710/FooExpected.hs0000755000000000000000000000022707346545000021346 0ustar0000000000000000 main = case 1 > 10 of True -> do putStrLn "hello" putStrLn "there" False -> do putStrLn "blah" putStrLn "blah" ghc-exactprint-0.6.2/tests/examples/ghc710/ForAll.hs0000755000000000000000000000022007346545000020311 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module ForAll where import Data.Data foo :: (forall a. Data a => a -> a) -> forall a. Data a => a -> a foo a = a ghc-exactprint-0.6.2/tests/examples/ghc710/ForeignDecl.hs0000755000000000000000000000624407346545000021327 0ustar0000000000000000{-# LANGUAGE MagicHash, UnliftedFFITypes #-} {-# LANGUAGE ForeignFunctionInterface #-} -- Based on ghc/testsuite/tests/ffi/should_compile contents module ForeignDecl where import Foreign import GHC.Exts import Data.Int import Data.Word -- simple functions foreign import ccall unsafe "a" a :: IO Int foreign import ccall unsafe "b" b :: Int -> IO Int foreign import ccall unsafe "c" c :: Int -> Char -> Float -> Double -> IO Float -- simple monadic code d = a >>= \ x -> b x >>= \ y -> c y 'f' 1.0 2.0 -- We can't import the same function using both stdcall and ccall -- calling conventions in the same file when compiling via C (this is a -- restriction in the C backend caused by the need to emit a prototype -- for stdcall functions). foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int -- We can't redefine the calling conventions of certain functions (those from -- math.h). foreign import stdcall "my_sin" my_sin :: Double -> IO Double foreign import stdcall "my_cos" my_cos :: Double -> IO Double foreign import stdcall "m1" m8 :: IO Int8 foreign import stdcall "m2" m16 :: IO Int16 foreign import stdcall "m3" m32 :: IO Int32 foreign import stdcall "m4" m64 :: IO Int64 foreign import stdcall "dynamic" d8 :: FunPtr (IO Int8) -> IO Int8 foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16 foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32 foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64 foreign import ccall unsafe "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# -> MutableByteArray# RealWorld -> Int -> Int8 -> Int16 -> Int32 -> Int64 -> Word8 -> Word16 -> Word32 -> Word64 -> Float -> Double -> IO () type Sink2 b = Ptr b -> ByteArray# -> MutableByteArray# RealWorld -> Int -> Int8 -> Int16 -> Int32 -> Word8 -> Word16 -> Word32 -> Float -> Double -> IO () foreign import ccall unsafe "dynamic" sink2 :: Ptr (Sink2 b) -> Sink2 b -- exports foreign export ccall "plusInt" (+) :: Int -> Int -> Int 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 ghc-exactprint-0.6.2/tests/examples/ghc710/FromUtils.hs0000755000000000000000000000120507346545000021062 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} import Data.Data -- --------------------------------------------------------------------- instance AnnotateP RdrName where annotateP l n = do case rdrName2String n of "[]" -> do addDeltaAnnotation AnnOpenS -- '[' addDeltaAnnotation AnnCloseS -- ']' -- --------------------------------------------------------------------- class (Typeable ast) => AnnotateP ast where annotateP :: SrcSpan -> ast -> IO () type SrcSpan = Int rdrName2String = undefined type RdrName = String data A = AnnOpenS | AnnCloseS addDeltaAnnotation = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/FunDeps.hs0000755000000000000000000000023307346545000020502 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -- FunDeps example class Foo a b c | a b -> c where bar :: a -> b -> c ghc-exactprint-0.6.2/tests/examples/ghc710/FunctionalDeps.hs0000755000000000000000000000073207346545000022060 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} -- from https://ocharles.org.uk/blog/posts/2014-12-14-functional-dependencies.html import Data.Foldable (forM_) import Data.IORef class Store store m | store -> m where new :: a -> m (store a) get :: store a -> m a put :: store a -> a -> m () instance Store IORef IO where new = newIORef get = readIORef put ioref a = modifyIORef ioref (const a) ghc-exactprint-0.6.2/tests/examples/ghc710/GADTRecords.hs0000755000000000000000000000134707346545000021206 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/GADTRecords2.hs0000755000000000000000000000025007346545000021260 0ustar0000000000000000{-# LANGUAGE GADTs #-} module GADTRecords2 (H1(..)) where -- | h1 data H1 a b where C3 :: (Num a) => { field :: a -- ^ hello docs } -> H1 Int Int ghc-exactprint-0.6.2/tests/examples/ghc710/GHCOrig.hs0000755000000000000000000011735507346545000020376 0ustar0000000000000000{-# 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___ -} ghc-exactprint-0.6.2/tests/examples/ghc710/GenericDeriving.hs0000755000000000000000000000220607346545000022204 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} import GHC.Generics -- from https://ocharles.org.uk/blog/posts/2014-12-16-derive-generic.html data Valid e a = Error e | OK a deriving (Generic) toEither :: Valid e a -> Either e a toEither (Error e) = Left e toEither (OK a) = Right a fromEither :: Either e a -> Valid e a fromEither (Left e) = Error e fromEither (Right a) = OK a -- --------------------------------------------------------------------- class GetError rep e | rep -> e where getError' :: rep a -> Maybe e instance GetError f e => GetError (M1 i c f) e where getError' (M1 m1) = getError' m1 instance GetError l e => GetError (l :+: r) e where getError' (L1 l) = getError' l getError' (R1 _) = Nothing instance GetError (K1 i e) e where getError' (K1 e) = Just e getError :: (Generic (errorLike e a), GetError (Rep (errorLike e a)) e) => errorLike e a -> Maybe e getError = getError' . from ghc-exactprint-0.6.2/tests/examples/ghc710/Guards.hs0000755000000000000000000000011207346545000020357 0ustar0000000000000000 f x | x > 0, x /= 10 = 1 / x | x == 0 = undefined where y = 4 ghc-exactprint-0.6.2/tests/examples/ghc710/Hang.hs0000755000000000000000000000001607346545000020012 0ustar0000000000000000(~>) = forall ghc-exactprint-0.6.2/tests/examples/ghc710/HangingRecord.hs0000755000000000000000000000006007346545000021646 0ustar0000000000000000 data Foo = Foo { r1 :: Int , r2 :: Int } ghc-exactprint-0.6.2/tests/examples/ghc710/HashQQ.hs0000755000000000000000000000245107346545000020267 0ustar0000000000000000{-# 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")) ghc-exactprint-0.6.2/tests/examples/ghc710/HsDo.hs0000755000000000000000000000112007346545000017767 0ustar0000000000000000module HsDo where import qualified Data.Map as Map moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) where numbered_summaries = zip summaries [1..] node_map :: NodeMap SummaryNode node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) | node@(s, _, _) <- nodes ] graphFromEdgedVertices = undefined nodes = undefined lookup_node = undefined type NodeMap a = Map.Map (Int,Int) (Int,Int,Int) data SummaryNode = SummaryNode moduleName = undefined ms_mod = undefined ms_hsc_src = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/IfThenElse1.hs0000755000000000000000000000022507346545000021206 0ustar0000000000000000-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai main = do cs <- if True then getLine else return "computer input" putStrLn cs ghc-exactprint-0.6.2/tests/examples/ghc710/IfThenElse2.hs0000755000000000000000000000015207346545000021206 0ustar0000000000000000-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai main = if True then print 12 else print 42 ghc-exactprint-0.6.2/tests/examples/ghc710/IfThenElse3.hs0000755000000000000000000000020107346545000021202 0ustar0000000000000000-- From http://lpaste.net/81623, courtesy of Albert Y. C. Lai main = do print 3 if True then do print 5 else print 7 ghc-exactprint-0.6.2/tests/examples/ghc710/ImplicitParams.hs0000755000000000000000000000225607346545000022063 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} -- From https://ocharles.org.uk/blog/posts/2014-12-11-implicit-params.html import Data.Char type LogFunction = String -> IO () type Present = String queueNewChristmasPresents :: LogFunction -> [Present] -> IO () queueNewChristmasPresents logMessage presents = do mapM (logMessage . ("Queueing present for delivery: " ++)) presents return () queueNewChristmasPresents2 :: (?logMessage :: LogFunction) => [Present] -> IO () queueNewChristmasPresents2 presents = do mapM (?logMessage . ("Queueing present for delivery: " ++)) presents return () ex1 :: IO () ex1 = let ?logMessage = \t -> putStrLn ("[XMAS LOG]: " ++ t) in queueNewChristmasPresents2 ["Cuddly Lambda", "Gamma Christmas Pudding"] ex2 :: IO () ex2 = do -- Specifies its own logger ex1 -- We can locally define a new logging function let ?logMessage = \t -> putStrLn (zipWith (\i c -> if even i then c else toUpper c) [0..] t) queueNewChristmasPresents2 ["Category Theory Books"] ghc-exactprint-0.6.2/tests/examples/ghc710/ImplicitSemi.hs0000755000000000000000000000023607346545000021531 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b explicit x ab be = x where ?above = ab; ?below = be ghc-exactprint-0.6.2/tests/examples/ghc710/ImplicitTypeSyn.hs0000755000000000000000000000102407346545000022243 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Imports.hs0000755000000000000000000000026507346545000020600 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ExplicitNamespaces #-} module Imports( f, type (+), pattern Single ) where import GHC.TypeLits pattern Single x = [x] f = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/ImportsSemi.hs0000755000000000000000000000007607346545000021416 0ustar0000000000000000module ImportsSemi where { ; ; ; ; ; ; import Data.List ;;; } ghc-exactprint-0.6.2/tests/examples/ghc710/IndentedDo.hs0000755000000000000000000000111307346545000021151 0ustar0000000000000000 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Infix.hs0000755000000000000000000000015707346545000020220 0ustar0000000000000000 infix 3 &&& (&&&) :: (Eq a) => [a] -> [a] -> [a] (&&& ) [] [] = [] xs &&& [] = xs ( &&&) [] ys = ys ghc-exactprint-0.6.2/tests/examples/ghc710/InfixPatternSynonyms.hs0000755000000000000000000000107707346545000023340 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/InlineSemi.hs0000755000000000000000000000014307346545000021172 0ustar0000000000000000{-# INLINE (|.) #-}; (|.)::Storable a=>Ptr a -> Int -> IO a ; (|.) a i = peekElemOff a i ghc-exactprint-0.6.2/tests/examples/ghc710/Internals.hs0000755000000000000000000003762707346545000021116 0ustar0000000000000000{-# 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 #-} ghc-exactprint-0.6.2/tests/examples/ghc710/Jon.hs0000755000000000000000000000046507346545000017673 0ustar0000000000000000{- ___ -}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 -} ghc-exactprint-0.6.2/tests/examples/ghc710/LambdaCase.hs0000755000000000000000000000062507346545000021117 0ustar0000000000000000{-# 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 } ghc-exactprint-0.6.2/tests/examples/ghc710/LayoutLet.hs0000755000000000000000000000006307346545000021061 0ustar0000000000000000 foo x = let a = 1 b = 2 in x + a + b ghc-exactprint-0.6.2/tests/examples/ghc710/LayoutWhere.hs0000755000000000000000000000007107346545000021406 0ustar0000000000000000 foo x = r where a = 3 b = 4 r = a + a + b ghc-exactprint-0.6.2/tests/examples/ghc710/LetExpr.hs0000755000000000000000000000260607346545000020527 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# Language DeriveFoldable #-} {-# LANGUAGE Safe #-} {-# options_ghc -w #-} -- | A simple let expression, to ensure the layout is detected -- With some haddock in the top {- And a normal multiline comment too -} module {- brah -} LetExpr ( foo -- foo does .. , bar -- bar does .. , Baz () -- baz does .. , Ba ( ..),Ca(Cc,Cd) , bbb , aaa , module Data.List , pattern Bar ) where import Data.List -- A comment in the middle import {-# SOURCE #-} BootImport ( Foo(..) ) import {-# SoURCE #-} safe qualified BootImport as BI import qualified Data.Map as {- blah -} Foo.Map import Control.Monad ( ) import Data.Word (Word8) import Data.Tree hiding ( drawTree ) import qualified Data.Maybe as M hiding ( maybe , isJust ) -- comment foo = let x = 1 y = 2 in x + y bar = 3 bbb x | x == 1 = () | otherwise = () aaa [ ] _ = 0 aaa x _unk = 1 aba () = 0 x `ccc` 1 = x + 1 x `ccc` y = x + y x !@# y = x + y data Baz = Baz1 | Baz2 data Ba = Ba | Bb data Ca = Cc | Cd pattern Foo a <- RealFoo a pattern Bar a <- RealBar a data Thing = RealFoo Thing | RealBar Int ghc-exactprint-0.6.2/tests/examples/ghc710/LetExpr2.hs0000755000000000000000000000004407346545000020603 0ustar0000000000000000l z = let ll = 34 in ll + z ghc-exactprint-0.6.2/tests/examples/ghc710/LetExprSemi.hs0000755000000000000000000000264107346545000021344 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# Language DeriveFoldable #-} {-# LANGUAGE Safe #-} {-# options_ghc -w #-} -- | A simple let expression, to ensure the layout is detected -- With some haddock in the top {- And a normal multiline comment too -} module {- brah -} LetExprSemi ( foo -- foo does .. , bar -- bar does .. , Baz () -- baz does .. , Ba ( ..),Ca(Cc,Cd) , bbb , aaa , module Data.List , pattern Bar ) where { import Data.List -- A comment in the middle ; import {-# SOURCE #-} BootImport ( Foo(..) ) ; import {-# SOURCE #-} safe qualified BootImport as BI ;;; import qualified Data.Map as {- blah -} Foo.Map; import Control.Monad ( ) ; import Data.Word (Word8); import Data.Tree hiding ( drawTree ) ; ; import qualified Data.Maybe as M hiding ( maybe , isJust ) ; -- comment foo = let x = 1 y = 2 in x + y ; bar = 3; bbb x | x == 1 = () | otherwise = () ; aaa [] _ = 0; aaa x _unk = 1 ; x `ccc` 1 = x + 1; x `ccc` y = x + y ; x !@# y = x + y ; data Baz = Baz1 | Baz2 ; data Ba = Ba | Bb ; data Ca = Cc | Cd ; pattern Foo a <- RealFoo a ; pattern Bar a <- RealBar a ; data Thing = RealFoo Thing | RealBar Int } ghc-exactprint-0.6.2/tests/examples/ghc710/LetStmt.hs0000755000000000000000000000023607346545000020535 0ustar0000000000000000-- A simple let statement, to ensure the layout is detected module Layout.LetStmt where foo = do {- ffo -}let x = 1 y = 2 -- baz x+y ghc-exactprint-0.6.2/tests/examples/ghc710/LiftedInfixConstructor.hs0000755000000000000000000000060507346545000023614 0ustar0000000000000000{-# 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) ghc-exactprint-0.6.2/tests/examples/ghc710/LinePragma.hs0000755000000000000000000000226107346545000021160 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/ghc710/ListComprehensions.hs0000755000000000000000000000574607346545000023004 0ustar0000000000000000{-# LANGUAGE ParallelListComp, TransformListComp, RecordWildCards #-} -- MonadComprehensions, -- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html import GHC.Exts import qualified Data.Map as M import Data.Ord (comparing) import Data.List (sortBy) -- Let’s look at a simple, normal list comprehension to start: regularListComp :: [Int] regularListComp = [ x + y * z | x <- [0..10] , y <- [10..20] , z <- [20..30] ] parallelListComp :: [Int] parallelListComp = [ x + y * z | x <- [0..10] | y <- [10..20] | z <- [20..30] ] -- fibs :: [Int] -- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) fibs :: [Int] fibs = 0 : 1 : [ x + y | x <- fibs | y <- tail fibs ] fiblikes :: [Int] fiblikes = 0 : 1 : [ x + y + z | x <- fibs | y <- tail fibs | z <- tail (tail fibs) ] -- TransformListComp data Character = Character { firstName :: String , lastName :: String , birthYear :: Int } deriving (Show, Eq) friends :: [Character] friends = [ Character "Phoebe" "Buffay" 1963 , Character "Chandler" "Bing" 1969 , Character "Rachel" "Green" 1969 , Character "Joey" "Tribbiani" 1967 , Character "Monica" "Geller" 1964 , Character "Ross" "Geller" 1966 ] oldest :: Int -> [Character] -> [String] oldest k tbl = [ firstName ++ " " ++ lastName | Character{..} <- tbl , then sortWith by birthYear , then take k ] groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] groupByLargest f = sortBy (comparing (negate . length)) . groupWith f bestBirthYears :: [Character] -> [(Int, [String])] bestBirthYears tbl = [ (the birthYear, firstName) | Character{..} <- tbl , then group by birthYear using groupByLargest ] 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 ] ghc-exactprint-0.6.2/tests/examples/ghc710/LocalDecls2Expected.hs0000755000000000000000000000012107346545000022703 0ustar0000000000000000module LocalDecls2Expected where foo a = bar a where nn :: Int nn = 2 ghc-exactprint-0.6.2/tests/examples/ghc710/MachineTypes.hs0000755000000000000000000000503107346545000021530 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} -- Safe if eliminate GeneralizedNewtypeInstance {-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Control.Arrow.Machine.Types where import qualified Control.Category as Cat import Data.Profunctor (Profunctor, dimap, rmap) import Control.Arrow import Control.Monad import Control.Monad.Trans import Control.Monad.State import Control.Monad.Reader import Control.Monad.Writer hiding ((<>)) import Control.Monad.Identity import Control.Applicative import Data.Foldable as Fd import Data.Traversable as Tv import Data.Semigroup (Semigroup, (<>)) import Data.Maybe (fromMaybe, isNothing, isJust) import qualified Control.Monad.Trans.Free as F import qualified Control.Monad.Trans.Free.Church as F import Control.Arrow.Machine.ArrowUtil import GHC.Exts (build) -- | To get multiple outputs by one input, the `Phase` parameter is introduced. -- -- Once a value `Feed`ed, the machine is `Sweep`ed until it `Suspend`s. data Phase = Feed | Sweep | Suspend deriving (Eq, Show) instance Monoid Phase where mempty = Sweep mappend Feed _ = Feed mappend _ Feed = Feed mappend Suspend _ = Suspend mappend _ Suspend = Suspend mappend Sweep Sweep = Sweep type ProcType a b c = ProcessA a b c -- | The stream transducer arrow. -- -- To construct `ProcessA` instances, use `Control.Arrow.Machine.Plan.Plan`, -- `arr`, functions declared in `Control.Arrow.Machine.Utils`, -- or arrow combinations of them. -- -- See an introduction at "Control.Arrow.Machine" documentation. data ProcessA a b c = ProcessA { feed :: a b (c, ProcessA a b c), sweep :: a b (Maybe c, ProcessA a b c), suspend :: !(b -> c) } -- For internal use class (Applicative f, Monad f) => ProcessHelper f where step :: ArrowApply a => ProcessA a b c -> a b (f c, ProcessA a b c) helperToMaybe :: f a -> Maybe a weakly :: a -> f a step' :: ArrowApply a => ProcessA a b c -> a (f b) (f c, ProcessA a b c) step' pa = proc hx -> do let mx = helperToMaybe hx maybe (arr $ const (suspend pa <$> hx, pa)) (\x -> proc _ -> step pa -< x) mx -<< () ghc-exactprint-0.6.2/tests/examples/ghc710/MagicHash.hs0000755000000000000000000000102107346545000020756 0ustar0000000000000000{-# 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 <> ghc-exactprint-0.6.2/tests/examples/ghc710/MangledSemiLet.hs0000755000000000000000000000017707346545000021777 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Minimal.hs0000755000000000000000000000151207346545000020525 0ustar0000000000000000class 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) #-} ghc-exactprint-0.6.2/tests/examples/ghc710/Mixed.hs0000755000000000000000000000135207346545000020207 0ustar0000000000000000 import Data.List () import Data.List hiding () infixl 1 `f` -- infixr 2 `\\\` infix 3 :==> infix 4 `MkFoo` data Foo = MkFoo Int | Float :==> Double x `f` y = x (\\\) :: (Eq a) => [a] -> [a] -> [a] (\\\) xs ys = xs g x = x + if True then 1 else 2 h x = x + 1::Int {-# SPECIALISe j :: Int -> Int , Integer -> Integer #-} j n = n + 1 test = let k x y = x+y in 1 `k` 2 `k` 3 data Rec = (:<-:) { a :: Int, b :: Float } ng1 x y = negate y instance (Num a, Num b) => Num (a,b) where {-# Specialise instance Num (Int,Int) #-} negate (a,b) = (ng 'c' a, ng1 'c' b) where ng x y = negate y class Foo1 a where class Foz a x = 2 where y = 3 instance Foo1 Int where ff = ff where g = g where type T = Int ghc-exactprint-0.6.2/tests/examples/ghc710/ModuleOnly.hs0000755000000000000000000000003007346545000021220 0ustar0000000000000000module ModuleOnly where ghc-exactprint-0.6.2/tests/examples/ghc710/MonadComprehensions.hs0000755000000000000000000000145107346545000023114 0ustar0000000000000000{-# LANGUAGE ParallelListComp, TransformListComp, RecordWildCards #-} {-# LANGUAGE MonadComprehensions #-} -- From https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html import GHC.Exts import qualified Data.Map as M import Data.Ord (comparing) import Data.List (sortBy) -- Monad Comprehensions sqrts :: M.Map Int Int sqrts = M.fromList $ [ (x, sx) | x <- map (^2) [1..100] | sx <- [1..100] ] sumIntSqrts :: Int -> Int -> Maybe Int sumIntSqrts a b = [ x + y | x <- M.lookup a sqrts , y <- M.lookup b sqrts ] greet :: IO String greet = [ name | name <- getLine , _ <- putStrLn $ unwords ["Hello, ", name, "!"] ] ghc-exactprint-0.6.2/tests/examples/ghc710/Move1.hs0000755000000000000000000000501507346545000020130 0ustar0000000000000000module Move1 where data Located a = L Int a type Name = String hsBinds = undefined divideDecls = undefined definingDeclsNames = undefined nub = undefined definedPNs :: a -> [b] definedPNs = undefined logm = undefined showGhc = undefined pnsNeedRenaming = undefined concatMap1 = undefined -- liftToTopLevel' :: ModuleName -- -> (ParseResult,[PosToken]) -> FilePath -- -> Located Name -- -> RefactGhc [a] liftToTopLevel' :: Int -> Located Name -> IO [a] liftToTopLevel' modName pn@(L _ n) = do liftToMod return [] where {-step1: divide the module's top level declaration list into three parts: 'parent' is the top level declaration containing the lifted declaration, 'before' and `after` are those declarations before and after 'parent'. step2: get the declarations to be lifted from parent, bind it to liftedDecls step3: remove the lifted declarations from parent and extra arguments may be introduce. step4. test whether there are any names need to be renamed. -} liftToMod :: IO () liftToMod = do -- renamed <- getRefactRenamed let renamed = undefined let declsr = hsBinds renamed let (before,parent,after) = divideDecls declsr pn -- error ("liftToMod:(before,parent,after)=" ++ (showGhc (before,parent,after))) -- ++AZ++ {- ++AZ++ : hsBinds does not return class or instance definitions when (isClassDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from a class declaration!" when (isInstDecl $ ghead "liftToMod" parent) $ error "Sorry, the refactorer cannot lift a definition from an instance declaration!" -} let liftedDecls = definingDeclsNames [n] parent True True declaredPns = nub $ concatMap1 definedPNs liftedDecls -- TODO: what about declarations between this -- one and the top level that are used in this one? logm $ "liftToMod:(liftedDecls,declaredPns)=" ++ (showGhc (liftedDecls,declaredPns)) -- original : pns<-pnsNeedRenaming inscps mod parent liftedDecls declaredPns -- pns <- pnsNeedRenaming renamed parent liftedDecls declaredPns return () ghc-exactprint-0.6.2/tests/examples/ghc710/MultiImplicitParams.hs0000755000000000000000000000027307346545000023073 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} foo = do ev <- let ?mousePosition = relative<$>Reactive (Size 1 1) _size<|*>_mousePos ?buttonChanges = _button in sink return baz ghc-exactprint-0.6.2/tests/examples/ghc710/MultiLineCommentWithPragmas.hs0000755000000000000000000000141407346545000024534 0ustar0000000000000000 {- -- 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 -} ghc-exactprint-0.6.2/tests/examples/ghc710/MultiParamTypeClasses.hs0000755000000000000000000000145207346545000023375 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- From https://ocharles.org.uk/blog/posts/2014-12-13-multi-param-type-classes.html import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT) import Data.Foldable (forM_) import Data.IORef class Store store m where new :: a -> m (store a) get :: store a -> m a put :: store a -> a -> m () type Present = String storePresents :: (Store store m, Monad m) => [Present] -> m (store [Present]) storePresents xs = do store <- new [] forM_ xs $ \x -> do old <- get store put store (x : old) return store instance Store IORef IO where new = newIORef get = readIORef put ioref a = modifyIORef ioref (const a) -- ex ps = do -- store <- storePresents ps -- get (store :: IORef [Present]) ghc-exactprint-0.6.2/tests/examples/ghc710/MultiWayIf.hs0000755000000000000000000000041407346545000021171 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/NestedDoLambda.hs0000755000000000000000000000171007346545000021745 0ustar0000000000000000{-# 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." ghc-exactprint-0.6.2/tests/examples/ghc710/NestedLambda.hs0000755000000000000000000000025607346545000021466 0ustar0000000000000000 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 ghc-exactprint-0.6.2/tests/examples/ghc710/NullaryTypeClasses.hs0000755000000000000000000000067407346545000022755 0ustar0000000000000000{-# LANGUAGE NullaryTypeClasses #-} -- From https://ocharles.org.uk/blog/posts/2014-12-10-nullary-type-classes.html class Logger where logMessage :: String -> IO () type Present = String queueNewChristmasPresents :: Logger => [Present] -> IO () queueNewChristmasPresents presents = do mapM (logMessage . ("Queueing present for delivery: " ++)) presents return () instance Logger where logMessage t = putStrLn ("[XMAS LOG]: " ++ t) ghc-exactprint-0.6.2/tests/examples/ghc710/Obscure.hs0000755000000000000000000000134707346545000020547 0ustar0000000000000000type 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)) ghc-exactprint-0.6.2/tests/examples/ghc710/OptSig.hs0000755000000000000000000000120007346545000020336 0ustar0000000000000000{-# 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))) ghc-exactprint-0.6.2/tests/examples/ghc710/OptSig2.hs0000755000000000000000000000013107346545000020422 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} errors= do let ls :: Int = undefined return () ghc-exactprint-0.6.2/tests/examples/ghc710/OveridingPrimitives.hs0000755000000000000000000000026107346545000023141 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} (~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts) (~#) = cascadeW infixr 0 ~# ghc-exactprint-0.6.2/tests/examples/ghc710/OverloadedStrings.hs0000755000000000000000000000041407346545000022575 0ustar0000000000000000{-# Language OverloadedStrings #-} -- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html import Data.String n :: Num a => a n = 43 f :: Fractional a => a f = 03.1420 -- foo :: Text foo :: Data.String.IsString a => a foo = "hello\n there" ghc-exactprint-0.6.2/tests/examples/ghc710/PArr.hs0000755000000000000000000000060607346545000020006 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module PArr where blah xs ys = [ (x, y) | x <- xs | y <- ys ] -- bar = [: 1, 2 .. 3 :] -- entry point for desugaring a parallel array comprehension -- parr = [:e | qss:] = <<[:e | qss:]>> () [:():] {- ary = let arr1 = toP [1..10] arr2 = toP [1..10] f = [: i1 + i2 | i1 <- arr1 | i2 <- arr2 :] in f !: 1 -} foo = 'a' ghc-exactprint-0.6.2/tests/examples/ghc710/ParensAroundContext.hs0000755000000000000000000000017307346545000023107 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module ParensAroundContext where f :: ((Eq a, _)) => a -> a -> Bool f x y = x == y ghc-exactprint-0.6.2/tests/examples/ghc710/PatBind.hs0000755000000000000000000000066607346545000020471 0ustar0000000000000000module Layout.PatBind where a,b :: Int a = 1 b = 2 c :: Maybe (a -> b) c = Nothing f :: (Num a1, Num a) => a -> a1 -> ( a, a1 ) f x y = ( x+1, y-1 ) -- Chris done comment attachment problem foo = x where -- do stuff doStuff = do stuff x = 1 stuff = 4 -- Pattern bind tup :: (Int, Int) h :: Int t :: Int tup@(h,t) = head $ zip [1..10] [3..ff] where ff :: Int ff = 15 blah = do { ; print "a" ; print "b" } ghc-exactprint-0.6.2/tests/examples/ghc710/PatSigBind.hs0000755000000000000000000000067607346545000021135 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/PatSynBind.hs0000755000000000000000000000556507346545000021166 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} -- From https://ocharles.org.uk/blog/posts/2014-12-03-pattern-synonyms.html import Foreign.C {- data BlendMode = NoBlending -- | AlphaBlending | AdditiveBlending | ColourModulatedBlending toBlendMode :: BlendMode -> CInt toBlendMode NoBlending = 0 -- #{const SDL_BLENDMODE_NONE} -- toBlendMode AlphaBlending = #{const SDL_BLENDMODE_BLEND} fromBlendMode :: CInt -> Maybe BlendMode fromBlendMode 0 = Just NoBlending -} {- pattern AlphaBlending = (1) :: CInt -- #{const SDL_BLENDMODE_BLEND} :: CInt setUpBlendMode :: CInt -> IO () setUpBlendMode AlphaBlending = do putStrLn "Enabling Alpha Blending" activateAlphaBlendingForAllTextures activateRenderAlphaBlending -} newtype BlendMode = MkBlendMode { unBlendMode :: CInt } pattern NoBlending = MkBlendMode 0 -- #{const SDL_BLENDMODE_NONE} pattern AlphaBlending = MkBlendMode 1 -- #{const SDL_BLENDMODE_BLEND} setUpBlendMode :: BlendMode -> IO () setUpBlendMode AlphaBlending = do putStrLn "Enabling Alpha Blending" activateAlphaBlendingForAllTextures activateRenderAlphaBlending data Renderer setRenderAlphaBlending :: Renderer -> IO () setRenderAlphaBlending r = sdlSetRenderDrawBlendMode r (unBlendMode AlphaBlending) activateAlphaBlendingForAllTextures = return () activateRenderAlphaBlending = return () sdlSetRenderDrawBlendMode _ _ = return () -- And from https://www.fpcomplete.com/user/icelandj/Pattern%20synonyms data Date = Date { month :: Int, day :: Int } deriving Show -- Months pattern January day = Date { month = 1, day = day } pattern February day = Date { month = 2, day = day } pattern March day = Date { month = 3, day = day } -- elided pattern December day = Date { month = 12, day = day } -- Holidays pattern Christmas = Date { month = 12, day = 25 } describe :: Date -> String describe (January 1) = "First day of year" describe (February n) = show n ++ "th of February" describe Christmas = "Presents!" describe _ = "meh" pattern Christmas2 = December 25 pattern BeforeChristmas <- December (compare 25 -> GT) pattern Christmas3 <- December (compare 25 -> EQ) pattern AfterChristmas <- December (compare 25 -> LT) react :: Date -> String react BeforeChristmas = "Waiting :(" react Christmas = "Presents!" react AfterChristmas = "Have to wait a whole year :(" react _ = "It's not even December..." isItNow :: Int -> (Ordering, Int) isItNow day = (compare 25 day, day) pattern BeforeChristmas4 day <- December (isItNow -> (GT, day)) pattern Christmas4 <- December (isItNow -> (EQ, _)) pattern AfterChristmas4 day <- December (isItNow -> (LT, day)) days'tilChristmas :: Date -> Int days'tilChristmas (BeforeChristmas4 n) = 25 - n days'tilChristmas Christmas4 = 0 days'tilChristmas (AfterChristmas4 n) = 365 + 25 - n ghc-exactprint-0.6.2/tests/examples/ghc710/PatternGuards.hs0000755000000000000000000000020307346545000021716 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} match n | Just 5 <- Just n , Just 6 <- Nothing , Just 7 <- Just 9 = Just 8 ghc-exactprint-0.6.2/tests/examples/ghc710/ProcNotation.hs0000755000000000000000000000103407346545000021555 0ustar0000000000000000{-#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) ghc-exactprint-0.6.2/tests/examples/ghc710/Process.hs0000755000000000000000000005003607346545000020562 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} module Synthesizer.MIDI.CausalIO.Process ( Events, slice, controllerLinear, controllerExponential, pitchBend, channelPressure, bendWheelPressure, constant, Instrument, Bank, GateChunk, noteEvents, embedPrograms, applyInstrument, applyModulatedInstrument, flattenControlSchedule, applyModulation, arrangeStorable, sequenceCore, sequenceModulated, sequenceModulatedMultiProgram, sequenceModulatedMultiProgramVelocityPitch, sequenceStorable, -- auxiliary function initWith, mapMaybe, ) where import qualified Synthesizer.CausalIO.Gate as Gate import qualified Synthesizer.CausalIO.Process as PIO import qualified Synthesizer.MIDI.Value.BendModulation as BM import qualified Synthesizer.MIDI.Value.BendWheelPressure as BWP import qualified Synthesizer.MIDI.Value as MV import qualified Synthesizer.MIDI.EventList as MIDIEv import Synthesizer.MIDI.EventList (StrictTime, ) import qualified Synthesizer.PiecewiseConstant.Signal as PC import qualified Synthesizer.Storable.Cut as CutSt import qualified Synthesizer.Generic.Cut as CutG import qualified Synthesizer.Zip as Zip import qualified Sound.MIDI.Message.Class.Check as Check import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import Control.DeepSeq (rnf, ) import qualified Data.EventList.Relative.TimeBody as EventList import qualified Data.EventList.Relative.BodyTime as EventListBT import qualified Data.EventList.Relative.TimeTime as EventListTT import qualified Data.EventList.Relative.TimeMixed as EventListTM import qualified Data.EventList.Relative.MixedTime as EventListMT import qualified Data.EventList.Absolute.TimeBody as AbsEventList import qualified Numeric.NonNegative.Wrapper as NonNegW import qualified Numeric.NonNegative.Class as NonNeg import qualified Algebra.Transcendental as Trans import qualified Algebra.RealRing as RealRing import qualified Algebra.Field as Field import qualified Algebra.Additive as Additive import qualified Algebra.ToInteger as ToInteger import qualified Data.StorableVector as SV import qualified Data.StorableVector.ST.Strict as SVST import Foreign.Storable (Storable, ) import qualified Control.Monad.Trans.Writer as MW import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.Trans.Class as MT import Control.Monad.IO.Class (liftIO, ) import qualified Data.Traversable as Trav import Data.Traversable (Traversable, ) import Data.Foldable (traverse_, ) import Control.Arrow (Arrow, arr, (^<<), (<<^), ) import Control.Category ((.), ) import qualified Data.Map as Map import qualified Data.List.HT as ListHT import qualified Data.Maybe as Maybe import Data.Monoid (Monoid, mempty, mappend, ) import Data.Maybe (maybeToList, ) import Data.Tuple.HT (mapFst, mapPair, ) import NumericPrelude.Numeric import NumericPrelude.Base hiding ((.), sequence, ) import Prelude () type Events event = EventListTT.T StrictTime [event] initWith :: (y -> c) -> c -> PIO.T (Events y) (EventListBT.T PC.ShortStrictTime c) initWith f initial = PIO.traverse initial $ \evs0 -> do y0 <- MS.get fmap (PC.subdivideLongStrict . EventListMT.consBody y0) $ Trav.traverse (\ys -> traverse_ (MS.put . f) ys >> MS.get) evs0 slice :: (Check.C event) => (event -> Maybe Int) -> (Int -> y) -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime y) slice select f initial = initWith f initial . mapMaybe select mapMaybe :: (Arrow arrow, Functor f) => (a -> Maybe b) -> arrow (f [a]) (f [b]) mapMaybe f = arr $ fmap $ Maybe.mapMaybe f catMaybes :: (Arrow arrow, Functor f) => arrow (f [Maybe a]) (f [a]) catMaybes = arr $ fmap Maybe.catMaybes traverse :: (Traversable f) => s -> (a -> MS.State s b) -> PIO.T (f [a]) (f [b]) traverse initial f = PIO.traverse initial (Trav.traverse (Trav.traverse f)) controllerLinear :: (Check.C event, Field.C y) => MIDIEv.Channel -> MIDIEv.Controller -> (y,y) -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime y) controllerLinear chan ctrl bnd initial = slice (Check.controller chan ctrl) (MV.controllerLinear bnd) initial controllerExponential :: (Check.C event, Trans.C y) => MIDIEv.Channel -> MIDIEv.Controller -> (y,y) -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime y) controllerExponential chan ctrl bnd initial = slice (Check.controller chan ctrl) (MV.controllerExponential bnd) initial pitchBend :: (Check.C event, Trans.C y) => MIDIEv.Channel -> y -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime y) pitchBend chan range center = slice (Check.pitchBend chan) (MV.pitchBend range center) center channelPressure :: (Check.C event, Trans.C y) => MIDIEv.Channel -> y -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime y) channelPressure chan maxVal initial = slice (Check.channelPressure chan) (MV.controllerLinear (zero,maxVal)) initial bendWheelPressure :: (Check.C event, RealRing.C y, Trans.C y) => MIDIEv.Channel -> Int -> y -> y -> PIO.T (Events event) (EventListBT.T PC.ShortStrictTime (BM.T y)) bendWheelPressure chan pitchRange wheelDepth pressDepth = let toBM = BM.fromBendWheelPressure pitchRange wheelDepth pressDepth in initWith toBM (toBM BWP.deflt) . catMaybes . traverse BWP.deflt (BWP.check chan) -- might be moved to synthesizer-core constant :: (Arrow arrow) => y -> arrow (Events event) (EventListBT.T PC.ShortStrictTime y) constant y = arr $ EventListBT.singleton y . NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . fromIntegral . EventListTT.duration _constant :: (Arrow arrow, CutG.Read input) => y -> arrow input (EventListBT.T PC.ShortStrictTime y) _constant y = arr $ EventListBT.singleton y . NonNegW.fromNumberMsg "MIDI.CausalIO.constant" . CutG.length noteEvents :: (Check.C event, Arrow arrow) => MIDIEv.Channel -> arrow (Events event) (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) noteEvents chan = mapMaybe $ MIDIEv.checkNoteEvent chan embedPrograms :: MIDIEv.Program -> PIO.T (Events (Either MIDIEv.Program (MIDIEv.NoteBoundary Bool))) (Events (MIDIEv.NoteBoundary (Maybe MIDIEv.Program))) embedPrograms initPgm = catMaybes . traverse initPgm MIDIEv.embedProgramState type GateChunk = Gate.Chunk MIDIEv.Velocity type Instrument y chunk = y -> y -> PIO.T GateChunk chunk type Bank y chunk = MIDIEv.Program -> Instrument y chunk {- for distinction of notes with the same pitch We must use Integer instead of Int, in order to avoid an overflow that would invalidate the check for unmatched NoteOffs that is based on comparison of the NoteIds. We cannot re-use NoteIds easily, since the events at one time point are handled out of order. -} newtype NoteId = NoteId Integer deriving (Show, Eq, Ord) succNoteId :: NoteId -> NoteId succNoteId (NoteId n) = NoteId (n+1) flattenNoteIdRange :: (NoteId,NoteId) -> [NoteId] flattenNoteIdRange (start,afterEnd) = takeWhile ( rnf (NonNegW.toNumber t)) . unwrapNoteOffList instance Monoid NoteOffList where mempty = NoteOffList (EventListTT.pause mempty) mappend (NoteOffList xs) (NoteOffList ys) = NoteOffList (mappend xs ys) {- | The function defined here are based on the interpretation of event lists as piecewise constant signals. They do not fit to the interpretation of atomic events. Because e.g. it makes no sense to split an atomic event into two instances by splitAt, and it is also not clear, whether dropping the first chunk shall leave a chunk of length zero or remove that chunk completely. -} instance CutG.Transform NoteOffList where take n (NoteOffList xs) = NoteOffList $ EventListTT.takeTime (NonNegW.fromNumberMsg "NoteOffList.take" $ fromIntegral n) xs drop n (NoteOffList xs) = NoteOffList $ EventListTT.dropTime (NonNegW.fromNumberMsg "NoteOffList.drop" $ fromIntegral n) xs splitAt n (NoteOffList xs) = mapPair (NoteOffList, NoteOffList) $ EventListTT.splitAtTime (NonNegW.fromNumberMsg "NoteOffList.splitAtTime" $ fromIntegral n) xs -- cf. ChunkySize.dropMarginRem dropMarginRem = CutG.dropMarginRemChunky (fmap fromIntegral . EventListTT.getTimes . unwrapNoteOffList) reverse (NoteOffList xs) = NoteOffList . EventListTT.reverse $ xs findEvent :: (a -> Bool) -> Events a -> (Events a, Maybe a) findEvent p = EventListTT.foldr (\t -> mapFst (EventListMT.consTime t)) (\evs rest -> case ListHT.break p evs of (prefix, suffix) -> mapFst (EventListMT.consBody prefix) $ case suffix of [] -> rest ev:_ -> (EventListTT.pause mempty, Just ev)) (EventListBT.empty, Nothing) gateFromNoteOffs :: (MIDIEv.Pitch, NoteId) -> NoteOffList -> GateChunk gateFromNoteOffs pitchNoteId (NoteOffList noteOffs) = let dur = EventListTT.duration noteOffs (sustain, mEnd) = findEvent (\bnd -> case bnd of -- AllNotesOff -> True NoteBoundary endPitch _ noteId -> pitchNoteId == (endPitch, noteId)) noteOffs in Gate.chunk dur $ flip fmap mEnd $ \end -> (EventListTT.duration sustain, case end of NoteBoundary _ endVel _ -> endVel {- AllNotesOff -> VoiceMsg.normalVelocity -} ) data NoteBoundary a = NoteBoundary VoiceMsg.Pitch VoiceMsg.Velocity a -- | AllSoundOff deriving (Eq, Show) {- | We count NoteIds per pitch, such that the pair (pitch,noteId) identifies a note. We treat nested notes in a first-in-first-out order (FIFO). E.g. > On, On, On, Off, Off, Off is interpreted as > On 0, On 1, On 2, Off 0, Off 1, Off 2 NoteOffs without previous NoteOns are thrown away. -} assignNoteIds :: (Traversable f) => PIO.T (f [MIDIEv.NoteBoundary (Maybe MIDIEv.Program)]) (f [NoteBoundary (NoteId, Maybe MIDIEv.Program)]) assignNoteIds = fmap concat ^<< traverse Map.empty (\bnd -> case bnd of MIDIEv.AllNotesOff -> do notes <- MS.get MS.put Map.empty return $ concatMap (\(pitch, range) -> map (\noteId -> NoteBoundary pitch VoiceMsg.normalVelocity (noteId, Nothing)) (flattenNoteIdRange range)) $ Map.toList notes MIDIEv.NoteBoundary pitch vel mpgm -> fmap (fmap (\noteId -> NoteBoundary pitch vel (noteId,mpgm))) $ case mpgm of Nothing -> do mNoteId <- MS.gets (Map.lookup pitch) case mNoteId of Nothing -> return [] Just (nextNoteOffId, nextNoteOnId) -> if nextNoteOffId >= nextNoteOnId then return [] else do MS.modify (Map.insert pitch (succNoteId nextNoteOffId, nextNoteOnId)) return [nextNoteOffId] Just _ -> do mNoteId <- MS.gets (Map.lookup pitch) let (nextNoteOffId, nextNoteOnId) = case mNoteId of Nothing -> (NoteId 0, NoteId 0) Just ids -> ids MS.modify (Map.insert pitch (nextNoteOffId, succNoteId nextNoteOnId)) return [nextNoteOnId]) {-# INLINE velFreqBank #-} velFreqBank :: (Trans.C y) => (MIDIEv.Program -> y -> y -> process) -> (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> process) velFreqBank bank pgm vel pitch = bank pgm (MV.velocity vel) (MV.frequencyFromPitch pitch) applyInstrumentCore :: (Arrow arrow) => ((MIDIEv.Pitch, NoteId) -> noteOffListCtrl -> gateCtrl) -> (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> PIO.T gateCtrl chunk) -> arrow (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) (Zip.T NoteOffList (Events (PIO.T noteOffListCtrl chunk))) applyInstrumentCore makeGate bank = arr $ uncurry Zip.Cons . mapFst NoteOffList . EventListTT.unzip . fmap (ListHT.unzipEithers . fmap (\ev -> case ev of -- MIDIEv.AllNotesOff -> Left MIDIEv.AllNotesOff NoteBoundary pitch vel (noteId, mpgm) -> case mpgm of Nothing -> Left $ NoteBoundary pitch vel noteId Just pgm -> Right $ bank pgm vel pitch <<^ makeGate (pitch, noteId))) applyInstrument :: (Arrow arrow) => (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> PIO.T GateChunk chunk) -> arrow (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) (Zip.T NoteOffList (Events (PIO.T NoteOffList chunk))) applyInstrument bank = applyInstrumentCore gateFromNoteOffs bank type ModulatedBank y ctrl chunk = MIDIEv.Program -> y -> y -> PIO.T (Zip.T GateChunk ctrl) chunk applyModulatedInstrument :: (Arrow arrow, CutG.Read ctrl) => (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> PIO.T (Zip.T GateChunk ctrl) chunk) -> arrow (Zip.T (Events (NoteBoundary (NoteId, Maybe MIDIEv.Program))) ctrl) (Zip.T (Zip.T NoteOffList ctrl) (Events (PIO.T (Zip.T NoteOffList ctrl) chunk))) applyModulatedInstrument bank = (\(Zip.Cons (Zip.Cons noteOffs events) ctrl) -> Zip.Cons (Zip.Cons noteOffs ctrl) events) ^<< Zip.arrowFirst (applyInstrumentCore (Zip.arrowFirst . gateFromNoteOffs) bank) {- | Turn an event list with bundles of elements into an event list with single events. ToDo: Move to event-list package? -} flatten :: (NonNeg.C time) => a -> EventListTT.T time [a] -> EventListTT.T time a flatten empty = EventListTT.foldr EventListMT.consTime (\bt xs -> uncurry EventListMT.consBody $ case bt of [] -> (empty, xs) b:bs -> (b, foldr (\c rest -> EventListTT.cons NonNeg.zero c rest) xs bs)) EventListBT.empty flattenControlSchedule :: (Monoid chunk, Arrow arrow) => arrow (Zip.T ctrl (EventListTT.T StrictTime [PIO.T ctrl chunk])) (Zip.T ctrl (EventListTT.T StrictTime (PIO.T ctrl chunk))) flattenControlSchedule = arr $ \(Zip.Cons ctrl evs) -> -- Zip.consChecked "flattenControlSchedule" ctrl $ Zip.Cons ctrl $ flatten (arr (const mempty)) evs data CausalState a b = forall state. CausalState (a -> state -> IO (b, state)) (state -> IO ()) state _applyChunkSimple :: CausalState a b -> a -> IO (b, CausalState a b) _applyChunkSimple (CausalState next delete state0) input = do (output, state1) <- next input state0 return (output, CausalState next delete state1) applyChunk :: (CutG.Read a, CutG.Read b) => CausalState a b -> a -> IO (b, Maybe (CausalState a b)) applyChunk (CausalState next delete state0) input = do (output, state1) <- next input state0 cs <- if CutG.length output < CutG.length input then do delete state1 return Nothing else return $ Just $ CausalState next delete state1 return (output, cs) -- could be moved to synthesizer-core applyModulation :: (CutG.Transform ctrl, CutG.NormalForm ctrl, CutG.Read chunk, Monoid time, ToInteger.C time) => PIO.T (Zip.T ctrl (EventListTT.T time (PIO.T ctrl chunk))) (EventListTT.T time chunk) applyModulation = PIO.Cons (\(Zip.Cons ctrl evs) acc0 -> do acc1 <- mapM (flip applyChunk ctrl) acc0 let (accChunks, acc2) = unzip acc1 (newChunks, newAcc) <- MW.runWriterT $ flip MS.evalStateT ctrl $ EventListTT.mapM (\time -> do ctrl_ <- MS.gets (CutG.drop (fromIntegral time)) MS.put ctrl_ return (case CutG.evaluateHead ctrl_ of () -> time)) (\(PIO.Cons next create delete) -> do state0 <- liftIO create (chunk, state1) <- liftIO . applyChunk (CausalState next delete state0) =<< MS.get MT.lift $ MW.tell $ maybeToList state1 return chunk) evs return (EventListTM.prependBodyEnd (EventList.fromPairList $ map ((,) mempty) accChunks) newChunks, Maybe.catMaybes acc2 ++ newAcc)) (return []) (mapM_ (\(CausalState _ close state) -> close state)) -- move synthesizer-core:CausalIO arrangeStorable :: (Arrow arrow, Storable a, Additive.C a) => arrow (EventListTT.T StrictTime (SV.Vector a)) (SV.Vector a) arrangeStorable = arr $ \evs -> SVST.runSTVector (do v <- SVST.new (fromIntegral $ EventListTT.duration evs) zero mapM_ (uncurry $ CutSt.addChunkToBuffer v) $ AbsEventList.toPairList $ AbsEventList.mapTime fromIntegral $ EventList.toAbsoluteEventList 0 $ EventListTM.switchTimeR const evs return v) sequenceCore :: (Check.C event, Monoid chunk, CutG.Read chunk, Trans.C y) => MIDIEv.Channel -> Bank y chunk -> PIO.T (Events event) (EventListTT.T StrictTime chunk) sequenceCore channel bank = applyModulation . flattenControlSchedule . applyInstrument (velFreqBank bank) . assignNoteIds . embedPrograms (VoiceMsg.toProgram 0) . noteEvents channel sequenceModulated :: (Check.C event, Monoid chunk, CutG.Read chunk, CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => MIDIEv.Channel -> ModulatedBank y ctrl chunk -> PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) sequenceModulated channel bank = applyModulation . flattenControlSchedule . applyModulatedInstrument (velFreqBank bank) . Zip.arrowFirst (assignNoteIds . embedPrograms (VoiceMsg.toProgram 0) . noteEvents channel) sequenceModulatedMultiProgram :: (Check.C event, Monoid chunk, CutG.Read chunk, CutG.Transform ctrl, CutG.NormalForm ctrl, Trans.C y) => MIDIEv.Channel -> MIDIEv.Program -> ModulatedBank y ctrl chunk -> PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) sequenceModulatedMultiProgram channel initPgm bank = applyModulation . flattenControlSchedule . applyModulatedInstrument (velFreqBank bank) . Zip.arrowFirst (assignNoteIds . embedPrograms initPgm . noteEvents channel) -- | may replace the other functions sequenceModulatedMultiProgramVelocityPitch :: (Check.C event, Monoid chunk, CutG.Read chunk, CutG.Transform ctrl, CutG.NormalForm ctrl) => MIDIEv.Channel -> MIDIEv.Program -> (MIDIEv.Program -> MIDIEv.Velocity -> MIDIEv.Pitch -> PIO.T (Zip.T GateChunk ctrl) chunk) -> PIO.T (Zip.T (Events event) ctrl) (EventListTT.T StrictTime chunk) sequenceModulatedMultiProgramVelocityPitch channel initPgm bank = applyModulation . flattenControlSchedule . applyModulatedInstrument bank . Zip.arrowFirst (assignNoteIds . embedPrograms initPgm . noteEvents channel) sequenceStorable :: (Check.C event, Storable a, Additive.C a, Trans.C y) => MIDIEv.Channel -> Bank y (SV.Vector a) -> PIO.T (Events event) (SV.Vector a) sequenceStorable channel bank = arrangeStorable . sequenceCore channel bank ghc-exactprint-0.6.2/tests/examples/ghc710/Process1.hs0000755000000000000000000000024307346545000020636 0ustar0000000000000000module Synthesizer.MIDI.CausalIO.Process1 where gateFromNoteOffs= let dur = 1 in (d, 3 {- AllNotesOff -> VoiceMsg.normalVelocity -} ) ghc-exactprint-0.6.2/tests/examples/ghc710/Pseudonym.hs0000755000000000000000000000412307346545000021123 0ustar0000000000000000default(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 ghc-exactprint-0.6.2/tests/examples/ghc710/PuncFunctions.hs0000755000000000000000000000177707346545000021752 0ustar0000000000000000-- | 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 ghc-exactprint-0.6.2/tests/examples/ghc710/QuasiQuote.hs0000755000000000000000000000110607346545000021236 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module QuasiQuote where import T7918A ex1 = [qq|e1|] ex2 = [qq|e2|] ex3 = [qq|e3|] ex4 = [qq|e4|] tx1 = undefined :: [qq|t1|] tx2 = undefined :: [qq|t2|] tx3 = undefined :: [qq|t3|] tx4 = undefined :: [qq|t4|] px1 [qq|p1|] = undefined px2 [qq|p2|] = undefined px3 [qq|p3|] = undefined px4 [qq|p4|] = undefined {-# 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")) ghc-exactprint-0.6.2/tests/examples/ghc710/QuasiQuote2.hs0000755000000000000000000000034307346545000021322 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Test where a = bar where bar = [q| |] b = bar where bar = [q| |] c = bar where bar = [q| |] d = [q| |] ghc-exactprint-0.6.2/tests/examples/ghc710/RSA.hs0000755000000000000000000000200607346545000017563 0ustar0000000000000000import 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 ghc-exactprint-0.6.2/tests/examples/ghc710/RankNTypes.hs0000755000000000000000000000617007346545000021202 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-18-rank-n-types.html import System.Random import Control.Monad.State import Data.Char id' :: forall a. a -> a id' x = x f = print (id' (3 :: Integer), id' "blah") -- rank 2 polymorphism type IdFunc = forall a. a -> a id'' :: IdFunc id'' x = x someInt :: IdFunc -> Integer someInt id' = id' 3 -- rank 3 polymorphism type SomeInt = IdFunc -> Integer someOtherInt :: SomeInt -> Integer someOtherInt someInt' = someInt' id + someInt' id -- random numbers data Player = Player { playerName :: String, playerPos :: (Double, Double) } deriving (Eq, Ord, Show) {- randomPlayer :: (MonadIO m, MonadState g m, RandomGen g) => m Player -} type GenAction m = forall a. (Random a) => m a type GenActionR m = forall a. (Random a) => (a, a) -> m a -- genRandom :: (RandomGen g) => GenAction (State g) -- genRandom = state random genRandomR :: (RandomGen g) => GenActionR (State g) genRandomR range = state (randomR range) genRandom :: (Random a, RandomGen g) => State g a genRandom = state random randomPlayer :: (MonadIO m) => GenActionR m -> m Player randomPlayer genR = do liftIO (putStrLn "Generating random player...") len <- genR (8, 12) name <- replicateM len (genR ('a', 'z')) x <- genR (-100, 100) y <- genR (-100, 100) liftIO (putStrLn "Done.") return (Player name (x, y)) main :: IO () main = randomPlayer randomRIO >>= print -- scott encoding data List a = Cons a (List a) | Nil uncons :: (a -> List a -> r) -> r -> List a -> r uncons co ni (Cons x xs) = co x xs uncons co ni Nil = ni listNull :: List a -> Bool listNull = uncons (\_ _ -> False) True listMap :: (a -> b) -> List a -> List b listMap f = uncons (\x xs -> Cons (f x) (listMap f xs)) Nil newtype ListS a = ListS { unconsS :: forall r. (a -> ListS a -> r) -> r -> r } nilS :: ListS a nilS = ListS (\co ni -> ni) consS :: a -> ListS a -> ListS a consS x xs = ListS (\co ni -> co x xs) unconsS' :: (a -> ListS a -> r) -> r -> ListS a -> r unconsS' co ni (ListS f) = f co ni instance Functor ListS where fmap f = unconsS' (\x xs -> consS (f x) (fmap f xs)) nilS -- Church Encoding newtype ListC a = ListC { foldC :: forall r. (a -> r -> r) -> r -> r } foldC' :: (a -> r -> r) -> r -> ListC a -> r foldC' co ni (ListC f) = f co ni instance Functor ListC where fmap f = foldC' (\x xs -> consC (f x) xs) nilC consC = undefined nilC = undefined -- GADTs and continuation passing style data Some :: * -> * where SomeInt :: Int -> Some Int SomeChar :: Char -> Some Char Anything :: a -> Some a unSome :: Some a -> a unSome (SomeInt x) = x + 3 unSome (SomeChar c) = toLower c unSome (Anything x) = x newtype SomeC a = SomeC { runSomeC :: forall r. ((a ~ Int) => Int -> r) -> ((a ~ Char) => Char -> r) -> (a -> r) -> r } -- dependent types idk :: forall (a :: *). a -> a idk x = x ghc-exactprint-0.6.2/tests/examples/ghc710/RdrNames.hs0000755000000000000000000001252107346545000020654 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples #-} module RdrNames where import Data.Monoid -- --------------------------------------------------------------------- -- | 'type' qcname {% amms (mkTypeImpExp (sLL $1 $> (unLoc $2))) -- [mj AnnType $1,mj AnnVal $2] } -- Tested in DataFamilies.hs -- --------------------------------------------------------------------- -- | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) -- [mo $1,mj AnnVal $2,mc $3] } ff = (RdrNames.:::) 0 1 -- --------------------------------------------------------------------- -- | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) -- [mo $1,mj AnnVal $2,mc $3] } data FF = ( ::: ) Int Int -- --------------------------------------------------------------------- -- | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) -- [mj AnnBackquote $1,mj AnnVal $2 -- ,mj AnnBackquote $3] } data GG = GG Int Int gg = 0 ` GG ` 1 -- --------------------------------------------------------------------- -- | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) -- [mj AnnBackquote $1,mj AnnVal $2 -- ,mj AnnBackquote $3] } vv = "a" ` mappend ` "b" -- --------------------------------------------------------------------- -- | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) -- [mj AnnBackquote $1,mj AnnVal $2 -- ,mj AnnBackquote $3] } vvq = "a" ` Data.Monoid.mappend ` "b" -- --------------------------------------------------------------------- -- | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) -- [mo $1,mc $2] } -- Tested in Vect.hs -- --------------------------------------------------------------------- -- | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) -- [mo $1,mc $2] } -- Tested in Vect.hs -- --------------------------------------------------------------------- -- | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon BoxedTuple -- (snd $2 + 1))) -- (mo $1:mc $3:(mcommas (fst $2))) } ng :: (, , ,) Int Int Int Int ng = undefined -- --------------------------------------------------------------------- -- | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon UnboxedTuple -- (snd $2 + 1))) -- (mo $1:mc $3:(mcommas (fst $2))) } -- Tested in Unboxed.hs -- --------------------------------------------------------------------- -- | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) -- [mo $1,mj AnnRarrow $2,mc $3] } ft :: (->) a b ft = undefined fp :: ( -> ) a b fp = undefined type family F a :: * -> * -> * type instance F Int = (->) type instance F Char = ( , ) -- --------------------------------------------------------------------- -- | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mo $1,mc $2] } lt :: [] a lt = undefined -- --------------------------------------------------------------------- -- | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } -- GHC source indicates this constuctor is only available in PrelPArr -- ltp :: [::] a -- ltp = undefined -- --------------------------------------------------------------------- -- | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) -- [mo $1,mj AnnTildehsh $2,mc $3] } -- primitive type? -- Refl Int :: ~# * Int Int -- Refl Maybe :: ~# (* -> *) Maybe Maybe -- | 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 ( ~ ) a b = Eq# (( ~# ) a b) data Coercible a b = MkCoercible ((~#) a b) -- --------------------------------------------------------------------- -- | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) -- [mo $1,mj AnnVal $2,mc $3] } -- TBD -- --------------------------------------------------------------------- -- | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) -- [mo $1,mj AnnTilde $2,mc $3] } -- --------------------------------------------------------------------- -- tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) -- [mj AnnBackquote $1,mj AnnVal $2 -- ,mj AnnBackquote $3] } -- --------------------------------------------------------------------- {- From #haskell-emacs gracjan> did you know that this is legal haskell: (+ 1) ` fmap {- -} ` [1,2,3] -} xxx = (+ 1) ` fmap {- -} ` [1,2,3] ghc-exactprint-0.6.2/tests/examples/ghc710/RebindableSyntax.hs0000755000000000000000000000175707346545000022410 0ustar0000000000000000{-# LANGUAGE RebindableSyntax, NoMonomorphismRestriction #-} -- From https://ocharles.org.uk/blog/guest-posts/2014-12-06-rebindable-syntax.html import Prelude hiding ((>>), (>>=), return) import Data.Monoid import Control.Monad ((<=<)) import Data.Map as M addNumbers = do 80 60 10 where (>>) = (+) return = return (>>) = mappend return = mempty -- We can perform the same computation as above using the Sum wrapper: someSum :: Sum Int someSum = do Sum 80 Sum 60 Sum 10 return someProduct :: Product Int someProduct = do Product 10 Product 30 -- Why not try something non-numeric? tummyMuscle :: String tummyMuscle = do "a" "b" ff = let (>>) = flip (.) return = id arithmetic = do (+1) (*100) (/300) return -- Here, the input is numeric and all functions operate on a number. -- What if we want to take a list and output a string? No problem: check = do sum sqrt floor show in 4 ghc-exactprint-0.6.2/tests/examples/ghc710/RecordSemi.hs0000755000000000000000000000133707346545000021200 0ustar0000000000000000-- | 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] } ghc-exactprint-0.6.2/tests/examples/ghc710/RecordUpdate.hs0000755000000000000000000000013407346545000021517 0ustar0000000000000000 data Foo = F { f1 :: Int, f2 :: String } foo :: Int -> Foo -> Foo foo v f = f { f1 = v } ghc-exactprint-0.6.2/tests/examples/ghc710/RecordWildcard.hs0000755000000000000000000000016107346545000022026 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} parseArgs = Args { equalProb = E `elem` opts , .. } ghc-exactprint-0.6.2/tests/examples/ghc710/RecursiveDo.hs0000755000000000000000000000323007346545000021370 0ustar0000000000000000{-# LANGUAGE RecursiveDo #-} -- From https://ocharles.org.uk/blog/posts/2014-12-09-recursive-do.html import Control.Monad.Fix data RoseTree a = RoseTree a [RoseTree a] deriving (Show) exampleTree :: RoseTree Int exampleTree = RoseTree 5 [RoseTree 4 [], RoseTree 6 []] pureMax :: Ord a => RoseTree a -> RoseTree (a, a) pureMax tree = let (t, largest) = go largest tree in t where go :: Ord a => a -> RoseTree a -> (RoseTree (a, a), a) go biggest (RoseTree x []) = (RoseTree (x, biggest) [], x) go biggest (RoseTree x xs) = let sub = map (go biggest) xs (xs', largests) = unzip sub in (RoseTree (x, biggest) xs', max x (maximum largests)) t = pureMax exampleTree -- --------------------------------------------------------------------- impureMin :: (MonadFix m, Ord b) => (a -> m b) -> RoseTree a -> m (RoseTree (a, b)) impureMin f tree = do rec (t, largest) <- go largest tree return t where go smallest (RoseTree x []) = do b <- f x return (RoseTree (x, smallest) [], b) go smallest (RoseTree x xs) = do sub <- mapM (go smallest) xs b <- f x let (xs', bs) = unzip sub return (RoseTree (x, smallest) xs', min b (minimum bs)) budget :: String -> IO Int budget "Ada" = return 10 -- A struggling startup programmer budget "Curry" = return 50 -- A big-earner in finance budget "Dijkstra" = return 20 -- Teaching is the real reward budget "Howard" = return 5 -- An frugile undergraduate! inviteTree = RoseTree "Ada" [ RoseTree "Dijkstra" [] , RoseTree "Curry" [ RoseTree "Howard" []] ] ti = impureMin budget inviteTree simplemdo = mdo return 5 ghc-exactprint-0.6.2/tests/examples/ghc710/RedundantDo.hs0000755000000000000000000000006307346545000021346 0ustar0000000000000000foo = case x of True -> foo False -> foo ghc-exactprint-0.6.2/tests/examples/ghc710/Remorse.hs0000755000000000000000000001172507346545000020562 0ustar0000000000000000import 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; ghc-exactprint-0.6.2/tests/examples/ghc710/Roles.hs0000755000000000000000000000047707346545000020234 0ustar0000000000000000{-# LANGUAGE RoleAnnotations, PolyKinds #-} module Roles where data T1 a = K1 a data T2 a = K2 a data T3 (a :: k) = K3 data T4 (a :: * -> *) b = K4 (a b) data T5 a = K5 a data T6 a = K6 data T7 a b = K7 b type role T1 nominal type role T2 representational type role T3 phantom type role T4 nominal _ type role T5 _ ghc-exactprint-0.6.2/tests/examples/ghc710/Rules.hs0000755000000000000000000000124507346545000020234 0ustar0000000000000000module Rules where import Data.Char {-# RULES "map-loop" [ ~ ] forall f . map' f = map' (id . f) #-} {-# NOINLINE map' #-} map' f [] = [] map' f (x:xs) = f x : map' f xs main = print (map' toUpper "Hello, World") -- Should warn foo1 x = x {-# RULES "foo1" [ 1] forall x. foo1 x = x #-} -- Should warn foo2 x = x {-# INLINE foo2 #-} {-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-} -- Should not warn foo3 x = x {-# NOINLINE foo3 #-} {-# RULES "foo3" forall x. foo3 x = x #-} {-# NOINLINE f #-} f :: Int -> String f x = "NOT FIRED" {-# NOINLINE neg #-} neg :: Int -> Int neg = negate {-# RULES "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED" #-} ghc-exactprint-0.6.2/tests/examples/ghc710/RulesSemi.hs0000755000000000000000000000071407346545000021052 0ustar0000000000000000 {-# 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 #-}; ghc-exactprint-0.6.2/tests/examples/ghc710/ScopedTypeVariables.hs0000755000000000000000000000057407346545000023056 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-20-scoped-type-variables.html import qualified Data.Map as Map insertMany :: forall k v . Ord k => (v -> v -> v) -> [(k,v)] -> Map.Map k v -> Map.Map k v insertMany f vs m = foldr f1 m vs where f1 :: (k, v) -> Map.Map k v -> Map.Map k v f1 (k,v) m = Map.insertWith f k v m ghc-exactprint-0.6.2/tests/examples/ghc710/SemiInstance.hs0000755000000000000000000000043207346545000021521 0ustar0000000000000000 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; } ghc-exactprint-0.6.2/tests/examples/ghc710/SemiWorkout.hs0000755000000000000000000000773207346545000021441 0ustar0000000000000000{-# 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) } ghc-exactprint-0.6.2/tests/examples/ghc710/Shebang.hs0000755000000000000000000000013507346545000020506 0ustar0000000000000000#!/usr/bin/env runhaskell {-# LANGUAGE OverloadedStrings #-} import Aws.SSSP.App main = web ghc-exactprint-0.6.2/tests/examples/ghc710/ShiftingLambda.hs0000755000000000000000000000143707346545000022021 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Sigs.hs0000755000000000000000000000102707346545000020045 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Sigs where -- TypeSig f :: Num a => a -> a f = undefined pattern Single :: () => (Show a) => a -> [a] pattern Single x = [x] g :: (Show a) => [a] -> a g (Single x) = x -- Fixities infixr 6 +++ infixr 7 ***,/// (+++) :: Int -> Int -> Int a +++ b = a + 2*b (***) :: Int -> Int -> Int a *** b = a - 4*b (///) :: Int -> Int -> Int a /// b = 2*a - 3*b -- Inline signatures {-# Inline g #-} {-# INLINE [~34] f #-} -- Specialise signature -- Multiple sigs x,y,z :: Int x = 0 y = 0 z = 0 ghc-exactprint-0.6.2/tests/examples/ghc710/Simple.hs0000755000000000000000000000011507346545000020366 0ustar0000000000000000 -- blah x :: (Int) x = 1 (y) = 1 z :: t z = do let a = 1 return a ghc-exactprint-0.6.2/tests/examples/ghc710/SimpleComplexTuple.hs0000755000000000000000000000002707346545000022732 0ustar0000000000000000 foo ((-),(.))= (5,6) ghc-exactprint-0.6.2/tests/examples/ghc710/SimpleDo.hs0000755000000000000000000000006107346545000020651 0ustar0000000000000000 foo = do let x = 1 -- a comment return x ghc-exactprint-0.6.2/tests/examples/ghc710/SlidingDataClassDecl.hs0000755000000000000000000000073607346545000023107 0ustar0000000000000000{-# 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)] ghc-exactprint-0.6.2/tests/examples/ghc710/SlidingDoClause.hs0000755000000000000000000000072107346545000022151 0ustar0000000000000000 -- :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 } ghc-exactprint-0.6.2/tests/examples/ghc710/SlidingLambda.hs0000755000000000000000000000016007346545000021627 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} foo = choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps ghc-exactprint-0.6.2/tests/examples/ghc710/SlidingListComp.hs0000755000000000000000000000047707346545000022214 0ustar0000000000000000 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] ghc-exactprint-0.6.2/tests/examples/ghc710/SlidingRecordSetter.hs0000755000000000000000000000032507346545000023057 0ustar0000000000000000 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) ghc-exactprint-0.6.2/tests/examples/ghc710/SpacesSplice.hs0000755000000000000000000000011207346545000021510 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} makeLenses '' PostscriptFont ghc-exactprint-0.6.2/tests/examples/ghc710/Splice.hs0000755000000000000000000000254307346545000020363 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} module Splice where import Language.Haskell.TH.Syntax import Language.Haskell.TH foo $( return $ VarP $ mkName "x" ) = x bar $( [p| x |] ) = x baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |] class Eq a => MyClass a data Foo = Foo deriving Eq instance MyClass Foo data Bar = Bar deriving Eq type Baz = Bar instance MyClass Baz data Quux a = Quux a deriving Eq data Quux2 a = Quux2 a deriving Eq instance Eq a => MyClass (Quux a) instance Ord a => MyClass (Quux2 a) class MyClass2 a b instance MyClass2 Int Bool makeLenses '' PostscriptFont $(return []) main = do putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) print $(isInstance ''Eq [ConT ''Foo] >>= lift) print $(isInstance ''MyClass [ConT ''Foo] >>= lift) print $ not $(isInstance ''Show [ConT ''Foo] >>= lift) print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one print $(isInstance ''MyClass [ConT ''Baz] >>= lift) print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift) ghc-exactprint-0.6.2/tests/examples/ghc710/SpliceSemi.hs0000755000000000000000000000014007346545000021170 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} $(makePredicates ''TheType) ; $(makePredicatesNot ''TheType) ghc-exactprint-0.6.2/tests/examples/ghc710/StaticPointers.hs0000755000000000000000000000134007346545000022111 0ustar0000000000000000{-# LANGUAGE StaticPointers #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} module Main where import GHC.StaticPtr import GHC.Word import GHC.Generics import Data.Data import Data.Binary import Data.ByteString fact :: Int -> Int fact 0 = 1 fact n = n * fact (n - 1) main = do let sptr :: StaticPtr (Int -> Int) sptr = static fact print $ staticPtrInfo sptr print $ deRefStaticPtr sptr 10 -- --------------------------------------------------------------------- type StaticKey1 = Fingerprint -- Defined in GHC.Fingerprint. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 deriving (Generic, Typeable) staticKey :: StaticPtr a -> StaticKey1 staticKey = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/Stmts.hs0000755000000000000000000000037407346545000020256 0ustar0000000000000000module Stmts where -- Make sure we get all the semicolons in statements foo :: IO () foo = do do { ;;;; a } a bar :: IO () bar = do { ; a ;; b } baz :: IO () baz = do { ;; s ; s ; ; s ;; } a = undefined b = undefined s = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/StrangeTypeClass.hs0000755000000000000000000000041007346545000022366 0ustar0000000000000000 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Stream.hs0000755000000000000000000000763407346545000020405 0ustar0000000000000000module Stream (Stream, carry, addStream, rationalToStream, streamToFloat, addFiniteStream, negate', average) where import Data.Ratio type Digit = Integer type Stream = [Integer] -- Convert from a Rational fraction to its stream representation rationalToStream :: Rational -> Stream rationalToStream x |t<1 = 0:rationalToStream t |otherwise = 1:rationalToStream (t-1) where t = 2*x -- Convert from a stream to the Float value streamToFloat :: Stream -> Float streamToFloat x = f x (1) f :: Stream -> Integer -> Float f [] n = 0 f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1) -- Add two stream addStream :: Stream -> Stream -> Stream addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys)) where u = interim x1 x2 y1 y2 c = carry x2 x3 y2 y3 -- Compute carry, the C(i) value, given x(i) and y(i) carry :: Digit -> Digit -> Digit -> Digit -> Digit carry x1 x2 y1 y2 |t>1 = 1 |t<(-1) = -1 |t==1 && (minus1 x2 y2) = 0 |t==1 && not (minus1 x2 y2) = 1 |t==(-1) && (minus1 x2 y2) = -1 |t==(-1) && not (minus1 x2 y2) = 0 |t==0 = 0 where t = x1+y1 -- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i) interim :: Digit -> Digit -> Digit -> Digit -> Digit interim x1 x2 y1 y2 |t>1 = 0 |t<(-1) = 0 |t==1 && (minus1 x2 y2) = 1 |t==1 && not (minus1 x2 y2) = -1 |t==(-1) && (minus1 x2 y2) = 1 |t==(-1) && not (minus1 x2 y2) = -1 |t==0 = 0 where t = x1+y1 -- Check if at least one of 2 digits is -1 minus1 :: Digit -> Digit -> Bool minus1 x y = (x==(-1))|| (y==(-1)) -- Algin two stream so that they have the same length align :: Stream -> Stream -> (Stream, Stream) align xs ys |x>y = (xs, (copy 0 (x-y)) ++ys) |otherwise = ((copy 0 (y-x)) ++ xs, ys) where x = toInteger(length xs) y = toInteger(length ys) -- Generate a list of x copy :: Integer -> Integer -> [Integer] copy x n = [x| i<- [1..n]] -- Add two finite stream (to add the integral part) addFiniteStream :: Stream -> Stream -> Stream addFiniteStream xs ys = add' u v where (u,v) = align xs ys -- Utility function for addFinitieStream add' :: Stream -> Stream -> Stream add' u v = normalise (f u v) where f [] [] = [] f (x:xs) (y:ys) = (x+y):f xs ys -- Normalise the sum normalise :: Stream -> Stream normalise = foldr f [0] where f x (y:ys) = (u:v:ys) where u = (x+y) `div` 2 v = (x+y) `mod` 2 -- Negate a stream negate' :: Stream -> Stream negate' = map (*(-1)) -- Compute average of two stream -- Using [-2,-1,0,1,2] to add, and then divide by 2 average :: Stream -> Stream -> Stream average xs ys = div2 (add xs ys) -- Addition of two streams, using [-2,-1,0,1,2] add :: Stream -> Stream -> Stream add (x:xs) (y:ys) = (x+y):(add xs ys) -- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1] div2 :: Stream -> Stream div2 (2:xs) = 1:div2 xs div2 ((-2):xs) = (-1):div2 xs div2 (0:xs) = 0:div2 xs div2 (1:(-2):xs) = div2 (0:0:xs) div2 (1:(-1):xs) = div2 (0:1:xs) div2 (1:0:xs) = div2 (0:2:xs) div2 (1:1:xs) = div2 (2:(-1):xs) div2 (1:2:xs) = div2 (2:0:xs) div2 ((-1):(-2):xs) = div2 ((-2):0:xs) div2 ((-1):(-1):xs) = div2 ((-2):1:xs) div2 ((-1):0:xs) = div2 (0:(-2):xs) div2 ((-1):1:xs) = div2 (0:(-1):xs) div2 ((-1):2:xs) = div2 (0:0:xs) test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3))) ghc-exactprint-0.6.2/tests/examples/ghc710/StrictLet.hs0000755000000000000000000000143107346545000021054 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {- If the (unboxed, hence strict) "let thunk =" would survive to the CallArity stage, it might yield wrong results (eta-expanding thunk and hence "cond" would be called multiple times). It does not actually happen (CallArity sees a "case"), so this test just safe-guards against future changes here. -} import Debug.Trace import GHC.Exts import System.Environment cond :: Int# -> Bool cond x = trace ("cond called with " ++ show (I# x)) True {-# NOINLINE cond #-} bar (I# x) = let go n = let x = thunk n in case n of 100# -> I# x _ -> go (n +# 1#) in go x where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#) main = do args <- getArgs bar (length args) `seq` return () ghc-exactprint-0.6.2/tests/examples/ghc710/StringGap.hs0000755000000000000000000000033407346545000021036 0ustar0000000000000000module 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" ghc-exactprint-0.6.2/tests/examples/ghc710/T10196.hs0000755000000000000000000000030707346545000017744 0ustar0000000000000000module 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ᵣ ghc-exactprint-0.6.2/tests/examples/ghc710/T10942.hs0000755000000000000000000000015607346545000017745 0ustar0000000000000000-- Let's trick you {-# LANGUAGE ExplicitForAll #-} module Test (foo) where foo :: forall a. a -> a foo x = x ghc-exactprint-0.6.2/tests/examples/ghc710/T2388.hs0000755000000000000000000000041207346545000017665 0ustar0000000000000000module T2388 where import Data.Bits import Data.Word import Data.Int test1 :: Word32 -> Char test1 w | w .&. 0x80000000 /= 0 = 'a' test1 _ = 'b' -- this should use a testq instruction on x86_64 test2 :: Int64 -> Char test2 w | w .&. (-3) /= 0 = 'a' test2 _ = 'b' ghc-exactprint-0.6.2/tests/examples/ghc710/T3132.hs0000755000000000000000000000015207346545000017652 0ustar0000000000000000module T3132 where import Data.Array.Unboxed step :: UArray Int Double -> [Double] step y = [y!1 + y!0] ghc-exactprint-0.6.2/tests/examples/ghc710/T5951.hs0000755000000000000000000000017407346545000017671 0ustar0000000000000000module T5951 where class A a class B b class C c instance A => B => C where foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/T7918A.hs0000755000000000000000000000205607346545000020000 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T7918A where import Language.Haskell.TH import Language.Haskell.TH.Quote qq = QuasiQuoter { quoteExp = \str -> case str of "e1" -> [| True |] "e2" -> [| id True |] "e3" -> [| True || False |] "e4" -> [| False |] , quoteType = \str -> case str of "t1" -> [t| Bool |] "t2" -> [t| Maybe Bool |] "t3" -> [t| Either Bool Int |] "t4" -> [t| Int |] , quotePat = let x = VarP (mkName "x") y = VarP (mkName "y") in \str -> case str of "p1" -> return $ x "p2" -> return $ ConP 'Just [x] "p3" -> return $ TupP [x, y] "p4" -> return $ y , quoteDec = undefined } ghc-exactprint-0.6.2/tests/examples/ghc710/TH.hs0000755000000000000000000000320207346545000017450 0ustar0000000000000000{-# Language TemplateHaskell #-} -- from https://ocharles.org.uk/blog/guest-posts/2014-12-22-template-haskell.html import Language.Haskell.TH e1 :: IO Exp e1 = runQ [| 1 + 2 |] e2 :: Integer e2 = $( return (InfixE (Just (LitE (IntegerL 1))) (VarE (mkName "+")) (Just (LitE (IntegerL 2))) ) ) fibs :: [Integer] fibs = 0 : 1 : zipWith (+) fibs (tail fibs) fibQ :: Int -> Q Exp fibQ n = [| fibs !! n |] -- e3 gives stage restriction, need to import this module to get it -- e3 = $(fibQ 22) e4 = $(runQ [| fibs !! $( [| 8 |]) |]) e5 :: IO Exp e5 = runQ [| 1 + 2 |] e6 :: IO [Dec] e6 = runQ [d|x = 5|] e7 :: IO Type e7 = runQ [t|Int|] e8 :: IO Pat e8 = runQ [p|(x,y)|] myExp :: Q Exp; myExp = runQ [| 1 + 2 |] e9 = runQ(myExp) >>= putStrLn.pprint -- --------------------------------------------------------------------- isPrime :: (Integral a) => a -> Bool isPrime k | k <=1 = False | otherwise = not $ elem 0 (map (mod k)[2..k-1]) nextPrime :: (Integral a) => a -> a nextPrime n | isPrime n = n | otherwise = nextPrime (n+1) -- returns a list of all primes between n and m, using the nextPrime function doPrime :: (Integral a) => a -> a -> [a] doPrime n m | curr > m = [] | otherwise = curr:doPrime (curr+1) m where curr = nextPrime n -- and our Q expression primeQ :: Int -> Int -> Q Exp primeQ n m = [| doPrime n m |] -- stage restriction on e10 -- e10 = $(primeQ 0 67) -- --------------------------------------------------------------------- e11 = $(stringE . show =<< reify ''Bool) -- stage restriction e12 -- e12 = $(stringE . show =<< reify 'primeQ) ghc-exactprint-0.6.2/tests/examples/ghc710/THMonadInstance.hs0000755000000000000000000000120507346545000022115 0ustar0000000000000000{-# 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 ] ) |] ghc-exactprint-0.6.2/tests/examples/ghc710/TemplateHaskell.hs0000755000000000000000000000155107346545000022221 0ustar0000000000000000{-# 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]))||] class QQExp2 a b where qqExp x = [e||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] ghc-exactprint-0.6.2/tests/examples/ghc710/TransformListComp.hs0000755000000000000000000000022307346545000022563 0ustar0000000000000000{-# LANGUAGE TransformListComp #-} oldest :: [Int] -> [String] oldest tbl = [ "str" | n <- tbl , then id ] ghc-exactprint-0.6.2/tests/examples/ghc710/Trit.hs0000755000000000000000000000560707346545000020072 0ustar0000000000000000module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction', neg, addTrits, subTrits, shiftLeft, shiftRight, multiply ) where import Stream import Utilities import Data.Ratio type Mantissa = Stream type Fraction = Stream type Trit = (Mantissa, Fraction) -- Convert from a Rational number to its Trit representation (Integral, Fraction) rationalToTrit :: Rational -> Trit rationalToTrit x |x<1 = ([0], rationalToStream x) |otherwise = (u', rationalToStream v) where u = n `div` d u' = toBinary u v = x - (toRational u) n = numerator x d = denominator x -- Get the integral part of Trit getIntegral :: Trit -> Mantissa getIntegral = fst -- Get the fraction part of Trit, with n digit of the stream getFraction :: Int -> Trit -> Stream getFraction n = take n. snd -- Get the fraction part of Trit getFraction' :: Trit -> Stream getFraction' = snd -- Negate a Trit neg :: Trit -> Trit neg (a, b) = (negate' a, negate' b) -- Add two Trits addTrits :: Trit -> Trit -> Trit addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys)) where u' = addFiniteStream m1 m2 c = [carry x1 x2 y1 y2] u = addFiniteStream u' c -- Substraction of 2 Trits subTrits :: Trit -> Trit -> Trit subTrits x y = addTrits x (neg y) -- Shift left = *2 opertaion with Trit shiftLeft :: Trit -> Trit shiftLeft (x, (y:ys)) = (x++ [y], ys) -- Shift right = /2 operation with Trit shiftRight :: Trit -> Integer -> Trit shiftRight (x, xs) 1 = (init x, (u:xs)) where u = last x shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1) where u = last x -- Multiply a Trit stream by 1,0 or -1, simply return the stream mulOneDigit :: Integer -> Stream -> Stream mulOneDigit x xs |x==1 = xs |x==0 = zero' |otherwise = negate' xs where zero' = (0:zero') -- Multiplication of two streams multiply :: Stream -> Stream -> Stream multiply (a0:a1:x) (b0:b1:y) = average p q where p = average (a1*b0: (average (mulOneDigit b1 x) (mulOneDigit a1 y))) (average (mulOneDigit b0 x) (mulOneDigit a0 y)) q = (a0*b0:a0*b1:a1*b1:(multiply x y)) start0 = take 30 (multiply (rationalToStream (1%2)) zo) zo :: Stream zo = 1:(-1):zero where zero = 0:zero start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4)))) ghc-exactprint-0.6.2/tests/examples/ghc710/Tuple.hs0000755000000000000000000000011107346545000020222 0ustar0000000000000000{-# LANGUAGE TupleSections #-} baz = (1, "hello", 6.5,,) 'a' (Just ()) ghc-exactprint-0.6.2/tests/examples/ghc710/TupleSections.hs0000755000000000000000000000136707346545000021750 0ustar0000000000000000{-# 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 = (,,(),,,()) ghc-exactprint-0.6.2/tests/examples/ghc710/TypeBrackets.hs0000755000000000000000000000044207346545000021540 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/TypeBrackets2.hs0000755000000000000000000000147207346545000021626 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/TypeBrackets4.hs0000755000000000000000000000036607346545000021631 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/TypeFamilies2.hs0000755000000000000000000000041107346545000021611 0ustar0000000000000000{-# 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 = ( , ) ghc-exactprint-0.6.2/tests/examples/ghc710/TypeInstance.hs0000755000000000000000000000052107346545000021544 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/TypeOperators.hs0000755000000000000000000000332707346545000021765 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} -- From https://ocharles.org.uk/blog/posts/2014-12-08-type-operators.html import Data.String data I a = I { unI :: a } data Var a x = Var { unK :: a } infixr 8 + data ((f + g)) a = InL (f a) | InR (g a) -- data (f + g) a = InL (f a) | InR (g a) class sub :<: sup where inj :: sub a -> sup a instance (sym :<: sym) where inj = id instance (sym1 :<: (sym1 + sym2)) where inj = InL instance (sym1 :<: sym3) => (sym1 :<: (sym2 + sym3)) where inj = InR . inj instance (I :<: g, IsString s) => IsString ((f + g) s) where fromString = inj . I . fromString var :: (Var a :<: f) => a -> f e var = inj . Var elim :: (I :<: f) => (a -> b) -> (Var a + f) b -> f b elim eval f = case f of InL (Var xs) -> inj (I (eval xs)) InR g -> g -------------------------------------------------------------------------------- data UserVar = UserName data ChristmasVar = ChristmasPresent email :: [(Var UserVar + Var ChristmasVar + I) String] email = [ "Dear " , var UserName , ", thank you for your recent email to Santa & Santa Inc." , "You have asked for a: " , var ChristmasPresent ] main :: IO () main = do name <- getLine present <- getLine putStrLn (concatMap (unI . (elim (\ChristmasPresent -> present) . elim (\UserName -> name))) email) {- *Main> main Ollie Lambda Necklace Dear Ollie, thank you for your recent email to Santa & Santa Inc.You have asked for a: Lambda Necklace -} ghc-exactprint-0.6.2/tests/examples/ghc710/TypeSignature.hs0000755000000000000000000000043507346545000021745 0ustar0000000000000000module TypeSignature where {- Lifting baz to the top level should bring in xx and a as parameters, and update the signature to include these -} foo a = (baz xx a) where xx :: Int -> Int -> Int xx p1 p2 = p1 + p2 baz :: (Int -> Int -> Int) -> Int ->Int baz xx a = xx 1 a ghc-exactprint-0.6.2/tests/examples/ghc710/TypeSignatureParens.hs0000755000000000000000000000045007346545000023113 0ustar0000000000000000{-# 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" ghc-exactprint-0.6.2/tests/examples/ghc710/TypeSynOperator.hs0000755000000000000000000000006107346545000022264 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} type a :-> t = a ghc-exactprint-0.6.2/tests/examples/ghc710/TypeSynParens.hs0000755000000000000000000000105507346545000021725 0ustar0000000000000000{-# 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] ghc-exactprint-0.6.2/tests/examples/ghc710/Unboxed.hs0000755000000000000000000000024607346545000020546 0ustar0000000000000000{-# LANGUAGE UnboxedTuples #-} module Layout.Unboxed where f1 :: (Num a1, Num a) => a -> a1 -> (# , #) a a1 f1 x y = (# , #) (x+1) (y-1) f2 x y z = (# ,, #) x y z ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined10.hs0000755000000000000000000007466607346545000021225 0ustar0000000000000000{- 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 ()) ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined11.hs0000755000000000000000000002265207346545000021212 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined13.hs0000755000000000000000000000636207346545000021214 0ustar0000000000000000{-# 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:+ { pack t } quotedString :: ByteString = '"' t:(qt:qdtext { qt } / qp:quotedPair { pack [qp] })* '"' { bsconcat t } quotedPair :: Char = '\\' c: { c } crlf :: () = '\r' '\n' lws :: () = _:crlf _:(' ' / '\t')+ -- text :: ByteString -- = ts:(cs:+ { cs } / _:lws { " " })+ { pack $ concat ts } qdtext :: ByteString = ts:(cs:+ { 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 } |] ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined2.hs0000755000000000000000000000306107346545000021123 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined3.hs0000755000000000000000000002504307346545000021130 0ustar0000000000000000{-# 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 []) ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined4.hs0000755000000000000000000002232107346545000021125 0ustar0000000000000000{-# 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 -- . -- -- * \"The Essence of the Iterator Pattern\", -- by Jeremy Gibbons and Bruno Oliveira, -- in /Mathematically-Structured Functional Programming/, 2006, online at -- . -- -- * \"An Investigation of the Laws of Traversals\", -- by Mauro Jaskelioff and Ondrej Rypacek, -- in /Mathematically-Structured Functional Programming/, 2012, online at -- . -- -- 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) ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined5.hs0000755000000000000000000000336607346545000021136 0ustar0000000000000000{-# 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" ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined6.hs0000755000000000000000000002011407346545000021125 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined7.hs0000755000000000000000000000347407346545000021140 0ustar0000000000000000{-# 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." ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined8.hs0000755000000000000000000000640707346545000021140 0ustar0000000000000000{-# 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 _:* 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 :: () = _:+ '.' 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 } |] ghc-exactprint-0.6.2/tests/examples/ghc710/Undefined9.hs0000755000000000000000000000111007346545000021123 0ustar0000000000000000{-# 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" |] ghc-exactprint-0.6.2/tests/examples/ghc710/Unicode.hs0000755000000000000000000000115207346545000020525 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/ghc710/UnicodeSyntaxFailure.hs0000755000000000000000000000006707346545000023250 0ustar0000000000000000{-# LANGUAGE UnicodeSyntax #-} foo x = addToEnv (∀) ghc-exactprint-0.6.2/tests/examples/ghc710/Utilities.hs0000755000000000000000000000053407346545000021115 0ustar0000000000000000module Utilities (toBinary, fl) where import Stream import Data.Ratio -- Convert from an Integer to its signed-digit representation toBinary :: Integer -> Stream toBinary 0 = [0] toBinary x = toBinary t ++ [x `mod` 2] where t = x `div` 2 fl :: Stream -> Stream fl (x:xs) = (f x):xs where f 0 = 1 f 1 = 0 ghc-exactprint-0.6.2/tests/examples/ghc710/Utils2.hs0000755000000000000000000000556407346545000020334 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} module Utils2 where import Control.Applicative (Applicative(..)) import Control.Monad (when, liftM, ap) import Control.Exception import Data.Data import Data.List import Data.Maybe import Data.Monoid -- import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Types hiding (showGhc) import qualified Bag as GHC import qualified BasicTypes as GHC import qualified BooleanFormula as GHC import qualified Class as GHC import qualified CoAxiom as GHC import qualified DynFlags as GHC import qualified FastString as GHC import qualified ForeignCall as GHC import qualified GHC as GHC import qualified GHC.Paths as GHC import qualified Lexer as GHC import qualified Name as GHC import qualified NameSet as GHC import qualified Outputable as GHC import qualified RdrName as GHC import qualified SrcLoc as GHC import qualified StringBuffer as GHC import qualified UniqSet as GHC import qualified Unique as GHC import qualified Var as GHC import qualified Data.Map as Map -- --------------------------------------------------------------------- instance AnnotateP GHC.RdrName where annotateP l n = do case rdrName2String n of "[]" -> do addDeltaAnnotation GHC.AnnOpenS -- '[' nonBUG addDeltaAnnotation GHC.AnnCloseS -- ']' BUG "()" -> do addDeltaAnnotation GHC.AnnOpenP -- '(' addDeltaAnnotation GHC.AnnCloseP -- ')' "(##)" -> do addDeltaAnnotation GHC.AnnOpen -- '(#' addDeltaAnnotation GHC.AnnClose -- '#)' "[::]" -> do addDeltaAnnotation GHC.AnnOpen -- '[:' addDeltaAnnotation GHC.AnnClose -- ':]' _ -> do addDeltaAnnotation GHC.AnnType addDeltaAnnotation GHC.AnnOpenP -- '(' addDeltaAnnotationLs GHC.AnnBackquote 0 addDeltaAnnotations GHC.AnnCommaTuple -- For '(,,,)' cnt <- countAnnsAP GHC.AnnVal cntT <- countAnnsAP GHC.AnnCommaTuple cntR <- countAnnsAP GHC.AnnRarrow case cnt of 0 -> if cntT >0 || cntR >0 then return () else addDeltaAnnotationExt l GHC.AnnVal 1 -> addDeltaAnnotation GHC.AnnVal x -> error $ "annotateP.RdrName: too many AnnVal :" ++ showGhc (l,x) addDeltaAnnotation GHC.AnnTildehsh addDeltaAnnotation GHC.AnnTilde addDeltaAnnotation GHC.AnnRarrow addDeltaAnnotationLs GHC.AnnBackquote 1 addDeltaAnnotation GHC.AnnCloseP -- ')' -- temporary, for test class (Typeable ast) => AnnotateP ast where annotateP :: GHC.SrcSpan -> ast -> IO () addDeltaAnnotation = undefined addDeltaAnnotations = undefined addDeltaAnnotationLs = undefined addDeltaAnnotationExt = undefined countAnnsAP = undefined showGhc = undefined rdrName2String = undefined ghc-exactprint-0.6.2/tests/examples/ghc710/ViewPatterns.hs0000755000000000000000000000103507346545000021572 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} -- From https://ghc.haskell.org/trac/ghc/wiki/ViewPatterns import Prelude hiding (length) data JList a = Empty | Single a | Join (JList a) (JList a) data JListView a = Nil | Cons a (JList a) view :: JList a -> JListView a view Empty = Nil view (Single a) = Cons a Empty view (Join (view -> Cons xh xt) y) = Cons xh $ Join xt y view (Join (view -> Nil) y) = view y length :: JList a -> Integer length (view -> Nil) = 0 length (view -> Cons x xs) = 1 + length xs ghc-exactprint-0.6.2/tests/examples/ghc710/Warning.hs0000755000000000000000000000040107346545000020540 0ustar0000000000000000 module Warning {-# WARNINg ["This is a module warning", "multi-line"] #-} where {-# Warning foo , bar ["This is a multi-line", "deprecation message", "for foo"] #-} foo :: Int foo = 4 bar :: Char bar = 'c' ghc-exactprint-0.6.2/tests/examples/ghc710/Zipper.hs0000755000000000000000000001267207346545000020421 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Generics.Zipper -- Copyright : (c) Michael D. Adams, 2010 -- License : BSD-style (see the LICENSE file) -- -- ``Scrap Your Zippers: A Generic Zipper for Heterogeneous Types. -- Michael D. Adams. WGP '10: Proceedings of the 2010 ACM SIGPLAN -- workshop on Generic programming, 2010.'' -- -- See -- ----------------------------------------------------------------------------- {-# OPTIONS -Wall #-} {-# LANGUAGE Rank2Types, GADTs #-} module Zipper where import Data.Generics import Control.Monad ((<=<), MonadPlus, mzero, mplus, liftM) import Data.Maybe (fromJust) -- Core types -- | A generic zipper with a root object of type @root@. data Zipper root = forall hole. (Data hole) => Zipper hole (Context hole root) ---- Internal types and functions data Context hole root where CtxtNull :: Context a a CtxtCons :: forall hole root rights parent. (Data parent) => Left (hole -> rights) -> Right rights parent -> Context parent root -> Context hole root combine :: Left (hole -> rights) -> hole -> Right rights parent -> parent combine lefts hole rights = fromRight ((fromLeft lefts) hole) rights data Left expects = LeftUnit expects | forall b. (Data b) => LeftCons (Left (b -> expects)) b toLeft :: (Data a) => a -> Left a toLeft a = gfoldl LeftCons LeftUnit a fromLeft :: Left r -> r fromLeft (LeftUnit a) = a fromLeft (LeftCons f b) = fromLeft f b data Right provides parent where RightNull :: Right parent parent RightCons :: (Data b) => b -> Right a t -> Right (b -> a) t fromRight :: r -> Right r parent -> parent fromRight f (RightNull) = f fromRight f (RightCons b r) = fromRight (f b) r -- | Apply a generic monadic transformation to the hole transM :: (Monad m) => GenericM m -> Zipper a -> m (Zipper a) transM f (Zipper hole ctxt) = do hole' <- f hole return (Zipper hole' ctxt) -- Generic zipper traversals ---- Traversal helpers -- | A movement operation such as 'left', 'right', 'up', or 'down'. type Move a = Zipper a -> Maybe (Zipper a) -- | Apply a generic query using the specified movement operation. moveQ :: Move a -- ^ Move operation -> b -- ^ Default if can't move -> (Zipper a -> b) -- ^ Query if can move -> Zipper a -- ^ Zipper -> b moveQ move b f z = case move z of Nothing -> b Just z' -> f z' -- | Repeatedly apply a monadic 'Maybe' generic transformation at the -- top-most, left-most position that the transformation returns -- 'Just'. Behaves like iteratively applying 'zsomewhere' but is -- more efficient because it re-evaluates the transformation -- at only the parents of the last successful application. zreduce :: GenericM Maybe -> Zipper a -> Zipper a zreduce f z = case transM f z of Nothing -> downQ (g z) (zreduce f . leftmost) z where g z' = rightQ (upQ z' g z') (zreduce f) z' Just x -> zreduce f (reduceAncestors1 f x x) reduceAncestors1 :: GenericM Maybe -> Zipper a -> Zipper a -> Zipper a reduceAncestors1 f z def = upQ def g z where g z' = reduceAncestors1 f z' def' where def' = case transM f z' of Nothing -> def Just x -> reduceAncestors1 f x x ------ Query -- | Apply a generic query to the left sibling if one exists. leftQ :: b -- ^ Value to return of no left sibling exists. -> (Zipper a -> b) -> Zipper a -> b leftQ b f z = moveQ left b f z -- | Apply a generic query to the right sibling if one exists. rightQ :: b -- ^ Value to return if no right sibling exists. -> (Zipper a -> b) -> Zipper a -> b rightQ b f z = moveQ right b f z -- | Apply a generic query to the parent if it exists. downQ :: b -- ^ Value to return if no children exist. -> (Zipper a -> b) -> Zipper a -> b downQ b f z = moveQ down b f z -- | Apply a generic query to the rightmost child if one exists. upQ :: b -- ^ Value to return if parent does not exist. -> (Zipper a -> b) -> Zipper a -> b upQ b f z = moveQ up b f z ---- Basic movement -- | Move left. Returns 'Nothing' iff already at leftmost sibling. left :: Zipper a -> Maybe (Zipper a) left (Zipper _ CtxtNull) = Nothing left (Zipper _ (CtxtCons (LeftUnit _) _ _)) = Nothing left (Zipper h (CtxtCons (LeftCons l h') r c)) = Just (Zipper h' (CtxtCons l (RightCons h r) c)) -- | Move right. Returns 'Nothing' iff already at rightmost sibling. right :: Zipper a -> Maybe (Zipper a) right (Zipper _ CtxtNull) = Nothing right (Zipper _ (CtxtCons _ RightNull _)) = Nothing right (Zipper h (CtxtCons l (RightCons h' r) c)) = Just (Zipper h' (CtxtCons (LeftCons l h) r c)) -- | Move down. Moves to rightmost immediate child. Returns 'Nothing' iff at a leaf and thus no children exist. down :: Zipper a -> Maybe (Zipper a) down (Zipper hole ctxt) = case toLeft hole of LeftUnit _ -> Nothing LeftCons l hole' -> Just (Zipper hole' (CtxtCons l RightNull ctxt)) -- | Move up. Returns 'Nothing' iff already at root and thus no parent exists. up :: Zipper a -> Maybe (Zipper a) up (Zipper _ CtxtNull) = Nothing up (Zipper hole (CtxtCons l r ctxt)) = Just (Zipper (combine l hole r) ctxt) ------ Movement -- | Move to the leftmost sibling. leftmost :: Zipper a -> Zipper a leftmost z = leftQ z leftmost z ghc-exactprint-0.6.2/tests/examples/ghc710/read018.hs0000755000000000000000000000043107346545000020302 0ustar0000000000000000{-# LANGUAGE DatatypeContexts #-} -- !!! Checking that empty contexts are permitted. module ShouldCompile where data () => Foo a = Foo a newtype () => Bar = Bar Int f :: () => Int -> Int f = (+1) class () => Fob a where instance () => Fob Int where instance () => Fob Float ghc-exactprint-0.6.2/tests/examples/ghc80/0000755000000000000000000000000007346545000016521 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc80/A.hs0000755000000000000000000000005307346545000017236 0ustar0000000000000000module A where class A a where has :: a ghc-exactprint-0.6.2/tests/examples/ghc80/AddParams2.hs0000755000000000000000000000032107346545000020772 0ustar0000000000000000module AddParams2 where collapse rightInner rightOuter = right where right = (rightInner, rightOuter) righ2 = (rightInner, (rightOuter baz bar)) baz = undefined bar = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Associated.hs0000755000000000000000000000016607346545000021142 0ustar0000000000000000module Associated(A(..)) where import AssociatedInternal (A(..)) foo = MkA 5 baz = NoA qux (MkA x) = x qux NoA = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/AssociatedInternal.hs0000755000000000000000000000025507346545000022636 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module AssociatedInternal (A(NewA,MkA, NoA)) where newtype A = NewA (Maybe Int) pattern MkA n = NewA (Just n) pattern NoA = NewA Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/B.hs0000755000000000000000000000005307346545000017237 0ustar0000000000000000module B where class B a where has :: a ghc-exactprint-0.6.2/tests/examples/ghc80/Base.hs0000755000000000000000000000014607346545000017733 0ustar0000000000000000module Base (AClass(..), BClass()) where import Extends (BClass ()) class AClass a where has :: a ghc-exactprint-0.6.2/tests/examples/ghc80/Bundle.hs0000755000000000000000000000015607346545000020273 0ustar0000000000000000module Bundle(A(..)) where import BundleInternal (A(..)) foo = MkA 5 baz = NoA qux (MkA x) = x qux NoA = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/Bundle1.hs0000755000000000000000000000016407346545000020353 0ustar0000000000000000module Associated1(A(..)) where import BundleInternal1 (A(..)) foo = MkA 5 baz = NoA qux (MkA x) = x qux NoA = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/BundleExport.hs0000755000000000000000000000020007346545000021463 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module BundleExport(P(.., A), Q(B)) where data P = P data Q = Q pattern A = P pattern B = Q ghc-exactprint-0.6.2/tests/examples/ghc80/BundleInternal.hs0000755000000000000000000000025107346545000021764 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module BundleInternal (A(NewA,MkA, NoA)) where newtype A = NewA (Maybe Int) pattern MkA n = NewA (Just n) pattern NoA = NewA Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/BundleInternal1.hs0000755000000000000000000000025207346545000022046 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module BundleInternal1 (A(NewA,MkA, NoA)) where newtype A = NewA (Maybe Int) pattern MkA n = NewA (Just n) pattern NoA = NewA Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/C.hs0000755000000000000000000000005707346545000017244 0ustar0000000000000000module C (oops) where import {-# SOURCE #-} B ghc-exactprint-0.6.2/tests/examples/ghc80/CheckUtils.hs0000755000000000000000000000707607346545000021130 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- This program must be called with GHC's libdir and the file to be checked as -- the command line arguments. module CheckUtils where import Data.Data import Data.List import System.IO import GHC import BasicTypes import DynFlags import MonadUtils import Outputable import ApiAnnotation import Bag (filterBag,isEmptyBag) import System.Directory (removeFile) import System.Environment( getArgs ) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Dynamic ( fromDynamic,Dynamic ) _main::IO() _main = do [libdir,fileName] <- getArgs testOneFile libdir fileName testOneFile libdir fileName = do ((anns,cs),p) <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags dflags let mn =mkModuleName fileName addTarget Target { targetId = TargetModule mn , targetAllowObjCode = True , targetContents = Nothing } load LoadAllTargets modSum <- getModSummary mn p <- parseModule modSum return (pm_annotations p,p) let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) problems = filter (\(s,a) -> not (Set.member s spans)) $ getAnnSrcSpans (anns,cs) exploded = [((kw,ss),[anchor]) | ((anchor,kw),sss) <- Map.toList anns,ss <- sss] exploded' = Map.toList $ Map.fromListWith (++) exploded problems' = filter (\(_,anchors) -> not (any (\a -> Set.member a spans) anchors)) exploded' putStrLn "---Problems---------------------" putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems]) putStrLn "---Problems'--------------------" putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems']) putStrLn "--------------------------------" putStrLn (intercalate "\n" [showAnns anns]) where getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns getAllSrcSpans :: (Data t) => t -> [SrcSpan] getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast where getSrcSpan :: SrcSpan -> [SrcSpan] getSrcSpan ss = [ss] showAnns anns = "[\n" ++ (intercalate "\n" $ map (\((s,k),v) -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) $ Map.toList anns) ++ "]\n" pp a = showPpr unsafeGlobalDynFlags a -- --------------------------------------------------------------------- -- Copied from syb for the test -- | Generic queries of type \"r\", -- i.e., take any \"a\" and return an \"r\" -- type GenericQ r = forall a. Data a => a -> r -- | Make a generic query; -- start from a type-specific case; -- return a constant otherwise -- mkQ :: ( Typeable a , Typeable b ) => r -> (b -> r) -> a -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r -- | Summarise all nodes in top-down, left-to-right order everything :: (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results everything k f x = foldl k (f x) (gmapQ (everything k f) x) ghc-exactprint-0.6.2/tests/examples/ghc80/Class.hs0000755000000000000000000000125607346545000020131 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} module Servant.Auth.Server.Internal.Class where import Servant.Auth import Data.Monoid import Servant hiding (BasicAuth) import Servant.Auth.Server.Internal.Types import Servant.Auth.Server.Internal.ConfigTypes import Servant.Auth.Server.Internal.BasicAuth import Servant.Auth.Server.Internal.Cookie import Servant.Auth.Server.Internal.JWT -- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all -- elements of @ctx@ to be the in the Context and whose authentication check -- returns an @AuthCheck v@. class IsAuth a v where type family AuthArgs a :: [*] runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) ghc-exactprint-0.6.2/tests/examples/ghc80/ClosedFam1a.hs0000755000000000000000000000007307346545000021137 0ustar0000000000000000module ClosedFam1a where import {-# SOURCE #-} ClosedFam1 ghc-exactprint-0.6.2/tests/examples/ghc80/ClosedFam2a.hs0000755000000000000000000000007207346545000021137 0ustar0000000000000000module ClosedFam2a where import {-# SOURCE #-} ClosedFam2 ghc-exactprint-0.6.2/tests/examples/ghc80/ClosedFam3a.hs0000755000000000000000000000007307346545000021141 0ustar0000000000000000module ClosedFam3a where import {-# SOURCE #-} ClosedFam3 ghc-exactprint-0.6.2/tests/examples/ghc80/CmmSwitchTest.hs0000755000000000000000000004050107346545000021616 0ustar0000000000000000{-# LANGUAGE MagicHash #-} import Control.Monad (unless, forM_) import GHC.Exts {-# NOINLINE aa #-} aa :: Int# -> Int# aa 1# = 42# aa 2# = 43# aa 3# = 43# aa 4# = 44# aa 5# = 44# aa 6# = 45# aa 7# = 45# aa 8# = 46# aa 9# = 46# aa 10# = 47# aa _ = 1337# {-# NOINLINE ab #-} ab :: Int# -> Int# ab 0# = 42# ab 1# = 42# ab 2# = 43# ab 3# = 43# ab 4# = 44# ab 5# = 44# ab 6# = 45# ab 7# = 45# ab 8# = 46# ab 9# = 46# ab 10# = 47# ab _ = 1337# {-# NOINLINE ac #-} ac :: Int# -> Int# ac 1# = 42# ac 2# = 43# ac 3# = 43# ac _ = 1337# {-# NOINLINE ad #-} ad :: Int# -> Int# ad 1# = 42# ad 2# = 43# ad 3# = 43# ad 4# = 44# ad _ = 1337# {-# NOINLINE ae #-} ae :: Int# -> Int# ae 1# = 42# ae 2# = 43# ae 3# = 43# ae 4# = 44# ae 5# = 44# ae _ = 1337# {-# NOINLINE af #-} af :: Int# -> Int# af -1# = 41# af 0# = 42# af 1# = 42# af 2# = 43# af 3# = 43# af 4# = 44# af 5# = 44# af 6# = 45# af 7# = 45# af 8# = 46# af 9# = 46# af 10# = 47# af _ = 1337# {-# NOINLINE ag #-} ag :: Int# -> Int# ag -10# = 37# ag -9# = 37# ag -8# = 38# ag -7# = 38# ag -6# = 39# ag -5# = 39# ag -4# = 40# ag -3# = 40# ag -2# = 41# ag -1# = 41# ag 0# = 42# ag 1# = 42# ag 2# = 43# ag 3# = 43# ag 4# = 44# ag 5# = 44# ag 6# = 45# ag 7# = 45# ag 8# = 46# ag 9# = 46# ag 10# = 47# ag _ = 1337# {-# NOINLINE ah #-} ah :: Int# -> Int# ah -20# = 32# ah -19# = 32# ah -18# = 33# ah -17# = 33# ah -16# = 34# ah -15# = 34# ah -14# = 35# ah -13# = 35# ah -12# = 36# ah -11# = 36# ah -10# = 37# ah 0# = 42# ah 1# = 42# ah 2# = 43# ah 3# = 43# ah 4# = 44# ah 5# = 44# ah 6# = 45# ah 7# = 45# ah 8# = 46# ah 9# = 46# ah 10# = 47# ah _ = 1337# {-# NOINLINE ai #-} ai :: Int# -> Int# ai -20# = 32# ai -19# = 32# ai -18# = 33# ai -17# = 33# ai -16# = 34# ai -15# = 34# ai -14# = 35# ai -13# = 35# ai -12# = 36# ai -11# = 36# ai -10# = 37# ai 1# = 42# ai 2# = 43# ai 3# = 43# ai 4# = 44# ai 5# = 44# ai 6# = 45# ai 7# = 45# ai 8# = 46# ai 9# = 46# ai 10# = 47# ai _ = 1337# {-# NOINLINE aj #-} aj :: Int# -> Int# aj -9223372036854775808# = -4611686018427387862# aj 0# = 42# aj 9223372036854775807# = 4611686018427387945# aj _ = 1337# {-# NOINLINE ak #-} ak :: Int# -> Int# ak 9223372036854775797# = 4611686018427387940# ak 9223372036854775798# = 4611686018427387941# ak 9223372036854775799# = 4611686018427387941# ak 9223372036854775800# = 4611686018427387942# ak 9223372036854775801# = 4611686018427387942# ak 9223372036854775802# = 4611686018427387943# ak 9223372036854775803# = 4611686018427387943# ak 9223372036854775804# = 4611686018427387944# ak 9223372036854775805# = 4611686018427387944# ak 9223372036854775806# = 4611686018427387945# ak 9223372036854775807# = 4611686018427387945# ak _ = 1337# {-# NOINLINE al #-} al :: Int# -> Int# al -9223372036854775808# = -4611686018427387862# al -9223372036854775807# = -4611686018427387862# al -9223372036854775806# = -4611686018427387861# al -9223372036854775805# = -4611686018427387861# al -9223372036854775804# = -4611686018427387860# al -9223372036854775803# = -4611686018427387860# al -9223372036854775802# = -4611686018427387859# al -9223372036854775801# = -4611686018427387859# al -9223372036854775800# = -4611686018427387858# al -9223372036854775799# = -4611686018427387858# al -9223372036854775798# = -4611686018427387857# al 9223372036854775797# = 4611686018427387940# al 9223372036854775798# = 4611686018427387941# al 9223372036854775799# = 4611686018427387941# al 9223372036854775800# = 4611686018427387942# al 9223372036854775801# = 4611686018427387942# al 9223372036854775802# = 4611686018427387943# al 9223372036854775803# = 4611686018427387943# al 9223372036854775804# = 4611686018427387944# al 9223372036854775805# = 4611686018427387944# al 9223372036854775806# = 4611686018427387945# al 9223372036854775807# = 4611686018427387945# al _ = 1337# {-# NOINLINE am #-} am :: Word# -> Word# am 0## = 42## am 1## = 42## am 2## = 43## am 3## = 43## am 4## = 44## am 5## = 44## am 6## = 45## am 7## = 45## am 8## = 46## am 9## = 46## am 10## = 47## am _ = 1337## {-# NOINLINE an #-} an :: Word# -> Word# an 1## = 42## an 2## = 43## an 3## = 43## an 4## = 44## an 5## = 44## an 6## = 45## an 7## = 45## an 8## = 46## an 9## = 46## an 10## = 47## an _ = 1337## {-# NOINLINE ao #-} ao :: Word# -> Word# ao 0## = 42## ao _ = 1337## {-# NOINLINE ap #-} ap :: Word# -> Word# ap 0## = 42## ap 1## = 42## ap _ = 1337## {-# NOINLINE aq #-} aq :: Word# -> Word# aq 0## = 42## aq 1## = 42## aq 2## = 43## aq _ = 1337## {-# NOINLINE ar #-} ar :: Word# -> Word# ar 0## = 42## ar 1## = 42## ar 2## = 43## ar 3## = 43## ar _ = 1337## {-# NOINLINE as #-} as :: Word# -> Word# as 0## = 42## as 1## = 42## as 2## = 43## as 3## = 43## as 4## = 44## as _ = 1337## {-# NOINLINE at #-} at :: Word# -> Word# at 1## = 42## at _ = 1337## {-# NOINLINE au #-} au :: Word# -> Word# au 1## = 42## au 2## = 43## au _ = 1337## {-# NOINLINE av #-} av :: Word# -> Word# av 1## = 42## av 2## = 43## av 3## = 43## av _ = 1337## {-# NOINLINE aw #-} aw :: Word# -> Word# aw 1## = 42## aw 2## = 43## aw 3## = 43## aw 4## = 44## aw _ = 1337## {-# NOINLINE ax #-} ax :: Word# -> Word# ax 1## = 42## ax 2## = 43## ax 3## = 43## ax 4## = 44## ax 5## = 44## ax _ = 1337## {-# NOINLINE ay #-} ay :: Word# -> Word# ay 0## = 42## ay 18446744073709551615## = 9223372036854775849## ay _ = 1337## {-# NOINLINE az #-} az :: Word# -> Word# az 18446744073709551605## = 9223372036854775844## az 18446744073709551606## = 9223372036854775845## az 18446744073709551607## = 9223372036854775845## az 18446744073709551608## = 9223372036854775846## az 18446744073709551609## = 9223372036854775846## az 18446744073709551610## = 9223372036854775847## az 18446744073709551611## = 9223372036854775847## az 18446744073709551612## = 9223372036854775848## az 18446744073709551613## = 9223372036854775848## az 18446744073709551614## = 9223372036854775849## az 18446744073709551615## = 9223372036854775849## az _ = 1337## {-# NOINLINE ba #-} ba :: Word# -> Word# ba 0## = 42## ba 1## = 42## ba 2## = 43## ba 3## = 43## ba 4## = 44## ba 5## = 44## ba 6## = 45## ba 7## = 45## ba 8## = 46## ba 9## = 46## ba 10## = 47## ba 18446744073709551605## = 9223372036854775844## ba 18446744073709551606## = 9223372036854775845## ba 18446744073709551607## = 9223372036854775845## ba 18446744073709551608## = 9223372036854775846## ba 18446744073709551609## = 9223372036854775846## ba 18446744073709551610## = 9223372036854775847## ba 18446744073709551611## = 9223372036854775847## ba 18446744073709551612## = 9223372036854775848## ba 18446744073709551613## = 9223372036854775848## ba 18446744073709551614## = 9223372036854775849## ba 18446744073709551615## = 9223372036854775849## ba _ = 1337## aa_check :: IO () aa_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (aa i) unless (r == o) $ putStrLn $ "ERR: aa (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ab_check :: IO () ab_check = forM_ [(-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (ab i) unless (r == o) $ putStrLn $ "ERR: ab (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ac_check :: IO () ac_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(I# i,o) -> do let r = I# (ac i) unless (r == o) $ putStrLn $ "ERR: ac (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ad_check :: IO () ad_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(I# i,o) -> do let r = I# (ad i) unless (r == o) $ putStrLn $ "ERR: ad (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ae_check :: IO () ae_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(I# i,o) -> do let r = I# (ae i) unless (r == o) $ putStrLn $ "ERR: ae (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." af_check :: IO () af_check = forM_ [(-2,1337), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (af i) unless (r == o) $ putStrLn $ "ERR: af (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ag_check :: IO () ag_check = forM_ [(-11,1337), (-10,37), (-9,37), (-8,38), (-7,38), (-6,39), (-5,39), (-4,40), (-3,40), (-2,41), (-1,41), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (ag i) unless (r == o) $ putStrLn $ "ERR: ag (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ah_check :: IO () ah_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (-1,1337), (0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (ah i) unless (r == o) $ putStrLn $ "ERR: ah (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ai_check :: IO () ai_check = forM_ [(-21,1337), (-20,32), (-19,32), (-18,33), (-17,33), (-16,34), (-15,34), (-14,35), (-13,35), (-12,36), (-11,36), (-10,37), (-9,1337), (0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(I# i,o) -> do let r = I# (ai i) unless (r == o) $ putStrLn $ "ERR: ai (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." aj_check :: IO () aj_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,1337), (-1,1337), (0,42), (1,1337), (9223372036854775806,1337), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do let r = I# (aj i) unless (r == o) $ putStrLn $ "ERR: aj (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ak_check :: IO () ak_check = forM_ [(9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do let r = I# (ak i) unless (r == o) $ putStrLn $ "ERR: ak (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." al_check :: IO () al_check = forM_ [(-9223372036854775808,-4611686018427387862), (-9223372036854775807,-4611686018427387862), (-9223372036854775806,-4611686018427387861), (-9223372036854775805,-4611686018427387861), (-9223372036854775804,-4611686018427387860), (-9223372036854775803,-4611686018427387860), (-9223372036854775802,-4611686018427387859), (-9223372036854775801,-4611686018427387859), (-9223372036854775800,-4611686018427387858), (-9223372036854775799,-4611686018427387858), (-9223372036854775798,-4611686018427387857), (-9223372036854775797,1337), (9223372036854775796,1337), (9223372036854775797,4611686018427387940), (9223372036854775798,4611686018427387941), (9223372036854775799,4611686018427387941), (9223372036854775800,4611686018427387942), (9223372036854775801,4611686018427387942), (9223372036854775802,4611686018427387943), (9223372036854775803,4611686018427387943), (9223372036854775804,4611686018427387944), (9223372036854775805,4611686018427387944), (9223372036854775806,4611686018427387945), (9223372036854775807,4611686018427387945)] $ \(I# i,o) -> do let r = I# (al i) unless (r == o) $ putStrLn $ "ERR: al (" ++ show (I# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." am_check :: IO () am_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do let r = W# (am i) unless (r == o) $ putStrLn $ "ERR: am (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." an_check :: IO () an_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337)] $ \(W# i,o) -> do let r = W# (an i) unless (r == o) $ putStrLn $ "ERR: an (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ao_check :: IO () ao_check = forM_ [(0,42), (1,1337)] $ \(W# i,o) -> do let r = W# (ao i) unless (r == o) $ putStrLn $ "ERR: ao (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ap_check :: IO () ap_check = forM_ [(0,42), (1,42), (2,1337)] $ \(W# i,o) -> do let r = W# (ap i) unless (r == o) $ putStrLn $ "ERR: ap (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." aq_check :: IO () aq_check = forM_ [(0,42), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do let r = W# (aq i) unless (r == o) $ putStrLn $ "ERR: aq (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ar_check :: IO () ar_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do let r = W# (ar i) unless (r == o) $ putStrLn $ "ERR: ar (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." as_check :: IO () as_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do let r = W# (as i) unless (r == o) $ putStrLn $ "ERR: as (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." at_check :: IO () at_check = forM_ [(0,1337), (1,42), (2,1337)] $ \(W# i,o) -> do let r = W# (at i) unless (r == o) $ putStrLn $ "ERR: at (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." au_check :: IO () au_check = forM_ [(0,1337), (1,42), (2,43), (3,1337)] $ \(W# i,o) -> do let r = W# (au i) unless (r == o) $ putStrLn $ "ERR: au (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." av_check :: IO () av_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,1337)] $ \(W# i,o) -> do let r = W# (av i) unless (r == o) $ putStrLn $ "ERR: av (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." aw_check :: IO () aw_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,1337)] $ \(W# i,o) -> do let r = W# (aw i) unless (r == o) $ putStrLn $ "ERR: aw (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ax_check :: IO () ax_check = forM_ [(0,1337), (1,42), (2,43), (3,43), (4,44), (5,44), (6,1337)] $ \(W# i,o) -> do let r = W# (ax i) unless (r == o) $ putStrLn $ "ERR: ax (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ay_check :: IO () ay_check = forM_ [(0,42), (1,1337), (18446744073709551614,1337), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do let r = W# (ay i) unless (r == o) $ putStrLn $ "ERR: ay (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." az_check :: IO () az_check = forM_ [(18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do let r = W# (az i) unless (r == o) $ putStrLn $ "ERR: az (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." ba_check :: IO () ba_check = forM_ [(0,42), (1,42), (2,43), (3,43), (4,44), (5,44), (6,45), (7,45), (8,46), (9,46), (10,47), (11,1337), (18446744073709551604,1337), (18446744073709551605,9223372036854775844), (18446744073709551606,9223372036854775845), (18446744073709551607,9223372036854775845), (18446744073709551608,9223372036854775846), (18446744073709551609,9223372036854775846), (18446744073709551610,9223372036854775847), (18446744073709551611,9223372036854775847), (18446744073709551612,9223372036854775848), (18446744073709551613,9223372036854775848), (18446744073709551614,9223372036854775849), (18446744073709551615,9223372036854775849)] $ \(W# i,o) -> do let r = W# (ba i) unless (r == o) $ putStrLn $ "ERR: ba (" ++ show (W# i)++ ") is " ++ show r ++ " and not " ++ show o ++"." main = do aa_check ab_check ac_check ad_check ae_check af_check ag_check ah_check ai_check aj_check ak_check al_check am_check an_check ao_check ap_check aq_check ar_check as_check at_check au_check av_check aw_check ax_check ay_check az_check ba_check ghc-exactprint-0.6.2/tests/examples/ghc80/CmmSwitchTestGen.hs0000755000000000000000000000557307346545000022262 0ustar0000000000000000{-# LANGUAGE TupleSections #-} -- Generates CmmSwitch.hs import qualified Data.Set as S import Data.Word import Data.List output :: Integer -> Integer output n = n`div`2 + 42 def :: Integer def = 1337 type Spec = (String, Bool, [Integer]) primtyp True = "Int#" primtyp False = "Word#" con True = "I#" con False = "W#" hash True = "#" hash False = "##" primLit s v = show v ++ hash s genSwitch :: Spec -> String genSwitch (name, signed, values) = unlines $ [ "{-# NOINLINE " ++ name ++ " #-}" ] ++ [ name ++ " :: " ++ primtyp signed ++ " -> " ++ primtyp signed ] ++ [ name ++ " " ++ primLit signed v ++ " = " ++ primLit signed (output v) | v <- values] ++ [ name ++ " _ = " ++ primLit signed def ] genCheck :: Spec -> String genCheck (name, signed, values) = unlines $ [ checkName name ++ " :: IO ()" , checkName name ++ " = forM_ [" ++ pairs ++ "] $ \\(" ++ con signed ++ " i,o) -> do" , " let r = " ++ con signed ++ " (" ++ name ++ " i)" , " unless (r == o) $ putStrLn $ \"ERR: " ++ name ++ " (\" ++ show (" ++ con signed ++ " i)++ \") is \" ++ show r ++ \" and not \" ++ show o ++\".\"" ] where f x | x `S.member` range = output x | otherwise = def range = S.fromList values checkValues = S.toList $ S.fromList $ [ v' | v <- values, v' <- [v-1,v,v+1], if signed then v' >= minS && v' <= maxS else v' >= minU && v' <= maxU ] pairs = intercalate ", " ["(" ++ show v ++ "," ++ show (f v) ++ ")" | v <- checkValues ] checkName :: String -> String checkName f = f ++ "_check" genMain :: [Spec] -> String genMain specs = unlines $ "main = do" : [ " " ++ checkName n | (n,_,_) <- specs ] genMod :: [Spec] -> String genMod specs = unlines $ "-- This file is generated from CmmSwitchGen!" : "{-# LANGUAGE MagicHash, NegativeLiterals #-}" : "import Control.Monad (unless, forM_)" : "import GHC.Exts" : map genSwitch specs ++ map genCheck specs ++ [ genMain specs ] main = putStrLn $ genMod $ zipWith (\n (s,v) -> (n,s,v)) names $ signedChecks ++ unsignedChecks signedChecks :: [(Bool, [Integer])] signedChecks = map (True,) [ [1..10] , [0..10] , [1..3] , [1..4] , [1..5] , [-1..10] , [-10..10] , [-20.. -10]++[0..10] , [-20.. -10]++[1..10] , [minS,0,maxS] , [maxS-10 .. maxS] , [minS..minS+10]++[maxS-10 .. maxS] ] minU, maxU, minS, maxS :: Integer minU = 0 maxU = fromIntegral (maxBound :: Word) minS = fromIntegral (minBound :: Int) maxS = fromIntegral (maxBound :: Int) unsignedChecks :: [(Bool, [Integer])] unsignedChecks = map (False,) [ [0..10] , [1..10] , [0] , [0..1] , [0..2] , [0..3] , [0..4] , [1] , [1..2] , [1..3] , [1..4] , [1..5] , [minU,maxU] , [maxU-10 .. maxU] , [minU..minU+10]++[maxU-10 .. maxU] ] names :: [String] names = [ c1:c2:[] | c1 <- ['a'..'z'], c2 <- ['a'..'z']] ghc-exactprint-0.6.2/tests/examples/ghc80/Collapse1.hs0000755000000000000000000000074507346545000020711 0ustar0000000000000000module LiftToTop3evel.Collapse1 where collapse' _ _ [] = [] collapse' left space (t:ts) = new : collapse' right space rest where (_, leftInner) = left rightInner = leftInner + symbolSize t right = (rightInner, (rightOuter rightInner rights)) (rights, rest) = span space ts new = (t, Bounds left right) rightOuter rightInner rights = rightInner + symbolSize rights data Bounds = Bounds (Int,Int) (Int,Int) symbolSize t = 4 ghc-exactprint-0.6.2/tests/examples/ghc80/Compare.hs0000755000000000000000000000106307346545000020446 0ustar0000000000000000{-# LANGUAGE Trustworthy, TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances #-} module Type.Compare where import Data.Ord import GHC.TypeLits type family (a :: Ordering) $$ (b :: Ordering) :: Ordering where LT $$ b = LT GT $$ b = GT EQ $$ b = b infixl 0 $$ -- | Compare two types of any (possibly different) kinds. -- Since `Compare` itself is a closed type family, add instances to `CompareUser` if you want to compare other types. type family Compare (a :: k) (b :: k') :: Ordering where Compare '() '() = EQ ghc-exactprint-0.6.2/tests/examples/ghc80/CustomTypeErrors01.hs0000755000000000000000000000040307346545000022527 0ustar0000000000000000{-# LANGUAGE DataKinds, UndecidableInstances #-} module T1 where import GHC.TypeLits data MyType = MyType instance TypeError (Text "Values of type 'MyType' cannot be compared for equality.") => Eq MyType where (==) = undefined err x = x == MyType ghc-exactprint-0.6.2/tests/examples/ghc80/CustomTypeErrors02.hs0000755000000000000000000000074707346545000022543 0ustar0000000000000000{-# LANGUAGE DataKinds, UndecidableInstances #-} {-# LANGUAGE TypeFamilies, TypeOperators, FlexibleContexts #-} module T2 where import GHC.TypeLits type family IntRep a where IntRep Int = Integer IntRep Integer = Integer IntRep Bool = Integer IntRep a = TypeError (Text "The type '" :<>: ShowType a :<>: Text "' cannot be represented as an integer.") convert :: Num (IntRep a) => a -> IntRep a convert _ = 5 err = convert id ghc-exactprint-0.6.2/tests/examples/ghc80/CustomTypeErrors03.hs0000755000000000000000000000017407346545000022536 0ustar0000000000000000{-# LANGUAGE DataKinds #-} module T3 where import GHC.TypeLits f :: TypeError (Text "This is a type error") f = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/D.hs0000755000000000000000000000021407346545000017240 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module D where import A import C type instance F a b = a unsafeCoerce :: a -> b unsafeCoerce x = oops x x ghc-exactprint-0.6.2/tests/examples/ghc80/DataFamilyInstanceLHS.hs0000755000000000000000000000042107346545000023124 0ustar0000000000000000{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-} module DataFamilyInstanceLHS where -- Test case from #10586 data MyKind = A | B data family Sing (a :: k) data instance Sing (_ :: MyKind) where SingA :: Sing A SingB :: Sing B foo :: Sing A foo = SingA ghc-exactprint-0.6.2/tests/examples/ghc80/DatatypeContexts.hs0000755000000000000000000000122107346545000022357 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DatatypeContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -- I don't know how to silence the -XDatatypeContexts warnings otherwise... {-# OPTIONS_GHC -w #-} {-| Module: Derived.DatatypeContexts Copyright: (C) 2014-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Stability: Provisional Portability: GHC Defines data types with DatatypeContexts (which are gross, but still possible). -} module Derived.DatatypeContexts where data family TyFamily x y z :: * data instance Ord a => TyFamily a b c = TyFamily a b c deriving Show ghc-exactprint-0.6.2/tests/examples/ghc80/Decision.hs0000755000000000000000000005177307346545000020632 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} module Airship.Internal.Decision ( flow , appendRequestPath ) where import Airship.Internal.Date (parseRfc1123Date, utcTimeToRfc1123) import Airship.Headers (addResponseHeader) import Airship.Types ( Response(..) , ResponseBody(..) , Webmachine , etagToByteString , getResponseBody , getResponseHeaders , halt , pathInfo , putResponseBody , request , requestHeaders , requestMethod , requestTime ) import Airship.Resource(Resource(..), PostResponse(..)) import Airship.Internal.Parsers (parseEtagList) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Monad (when) import Control.Monad.Trans (lift) import Control.Monad.Trans.State.Strict (StateT(..), evalStateT, get, modify) import Control.Monad.Writer.Class (tell) import Blaze.ByteString.Builder (toByteString) import Data.Maybe (isJust) import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.ByteString (ByteString, intercalate) import Network.HTTP.Media import qualified Network.HTTP.Types as HTTP ------------------------------------------------------------------------------ -- HTTP Headers -- These are headers not defined for us already in -- Network.HTTP.Types ------------------------------------------------------------------------------ -- TODO this exist in http-types-0.9, see CHANGES.txt hAcceptCharset :: HTTP.HeaderName hAcceptCharset = "Accept-Charset" hAcceptEncoding :: HTTP.HeaderName hAcceptEncoding = "Accept-Encoding" hIfMatch :: HTTP.HeaderName hIfMatch = "If-Match" hIfUnmodifiedSince :: HTTP.HeaderName hIfUnmodifiedSince = "If-Unmodified-Since" hIfNoneMatch :: HTTP.HeaderName hIfNoneMatch = "If-None-Match" ------------------------------------------------------------------------------ -- FlowState: StateT used for recording information as we walk the decision -- tree ------------------------------------------------------------------------------ data FlowState m = FlowState { _contentType :: Maybe (MediaType, Webmachine m ResponseBody) } type FlowStateT m a = StateT (FlowState m) (Webmachine m) a type Flow m = Resource m -> FlowStateT m Response initFlowState :: FlowState m initFlowState = FlowState Nothing flow :: Monad m => Resource m -> Webmachine m Response flow r = evalStateT (b13 r) initFlowState trace :: Monad m => Text -> FlowStateT m () trace t = lift $ tell [t] ----------------------------------------------------------------------------- -- Header value data newtypes ------------------------------------------------------------------------------ newtype IfMatch = IfMatch ByteString newtype IfNoneMatch = IfNoneMatch ByteString ------------------------------------------------------------------------------ -- Decision Helpers ------------------------------------------------------------------------------ negotiateContentTypesAccepted :: Monad m => Resource m -> FlowStateT m () negotiateContentTypesAccepted Resource{..} = do req <- lift request accepted <- lift contentTypesAccepted let reqHeaders = requestHeaders req result = do cType <- lookup HTTP.hContentType reqHeaders mapContentMedia accepted cType case result of (Just process) -> lift process Nothing -> lift $ halt HTTP.status415 appendRequestPath :: Monad m => [Text] -> Webmachine m ByteString appendRequestPath ts = do currentPath <- pathInfo <$> request return $ toByteString (HTTP.encodePathSegments (currentPath ++ ts)) requestHeaderDate :: Monad m => HTTP.HeaderName -> Webmachine m (Maybe UTCTime) requestHeaderDate headerName = do req <- request let reqHeaders = requestHeaders req dateHeader = lookup headerName reqHeaders parsedDate = dateHeader >>= parseRfc1123Date return parsedDate writeCacheTags :: Monad m => Resource m -> FlowStateT m () writeCacheTags Resource{..} = lift $ do etag <- generateETag case etag of Nothing -> return () Just t -> addResponseHeader ("ETag", etagToByteString t) modified <- lastModified case modified of Nothing -> return () Just d -> addResponseHeader ("Last-Modified", utcTimeToRfc1123 d) ------------------------------------------------------------------------------ -- Type definitions for all decision nodes ------------------------------------------------------------------------------ b13, b12, b11, b10, b09, b08, b07, b06, b05, b04, b03 :: Monad m => Flow m c04, c03 :: Monad m => Flow m d05, d04 :: Monad m => Flow m e06, e05 :: Monad m => Flow m f07, f06 :: Monad m => Flow m g11, g09 :: Monad m => IfMatch -> Flow m g08, g07 :: Monad m => Flow m h12, h11, h10, h07 :: Monad m => Flow m i13 :: Monad m => IfNoneMatch -> Flow m i12, i07, i04 :: Monad m => Flow m j18 :: Monad m => Flow m k13 :: Monad m => IfNoneMatch -> Flow m k07, k05 :: Monad m => Flow m l17, l15, l14, l13, l07, l05 :: Monad m => Flow m m20, m16, m07, m05 :: Monad m => Flow m n16, n11, n05 :: Monad m => Flow m o20, o18, o16, o14 :: Monad m => Flow m p11, p03 :: Monad m => Flow m ------------------------------------------------------------------------------ -- B column ------------------------------------------------------------------------------ b13 r@Resource{..} = do trace "b13" available <- lift serviceAvailable if available then b12 r else lift $ halt HTTP.status503 b12 r@Resource{..} = do trace "b12" -- known method req <- lift request let knownMethods = [ HTTP.methodGet , HTTP.methodPost , HTTP.methodHead , HTTP.methodPut , HTTP.methodDelete , HTTP.methodTrace , HTTP.methodConnect , HTTP.methodOptions , HTTP.methodPatch ] if requestMethod req `elem` knownMethods then b11 r else lift $ halt HTTP.status501 b11 r@Resource{..} = do trace "b11" long <- lift uriTooLong if long then lift $ halt HTTP.status414 else b10 r b10 r@Resource{..} = do trace "b10" req <- lift request allowed <- lift allowedMethods if requestMethod req `elem` allowed then b09 r else do lift $ addResponseHeader ("Allow", intercalate "," allowed) lift $ halt HTTP.status405 b09 r@Resource{..} = do trace "b09" malformed <- lift malformedRequest if malformed then lift $ halt HTTP.status400 else b08 r b08 r@Resource{..} = do trace "b08" authorized <- lift isAuthorized if authorized then b07 r else lift $ halt HTTP.status401 b07 r@Resource{..} = do trace "b07" forbid <- lift forbidden if forbid then lift $ halt HTTP.status403 else b06 r b06 r@Resource{..} = do trace "b06" validC <- lift validContentHeaders if validC then b05 r else lift $ halt HTTP.status501 b05 r@Resource{..} = do trace "b05" known <- lift knownContentType if known then b04 r else lift $ halt HTTP.status415 b04 r@Resource{..} = do trace "b04" large <- lift entityTooLarge if large then lift $ halt HTTP.status413 else b03 r b03 r@Resource{..} = do trace "b03" req <- lift request allowed <- lift allowedMethods if requestMethod req == HTTP.methodOptions then do lift $ addResponseHeader ("Allow", intercalate "," allowed) lift $ halt HTTP.status204 else c03 r ------------------------------------------------------------------------------ -- C column ------------------------------------------------------------------------------ c04 r@Resource{..} = do trace "c04" req <- lift request provided <- lift contentTypesProvided let reqHeaders = requestHeaders req result = do acceptStr <- lookup HTTP.hAccept reqHeaders (acceptTyp, resource) <- mapAcceptMedia provided' acceptStr Just (acceptTyp, resource) where -- this is so that in addition to getting back the resource -- that we match, we also return the content-type provided -- by that resource. provided' = map dupContentType provided dupContentType (a, b) = (a, (a, b)) case result of Nothing -> lift $ halt HTTP.status406 Just res -> do modify (\fs -> fs { _contentType = Just res }) d04 r c03 r@Resource{..} = do trace "c03" req <- lift request let reqHeaders = requestHeaders req case lookup HTTP.hAccept reqHeaders of (Just _h) -> c04 r Nothing -> d04 r ------------------------------------------------------------------------------ -- D column ------------------------------------------------------------------------------ d05 r@Resource{..} = do trace "d05" langAvailable <- lift languageAvailable if langAvailable then e05 r else lift $ halt HTTP.status406 d04 r@Resource{..} = do trace "d04" req <- lift request let reqHeaders = requestHeaders req case lookup HTTP.hAcceptLanguage reqHeaders of (Just _h) -> d05 r Nothing -> e05 r ------------------------------------------------------------------------------ -- E column ------------------------------------------------------------------------------ e06 r@Resource{..} = do trace "e06" -- TODO: charset negotiation f06 r e05 r@Resource{..} = do trace "e05" req <- lift request let reqHeaders = requestHeaders req case lookup hAcceptCharset reqHeaders of (Just _h) -> e06 r Nothing -> f06 r ------------------------------------------------------------------------------ -- F column ------------------------------------------------------------------------------ f07 r@Resource{..} = do trace "f07" -- TODO: encoding negotiation g07 r f06 r@Resource{..} = do trace "f06" req <- lift request let reqHeaders = requestHeaders req case lookup hAcceptEncoding reqHeaders of (Just _h) -> f07 r Nothing -> g07 r ------------------------------------------------------------------------------ -- G column ------------------------------------------------------------------------------ g11 (IfMatch ifMatch) r@Resource{..} = do trace "g11" let etags = parseEtagList ifMatch if null etags then lift $ halt HTTP.status412 else h10 r g09 ifMatch r@Resource{..} = do trace "g09" case ifMatch of -- TODO: should we be stripping whitespace here? (IfMatch "*") -> h10 r _ -> g11 ifMatch r g08 r@Resource{..} = do trace "g08" req <- lift request let reqHeaders = requestHeaders req case IfMatch <$> lookup hIfMatch reqHeaders of (Just h) -> g09 h r Nothing -> h10 r g07 r@Resource{..} = do trace "g07" -- TODO: set Vary headers exists <- lift resourceExists if exists then g08 r else h07 r ------------------------------------------------------------------------------ -- H column ------------------------------------------------------------------------------ h12 r@Resource{..} = do trace "h12" modified <- lift lastModified parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince let maybeGreater = do lastM <- modified headerDate <- parsedDate return (lastM > headerDate) if maybeGreater == Just True then lift $ halt HTTP.status412 else i12 r h11 r@Resource{..} = do trace "h11" parsedDate <- lift $ requestHeaderDate hIfUnmodifiedSince if isJust parsedDate then h12 r else i12 r h10 r@Resource{..} = do trace "h10" req <- lift request let reqHeaders = requestHeaders req case lookup hIfUnmodifiedSince reqHeaders of (Just _h) -> h11 r Nothing -> i12 r h07 r@Resource {..} = do trace "h07" req <- lift request let reqHeaders = requestHeaders req case lookup hIfMatch reqHeaders of -- TODO: should we be stripping whitespace here? (Just "*") -> lift $ halt HTTP.status412 _ -> i07 r ------------------------------------------------------------------------------ -- I column ------------------------------------------------------------------------------ i13 ifNoneMatch r@Resource{..} = do trace "i13" case ifNoneMatch of -- TODO: should we be stripping whitespace here? (IfNoneMatch "*") -> j18 r _ -> k13 ifNoneMatch r i12 r@Resource{..} = do trace "i12" req <- lift request let reqHeaders = requestHeaders req case IfNoneMatch <$> lookup hIfNoneMatch reqHeaders of (Just h) -> i13 h r Nothing -> l13 r i07 r = do trace "i07" req <- lift request if requestMethod req == HTTP.methodPut then i04 r else k07 r i04 r@Resource{..} = do trace "i04" moved <- lift movedPermanently case moved of (Just loc) -> do lift $ addResponseHeader ("Location", loc) lift $ halt HTTP.status301 Nothing -> p03 r ------------------------------------------------------------------------------ -- J column ------------------------------------------------------------------------------ j18 _ = do trace "j18" req <- lift request let getOrHead = [ HTTP.methodGet , HTTP.methodHead ] if requestMethod req `elem` getOrHead then lift $ halt HTTP.status304 else lift $ halt HTTP.status412 ------------------------------------------------------------------------------ -- K column ------------------------------------------------------------------------------ k13 (IfNoneMatch ifNoneMatch) r@Resource{..} = do trace "k13" let etags = parseEtagList ifNoneMatch if null etags then l13 r else j18 r k07 r@Resource{..} = do trace "k07" prevExisted <- lift previouslyExisted if prevExisted then k05 r else l07 r k05 r@Resource{..} = do trace "k05" moved <- lift movedPermanently case moved of (Just loc) -> do lift $ addResponseHeader ("Location", loc) lift $ halt HTTP.status301 Nothing -> l05 r ------------------------------------------------------------------------------ -- L column ------------------------------------------------------------------------------ l17 r@Resource{..} = do trace "l17" parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince modified <- lift lastModified let maybeGreater = do lastM <- modified ifModifiedSince <- parsedDate return (lastM > ifModifiedSince) if maybeGreater == Just True then m16 r else lift $ halt HTTP.status304 l15 r@Resource{..} = do trace "l15" parsedDate <- lift $ requestHeaderDate HTTP.hIfModifiedSince now <- lift requestTime let maybeGreater = (> now) <$> parsedDate if maybeGreater == Just True then m16 r else l17 r l14 r@Resource{..} = do trace "l14" req <- lift request let reqHeaders = requestHeaders req dateHeader = lookup HTTP.hIfModifiedSince reqHeaders validDate = isJust (dateHeader >>= parseRfc1123Date) if validDate then l15 r else m16 r l13 r@Resource{..} = do trace "l13" req <- lift request let reqHeaders = requestHeaders req case lookup HTTP.hIfModifiedSince reqHeaders of (Just _h) -> l14 r Nothing -> m16 r l07 r = do trace "l07" req <- lift request if requestMethod req == HTTP.methodPost then m07 r else lift $ halt HTTP.status404 l05 r@Resource{..} = do trace "l05" moved <- lift movedTemporarily case moved of (Just loc) -> do lift $ addResponseHeader ("Location", loc) lift $ halt HTTP.status307 Nothing -> m05 r ------------------------------------------------------------------------------ -- M column ------------------------------------------------------------------------------ m20 r@Resource{..} = do trace "m20" deleteAccepted <- lift deleteResource if deleteAccepted then do completed <- lift deleteCompleted if completed then o20 r else lift $ halt HTTP.status202 else lift $ halt HTTP.status500 m16 r = do trace "m16" req <- lift request if requestMethod req == HTTP.methodDelete then m20 r else n16 r m07 r@Resource{..} = do trace "m07" allowMissing <- lift allowMissingPost if allowMissing then n11 r else lift $ halt HTTP.status404 m05 r = do trace "m05" req <- lift request if requestMethod req == HTTP.methodPost then n05 r else lift $ halt HTTP.status410 ------------------------------------------------------------------------------ -- N column ------------------------------------------------------------------------------ n16 r = do trace "n16" req <- lift request if requestMethod req == HTTP.methodPost then n11 r else o16 r n11 r@Resource{..} = trace "n11" >> lift processPost >>= flip processPostAction r create :: Monad m => [Text] -> Resource m -> FlowStateT m () create ts r = do loc <- lift (appendRequestPath ts) lift (addResponseHeader ("Location", loc)) negotiateContentTypesAccepted r processPostAction :: Monad m => PostResponse m -> Flow m processPostAction (PostCreate ts) r = do create ts r p11 r processPostAction (PostCreateRedirect ts) r = do create ts r lift $ halt HTTP.status303 processPostAction (PostProcess p) r = lift p >> p11 r processPostAction (PostProcessRedirect ts) _r = do locBs <- lift ts lift $ addResponseHeader ("Location", locBs) lift $ halt HTTP.status303 n05 r@Resource{..} = do trace "n05" allow <- lift allowMissingPost if allow then n11 r else lift $ halt HTTP.status410 ------------------------------------------------------------------------------ -- O column ------------------------------------------------------------------------------ o20 r = do trace "o20" body <- lift getResponseBody -- ResponseBody is a little tough to make an instance of 'Eq', -- so we just use a pattern match case body of Empty -> lift $ halt HTTP.status204 _ -> o18 r o18 r@Resource{..} = do trace "o18" multiple <- lift multipleChoices if multiple then lift $ halt HTTP.status300 else do -- TODO: set etag, expiration, etc. headers req <- lift request let getOrHead = [ HTTP.methodGet , HTTP.methodHead ] when (requestMethod req `elem` getOrHead) $ do m <- _contentType <$> get (cType, body) <- case m of Nothing -> do provided <- lift contentTypesProvided return (head provided) Just (cType, body) -> return (cType, body) b <- lift body lift $ putResponseBody b lift $ addResponseHeader ("Content-Type", renderHeader cType) writeCacheTags r lift $ halt HTTP.status200 o16 r = do trace "o16" req <- lift request if requestMethod req == HTTP.methodPut then o14 r else o18 r o14 r@Resource{..} = do trace "o14" conflict <- lift isConflict if conflict then lift $ halt HTTP.status409 else negotiateContentTypesAccepted r >> p11 r ------------------------------------------------------------------------------ -- P column ------------------------------------------------------------------------------ p11 r = do trace "p11" headers <- lift getResponseHeaders case lookup HTTP.hLocation headers of (Just _) -> lift $ halt HTTP.status201 _ -> o20 r p03 r@Resource{..} = do trace "p03" conflict <- lift isConflict if conflict then lift $ halt HTTP.status409 else negotiateContentTypesAccepted r >> p11 r ghc-exactprint-0.6.2/tests/examples/ghc80/Defer03.hs0000755000000000000000000000011507346545000020245 0ustar0000000000000000module Main where a :: Int a = 'p' main :: IO () main = print "No errors!" ghc-exactprint-0.6.2/tests/examples/ghc80/Dep1.hs0000755000000000000000000000022007346545000017643 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module Dep1 where import Data.Kind data Proxy k (a :: k) = P x :: Proxy * Int x = P y :: Proxy Bool True y = P ghc-exactprint-0.6.2/tests/examples/ghc80/Dep2.hs0000755000000000000000000000015207346545000017650 0ustar0000000000000000{-# LANGUAGE PolyKinds, GADTs #-} module Dep2 where data G (a :: k) where G1 :: G Int G2 :: G Maybe ghc-exactprint-0.6.2/tests/examples/ghc80/DepFail1.hs0000755000000000000000000000020007346545000020435 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module DepFail1 where data Proxy k (a :: k) = P z :: Proxy Bool z = P a :: Proxy Int Bool a = P ghc-exactprint-0.6.2/tests/examples/ghc80/DeprM.hs0000755000000000000000000000015007346545000020063 0ustar0000000000000000module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where f :: Int f = 42 ghc-exactprint-0.6.2/tests/examples/ghc80/DeprU.hs0000755000000000000000000000013307346545000020074 0ustar0000000000000000module A where import DeprM -- here should be emitted deprecation warning g :: Int g = f ghc-exactprint-0.6.2/tests/examples/ghc80/Deprecation.hs0000755000000000000000000000070607346545000021320 0ustar0000000000000000 module Deprecation {-# Deprecated ["This is a module \"deprecation\"", "multi-line", "with unicode: Frère" ] #-} ( foo ) where {-# DEPRECATEd foo ["This is a multi-line", "deprecation message", "for foo"] #-} foo :: Int foo = 4 {-# DEPRECATED withBool "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-} ghc-exactprint-0.6.2/tests/examples/ghc80/DsStrict.hs0000755000000000000000000000134707346545000020624 0ustar0000000000000000{-# LANGUAGE Strict #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} module Main where import Debug.Trace f0 a = "fun" f0' ~a = "fun2" f1 ~n = case n of a -> "case" f1' ~n = case n of ~a -> "case2" f2 = \a -> "lamda" f2' = \ ~a -> "lambda2" newtype Age = MkAge Int f4, f4' :: Age -> String f4 (MkAge a) = "newtype" f4' ~(MkAge a) = "newtype2" main :: IO () main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs where fs = [("fun",f0 ) ,("fun lazy",f0') ,("case",f1) ,("case lazy",f1') ,("lambda",f2) ,("lambda lazy",f2') ,("newtype",(\ ~i -> f4 (MkAge i))) ,("newtype lazy",(\ ~i -> f4' (MkAge i)))] v n = trace ("evaluated in " ++ n) 1 ghc-exactprint-0.6.2/tests/examples/ghc80/DsStrictData.hs0000755000000000000000000000262207346545000021413 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-} -- | Tests the StrictData LANGUAGE pragma. module Main where import qualified Control.Exception as E import System.IO.Unsafe (unsafePerformIO) data Strict a = S a data Strict2 b = S2 !b data Strict3 c where S3 :: c -> Strict3 c data UStrict = US {-# UNPACK #-} Int data Lazy d = L ~d data Lazy2 e where L2 :: ~e -> Lazy2 e main :: IO () main = do print (isBottom (S bottom)) print (isBottom (S2 bottom)) print (isBottom (US bottom)) print (isBottom (S3 bottom)) putStrLn "" print (not (isBottom (L bottom))) print (not (isBottom (L2 bottom))) print (not (isBottom (Just bottom))) -- sanity check ------------------------------------------------------------------------ -- Support for testing for bottom bottom :: a bottom = error "_|_" isBottom :: a -> Bool isBottom f = unsafePerformIO $ (E.evaluate f >> return False) `E.catches` [ E.Handler (\(_ :: E.ArrayException) -> return True) , E.Handler (\(_ :: E.ErrorCall) -> return True) , E.Handler (\(_ :: E.NoMethodError) -> return True) , E.Handler (\(_ :: E.NonTermination) -> return True) , E.Handler (\(_ :: E.PatternMatchFail) -> return True) , E.Handler (\(_ :: E.RecConError) -> return True) , E.Handler (\(_ :: E.RecSelError) -> return True) , E.Handler (\(_ :: E.RecUpdError) -> return True) ] ghc-exactprint-0.6.2/tests/examples/ghc80/DsStrictFail.hs0000755000000000000000000000012707346545000021413 0ustar0000000000000000{-# LANGUAGE Strict #-} module Main where main = let False = True in return () ghc-exactprint-0.6.2/tests/examples/ghc80/DsStrictLet.hs0000755000000000000000000000061107346545000021262 0ustar0000000000000000{-# LANGUAGE Strict #-} module Main where import Debug.Trace main = let False = trace "no binders" False -- evaluated a :: a -> a a = trace "polymorphic" id -- evaluated f :: Eq a => a -> a -> Bool f = trace "overloaded" (==) -- not evaluated xs :: [Int] xs = (trace "recursive" (:) 1 xs) -- evaluated in return () ghc-exactprint-0.6.2/tests/examples/ghc80/DsStrictWarn.hs0000755000000000000000000000031107346545000021442 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-} {-# LANGUAGE Strict #-} module DsStrictWarn where -- should warn about non-exhaustive pattern match w :: String -> String w x = let (_:_) = x in "1" ghc-exactprint-0.6.2/tests/examples/ghc80/Eq.hs0000755000000000000000000000431507346545000017430 0ustar0000000000000000{-# LANGUAGE TypeOperators, DataKinds, PolyKinds, TypeFamilies, RankNTypes, FlexibleContexts, TemplateHaskell, UndecidableInstances, GADTs, DefaultSignatures #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Singletons.Prelude.Eq -- Copyright : (C) 2013 Richard Eisenberg -- License : BSD-style (see LICENSE) -- Maintainer : Richard Eisenberg (eir@cis.upenn.edu) -- Stability : experimental -- Portability : non-portable -- -- Defines the SEq singleton version of the Eq type class. -- ----------------------------------------------------------------------------- module Data.Singletons.Prelude.Eq ( PEq(..), SEq(..), (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$) ) where import Data.Singletons.Prelude.Bool import Data.Singletons import Data.Singletons.Single import Data.Singletons.Prelude.Instances import Data.Singletons.Util import Data.Singletons.Promote import Data.Type.Equality -- NB: These must be defined by hand because of the custom handling of the -- default for (:==) to use Data.Type.Equality.== -- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)', -- then it defaults to a use of '(==)', from @Data.Type.Equality@. class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where type (:==) (x :: a) (y :: a) :: Bool type (:/=) (x :: a) (y :: a) :: Bool type (x :: a) :== (y :: a) = x == y type (x :: a) :/= (y :: a) = Not (x :== y) infix 4 :== infix 4 :/= $(genDefunSymbols [''(:==), ''(:/=)]) -- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is required -- that instances define a body for '(%:==)'. You may also supply a body for '(%:/=)'. class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where -- | Boolean equality on singletons (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b) infix 4 %:== -- | Boolean disequality on singletons (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b) default (%:/=) :: forall (a :: k) (b :: k). ((a :/= b) ~ Not (a :== b)) => Sing a -> Sing b -> Sing (a :/= b) a %:/= b = sNot (a %:== b) infix 4 %:/= $(singEqInstances basicTypes) ghc-exactprint-0.6.2/tests/examples/ghc80/ExpandSynsFail1.hs0000755000000000000000000000011407346545000022025 0ustar0000000000000000type Foo = Int type Bar = Bool main = print $ (1 :: Foo) == (False :: Bar) ghc-exactprint-0.6.2/tests/examples/ghc80/ExpandSynsFail2.hs0000755000000000000000000000055507346545000022037 0ustar0000000000000000-- In case of types with nested type synonyms, all synonyms should be expanded {-# LANGUAGE RankNTypes #-} import Control.Monad.ST type Foo = Int type Bar = Bool type MyFooST s = ST s Foo type MyBarST s = ST s Bar fooGen :: forall s . MyFooST s fooGen = undefined barGen :: forall s . MyBarST s barGen = undefined main = print (runST fooGen == runST barGen) ghc-exactprint-0.6.2/tests/examples/ghc80/ExpandSynsFail3.hs0000755000000000000000000000076307346545000022041 0ustar0000000000000000-- We test two things here: -- -- 1. We expand only as much as necessary. In this case, we shouldn't expand T. -- 2. When we find a difference(T3 and T5 in this case), we do minimal expansion -- e.g. we don't expand both of them to T1, instead we expand T5 to T3. module Main where type T5 = T4 type T4 = T3 type T3 = T2 type T2 = T1 type T1 = Int type T a = Int -> Bool -> a -> String f :: T (T3, T5, Int) -> Int f = undefined a :: Int a = f (undefined :: T (T5, T3, Bool)) main = print a ghc-exactprint-0.6.2/tests/examples/ghc80/ExpandSynsFail4.hs0000755000000000000000000000041107346545000022030 0ustar0000000000000000-- Synonyms shouldn't be expanded since type error is visible without -- expansions. Error message should not have `Type synonyms expanded: ...` part. module Main where type T a = [a] f :: T Int -> String f = undefined main = putStrLn $ f (undefined :: T Bool) ghc-exactprint-0.6.2/tests/examples/ghc80/ExportSyntax.hs0000755000000000000000000000032007346545000021543 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module ExportSyntax ( A(.., NoA), Q(F,..), G(T,..,U)) where data A = A | B pattern NoA = B data Q a = Q a pattern F a = Q a data G = G | H pattern T = G pattern U = H ghc-exactprint-0.6.2/tests/examples/ghc80/ExportSyntaxImport.hs0000755000000000000000000000011107346545000022734 0ustar0000000000000000module ExportSyntaxImport where import ExportSyntax foo = NoA baz = A ghc-exactprint-0.6.2/tests/examples/ghc80/ExprSigLocal.hs0000755000000000000000000000035407346545000021416 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures, RankNTypes #-} module ExprSigLocal where -- We expect this to compile fine, -- reporting that '_' stands 'a' y :: forall b. b->b y = ((\x -> x) :: forall a. a -> _) g :: forall a. a -> _ g x = x ghc-exactprint-0.6.2/tests/examples/ghc80/Extends.hs0000755000000000000000000000006607346545000020474 0ustar0000000000000000module Extends where class BClass b where has :: b ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInExpressionSignature.hs0000755000000000000000000000013307346545000030273 0ustar0000000000000000module ExtraConstraintsWildcardInExpressionSignature where foo x y = ((==) :: _ => _) x y ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSignature.hs0000755000000000000000000000017307346545000027555 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module ExtraConstraintsWildcardInPatternSignature where foo (x :: _ => _) y = x == y ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInPatternSplice.hs0000755000000000000000000000023107346545000027026 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} module ExtraConstraintsWildcardInPatternSplice where foo $( [p| (x :: _) |] ) = x ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice.hs0000755000000000000000000000023307346545000026334 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ExtraConstraintsWildcardInTypeSplice where import Language.Haskell.TH metaType :: TypeQ metaType = [t| _ => _ |] ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSplice2.hs0000755000000000000000000000026707346545000026425 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ExtraConstraintsWildcardInTypeSplice2 where import Language.Haskell.TH.Lib (wildCardT) show' :: $(wildCardT) => a -> String show' x = show x ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardInTypeSpliceUsed.hs0000755000000000000000000000035207346545000027157 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ExtraConstraintsWildcardInTypeSpliceUsed where import ExtraConstraintsWildcardInTypeSplice -- An extra-constraints wild card is not supported in type splices eq :: $(metaType) eq x y = x == y ghc-exactprint-0.6.2/tests/examples/ghc80/ExtraConstraintsWildcardTwice.hs0000755000000000000000000000017507346545000025044 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module ExtraConstraintsWildcardTwice where foo :: ((_), _) => a -> a foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/F.hs0000755000000000000000000000137407346545000017252 0ustar0000000000000000-- | Thompson's group F. -- -- See eg. -- -- Based mainly on James Michael Belk's PhD thesis \"THOMPSON'S GROUP F\"; -- see -- {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, BangPatterns, PatternSynonyms, DeriveFunctor #-} module Math.Combinat.Groups.Thompson.F where -- | Remove the carets with the given indices -- (throws an error if there is no caret at the given index) removeCarets :: [Int] -> T -> T removeCarets idxs tree = if null rem then final else error ("removeCarets: some stuff remained: " ++ show rem) where (_,rem,final) = go 0 idxs tree where go :: Int -> [Int] -> T -> (Int,[Int],T) go !x [] t = (x + treeWidth t , [] , t) ghc-exactprint-0.6.2/tests/examples/ghc80/FDsFromGivens2.hs0000755000000000000000000000042407346545000021616 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, GADTs #-} module FDsFromGivens2 where class C a b | a -> b where cop :: a -> b -> () data KCC where KCC :: C Char Char => () -> KCC f :: C Char [a] => a -> a f = undefined bar (KCC _) = f ghc-exactprint-0.6.2/tests/examples/ghc80/Families.hs0000755000000000000000000000062107346545000020610 0ustar0000000000000000{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds, KindSignatures, TypeOperators, UndecidableInstances #-} {-# LANGUAGE RankNTypes, LiberalTypeSynonyms, EmptyDataDecls #-} -- | A prelude for type-level programming with type families module Prelude.Type.Families where -- >>> T :: T ((I 4) `Minus` (I 7)) -- -3 type family (a :: k) `Minus` (b :: k) :: k type instance a `Minus` b = a + Negate b ghc-exactprint-0.6.2/tests/examples/ghc80/FooBar.hs0000755000000000000000000000005307346545000020226 0ustar0000000000000000module FooBar where import Foo import Bar ghc-exactprint-0.6.2/tests/examples/ghc80/ForFree.hs0000755000000000000000000000132707346545000020413 0ustar0000000000000000 {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -- {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} module Control.ForFree where { -- | Free monad from a functor ; data Free f x = Pure x | Free (f (Free f x)); deriving instance (Eq (f (Free f a)), Eq a) => Eq (Free f a); deriving instance (Ord (f (Free f a)), Ord a) => Ord (Free f a); deriving instance (Read (f (Free f a)), Read a) => Read (Free f a); deriving instance (Show (f (Free f a)), Show a) => Show (Free f a); } ghc-exactprint-0.6.2/tests/examples/ghc80/FromGrin2.hs0000755000000000000000000000036707346545000020673 0ustar0000000000000000 -- ./hackage-roundtrip-work/ajhc-0.8.0.10/src/C/FromGrin2.hs -- orig line 588 convertExp :: Exp -> C (Statement,Expression) convertExp (Prim Func { primArgTypes = as, primRetType = r, primRetArgs = rs@(_:_), ..} vs ty) = do return (mempty,e) ghc-exactprint-0.6.2/tests/examples/ghc80/FrontendPlugin.hs0000755000000000000000000000314507346545000022021 0ustar0000000000000000module FrontendPlugin where import GhcPlugins import qualified GHC import GHC ( Ghc, LoadHowMuch(..) ) import DriverPipeline hiding ( hsc_env ) import DriverPhases import System.Exit import Control.Monad import Data.List frontendPlugin :: FrontendPlugin frontendPlugin = defaultFrontendPlugin { frontend = doMake } -- Copypasted from ghc/Main.hs doMake :: [String] -> [(String,Maybe Phase)] -> Ghc () doMake opts srcs = do liftIO $ print opts let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm , StopLn] hsc_env <- GHC.getSession -- if we have no haskell sources from which to do a dependency -- analysis, then just do one-shot compilation and/or linking. -- This means that "ghc Foo.o Bar.o -o baz" links the program as -- we expect. if (null hs_srcs) then liftIO (oneShot hsc_env StopLn srcs) else do o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs dflags <- GHC.getSessionDynFlags let dflags' = dflags { ldInputs = map (FileOption "") o_files ++ ldInputs dflags } _ <- GHC.setSessionDynFlags dflags' targets <- mapM (uncurry GHC.guessTarget) hs_srcs GHC.setTargets targets ok_flag <- GHC.load LoadAllTargets when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1)) return () ghc-exactprint-0.6.2/tests/examples/ghc80/GA1r.hs0000755000000000000000000000022207346545000017606 0ustar0000000000000000module GA1r where import Text.ParserCombinators.Parsec parseStr :: CharParser () String parseStr = char '"' *> (many1 (noneOf "\"")) <* char '"' ghc-exactprint-0.6.2/tests/examples/ghc80/GADTContext.hs0000755000000000000000000000251607346545000021150 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} data StackItem a where Snum :: forall a. Fractional a => a -> StackItem a Sop :: OpDesc -> StackItem a deriving instance Show a => Show (StackItem a) type MPI = ?mpi_secret :: MPISecret mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) 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]) TestParens :: (forall v . (Eq v) => MaybeDefault v) TestParens2 :: (forall v . ((Eq v)) => MaybeDefault v) TestParens3 :: (forall v . (((Eq v)) => (MaybeDefault v))) TestParens4 :: (forall v . (((Eq v)) => (MaybeDefault v -> MaybeDefault v))) data T a where K1 :: forall a. Ord a => { x :: [a], y :: Int } -> T a K2 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> T a K3 :: forall a. ((Ord a)) => { x :: ([a]), y :: ((Int)) } -> (T a) K4 :: (forall a. Ord a => { x :: [a], y :: Int } -> T a) [t| Map.Map T.Text $tc |] bar $( [p| x |] ) = x ghc-exactprint-0.6.2/tests/examples/ghc80/Generate.hs0000755000000000000000000000031507346545000020611 0ustar0000000000000000import Control.Monad (forM_) main :: IO () main = forM_ [0..0xffff] $ \i -> do putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits" putStrLn $ ".asciz \"Section " ++ show i ++ "\"" putStrLn "" ghc-exactprint-0.6.2/tests/examples/ghc80/Generic.hs0000755000000000000000000000037707346545000020443 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} module Env.Generic ( Record(..) , type (?)(..) ) where import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$)) import Options.Generic (Generic, ParseRecord, type ()(..)) ghc-exactprint-0.6.2/tests/examples/ghc80/IPLocation.hs0000755000000000000000000000256707346545000021073 0ustar0000000000000000{-# LANGUAGE ImplicitParams, RankNTypes #-} {-# OPTIONS_GHC -dcore-lint #-} module Main where import GHC.Exception import GHC.Types f0 = putStrLn $ showCallStack ?loc -- should just show the location of ?loc f1 :: (?loc :: CallStack) => IO () f1 = putStrLn $ showCallStack ?loc -- should show the location of ?loc *and* f1's call-site f2 :: (?loc :: CallStack) => IO () f2 = do putStrLn $ showCallStack ?loc putStrLn $ showCallStack ?loc -- each ?loc should refer to a different location, but they should -- share f2's call-site f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO () f3 x = x () -- the call-site for the functional argument should be added to the -- stack.. f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO () f4 x = x () -- as should the call-site for f4 itself f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO () f5 x = x () -- we only push new call-sites onto CallStacks with the name IP name f6 :: (?loc :: CallStack) => Int -> IO () f6 0 = putStrLn $ showCallStack ?loc f6 n = f6 (n-1) -- recursive functions add a SrcLoc for each recursive call main = do f0 f1 f2 f3 (\ () -> putStrLn $ showCallStack ?loc) f4 (\ () -> putStrLn $ showCallStack ?loc) f5 (\ () -> putStrLn $ showCallStack ?loc3) f6 5 ghc-exactprint-0.6.2/tests/examples/ghc80/Improvement.hs0000755000000000000000000000056107346545000021367 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Foo where type family F a type instance F Int = Bool class C a b where instance (b~Int) => C Bool b blug :: C (F a) a => a -> F a blug = error "Urk" foo :: Bool foo = blug undefined -- [W] C (F a0) a0, F a0 ~ Bool ghc-exactprint-0.6.2/tests/examples/ghc80/KindEqualities.hs0000755000000000000000000000104607346545000021774 0ustar0000000000000000{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module KindEqualities where data TyRep1 :: * -> * where TyInt1 :: TyRep1 Int TyBool1 :: TyRep1 Bool zero1 :: forall a. TyRep1 a -> a zero1 TyInt1 = 0 zero1 TyBool1 = False data Proxy (a :: k) = P data TyRep :: k -> * where TyInt :: TyRep Int TyBool :: TyRep Bool TyMaybe :: TyRep Maybe TyApp :: TyRep a -> TyRep b -> TyRep (a b) zero :: forall (a :: *). TyRep a -> a zero TyInt = 0 zero TyBool = False zero (TyApp TyMaybe _) = Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/KindLevels.hs0000755000000000000000000000022107346545000021113 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds #-} module KindLevels where data A data B :: A -> * data C :: B a -> * data D :: C b -> * data E :: D c -> * ghc-exactprint-0.6.2/tests/examples/ghc80/ListComprehensions.hs0000755000000000000000000000116607346545000022714 0ustar0000000000000000{-# LANGUAGE ParallelListComp, TransformListComp, RecordWildCards #-} -- MonadComprehensions, module ListComprehensions where import GHC.Exts import qualified Data.Map as M import Data.Ord (comparing) import Data.List (sortBy) -- Let’s look at a simple, normal list comprehension to start: parallelListComp :: [Int] parallelListComp = [ x + y * z | x <- [0..10] | y <- [10..20] | z <- [20..30] ] oldest :: [Int] -> [String] oldest tbl = [ "str" | n <- tbl , then id ] ghc-exactprint-0.6.2/tests/examples/ghc80/LiteralsTest2.hs0000755000000000000000000000042407346545000021561 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module LiteralsTest2 where x,y :: Int x = 0003 y = 0x04 s :: String s = "\x20" c :: Char c = '\x20' d :: Double d = 0.00 blah = x where charH = '\x41'# intH = 0004# wordH = 005## floatH = 3.20# doubleH = 04.16## x = 1 ghc-exactprint-0.6.2/tests/examples/ghc80/Main.hs0000755000000000000000000000044607346545000017750 0ustar0000000000000000-- Copyright (C) 2015, Luke Iannini {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ForeignFunctionInterface #-} module Main where import Printf ( pr ) foreign import ccall "talkToCxx" talkToCxx :: IO () main :: IO () main = do putStrLn ( $(pr "Hello From Template Haskell!") ) talkToCxx ghc-exactprint-0.6.2/tests/examples/ghc80/Manipulate.hs0000755000000000000000000000324707346545000021165 0ustar0000000000000000{- | Module : Control.Comonad.Sheet.Manipulate Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets. Copyright : Copyright (c) 2014 Kenneth Foner Maintainer : kenneth.foner@gmail.com Stability : experimental Portability : non-portable This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert'). -} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Control.Comonad.Sheet.Manipulate where -- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@. instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a) asDimensionalAs = asNestedAs -- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures. instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a) x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t instance DepIndex (a,b) TH_0 where type (a,b) `DepIndexResult` TH_0 = a (a,b) # TH_0 = a ghc-exactprint-0.6.2/tests/examples/ghc80/Match.hs0000755000000000000000000000250007346545000020111 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_HADDOCK hide #-} -- Discriminate binary functions that commute, and if so return the operands in -- a stable ordering such that matching recognises expressions modulo -- commutativity. -- commutes :: forall acc env aenv a r. HashAcc acc -> PrimFun (a -> r) -> PreOpenExp acc env aenv a -> Maybe (PreOpenExp acc env aenv a) commutes h f x = case f of PrimAdd _ -> Just (swizzle x) PrimMul _ -> Just (swizzle x) PrimBAnd _ -> Just (swizzle x) PrimBOr _ -> Just (swizzle x) PrimBXor _ -> Just (swizzle x) PrimEq _ -> Just (swizzle x) PrimNEq _ -> Just (swizzle x) PrimMax _ -> Just (swizzle x) PrimMin _ -> Just (swizzle x) PrimLAnd -> Just (swizzle x) PrimLOr -> Just (swizzle x) _ -> Nothing where swizzle :: PreOpenExp acc env aenv (a',a') -> PreOpenExp acc env aenv (a',a') swizzle exp | Tuple (NilTup `SnocTup` a `SnocTup` b) <- exp , hashPreOpenExp h a > hashPreOpenExp h b = Tuple (NilTup `SnocTup` b `SnocTup` a) -- | otherwise = exp ghc-exactprint-0.6.2/tests/examples/ghc80/MonadFailErrors.hs0000755000000000000000000000271707346545000022116 0ustar0000000000000000-- Test purpose: -- Break properly if MonadFail is live {-# LANGUAGE MonadFailDesugaring #-} module MonadFailWarnings where import Control.Monad.Fail import Control.Monad.ST import Data.Functor.Identity general :: Monad m => m a general = do Just x <- undefined undefined general' :: MonadFail m => m a general' = do Just x <- undefined undefined identity :: Identity a identity = do Just x <- undefined undefined io :: IO a io = do Just x <- undefined undefined st :: ST s a st = do Just x <- undefined undefined reader :: r -> a reader = do Just x <- undefined undefined newtype Newtype a = Newtype a newtypeMatch :: Identity a newtypeMatch = do Newtype x <- undefined undefined data Data a = Data a singleConMatch :: Identity a singleConMatch = do Data x <- undefined undefined data Maybe' a = Nothing' | Just' a instance Functor Maybe' where fmap = undefined instance Applicative Maybe' where pure = undefined; (<*>) = undefined instance Monad Maybe' where (>>=) = undefined instance MonadFail Maybe' where fail = undefined customFailable :: Maybe' a customFailable = do Just x <- undefined undefined wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a wildcardx = do x <- undefined undefined explicitlyIrrefutable = do ~(x:y) <- undefined undefined wildcard_ = do _ <- undefined undefined tuple = do (a,b) <- undefined undefined ghc-exactprint-0.6.2/tests/examples/ghc80/MonadFailWarnings.hs0000755000000000000000000000410507346545000022423 0ustar0000000000000000-- Test purpose: -- Ensure that MonadFail warnings are issued correctly if the warning flag -- is enabled {-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} module MonadFailWarnings where import Control.Monad.Fail import Control.Monad.ST import Data.Functor.Identity -- should warn, because the do-block gets a general Monad constraint, -- but should have MonadFail general :: Monad m => m a general = do Just x <- undefined undefined -- should NOT warn, because the constraint is correct general' :: MonadFail m => m a general' = do Just x <- undefined undefined -- should warn, because Identity isn't MonadFail identity :: Identity a identity = do Just x <- undefined undefined -- should NOT warn, because IO is MonadFail io :: IO a io = do Just x <- undefined undefined -- should warn, because (ST s) is not MonadFail st :: ST s a st = do Just x <- undefined undefined -- should warn, because (r ->) is not MonadFail reader :: r -> a reader = do Just x <- undefined undefined -- should NOT warn, because matching against newtype newtype Newtype a = Newtype a newtypeMatch :: Identity a newtypeMatch = do Newtype x <- undefined undefined -- should NOT warn, because Data has only one constructor data Data a = Data a singleConMatch :: Identity a singleConMatch = do Data x <- undefined undefined -- should NOT warn, because Maybe' has a MonadFail instance data Maybe' a = Nothing' | Just' a instance Functor Maybe' where fmap = undefined instance Applicative Maybe' where pure = undefined; (<*>) = undefined instance Monad Maybe' where (>>=) = undefined instance MonadFail Maybe' where fail = undefined customFailable :: Maybe' a customFailable = do Just x <- undefined undefined -- should NOT warn, because patterns always match wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a wildcardx = do x <- undefined undefined explicitlyIrrefutable = do ~(x:y) <- undefined undefined wildcard_ = do _ <- undefined undefined tuple = do (a,b) <- undefined undefined ghc-exactprint-0.6.2/tests/examples/ghc80/MonadFailWarningsDisabled.hs0000755000000000000000000000274207346545000024060 0ustar0000000000000000-- Test purpose: -- Make sure that not enabling MonadFail warnings makes code compile just -- as it did in < 8.0 module MonadFailWarnings where import Control.Monad.Fail import Control.Monad.ST import Data.Functor.Identity general :: Monad m => m a general = do Just x <- undefined undefined general' :: MonadFail m => m a general' = do Just x <- undefined undefined identity :: Identity a identity = do Just x <- undefined undefined io :: IO a io = do Just x <- undefined undefined st :: ST s a st = do Just x <- undefined undefined reader :: r -> a reader = do Just x <- undefined undefined newtype Newtype a = Newtype a newtypeMatch :: Identity a newtypeMatch = do Newtype x <- undefined undefined data Data a = Data a singleConMatch :: Identity a singleConMatch = do Data x <- undefined undefined data Maybe' a = Nothing' | Just' a instance Functor Maybe' where fmap = undefined instance Applicative Maybe' where pure = undefined; (<*>) = undefined instance Monad Maybe' where (>>=) = undefined instance MonadFail Maybe' where fail = undefined customFailable :: Maybe' a customFailable = do Just x <- undefined undefined wildcardx, explicitlyIrrefutable, wildcard_, tuple :: Monad m => m a wildcardx = do x <- undefined undefined explicitlyIrrefutable = do ~(x:y) <- undefined undefined wildcard_ = do _ <- undefined undefined tuple = do (a,b) <- undefined undefined ghc-exactprint-0.6.2/tests/examples/ghc80/MonadFailWarningsWithRebindableSyntax.hs0000755000000000000000000000054407346545000026441 0ustar0000000000000000-- Test purpose: -- RebindableSyntax does not play that well with MonadFail, so here we ensure -- that when both settings are enabled we get the proper warning. {-# OPTIONS_GHC -fwarn-missing-monadfail-instance #-} {-# LANGUAGE RebindableSyntax #-} module MonadFailWarningsWithRebindableSyntax where import Prelude test1 f g = do Just x <- f g ghc-exactprint-0.6.2/tests/examples/ghc80/MonadT.hs0000755000000000000000000000274407346545000020251 0ustar0000000000000000{-# OPTIONS -XRank2Types #-} module Control.Monatron.MonadT ( MonadT(..), FMonadT(..), MMonadT(..), FComp(..), FunctorD(..), tmap, mtmap, module Control.Monad ) where import Control.Monad ---------------------------------------------------------- -- Class of monad transformers with -- a lifting of first-order operations ---------------------------------------------------------- class MonadT t where lift :: Monad m => m a -> t m a treturn :: Monad m => a -> t m a treturn = lift. return tbind :: Monad m => t m a -> (a -> t m b) -> t m b newtype FunctorD f = FunctorD {fmapD :: forall a b . (a -> b) -> f a -> f b} functor :: Functor f => FunctorD f functor = FunctorD fmap class MonadT t => FMonadT t where tmap' :: FunctorD m -> FunctorD n -> (a -> b) -> (forall x. m x -> n x) -> t m a -> t n b tmap :: (FMonadT t, Functor m, Functor n) => (forall b. m b -> n b) -> t m a -> t n a tmap = tmap' functor functor id mtmap :: FMonadT t => FunctorD f -> (a -> b) -> t f a -> t f b mtmap fd f = tmap' fd fd f id class FMonadT t => MMonadT t where flift :: Functor f => f a -> t f a --should coincide with lift! monoidalT :: (Functor f, Functor g) => t f (t g a) -> t (FComp f g) a ---------------------------------------- -- Functor Composition ---------------------------------------- newtype (FComp f g) a = Comp {deComp :: (f (g a)) } instance (Functor f, Functor g) => Functor (FComp f g) where fmap f (Comp fga) = Comp (fmap (fmap f) fga) ghc-exactprint-0.6.2/tests/examples/ghc80/MultiLineWarningPragma.hs0000755000000000000000000000077007346545000023444 0ustar0000000000000000 {-# 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!" #-} ghc-exactprint-0.6.2/tests/examples/ghc80/MultiQuote.hs0000755000000000000000000000233407346545000021172 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes#-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE EmptyCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Internal API for the store package. The functions here which are -- not re-exported by "Data.Store" are less likely to have stable APIs. -- -- This module also defines most of the included 'Store' instances, for -- types from the base package and other commonly used packages -- (bytestring, containers, text, time, etc). module Data.Store.Internal where ------------------------------------------------------------------------ -- Instances generated by TH $($(derive [d| -- TODO -- instance Deriving (Store ()) instance Deriving (Store All) instance Deriving (Store Any) instance Deriving (Store Void) instance Deriving (Store Bool) |])) ghc-exactprint-0.6.2/tests/examples/ghc80/MultiWayIf.hs0000755000000000000000000000126307346545000021114 0ustar0000000000000000{-# LANGUAGE MultiWayIf #-} module MultiWayIf where foo = if | test1 -> e1 | test2 witharg -> e2 | otherwise -> def bar = if { | test1 -> if { | test2 -> e1 | test3 -> e2 } | test4 -> e3 } -- taken from GHC's test suite x = 10 x1 = if | x < 10 -> "< 10" | otherwise -> "" x2 = if | x < 10 -> "< 10" | otherwise -> "" x3 = if | x < 10 -> "< 10" | otherwise -> "" x4 = if | True -> "yes" x5 = if | True -> if | False -> 1 | True -> 2 x6 = if | x < 10 -> if | True -> "yes" | False -> "no" | otherwise -> "maybe" x7 = (if | True -> 0) -- issue #98 spam = if | () <- () -> () ghc-exactprint-0.6.2/tests/examples/ghc80/NamedWildcardInDataFamilyInstanceLHS.hs0000755000000000000000000000037607346545000026043 0ustar0000000000000000{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-} module NamedWildcardInDataFamilyInstanceLHS where data MyKind = A | B data family Sing (a :: k) data instance Sing (_a :: MyKind) where SingA :: Sing A SingB :: Sing B ghc-exactprint-0.6.2/tests/examples/ghc80/NamedWildcardInTypeFamilyInstanceLHS.hs0000755000000000000000000000016607346545000026110 0ustar0000000000000000{-# LANGUAGE NamedWildCards #-} module NamedWildcardInTypeFamilyInstanceLHS where type family F a where F _t = Int ghc-exactprint-0.6.2/tests/examples/ghc80/NamedWildcardInTypeSplice.hs0000755000000000000000000000026207346545000024047 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NamedWildCards #-} module NamedWildcardInTypeSplice where import Language.Haskell.TH metaType :: TypeQ metaType = [t| _a -> _a |] ghc-exactprint-0.6.2/tests/examples/ghc80/OutOfHeap.hs0000755000000000000000000000045707346545000020720 0ustar0000000000000000import qualified Data.Array.Unboxed as UA import Data.Word main :: IO () main = print (UA.listArray (1, 2^(20::Int)) (repeat 0) :: UA.UArray Int Word64) -- this unboxed array should at least take: -- 2^20 * 64 bits -- = 8 * (2^20 bytes) -- = 8 MiB (in heap) ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail04_A.hs0000755000000000000000000000036007346545000023606 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module OverloadedRecFldsFail04_A (U(..), V(MkV, x), Unused(..), u) where data U = MkU { x :: Bool, y :: Bool } data V = MkV { x :: Int } data Unused = MkUnused { unused :: Bool } u = MkU False True ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail06_A.hs0000755000000000000000000000075307346545000023616 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -fwarn-unused-binds #-} module OverloadedRecFldsFail06_A (U(..), V(..), Unused(unused), u, getX, getY, z) where data U = MkU { x :: Bool, y :: Bool } | MkU2 { used_locally :: Bool } deriving Show data V = MkV { x :: Int } | MkV2 { y :: Bool } data Unused = MkUnused { unused :: Bool, unused2 :: Bool, used_locally :: Bool } u = MkU False True z MkU2{used_locally=used_locally} = used_locally getX MkU{x=x} = x getY MkV2{y=y} = y ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail10_A.hs0000755000000000000000000000020207346545000023576 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module OverloadedRecFldsFail10_A where data family F a data instance F Int = MkFInt { foo :: Int } ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail10_B.hs0000755000000000000000000000025307346545000023605 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module OverloadedRecFldsFail10_B (F(..)) where import OverloadedRecFldsFail10_A hiding (foo) data instance F Bool = MkFBool { foo :: Int } ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail10_C.hs0000755000000000000000000000026607346545000023612 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} module OverloadedRecFldsFail10_C (F(..)) where import OverloadedRecFldsFail10_A data instance F Char = MkFChar { foo :: Char } ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail11_A.hs0000755000000000000000000000027007346545000023604 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module OverloadedRecFldsFail11_A where {-# WARNING foo "Warning on a record field" #-} data S = MkS { foo :: Bool } data T = MkT { foo :: Int } ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsFail12_A.hs0000755000000000000000000000023207346545000023603 0ustar0000000000000000module OverloadedRecFldsFail12_A where {-# WARNING foo "Deprecated foo" #-} {-# WARNING bar "Deprecated bar" #-} data T = MkT { foo :: Int, bar :: Int } ghc-exactprint-0.6.2/tests/examples/ghc80/OverloadedRecFldsRun02_A.hs0000755000000000000000000000035707346545000023503 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module OverloadedRecFldsRun02_A (U(..), V(MkV, x), Unused(..), u) where data U = MkU { x :: Bool, y :: Bool } data V = MkV { x :: Int } data Unused = MkUnused { unused :: Bool } u = MkU False True ghc-exactprint-0.6.2/tests/examples/ghc80/P.hs0000755000000000000000000000035607346545000017263 0ustar0000000000000000module P where import qualified Map import qualified Set foo = do let x = Map.insert 0 "foo" . Map.insert (6 :: Int) "foo" $ Map.empty print (Map.lookup 1 x) print (Set.size (Map.keysSet x)) return x ghc-exactprint-0.6.2/tests/examples/ghc80/PSQ.hs0000755000000000000000000000016307346545000017523 0ustar0000000000000000 data TourView a = Null | Single {-# UNPACK #-} !(Elem a) | (PSQ a) `Play` (PSQ a) ghc-exactprint-0.6.2/tests/examples/ghc80/ParenFunBind.hs0000755000000000000000000000013307346545000021370 0ustar0000000000000000module ParenFunBind where (foo x) y = x + y ((bar x)) y = x + y ((baz x)) (y) = x + y ghc-exactprint-0.6.2/tests/examples/ghc80/ParenTypeSynonym.hs0000755000000000000000000000011607346545000022362 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} module ParenTypeSynonym where type Is = (~) ghc-exactprint-0.6.2/tests/examples/ghc80/PartialClassMethodSignature2.hs0000755000000000000000000000020107346545000024540 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module PartialClassMethodSignature2 where class Foo a where foo :: (Eq a, _) => a -> a ghc-exactprint-0.6.2/tests/examples/ghc80/PluralS.hs0000755000000000000000000000073607346545000020450 0ustar0000000000000000-- Test purpose: -- -- Ensure the plural "s" in warnings is only shown if there are more than -- one entries {-# OPTIONS_GHC -Wredundant-constraints #-} {-# OPTIONS_GHC -Wtype-defaults #-} module PluralS () where -- Defaulting type classes defaultingNum = 123 `seq` () defaultingNumAndShow = show 123 -- Redundant constraints redundantNum :: (Num a, Num a) => a redundantNum = 123 redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a redundantMultiple = 123 ghc-exactprint-0.6.2/tests/examples/ghc80/PolyInstances.hs0000755000000000000000000000071207346545000021653 0ustar0000000000000000{-# LANGUAGE PolyKinds, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module PolyInstances where import GHC.Exts import Data.Proxy class C (a :: k) instance (C a, C b) => C (a b) data Dict :: Constraint -> * instance C Dict foo :: C p => proxy p -> () foo = undefined bar :: forall (p :: Constraint) proxy. C p => proxy p -> () bar _ = foo (Proxy :: Proxy (Dict p)) ghc-exactprint-0.6.2/tests/examples/ghc80/PopCnt.hs0000755000000000000000000000030707346545000020263 0ustar0000000000000000{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-} module Main where import GHC.Exts foreign import prim "do_popcnt32" popcnt32 :: Int# -> Int# main = print (I# (popcnt32 0xffff#)) ghc-exactprint-0.6.2/tests/examples/ghc80/Ppr017.hs0000755000000000000000000000026507346545000020054 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ExplicitNamespaces #-} module Imports( f, type (+), pattern Single ) where import GHC.TypeLits pattern Single x = [x] f = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Primop.hs0000755000000000000000000000041407346545000020325 0ustar0000000000000000{-# LANGUAGE GHCForeignImportPrim, MagicHash, UnliftedFFITypes, UnboxedTuples #-} import GHC.Exts foreign import prim "dummy" dummy :: Word# -> Word# foreign import prim "dummy2" dummy2 :: Any -> State# RealWorld -> (# State# RealWorld, Word# #) ghc-exactprint-0.6.2/tests/examples/ghc80/Printf.hs0000755000000000000000000000176307346545000020331 0ustar0000000000000000-- Copyright (C) 2015, Luke Iannini {-# LANGUAGE TemplateHaskell #-} module Printf where -- Skeletal printf from the paper: -- http://research.microsoft.com/pubs/67015/meta-haskell.pdf -- It needs to be in a separate module to the one where -- you intend to use it. -- Import some Template Haskell syntax import Language.Haskell.TH -- Describe a format string data Format = D | S | L String -- Parse a format string. This is left largely to you -- as we are here interested in building our first ever -- Template Haskell program and not in building printf. parse :: String -> [Format] parse s = [ L s ] -- Generate Haskell source code from a parsed representation -- of the format string. This code will be spliced into -- the module which calls "pr", at compile time. gen :: [Format] -> Q Exp gen [D] = [| \n -> show n |] gen [S] = [| \s -> s |] gen [L s] = stringE s -- Here we generate the Haskell code for the splice -- from an input format string. pr :: String -> Q Exp pr s = gen (parse s) ghc-exactprint-0.6.2/tests/examples/ghc80/PromotedClass.hs0000755000000000000000000000024507346545000021640 0ustar0000000000000000{-# LANGUAGE TypeInType, GADTs #-} module PromotedClass where import Data.Proxy data X a where MkX :: Show a => a -> X a foo :: Proxy ('MkX 'True) foo = Proxy ghc-exactprint-0.6.2/tests/examples/ghc80/Q.hs0000755000000000000000000000022107346545000017253 0ustar0000000000000000module Q where import qualified Map import Map(Map) mymember :: Int -> Map Int a -> Bool mymember k m = Map.member k m || Map.member (k + 1) m ghc-exactprint-0.6.2/tests/examples/ghc80/QQ.hs0000755000000000000000000000064407346545000017405 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module QQ where import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Language.Haskell.TH pq = QuasiQuoter { quoteDec = \_ -> return [sig], quoteType = \_ -> undefined, quoteExp = \_ -> undefined, quotePat = \_ -> undefined } sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int) int = ConT (mkName "Int") ghc-exactprint-0.6.2/tests/examples/ghc80/Query.hs0000755000000000000000000000026607346545000020171 0ustar0000000000000000{-# LANGUAGE CPP #-} module AWS.Lib.Query where requestQuery = do if st < 400 #ifdef DEBUG do e #else then return body else fail "not reached" #endif ghc-exactprint-0.6.2/tests/examples/ghc80/RandomPGC.hs0000755000000000000000000005317607346545000020646 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : System.Random -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file LICENSE in the 'random' repository) -- -- Maintainer : libraries@haskell.org -- Stability : stable -- Portability : portable -- -- This library deals with the common task of pseudo-random number -- generation. The library makes it possible to generate repeatable -- results, by starting with a specified initial random number generator, -- or to get different results on each run by using the system-initialised -- generator or by supplying a seed from some other source. -- -- The library is split into two layers: -- -- * A core /random number generator/ provides a supply of bits. -- The class 'RandomGen' provides a common interface to such generators. -- The library provides one instance of 'RandomGen', the abstract -- data type 'StdGen'. Programmers may, of course, supply their own -- instances of 'RandomGen'. -- -- * The class 'Random' provides a way to extract values of a particular -- type from a random number generator. For example, the 'Float' -- instance of 'Random' allows one to generate random values of type -- 'Float'. -- -- This implementation uses the Portable Combined Generator of L'Ecuyer -- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by -- Lennart Augustsson. It has a period of roughly 2.30584e18. -- ----------------------------------------------------------------------------- #include "MachDeps.h" module RandomPGC ( -- $intro -- * Random number generators #ifdef ENABLE_SPLITTABLEGEN RandomGen(next, genRange) , SplittableGen(split) #else RandomGen(next, genRange, split) #endif -- ** Standard random number generators , StdGen , mkStdGen -- ** The global random number generator -- $globalrng , getStdRandom , getStdGen , setStdGen , newStdGen -- * Random values of various types , Random ( random, randomR, randoms, randomRs, randomIO, randomRIO ) -- * References -- $references ) where import Prelude import Data.Bits import Data.Int import Data.Word import Foreign.C.Types #ifdef __NHC__ import CPUTime ( getCPUTime ) import Foreign.Ptr ( Ptr, nullPtr ) import Foreign.C ( CTime, CUInt ) #else import System.CPUTime ( getCPUTime ) import Data.Time ( getCurrentTime, UTCTime(..) ) import Data.Ratio ( numerator, denominator ) #endif import Data.Char ( isSpace, chr, ord ) import System.IO.Unsafe ( unsafePerformIO ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.IORef ( atomicModifyIORef' ) import Numeric ( readDec ) #ifdef __GLASGOW_HASKELL__ import GHC.Exts ( build ) #else -- | A dummy variant of build without fusion. {-# INLINE build #-} build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] build g = g (:) [] #endif -- The standard nhc98 implementation of Time.ClockTime does not match -- the extended one expected in this module, so we lash-up a quick -- replacement here. #ifdef __NHC__ foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime getTime :: IO (Integer, Integer) getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) #else getTime :: IO (Integer, Integer) getTime = do utc <- getCurrentTime let daytime = toRational $ utctDayTime utc return $ quotRem (numerator daytime) (denominator daytime) #endif -- | The class 'RandomGen' provides a common interface to random number -- generators. -- #ifdef ENABLE_SPLITTABLEGEN -- Minimal complete definition: 'next'. #else -- Minimal complete definition: 'next' and 'split'. #endif class RandomGen g where -- |The 'next' operation returns an 'Int' that is uniformly distributed -- in the range returned by 'genRange' (including both end points), -- and a new generator. next :: g -> (Int, g) -- |The 'genRange' operation yields the range of values returned by -- the generator. -- -- It is required that: -- -- * If @(a,b) = 'genRange' g@, then @a < b@. -- -- * 'genRange' always returns a pair of defined 'Int's. -- -- The second condition ensures that 'genRange' cannot examine its -- argument, and hence the value it returns can be determined only by the -- instance of 'RandomGen'. That in turn allows an implementation to make -- a single call to 'genRange' to establish a generator's range, without -- being concerned that the generator returned by (say) 'next' might have -- a different range to the generator passed to 'next'. -- -- The default definition spans the full range of 'Int'. genRange :: g -> (Int,Int) -- default method genRange _ = (minBound, maxBound) #ifdef ENABLE_SPLITTABLEGEN -- | The class 'SplittableGen' proivides a way to specify a random number -- generator that can be split into two new generators. class SplittableGen g where #endif -- |The 'split' operation allows one to obtain two distinct random number -- generators. This is very useful in functional programs (for example, when -- passing a random number generator down to recursive calls), but very -- little work has been done on statistically robust implementations of -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] -- are the only examples we know of). split :: g -> (g, g) {- | The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. The result of repeatedly using 'next' should be at least as statistically robust as the /Minimal Standard Random Number Generator/ described by ["System.Random\#Park", "System.Random\#Carta"]. Until more is known about implementations of 'split', all we require is that 'split' deliver generators that are (a) not identical and (b) independently robust in the sense just given. The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the state of a random number generator. It is required that @'read' ('show' g) == g@. In addition, 'reads' may be used to map an arbitrary string (not necessarily one produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' instance of 'StdGen' has the following properties: * It guarantees to succeed on any string. * It guarantees to consume only a finite portion of the string. * Different argument strings are likely to result in different results. -} data StdGen = StdGen !Int32 !Int32 instance RandomGen StdGen where next = stdNext genRange _ = stdRange #ifdef ENABLE_SPLITTABLEGEN instance SplittableGen StdGen where #endif split = stdSplit instance Show StdGen where showsPrec p (StdGen s1 s2) = showsPrec p s1 . showChar ' ' . showsPrec p s2 instance Read StdGen where readsPrec _p = \ r -> case try_read r of r'@[_] -> r' _ -> [stdFromString r] -- because it shouldn't ever fail. where try_read r = do (s1, r1) <- readDec (dropWhile isSpace r) (s2, r2) <- readDec (dropWhile isSpace r1) return (StdGen s1 s2, r2) {- If we cannot unravel the StdGen from a string, create one based on the string given. -} stdFromString :: String -> (StdGen, String) stdFromString s = (mkStdGen num, rest) where (cs, rest) = splitAt 6 s num = foldl (\a x -> x + 3 * a) 1 (map ord cs) {- | The function 'mkStdGen' provides an alternative way of producing an initial generator, by mapping an 'Int' into a generator. Again, distinct arguments should be likely to produce distinct generators. -} mkStdGen :: Int -> StdGen -- why not Integer ? mkStdGen s = mkStdGen32 $ fromIntegral s {- From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be initialized to values in the range [1, 2147483562] and [1, 2147483398] respectively." -} mkStdGen32 :: Int32 -> StdGen mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) where -- We want a non-negative number, but we can't just take the abs -- of sMaybeNegative as -minBound == minBound. s = sMaybeNegative .&. maxBound (q, s1) = s `divMod` 2147483562 s2 = q `mod` 2147483398 createStdGen :: Integer -> StdGen createStdGen s = mkStdGen32 $ fromIntegral s {- | With a source of random number supply in hand, the 'Random' class allows the programmer to extract random values of a variety of types. Minimal complete definition: 'randomR' and 'random'. -} class Random a where -- | Takes a range /(lo,hi)/ and a random number generator -- /g/, and returns a random value uniformly distributed in the closed -- interval /[lo,hi]/, together with a new generator. It is unspecified -- what happens if /lo>hi/. For continuous types there is no requirement -- that the values /lo/ and /hi/ are ever produced, but they may be, -- depending on the implementation and the interval. randomR :: RandomGen g => (a,a) -> g -> (a,g) -- | The same as 'randomR', but using a default range determined by the type: -- -- * For bounded types (instances of 'Bounded', such as 'Char'), -- the range is normally the whole type. -- -- * For fractional types, the range is normally the semi-closed interval -- @[0,1)@. -- -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. random :: RandomGen g => g -> (a, g) -- | Plural variant of 'randomR', producing an infinite list of -- random values instead of returning a new generator. {-# INLINE randomRs #-} randomRs :: RandomGen g => (a,a) -> g -> [a] randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) -- | Plural variant of 'random', producing an infinite list of -- random values instead of returning a new generator. {-# INLINE randoms #-} randoms :: RandomGen g => g -> [a] randoms g = build (\cons _nil -> buildRandoms cons random g) -- | A variant of 'randomR' that uses the global random number generator -- (see "System.Random#globalrng"). randomRIO :: (a,a) -> IO a randomRIO range = getStdRandom (randomR range) -- | A variant of 'random' that uses the global random number generator -- (see "System.Random#globalrng"). randomIO :: IO a randomIO = getStdRandom random -- | Produce an infinite list-equivalent of random values. {-# INLINE buildRandoms #-} buildRandoms :: RandomGen g => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion -> (g -> (a,g)) -- ^ E.g. 'random' -> g -- ^ A 'RandomGen' instance -> as buildRandoms cons rand = go where -- The seq fixes part of #4218 and also makes fused Core simpler. go g = x `seq` (x `cons` go g') where (x,g') = rand g instance Random Integer where randomR ival g = randomIvalInteger ival g random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g instance Random Int where randomR = randomIvalIntegral; random = randomBounded instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded #ifndef __NHC__ -- Word is a type synonym in nhc98. instance Random Word where randomR = randomIvalIntegral; random = randomBounded #endif instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded instance Random CChar where randomR = randomIvalIntegral; random = randomBounded instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded instance Random CShort where randomR = randomIvalIntegral; random = randomBounded instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded instance Random CInt where randomR = randomIvalIntegral; random = randomBounded instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded instance Random CLong where randomR = randomIvalIntegral; random = randomBounded instance Random CULong where randomR = randomIvalIntegral; random = randomBounded instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded instance Random CSize where randomR = randomIvalIntegral; random = randomBounded instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded instance Random Char where randomR (a,b) g = case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of (x,g') -> (chr x, g') random g = randomR (minBound,maxBound) g instance Random Bool where randomR (a,b) g = case (randomIvalInteger (bool2Int a, bool2Int b) g) of (x, g') -> (int2Bool x, g') where bool2Int :: Bool -> Integer bool2Int False = 0 bool2Int True = 1 int2Bool :: Int -> Bool int2Bool 0 = False int2Bool _ = True random g = randomR (minBound,maxBound) g {-# INLINE randomRFloating #-} randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) randomRFloating (l,h) g | l>h = randomRFloating (h,l) g | otherwise = let (coef,g') = random g in (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow instance Random Double where randomR = randomRFloating random rng = case random rng of (x,rng') -> -- We use 53 bits of randomness corresponding to the 53 bit significand: ((fromIntegral (mask53 .&. (x::Int64)) :: Double) / fromIntegral twoto53, rng') where twoto53 = (2::Int64) ^ (53::Int64) mask53 = twoto53 - 1 instance Random Float where randomR = randomRFloating random rng = -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. case random rng of (x,rng') -> -- We use 24 bits of randomness corresponding to the 24 bit significand: ((fromIntegral (mask24 .&. (x::Int32)) :: Float) / fromIntegral twoto24, rng') -- Note, encodeFloat is another option, but I'm not seeing slightly -- worse performance with the following [2011.06.25]: -- (encodeFloat rand (-24), rng') where mask24 = twoto24 - 1 twoto24 = (2::Int32) ^ (24::Int32) -- CFloat/CDouble are basically the same as a Float/Double: instance Random CFloat where randomR = randomRFloating random rng = case random rng of (x,rng') -> (realToFrac (x::Float), rng') instance Random CDouble where randomR = randomRFloating -- A MYSTERY: -- Presently, this is showing better performance than the Double instance: -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) random = randomFrac -- random rng = case random rng of -- (x,rng') -> (realToFrac (x::Double), rng') mkStdRNG :: Integer -> IO StdGen mkStdRNG o = do ct <- getCPUTime (sec, psec) <- getTime return (createStdGen (sec * 12345 + psec + ct + o)) randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) randomBounded = randomR (minBound, maxBound) -- The two integer functions below take an [inclusive,inclusive] range. randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) {-# SPECIALIZE randomIvalInteger :: (Num a) => (Integer, Integer) -> StdGen -> (a, StdGen) #-} randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) randomIvalInteger (l,h) rng | l > h = randomIvalInteger (h,l) rng | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') where (genlo, genhi) = genRange rng b = fromIntegral genhi - fromIntegral genlo + 1 -- Probabilities of the most likely and least likely result -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen -- is uniform, of course -- On average, log q / log b more random values will be generated -- than the minimum q = 1000 k = h - l + 1 magtgt = k * q -- generate random values until we exceed the target magnitude f mag v g | mag >= magtgt = (v, g) | otherwise = v' `seq`f (mag*b) v' g' where (x,g') = next g v' = (v * b + (fromIntegral x - fromIntegral genlo)) -- The continuous functions on the other hand take an [inclusive,exclusive) range. randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) randomFrac = randomIvalDouble (0::Double,1) realToFrac randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) randomIvalDouble (l,h) fromDouble rng | l > h = randomIvalDouble (h,l) fromDouble rng | otherwise = case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of (x, rng') -> let scaled_x = fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow fromIntegral (x::Int32) in (scaled_x, rng') int32Count :: Integer int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 stdRange :: (Int,Int) stdRange = (1, 2147483562) stdNext :: StdGen -> (Int, StdGen) -- Returns values in the range stdRange stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') where z' = if z < 1 then z + 2147483562 else z z = s1'' - s2'' k = s1 `quot` 53668 s1' = 40014 * (s1 - k * 53668) - k * 12211 s1'' = if s1' < 0 then s1' + 2147483563 else s1' k' = s2 `quot` 52774 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' stdSplit :: StdGen -> (StdGen, StdGen) stdSplit std@(StdGen s1 s2) = (left, right) where -- no statistical foundation for this! left = StdGen new_s1 t2 right = StdGen t1 new_s2 new_s1 | s1 == 2147483562 = 1 | otherwise = s1 + 1 new_s2 | s2 == 1 = 2147483398 | otherwise = s2 - 1 StdGen t1 t2 = snd (next std) -- The global random number generator {- $globalrng #globalrng# There is a single, implicit, global random number generator of type 'StdGen', held in some global variable maintained by the 'IO' monad. It is initialised automatically in some system-dependent fashion, for example, by using the time of day, or Linux's kernel random number generator. To get deterministic behaviour, use 'setStdGen'. -} -- |Sets the global random number generator. setStdGen :: StdGen -> IO () setStdGen sgen = writeIORef theStdGen sgen -- |Gets the global random number generator. getStdGen :: IO StdGen getStdGen = readIORef theStdGen theStdGen :: IORef StdGen theStdGen = unsafePerformIO $ do rng <- mkStdRNG 0 newIORef rng -- |Applies 'split' to the current global random generator, -- updates it with one of the results, and returns the other. newStdGen :: IO StdGen newStdGen = atomicModifyIORef' theStdGen split {- |Uses the supplied function to get a value from the current global random generator, and updates the global generator with the new generator returned by the function. For example, @rollDice@ gets a random integer between 1 and 6: > rollDice :: IO Int > rollDice = getStdRandom (randomR (1,6)) -} getStdRandom :: (StdGen -> (a,StdGen)) -> IO a getStdRandom f = atomicModifyIORef' theStdGen (swap . f) where swap (v,g) = (g,v) {- $references 1. FW #Burton# Burton and RL Page, /Distributed random number generation/, Journal of Functional Programming, 2(2):203-212, April 1992. 2. SK #Park# Park, and KW Miller, /Random number generators - good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. 3. DG #Carta# Carta, /Two fast implementations of the minimal standard random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. 4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, Department of Mathematics, University of Salzburg, , 1998. 5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. The Web site is a great source of information. -} ghc-exactprint-0.6.2/tests/examples/ghc80/RepArrow.hs0000755000000000000000000000037607346545000020627 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module RepArrow where import Data.Ord ( Down ) -- convenient "Id" newtype, without its constructor import Data.Coerce foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int foo = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/Roles12a.hs0000755000000000000000000000006407346545000020450 0ustar0000000000000000module Roles12a where import {-# SOURCE #-} Roles12 ghc-exactprint-0.6.2/tests/examples/ghc80/RuleDefiningPlugin.hs0000755000000000000000000000022107346545000022605 0ustar0000000000000000module RuleDefiningPlugin where import GhcPlugins {-# RULES "unsound" forall x. show x = "SHOWED" #-} plugin :: Plugin plugin = defaultPlugin ghc-exactprint-0.6.2/tests/examples/ghc80/RulePragma.hs0000755000000000000000000000022407346545000021115 0ustar0000000000000000module Data.Text.Internal.Fusion.Common where {-# RULES "STREAM map/map fusion" forall f g s. map f (map g s) = map (\x -> f (g x)) s #-} ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap1.hs0000755000000000000000000000045507346545000021147 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances #-} -- | Compilation should fail as we have overlapping instances that don't obey -- our heuristics. module SH_Overlap1 where import safe SH_Overlap1_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap10.hs0000755000000000000000000000053607346545000021227 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since -- overlapped instance declares itself overlappable. module SH_Overlap10 where import SH_Overlap10_A instance {-# OVERLAPS #-} C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap10_A.hs0000755000000000000000000000031007346545000021455 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap10_A ( C(..) ) where import SH_Overlap10_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap10_B.hs0000755000000000000000000000016307346545000021464 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} module SH_Overlap10_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap11.hs0000755000000000000000000000060707346545000021227 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred -- unsafe due to overlapping instances at call site `f`. -- -- Testing that we are given correct reason. module SH_Overlap11 where import SH_Overlap11_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap11_A.hs0000755000000000000000000000031007346545000021456 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap11_A ( C(..) ) where import SH_Overlap11_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap11_B.hs0000755000000000000000000000016307346545000021465 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} module SH_Overlap11_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap1_A.hs0000755000000000000000000000027207346545000021404 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap1_A ( C(..) ) where import SH_Overlap1_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap1_B.hs0000755000000000000000000000014607346545000021405 0ustar0000000000000000{-# LANGUAGE Safe #-} module SH_Overlap1_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap2.hs0000755000000000000000000000074107346545000021146 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'. -- -- Question: Should the OI-check be enforced? Y, see reasoning in -- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should -- be tied to Safe Haskell mode only, and not to safe imports. module SH_Overlap2 where import SH_Overlap2_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap2_A.hs0000755000000000000000000000027207346545000021405 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap2_A ( C(..) ) where import SH_Overlap2_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap2_B.hs0000755000000000000000000000014607346545000021406 0ustar0000000000000000{-# LANGUAGE Safe #-} module SH_Overlap2_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap3.hs0000755000000000000000000000053507346545000021150 0ustar0000000000000000{-# LANGUAGE Unsafe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is -- marked `Unsafe`. Compilation should succeed (symetry with inferring safety). module SH_Overlap3 where import SH_Overlap3_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap3_A.hs0000755000000000000000000000027207346545000021406 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap3_A ( C(..) ) where import SH_Overlap3_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap3_B.hs0000755000000000000000000000014607346545000021407 0ustar0000000000000000{-# LANGUAGE Safe #-} module SH_Overlap3_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap4.hs0000755000000000000000000000126607346545000021153 0ustar0000000000000000{-# LANGUAGE Unsafe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`. -- -- Question: Should compilation now fail? N. At first it seems a nice idea to -- tie the overlap check to safe imports. However, instances are a global -- entity and can be imported by multiple import paths. How should safe imports -- interact with this? Especially when considering transitive situations... -- -- Simplest is to just enforce the overlap check in Safe and Trustworthy -- modules, but not in Unsafe ones. module SH_Overlap4 where import safe SH_Overlap4_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap4_A.hs0000755000000000000000000000027207346545000021407 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap4_A ( C(..) ) where import SH_Overlap4_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap4_B.hs0000755000000000000000000000014607346545000021410 0ustar0000000000000000{-# LANGUAGE Safe #-} module SH_Overlap4_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap5.hs0000755000000000000000000000044607346545000021153 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} -- | Compilation should fail as we have overlapping instances that don't obey -- our heuristics. module SH_Overlap5 where import safe SH_Overlap5_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap5_A.hs0000755000000000000000000000027207346545000021410 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap5_A ( C(..) ) where import SH_Overlap5_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap5_B.hs0000755000000000000000000000014607346545000021411 0ustar0000000000000000{-# LANGUAGE Safe #-} module SH_Overlap5_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap6.hs0000755000000000000000000000047507346545000021156 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not -- explicitly marked. Compilation should still fail. module SH_Overlap6 where import safe SH_Overlap6_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap6_A.hs0000755000000000000000000000030607346545000021407 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap6_A ( C(..) ) where import SH_Overlap6_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap6_B.hs0000755000000000000000000000016207346545000021410 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} module SH_Overlap6_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap7.hs0000755000000000000000000000052107346545000021147 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred -- unsafe due to overlapping instances at call site `f`. module SH_Overlap7 where import SH_Overlap7_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap7_A.hs0000755000000000000000000000033407346545000021411 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE Safe #-} module SH_Overlap7_A ( C(..) ) where import SH_Overlap7_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap7_B.hs0000755000000000000000000000021007346545000021403 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE Safe #-} module SH_Overlap7_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap8.hs0000755000000000000000000000070307346545000021152 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} -- | Overlapping instances, but with a single parameter type-class and no -- orphans. So `SH_Overlap8` decided to explictly depend on `SH_Overlap8_A` -- since that's where the type-class `C` with function `f` is defined. -- -- Question: Safe or Unsafe? Safe module SH_Overlap8 where import safe SH_Overlap8_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap8_A.hs0000755000000000000000000000031007346545000021404 0ustar0000000000000000{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap8_A ( C(..) ) where class C a where f :: a -> String instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap9.hs0000755000000000000000000000052307346545000021153 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-safe #-} {-# LANGUAGE FlexibleInstances #-} -- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred -- unsafe due to overlapping instances at call site `f`. module SH_Overlap9 where import SH_Overlap9_A instance C [a] where f _ = "[a]" test :: String test = f ([1,2,3,4] :: [Int]) ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap9_A.hs0000755000000000000000000000030607346545000021412 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} {-# LANGUAGE FlexibleInstances #-} module SH_Overlap9_A ( C(..) ) where import SH_Overlap9_B instance {-# OVERLAPS #-} C [Int] where f _ = "[Int]" ghc-exactprint-0.6.2/tests/examples/ghc80/SH_Overlap9_B.hs0000755000000000000000000000016207346545000021413 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unsafe #-} module SH_Overlap9_B ( C(..) ) where class C a where f :: a -> String ghc-exactprint-0.6.2/tests/examples/ghc80/SayAnnNames.hs0000755000000000000000000000214007346545000021232 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module SayAnnNames (plugin, SomeAnn(..)) where import GhcPlugins import Control.Monad (unless) import Data.Data data SomeAnn = SomeAnn deriving (Data, Typeable) plugin :: Plugin plugin = defaultPlugin { installCoreToDos = install } install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] install _ todo = do reinitializeGlobals return (CoreDoPluginPass "Say name" pass : todo) pass :: ModGuts -> CoreM ModGuts pass g = do dflags <- getDynFlags mapM_ (printAnn dflags g) (mg_binds g) >> return g where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind printAnn dflags guts bndr@(NonRec b _) = do anns <- annotationsOn guts b :: CoreM [SomeAnn] unless (null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc dflags (ppr b) return bndr printAnn _ _ bndr = return bndr annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] annotationsOn guts bndr = do anns <- getAnnotations deserializeWithData guts return $ lookupWithDefaultUFM anns [] (varUnique bndr) ghc-exactprint-0.6.2/tests/examples/ghc80/SelfDep.hs0000755000000000000000000000004707346545000020403 0ustar0000000000000000module SelfDep where data T :: T -> * ghc-exactprint-0.6.2/tests/examples/ghc80/SemicolonIf.hs0000755000000000000000000000056607346545000021276 0ustar0000000000000000module Bar where import Data.Text as Text replace :: Text -> Text replace = Text.map (\c -> if c == '_' then '.'; else c) replace1 :: Text -> Text replace1 = Text.map (\c -> if c == '_' ; then '.' else c) replace2 :: Text -> Text replace2 = Text.map (\c -> if c == '_'; then '.'; else c) replace4 :: Text -> Text replace4 = Text.map (\c -> if c == '_' then '.' else c) ghc-exactprint-0.6.2/tests/examples/ghc80/SemigroupWarnings.hs0000755000000000000000000000117707346545000022551 0ustar0000000000000000-- Test purpose: -- Ensure that missing semigroup warnings are issued -- correctly if the warning flag is enabled {-# OPTIONS_GHC -fwarn-semigroup #-} module SemigroupWarnings where import Data.Semigroup -- Bad instance, should complain about missing Semigroup parent data LacksSemigroup instance Monoid LacksSemigroup where mempty = undefined mappend = undefined -- Correct instance, should not warn data HasSemigroup instance Semigroup HasSemigroup where (<>) = undefined instance Monoid HasSemigroup where mempty = undefined mappend = undefined -- Should issue a Prelude clash warning (<>) = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Setup.hs0000755000000000000000000000005707346545000020162 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-exactprint-0.6.2/tests/examples/ghc80/ShouldFail.hs0000755000000000000000000000001307346545000021104 0ustar0000000000000000import Set ghc-exactprint-0.6.2/tests/examples/ghc80/SigTvKinds.hs0000755000000000000000000000023307346545000021103 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module SigTvKinds where data T (a :: k1) x = MkT (S a ()) data S (b :: k2) y = MkS (T b ()) -- tests TcTyClsDecls.no_sig_tv ghc-exactprint-0.6.2/tests/examples/ghc80/SigTvKinds2.hs0000755000000000000000000000020607346545000021165 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module SigTvKinds2 where data SameKind :: k -> k -> * data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b) ghc-exactprint-0.6.2/tests/examples/ghc80/SpecializePhaseControl.hs0000755000000000000000000000064607346545000023500 0ustar0000000000000000{-# SPECIALISE [1] x :: Integer -> Integer -> Integer, Integer -> Int -> Integer, Int -> Int -> Int #-} {-# INLINABLE [1] x #-} x :: (Num a, Integral b) => a -> b -> a x = undefined {-# SPECIALISE INLINE [999] y :: Integer -> Integer -> Integer, Integer -> Int -> Integer, Int -> Int -> Int #-} {-# INLINABLE [1] y #-} y :: (Num a, Integral b) => a -> b -> a y = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Splices.hs0000755000000000000000000000117107346545000020462 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NamedWildCards #-} module Splices where import Language.Haskell.TH import Language.Haskell.TH.Lib (wildCardT) metaType1 :: TypeQ metaType1 = wildCardT metaType2 :: TypeQ metaType2 = [t| _ |] metaType3 :: TypeQ metaType3 = [t| _ -> _ -> _ |] metaDec1 :: Q [Dec] metaDec1 = [d| foo :: _ => _ foo x y = x == y |] metaDec2 :: Q [Dec] metaDec2 = [d| bar :: _a -> _b -> (_a, _b) bar x y = (not x, y) |] -- An expression with a partial type annotation metaExp1 :: ExpQ metaExp1 = [| Just True :: Maybe _ |] metaExp2 :: ExpQ metaExp2 = [| id :: _a -> _a |] ghc-exactprint-0.6.2/tests/examples/ghc80/SplicesUsed.hs0000755000000000000000000000044307346545000021304 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PartialTypeSignatures #-} module SplicesUsed where import Splices maybeBool :: $(metaType1) maybeBool = $(metaExp2) $(metaExp1) charA :: a -> $(metaType2) charA x = ('x', x) filter' :: $(metaType3) filter' = filter $(metaDec1) $(metaDec2) ghc-exactprint-0.6.2/tests/examples/ghc80/StackOverflow.hs0000755000000000000000000000010507346545000021645 0ustar0000000000000000main :: IO () main = main' () where main' _ = main >> main' () ghc-exactprint-0.6.2/tests/examples/ghc80/Structure8.hs0000755000000000000000000000002607346545000021146 0ustar0000000000000000foo x | otherwise = y ghc-exactprint-0.6.2/tests/examples/ghc80/Structure8a.hs0000755000000000000000000000001207346545000021302 0ustar0000000000000000foo x = y ghc-exactprint-0.6.2/tests/examples/ghc80/T10009.hs0000755000000000000000000000526707346545000017667 0ustar0000000000000000{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10009 where type family F a type family UnF a f :: (UnF (F b) ~ b) => F b -> () f = error "urk" g :: forall a. (UnF (F a) ~ a) => a -> () g _ = f (undefined :: F a) {- --------------- [G] UnF (F b) ~ b [W] UnF (F beta) ~ beta [W] F a ~ F beta ------------------- [G] g1: F a ~ fsk1 fsk1 := F a [G] g2: UnF fsk1 ~ fsk2 fsk2 := UnF fsk1 [G] g3: fsk2 ~ a [W] w1: F beta ~ fmv1 [W] w2: UnF fmv1 ~ fmv2 [W] w3: fmv2 ~ beta [W] w5: fsk1 ~ fmv1 -- From F a ~ F beta -- using flat-cache ---- No progress in solving ----- -- Unflatten: [W] w3: UnF (F beta) ~ beta [W] w5: fsk1 ~ F beta --- Improvement [D] F beta ~ fmv1 [D] UnF fmv1 ~ fmv2 -- (A) [D] fmv2 ~ beta [D] fmv1 ~ fsk1 -- (B) From F a ~ F beta -- NB: put fmv on left --> rewrite (A) with (B), and match with g2 [D] F beta ~ fmv1 [D] fmv2 ~ fsk2 -- (C) [D] fmv2 ~ beta -- (D) [D] fmv1 ~ fsk1 --> rewrite (D) with (C) and re-orient [D] F beta ~ fmv1 [D] fmv2 ~ fsk2 [D] beta ~ fsk2 -- (E) [D] fmv1 ~ fsk1 -- Now we can unify beta! -} {- ----- Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy wl: [W] F b_amr ~ F b_amt work item: [W] UnF (F b_amt) ~ b_amt b_amt is the unification variable ===> b_amt := s_amF Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy wl: [W] F b_amr ~ F b_amt [W] UnF s_amD ~ s_amF work item: [W] F b_amt ~ s_amD ===> wl: [W] F b_amr ~ F b_amt [W] UnF s_amD ~ s_amF Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy [W] F s_amF ~ s_amD ===> wl: [W] F b_amr ~ F b_amt Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy [W] F s_amF ~ s_amD [W] UnF s_amD ~ s_amF ===> Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy [W] UnF s_amD ~ s_amF [W] F s_amF ~ s_amD wl: work-item: [W] F b_amr ~ F b_amt --> fsk_amy ~ s_amD --> s_amD ~ fsk_amy ===> Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy [W] UnF s_amD ~ s_amF [W] F s_amF ~ s_amD [W] s_amD ~ fsk_amy wl: work item: [D] UnF s_amD ~ s_amF --> [D] UnF fsk_amy ~ s_amF --> [D] s_amF ~ fsk_amA ===> Inert: [G] fsk_amA ~ b_amr [G] UnF fsk_amy ~ fsk_amA [G} F b_amr ~ fsk_amy [W] UnF s_amD ~ s_amF [W] F s_amF ~ s_amD [W] s_amD ~ fsk_amy [D] s_amF ~ fsk_amA wl: work item: [D] F s_amF ~ s_amD --> F fsk_amA ~ s_amD --> s_amd ~ b_amr -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10030.hs0000755000000000000000000000020507346545000017644 0ustar0000000000000000module Main where import GHC.Generics main = do putStrLn $ packageName $ from $ Just True putStrLn $ packageName $ from $ True ghc-exactprint-0.6.2/tests/examples/ghc80/T10041.hs0000755000000000000000000000035507346545000017654 0ustar0000000000000000{-# LANGUAGE PolyKinds, TypeFamilies, DataKinds #-} {-# LANGUAGE TypeOperators, GADTs, InstanceSigs #-} module T10041 where data family Sing (a :: k) data instance Sing (xs :: [k]) where SNil :: Sing '[] class SingI (a :: ĸ) where ghc-exactprint-0.6.2/tests/examples/ghc80/T10045.hs0000755000000000000000000000021307346545000017651 0ustar0000000000000000module T10045 where newtype Meta = Meta () foo (Meta ws1) = let copy :: _ copy w from = copy w True in copy ws1 False ghc-exactprint-0.6.2/tests/examples/ghc80/T10047.hs0000755000000000000000000000024207346545000017655 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-missing-fields #-} module T10047 where import Language.Haskell.TH import Language.Haskell.TH.Quote n = QuasiQuoter { quoteExp = dyn } ghc-exactprint-0.6.2/tests/examples/ghc80/T10052-input.hs0000755000000000000000000000006107346545000021005 0ustar0000000000000000main = let (x :: String) = "hello" in putStrLn x ghc-exactprint-0.6.2/tests/examples/ghc80/T10052.hs0000755000000000000000000000150507346545000017654 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wall #-} module Main where import System.Environment import GHC main :: IO () main = do flags <- getArgs runGhc' flags $ do setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing] _success <- load LoadAllTargets return () runGhc' :: [String] -> Ghc a -> IO a runGhc' args act = do let libdir = head args flags = tail args (dynFlags, _warns) <- parseStaticFlags (map noLoc flags) runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 dynFlags let dflags2 = dflags1 { hscTarget = HscInterpreted , ghcLink = LinkInMemory , verbosity = 1 } _newPkgs <- setSessionDynFlags dflags2 act ghc-exactprint-0.6.2/tests/examples/ghc80/T10083.hs0000755000000000000000000000020407346545000017653 0ustar0000000000000000module T10083 where import T10083a data RSR = MkRSR SR eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) foo x y = not (eqRSR x y) ghc-exactprint-0.6.2/tests/examples/ghc80/T10083a.hs0000755000000000000000000000016207346545000020017 0ustar0000000000000000module T10083a where import {-# SOURCE #-} T10083 data SR = MkSR RSR eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 ghc-exactprint-0.6.2/tests/examples/ghc80/T10100.hs0000755000000000000000000000047507346545000017653 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} module T10100 where data Zero data Succ a class Add a b ab | a b -> ab, a ab -> b instance Add Zero b b instance (Add a b ab) => Add (Succ a) b (Succ ab) ghc-exactprint-0.6.2/tests/examples/ghc80/T10104.hs0000755000000000000000000000042307346545000017650 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module Main where import GHC.Prim data P = Positives Int# Float# Double# Char# Word# deriving Show data N = Negatives Int# Float# Double# deriving Show main = do print $ Positives 42# 4.23# 4.23## '4'# 4## print $ Negatives -4# -4.0# -4.0## ghc-exactprint-0.6.2/tests/examples/ghc80/T10109.hs0000755000000000000000000000041307346545000017654 0ustar0000000000000000{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, FlexibleInstances #-} module T10109 where data Succ a class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab instance (Add a b ab) => Add (Succ a) b (Succ ab) ghc-exactprint-0.6.2/tests/examples/ghc80/T10110A.hs0000755000000000000000000000007307346545000017747 0ustar0000000000000000module T10110A (a) where {-# NOINLINE a #-} a :: Int a = 3 ghc-exactprint-0.6.2/tests/examples/ghc80/T10110B.hs0000755000000000000000000000005007346545000017743 0ustar0000000000000000module T10110B (b) where b :: Int b = 5 ghc-exactprint-0.6.2/tests/examples/ghc80/T10110C.hs0000755000000000000000000000012007346545000017742 0ustar0000000000000000module T10110C (c) where import T10110A (a) import T10110B (b) c :: Int c = a+b ghc-exactprint-0.6.2/tests/examples/ghc80/T10112.hs0000755000000000000000000000043607346545000017653 0ustar0000000000000000{-# LANGUAGE RankNTypes, RebindableSyntax #-} module T10112 where import qualified Prelude as P (>>=) :: a -> ((forall b . b) -> c) -> c a >>= f = f P.undefined return a = a fail s = P.undefined t1 = 'd' >>= (\_ -> 'k') t2 = do { _ <- 'd' ; 'k' } foo = P.putStrLn [t1, t2] ghc-exactprint-0.6.2/tests/examples/ghc80/T10134.hs0000755000000000000000000000105407346545000017654 0ustar0000000000000000{-# LANGUAGE DataKinds, TypeOperators, ConstraintKinds, TypeFamilies, NoMonoLocalBinds, NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10134 where import GHC.TypeLits import T10134a import Prelude type Positive n = ((n-1)+1)~n data Dummy n d = Dummy { vec :: Vec n (Vec d Bool) } nextDummy :: Positive (2*(n+d)) => Dummy n d -> Dummy n d nextDummy d = Dummy { vec = vec dFst } where (dFst,dSnd) = nextDummy' d nextDummy' :: Positive (2*(n+d)) => Dummy n d -> ( Dummy n d, Bool ) nextDummy' _ = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T10139.hs0000755000000000000000000000216307346545000017663 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleInstances, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, FunctionalDependencies #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10139 where import GHC.Exts import Data.Monoid class Monoid v => Measured v a | a -> v where _measure :: v -> a data FingerTree v a = Dummy v a singleton :: Measured v a => a -> FingerTree v a singleton = undefined class DOps a where plus :: a -> D a -> a type family D a :: * type instance D (FingerTree (Size Int, v) (Sized a)) = [Diff (Normal a)] type family Normal a :: * data Diff a = Add Int a newtype Sized a = Sized a newtype Size a = Size a -- This works: {- instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where plus = foldr (\(Add index val) seq -> singleton ((coerce) val)) -} -- This hangs: instance (Measured (Size Int, v) (Sized a), Coercible (Normal a) (Sized a)) => DOps (FingerTree (Size Int, v) (Sized a)) where plus = foldr (flip f) where f _seq x = case x of Add _index val -> singleton ((coerce) val) ghc-exactprint-0.6.2/tests/examples/ghc80/T10141.hs0000755000000000000000000000021307346545000017646 0ustar0000000000000000{-# LANGUAGE TypeFamilies, PolyKinds #-} module T10141 where type family G (a :: k) where G Int = Bool G Bool = Int G a = a ghc-exactprint-0.6.2/tests/examples/ghc80/T10148.hs0000755000000000000000000000122707346545000017663 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main where import Debug.Trace data Machine = Machine (Int -> Machine) Int main :: IO () main = (go 7 $ Machine (gstep (Array 99)) 8) `seq` return () where go :: Int -> Machine -> Int go 0 (Machine _ done) = done go nq (Machine step _) = go (nq-1) $ step 0 gstep :: Array Int -> Int -> Machine gstep m x = Machine (gstep m') (mindexA m) where !m' = adjustA x m data Array a = Array a adjustA :: (Show a) => Int -> Array a -> Array a adjustA i (Array t) | i < 0 = undefined i -- not just undefined! | otherwise = Array $ trace ("adj " ++ show t) $ t mindexA :: Array a -> a mindexA (Array v) = v ghc-exactprint-0.6.2/tests/examples/ghc80/T10156.hs0000755000000000000000000000044207346545000017660 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, TypeFamilies #-} module T10156 where import Data.Coerce data Iso a b = Iso (a -> b) (b -> a) coerceIso :: Coercible a b => Iso a b coerceIso = Iso coerce coerce type family F x f :: (Coercible a (F b), Coercible c (F b)) => a -> b -> c f x _ = coerce x ghc-exactprint-0.6.2/tests/examples/ghc80/T10180.hs0000755000000000000000000000073407346545000017661 0ustar0000000000000000{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, EmptyCase #-} module T10180 where newtype Foo = Foo Int type family Bar a type instance Bar Int = Int type family Baz a where Baz Int = Int Baz Char = Int data a :~: b where Refl :: a :~: a absurd0 :: Int :~: Bool -> a absurd0 x = case x of {} absurd1 :: Foo :~: Bool -> a absurd1 x = case x of {} absurd2 :: Bar Int :~: Bool -> a absurd2 x = case x of {} absurd3 :: Baz a :~: Bool -> a absurd3 x = case x of {} ghc-exactprint-0.6.2/tests/examples/ghc80/T10181.hs0000755000000000000000000000003707346545000017656 0ustar0000000000000000module T10181 where t a = t a ghc-exactprint-0.6.2/tests/examples/ghc80/T10182.hs0000755000000000000000000000012107346545000017651 0ustar0000000000000000module T10182 where import T10182a instance Show (a -> b) where show _ = "" ghc-exactprint-0.6.2/tests/examples/ghc80/T10182a.hs0000755000000000000000000000006207346545000020016 0ustar0000000000000000module T10182a where import {-# SOURCE #-} T10182 ghc-exactprint-0.6.2/tests/examples/ghc80/T10184.hs0000755000000000000000000000023107346545000017655 0ustar0000000000000000module T10184 where import Data.Coerce newtype Bar a = Bar (Either a (Bar a)) newtype Age = MkAge Int x :: Bar Age x = coerce (Bar (Left (5 :: Int))) ghc-exactprint-0.6.2/tests/examples/ghc80/T10185.hs0000755000000000000000000000023507346545000017662 0ustar0000000000000000module T10185 where import Data.Coerce import Data.Proxy foo :: (Coercible (a b) (c d), Coercible (c d) (e f)) => Proxy (c d) -> a b -> e f foo _ = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10188.hs0000755000000000000000000000053207346545000017665 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} module T10188 where data Peano = Zero | Succ Peano type family Length (as :: [k]) :: Peano where Length (a : as) = Succ (Length as) Length '[] = Zero type family Length' (as :: [k]) :: Peano where Length' ((:) a as) = Succ (Length' as) Length' '[] = Zero ghc-exactprint-0.6.2/tests/examples/ghc80/T10194.hs0000755000000000000000000000017407346545000017664 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module T10194 where type X = forall a . a comp :: (X -> c) -> (a -> X) -> (a -> c) comp = (.) ghc-exactprint-0.6.2/tests/examples/ghc80/T10195.hs0000755000000000000000000000137407346545000017670 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs, ConstraintKinds, DataKinds, KindSignatures, FlexibleInstances #-} {-# OPTIONS -fno-warn-redundant-constraints #-} module T10195 where import GHC.Exts data Foo m zp r'q = Foo zp data Dict :: Constraint -> * where Dict :: a => Dict a type family BarFamily a b :: Bool class Bar m m' instance (BarFamily m m' ~ 'True) => Bar m m' magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq) magic = undefined getDict :: a -> Dict (Num a) getDict _ = undefined fromScalar :: r -> c m r fromScalar = undefined foo :: (Bar m m') => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq) foo b (Foo sc) = let scinv = fromScalar sc in case getDict scinv of Dict -> magic $ scinv * b ghc-exactprint-0.6.2/tests/examples/ghc80/T10196.hs0000755000000000000000000000030707346545000017664 0ustar0000000000000000module 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ᵣ ghc-exactprint-0.6.2/tests/examples/ghc80/T10215.hs0000755000000000000000000000032307346545000017652 0ustar0000000000000000testF :: Float -> Bool testF x = x == 0 && not (isNegativeZero x) testD :: Double -> Bool testD x = x == 0 && not (isNegativeZero x) main :: IO () main = do print $ testF (-0.0) print $ testD (-0.0) ghc-exactprint-0.6.2/tests/examples/ghc80/T10218.hs0000755000000000000000000000052507346545000017661 0ustar0000000000000000{-# OPTIONS_GHC -feager-blackholing #-} module Main where {-# NOINLINE foo #-} foo :: Bool -> Int -> Int -> Int foo True _ x = 1 foo False _ x = x+1 {-# NOINLINE bar #-} bar :: Int -> (Int,Int) bar x = let y1 = x * 2 y2 = x * 2 in (foo False y1 y2,foo False y2 y1) main = print (fst p + snd p) where p = bar 3 ghc-exactprint-0.6.2/tests/examples/ghc80/T10220B.hs0000755000000000000000000000002507346545000017747 0ustar0000000000000000module T10220B where ghc-exactprint-0.6.2/tests/examples/ghc80/T10226.hs0000755000000000000000000000344207346545000017661 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -- only necessary in 7.10 {-# LANGUAGE FlexibleContexts #-} -- necessary for showFromF' example {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10226 where type family F a type family FInv a -- This definition is accepted in 7.8 without anything extra, but requires -- AllowAmbiguousTypes in 7.10 (this, by itself, is not a problem): showFromF :: (Show a, FInv (F a) ~ a) => F a -> String showFromF fa = undefined -- Consider what happens when we attempt to call `showFromF` at some type b. -- In order to check that this is valid, we have to find an a such that -- -- > b ~ F a /\ Show a /\ FInv (F a) ~ a -- -- Introducing an intermediate variable `x` for the result of `F a` gives us -- -- > b ~ F a /\ Show a /\ FInv x ~ a /\ F a ~ x -- -- Simplifying -- -- > b ~ x /\ Show a /\ FInv x ~ a /\ F a ~ x -- -- Set x := b -- -- > Show a /\ FInv b ~ a /\ F a ~ b -- -- Set a := FInv b -- -- > Show (FInv b) /\ FInv b ~ FInv b /\ F (FInv b) ~ b -- -- Simplifying -- -- > Show (FInv b) /\ F (FInv b) ~ b -- -- Indeed, we can give this definition in 7.8, but not in 7.10: showFromF' :: (Show (FInv b), F (FInv b) ~ b) => b -> String showFromF' = showFromF {------------------------------------------------------------------------------- In 7.10 the definition of showFromF' is not accepted, but it gets stranger. In 7.10 we cannot _call_ showFromF at all, even at a concrete type. Below we try to call it at type b ~ Int. It would need to show > Show (FInv Int) /\ F (FInt Int) ~ Int all of which should easily get resolved, but somehow don't. -------------------------------------------------------------------------------} type instance F Int = Int type instance FInv Int = Int test :: String test = showFromF (0 :: Int) ghc-exactprint-0.6.2/tests/examples/ghc80/T10233.hs0000755000000000000000000000006607346545000017656 0ustar0000000000000000module T10233 where import T10233a( Constraint, Int ) ghc-exactprint-0.6.2/tests/examples/ghc80/T10233a.hs0000755000000000000000000000011607346545000020013 0ustar0000000000000000module T10233a ( module GHC.Exts ) where import GHC.Exts ( Constraint, Int ) ghc-exactprint-0.6.2/tests/examples/ghc80/T10245.hs0000755000000000000000000000040107346545000017652 0ustar0000000000000000f :: Int -> String f n = case n of 0x8000000000000000 -> "yes" _ -> "no" {-# NOINLINE f #-} main = do let string = "0x8000000000000000" let i = read string :: Integer let i' = fromIntegral i :: Int print i print i' print (f i') ghc-exactprint-0.6.2/tests/examples/ghc80/T10246.hs0000755000000000000000000000113607346545000017661 0ustar0000000000000000f1 :: Int -> String f1 n = case n of 0 -> "bar" 0x10000000000000000 -> "foo" _ -> "c" {-# NOINLINE f1 #-} g1 :: Int -> String g1 n = if n == 0 then "bar" else if n == 0x10000000000000000 then "foo" else "c" {-# NOINLINE g1 #-} f2 :: Int -> String f2 n = case n of 0x10000000000000000 -> "foo" 0 -> "bar" _ -> "c" {-# NOINLINE f2 #-} g2 :: Int -> String g2 n = if n == 0x10000000000000000 then "foo" else if n == 0 then "bar" else "c" {-# NOINLINE g2 #-} main = do let i = read "0" :: Int print (f1 i) print (g1 i) print (f2 i) print (g2 i) ghc-exactprint-0.6.2/tests/examples/ghc80/T10251.hs0000755000000000000000000000142407346545000017655 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -O #-} module T10251 where data D = D data E = E class Storable a where poke2 :: a -> E instance Storable D where poke2 = poke2 -- undefined class Foo a where instance Foo D where class (Foo t, Storable t) => FooStorable t where instance FooStorable D where {-# SPECIALIZE instance FooStorable D #-} {-# SPECIALIZE bug :: D -> E #-} bug :: FooStorable t => t -> E bug = poke2 {- sf 9160 # ghc -c -fforce-recomp -Wall B.hs ghc: panic! (the 'impossible' happened) (GHC version 7.10.1 for x86_64-unknown-linux): Template variable unbound in rewrite rule $fFooStorableD_XU [$fFooStorableD_XU] [$fFooStorableD_XU] [] [] Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10263.hs0000755000000000000000000000015107346545000017654 0ustar0000000000000000{-# LANGUAGE RoleAnnotations #-} module T10263 where data Maybe a = AF type role Maybe representational ghc-exactprint-0.6.2/tests/examples/ghc80/T10267.hs0000755000000000000000000000132207346545000017661 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10267 where import Language.Haskell.TH import T10267a [d| i :: a -> a i = _foo j :: a -> a j x = _ |] $(return [ SigD (mkName "k") (ForallT [PlainTV (mkName "a")] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "k") [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []] ]) $(return [ SigD (mkName "l") (ForallT [PlainTV (mkName "a")] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "l") [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []] ]) foo :: a -> a foo x = $varX ghc-exactprint-0.6.2/tests/examples/ghc80/T10267a.hs0000755000000000000000000000016107346545000020022 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10267a where import Language.Haskell.TH varX :: Q Exp varX = [| x |] ghc-exactprint-0.6.2/tests/examples/ghc80/T10279.hs0000755000000000000000000000077207346545000017674 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10279 where import Language.Haskell.TH import Language.Haskell.TH.Syntax -- NB: rts-1.0 is used here because it doesn't change. -- You do need to pick the right version number, otherwise the -- error message doesn't recognize it as a source package ID, -- (This is OK, since it will look obviously wrong when they -- try to find the package in their package database.) blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) ghc-exactprint-0.6.2/tests/examples/ghc80/T10283.hs0000755000000000000000000000133207346545000017660 0ustar0000000000000000{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} {-# LANGUAGE ImpredicativeTypes #-} module T9834 where import Control.Applicative import Data.Functor.Identity type Nat f g = forall a. f a -> g a newtype Comp p q a = Comp (p (q a)) liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a liftOuter pa = Comp (pure <$> pa) runIdComp :: Functor p => Comp p Identity a -> p a runIdComp (Comp p) = runIdentity <$> p wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a wrapIdComp f = runIdComp . f . liftOuter class Applicative p => ApplicativeFix p where afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a afix = wrapIdComp ghc-exactprint-0.6.2/tests/examples/ghc80/T10284.hs0000755000000000000000000000073107346545000017663 0ustar0000000000000000{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-} import Control.Exception a :: Int a = 'a' main :: IO () main = do catch (evaluate a) (\e -> do let err = show (e :: TypeError) putStrLn ("As expected, TypeError: " ++ err) return "") catch (evaluate a) (\e -> do let err = show (e :: ErrorCall) putStrLn ("Something went horribly wrong: " ++ err) return "") ghc-exactprint-0.6.2/tests/examples/ghc80/T10285.hs0000755000000000000000000000030507346545000017661 0ustar0000000000000000module T10285 where import T10285a import Data.Type.Coercion import Data.Coerce oops :: Coercion (N a) (N b) -> a -> b oops Coercion = coerce unsafeCoerce :: a -> b unsafeCoerce = oops coercion ghc-exactprint-0.6.2/tests/examples/ghc80/T10285a.hs0000755000000000000000000000031207346545000020020 0ustar0000000000000000{-# LANGUAGE RoleAnnotations #-} module T10285a (N, coercion) where import Data.Type.Coercion newtype N a = MkN Int type role N representational coercion :: Coercion (N a) (N b) coercion = Coercion ghc-exactprint-0.6.2/tests/examples/ghc80/T10294.hs0000755000000000000000000000012407346545000017660 0ustar0000000000000000module T10294 where import SayAnnNames {-# ANN foo SomeAnn #-} foo :: () foo = () ghc-exactprint-0.6.2/tests/examples/ghc80/T10294a.hs0000755000000000000000000000014007346545000020017 0ustar0000000000000000module T10294a where import SayAnnNames import Data.Data baz :: Constr baz = toConstr SomeAnn ghc-exactprint-0.6.2/tests/examples/ghc80/T10306.hs0000755000000000000000000000061507346545000017657 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies #-} module T10306 where import Language.Haskell.TH import GHC.TypeLits -- Attempting to reify a built-in type family like (+) previously -- caused a crash, because it has no equations $(do x <- reify ''(+) case x of FamilyI (ClosedTypeFamilyD _ _ _ _ []) _ -> return [] _ -> error $ show x ) ghc-exactprint-0.6.2/tests/examples/ghc80/T10318.hs0000755000000000000000000000155407346545000017665 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, UndecidableSuperClasses #-} module T10318 where -- | Product of non-zero elements always non-zero. -- Every integral domain has a field of fractions. -- The field of fractions of any field is itself. class (Frac (Frac a) ~ Frac a, Fractional (Frac a), IntegralDomain (Frac a)) => IntegralDomain a where type Frac a :: * embed :: a -> Frac a instance IntegralDomain Integer where type Frac Integer = Rational embed = fromInteger instance IntegralDomain Rational where type Frac Rational = Rational embed = id g :: IntegralDomain a => a -> a g x = g x h :: a -> Frac a h x = h x -- This is the test function f :: IntegralDomain a => a -> Frac a f x = g (h (h x)) -- Given: IntegralDomain (Frac a) -- Wanted: IntegralDomain (Frac (Frac a)) ghc-exactprint-0.6.2/tests/examples/ghc80/T10322A.hs0000755000000000000000000000007307346545000017754 0ustar0000000000000000module T10322A (a) where {-# NOINLINE a #-} a :: Int a = 3 ghc-exactprint-0.6.2/tests/examples/ghc80/T10322B.hs0000755000000000000000000000007507346545000017757 0ustar0000000000000000module T10322B (b) where import T10322A (a) b :: Int b = a+1 ghc-exactprint-0.6.2/tests/examples/ghc80/T10322C.hs0000755000000000000000000000012007346545000017747 0ustar0000000000000000module T10322C (c) where import T10322A (a) import T10322B (b) c :: Int c = a+b ghc-exactprint-0.6.2/tests/examples/ghc80/T10335.hs0000755000000000000000000000037707346545000017666 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-} module Foo where type X a = (Eq a, Show a) class Eq a => C a b -- HEAD was unable to find the (Eq a) superclass -- for a while in March/April 2015 instance X a => C a [b] ghc-exactprint-0.6.2/tests/examples/ghc80/T10340.hs0000755000000000000000000000045407346545000017656 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module T10340 where import GHC.Exts (Any) class MonadState s m where get :: m s newtype State s a = State (s -> (s, a)) instance MonadState s (State s) where get = State $ \s -> (s, s) foo :: State Any Any foo = get ghc-exactprint-0.6.2/tests/examples/ghc80/T10348.hs0000755000000000000000000000120607346545000017662 0ustar0000000000000000{-# LANGUAGE AutoDeriveTypeable, GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeOperators #-} module T10348 where import GHC.TypeLits import Data.Typeable import Data.Proxy data Foo (n :: Nat) where Hey :: KnownNat n => Foo n deriving instance Show (Foo n) data T t where T :: (Show t, Typeable t) => t -> T t deriving instance Show (T n) hey :: KnownNat n => T (Foo n) hey = T Hey ho :: T (Foo 42) ho = T Hey f1 :: KnownNat a => Proxy a -> TypeRep f1 = typeRep g2 :: KnownSymbol a => Proxy a -> TypeRep g2 = typeRep pEqT :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Maybe (a :~: b) pEqT Proxy Proxy = eqT ghc-exactprint-0.6.2/tests/examples/ghc80/T10351.hs0000755000000000000000000000010307346545000017647 0ustar0000000000000000module T10351 where class C a where op :: a -> () f x = op [x] ghc-exactprint-0.6.2/tests/examples/ghc80/T10359.hs0000755000000000000000000001115607346545000017671 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} module Main( main, boo ) where import Prelude hiding (repeat) boo xs f = (\x -> f x, xs) repeat :: Int -> (a -> a) -> a -> a repeat 1 f x = f x repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x ---- Buggy version ------------------ type Numerical a = (Fractional a, Real a) data Box a = Box { func :: forall dum. (Numerical dum) => dum -> a -> a , obj :: !a } do_step :: (Numerical num) => num -> Box a -> Box a do_step number Box{..} = Box{ obj = func number obj, .. } start :: Box Double start = Box { func = \x y -> realToFrac x + y , obj = 0 } test :: Int -> IO () test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start ---- Driver ----------- main :: IO () main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000 {- ---- No tuple constraint synonym is better ------------------------------------------ data Box2 a = Box2 { func2 :: forall num. (Fractional num, Real num) => num -> a -> a , obj2 :: !a } do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..} start2 :: Box2 Double start2 = Box2 { func2 = \x y -> realToFrac x + y , obj2 = 0 } test2 :: Int -> IO () test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2 ---- Not copying the function field works too --------------------------------------------- do_step3 :: (Numerical num) => num -> Box a -> Box a do_step3 number b@Box{..} = b{ obj = func number obj } test3 :: Int -> IO () test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start ---- But record wildcards are not at fault ------------------------------------------ do_step4 :: (Numerical num) => num -> Box a -> Box a do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f } test4 :: Int -> IO () test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start -} {- First of all, very nice example. Thank you for making it so small and easy to work with. I can see what's happening. The key part is what happens here: {{{ do_step4 :: (Numerical num) => num -> Box a -> Box a do_step4 number Box{ func = f, obj = x} = Box{ func = f, obj = f number x } }}} After elaboration (ie making dictionaries explicit) we get this: {{{ do_step4 dn1 number (Box {func = f, obj = x }) = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f , case dn2 of (f,r) -> r) , obj = f dn1 number x } }}} That's odd! We expected this: {{{ do_step4 dn1 number (Box {func = f, obj = x }) = Box { func = f , obj = f dn1 number x } }}} And indeed, the allocation of all those `\dn2` closures is what is causing the problem. So we are missing this optimisation: {{{ (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r) ===> dn2 }}} If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`. But there are at least three problems: * The tuple transformation above is hard to spot * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different. You might argue that the latter two can be ignored because dictionary arguments are special; indeed we often toy with making them strict. But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from? It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`. GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`). Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`. How does it get those dictionaries? By selecting the components of the `Franctional dum` passed to `f`. If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially. But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint. That would leave us with eta reduction, which is easier. As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work. Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug! -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10361a.hs0000755000000000000000000000074307346545000020023 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} module T10361a where class C1 a where type T1 a type instance T1 a = Char class C2 a where -- equivalent to C1 type T2 a type instance T2 a = Char class C3 a where -- equivalent to C1, C2 type T3 a type instance T3 a = Char data A = B deriving C1 deriving instance C2 A instance C3 A test1 :: T1 A test1 = 'x' test2 :: T2 A test2 = 'x' test3 :: T3 A test3 = 'x' ghc-exactprint-0.6.2/tests/examples/ghc80/T10361b.hs0000755000000000000000000000277407346545000020032 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module T10361b where import GHC.Generics --------------------------------------------------------------------- class Convert a where type Result a type instance Result a = GResult (Rep a) convert :: a -> Result a default convert :: (Generic a, GConvert (Rep a)) => a -> GResult (Rep a) convert x = gconvert (from x) instance Convert Float where type Result Float = Float convert = id instance Convert Int where type Result Int = Int convert = id --------------------------------------------------------------------- class GConvert f where type GResult f gconvert :: f p -> GResult f instance (Convert c) => GConvert (K1 i c) where type GResult (K1 i c) = Result c gconvert (K1 x) = convert x instance (GConvert f) => GConvert (M1 i t f) where type GResult (M1 i t f) = GResult f gconvert (M1 x) = gconvert x instance (GConvert f, GConvert g) => GConvert (f :*: g) where type GResult (f :*: g) = (GResult f, GResult g) gconvert (x :*: y) = (gconvert x, gconvert y) --------------------------------------------------------------------- data Data1 = Data1 Int Float deriving (Generic) instance Convert Data1 val :: (Int, Float) val = convert $ Data1 0 0.0 data Data2 = Data2 Int Float deriving (Generic, Convert) ghc-exactprint-0.6.2/tests/examples/ghc80/T10370.hs0000755000000000000000000013515707346545000017672 0ustar0000000000000000module Out where import Control.Monad (forever) a1 :: IO (); a1 = forever $ putStrLn "a1" a2 :: IO (); a2 = forever $ putStrLn "a2" a3 :: IO (); a3 = forever $ putStrLn "a3" a4 :: IO (); a4 = forever $ putStrLn "a4" a5 :: IO (); a5 = forever $ putStrLn "a5" a6 :: IO (); a6 = forever $ putStrLn "a6" a7 :: IO (); a7 = forever $ putStrLn "a7" a8 :: IO (); a8 = forever $ putStrLn "a8" a9 :: IO (); a9 = forever $ putStrLn "a9" a10 :: IO (); a10 = forever $ putStrLn "a10" a11 :: IO (); a11 = forever $ putStrLn "a11" a12 :: IO (); a12 = forever $ putStrLn "a12" a13 :: IO (); a13 = forever $ putStrLn "a13" a14 :: IO (); a14 = forever $ putStrLn "a14" a15 :: IO (); a15 = forever $ putStrLn "a15" a16 :: IO (); a16 = forever $ putStrLn "a16" a17 :: IO (); a17 = forever $ putStrLn "a17" a18 :: IO (); a18 = forever $ putStrLn "a18" a19 :: IO (); a19 = forever $ putStrLn "a19" a20 :: IO (); a20 = forever $ putStrLn "a20" a21 :: IO (); a21 = forever $ putStrLn "a21" a22 :: IO (); a22 = forever $ putStrLn "a22" a23 :: IO (); a23 = forever $ putStrLn "a23" a24 :: IO (); a24 = forever $ putStrLn "a24" a25 :: IO (); a25 = forever $ putStrLn "a25" a26 :: IO (); a26 = forever $ putStrLn "a26" a27 :: IO (); a27 = forever $ putStrLn "a27" a28 :: IO (); a28 = forever $ putStrLn "a28" a29 :: IO (); a29 = forever $ putStrLn "a29" a30 :: IO (); a30 = forever $ putStrLn "a30" a31 :: IO (); a31 = forever $ putStrLn "a31" a32 :: IO (); a32 = forever $ putStrLn "a32" a33 :: IO (); a33 = forever $ putStrLn "a33" a34 :: IO (); a34 = forever $ putStrLn "a34" a35 :: IO (); a35 = forever $ putStrLn "a35" a36 :: IO (); a36 = forever $ putStrLn "a36" a37 :: IO (); a37 = forever $ putStrLn "a37" a38 :: IO (); a38 = forever $ putStrLn "a38" a39 :: IO (); a39 = forever $ putStrLn "a39" a40 :: IO (); a40 = forever $ putStrLn "a40" a41 :: IO (); a41 = forever $ putStrLn "a41" a42 :: IO (); a42 = forever $ putStrLn "a42" a43 :: IO (); a43 = forever $ putStrLn "a43" a44 :: IO (); a44 = forever $ putStrLn "a44" a45 :: IO (); a45 = forever $ putStrLn "a45" a46 :: IO (); a46 = forever $ putStrLn "a46" a47 :: IO (); a47 = forever $ putStrLn "a47" a48 :: IO (); a48 = forever $ putStrLn "a48" a49 :: IO (); a49 = forever $ putStrLn "a49" a50 :: IO (); a50 = forever $ putStrLn "a50" a51 :: IO (); a51 = forever $ putStrLn "a51" a52 :: IO (); a52 = forever $ putStrLn "a52" a53 :: IO (); a53 = forever $ putStrLn "a53" a54 :: IO (); a54 = forever $ putStrLn "a54" a55 :: IO (); a55 = forever $ putStrLn "a55" a56 :: IO (); a56 = forever $ putStrLn "a56" a57 :: IO (); a57 = forever $ putStrLn "a57" a58 :: IO (); a58 = forever $ putStrLn "a58" a59 :: IO (); a59 = forever $ putStrLn "a59" a60 :: IO (); a60 = forever $ putStrLn "a60" a61 :: IO (); a61 = forever $ putStrLn "a61" a62 :: IO (); a62 = forever $ putStrLn "a62" a63 :: IO (); a63 = forever $ putStrLn "a63" a64 :: IO (); a64 = forever $ putStrLn "a64" a65 :: IO (); a65 = forever $ putStrLn "a65" a66 :: IO (); a66 = forever $ putStrLn "a66" a67 :: IO (); a67 = forever $ putStrLn "a67" a68 :: IO (); a68 = forever $ putStrLn "a68" a69 :: IO (); a69 = forever $ putStrLn "a69" a70 :: IO (); a70 = forever $ putStrLn "a70" a71 :: IO (); a71 = forever $ putStrLn "a71" a72 :: IO (); a72 = forever $ putStrLn "a72" a73 :: IO (); a73 = forever $ putStrLn "a73" a74 :: IO (); a74 = forever $ putStrLn "a74" a75 :: IO (); a75 = forever $ putStrLn "a75" a76 :: IO (); a76 = forever $ putStrLn "a76" a77 :: IO (); a77 = forever $ putStrLn "a77" a78 :: IO (); a78 = forever $ putStrLn "a78" a79 :: IO (); a79 = forever $ putStrLn "a79" a80 :: IO (); a80 = forever $ putStrLn "a80" a81 :: IO (); a81 = forever $ putStrLn "a81" a82 :: IO (); a82 = forever $ putStrLn "a82" a83 :: IO (); a83 = forever $ putStrLn "a83" a84 :: IO (); a84 = forever $ putStrLn "a84" a85 :: IO (); a85 = forever $ putStrLn "a85" a86 :: IO (); a86 = forever $ putStrLn "a86" a87 :: IO (); a87 = forever $ putStrLn "a87" a88 :: IO (); a88 = forever $ putStrLn "a88" a89 :: IO (); a89 = forever $ putStrLn "a89" a90 :: IO (); a90 = forever $ putStrLn "a90" a91 :: IO (); a91 = forever $ putStrLn "a91" a92 :: IO (); a92 = forever $ putStrLn "a92" a93 :: IO (); a93 = forever $ putStrLn "a93" a94 :: IO (); a94 = forever $ putStrLn "a94" a95 :: IO (); a95 = forever $ putStrLn "a95" a96 :: IO (); a96 = forever $ putStrLn "a96" a97 :: IO (); a97 = forever $ putStrLn "a97" a98 :: IO (); a98 = forever $ putStrLn "a98" a99 :: IO (); a99 = forever $ putStrLn "a99" a100 :: IO (); a100 = forever $ putStrLn "a100" a101 :: IO (); a101 = forever $ putStrLn "a101" a102 :: IO (); a102 = forever $ putStrLn "a102" a103 :: IO (); a103 = forever $ putStrLn "a103" a104 :: IO (); a104 = forever $ putStrLn "a104" a105 :: IO (); a105 = forever $ putStrLn "a105" a106 :: IO (); a106 = forever $ putStrLn "a106" a107 :: IO (); a107 = forever $ putStrLn "a107" a108 :: IO (); a108 = forever $ putStrLn "a108" a109 :: IO (); a109 = forever $ putStrLn "a109" a110 :: IO (); a110 = forever $ putStrLn "a110" a111 :: IO (); a111 = forever $ putStrLn "a111" a112 :: IO (); a112 = forever $ putStrLn "a112" a113 :: IO (); a113 = forever $ putStrLn "a113" a114 :: IO (); a114 = forever $ putStrLn "a114" a115 :: IO (); a115 = forever $ putStrLn "a115" a116 :: IO (); a116 = forever $ putStrLn "a116" a117 :: IO (); a117 = forever $ putStrLn "a117" a118 :: IO (); a118 = forever $ putStrLn "a118" a119 :: IO (); a119 = forever $ putStrLn "a119" a120 :: IO (); a120 = forever $ putStrLn "a120" a121 :: IO (); a121 = forever $ putStrLn "a121" a122 :: IO (); a122 = forever $ putStrLn "a122" a123 :: IO (); a123 = forever $ putStrLn "a123" a124 :: IO (); a124 = forever $ putStrLn "a124" a125 :: IO (); a125 = forever $ putStrLn "a125" a126 :: IO (); a126 = forever $ putStrLn "a126" a127 :: IO (); a127 = forever $ putStrLn "a127" a128 :: IO (); a128 = forever $ putStrLn "a128" a129 :: IO (); a129 = forever $ putStrLn "a129" a130 :: IO (); a130 = forever $ putStrLn "a130" a131 :: IO (); a131 = forever $ putStrLn "a131" a132 :: IO (); a132 = forever $ putStrLn "a132" a133 :: IO (); a133 = forever $ putStrLn "a133" a134 :: IO (); a134 = forever $ putStrLn "a134" a135 :: IO (); a135 = forever $ putStrLn "a135" a136 :: IO (); a136 = forever $ putStrLn "a136" a137 :: IO (); a137 = forever $ putStrLn "a137" a138 :: IO (); a138 = forever $ putStrLn "a138" a139 :: IO (); a139 = forever $ putStrLn "a139" a140 :: IO (); a140 = forever $ putStrLn "a140" a141 :: IO (); a141 = forever $ putStrLn "a141" a142 :: IO (); a142 = forever $ putStrLn "a142" a143 :: IO (); a143 = forever $ putStrLn "a143" a144 :: IO (); a144 = forever $ putStrLn "a144" a145 :: IO (); a145 = forever $ putStrLn "a145" a146 :: IO (); a146 = forever $ putStrLn "a146" a147 :: IO (); a147 = forever $ putStrLn "a147" a148 :: IO (); a148 = forever $ putStrLn "a148" a149 :: IO (); a149 = forever $ putStrLn "a149" a150 :: IO (); a150 = forever $ putStrLn "a150" a151 :: IO (); a151 = forever $ putStrLn "a151" a152 :: IO (); a152 = forever $ putStrLn "a152" a153 :: IO (); a153 = forever $ putStrLn "a153" a154 :: IO (); a154 = forever $ putStrLn "a154" a155 :: IO (); a155 = forever $ putStrLn "a155" a156 :: IO (); a156 = forever $ putStrLn "a156" a157 :: IO (); a157 = forever $ putStrLn "a157" a158 :: IO (); a158 = forever $ putStrLn "a158" a159 :: IO (); a159 = forever $ putStrLn "a159" a160 :: IO (); a160 = forever $ putStrLn "a160" a161 :: IO (); a161 = forever $ putStrLn "a161" a162 :: IO (); a162 = forever $ putStrLn "a162" a163 :: IO (); a163 = forever $ putStrLn "a163" a164 :: IO (); a164 = forever $ putStrLn "a164" a165 :: IO (); a165 = forever $ putStrLn "a165" a166 :: IO (); a166 = forever $ putStrLn "a166" a167 :: IO (); a167 = forever $ putStrLn "a167" a168 :: IO (); a168 = forever $ putStrLn "a168" a169 :: IO (); a169 = forever $ putStrLn "a169" a170 :: IO (); a170 = forever $ putStrLn "a170" a171 :: IO (); a171 = forever $ putStrLn "a171" a172 :: IO (); a172 = forever $ putStrLn "a172" a173 :: IO (); a173 = forever $ putStrLn "a173" a174 :: IO (); a174 = forever $ putStrLn "a174" a175 :: IO (); a175 = forever $ putStrLn "a175" a176 :: IO (); a176 = forever $ putStrLn "a176" a177 :: IO (); a177 = forever $ putStrLn "a177" a178 :: IO (); a178 = forever $ putStrLn "a178" a179 :: IO (); a179 = forever $ putStrLn "a179" a180 :: IO (); a180 = forever $ putStrLn "a180" a181 :: IO (); a181 = forever $ putStrLn "a181" a182 :: IO (); a182 = forever $ putStrLn "a182" a183 :: IO (); a183 = forever $ putStrLn "a183" a184 :: IO (); a184 = forever $ putStrLn "a184" a185 :: IO (); a185 = forever $ putStrLn "a185" a186 :: IO (); a186 = forever $ putStrLn "a186" a187 :: IO (); a187 = forever $ putStrLn "a187" a188 :: IO (); a188 = forever $ putStrLn "a188" a189 :: IO (); a189 = forever $ putStrLn "a189" a190 :: IO (); a190 = forever $ putStrLn "a190" a191 :: IO (); a191 = forever $ putStrLn "a191" a192 :: IO (); a192 = forever $ putStrLn "a192" a193 :: IO (); a193 = forever $ putStrLn "a193" a194 :: IO (); a194 = forever $ putStrLn "a194" a195 :: IO (); a195 = forever $ putStrLn "a195" a196 :: IO (); a196 = forever $ putStrLn "a196" a197 :: IO (); a197 = forever $ putStrLn "a197" a198 :: IO (); a198 = forever $ putStrLn "a198" a199 :: IO (); a199 = forever $ putStrLn "a199" a200 :: IO (); a200 = forever $ putStrLn "a200" a201 :: IO (); a201 = forever $ putStrLn "a201" a202 :: IO (); a202 = forever $ putStrLn "a202" a203 :: IO (); a203 = forever $ putStrLn "a203" a204 :: IO (); a204 = forever $ putStrLn "a204" a205 :: IO (); a205 = forever $ putStrLn "a205" a206 :: IO (); a206 = forever $ putStrLn "a206" a207 :: IO (); a207 = forever $ putStrLn "a207" a208 :: IO (); a208 = forever $ putStrLn "a208" a209 :: IO (); a209 = forever $ putStrLn "a209" a210 :: IO (); a210 = forever $ putStrLn "a210" a211 :: IO (); a211 = forever $ putStrLn "a211" a212 :: IO (); a212 = forever $ putStrLn "a212" a213 :: IO (); a213 = forever $ putStrLn "a213" a214 :: IO (); a214 = forever $ putStrLn "a214" a215 :: IO (); a215 = forever $ putStrLn "a215" a216 :: IO (); a216 = forever $ putStrLn "a216" a217 :: IO (); a217 = forever $ putStrLn "a217" a218 :: IO (); a218 = forever $ putStrLn "a218" a219 :: IO (); a219 = forever $ putStrLn "a219" a220 :: IO (); a220 = forever $ putStrLn "a220" a221 :: IO (); a221 = forever $ putStrLn "a221" a222 :: IO (); a222 = forever $ putStrLn "a222" a223 :: IO (); a223 = forever $ putStrLn "a223" a224 :: IO (); a224 = forever $ putStrLn "a224" a225 :: IO (); a225 = forever $ putStrLn "a225" a226 :: IO (); a226 = forever $ putStrLn "a226" a227 :: IO (); a227 = forever $ putStrLn "a227" a228 :: IO (); a228 = forever $ putStrLn "a228" a229 :: IO (); a229 = forever $ putStrLn "a229" a230 :: IO (); a230 = forever $ putStrLn "a230" a231 :: IO (); a231 = forever $ putStrLn "a231" a232 :: IO (); a232 = forever $ putStrLn "a232" a233 :: IO (); a233 = forever $ putStrLn "a233" a234 :: IO (); a234 = forever $ putStrLn "a234" a235 :: IO (); a235 = forever $ putStrLn "a235" a236 :: IO (); a236 = forever $ putStrLn "a236" a237 :: IO (); a237 = forever $ putStrLn "a237" a238 :: IO (); a238 = forever $ putStrLn "a238" a239 :: IO (); a239 = forever $ putStrLn "a239" a240 :: IO (); a240 = forever $ putStrLn "a240" a241 :: IO (); a241 = forever $ putStrLn "a241" a242 :: IO (); a242 = forever $ putStrLn "a242" a243 :: IO (); a243 = forever $ putStrLn "a243" a244 :: IO (); a244 = forever $ putStrLn "a244" a245 :: IO (); a245 = forever $ putStrLn "a245" a246 :: IO (); a246 = forever $ putStrLn "a246" a247 :: IO (); a247 = forever $ putStrLn "a247" a248 :: IO (); a248 = forever $ putStrLn "a248" a249 :: IO (); a249 = forever $ putStrLn "a249" a250 :: IO (); a250 = forever $ putStrLn "a250" a251 :: IO (); a251 = forever $ putStrLn "a251" a252 :: IO (); a252 = forever $ putStrLn "a252" a253 :: IO (); a253 = forever $ putStrLn "a253" a254 :: IO (); a254 = forever $ putStrLn "a254" a255 :: IO (); a255 = forever $ putStrLn "a255" a256 :: IO (); a256 = forever $ putStrLn "a256" a257 :: IO (); a257 = forever $ putStrLn "a257" a258 :: IO (); a258 = forever $ putStrLn "a258" a259 :: IO (); a259 = forever $ putStrLn "a259" a260 :: IO (); a260 = forever $ putStrLn "a260" a261 :: IO (); a261 = forever $ putStrLn "a261" a262 :: IO (); a262 = forever $ putStrLn "a262" a263 :: IO (); a263 = forever $ putStrLn "a263" a264 :: IO (); a264 = forever $ putStrLn "a264" a265 :: IO (); a265 = forever $ putStrLn "a265" a266 :: IO (); a266 = forever $ putStrLn "a266" a267 :: IO (); a267 = forever $ putStrLn "a267" a268 :: IO (); a268 = forever $ putStrLn "a268" a269 :: IO (); a269 = forever $ putStrLn "a269" a270 :: IO (); a270 = forever $ putStrLn "a270" a271 :: IO (); a271 = forever $ putStrLn "a271" a272 :: IO (); a272 = forever $ putStrLn "a272" a273 :: IO (); a273 = forever $ putStrLn "a273" a274 :: IO (); a274 = forever $ putStrLn "a274" a275 :: IO (); a275 = forever $ putStrLn "a275" a276 :: IO (); a276 = forever $ putStrLn "a276" a277 :: IO (); a277 = forever $ putStrLn "a277" a278 :: IO (); a278 = forever $ putStrLn "a278" a279 :: IO (); a279 = forever $ putStrLn "a279" a280 :: IO (); a280 = forever $ putStrLn "a280" a281 :: IO (); a281 = forever $ putStrLn "a281" a282 :: IO (); a282 = forever $ putStrLn "a282" a283 :: IO (); a283 = forever $ putStrLn "a283" a284 :: IO (); a284 = forever $ putStrLn "a284" a285 :: IO (); a285 = forever $ putStrLn "a285" a286 :: IO (); a286 = forever $ putStrLn "a286" a287 :: IO (); a287 = forever $ putStrLn "a287" a288 :: IO (); a288 = forever $ putStrLn "a288" a289 :: IO (); a289 = forever $ putStrLn "a289" a290 :: IO (); a290 = forever $ putStrLn "a290" a291 :: IO (); a291 = forever $ putStrLn "a291" a292 :: IO (); a292 = forever $ putStrLn "a292" a293 :: IO (); a293 = forever $ putStrLn "a293" a294 :: IO (); a294 = forever $ putStrLn "a294" a295 :: IO (); a295 = forever $ putStrLn "a295" a296 :: IO (); a296 = forever $ putStrLn "a296" a297 :: IO (); a297 = forever $ putStrLn "a297" a298 :: IO (); a298 = forever $ putStrLn "a298" a299 :: IO (); a299 = forever $ putStrLn "a299" a300 :: IO (); a300 = forever $ putStrLn "a300" a301 :: IO (); a301 = forever $ putStrLn "a301" a302 :: IO (); a302 = forever $ putStrLn "a302" a303 :: IO (); a303 = forever $ putStrLn "a303" a304 :: IO (); a304 = forever $ putStrLn "a304" a305 :: IO (); a305 = forever $ putStrLn "a305" a306 :: IO (); a306 = forever $ putStrLn "a306" a307 :: IO (); a307 = forever $ putStrLn "a307" a308 :: IO (); a308 = forever $ putStrLn "a308" a309 :: IO (); a309 = forever $ putStrLn "a309" a310 :: IO (); a310 = forever $ putStrLn "a310" a311 :: IO (); a311 = forever $ putStrLn "a311" a312 :: IO (); a312 = forever $ putStrLn "a312" a313 :: IO (); a313 = forever $ putStrLn "a313" a314 :: IO (); a314 = forever $ putStrLn "a314" a315 :: IO (); a315 = forever $ putStrLn "a315" a316 :: IO (); a316 = forever $ putStrLn "a316" a317 :: IO (); a317 = forever $ putStrLn "a317" a318 :: IO (); a318 = forever $ putStrLn "a318" a319 :: IO (); a319 = forever $ putStrLn "a319" a320 :: IO (); a320 = forever $ putStrLn "a320" a321 :: IO (); a321 = forever $ putStrLn "a321" a322 :: IO (); a322 = forever $ putStrLn "a322" a323 :: IO (); a323 = forever $ putStrLn "a323" a324 :: IO (); a324 = forever $ putStrLn "a324" a325 :: IO (); a325 = forever $ putStrLn "a325" a326 :: IO (); a326 = forever $ putStrLn "a326" a327 :: IO (); a327 = forever $ putStrLn "a327" a328 :: IO (); a328 = forever $ putStrLn "a328" a329 :: IO (); a329 = forever $ putStrLn "a329" a330 :: IO (); a330 = forever $ putStrLn "a330" a331 :: IO (); a331 = forever $ putStrLn "a331" a332 :: IO (); a332 = forever $ putStrLn "a332" a333 :: IO (); a333 = forever $ putStrLn "a333" a334 :: IO (); a334 = forever $ putStrLn "a334" a335 :: IO (); a335 = forever $ putStrLn "a335" a336 :: IO (); a336 = forever $ putStrLn "a336" a337 :: IO (); a337 = forever $ putStrLn "a337" a338 :: IO (); a338 = forever $ putStrLn "a338" a339 :: IO (); a339 = forever $ putStrLn "a339" a340 :: IO (); a340 = forever $ putStrLn "a340" a341 :: IO (); a341 = forever $ putStrLn "a341" a342 :: IO (); a342 = forever $ putStrLn "a342" a343 :: IO (); a343 = forever $ putStrLn "a343" a344 :: IO (); a344 = forever $ putStrLn "a344" a345 :: IO (); a345 = forever $ putStrLn "a345" a346 :: IO (); a346 = forever $ putStrLn "a346" a347 :: IO (); a347 = forever $ putStrLn "a347" a348 :: IO (); a348 = forever $ putStrLn "a348" a349 :: IO (); a349 = forever $ putStrLn "a349" a350 :: IO (); a350 = forever $ putStrLn "a350" a351 :: IO (); a351 = forever $ putStrLn "a351" a352 :: IO (); a352 = forever $ putStrLn "a352" a353 :: IO (); a353 = forever $ putStrLn "a353" a354 :: IO (); a354 = forever $ putStrLn "a354" a355 :: IO (); a355 = forever $ putStrLn "a355" a356 :: IO (); a356 = forever $ putStrLn "a356" a357 :: IO (); a357 = forever $ putStrLn "a357" a358 :: IO (); a358 = forever $ putStrLn "a358" a359 :: IO (); a359 = forever $ putStrLn "a359" a360 :: IO (); a360 = forever $ putStrLn "a360" a361 :: IO (); a361 = forever $ putStrLn "a361" a362 :: IO (); a362 = forever $ putStrLn "a362" a363 :: IO (); a363 = forever $ putStrLn "a363" a364 :: IO (); a364 = forever $ putStrLn "a364" a365 :: IO (); a365 = forever $ putStrLn "a365" a366 :: IO (); a366 = forever $ putStrLn "a366" a367 :: IO (); a367 = forever $ putStrLn "a367" a368 :: IO (); a368 = forever $ putStrLn "a368" a369 :: IO (); a369 = forever $ putStrLn "a369" a370 :: IO (); a370 = forever $ putStrLn "a370" a371 :: IO (); a371 = forever $ putStrLn "a371" a372 :: IO (); a372 = forever $ putStrLn "a372" a373 :: IO (); a373 = forever $ putStrLn "a373" a374 :: IO (); a374 = forever $ putStrLn "a374" a375 :: IO (); a375 = forever $ putStrLn "a375" a376 :: IO (); a376 = forever $ putStrLn "a376" a377 :: IO (); a377 = forever $ putStrLn "a377" a378 :: IO (); a378 = forever $ putStrLn "a378" a379 :: IO (); a379 = forever $ putStrLn "a379" a380 :: IO (); a380 = forever $ putStrLn "a380" a381 :: IO (); a381 = forever $ putStrLn "a381" a382 :: IO (); a382 = forever $ putStrLn "a382" a383 :: IO (); a383 = forever $ putStrLn "a383" a384 :: IO (); a384 = forever $ putStrLn "a384" a385 :: IO (); a385 = forever $ putStrLn "a385" a386 :: IO (); a386 = forever $ putStrLn "a386" a387 :: IO (); a387 = forever $ putStrLn "a387" a388 :: IO (); a388 = forever $ putStrLn "a388" a389 :: IO (); a389 = forever $ putStrLn "a389" a390 :: IO (); a390 = forever $ putStrLn "a390" a391 :: IO (); a391 = forever $ putStrLn "a391" a392 :: IO (); a392 = forever $ putStrLn "a392" a393 :: IO (); a393 = forever $ putStrLn "a393" a394 :: IO (); a394 = forever $ putStrLn "a394" a395 :: IO (); a395 = forever $ putStrLn "a395" a396 :: IO (); a396 = forever $ putStrLn "a396" a397 :: IO (); a397 = forever $ putStrLn "a397" a398 :: IO (); a398 = forever $ putStrLn "a398" a399 :: IO (); a399 = forever $ putStrLn "a399" a400 :: IO (); a400 = forever $ putStrLn "a400" a401 :: IO (); a401 = forever $ putStrLn "a401" a402 :: IO (); a402 = forever $ putStrLn "a402" a403 :: IO (); a403 = forever $ putStrLn "a403" a404 :: IO (); a404 = forever $ putStrLn "a404" a405 :: IO (); a405 = forever $ putStrLn "a405" a406 :: IO (); a406 = forever $ putStrLn "a406" a407 :: IO (); a407 = forever $ putStrLn "a407" a408 :: IO (); a408 = forever $ putStrLn "a408" a409 :: IO (); a409 = forever $ putStrLn "a409" a410 :: IO (); a410 = forever $ putStrLn "a410" a411 :: IO (); a411 = forever $ putStrLn "a411" a412 :: IO (); a412 = forever $ putStrLn "a412" a413 :: IO (); a413 = forever $ putStrLn "a413" a414 :: IO (); a414 = forever $ putStrLn "a414" a415 :: IO (); a415 = forever $ putStrLn "a415" a416 :: IO (); a416 = forever $ putStrLn "a416" a417 :: IO (); a417 = forever $ putStrLn "a417" a418 :: IO (); a418 = forever $ putStrLn "a418" a419 :: IO (); a419 = forever $ putStrLn "a419" a420 :: IO (); a420 = forever $ putStrLn "a420" a421 :: IO (); a421 = forever $ putStrLn "a421" a422 :: IO (); a422 = forever $ putStrLn "a422" a423 :: IO (); a423 = forever $ putStrLn "a423" a424 :: IO (); a424 = forever $ putStrLn "a424" a425 :: IO (); a425 = forever $ putStrLn "a425" a426 :: IO (); a426 = forever $ putStrLn "a426" a427 :: IO (); a427 = forever $ putStrLn "a427" a428 :: IO (); a428 = forever $ putStrLn "a428" a429 :: IO (); a429 = forever $ putStrLn "a429" a430 :: IO (); a430 = forever $ putStrLn "a430" a431 :: IO (); a431 = forever $ putStrLn "a431" a432 :: IO (); a432 = forever $ putStrLn "a432" a433 :: IO (); a433 = forever $ putStrLn "a433" a434 :: IO (); a434 = forever $ putStrLn "a434" a435 :: IO (); a435 = forever $ putStrLn "a435" a436 :: IO (); a436 = forever $ putStrLn "a436" a437 :: IO (); a437 = forever $ putStrLn "a437" a438 :: IO (); a438 = forever $ putStrLn "a438" a439 :: IO (); a439 = forever $ putStrLn "a439" a440 :: IO (); a440 = forever $ putStrLn "a440" a441 :: IO (); a441 = forever $ putStrLn "a441" a442 :: IO (); a442 = forever $ putStrLn "a442" a443 :: IO (); a443 = forever $ putStrLn "a443" a444 :: IO (); a444 = forever $ putStrLn "a444" a445 :: IO (); a445 = forever $ putStrLn "a445" a446 :: IO (); a446 = forever $ putStrLn "a446" a447 :: IO (); a447 = forever $ putStrLn "a447" a448 :: IO (); a448 = forever $ putStrLn "a448" a449 :: IO (); a449 = forever $ putStrLn "a449" a450 :: IO (); a450 = forever $ putStrLn "a450" a451 :: IO (); a451 = forever $ putStrLn "a451" a452 :: IO (); a452 = forever $ putStrLn "a452" a453 :: IO (); a453 = forever $ putStrLn "a453" a454 :: IO (); a454 = forever $ putStrLn "a454" a455 :: IO (); a455 = forever $ putStrLn "a455" a456 :: IO (); a456 = forever $ putStrLn "a456" a457 :: IO (); a457 = forever $ putStrLn "a457" a458 :: IO (); a458 = forever $ putStrLn "a458" a459 :: IO (); a459 = forever $ putStrLn "a459" a460 :: IO (); a460 = forever $ putStrLn "a460" a461 :: IO (); a461 = forever $ putStrLn "a461" a462 :: IO (); a462 = forever $ putStrLn "a462" a463 :: IO (); a463 = forever $ putStrLn "a463" a464 :: IO (); a464 = forever $ putStrLn "a464" a465 :: IO (); a465 = forever $ putStrLn "a465" a466 :: IO (); a466 = forever $ putStrLn "a466" a467 :: IO (); a467 = forever $ putStrLn "a467" a468 :: IO (); a468 = forever $ putStrLn "a468" a469 :: IO (); a469 = forever $ putStrLn "a469" a470 :: IO (); a470 = forever $ putStrLn "a470" a471 :: IO (); a471 = forever $ putStrLn "a471" a472 :: IO (); a472 = forever $ putStrLn "a472" a473 :: IO (); a473 = forever $ putStrLn "a473" a474 :: IO (); a474 = forever $ putStrLn "a474" a475 :: IO (); a475 = forever $ putStrLn "a475" a476 :: IO (); a476 = forever $ putStrLn "a476" a477 :: IO (); a477 = forever $ putStrLn "a477" a478 :: IO (); a478 = forever $ putStrLn "a478" a479 :: IO (); a479 = forever $ putStrLn "a479" a480 :: IO (); a480 = forever $ putStrLn "a480" a481 :: IO (); a481 = forever $ putStrLn "a481" a482 :: IO (); a482 = forever $ putStrLn "a482" a483 :: IO (); a483 = forever $ putStrLn "a483" a484 :: IO (); a484 = forever $ putStrLn "a484" a485 :: IO (); a485 = forever $ putStrLn "a485" a486 :: IO (); a486 = forever $ putStrLn "a486" a487 :: IO (); a487 = forever $ putStrLn "a487" a488 :: IO (); a488 = forever $ putStrLn "a488" a489 :: IO (); a489 = forever $ putStrLn "a489" a490 :: IO (); a490 = forever $ putStrLn "a490" a491 :: IO (); a491 = forever $ putStrLn "a491" a492 :: IO (); a492 = forever $ putStrLn "a492" a493 :: IO (); a493 = forever $ putStrLn "a493" a494 :: IO (); a494 = forever $ putStrLn "a494" a495 :: IO (); a495 = forever $ putStrLn "a495" a496 :: IO (); a496 = forever $ putStrLn "a496" a497 :: IO (); a497 = forever $ putStrLn "a497" a498 :: IO (); a498 = forever $ putStrLn "a498" a499 :: IO (); a499 = forever $ putStrLn "a499" a500 :: IO (); a500 = forever $ putStrLn "a500" a501 :: IO (); a501 = forever $ putStrLn "a501" a502 :: IO (); a502 = forever $ putStrLn "a502" a503 :: IO (); a503 = forever $ putStrLn "a503" a504 :: IO (); a504 = forever $ putStrLn "a504" a505 :: IO (); a505 = forever $ putStrLn "a505" a506 :: IO (); a506 = forever $ putStrLn "a506" a507 :: IO (); a507 = forever $ putStrLn "a507" a508 :: IO (); a508 = forever $ putStrLn "a508" a509 :: IO (); a509 = forever $ putStrLn "a509" a510 :: IO (); a510 = forever $ putStrLn "a510" a511 :: IO (); a511 = forever $ putStrLn "a511" a512 :: IO (); a512 = forever $ putStrLn "a512" a513 :: IO (); a513 = forever $ putStrLn "a513" a514 :: IO (); a514 = forever $ putStrLn "a514" a515 :: IO (); a515 = forever $ putStrLn "a515" a516 :: IO (); a516 = forever $ putStrLn "a516" a517 :: IO (); a517 = forever $ putStrLn "a517" a518 :: IO (); a518 = forever $ putStrLn "a518" a519 :: IO (); a519 = forever $ putStrLn "a519" a520 :: IO (); a520 = forever $ putStrLn "a520" a521 :: IO (); a521 = forever $ putStrLn "a521" a522 :: IO (); a522 = forever $ putStrLn "a522" a523 :: IO (); a523 = forever $ putStrLn "a523" a524 :: IO (); a524 = forever $ putStrLn "a524" a525 :: IO (); a525 = forever $ putStrLn "a525" a526 :: IO (); a526 = forever $ putStrLn "a526" a527 :: IO (); a527 = forever $ putStrLn "a527" a528 :: IO (); a528 = forever $ putStrLn "a528" a529 :: IO (); a529 = forever $ putStrLn "a529" a530 :: IO (); a530 = forever $ putStrLn "a530" a531 :: IO (); a531 = forever $ putStrLn "a531" a532 :: IO (); a532 = forever $ putStrLn "a532" a533 :: IO (); a533 = forever $ putStrLn "a533" a534 :: IO (); a534 = forever $ putStrLn "a534" a535 :: IO (); a535 = forever $ putStrLn "a535" a536 :: IO (); a536 = forever $ putStrLn "a536" a537 :: IO (); a537 = forever $ putStrLn "a537" a538 :: IO (); a538 = forever $ putStrLn "a538" a539 :: IO (); a539 = forever $ putStrLn "a539" a540 :: IO (); a540 = forever $ putStrLn "a540" a541 :: IO (); a541 = forever $ putStrLn "a541" a542 :: IO (); a542 = forever $ putStrLn "a542" a543 :: IO (); a543 = forever $ putStrLn "a543" a544 :: IO (); a544 = forever $ putStrLn "a544" a545 :: IO (); a545 = forever $ putStrLn "a545" a546 :: IO (); a546 = forever $ putStrLn "a546" a547 :: IO (); a547 = forever $ putStrLn "a547" a548 :: IO (); a548 = forever $ putStrLn "a548" a549 :: IO (); a549 = forever $ putStrLn "a549" a550 :: IO (); a550 = forever $ putStrLn "a550" a551 :: IO (); a551 = forever $ putStrLn "a551" a552 :: IO (); a552 = forever $ putStrLn "a552" a553 :: IO (); a553 = forever $ putStrLn "a553" a554 :: IO (); a554 = forever $ putStrLn "a554" a555 :: IO (); a555 = forever $ putStrLn "a555" a556 :: IO (); a556 = forever $ putStrLn "a556" a557 :: IO (); a557 = forever $ putStrLn "a557" a558 :: IO (); a558 = forever $ putStrLn "a558" a559 :: IO (); a559 = forever $ putStrLn "a559" a560 :: IO (); a560 = forever $ putStrLn "a560" a561 :: IO (); a561 = forever $ putStrLn "a561" a562 :: IO (); a562 = forever $ putStrLn "a562" a563 :: IO (); a563 = forever $ putStrLn "a563" a564 :: IO (); a564 = forever $ putStrLn "a564" a565 :: IO (); a565 = forever $ putStrLn "a565" a566 :: IO (); a566 = forever $ putStrLn "a566" a567 :: IO (); a567 = forever $ putStrLn "a567" a568 :: IO (); a568 = forever $ putStrLn "a568" a569 :: IO (); a569 = forever $ putStrLn "a569" a570 :: IO (); a570 = forever $ putStrLn "a570" a571 :: IO (); a571 = forever $ putStrLn "a571" a572 :: IO (); a572 = forever $ putStrLn "a572" a573 :: IO (); a573 = forever $ putStrLn "a573" a574 :: IO (); a574 = forever $ putStrLn "a574" a575 :: IO (); a575 = forever $ putStrLn "a575" a576 :: IO (); a576 = forever $ putStrLn "a576" a577 :: IO (); a577 = forever $ putStrLn "a577" a578 :: IO (); a578 = forever $ putStrLn "a578" a579 :: IO (); a579 = forever $ putStrLn "a579" a580 :: IO (); a580 = forever $ putStrLn "a580" a581 :: IO (); a581 = forever $ putStrLn "a581" a582 :: IO (); a582 = forever $ putStrLn "a582" a583 :: IO (); a583 = forever $ putStrLn "a583" a584 :: IO (); a584 = forever $ putStrLn "a584" a585 :: IO (); a585 = forever $ putStrLn "a585" a586 :: IO (); a586 = forever $ putStrLn "a586" a587 :: IO (); a587 = forever $ putStrLn "a587" a588 :: IO (); a588 = forever $ putStrLn "a588" a589 :: IO (); a589 = forever $ putStrLn "a589" a590 :: IO (); a590 = forever $ putStrLn "a590" a591 :: IO (); a591 = forever $ putStrLn "a591" a592 :: IO (); a592 = forever $ putStrLn "a592" a593 :: IO (); a593 = forever $ putStrLn "a593" a594 :: IO (); a594 = forever $ putStrLn "a594" a595 :: IO (); a595 = forever $ putStrLn "a595" a596 :: IO (); a596 = forever $ putStrLn "a596" a597 :: IO (); a597 = forever $ putStrLn "a597" a598 :: IO (); a598 = forever $ putStrLn "a598" a599 :: IO (); a599 = forever $ putStrLn "a599" a600 :: IO (); a600 = forever $ putStrLn "a600" a601 :: IO (); a601 = forever $ putStrLn "a601" a602 :: IO (); a602 = forever $ putStrLn "a602" a603 :: IO (); a603 = forever $ putStrLn "a603" a604 :: IO (); a604 = forever $ putStrLn "a604" a605 :: IO (); a605 = forever $ putStrLn "a605" a606 :: IO (); a606 = forever $ putStrLn "a606" a607 :: IO (); a607 = forever $ putStrLn "a607" a608 :: IO (); a608 = forever $ putStrLn "a608" a609 :: IO (); a609 = forever $ putStrLn "a609" a610 :: IO (); a610 = forever $ putStrLn "a610" a611 :: IO (); a611 = forever $ putStrLn "a611" a612 :: IO (); a612 = forever $ putStrLn "a612" a613 :: IO (); a613 = forever $ putStrLn "a613" a614 :: IO (); a614 = forever $ putStrLn "a614" a615 :: IO (); a615 = forever $ putStrLn "a615" a616 :: IO (); a616 = forever $ putStrLn "a616" a617 :: IO (); a617 = forever $ putStrLn "a617" a618 :: IO (); a618 = forever $ putStrLn "a618" a619 :: IO (); a619 = forever $ putStrLn "a619" a620 :: IO (); a620 = forever $ putStrLn "a620" a621 :: IO (); a621 = forever $ putStrLn "a621" a622 :: IO (); a622 = forever $ putStrLn "a622" a623 :: IO (); a623 = forever $ putStrLn "a623" a624 :: IO (); a624 = forever $ putStrLn "a624" a625 :: IO (); a625 = forever $ putStrLn "a625" a626 :: IO (); a626 = forever $ putStrLn "a626" a627 :: IO (); a627 = forever $ putStrLn "a627" a628 :: IO (); a628 = forever $ putStrLn "a628" a629 :: IO (); a629 = forever $ putStrLn "a629" a630 :: IO (); a630 = forever $ putStrLn "a630" a631 :: IO (); a631 = forever $ putStrLn "a631" a632 :: IO (); a632 = forever $ putStrLn "a632" a633 :: IO (); a633 = forever $ putStrLn "a633" a634 :: IO (); a634 = forever $ putStrLn "a634" a635 :: IO (); a635 = forever $ putStrLn "a635" a636 :: IO (); a636 = forever $ putStrLn "a636" a637 :: IO (); a637 = forever $ putStrLn "a637" a638 :: IO (); a638 = forever $ putStrLn "a638" a639 :: IO (); a639 = forever $ putStrLn "a639" a640 :: IO (); a640 = forever $ putStrLn "a640" a641 :: IO (); a641 = forever $ putStrLn "a641" a642 :: IO (); a642 = forever $ putStrLn "a642" a643 :: IO (); a643 = forever $ putStrLn "a643" a644 :: IO (); a644 = forever $ putStrLn "a644" a645 :: IO (); a645 = forever $ putStrLn "a645" a646 :: IO (); a646 = forever $ putStrLn "a646" a647 :: IO (); a647 = forever $ putStrLn "a647" a648 :: IO (); a648 = forever $ putStrLn "a648" a649 :: IO (); a649 = forever $ putStrLn "a649" a650 :: IO (); a650 = forever $ putStrLn "a650" a651 :: IO (); a651 = forever $ putStrLn "a651" a652 :: IO (); a652 = forever $ putStrLn "a652" a653 :: IO (); a653 = forever $ putStrLn "a653" a654 :: IO (); a654 = forever $ putStrLn "a654" a655 :: IO (); a655 = forever $ putStrLn "a655" a656 :: IO (); a656 = forever $ putStrLn "a656" a657 :: IO (); a657 = forever $ putStrLn "a657" a658 :: IO (); a658 = forever $ putStrLn "a658" a659 :: IO (); a659 = forever $ putStrLn "a659" a660 :: IO (); a660 = forever $ putStrLn "a660" a661 :: IO (); a661 = forever $ putStrLn "a661" a662 :: IO (); a662 = forever $ putStrLn "a662" a663 :: IO (); a663 = forever $ putStrLn "a663" a664 :: IO (); a664 = forever $ putStrLn "a664" a665 :: IO (); a665 = forever $ putStrLn "a665" a666 :: IO (); a666 = forever $ putStrLn "a666" a667 :: IO (); a667 = forever $ putStrLn "a667" a668 :: IO (); a668 = forever $ putStrLn "a668" a669 :: IO (); a669 = forever $ putStrLn "a669" a670 :: IO (); a670 = forever $ putStrLn "a670" a671 :: IO (); a671 = forever $ putStrLn "a671" a672 :: IO (); a672 = forever $ putStrLn "a672" a673 :: IO (); a673 = forever $ putStrLn "a673" a674 :: IO (); a674 = forever $ putStrLn "a674" a675 :: IO (); a675 = forever $ putStrLn "a675" a676 :: IO (); a676 = forever $ putStrLn "a676" a677 :: IO (); a677 = forever $ putStrLn "a677" a678 :: IO (); a678 = forever $ putStrLn "a678" a679 :: IO (); a679 = forever $ putStrLn "a679" a680 :: IO (); a680 = forever $ putStrLn "a680" a681 :: IO (); a681 = forever $ putStrLn "a681" a682 :: IO (); a682 = forever $ putStrLn "a682" a683 :: IO (); a683 = forever $ putStrLn "a683" a684 :: IO (); a684 = forever $ putStrLn "a684" a685 :: IO (); a685 = forever $ putStrLn "a685" a686 :: IO (); a686 = forever $ putStrLn "a686" a687 :: IO (); a687 = forever $ putStrLn "a687" a688 :: IO (); a688 = forever $ putStrLn "a688" a689 :: IO (); a689 = forever $ putStrLn "a689" a690 :: IO (); a690 = forever $ putStrLn "a690" a691 :: IO (); a691 = forever $ putStrLn "a691" a692 :: IO (); a692 = forever $ putStrLn "a692" a693 :: IO (); a693 = forever $ putStrLn "a693" a694 :: IO (); a694 = forever $ putStrLn "a694" a695 :: IO (); a695 = forever $ putStrLn "a695" a696 :: IO (); a696 = forever $ putStrLn "a696" a697 :: IO (); a697 = forever $ putStrLn "a697" a698 :: IO (); a698 = forever $ putStrLn "a698" a699 :: IO (); a699 = forever $ putStrLn "a699" a700 :: IO (); a700 = forever $ putStrLn "a700" a701 :: IO (); a701 = forever $ putStrLn "a701" a702 :: IO (); a702 = forever $ putStrLn "a702" a703 :: IO (); a703 = forever $ putStrLn "a703" a704 :: IO (); a704 = forever $ putStrLn "a704" a705 :: IO (); a705 = forever $ putStrLn "a705" a706 :: IO (); a706 = forever $ putStrLn "a706" a707 :: IO (); a707 = forever $ putStrLn "a707" a708 :: IO (); a708 = forever $ putStrLn "a708" a709 :: IO (); a709 = forever $ putStrLn "a709" a710 :: IO (); a710 = forever $ putStrLn "a710" a711 :: IO (); a711 = forever $ putStrLn "a711" a712 :: IO (); a712 = forever $ putStrLn "a712" a713 :: IO (); a713 = forever $ putStrLn "a713" a714 :: IO (); a714 = forever $ putStrLn "a714" a715 :: IO (); a715 = forever $ putStrLn "a715" a716 :: IO (); a716 = forever $ putStrLn "a716" a717 :: IO (); a717 = forever $ putStrLn "a717" a718 :: IO (); a718 = forever $ putStrLn "a718" a719 :: IO (); a719 = forever $ putStrLn "a719" a720 :: IO (); a720 = forever $ putStrLn "a720" a721 :: IO (); a721 = forever $ putStrLn "a721" a722 :: IO (); a722 = forever $ putStrLn "a722" a723 :: IO (); a723 = forever $ putStrLn "a723" a724 :: IO (); a724 = forever $ putStrLn "a724" a725 :: IO (); a725 = forever $ putStrLn "a725" a726 :: IO (); a726 = forever $ putStrLn "a726" a727 :: IO (); a727 = forever $ putStrLn "a727" a728 :: IO (); a728 = forever $ putStrLn "a728" a729 :: IO (); a729 = forever $ putStrLn "a729" a730 :: IO (); a730 = forever $ putStrLn "a730" a731 :: IO (); a731 = forever $ putStrLn "a731" a732 :: IO (); a732 = forever $ putStrLn "a732" a733 :: IO (); a733 = forever $ putStrLn "a733" a734 :: IO (); a734 = forever $ putStrLn "a734" a735 :: IO (); a735 = forever $ putStrLn "a735" a736 :: IO (); a736 = forever $ putStrLn "a736" a737 :: IO (); a737 = forever $ putStrLn "a737" a738 :: IO (); a738 = forever $ putStrLn "a738" a739 :: IO (); a739 = forever $ putStrLn "a739" a740 :: IO (); a740 = forever $ putStrLn "a740" a741 :: IO (); a741 = forever $ putStrLn "a741" a742 :: IO (); a742 = forever $ putStrLn "a742" a743 :: IO (); a743 = forever $ putStrLn "a743" a744 :: IO (); a744 = forever $ putStrLn "a744" a745 :: IO (); a745 = forever $ putStrLn "a745" a746 :: IO (); a746 = forever $ putStrLn "a746" a747 :: IO (); a747 = forever $ putStrLn "a747" a748 :: IO (); a748 = forever $ putStrLn "a748" a749 :: IO (); a749 = forever $ putStrLn "a749" a750 :: IO (); a750 = forever $ putStrLn "a750" a751 :: IO (); a751 = forever $ putStrLn "a751" a752 :: IO (); a752 = forever $ putStrLn "a752" a753 :: IO (); a753 = forever $ putStrLn "a753" a754 :: IO (); a754 = forever $ putStrLn "a754" a755 :: IO (); a755 = forever $ putStrLn "a755" a756 :: IO (); a756 = forever $ putStrLn "a756" a757 :: IO (); a757 = forever $ putStrLn "a757" a758 :: IO (); a758 = forever $ putStrLn "a758" a759 :: IO (); a759 = forever $ putStrLn "a759" a760 :: IO (); a760 = forever $ putStrLn "a760" a761 :: IO (); a761 = forever $ putStrLn "a761" a762 :: IO (); a762 = forever $ putStrLn "a762" a763 :: IO (); a763 = forever $ putStrLn "a763" a764 :: IO (); a764 = forever $ putStrLn "a764" a765 :: IO (); a765 = forever $ putStrLn "a765" a766 :: IO (); a766 = forever $ putStrLn "a766" a767 :: IO (); a767 = forever $ putStrLn "a767" a768 :: IO (); a768 = forever $ putStrLn "a768" a769 :: IO (); a769 = forever $ putStrLn "a769" a770 :: IO (); a770 = forever $ putStrLn "a770" a771 :: IO (); a771 = forever $ putStrLn "a771" a772 :: IO (); a772 = forever $ putStrLn "a772" a773 :: IO (); a773 = forever $ putStrLn "a773" a774 :: IO (); a774 = forever $ putStrLn "a774" a775 :: IO (); a775 = forever $ putStrLn "a775" a776 :: IO (); a776 = forever $ putStrLn "a776" a777 :: IO (); a777 = forever $ putStrLn "a777" a778 :: IO (); a778 = forever $ putStrLn "a778" a779 :: IO (); a779 = forever $ putStrLn "a779" a780 :: IO (); a780 = forever $ putStrLn "a780" a781 :: IO (); a781 = forever $ putStrLn "a781" a782 :: IO (); a782 = forever $ putStrLn "a782" a783 :: IO (); a783 = forever $ putStrLn "a783" a784 :: IO (); a784 = forever $ putStrLn "a784" a785 :: IO (); a785 = forever $ putStrLn "a785" a786 :: IO (); a786 = forever $ putStrLn "a786" a787 :: IO (); a787 = forever $ putStrLn "a787" a788 :: IO (); a788 = forever $ putStrLn "a788" a789 :: IO (); a789 = forever $ putStrLn "a789" a790 :: IO (); a790 = forever $ putStrLn "a790" a791 :: IO (); a791 = forever $ putStrLn "a791" a792 :: IO (); a792 = forever $ putStrLn "a792" a793 :: IO (); a793 = forever $ putStrLn "a793" a794 :: IO (); a794 = forever $ putStrLn "a794" a795 :: IO (); a795 = forever $ putStrLn "a795" a796 :: IO (); a796 = forever $ putStrLn "a796" a797 :: IO (); a797 = forever $ putStrLn "a797" a798 :: IO (); a798 = forever $ putStrLn "a798" a799 :: IO (); a799 = forever $ putStrLn "a799" a800 :: IO (); a800 = forever $ putStrLn "a800" a801 :: IO (); a801 = forever $ putStrLn "a801" a802 :: IO (); a802 = forever $ putStrLn "a802" a803 :: IO (); a803 = forever $ putStrLn "a803" a804 :: IO (); a804 = forever $ putStrLn "a804" a805 :: IO (); a805 = forever $ putStrLn "a805" a806 :: IO (); a806 = forever $ putStrLn "a806" a807 :: IO (); a807 = forever $ putStrLn "a807" a808 :: IO (); a808 = forever $ putStrLn "a808" a809 :: IO (); a809 = forever $ putStrLn "a809" a810 :: IO (); a810 = forever $ putStrLn "a810" a811 :: IO (); a811 = forever $ putStrLn "a811" a812 :: IO (); a812 = forever $ putStrLn "a812" a813 :: IO (); a813 = forever $ putStrLn "a813" a814 :: IO (); a814 = forever $ putStrLn "a814" a815 :: IO (); a815 = forever $ putStrLn "a815" a816 :: IO (); a816 = forever $ putStrLn "a816" a817 :: IO (); a817 = forever $ putStrLn "a817" a818 :: IO (); a818 = forever $ putStrLn "a818" a819 :: IO (); a819 = forever $ putStrLn "a819" a820 :: IO (); a820 = forever $ putStrLn "a820" a821 :: IO (); a821 = forever $ putStrLn "a821" a822 :: IO (); a822 = forever $ putStrLn "a822" a823 :: IO (); a823 = forever $ putStrLn "a823" a824 :: IO (); a824 = forever $ putStrLn "a824" a825 :: IO (); a825 = forever $ putStrLn "a825" a826 :: IO (); a826 = forever $ putStrLn "a826" a827 :: IO (); a827 = forever $ putStrLn "a827" a828 :: IO (); a828 = forever $ putStrLn "a828" a829 :: IO (); a829 = forever $ putStrLn "a829" a830 :: IO (); a830 = forever $ putStrLn "a830" a831 :: IO (); a831 = forever $ putStrLn "a831" a832 :: IO (); a832 = forever $ putStrLn "a832" a833 :: IO (); a833 = forever $ putStrLn "a833" a834 :: IO (); a834 = forever $ putStrLn "a834" a835 :: IO (); a835 = forever $ putStrLn "a835" a836 :: IO (); a836 = forever $ putStrLn "a836" a837 :: IO (); a837 = forever $ putStrLn "a837" a838 :: IO (); a838 = forever $ putStrLn "a838" a839 :: IO (); a839 = forever $ putStrLn "a839" a840 :: IO (); a840 = forever $ putStrLn "a840" a841 :: IO (); a841 = forever $ putStrLn "a841" a842 :: IO (); a842 = forever $ putStrLn "a842" a843 :: IO (); a843 = forever $ putStrLn "a843" a844 :: IO (); a844 = forever $ putStrLn "a844" a845 :: IO (); a845 = forever $ putStrLn "a845" a846 :: IO (); a846 = forever $ putStrLn "a846" a847 :: IO (); a847 = forever $ putStrLn "a847" a848 :: IO (); a848 = forever $ putStrLn "a848" a849 :: IO (); a849 = forever $ putStrLn "a849" a850 :: IO (); a850 = forever $ putStrLn "a850" a851 :: IO (); a851 = forever $ putStrLn "a851" a852 :: IO (); a852 = forever $ putStrLn "a852" a853 :: IO (); a853 = forever $ putStrLn "a853" a854 :: IO (); a854 = forever $ putStrLn "a854" a855 :: IO (); a855 = forever $ putStrLn "a855" a856 :: IO (); a856 = forever $ putStrLn "a856" a857 :: IO (); a857 = forever $ putStrLn "a857" a858 :: IO (); a858 = forever $ putStrLn "a858" a859 :: IO (); a859 = forever $ putStrLn "a859" a860 :: IO (); a860 = forever $ putStrLn "a860" a861 :: IO (); a861 = forever $ putStrLn "a861" a862 :: IO (); a862 = forever $ putStrLn "a862" a863 :: IO (); a863 = forever $ putStrLn "a863" a864 :: IO (); a864 = forever $ putStrLn "a864" a865 :: IO (); a865 = forever $ putStrLn "a865" a866 :: IO (); a866 = forever $ putStrLn "a866" a867 :: IO (); a867 = forever $ putStrLn "a867" a868 :: IO (); a868 = forever $ putStrLn "a868" a869 :: IO (); a869 = forever $ putStrLn "a869" a870 :: IO (); a870 = forever $ putStrLn "a870" a871 :: IO (); a871 = forever $ putStrLn "a871" a872 :: IO (); a872 = forever $ putStrLn "a872" a873 :: IO (); a873 = forever $ putStrLn "a873" a874 :: IO (); a874 = forever $ putStrLn "a874" a875 :: IO (); a875 = forever $ putStrLn "a875" a876 :: IO (); a876 = forever $ putStrLn "a876" a877 :: IO (); a877 = forever $ putStrLn "a877" a878 :: IO (); a878 = forever $ putStrLn "a878" a879 :: IO (); a879 = forever $ putStrLn "a879" a880 :: IO (); a880 = forever $ putStrLn "a880" a881 :: IO (); a881 = forever $ putStrLn "a881" a882 :: IO (); a882 = forever $ putStrLn "a882" a883 :: IO (); a883 = forever $ putStrLn "a883" a884 :: IO (); a884 = forever $ putStrLn "a884" a885 :: IO (); a885 = forever $ putStrLn "a885" a886 :: IO (); a886 = forever $ putStrLn "a886" a887 :: IO (); a887 = forever $ putStrLn "a887" a888 :: IO (); a888 = forever $ putStrLn "a888" a889 :: IO (); a889 = forever $ putStrLn "a889" a890 :: IO (); a890 = forever $ putStrLn "a890" a891 :: IO (); a891 = forever $ putStrLn "a891" a892 :: IO (); a892 = forever $ putStrLn "a892" a893 :: IO (); a893 = forever $ putStrLn "a893" a894 :: IO (); a894 = forever $ putStrLn "a894" a895 :: IO (); a895 = forever $ putStrLn "a895" a896 :: IO (); a896 = forever $ putStrLn "a896" a897 :: IO (); a897 = forever $ putStrLn "a897" a898 :: IO (); a898 = forever $ putStrLn "a898" a899 :: IO (); a899 = forever $ putStrLn "a899" a900 :: IO (); a900 = forever $ putStrLn "a900" a901 :: IO (); a901 = forever $ putStrLn "a901" a902 :: IO (); a902 = forever $ putStrLn "a902" a903 :: IO (); a903 = forever $ putStrLn "a903" a904 :: IO (); a904 = forever $ putStrLn "a904" a905 :: IO (); a905 = forever $ putStrLn "a905" a906 :: IO (); a906 = forever $ putStrLn "a906" a907 :: IO (); a907 = forever $ putStrLn "a907" a908 :: IO (); a908 = forever $ putStrLn "a908" a909 :: IO (); a909 = forever $ putStrLn "a909" a910 :: IO (); a910 = forever $ putStrLn "a910" a911 :: IO (); a911 = forever $ putStrLn "a911" a912 :: IO (); a912 = forever $ putStrLn "a912" a913 :: IO (); a913 = forever $ putStrLn "a913" a914 :: IO (); a914 = forever $ putStrLn "a914" a915 :: IO (); a915 = forever $ putStrLn "a915" a916 :: IO (); a916 = forever $ putStrLn "a916" a917 :: IO (); a917 = forever $ putStrLn "a917" a918 :: IO (); a918 = forever $ putStrLn "a918" a919 :: IO (); a919 = forever $ putStrLn "a919" a920 :: IO (); a920 = forever $ putStrLn "a920" a921 :: IO (); a921 = forever $ putStrLn "a921" a922 :: IO (); a922 = forever $ putStrLn "a922" a923 :: IO (); a923 = forever $ putStrLn "a923" a924 :: IO (); a924 = forever $ putStrLn "a924" a925 :: IO (); a925 = forever $ putStrLn "a925" a926 :: IO (); a926 = forever $ putStrLn "a926" a927 :: IO (); a927 = forever $ putStrLn "a927" a928 :: IO (); a928 = forever $ putStrLn "a928" a929 :: IO (); a929 = forever $ putStrLn "a929" a930 :: IO (); a930 = forever $ putStrLn "a930" a931 :: IO (); a931 = forever $ putStrLn "a931" a932 :: IO (); a932 = forever $ putStrLn "a932" a933 :: IO (); a933 = forever $ putStrLn "a933" a934 :: IO (); a934 = forever $ putStrLn "a934" a935 :: IO (); a935 = forever $ putStrLn "a935" a936 :: IO (); a936 = forever $ putStrLn "a936" a937 :: IO (); a937 = forever $ putStrLn "a937" a938 :: IO (); a938 = forever $ putStrLn "a938" a939 :: IO (); a939 = forever $ putStrLn "a939" a940 :: IO (); a940 = forever $ putStrLn "a940" a941 :: IO (); a941 = forever $ putStrLn "a941" a942 :: IO (); a942 = forever $ putStrLn "a942" a943 :: IO (); a943 = forever $ putStrLn "a943" a944 :: IO (); a944 = forever $ putStrLn "a944" a945 :: IO (); a945 = forever $ putStrLn "a945" a946 :: IO (); a946 = forever $ putStrLn "a946" a947 :: IO (); a947 = forever $ putStrLn "a947" a948 :: IO (); a948 = forever $ putStrLn "a948" a949 :: IO (); a949 = forever $ putStrLn "a949" a950 :: IO (); a950 = forever $ putStrLn "a950" a951 :: IO (); a951 = forever $ putStrLn "a951" a952 :: IO (); a952 = forever $ putStrLn "a952" a953 :: IO (); a953 = forever $ putStrLn "a953" a954 :: IO (); a954 = forever $ putStrLn "a954" a955 :: IO (); a955 = forever $ putStrLn "a955" a956 :: IO (); a956 = forever $ putStrLn "a956" a957 :: IO (); a957 = forever $ putStrLn "a957" a958 :: IO (); a958 = forever $ putStrLn "a958" a959 :: IO (); a959 = forever $ putStrLn "a959" a960 :: IO (); a960 = forever $ putStrLn "a960" a961 :: IO (); a961 = forever $ putStrLn "a961" a962 :: IO (); a962 = forever $ putStrLn "a962" a963 :: IO (); a963 = forever $ putStrLn "a963" a964 :: IO (); a964 = forever $ putStrLn "a964" a965 :: IO (); a965 = forever $ putStrLn "a965" a966 :: IO (); a966 = forever $ putStrLn "a966" a967 :: IO (); a967 = forever $ putStrLn "a967" a968 :: IO (); a968 = forever $ putStrLn "a968" a969 :: IO (); a969 = forever $ putStrLn "a969" a970 :: IO (); a970 = forever $ putStrLn "a970" a971 :: IO (); a971 = forever $ putStrLn "a971" a972 :: IO (); a972 = forever $ putStrLn "a972" a973 :: IO (); a973 = forever $ putStrLn "a973" a974 :: IO (); a974 = forever $ putStrLn "a974" a975 :: IO (); a975 = forever $ putStrLn "a975" a976 :: IO (); a976 = forever $ putStrLn "a976" a977 :: IO (); a977 = forever $ putStrLn "a977" a978 :: IO (); a978 = forever $ putStrLn "a978" a979 :: IO (); a979 = forever $ putStrLn "a979" a980 :: IO (); a980 = forever $ putStrLn "a980" a981 :: IO (); a981 = forever $ putStrLn "a981" a982 :: IO (); a982 = forever $ putStrLn "a982" a983 :: IO (); a983 = forever $ putStrLn "a983" a984 :: IO (); a984 = forever $ putStrLn "a984" a985 :: IO (); a985 = forever $ putStrLn "a985" a986 :: IO (); a986 = forever $ putStrLn "a986" a987 :: IO (); a987 = forever $ putStrLn "a987" a988 :: IO (); a988 = forever $ putStrLn "a988" a989 :: IO (); a989 = forever $ putStrLn "a989" a990 :: IO (); a990 = forever $ putStrLn "a990" a991 :: IO (); a991 = forever $ putStrLn "a991" a992 :: IO (); a992 = forever $ putStrLn "a992" a993 :: IO (); a993 = forever $ putStrLn "a993" a994 :: IO (); a994 = forever $ putStrLn "a994" a995 :: IO (); a995 = forever $ putStrLn "a995" a996 :: IO (); a996 = forever $ putStrLn "a996" a997 :: IO (); a997 = forever $ putStrLn "a997" a998 :: IO (); a998 = forever $ putStrLn "a998" a999 :: IO (); a999 = forever $ putStrLn "a999" a1000 :: IO (); a1000 = forever $ putStrLn "a1000" ghc-exactprint-0.6.2/tests/examples/ghc80/T10384.hs0000755000000000000000000000017307346545000017664 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, RankNTypes, ScopedTypeVariables #-} module A where x = \(y :: forall a. a -> a) -> [|| y ||] ghc-exactprint-0.6.2/tests/examples/ghc80/T10390.hs0000755000000000000000000000072707346545000017666 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module T10390 where class ApPair r where apPair :: (forall a . (ApPair a, Num a) => Maybe a) -> Maybe r instance (ApPair a, ApPair b) => ApPair (a,b) where apPair = apPair' apPair' :: (ApPair b, ApPair c) => (forall a . (Num a, ApPair a) => Maybe a) -> Maybe (b,c) -- NB constraints in a different order to apPair apPair' f = let (Just a) = apPair f (Just b) = apPair f in Just $ (a, b) ghc-exactprint-0.6.2/tests/examples/ghc80/T10398.hs0000755000000000000000000000040307346545000017665 0ustar0000000000000000module Foo ( -- The reference to chunk2 should show up in the -ddump-parsed output. -- $chunk1 -- $chunk2 foo, -- $chunk3 bar ) where {- $chunk1 This is chunk 1. -} {- $chunk2 This is chunk 2. -} {- $chunk3 This is chunk 3. -} foo = 3 bar = 7 ghc-exactprint-0.6.2/tests/examples/ghc80/T10403.hs0000755000000000000000000000104407346545000017652 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} {-# OPTIONS_GHC -fdefer-type-errors #-} module T10403 where data I a = I a instance Functor I where fmap f (I a) = I (f a) newtype B t a = B a instance Functor (B t) where fmap f (B a) = B (f a) newtype H f = H (f ()) h1 :: _ => _ -- h :: Functor m => (a -> b) -> m a -> H m h1 f b = (H . fmap (const ())) (fmap f b) h2 :: _ -- h2 :: Functor m => (a -> b) -> m a -> H m h2 f b = (H . fmap (const ())) (fmap f b) app1 :: H (B t) app1 = h1 (H . I) (B ()) app2 :: H (B t) app2 = h2 (H . I) (B ()) ghc-exactprint-0.6.2/tests/examples/ghc80/T10414.hs0000755000000000000000000000276607346545000017670 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} import GHC.Exts newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)} -- inline sequence :: [Eval a] -> Eval [a] well_sequenced :: [Eval a] -> Eval [a] well_sequenced = foldr cons nil where cons e es = Eval $ \s -> case runEval e s of (# s', a #) -> case runEval es s' of (# s'', as #) -> (# s'', a : as #) nil = Eval $ \s -> (# s, [] #) -- seemingly demonic use of spark# ill_sequenced :: [Eval a] -> Eval [a] ill_sequenced as = Eval $ spark# (case well_sequenced as of Eval f -> case f realWorld# of (# _, a' #) -> a') -- 'parallelized' version of (show >=> show >=> show >=> show >=> show) main :: IO () main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y') where layer :: (Char -> String) -> (Char -> String) layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as) . well_sequenced -- [Eval String] -> Eval [String] . map ill_sequenced -- [[Eval Char]] -> [Eval String]; -- 'map well_sequenced' is fine . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval . chunk' -- String -> [String] . concatMap f . show -- add single quotes chunk' :: String -> [String] chunk' [] = [] chunk' xs = as : chunk' bs where (as,bs) = splitAt 3 xs -- this doesn't work: -- chunk (a:b:c:xs) = [a,b,c]:chunk xs -- chunk xs = [xs] ghc-exactprint-0.6.2/tests/examples/ghc80/T10420.hs0000755000000000000000000000016507346545000017654 0ustar0000000000000000module Main where import T10420a import RuleDefiningPlugin {-# NOINLINE x #-} x = "foo" main = putStrLn (show x) ghc-exactprint-0.6.2/tests/examples/ghc80/T10420a.hs0000755000000000000000000000010507346545000020007 0ustar0000000000000000{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-} module T10420a where ghc-exactprint-0.6.2/tests/examples/ghc80/T10423.hs0000755000000000000000000000031707346545000017656 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeFamilies, MultiParamTypeClasses #-} module T10423 where class Monad m => Testable m a newtype Prop m = MkProp (m Int) instance (Monad m, m ~ n) => Testable n (Prop m) ghc-exactprint-0.6.2/tests/examples/ghc80/T10428.hs0000755000000000000000000000020007346545000017652 0ustar0000000000000000module T10428 where import Data.Coerce coerceNewtype :: (Coercible (o r) (n m' r)) => [o r] -> [n m' r] coerceNewtype = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10438.hs0000755000000000000000000000024107346545000017660 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE TypeFamilies #-} module T10438 where foo f = g where g r = x where x :: _ x = r ghc-exactprint-0.6.2/tests/examples/ghc80/T10447.hs0000755000000000000000000000156107346545000017666 0ustar0000000000000000{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-} module Main where class (a ~ Int) => Foo a instance Foo Int data A a where A1 :: Ord a => a -> A a A2 :: Int -> A Int A3 :: b ~ Int => b -> A Int A4 :: a ~ Int => Int -> A a A5 :: a ~ Int => a -> A a A6 :: (a ~ b, b ~ Int) => Int -> b -> A a A7 :: Foo a => Int -> a -> A a deriving instance Foldable A data HK f a where HK1 :: f a -> HK f (f a) HK2 :: f a -> HK f a deriving instance Foldable f => Foldable (HK f) one :: Int one = 1 main :: IO () main = do mapM_ (print . foldr (+) one) [ A1 one , A2 one , A3 one , A4 one , A5 one , A6 one one , A7 one one ] mapM_ (print . foldr mappend Nothing) [ HK1 (Just "Hello") , HK2 (Just (Just "World")) ] ghc-exactprint-0.6.2/tests/examples/ghc80/T10451.hs0000755000000000000000000000226007346545000017656 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} module T10451 where type S a = ( Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a ) type T a = ( Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a , Eq a, Eq a, Eq a, Eq a) ghc-exactprint-0.6.2/tests/examples/ghc80/T10460.hs0000755000000000000000000000020407346545000017652 0ustar0000000000000000{-# LANGUAGE GHCForeignImportPrim #-} module T10460 where import GHC.Exts -- don't link me! foreign import prim "f" f :: Any -> Any ghc-exactprint-0.6.2/tests/examples/ghc80/T10461.hs0000755000000000000000000000020607346545000017655 0ustar0000000000000000{-# LANGUAGE MagicHash, GHCForeignImportPrim #-} module T10461 where import GHC.Exts foreign import prim cheneycopy :: Any -> Word# ghc-exactprint-0.6.2/tests/examples/ghc80/T10463.hs0000755000000000000000000000014707346545000017663 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-} module T10463 where f (x :: _) = x ++ "" ghc-exactprint-0.6.2/tests/examples/ghc80/T10481.hs0000755000000000000000000000023707346545000017663 0ustar0000000000000000{-# LANGUAGE MagicHash #-} import GHC.Exts import Control.Exception f :: ArithException -> Int# f x = raise# (toException x) main = print (I# (f Overflow)) ghc-exactprint-0.6.2/tests/examples/ghc80/T10482.hs0000755000000000000000000000053707346545000017667 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} module T10482 where data family Foo a data instance Foo (a, b) = FooPair !(Foo a) !(Foo b) newtype instance Foo Int = Foo Int foo :: Foo ((Int, Int), Int) -> Int -> Int foo !f k = if k == 0 then 0 else if even k then foo f (k-1) else case f of FooPair (FooPair (Foo n) _) _ -> n ghc-exactprint-0.6.2/tests/examples/ghc80/T10482a.hs0000755000000000000000000000275607346545000020035 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} -- Makes f2 a bit more challenging -- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482 module Foo where h :: Int -> Int -> Bool h 0 y = y>0 h n y = h (n-1) y -- The main point: all of these functions can have the CPR property ------- f1 ----------- -- x is used strictly by h, so it'll be available -- unboxed before it is returned in the True branch f1 :: Int -> Int f1 x = case h x x of True -> x False -> f1 (x-1) ------- f2 ----------- -- x is a strict field of MkT2, so we'll pass it unboxed -- to $wf2, so it's available unboxed. This depends on -- the case expression analysing (a subcomponent of) one -- of the original arguments to the function, so it's -- a bit more delicate. data T2 = MkT2 !Int Int f2 :: T2 -> Int f2 (MkT2 x y) | y>0 = f2 (MkT2 x (y-1)) | y>1 = 1 | otherwise = x ------- f3 ----------- -- h is strict in x, so x will be unboxed before it -- is rerturned in the otherwise case. data T3 = MkT3 Int Int f3 :: T3 -> Int f3 (MkT3 x y) | h x y = f3 (MkT3 x (y-1)) | otherwise = x ------- f4 ----------- -- Just like f2, but MkT4 can't unbox its strict -- argument automatically, as f2 can data family Foo a newtype instance Foo Int = Foo Int data T4 a = MkT4 !(Foo a) Int f4 :: T4 Int -> Int f4 (MkT4 x@(Foo v) y) | y>0 = f4 (MkT4 x (y-1)) | otherwise = v ghc-exactprint-0.6.2/tests/examples/ghc80/T10487.hs0000755000000000000000000000032007346545000017662 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-} module T10487 where import GHC.Generics import qualified T10487_M as M data Name = Name deriving instance Generic Name deriving instance Generic M.Name ghc-exactprint-0.6.2/tests/examples/ghc80/T10487_M.hs0000755000000000000000000000005007346545000020136 0ustar0000000000000000module T10487_M where data Name = Name ghc-exactprint-0.6.2/tests/examples/ghc80/T10489.hs0000755000000000000000000000017407346545000017673 0ustar0000000000000000module T10489 where -- Triggered an ASSERT in a debug build at some point. convert d = let d' = case d of '0' -> '!' in d' ghc-exactprint-0.6.2/tests/examples/ghc80/T10493.hs0000755000000000000000000000026607346545000017670 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module T10493 where import Data.Coerce import Data.Ord (Down) -- no constructor foo :: Coercible (Down Int) Int => Down Int -> Int foo = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10494.hs0000755000000000000000000000013607346545000017665 0ustar0000000000000000module App where import Data.Coerce foo :: Coercible (a b) (c d) => a b -> c d foo = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10495.hs0000755000000000000000000000006607346545000017670 0ustar0000000000000000module T10495 where import Data.Coerce foo = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10503.hs0000755000000000000000000000035607346545000017660 0ustar0000000000000000{-# LANGUAGE RankNTypes, PolyKinds, DataKinds, TypeFamilies #-} module GHCBug where data Proxy p = Proxy data KProxy (a :: *) = KProxy h :: forall r . (Proxy ('KProxy :: KProxy k) ~ Proxy ('KProxy :: KProxy *) => r) -> r h = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T10507.hs0000755000000000000000000000106007346545000017655 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10507 where import Data.Type.Equality ( (:~:)(Refl) ) import Prelude (Maybe(..), undefined) import GHC.TypeLits ( Nat, type (<=)) data V (n::Nat) testEq :: (m <= n) => V m -> V n -> Maybe (m :~: n) testEq = undefined uext :: (1 <= m, m <= n) => V m -> V n -> V n uext e w = case testEq e w of Just Refl -> e ghc-exactprint-0.6.2/tests/examples/ghc80/T10508_api.hs0000755000000000000000000000121407346545000020510 0ustar0000000000000000module Main where import DynFlags import GHC import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import System.Environment (getArgs) main :: IO () main = do [libdir] <- getArgs runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags $ dflags `gopt_unset` Opt_ImplicitImportQualified `xopt_unset` Opt_ImplicitPrelude forM_ exprs $ \expr -> handleSourceError printException $ do dyn <- dynCompileExpr expr liftIO $ print dyn where exprs = [ "" , "(),()" , "()" , "\"test\"" , unlines [ "[()]" , " :: [()]" ] ] ghc-exactprint-0.6.2/tests/examples/ghc80/T10516.hs0000755000000000000000000000017307346545000017661 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module T10516 where type App f a = f a newtype X f a = X (f a) f :: f a -> X (App f) a f = X ghc-exactprint-0.6.2/tests/examples/ghc80/T10519.hs0000755000000000000000000000022207346545000017657 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE PartialTypeSignatures #-} module T10519 where foo :: forall a. _ => a -> a -> Bool foo x y = x == y ghc-exactprint-0.6.2/tests/examples/ghc80/T10521.hs0000755000000000000000000000044607346545000017660 0ustar0000000000000000import Data.Word( Word8 ) toV :: Float -> Word8 toV d = let coeff = significand d * 255.9999 / d a = truncate $ d * coeff b = exponent d in a `seq` (b `seq` a) main :: IO () main = print $ map toV [ 3.56158e-2, 0.7415215, 0.5383201, 0.1289829, 0.45520145 ] ghc-exactprint-0.6.2/tests/examples/ghc80/T10521b.hs0000755000000000000000000000043507346545000020020 0ustar0000000000000000{-# LANGUAGE MagicHash #-} import GHC.Exts f :: Float# -> Float# f x = x {-# NOINLINE f #-} g :: Double# -> Double# g x = x {-# NOINLINE g #-} h :: Float -> Float h (F# x) = let a = F# (f x) b = D# (g (2.0##)) in a `seq` (b `seq` a) main = print (h 1.0) ghc-exactprint-0.6.2/tests/examples/ghc80/T10524.hs0000755000000000000000000000034207346545000017656 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE PolyKinds #-} module T10524 where import Data.Data newtype WrappedFunctor f a = WrapFunctor (f a) deriving (Data, Typeable) -- WrappedFunctor :: forall k. (k -> *) -> k -> * ghc-exactprint-0.6.2/tests/examples/ghc80/T10534.hs0000755000000000000000000000022107346545000017653 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T10534 where import T10534a newtype instance DF a = MkDF () unsafeCoerce :: a -> b unsafeCoerce = silly ghc-exactprint-0.6.2/tests/examples/ghc80/T10534a.hs0000755000000000000000000000024707346545000020024 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleContexts #-} module T10534a where import Data.Coerce data family DF a silly :: Coercible (DF a) (DF b) => a -> b silly = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10549.hs0000755000000000000000000000056707346545000017676 0ustar0000000000000000{-# OPTIONS_GHC -O2 #-} -- Verify that -O2 is rejected when this module is loaded by GHCi module T10549 where import qualified Data.ByteString.Internal as Internal import System.IO.Unsafe (unsafePerformIO) import Data.Word (Word8) import Foreign.Ptr (Ptr) import Foreign.Storable (peek) type S = Ptr Word8 chr :: S -> Char chr x = Internal.w2c $ unsafePerformIO $ peek x ghc-exactprint-0.6.2/tests/examples/ghc80/T10549a.hs0000755000000000000000000000013507346545000020026 0ustar0000000000000000{-# OPTIONS_GHC -O #-} module Main(main) where import GHC.Exts main = print 1 go (Ptr a) = a ghc-exactprint-0.6.2/tests/examples/ghc80/T10561.hs0000755000000000000000000000107407346545000017662 0ustar0000000000000000{-# LANGUAGE PolyKinds, DeriveFunctor, RankNTypes #-} module T10561 where -- Ultimately this should "Just Work", -- but in GHC 7.10 it gave a Lint failure -- For now (HEAD, Jun 2015) it gives a kind error message, -- which is better than a crash newtype Compose f g a = Compose (f (g a)) deriving Functor {- instance forall (f_ant :: k_ans -> *) (g_anu :: * -> k_ans). (Functor f_ant, Functor g_anu) => Functor (Compose f_ant g_anu) where fmap f_anv (T10561.Compose a1_anw) = Compose (fmap (fmap f_anv) a1_anw) -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10562.hs0000755000000000000000000000052507346545000017663 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies #-} module T10562 where type family Flip a data QueryRep qtyp a where QAtom :: a -> QueryRep () a QOp :: QueryRep (Flip qtyp) a -> QueryRep qtyp a instance Eq (QueryRep qtyp a) where (==) = error "urk" instance (Ord a) => Ord (QueryRep qtyp a) where compare (QOp a) (QOp b) = a `compare` b ghc-exactprint-0.6.2/tests/examples/ghc80/T10564.hs0000755000000000000000000000107407346545000017665 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances, DataKinds, TypeFamilies, KindSignatures, PolyKinds, FunctionalDependencies #-} module T10564 where class HasFieldM (l :: k) r (v :: Maybe *) | l r -> v class HasFieldM1 (b :: Maybe [*]) (l :: k) r v | b l r -> v class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k]) | e1 l -> r data Label a type family LabelsOf (a :: [*]) :: [*] instance (HMemberM (Label (l::k)) (LabelsOf xs) b, HasFieldM1 b l (r xs) v) => HasFieldM l (r xs) v where ghc-exactprint-0.6.2/tests/examples/ghc80/T10570.hs0000755000000000000000000000040107346545000017653 0ustar0000000000000000{-# LANGUAGE FunctionalDependencies, PolyKinds, FlexibleInstances #-} module T10570 where import Data.Proxy class ConsByIdx2 x a m cls | x -> m where consByIdx2 :: x -> a -> m cls instance ConsByIdx2 Int a Proxy cls where consByIdx2 _ _ = Proxy ghc-exactprint-0.6.2/tests/examples/ghc80/T10590.hs0000755000000000000000000000210407346545000017657 0ustar0000000000000000import Foreign.C import Foreign.Marshal.Array import Foreign.Storable import Control.Concurrent -- The test works only on UNIX like. -- unportable bits: import qualified System.Posix.Internals as SPI import qualified System.Posix.Types as SPT pipe :: IO (CInt, CInt) pipe = allocaArray 2 $ \fds -> do throwErrnoIfMinus1_ "pipe" $ SPI.c_pipe fds rd <- peekElemOff fds 0 wr <- peekElemOff fds 1 return (rd, wr) main :: IO () main = do (r1, w1) <- pipe (r2, _w2) <- pipe _ <- forkIO $ do -- thread A threadWaitRead (SPT.Fd r1) _ <- forkIO $ do -- thread B threadWaitRead (SPT.Fd r2) yield -- switch to A, then B -- now both are blocked _ <- SPI.c_close w1 -- unblocking thread A fd _ <- SPI.c_close r2 -- breaking thread B fd yield -- kick RTS IO manager {- Trac #10590 exposed a bug as: T10590: internal error: removeThreadFromDeQueue: not found (GHC version 7.11.20150702 for x86_64_unknown_linux) Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10596.hs0000755000000000000000000000042107346545000017665 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10596 where import Language.Haskell.TH import Language.Haskell.TH.Syntax import System.IO do putQ (100 :: Int) x <- (getQ :: Q (Maybe Int)) -- It should print "Just 100" runIO $ print x runIO $ hFlush stdout return [] ghc-exactprint-0.6.2/tests/examples/ghc80/T10602.hs0000755000000000000000000000137407346545000017661 0ustar0000000000000000{-# OPTIONS_GHC -O2 #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {-# LANGUAGE NoImplicitPrelude #-} -- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away. -- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away. module T10602 where -- Copy-pasting T10602b.hs into the current module makes the problem go away. import T10602b data PairS a = PairS a a -- Removing the '~' makes the problem go away. (PairS _ _) >> ~(PairS b g) = PairS b g class Binary t where put :: t -> PairS () -- Not using a newtype makes the problem go away. newtype A a = A [a] instance Binary a => Binary (A a) where put (A xs) = case splitAt 254 xs of (_, []) -> foldr (>>) (PairS () ()) (map put xs) (_, b) -> put (A b) ghc-exactprint-0.6.2/tests/examples/ghc80/T10602b.hs0000755000000000000000000000102407346545000020013 0ustar0000000000000000{-# OPTIONS_GHC -O2 #-} {-# LANGUAGE NoImplicitPrelude #-} module T10602b (splitAt, map, foldr) where import GHC.Classes import GHC.Types import GHC.Num import GHC.Base splitAt :: Int -> [a] -> ([a],[a]) splitAt n ls | n <= 0 = ([], ls) | otherwise = splitAt' n ls where splitAt' :: Int -> [a] -> ([a], [a]) splitAt' _ [] = ([], []) splitAt' 1 (x:xs) = ([x], xs) splitAt' m (x:xs) = (x:xs', xs'') where (xs', xs'') = splitAt' (m - 1) xs ghc-exactprint-0.6.2/tests/examples/ghc80/T10615.hs0000755000000000000000000000014307346545000017656 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module T10615 where f1 :: _ -> f f1 = const f2 :: _ -> _f f2 = const ghc-exactprint-0.6.2/tests/examples/ghc80/T10618.hs0000755000000000000000000000006507346545000017664 0ustar0000000000000000module T10618 where foo = Just $ Nothing <> Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/T10620.hs0000755000000000000000000000032307346545000017652 0ustar0000000000000000{-# LANGUAGE MagicHash, TemplateHaskell #-} module Main where import Language.Haskell.TH main :: IO () main = do putStrLn $([| 'a'# |] >>= stringE . show) putStrLn $([| "abc"# |] >>= stringE . show) ghc-exactprint-0.6.2/tests/examples/ghc80/T10627.hs0000755000000000000000000000047107346545000017665 0ustar0000000000000000-- Made GHC 6.10.2 go into a loop in substRecBndrs {-# OPTIONS_GHC -w #-} module T10627 where import Data.Word class C a where splitFraction :: a -> (b,a) roundSimple :: (C a) => a -> b roundSimple x = error "rik" {-# RULES "rs" roundSimple = (fromIntegral :: Int -> Word) . roundSimple; #-} ghc-exactprint-0.6.2/tests/examples/ghc80/T10632.hs0000755000000000000000000000020407346545000017653 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} f :: (?file1 :: String) => IO () f = putStrLn $ "f2: " main :: IO () main = let ?file1 = "A" in f ghc-exactprint-0.6.2/tests/examples/ghc80/T10634.hs0000755000000000000000000000065707346545000017671 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T10634 where import Data.Int (Int8, Int16, Int32) type family Up a type instance Up Int8 = Int16 type instance Up Int16 = Int32 class (Up (Down a) ~ a) => Convert a where type Down a down :: a -> Down a instance Convert Int16 where type Down Int16 = Int8 down = fromIntegral instance Convert Int32 where type Down Int32 = Int16 down = fromIntegral x :: Int8 x = down 8 ghc-exactprint-0.6.2/tests/examples/ghc80/T10637.hs0000755000000000000000000000007307346545000017664 0ustar0000000000000000module T10637 where import {-# SOURCE #-} A () data B = B ghc-exactprint-0.6.2/tests/examples/ghc80/T10638.hs0000755000000000000000000000202507346545000017664 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} import Language.Haskell.TH import Language.Haskell.TH.Syntax import GHC.Exts {- the prim and javascript calling conventions do not support headers and the static keyword. -} -- check that quasiquoting roundtrips succesfully and that the declaration -- does not include the static keyword test1 :: String test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] addTopDecls ds case p of "test1" -> return (LitE . stringL $ p) _ -> error $ "unexpected value: " ++ show p ) -- check that constructed prim imports with the static keyword are rejected test2 :: String test2 = $(do t <- [t| Int# -> Int# |] cmm_test2 <- newName "cmm_test2" addTopDecls [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] [| test1 |] ) ghc-exactprint-0.6.2/tests/examples/ghc80/T10642.hs0000755000000000000000000000031607346545000017660 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T10642 where import Data.Coerce type family F a newtype D a = D (F a) -- | This works on 7.10.1, but fails on HEAD (20150711) coerceD :: F a -> D a coerceD = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T10662.hs0000755000000000000000000000010407346545000017655 0ustar0000000000000000main :: IO () main = do return $ let a = "hello" in a return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10667.hs0000755000000000000000000000020607346545000017665 0ustar0000000000000000module A where -- when used with '-g' debug generation option -- '*/*' leaked into a /* comment */ and broke -- GNU as. x */* y = 42 ghc-exactprint-0.6.2/tests/examples/ghc80/T10668.hs0000755000000000000000000000006507346545000017671 0ustar0000000000000000module T10668 where import Data.Type.Equality(Refl) ghc-exactprint-0.6.2/tests/examples/ghc80/T10670.hs0000755000000000000000000000110707346545000017660 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, RankNTypes, GADTs, PolyKinds #-} module T10670 where import Unsafe.Coerce data TypeRepT (a::k) where TRCon :: TypeRepT a data G2 c a where G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) {-# NOINLINE getT2 #-} getT2 c t = Nothing tyRepTArr :: TypeRepT (->) {-# NOINLINE tyRepTArr #-} tyRepTArr = TRCon s :: forall a x. TypeRepT (a :: *) -> Maybe x s tf = case getT2 tyRepTArr tf :: Maybe (G2 (->) a) of Just (G2 _ _) -> Nothing _ -> Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/T10670a.hs0000755000000000000000000000224607346545000020026 0ustar0000000000000000{-# LANGUAGE GADTs , PolyKinds #-} module Bug2 where import Unsafe.Coerce data TyConT (a::k) = TyConT String eqTyConT :: TyConT a -> TyConT b -> Bool eqTyConT (TyConT a) (TyConT b) = a == b tyConTArr :: TyConT (->) tyConTArr = TyConT "(->)" data TypeRepT (a::k) where TRCon :: TyConT a -> TypeRepT a TRApp :: TypeRepT a -> TypeRepT b -> TypeRepT (a b) data GetAppT a where GA :: TypeRepT a -> TypeRepT b -> GetAppT (a b) getAppT :: TypeRepT a -> Maybe (GetAppT a) getAppT (TRApp a b) = Just $ GA a b getAppT _ = Nothing eqTT :: TypeRepT (a::k1) -> TypeRepT (b::k2) -> Bool eqTT (TRCon a) (TRCon b) = eqTyConT a b eqTT (TRApp c a) (TRApp d b) = eqTT c d && eqTT a b eqTT _ _ = False data G2 c a where G2 :: TypeRepT a -> TypeRepT b -> G2 c (c a b) getT2 :: TypeRepT (c :: k2 -> k1 -> k) -> TypeRepT (a :: k) -> Maybe (G2 c a) getT2 c t = do GA t' b <- getAppT t GA c' a <- getAppT t' if eqTT c c' then Just (unsafeCoerce $ G2 a b :: G2 c a) else Nothing tyRepTArr :: TypeRepT (->) tyRepTArr = TRCon tyConTArr s tf = case getT2 tyRepTArr tf of Just (G2 _ _) -> Nothing _ -> Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/T10678.hs0000755000000000000000000000125207346545000017671 0ustar0000000000000000{-# LANGUAGE MagicHash #-} import GHC.Prim main :: IO () main = go 1000000# 10 (2^100) go :: Int# -> Integer -> Integer -> IO () go 0# _ _ = return () go n# a b = (a + b) `seq` go (n# -# 1#) a b {-# NOINLINE go #-} {- This test is based on a strategy from rwbarton relying on the inefficiency of `Integer` addition as defined by `integer-gmp` without `runRW#`. When I was testing the patch interactively, I measured allocations for, say, a million (large Integer) + (small Integer) additions. If that addition allocates, say, 6 words, then one can fairly reliably write the program so that it will allocate between 6 million and 7 million words, total. -} ghc-exactprint-0.6.2/tests/examples/ghc80/T10689.hs0000755000000000000000000000024607346545000017675 0ustar0000000000000000module T10694 where f :: Eq a => a -> Bool {-# NOINLINE f #-} f x = x==x type Foo a b = b {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} finkle = f 'c' ghc-exactprint-0.6.2/tests/examples/ghc80/T10694.hs0000755000000000000000000000057007346545000017671 0ustar0000000000000000module T10694 where -- The point here is that 'm' should NOT have the CPR property -- Checked by grepping in the -ddump-simpl -- Some nonsense so that the simplifier can't see through -- to the I# constructor pm :: Int -> Int -> (Int, Int) pm x y = (l !! 0, l !! 1) where l = [x+y, x-y] {-# NOINLINE pm #-} m :: Int -> Int -> Int m x y = case pm x y of (pr, mr) -> mr ghc-exactprint-0.6.2/tests/examples/ghc80/T10698.hs0000755000000000000000000000066407346545000017701 0ustar0000000000000000{-# LANGUAGE RoleAnnotations #-} module T10698 where import Data.Coerce data Map k a = Map k a type role Map nominal representational map1 :: (k1->k2) -> Map k1 a -> Map k2 a map1 f (Map a b) = Map (f a) b {-# NOINLINE [1] map1 #-} {-# RULES "map1/coerce" map1 coerce = coerce #-} map2 :: (a -> b) -> Map k a -> Map k b map2 f (Map a b) = Map a (f b) {-# NOINLINE [1] map2 #-} {-# RULES "map2/coerce" map2 coerce = coerce #-} ghc-exactprint-0.6.2/tests/examples/ghc80/T10704.hs0000755000000000000000000000114507346545000017660 0ustar0000000000000000{-# LANGUAGE MagicHash, TemplateHaskell #-} module Main where import GHC.Exts import T10704a main :: IO () main = do putStrLn $(fixityExp ''(->)) putStrLn $(fixityExp ''Show) putStrLn $(fixityExp 'show) putStrLn $(fixityExp '(+)) putStrLn $(fixityExp ''Int) putStrLn $(fixityExp ''Item) putStrLn $(fixityExp ''Char#) putStrLn $(fixityExp 'Just) putStrLn $(fixityExp 'seq) putStrLn $(fixityExp '($)) putStrLn $(fixityExp ''(:=>)) putStrLn $(fixityExp ''(:+:)) putStrLn $(fixityExp ''(:*:)) putStrLn $(fixityExp ''(:%:)) putStrLn $(fixityExp ''(:?:)) putStrLn $(fixityExp ''(:@:)) ghc-exactprint-0.6.2/tests/examples/ghc80/T10704a.hs0000755000000000000000000000065407346545000020025 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-} module T10704a where import Language.Haskell.TH infixl 1 :=> infixl 2 :+: infix 3 :*: infix 4 :%: infixr 5 :?: infixr 6 :@: class a :=> b type a :+: b = Either a b data a :*: b = a :*: b newtype a :%: b = Percent (a, b) data family a :?: b type family a :@: b where a :@: b = Int fixityExp :: Name -> Q Exp fixityExp n = reifyFixity n >>= stringE . show ghc-exactprint-0.6.2/tests/examples/ghc80/T10713.hs0000755000000000000000000000035207346545000017657 0ustar0000000000000000{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds #-} module T10713 where import Data.Proxy type family TEq t s where TEq t t = 'True TEq t s = 'False data family T a foo :: Proxy (TEq (T Int) (T Bool)) -> Proxy 'False foo = id ghc-exactprint-0.6.2/tests/examples/ghc80/T10734.hs0000755000000000000000000000051407346545000017662 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH main :: IO () main = do pprint <$> runQ [| do { let { }; return (); } |] >>= putStrLn pprint <$> runQ [| do { let { x = 5 }; return x; } |] >>= putStrLn pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn ghc-exactprint-0.6.2/tests/examples/ghc80/T10742.hs0000755000000000000000000000046507346545000017666 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T10742 where import GHC.TypeLits data T a where MkT :: T Int test :: ((x <=? y) ~ 'True, (y <=? z) ~ 'True) => proxy x y z -> () test _ = case MkT of MkT -> () ghc-exactprint-0.6.2/tests/examples/ghc80/T10744.hs0000755000000000000000000000040007346545000017655 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module T10744 where import GHC.Exts import GHC.Magic -- Checks if oneShot is open-kinded f0 :: Int -> Int f0 = oneShot $ \n -> n f1 :: Int# -> Int f1 = oneShot $ \n# -> I# n# f2 :: Int -> Int# f2 = oneShot $ \(I# n#) -> n# ghc-exactprint-0.6.2/tests/examples/ghc80/T10747.hs0000755000000000000000000000013607346545000017666 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module T10747 where pattern head `Cons` tail = head : tail ghc-exactprint-0.6.2/tests/examples/ghc80/T10753.hs0000755000000000000000000000126007346545000017662 0ustar0000000000000000{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-missing-methods #-} module T10753 where class MonadState s m | m -> s where get :: m s newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance (Monad m) => Monad (StateT s m) where instance (Functor m, Monad m) => Applicative (StateT s m) where instance (Functor m) => Functor (StateT s m) where instance (Monad m) => MonadState s (StateT s m) where class HasConns (m :: * -> *) where type Conn m foo :: (Monad m) => StateT (Conn m) m () foo = do _ <- get return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10767.hs0000755000000000000000000000233007346545000017666 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} module Main where {- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning: T10767.hs:43:1: Warning: RULE left-hand side too complicated to desugar Optimised lhs: case cobox_aWY of _ [Occ=Dead] { GHC.Types.Eq# cobox -> genLength @ Int $dSpecList_aWX } Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox -> genLength @ Int $dSpecList_aWX } -} import Data.Proxy class SpecList a where type List a :: * slCase :: List a -> b -> (a -> List a -> b) -> b data IntList = ILNil | ILCons {-# UNPACK #-} !Int IntList deriving (Show) instance SpecList Int where type List Int = IntList slCase ILNil n _ = n slCase (ILCons i t) _ c = c i t fromList :: [Int] -> IntList fromList [] = ILNil fromList (h : t) = ILCons h (fromList t) lst1 :: IntList lst1 = fromList [1..10] {-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-} genLength :: forall a . SpecList a => Proxy a -> List a -> Int genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail) main :: IO () main = print (genLength (Proxy :: Proxy Int) lst1) ghc-exactprint-0.6.2/tests/examples/ghc80/T10781.hs0000755000000000000000000000056307346545000017670 0ustar0000000000000000module T10781 where {- ghc-7.10.2 reported: T10781.hs:6:5: Found hole ‘_name’ with type: t Where: ‘t’ is a rigid type variable bound by the inferred type of f :: t at T10781.hs:6:1 Relevant bindings include f :: t (bound at T10781.hs:6:1) In the expression: Foo._name In an equation for ‘f’: f = Foo._name -} f = Foo._name ghc-exactprint-0.6.2/tests/examples/ghc80/T10796a.hs0000755000000000000000000000062507346545000020036 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10796a where import Data.Ratio import Data.Set (Set, fromList) import Language.Haskell.TH.Syntax (liftData) -- Data instance with toConstr implemented using a variable, -- not a data constructor splicedSet :: Set Char splicedSet = $(liftData (fromList "test")) -- Infix data constructor splicedRatio :: Ratio Int splicedRatio = $(liftData (1 % 2 :: Ratio Int)) ghc-exactprint-0.6.2/tests/examples/ghc80/T10796b.hs0000755000000000000000000000035407346545000020036 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10796b where import Data.Set (Set, fromList) import Language.Haskell.TH.Quote (dataToPatQ) badPattern :: Set Char -> Set Char badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s ghc-exactprint-0.6.2/tests/examples/ghc80/T10806.hs0000755000000000000000000000043107346545000017660 0ustar0000000000000000{-# LANGUAGE GADTs, ExplicitNamespaces, TypeOperators, DataKinds #-} module T10806 where import GHC.TypeLits (Nat, type (<=)) data Q a where Q :: (a <= b, b <= c) => proxy a -> proxy b -> Q c triggersLoop :: Q b -> Q b -> Bool triggersLoop (Q _ _) (Q _ _) = print 'x' 'y' ghc-exactprint-0.6.2/tests/examples/ghc80/T10815.hs0000755000000000000000000000043107346545000017660 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-} module T10815 where import Data.Proxy type family Any :: k class kproxy ~ 'KProxy => C (kproxy :: KProxy k) where type F (a :: k) type G a :: k instance C ('KProxy :: KProxy Bool) where type F a = Int type G a = Any ghc-exactprint-0.6.2/tests/examples/ghc80/T10819.hs0000755000000000000000000000070407346545000017667 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} module T10819 where import T10819_Lib import Language.Haskell.TH.Syntax class C a b | b -> a where f :: b -> a data D = X instance C Int D where f X = 2 $(doSomeTH "N" (mkName "D") [ConT (mkName "C") `AppT` ConT (mkName "Int")]) thing :: N thing = N X thing1 :: Int thing1 = f thing ghc-exactprint-0.6.2/tests/examples/ghc80/T10819_Lib.hs0000755000000000000000000000032507346545000020454 0ustar0000000000000000module T10819_Lib where import Language.Haskell.TH.Syntax doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv] where n = mkName s ghc-exactprint-0.6.2/tests/examples/ghc80/T10820.hs0000755000000000000000000000075207346545000017662 0ustar0000000000000000{-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MagicHash #-} module Main where import Language.Haskell.TH.Syntax import GHC.LanguageExtensions main = do print $(isExtEnabled Cpp >>= lift) print $(isExtEnabled LiberalTypeSynonyms >>= lift) print $(isExtEnabled RankNTypes >>= lift) print $(isExtEnabled TypeSynonymInstances >>= lift) print $(isExtEnabled MagicHash >>= lift) ghc-exactprint-0.6.2/tests/examples/ghc80/T10826.hs0000755000000000000000000000022107346545000017657 0ustar0000000000000000{-# LANGUAGE Safe #-} module Test (hook) where import System.IO.Unsafe {-# ANN hook (unsafePerformIO (putStrLn "Woops.")) #-} hook = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T10830.hs0000755000000000000000000000012507346545000017655 0ustar0000000000000000import GHC.OldList main :: IO () main = maximumBy compare [1..10000] `seq` return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10836.hs0000755000000000000000000000031207346545000017661 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T10836 where type family Foo a = r | r -> a where Foo Int = Int Foo Bool = Int type family Bar a = r | r -> a where Bar Int = Int Bar Bool = Int ghc-exactprint-0.6.2/tests/examples/ghc80/T10845.hs0000755000000000000000000000077607346545000017677 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} {-# OPTIONS_GHC -dcore-lint #-} import GHC.Stack f1 :: (?loc :: CallStack) => CallStack -- we can infer a CallStack for let-binders f1 = let y x = (?loc :: CallStack) in y 0 f2 :: (?loc :: CallStack) => CallStack -- but only when we would infer an IP. -- i.e. the monomorphism restriction prevents us -- from inferring a CallStack. f2 = let y = (?loc :: CallStack) in y main :: IO () main = do putStrLn $ prettyCallStack f1 putStrLn $ prettyCallStack f2 ghc-exactprint-0.6.2/tests/examples/ghc80/T10846.hs0000755000000000000000000000070007346545000017663 0ustar0000000000000000{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} module Main where import GHC.Stack f1 :: (?loc :: CallStack) => String f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc f2 :: (?loc :: CallStack) => _ f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc f3 :: (?loc :: CallStack, _) => String f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc main :: IO () main = do putStrLn f1 putStrLn f2 putStrLn f3 ghc-exactprint-0.6.2/tests/examples/ghc80/T10870.hs0000755000000000000000000000052707346545000017667 0ustar0000000000000000import Data.Bits import Data.Int import Data.Word unsafeShift32R :: (Bits a, Num a) => a -> a unsafeShift32R x = unsafeShiftR x 32 main :: IO () main = do print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ] print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ] print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ] ghc-exactprint-0.6.2/tests/examples/ghc80/T10890.hs0000755000000000000000000000064507346545000017672 0ustar0000000000000000module Main where -- Previously GHC was printing this warning: -- -- Main.hs:5:1: Warning: -- The import of ‘A.has’ from module ‘A’ is redundant -- -- Main.hs:6:1: Warning: -- The import of ‘B.has’ from module ‘B’ is redundant import A (A (has)) import B (B (has)) data Blah = Blah instance A Blah where has = Blah instance B Blah where has = Blah main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10890_1.hs0000755000000000000000000000065607346545000020114 0ustar0000000000000000module Main where import Base import Extends -- Previously GHC was giving this false positive: -- -- T10890_1.hs:4:1: Warning: -- The import of ‘Extends’ is redundant -- except perhaps to import instances from ‘Extends’ -- To import instances alone, use: import Extends() data Bar = Bar instance AClass Bar where has = Bar instance BClass Bar where has = Bar main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10890_2.hs0000755000000000000000000000056507346545000020114 0ustar0000000000000000module T10890_2 where -- Previously GHC was printing this warning: -- -- Main.hs:5:1: Warning: -- The import of ‘A.has’ from module ‘A’ is redundant -- -- Main.hs:6:1: Warning: -- The import of ‘B.has’ from module ‘B’ is redundant import T10890_2A (A (has)) import T10890_2B (B (has)) data Blah = Blah instance A Blah where has = Blah ghc-exactprint-0.6.2/tests/examples/ghc80/T10890_2A.hs0000755000000000000000000000006307346545000020206 0ustar0000000000000000module T10890_2A where class A a where has :: a ghc-exactprint-0.6.2/tests/examples/ghc80/T10890_2B.hs0000755000000000000000000000006307346545000020207 0ustar0000000000000000module T10890_2B where class B a where has :: a ghc-exactprint-0.6.2/tests/examples/ghc80/T10891.hs0000755000000000000000000000116607346545000017672 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module T10891 where import Language.Haskell.TH import System.IO class C a where f :: a -> Int class C' a where type F a :: * type F a = a f' :: a -> Int class C'' a where data Fd a :: * instance C' Int where type F Int = Bool f' = id instance C'' Int where data Fd Int = B Bool | C Char $(return []) test :: () test = $(let display :: Name -> Q () display q = do i <- reify q runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) in do display ''C display ''C' display ''C'' [| () |]) ghc-exactprint-0.6.2/tests/examples/ghc80/T10895.hs0000755000000000000000000000002507346545000017667 0ustar0000000000000000module NotMain where ghc-exactprint-0.6.2/tests/examples/ghc80/T10897a.hs0000755000000000000000000000014407346545000020034 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module T10897a where pattern Single :: a -> a pattern Single x = x ghc-exactprint-0.6.2/tests/examples/ghc80/T10897b.hs0000755000000000000000000000005707346545000020040 0ustar0000000000000000module B where import T10897a Single y = True ghc-exactprint-0.6.2/tests/examples/ghc80/T10904.hs0000755000000000000000000000114207346545000017657 0ustar0000000000000000import Control.Concurrent import Control.Monad import Foreign import Foreign.C.Types import System.Environment foreign import ccall safe "finalizerlib.h init_value" init_value :: Ptr CInt -> IO () foreign import ccall safe "finalizerlib.h &finalize_value" finalize_value :: FinalizerPtr CInt allocateValue :: IO () allocateValue = do fp <- mallocForeignPtrBytes 10000 withForeignPtr fp init_value addForeignPtrFinalizer finalize_value fp main :: IO () main = do [n] <- fmap (fmap read) getArgs _ <- forkIO (loop n) loop n where loop n = replicateM_ n allocateValue ghc-exactprint-0.6.2/tests/examples/ghc80/T10908.hs0000755000000000000000000000025107346545000017663 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-missing-exported-sigs #-} module Bug (Data.List.intercalate, x) where import qualified Data.List intercalate = True x :: Bool x = intercalate ghc-exactprint-0.6.2/tests/examples/ghc80/T10929.hs0000755000000000000000000000056407346545000017675 0ustar0000000000000000module T10929 where x1 :: [Integer] x1 = [5 .. 3] x2 :: [Integer] x2 = [3 .. 5] x3 :: [Integer] x3 = [5, 3 .. 1] x4 :: [Integer] x4 = [5, (3+0) .. 1] x5 :: [Integer] x5 = [1, 3 .. 5] x6 :: [Integer] x6 = [1, (3+0) .. 5] x7 :: [Integer] x7 = [5, 7 .. 1] x8 :: [Integer] x8 = [5, (7+0) .. 1] x9 :: [Integer] x9 = [3, 1 .. 5] x10 :: [Integer] x10 = [3, (1+0) .. 5] ghc-exactprint-0.6.2/tests/examples/ghc80/T10931.hs0000755000000000000000000000106707346545000017665 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall #-} module T10931 ( BugC(..) ) where data IdT f a = IdC (f a) class ( m ~ Outer m (Inner m) ) => BugC (m :: * -> *) where type Inner m :: * -> * type Outer m :: (* -> *) -> * -> * bug :: ( forall n. ( n ~ Outer n (Inner n) , Outer n ~ Outer m ) => Inner n a) -> m a instance BugC (IdT m) where type Inner (IdT m) = m type Outer (IdT m) = IdT bug f = IdC f ghc-exactprint-0.6.2/tests/examples/ghc80/T10935.hs0000755000000000000000000000014507346545000017665 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-} module T10935 where f x = let y = x+1 in (y,y) ghc-exactprint-0.6.2/tests/examples/ghc80/T10942.hs0000755000000000000000000000110007346545000017653 0ustar0000000000000000module Main where import DynFlags import GHC import Control.Monad.IO.Class (liftIO) import System.Environment import HeaderInfo import Outputable import StringBuffer main :: IO () main = do [libdir] <- getArgs runGhc (Just libdir) $ do dflags <- getSessionDynFlags let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream `gopt_set` Opt_Haddock filename = "T10942_A.hs" setSessionDynFlags dflags' stringBuffer <- liftIO $ hGetStringBuffer filename liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename)) ghc-exactprint-0.6.2/tests/examples/ghc80/T10942_A.hs0000755000000000000000000000044207346545000020123 0ustar0000000000000000{- A normal comment, to check if we can still pick up the CPP directive after it. -} -- Check that we can parse a file with leading comments -- ^ haddock -- * haddock -- | haddock -- $ haddock {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-} module T10942 where main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T10945.hs0000755000000000000000000000053607346545000017672 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10945 where import Language.Haskell.TH $$(return [ SigD (mkName "m") (ForallT [PlainTV (mkName "a")] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "m") [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []] ]) ghc-exactprint-0.6.2/tests/examples/ghc80/T10946.hs0000755000000000000000000000016107346545000017665 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10946 where import Language.Haskell.TH m :: a -> a m x = $$([||_||]) ghc-exactprint-0.6.2/tests/examples/ghc80/T10955dyn.hs0000755000000000000000000000017107346545000020401 0ustar0000000000000000module Main where import Foreign import Foreign.C.Types foreign import ccall "bar" dle :: IO CInt main = dle >>= print ghc-exactprint-0.6.2/tests/examples/ghc80/T10962.hs0000755000000000000000000000043107346545000017663 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module Main where import GHC.Base main :: IO () main = do -- Overflow. let (# w1, i1 #) = subWordC# 1## 3## print (W# w1, I# i1) -- No overflow. let (# w2, i2 #) = subWordC# 3## 1## print (W# w2, I# i2) ghc-exactprint-0.6.2/tests/examples/ghc80/T10970a.hs0000755000000000000000000000020507346545000020022 0ustar0000000000000000{-# LANGUAGE CPP #-} main = do #ifndef VERSION_containers putStrLn "OK" #endif #ifndef MIN_VERSION_base putStrLn "OK" #endif ghc-exactprint-0.6.2/tests/examples/ghc80/T10971a.hs0000755000000000000000000000035507346545000020031 0ustar0000000000000000{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} module T10971a where import Data.Traversable (fmapDefault) f = \x -> length x g = \f x -> fmapDefault f x h = \f x -> (fmapDefault f x, length x) ghc-exactprint-0.6.2/tests/examples/ghc80/T10971b.hs0000755000000000000000000000032307346545000020025 0ustar0000000000000000{-# LANGUAGE MonomorphismRestriction, NoExtendedDefaultRules #-} module T10971b where import Data.Traversable (fmapDefault) f = \x -> length x g = \f x -> fmapDefault f x h = \f x -> (fmapDefault f x, length x) ghc-exactprint-0.6.2/tests/examples/ghc80/T10971c.hs0000755000000000000000000000032307346545000020026 0ustar0000000000000000{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-} module T10971c where import Data.Traversable (fmapDefault) f = \x -> length x g = \f x -> fmapDefault f x h = \f x -> (fmapDefault f x, length x) ghc-exactprint-0.6.2/tests/examples/ghc80/T10971d.hs0000755000000000000000000000014707346545000020033 0ustar0000000000000000import T10971c main = do print $ f (Just 1) print $ g (+1) (Just 5) print $ h (const 5) Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/T10997.hs0000755000000000000000000000011507346545000017672 0ustar0000000000000000module T10997 where import T10997a foo :: Exp a -> String foo Tru = "True" ghc-exactprint-0.6.2/tests/examples/ghc80/T10997_1.hs0000755000000000000000000000046507346545000020122 0ustar0000000000000000module T10997_1 where import T10997_1a {- With ghc-7.10.2: The interface for ‘T10997a’ Declaration for Just' Pattern synonym Just': Iface type variable out of scope: k Cannot continue after interface file error -} bar :: (Showable a) => Maybe a -> Maybe a bar (Just' a) = Just' a ghc-exactprint-0.6.2/tests/examples/ghc80/T10997_1a.hs0000755000000000000000000000074207346545000020261 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-} module T10997_1a where import GHC.Exts type family Showable (a :: k) :: Constraint where Showable (a :: *) = (Show a) Showable a = () extractJust :: Maybe a -> (Bool, a) extractJust (Just a) = (True, a) extractJust _ = (False, undefined) pattern Just' :: Showable a => a -> (Maybe a) pattern Just' a <- (extractJust -> (True, a)) where Just' a = Just a ghc-exactprint-0.6.2/tests/examples/ghc80/T10997a.hs0000755000000000000000000000025607346545000020041 0ustar0000000000000000{-# LANGUAGE GADTs, PatternSynonyms #-} module T10997a where data Exp ty where LitB :: Bool -> Exp Bool pattern Tru :: () => b ~ Bool => Exp b pattern Tru = LitB True ghc-exactprint-0.6.2/tests/examples/ghc80/T10999.hs0000755000000000000000000000020707346545000017676 0ustar0000000000000000module T10999 where import qualified Data.Set as Set f :: _ => () -> _ f _ = Set.fromList undefined g = map fst $ Set.toList $ f () ghc-exactprint-0.6.2/tests/examples/ghc80/T11010.hs0000755000000000000000000000112007346545000017640 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax #-} module T11010 where data Expr a where Fun :: String -> (a -> b) -> (Expr a -> Expr b) pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b) pattern IntFun str f x = Fun str f x -- Alternative syntax for pattern synonyms: -- pattern -- Suc :: () => (a ~ Int) => Expr a -> Expr Int -- Suc n <- IntFun _ _ n where -- Suc n = IntFun "suc" (+ 1) n pattern Suc :: (a ~ Int) => Expr a -> Expr Int pattern Suc n <- IntFun _ _ n where Suc n = IntFun "suc" (+ 1) n ghc-exactprint-0.6.2/tests/examples/ghc80/T11016.hs0000755000000000000000000000022107346545000017647 0ustar0000000000000000{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-} module T11016 where f1 :: (?x :: Int, _) => Int f1 = ?x f2 :: (?x :: Int) => _ f2 = ?x ghc-exactprint-0.6.2/tests/examples/ghc80/T11039.hs0000755000000000000000000000017707346545000017666 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo () where data A a = A a pattern Q :: () => (A ~ f) => a -> f a pattern Q a = A a ghc-exactprint-0.6.2/tests/examples/ghc80/T11053.hs0000755000000000000000000000044107346545000017654 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} -- turn on with -fwarn-missing-pat-syn-sigs module Foo where -- Should warn because of missing signature pattern T = True pattern J a = Just a pattern J1 a <- Just a pattern J2{b} = Just b pattern J3{c} <- Just c pattern F :: Bool pattern F = False ghc-exactprint-0.6.2/tests/examples/ghc80/T11067.hs0000755000000000000000000000177407346545000017673 0ustar0000000000000000{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} module T11067 where import Data.Monoid import GHC.Exts (Constraint) type family Skolem (p :: k -> Constraint) :: k type family SkolemF (p :: k2 -> Constraint) (f :: k1 -> k2) :: k1 -- | A quantified constraint type Forall (p :: k -> Constraint) = p (Skolem p) type ForallF (p :: k2 -> Constraint) (f :: k1 -> k2) = p (f (SkolemF p f)) -- These work class ForallF Monoid t => Monoid1 t instance ForallF Monoid t => Monoid1 t class ForallF Monoid1 t => Monoid2 t instance ForallF Monoid1 t => Monoid2 t -- Changing f a ~ g a to, (Ord (f a), Ord (g a)), say, removes the error class (f a ~ g a) => H f g a instance (f a ~ g a) => H f g a -- This one gives a superclass cycle error. class Forall (H f g) => H1 f g instance Forall (H f g) => H1 f g ghc-exactprint-0.6.2/tests/examples/ghc80/T11071.hs0000755000000000000000000000210007346545000017646 0ustar0000000000000000module T11071 where import Data.List (lines) import qualified Data.Map as M () import qualified Data.IntMap as M () import qualified Data.IntMap as M () -- just to see if this confused the code import qualified Data.Ord as Ord hiding (Down) import qualified Data.Map as M' hiding (size, filter) import qualified Data.Map as M' hiding (size) import qualified Data.IntMap as M' hiding (size) import qualified System.IO as M' () -- unrelated ignore :: a -> IO () ignore = const (return ()) main = do ignore NoSuchModule.foo -- no such module ignore Data.List.foobar -- does not exist (one import) ignore M.foobar -- does not exist (two imports) ignore M'.foobar -- does not exist (three imports) ignore Data.List.sort -- needs import ignore Data.List.unlines -- needs import, similar to imported ignore M.size -- multiple modules to import from ignore M.valid -- only one module to import from ignore Ord.Down -- explicit hiding ignore M'.size -- hidden and/or missing in import list ghc-exactprint-0.6.2/tests/examples/ghc80/T11071a.hs0000755000000000000000000000100107346545000020006 0ustar0000000000000000module T11071 where import Data.List (lines) import Data.IntMap () import Data.Ord hiding (Down) import Prelude hiding (True) ignore :: a -> IO () ignore = const (return ()) main = do ignore intersperse -- missing in import list (one import) ignore foldl' -- missing in import list (two imports) ignore Down -- explicitly hidden ignore True -- explicitly hidden from prelude (not really special) ignore foobar -- genuinely out of scope ghc-exactprint-0.6.2/tests/examples/ghc80/T11076.hs0000755000000000000000000000055107346545000017663 0ustar0000000000000000{- Test case for a problem where GHC had incorrect strictness information for foreign calls with lifted arguments -} {-# OPTIONS_GHC -O0 #-} module Main where import T11076A import Control.Exception x :: Bool x = error "OK: x has been forced" main :: IO () main = print (testBool x) `catch` \(ErrorCall e) -> putStrLn e -- x should be forced ghc-exactprint-0.6.2/tests/examples/ghc80/T11076A.hs0000755000000000000000000000101407346545000017757 0ustar0000000000000000{-# OPTIONS_GHC -O #-} {-# LANGUAGE MagicHash, ForeignFunctionInterface, UnliftedFFITypes, GHCForeignImportPrim, BangPatterns #-} module T11076A where import GHC.Exts import Unsafe.Coerce {- If the demand type for the foreign call argument is incorrectly strict, the bang pattern can be optimized out -} testBool :: Bool -> Int testBool !x = I# (cmm_testPrim (unsafeCoerce x)) {-# INLINE testBool #-} foreign import prim "testPrim" cmm_testPrim :: Any -> Int# ghc-exactprint-0.6.2/tests/examples/ghc80/T11077.hs0000755000000000000000000000011207346545000017655 0ustar0000000000000000module T11077 (module X, foo) where import Data.List as X foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T11103.hs0000755000000000000000000000130407346545000017647 0ustar0000000000000000-- When using DuplicateRecordFields with TemplateHaskell, it is not possible to -- reify ambiguous names that are output by reifying field labels. -- See also overloadedrecflds/should_run/overloadedrecfldsrun04.hs {-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} import Language.Haskell.TH import Language.Haskell.TH.Syntax data R = MkR { foo :: Int, bar :: Int } data S = MkS { foo :: Int } $(do info <- reify ''R case info of TyConI (DataD _ _ _ [RecC _ [(foo_n, _, _), (bar_n, _, _)]] _) -> do { reify bar_n -- This is unambiguous ; reify foo_n -- This is ambiguous ; return [] } _ -> error "unexpected result of reify") ghc-exactprint-0.6.2/tests/examples/ghc80/T11112.hs0000755000000000000000000000007607346545000017654 0ustar0000000000000000module T11112 where sort :: Ord s -> [s] -> [s] sort xs = xs ghc-exactprint-0.6.2/tests/examples/ghc80/T11128.hs0000755000000000000000000000213207346545000017656 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# OPTIONS_GHC -fwarn-noncanonical-monad-instances #-} -- | Test noncanonical-monad-instances warnings module T11128 where import Control.Applicative as A import Control.Monad as M ---------------------------------------------------------------------------- -- minimal definition data T0 a = T0 a deriving Functor instance A.Applicative T0 where pure = T0 (<*>) = M.ap instance M.Monad T0 where (>>=) = undefined ---------------------------------------------------------------------------- -- trigger all 4 warnings data T1 a = T1 a deriving Functor instance A.Applicative T1 where pure = return (<*>) = M.ap (*>) = (M.>>) instance M.Monad T1 where (>>=) = undefined return = T1 (>>) = undefined ---------------------------------------------------------------------------- -- backward compat canonical defintion data T2 a = T2 a deriving Functor instance Applicative T2 where pure = T2 (<*>) = ap (*>) = undefined instance M.Monad T2 where (>>=) = undefined return = pure (>>) = (*>) ghc-exactprint-0.6.2/tests/examples/ghc80/T11136.hs0000755000000000000000000000015107346545000017654 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T11136 where class C a where type D a type instance D a x = x ghc-exactprint-0.6.2/tests/examples/ghc80/T11148.hs0000755000000000000000000000042107346545000017657 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} module T11148 where data family G a b c d data instance G Int b Float d = G deriving Functor data family H a b c d data instance H [b] b d c = H deriving Functor ghc-exactprint-0.6.2/tests/examples/ghc80/T11155.hs0000755000000000000000000000032207346545000017655 0ustar0000000000000000{-# OPTIONS_GHC -O -fno-full-laziness #-} module T11155 where foo :: Bool {-# NOINLINE foo #-} foo = error "rk" bar x = let t :: Char t = case foo of { True -> 'v'; False -> 'y' } in [t] ghc-exactprint-0.6.2/tests/examples/ghc80/T11164.hs0000755000000000000000000000005007346545000017653 0ustar0000000000000000module T11164 where import T11164b (T) ghc-exactprint-0.6.2/tests/examples/ghc80/T11164a.hs0000755000000000000000000000010407346545000020014 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T11164a where data family T a ghc-exactprint-0.6.2/tests/examples/ghc80/T11164b.hs0000755000000000000000000000013607346545000020022 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T11164b where import T11164a data instance T Int = MkT ghc-exactprint-0.6.2/tests/examples/ghc80/T11167.hs0000755000000000000000000000103607346545000017663 0ustar0000000000000000module T11167 where data SomeException newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} runContT' :: ContT r m a -> (a -> m r) -> m r runContT' = runContT catch_ :: IO a -> (SomeException -> IO a) -> IO a catch_ = undefined foo :: IO () foo = (undefined :: ContT () IO a) `runContT` (undefined :: a -> IO ()) `catch_` (undefined :: SomeException -> IO ()) foo' :: IO () foo' = (undefined :: ContT () IO a) `runContT'` (undefined :: a -> IO ()) `catch_` (undefined :: SomeException -> IO ()) ghc-exactprint-0.6.2/tests/examples/ghc80/T11167_ambig.hs0000755000000000000000000000121107346545000021015 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module T11167_ambig where data SomeException newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r} newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r} runContT' :: ContT r m a -> (a -> m r) -> m r runContT' = runContT catch_ :: IO a -> (SomeException -> IO a) -> IO a catch_ = undefined foo :: IO () foo = (undefined :: ContT () IO a) `runContT` (undefined :: a -> IO ()) `catch_` (undefined :: SomeException -> IO ()) foo' :: IO () foo' = (undefined :: ContT () IO a) `runContT'` (undefined :: a -> IO ()) `catch_` (undefined :: SomeException -> IO ()) ghc-exactprint-0.6.2/tests/examples/ghc80/T11167_ambiguous_fixity.hs0000755000000000000000000000024607346545000023334 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module T11167_ambiguous_fixity where import T11167_ambiguous_fixity_A import T11167_ambiguous_fixity_B x a = (a :: A) `foo` 0 ghc-exactprint-0.6.2/tests/examples/ghc80/T11167_ambiguous_fixity_A.hs0000755000000000000000000000024307346545000023571 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module T11167_ambiguous_fixity_A where data A = MkA { foo :: Int -> Int } data C = MkC { foo :: Int -> Int } infixr 3 `foo` ghc-exactprint-0.6.2/tests/examples/ghc80/T11167_ambiguous_fixity_B.hs0000755000000000000000000000013107346545000023566 0ustar0000000000000000module T11167_ambiguous_fixity_B where data B = MkB { foo :: Int -> Int } infixl 5 `foo` ghc-exactprint-0.6.2/tests/examples/ghc80/T11173.hs0000755000000000000000000000026307346545000017661 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module T11173 where import T11173a (A(..)) -- Check that the fixity declaration applied to the field 'foo' is used x b = b `foo` b `foo` 0 ghc-exactprint-0.6.2/tests/examples/ghc80/T11173a.hs0000755000000000000000000000041207346545000020016 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} module T11173a where data A = A { foo :: Int -> Int, bar :: Int -> Int } newtype B = B { foo :: Int -> Int } infixr 5 `foo` infixr 5 `bar` -- This is well-typed only if the fixity is correctly applied y b = b `bar` b `bar` 0 ghc-exactprint-0.6.2/tests/examples/ghc80/T11182.hs0000755000000000000000000000026207346545000017660 0ustar0000000000000000{-# LANGUAGE Strict #-} -- | Strict should imply StrictData module Main where data Lazy a = Lazy ~a main :: IO () main = case Lazy undefined of Lazy _ -> putStrLn "Lazy" ghc-exactprint-0.6.2/tests/examples/ghc80/T11187.hs0000755000000000000000000000054107346545000017665 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T11187 where import Data.Type.Coercion type family X coercionXX :: Coercion X X coercionXX = Coercion coercionXX1 :: Coercion X X coercionXX1 = c where c :: x ~ X => Coercion x x c = Coercion coercionXX2 :: Coercion X X coercionXX2 = c where c = Coercion ghc-exactprint-0.6.2/tests/examples/ghc80/T11192.hs0000755000000000000000000000035007346545000017657 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module T11192 where fails :: a fails = let go :: _ go 0 a = a in go (0 :: Int) undefined succeeds :: a succeeds = let go :: _ go _ a = a in go (0 :: Int) undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T11193.hs0000755000000000000000000000031007346545000017654 0ustar0000000000000000{-# LANGUAGE Strict #-} module Main where main = do ~a <- return (error "don't error here!") b <- return (error "error here!") -- this binding should be strict print "should never reach here" ghc-exactprint-0.6.2/tests/examples/ghc80/T11208.hs0000755000000000000000000000017407346545000017661 0ustar0000000000000000module T11208 where import qualified Prelude as P f n = n P.+ 1 g h (P.Just x) = P.Just (h x) g _ P.Nothing = P.Nothing ghc-exactprint-0.6.2/tests/examples/ghc80/T11216.hs0000755000000000000000000000014107346545000017652 0ustar0000000000000000{-# LANGUAGE RebindableSyntax #-} module Bug where foo :: (a, b) -> () foo x | (_,_) <- x = () ghc-exactprint-0.6.2/tests/examples/ghc80/T11224.hs0000755000000000000000000000117507346545000017661 0ustar0000000000000000{-# LANGUAGE PatternSynonyms , ViewPatterns #-} -- inlining a pattern synonym shouldn't change semantics import Text.Read -- pattern PRead :: () => Read a => a -> String pattern PRead a <- (readMaybe -> Just a) foo :: String -> Int foo (PRead x) = (x::Int) foo (PRead xs) = sum (xs::[Int]) foo _ = 666 bar :: String -> Int bar (readMaybe -> Just x) = (x::Int) bar (readMaybe -> Just xs) = sum (xs::[Int]) bar _ = 666 main :: IO () main = do print $ foo "1" -- 1 print $ foo "[1,2,3]" -- 666 -- ??? print $ foo "xxx" -- 666 print $ bar "1" -- 1 print $ bar "[1,2,3]" -- 6 print $ bar "xxx" -- 666 ghc-exactprint-0.6.2/tests/examples/ghc80/T11232.hs0000755000000000000000000000042207346545000017652 0ustar0000000000000000module T11232 where import Control.Monad import Data.Data mkMp :: ( MonadPlus m , Typeable a , Typeable b ) => (b -> m b) -> a -> m a mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext))) newtype M m x = M { unM :: x -> m x } ghc-exactprint-0.6.2/tests/examples/ghc80/T11237.hs0000755000000000000000000000037707346545000017670 0ustar0000000000000000{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} module TypeInTypeBug where import qualified Data.Kind data Works :: Data.Kind.Type where WorksConstr :: Works type Set = Data.Kind.Type data ShouldWork :: Set where ShouldWorkConstr :: ShouldWork ghc-exactprint-0.6.2/tests/examples/ghc80/T1133Aa.hs0000755000000000000000000000006307346545000020034 0ustar0000000000000000module T1133Aa where import {-# SOURCE #-} T1133A ghc-exactprint-0.6.2/tests/examples/ghc80/T1133a.hs0000755000000000000000000000006107346545000017731 0ustar0000000000000000module T1133a where import {-# SOURCE #-} T1133 ghc-exactprint-0.6.2/tests/examples/ghc80/T11381.hs0000755000000000000000000000037607346545000017667 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T11381 where -- ensure that this code does not compile without InjectiveTypeFamilies and that -- injectivity error is not reported. type family F a = r | r -> a type instance F Int = Bool type instance F Int = Char ghc-exactprint-0.6.2/tests/examples/ghc80/T11959.hs0000755000000000000000000000016007346545000017671 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Main where import T11959Lib (Vec2(..), pattern (:>)) main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T17a.hs0000755000000000000000000000035207346545000017574 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-top-binds #-} -- Trac #17 module Temp (foo, bar, quux) where top :: Int top = 1 foo :: () foo = let True = True in () bar :: Int -> Int bar match = 1 quux :: Int quux = let local = True in 2 ghc-exactprint-0.6.2/tests/examples/ghc80/T17b.hs0000755000000000000000000000035407346545000017577 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-local-binds #-} -- Trac #17 module Temp (foo, bar, quux) where top :: Int top = 1 foo :: () foo = let True = True in () bar :: Int -> Int bar match = 1 quux :: Int quux = let local = True in 2 ghc-exactprint-0.6.2/tests/examples/ghc80/T17c.hs0000755000000000000000000000035607346545000017602 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-pattern-binds #-} -- Trac #17 module Temp (foo, bar, quux) where top :: Int top = 1 foo :: () foo = let True = True in () bar :: Int -> Int bar match = 1 quux :: Int quux = let local = True in 2 ghc-exactprint-0.6.2/tests/examples/ghc80/T17d.hs0000755000000000000000000000035007346545000017575 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-matches #-} -- Trac #17 module Temp (foo, bar, quux) where top :: Int top = 1 foo :: () foo = let True = True in () bar :: Int -> Int bar match = 1 quux :: Int quux = let local = True in 2 ghc-exactprint-0.6.2/tests/examples/ghc80/T17e.hs0000755000000000000000000000034607346545000017603 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-binds #-} -- Trac #17 module Temp (foo, bar, quux) where top :: Int top = 1 foo :: () foo = let True = True in () bar :: Int -> Int bar match = 1 quux :: Int quux = let local = True in 2 ghc-exactprint-0.6.2/tests/examples/ghc80/T1830_1.hs0000755000000000000000000000014107346545000020013 0ustar0000000000000000module T1830_1 where import Language.Haskell.TH.Syntax (Lift) data Foo a = Foo a deriving Lift ghc-exactprint-0.6.2/tests/examples/ghc80/T1830_2.hs0000755000000000000000000000016707346545000020024 0ustar0000000000000000{-# LANGUAGE DeriveLift #-} module T1830_2 where import Language.Haskell.TH.Syntax (Lift) data Nothing deriving Lift ghc-exactprint-0.6.2/tests/examples/ghc80/T1830_3.hs0000755000000000000000000000056007346545000020022 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH.Syntax (lift) import T1830_3a main :: IO () main = do print ($(lift algDT1) == algDT1) print ($(lift algDT2) == algDT2) print ($(lift algDT3) == algDT3) print ($(lift prim) == prim) print ($(lift df1) == df1) print ($(lift df2) == df2) print ($(lift df3) == df3) ghc-exactprint-0.6.2/tests/examples/ghc80/T1830_3a.hs0000755000000000000000000000217507346545000020167 0ustar0000000000000000{-# LANGUAGE DeriveLift #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeFamilies #-} module T1830_3a where import GHC.Exts import Language.Haskell.TH.Syntax (Lift(..)) data AlgDT a b c = NormalCon a b | RecCon { recCon1 :: a, recCon2 :: b} | a :^: b deriving (Eq, Lift) data Prim = Prim Char# Double# Int# Float# Word# deriving (Eq, Lift) -- We can't test this for equality easily due to the unstable nature of -- primitive string literal equality. We include this anyway to ensure that -- deriving Lift for datatypes with Addr# in them does in fact work. data AddrHash = AddrHash Addr# deriving Lift data Empty deriving Lift data family DataFam a b c data instance DataFam Int b c = DF1 Int | DF2 b deriving (Eq, Lift) newtype instance DataFam Char b c = DF3 Char deriving (Eq, Lift) algDT1, algDT2, algDT3 :: AlgDT Int String () algDT1 = NormalCon 1 "foo" algDT2 = RecCon 2 "bar" algDT3 = 3 :^: "baz" prim :: Prim prim = Prim 'a'# 1.0## 1# 1.0# 1## df1, df2 :: DataFam Int Char () df1 = DF1 1 df2 = DF2 'a' df3 :: DataFam Char () () df3 = DF3 'b' ghc-exactprint-0.6.2/tests/examples/ghc80/T2006.hs0000755000000000000000000000046107346545000017574 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} {-# LANGUAGE GADTs #-} module T2006 where data Expr a vs where EPrim :: String -> a -> Expr a vs EVar :: Expr a (a,vs) interpret :: Expr a () -> a interpret (EPrim _ a) = a -- interpret EVar = error "unreachable" ghc-exactprint-0.6.2/tests/examples/ghc80/T2204.hs0000755000000000000000000000022707346545000017574 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T2204 where f :: String -> Int f "01" = 0 g :: Int -> Int g 0 = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/T2632.hs0000755000000000000000000000035107346545000017577 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- Trac #2632 module MkData where import Language.Haskell.TH op :: Num v => v -> v -> v op a b = a + b decl1 = [d| func = 0 `op` 3 |] decl2 = [d| op x y = x func = 0 `op` 3 |] ghc-exactprint-0.6.2/tests/examples/ghc80/T2931.hs0000755000000000000000000000011707346545000017601 0ustar0000000000000000-- Trac #2931 module Foo where a = 1 -- NB: no newline after the 'a'! b = 'a ghc-exactprint-0.6.2/tests/examples/ghc80/T2991.hs0000755000000000000000000000026107346545000017607 0ustar0000000000000000module Main where -- Test that there are actually entries in the .mix file for an imported -- literate module generated with --make. import T2991LiterateModule main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T3078.hs0000755000000000000000000000035507346545000017610 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T3078 where data T = A Int | B Int funny :: T -> Int funny t = n where n | A x <- t = x | B x <- t = x ghc-exactprint-0.6.2/tests/examples/ghc80/T322.hs0000755000000000000000000000107407346545000017514 0ustar0000000000000000{-# OPTIONS -fwarn-incomplete-patterns -fwarn-overlapping-patterns -Werror #-} module T322 where instance (Num a) => Num (Maybe a) where (Just a) + (Just b) = Just (a + b) _ + _ = Nothing (Just a) - (Just b) = Just (a - b) _ - _ = Nothing (Just a) * (Just b) = Just (a * b) _ * _ = Nothing negate (Just a) = Just (negate a) negate _ = Nothing abs (Just a) = Just (abs a) abs _ = Nothing signum (Just a) = Just (signum a) signum _ = Nothing fromInteger = Just . fromInteger f :: Maybe Int -> Int f 1 = 1 f Nothing = 2 f _ = 3 ghc-exactprint-0.6.2/tests/examples/ghc80/T3468a.hs0000755000000000000000000000006107346545000017746 0ustar0000000000000000module T3468a where import {-# SOURCE #-} T3468 ghc-exactprint-0.6.2/tests/examples/ghc80/T3572.hs0000755000000000000000000000033007346545000017600 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TemplateHaskellQuotes #-} -- Trac #3572 module Main where import Language.Haskell.TH import Language.Haskell.TH.Ppr main = putStrLn . pprint =<< runQ [d| data Void |] ghc-exactprint-0.6.2/tests/examples/ghc80/T365.hs0000755000000000000000000000014307346545000017517 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-} module Main where main = print "Hello World" ghc-exactprint-0.6.2/tests/examples/ghc80/T366.hs0000755000000000000000000000030707346545000017522 0ustar0000000000000000{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T366 where data T a where C1 :: T Char C2 :: T Float exhaustive :: T Char -> Char exhaustive C1 = ' ' ghc-exactprint-0.6.2/tests/examples/ghc80/T3927.hs0000755000000000000000000000036207346545000017611 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T3927 where data T a where T1 :: T Int T2 :: T Bool -- f1 is exhaustive f1 :: T a -> T a -> Bool f1 T1 T1 = True f1 T2 T2 = False ghc-exactprint-0.6.2/tests/examples/ghc80/T3927a.hs0000755000000000000000000000047307346545000017755 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} {-# LANGUAGE GADTs, TypeFamilies #-} module T3927a where type family F a type instance F a = () data Foo a where FooA :: Foo () FooB :: Foo Int f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted f _ FooA = () ghc-exactprint-0.6.2/tests/examples/ghc80/T4056.hs0000755000000000000000000000046407346545000017606 0ustar0000000000000000{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} {-# LANGUAGE TemplateHaskellQuotes #-} module T4056 where import Language.Haskell.TH astTest :: Q [Dec] astTest = [d| class C t where op :: [t] -> [t] op = undefined |] class D t where bop :: [t] -> [t] bop = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T4139.hs0000755000000000000000000000063407346545000017607 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module T4139 where data F a where FInt :: F Int FBool :: F Bool class Baz a where baz :: F a -> G a instance Baz Int where baz _ = GInt instance Baz Bool where baz _ = GBool data G a where GInt :: G Int GBool :: G Bool bar :: Baz a => F a -> () bar a@(FInt) = case baz a of GInt -> () -- GBool -> () bar _ = () ghc-exactprint-0.6.2/tests/examples/ghc80/T4169.hs0000755000000000000000000000036207346545000017610 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- Crashed GHC 6.12 module T4165 where import Language.Haskell.TH class Numeric a where fromIntegerNum :: a fromIntegerNum = undefined ast :: Q [Dec] ast = [d| instance Numeric Int |] ghc-exactprint-0.6.2/tests/examples/ghc80/T4170.hs0000755000000000000000000000025307346545000017577 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module T4170 where import Language.Haskell.TH class LOL a lol :: Q [Dec] lol = [d| instance LOL Int |] instance LOL Int ghc-exactprint-0.6.2/tests/examples/ghc80/T5001b.hs0000755000000000000000000000030307346545000017727 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} module T5001b where class GEnum a where genum :: [a] default genum :: [a] genum = undefined instance GEnum Int where {-# INLINE genum #-} ghc-exactprint-0.6.2/tests/examples/ghc80/T5333.hs0000755000000000000000000000134207346545000017601 0ustar0000000000000000{-# LANGUAGE Arrows, NoMonomorphismRestriction #-} module T5333 where import Prelude hiding ( id, (.) ) import Control.Arrow cc1 :: a e b -> a e b -> a e b cc1 = undefined -- With GHC < 7.10.1, the following compile failures occured: -- -- ghc: panic! (the 'impossible' happened) -- (GHC version 7.8.4 for x86_64-unknown-linux): -- mkCmdEnv Not found: base:GHC.Desugar.>>>{v 02V} -- 'g' fails to compile. g = proc (x, y, z) -> ((returnA -< x) &&& (returnA -< y) &&& (returnA -< z)) -- 'f' compiles: -- - without an infix declaration -- - with the infixl declaration -- and fails with the infixr declaration infixr 6 `cc1` -- infixl 6 `cc1` f = proc (x, y, z) -> ((returnA -< x) `cc1` (returnA -< y) `cc1` (returnA -< z)) ghc-exactprint-0.6.2/tests/examples/ghc80/T5721.hs0000755000000000000000000000016507346545000017604 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module T5371 where import Language.Haskell.TH f :: a -> Name f (x :: a) = ''a ghc-exactprint-0.6.2/tests/examples/ghc80/T5821.hs0000755000000000000000000000034207346545000017602 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module T5821 where type family T a type instance T Int = Bool foo :: Num a => a -> T a foo = undefined {-# SPECIALISE foo :: Int -> Bool #-} ghc-exactprint-0.6.2/tests/examples/ghc80/T5884Other.hs0000755000000000000000000000006007346545000020612 0ustar0000000000000000module T5884Other where data Pair a = Pair a a ghc-exactprint-0.6.2/tests/examples/ghc80/T5908.hs0000755000000000000000000000330407346545000017611 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE ExplicitForAll , GADTs , RebindableSyntax #-} module T5908 ( Writer , runWriter , execWriter , WriterT , runWriterT , execWriterT , tell ) where import Control.Category (Category (id), (>>>)) import Prelude hiding (Monad (..), id) import qualified Prelude newtype Identity a = Identity { runIdentity :: a } class Monad m where (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b return :: a -> m ex ex a fail :: String -> m e x a {-# INLINE (>>) #-} m >> k = m >>= \ _ -> k fail = error type Writer w = WriterT w Identity runWriter :: Writer w e x a -> (a, w e x) runWriter = runIdentity . runWriterT execWriter :: Writer w e x a -> w e x execWriter m = snd (runWriter m) newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) execWriterT m = do ~(_, w) <- runWriterT m return w where (>>=) = (Prelude.>>=) return = Prelude.return instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where return a = WriterT $ return (a, id) where return = Prelude.return m >>= k = WriterT $ do ~(a, w) <- runWriterT m ~(b, w') <- runWriterT (k a) return (b, w >>> w') where (>>=) = (Prelude.>>=) return = Prelude.return fail msg = WriterT $ fail msg where fail = Prelude.fail tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () tell w = WriterT $ return ((), w) where return = Prelude.return ghc-exactprint-0.6.2/tests/examples/ghc80/T6018.hs0000755000000000000000000001540107346545000017603 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} module T6018 where import T6018a -- defines G, identical to F type family F a b c = (result :: k) | result -> a b c type instance F Int Char Bool = Bool type instance F Char Bool Int = Int type instance F Bool Int Char = Char type instance G Bool Int Char = Char type family I (a :: k) b (c :: k) = r | r -> a b type instance I Int Char Bool = Bool type instance I Int Char Int = Bool type instance I Bool Int Int = Int -- this is injective - a type variable introduced in the LHS is not mentioned on -- RHS but we don't claim injectivity in that argument. type family J a (b :: k) = r | r -> a type instance J Int b = Char type MaybeSyn a = Maybe a newtype MaybeNew a = MaybeNew (Maybe a) -- make sure we look through type synonyms... type family K a = r | r -> a type instance K a = MaybeSyn a -- .. but not newtypes type family M a = r | r -> a type instance M (Maybe a) = MaybeSyn a type instance M (MaybeNew a) = MaybeNew a -- Closed type families -- these are simple conversions from open type families. They should behave the -- same type family FClosed a b c = result | result -> a b c where FClosed Int Char Bool = Bool FClosed Char Bool Int = Int FClosed Bool Int Char = Char type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where IClosed Int Char Bool = Bool IClosed Int Char Int = Bool IClosed Bool Int Int = Int type family JClosed a (b :: k) = r | r -> a where JClosed Int b = Char type family KClosed a = r | r -> a where KClosed a = MaybeSyn a -- Here the last equation might return both Int and Char but we have to -- recognize that it is not possible due to equation overlap type family Bak a = r | r -> a where Bak Int = Char Bak Char = Int Bak a = a -- This is similar, except that the last equation contains concrete type. Since -- it is overlapped it should be dropped with a warning type family Foo a = r | r -> a where Foo Int = Bool Foo Bool = Int Foo Bool = Bool -- this one was tricky in the early implementation of injectivity. Now it is -- identical to the above but we still keep it as a regression test. type family Bar a = r | r -> a where Bar Int = Bool Bar Bool = Int Bar Bool = Char -- Now let's use declared type families. All the below definitions should work -- No ambiguity for any of the arguments - all are injective f :: F a b c -> F a b c f x = x -- From 1st instance of F: a ~ Int, b ~ Char, c ~ Bool fapp :: Bool fapp = f True -- now the closed variant of F fc :: FClosed a b c -> FClosed a b c fc x = x fcapp :: Bool fcapp = fc True -- The last argument is not injective so it must be instantiated i :: I a b Int -> I a b Int i x = x -- From 1st instance of I: a ~ Int, b ~ Char iapp :: Bool iapp = i True -- again, closed variant of I ic :: IClosed a b Int -> IClosed a b Int ic x = x icapp :: Bool icapp = ic True -- Now we have to test weird closed type families: bak :: Bak a -> Bak a bak x = x bakapp1 :: Char bakapp1 = bak 'c' bakapp2 :: Double bakapp2 = bak 1.0 bakapp3 :: () bakapp3 = bak () foo :: Foo a -> Foo a foo x = x fooapp1 :: Bool fooapp1 = foo True bar :: Bar a -> Bar a bar x = x barapp1 :: Bool barapp1 = bar True barapp2 :: Int barapp2 = bar 1 -- Declarations below test more liberal RHSs of injectivity annotations: -- permiting variables to appear in different order than the one in which they -- were declared. type family H a b = r | r -> b a type family Hc a b = r | r -> b a where Hc a b = a b class Hcl a b where type Ht a b = r | r -> b a -- repeated tyvars in the RHS of injectivity annotation: no warnings or errors -- (consistent with behaviour for functional dependencies) type family Jx a b = r | r -> a a type family Jcx a b = r | r -> a a where Jcx a b = a b class Jcl a b where type Jt a b = r | r -> a a type family Kx a b = r | r -> a b b type family Kcx a b = r | r -> a b b where Kcx a b = a b class Kcl a b where type Kt a b = r | r -> a b b -- Declaring kind injectivity. Here we only claim that knowing the RHS -- determines the LHS kind but not the type. type family L (a :: k1) = (r :: k2) | r -> k1 where L 'True = Int L 'False = Int L Maybe = 3 L IO = 3 data KProxy (a :: *) = KProxy type family KP (kproxy :: KProxy k) = r | r -> k type instance KP ('KProxy :: KProxy Bool) = Int type instance KP ('KProxy :: KProxy *) = Char kproxy_id :: KP ('KProxy :: KProxy k) -> KP ('KProxy :: KProxy k) kproxy_id x = x kproxy_id_use = kproxy_id 'a' -- Now test some awkward cases from The Injectivity Paper. All should be -- accepted. type family Gx a type family Hx a type family Gi a = r | r -> a type instance Gi Int = Char type family Hi a = r | r -> a type family F2 a = r | r -> a type instance F2 [a] = [Gi a] type instance F2 (Maybe a) = Hi a -> Int type family F4 a = r | r -> a type instance F4 [a] = (Gx a, a, a, a) type instance F4 (Maybe a) = (Hx a, a, Int, Bool) type family G2 a b = r | r -> a b type instance G2 a Bool = (a, a) type instance G2 Bool b = (b, Bool) type family G6 a = r | r -> a type instance G6 [a] = [Gi a] type instance G6 Bool = Int g6_id :: G6 a -> G6 a g6_id x = x g6_use :: [Char] g6_use = g6_id "foo" -- A sole exception to "bare variables in the RHS" rule type family Id (a :: k) = (result :: k) | result -> a type instance Id a = a -- This makes sure that over-saturated type family applications at the top-level -- are accepted. type family IdProxy (a :: k) b = r | r -> a type instance IdProxy a b = (Id a) b -- make sure we look through type synonyms properly type IdSyn a = Id a type family IdProxySyn (a :: k) b = r | r -> a type instance IdProxySyn a b = (IdSyn a) b -- this has bare variable in the RHS but all LHS varaiables are also bare so it -- should be accepted type family Fa (a :: k) (b :: k) = (r :: k2) | r -> k type instance Fa a b = a -- Taken from #9587. This exposed a bug in the solver. type family Arr (repr :: * -> *) (a :: *) (b :: *) = (r :: *) | r -> repr a b class ESymantics repr where int :: Int -> repr Int add :: repr Int -> repr Int -> repr Int lam :: (repr a -> repr b) -> repr (Arr repr a b) app :: repr (Arr repr a b) -> repr a -> repr b te4 = let c3 = lam (\f -> lam (\x -> f `app` (f `app` (f `app` x)))) in (c3 `app` (lam (\x -> x `add` int 14))) `app` (int 0) -- This used to fail during development class Manifold' a where type Base a = r | r -> a project :: a -> Base a unproject :: Base a -> a id' :: forall a. ( Manifold' a ) => Base a -> Base a id' = project . unproject ghc-exactprint-0.6.2/tests/examples/ghc80/T6018Afail.hs0000755000000000000000000000027107346545000020537 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018Afail where type family G a b c = (result :: *) | result -> a b c type instance G Int Char Bool = Bool type instance G Char Bool Int = Int ghc-exactprint-0.6.2/tests/examples/ghc80/T6018Bfail.hs0000755000000000000000000000015607346545000020542 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018Bfail where type family H a b c = (result :: *) | result -> a b c ghc-exactprint-0.6.2/tests/examples/ghc80/T6018Cfail.hs0000755000000000000000000000022607346545000020541 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018Cfail where import T6018Bfail type instance H Int Char Bool = Bool type instance H Char Bool Int = Int ghc-exactprint-0.6.2/tests/examples/ghc80/T6018Dfail.hs0000755000000000000000000000016007346545000020537 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018Dfail where import T6018Bfail type instance H Bool Int Char = Int ghc-exactprint-0.6.2/tests/examples/ghc80/T6018a.hs0000755000000000000000000000043307346545000017743 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018a where import {-# SOURCE #-} T6018 -- test support for hs-boot files type family G a b c = (result :: *) | result -> a b c type instance G Int Char Bool = Bool type instance G Char Bool Int = Int type instance F Bool Int Char = Char ghc-exactprint-0.6.2/tests/examples/ghc80/T6018fail.hs0000755000000000000000000000747007346545000020446 0ustar0000000000000000{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds, MultiParamTypeClasses, FlexibleInstances #-} module T6018fail where import T6018Afail -- defines G, identical to F import T6018Cfail -- imports H from T6018Bfail, defines some equations for H import T6018Dfail -- imports H from T6018Bfail, defines conflicting eqns type family F a b c = (result :: *) | result -> a b c type instance F Int Char Bool = Bool type instance F Char Bool Int = Int type instance F Bool Int Char = Int type instance G Bool Int Char = Int type family I a b c = r | r -> a b type instance I Int Char Bool = Bool type instance I Int Int Int = Bool type instance I Bool Int Int = Int -- Id is injective... type family Id a = result | result -> a type instance Id a = a -- ...but despite that we disallow a call to Id type family IdProxy a = r | r -> a type instance IdProxy a = Id a data N = Z | S N -- P is not injective, although the user declares otherwise. This -- should be rejected on the grounds of calling a type family in the -- RHS. type family P (a :: N) (b :: N) = (r :: N) | r -> a b type instance P Z m = m type instance P (S n) m = S (P n m) -- this is not injective - not all injective type variables mentioned -- on LHS are mentioned on RHS type family J a b c = r | r -> a b type instance J Int b c = Char -- same as above, but tyvar is now nested inside a tycon type family K (a :: N) (b :: N) = (r :: N) | r -> a b type instance K (S n) m = S m -- Make sure we look through type synonyms to catch errors type MaybeSyn a = Id a type family L a = r | r -> a type instance L a = MaybeSyn a -- These should fail because given the RHS kind there is no way to determine LHS -- kind class PolyKindVarsC a where type PolyKindVarsF a = (r :: k) | r -> a instance PolyKindVarsC '[] where type PolyKindVarsF '[] = '[] type family PolyKindVars (a :: k0) = (r :: k1) | r -> a type instance PolyKindVars '[] = '[] -- This should fail because there is no way to determine k from the RHS type family Fc (a :: k) (b :: k) = r | r -> k type instance Fc a b = Int -- This should fail because there is no way to determine a, b and k from the RHS type family Gc (a :: k) (b :: k) = r | r -> a b type instance Gc a b = Int -- fails because injectivity is not compositional in this case type family F1 a = r | r -> a type instance F1 [a] = Maybe (GF1 a) type instance F1 (Maybe a) = Maybe (GF2 a) type family GF1 a = r | r -> a type instance GF1 Int = Bool type family GF2 a = r | r -> a type instance GF2 Int = Bool type family HF1 a type instance HF1 Bool = Bool type family W1 a = r | r -> a type instance W1 [a] = a type family W2 a = r | r -> a type instance W2 [a] = W2 a -- not injective because of infinite types type family Z1 a = r | r -> a type instance Z1 [a] = (a, a) type instance Z1 (Maybe b) = (b, [b]) type family G1 a = r | r -> a type instance G1 [a] = [a] type instance G1 (Maybe b) = [(b, b)] type family G3 a b = r | r -> b type instance G3 a Int = (a, Int) type instance G3 a Bool = (Bool, a) type family G4 a b = r | r -> a b type instance G4 a b = [a] type family G5 a = r | r -> a type instance G5 [a] = [GF1 a] -- GF1 injective type instance G5 Int = [Bool] type family G6 a = r | r -> a type instance G6 [a] = [HF1 a] -- HF1 not injective type instance G6 Bool = Int type family G7a a b (c :: k) = r | r -> a b type family G7 a b (c :: k) = r | r -> a b c type instance G7 a b c = [G7a a b c] class C a b where type FC a (b :: *) = r | r -> b type instance FC a b = b instance C Int Char where type FC Int Char = Bool -- this should fail because the default instance conflicts with one of the -- earlier instances instance C Int Bool {- where type FC Int Bool = Bool-} -- and this should fail because it violates "bare variable in the RHS" -- restriction instance C Char a ghc-exactprint-0.6.2/tests/examples/ghc80/T6018failclosed.hs0000755000000000000000000000455007346545000021634 0ustar0000000000000000{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, UndecidableInstances #-} module T6018failclosed where -- Id is injective... type family IdClosed a = result | result -> a where IdClosed a = a -- ...but despite that we disallow a call to Id type family IdProxyClosed (a :: *) = r | r -> a where IdProxyClosed a = IdClosed a data N = Z | S N -- PClosed is not injective, although the user declares otherwise. This -- should be rejected on the grounds of calling a type family in the -- RHS. type family PClosed (a :: N) (b :: N) = (r :: N) | r -> a b where PClosed Z m = m PClosed (S n) m = S (PClosed n m) -- this is not injective - not all injective type variables mentioned -- on LHS are mentioned on RHS type family JClosed a b c = r | r -> a b where JClosed Int b c = Char -- this is not injective - not all injective type variables mentioned -- on LHS are mentioned on RHS (tyvar is now nested inside a tycon) type family KClosed (a :: N) (b :: N) = (r :: N) | r -> a b where KClosed (S n) m = S m -- hiding a type family application behind a type synonym should be rejected type MaybeSynClosed a = IdClosed a type family LClosed a = r | r -> a where LClosed a = MaybeSynClosed a type family FClosed a b c = (result :: *) | result -> a b c where FClosed Int Char Bool = Bool FClosed Char Bool Int = Int FClosed Bool Int Char = Int type family IClosed a b c = r | r -> a b where IClosed Int Char Bool = Bool IClosed Int Int Int = Bool IClosed Bool Int Int = Int type family E2 (a :: Bool) = r | r -> a where E2 False = True E2 True = False E2 a = False -- This exposed a subtle bug in the implementation during development. After -- unifying the RHS of (1) and (2) the LHS substitution was done only in (2) -- which made it look like an overlapped equation. This is not the case and this -- definition should be rejected. The first two equations are here to make sure -- that the internal implementation does list indexing corrcectly (this is a bit -- tricky because the list is kept in reverse order). type family F a b = r | r -> a b where F Float IO = Float F Bool IO = Bool F a IO = IO a -- (1) F Char b = b Int -- (2) -- This should fail because there is no way to determine a, b and k from the RHS type family Gc (a :: k) (b :: k) = r | r -> k where Gc a b = Int ghc-exactprint-0.6.2/tests/examples/ghc80/T6018failclosed2.hs0000755000000000000000000000060407346545000021712 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T6018failclosed2 where -- this one is a strange beast. Last equation is unreachable and thus it is -- removed. It is then impossible to typecheck barapp and thus we generate an -- error type family Bar a = r | r -> a where Bar Int = Bool Bar Bool = Int Bar Bool = Char bar :: Bar a -> Bar a bar x = x barapp :: Char barapp = bar 'c' ghc-exactprint-0.6.2/tests/examples/ghc80/T6018rnfail.hs0000755000000000000000000000242407346545000021000 0ustar0000000000000000{-# LANGUAGE TypeFamilies, PolyKinds #-} module T6018rnfail where -- IA = injectivity annotation `| foo -> bar` -- use incorrect tyvar in LHS of IA type family F a = r | a -> a type family Fc a = r | a -> a where Fc a = a class Fcl a where type Ft a = r | a -> a -- declare result tyvar to be duplicate (without IA) type family G a = a type family Gc a = a where Gc a = a -- declare result tyvar to be duplicate (with IA) type family Gb a = a | a -> a type family Gcb a = a | a -> a where Gcb a = a class Gclb a where -- here we want two errors type Gtb a = a | a -> a -- not in-scope tyvar in RHS of IA type family I a b = r | r -> c type family Ic a b = r | r -> c where Ic a b = a class Icl a b where type It a b = r | r -> c -- not in-scope tyvar in LHS of IA type family L a b = r | c -> a type family Lc a b = r | c -> a where Lc a b = a class Lcl a b where type Lt a b = r | c -> a -- result variable shadows variable in class head class M a b where type Mt b = a | a -> b -- here b is out-of-scope class N a b where type Nt a = r | r -> a b -- result is out of scope. Not possible for associated types type family O1 a | r -> a type family Oc1 a | r -> a where Oc1 a = a type family O2 a :: * | r -> a type family Oc2 a :: * | r -> a where Oc2 a = a ghc-exactprint-0.6.2/tests/examples/ghc80/T6018th.hs0000755000000000000000000001005607346545000020140 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances, PolyKinds #-} module T6018th where import Language.Haskell.TH -- Test that injectivity works correct with TH. This test is not as exhaustive -- as the original T6018 test. -- type family F a b c = (result :: k) | result -> a b c -- type instance F Int Char Bool = Bool -- type instance F Char Bool Int = Int -- type instance F Bool Int Char = Char $( return [ OpenTypeFamilyD (mkName "F") [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) (Just $ InjectivityAnn (mkName "result") [(mkName "a"), (mkName "b"), (mkName "c") ]) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") , ConT (mkName "Int")] ( ConT (mkName "Int"))) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Char")] ( ConT (mkName "Char"))) ] ) -- this is injective - a type variables mentioned on LHS is not mentioned on RHS -- but we don't claim injectivity in that argument. -- -- type family J a (b :: k) = r | r -> a ---type instance J Int b = Char $( return [ OpenTypeFamilyD (mkName "J") [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [mkName "a"]) , TySynInstD (mkName "J") (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] ( ConT (mkName "Int"))) ] ) -- Closed type families -- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where -- IClosed Int Char Bool = Bool -- IClosed Int Char Int = Bool -- IClosed Bool Int Int = Int $( return [ ClosedTypeFamilyD (mkName "I") [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT , KindedTV (mkName "c") StarT ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]) [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool")) , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Int")] ( ConT (mkName "Bool")) , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Int")) ] ] ) -- reification test $( do { decl@([ClosedTypeFamilyD _ _ _ (Just inj) _]) <- [d| type family Bak a = r | r -> a where Bak Int = Char Bak Char = Int Bak a = a |] ; return decl } ) -- Check whether incorrect injectivity declarations are caught -- type family I a b c = r | r -> a b -- type instance I Int Char Bool = Bool -- type instance I Int Int Int = Bool -- type instance I Bool Int Int = Int $( return [ OpenTypeFamilyD (mkName "H") [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b") ]) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Int"))) ] ) ghc-exactprint-0.6.2/tests/examples/ghc80/T6062.hs0000755000000000000000000000011707346545000017600 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module T6062 where x = [| False True |] ghc-exactprint-0.6.2/tests/examples/ghc80/T6124.hs0000755000000000000000000000031507346545000017577 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module T6124 where newtype A = MkA Int newtype B = MkB Char data T a where A :: T A B :: T B f :: T A -> A f A = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T7411.hs0000755000000000000000000000016107346545000017576 0ustar0000000000000000import Control.Exception import Control.DeepSeq main = evaluate (('a' : undefined) `deepseq` return () :: IO ()) ghc-exactprint-0.6.2/tests/examples/ghc80/T7669a.hs0000755000000000000000000000022107346545000017753 0ustar0000000000000000{-# LANGUAGE EmptyCase #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} module T7669 where data Void foo :: Void -> () foo x = case x of {} ghc-exactprint-0.6.2/tests/examples/ghc80/T7672.hs0000755000000000000000000000010107346545000017601 0ustar0000000000000000module T7672 where import qualified T7672a as XX data T = S XX.T ghc-exactprint-0.6.2/tests/examples/ghc80/T7672a.hs0000755000000000000000000000011207346545000017744 0ustar0000000000000000module T7672a(Decl.T) where import {-# SOURCE #-} qualified T7672 as Decl ghc-exactprint-0.6.2/tests/examples/ghc80/T7765.hs0000755000000000000000000000002207346545000017606 0ustar0000000000000000module Main where ghc-exactprint-0.6.2/tests/examples/ghc80/T7788.hs0000755000000000000000000000052207346545000017620 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module T7788 where data Proxy a = Proxy foo :: Proxy (F (Fix Id)) -> () foo = undefined newtype Fix a = Fix (a (Fix a)) newtype Id a = Id a type family F a type instance F (Fix a) = F (a (Fix a)) type instance F (Id a) = F a main :: IO () main = print $ foo Proxy ghc-exactprint-0.6.2/tests/examples/ghc80/T8030.hs0000755000000000000000000000036607346545000017603 0ustar0000000000000000{-# LANGUAGE PolyKinds, FlexibleContexts, TypeFamilies #-} module T8030 where -- The types of op1 and op2 are both ambiguous -- and should be reported as such class C (a :: k) where type Pr a :: * op1 :: Pr a op2 :: Pr a -> Pr a -> Pr a ghc-exactprint-0.6.2/tests/examples/ghc80/T8034.hs0000755000000000000000000000014107346545000017576 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T8034 where class C a where type F a foo :: F a -> F a ghc-exactprint-0.6.2/tests/examples/ghc80/T8101b.hs0000755000000000000000000000012607346545000017736 0ustar0000000000000000 module A where data ABC = A | B | C abc :: ABC -> Int abc x = case x of A -> 1 ghc-exactprint-0.6.2/tests/examples/ghc80/T8131b.hs0000755000000000000000000000041407346545000017741 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} import GHC.Prim import GHC.IO main = IO $ \s -> let (# s1, p0 #) = newByteArray# 10# s (# s2, p #) = unsafeFreezeByteArray# p0 s1 (# s3, q #) = newByteArray# 10# s2 in (# copyByteArray# p 0# q 0# 10# s, () #) ghc-exactprint-0.6.2/tests/examples/ghc80/T8274.hs0000755000000000000000000000034207346545000017607 0ustar0000000000000000{-# LANGUAGE MagicHash #-} module T8274 where import GHC.Prim data P = Positives Int# Float# Double# Char# Word# data N = Negatives Int# Float# Double# p = Positives 42# 4.23# 4.23## '4'# 4## n = Negatives -4# -4.0# -4.0## ghc-exactprint-0.6.2/tests/examples/ghc80/T8455.hs0000755000000000000000000000014507346545000017611 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE DataKinds #-} module T8455 where ty = [t| 5 |] ghc-exactprint-0.6.2/tests/examples/ghc80/T8550.hs0000755000000000000000000000045607346545000017612 0ustar0000000000000000{-# LANGUAGE TypeFamilies, GADTs, UndecidableInstances #-} module T8550 where type family F a type instance F () = F () data A where A :: F () ~ () => A x :: A x = A main :: IO () main = seq A (return ()) -- Note: This worked in GHC 7.8, but I (Richard E) think this regression -- is acceptable. ghc-exactprint-0.6.2/tests/examples/ghc80/T8555.hs0000755000000000000000000000017207346545000017612 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module T8555 where import Data.Coerce foo :: Coercible [a] [b] => a -> b foo = coerce ghc-exactprint-0.6.2/tests/examples/ghc80/T8633.hs0000755000000000000000000000113607346545000017610 0ustar0000000000000000module Main where import Language.Haskell.TH.Syntax t1 = case mkName "^.." of Name (OccName ".") (NameQ (ModName "^")) -> error "bug0" Name (OccName "^..") NameS -> return () t2 = case mkName "Control.Lens.^.." of Name (OccName ".") (NameQ (ModName "Control.Lens.^")) -> error "bug1" Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return () t3 = case mkName "Data.Bits..&." of Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return () t4 = case mkName "abcde" of Name (OccName "abcde") NameS -> return () main :: IO () main = do t1; t2; t3; t4 ghc-exactprint-0.6.2/tests/examples/ghc80/T8743a.hs0000755000000000000000000000006407346545000017752 0ustar0000000000000000module T8743a where import {-# SOURCE #-} T8743 () ghc-exactprint-0.6.2/tests/examples/ghc80/T8759a.hs0000755000000000000000000000017507346545000017764 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE PatternSynonyms #-} module T8759a where foo = [d| pattern Q = False |] ghc-exactprint-0.6.2/tests/examples/ghc80/T8799.hs0000755000000000000000000000027707346545000017632 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module T8555 where import Data.Coerce foo :: Coercible a b => b -> a foo = coerce bar :: (Coercible a b, Coercible b c) => b -> c -> a bar b c = coerce c ghc-exactprint-0.6.2/tests/examples/ghc80/T8970.hs0000755000000000000000000000073507346545000017620 0ustar0000000000000000{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T8970 where data K = Foo | Bar data D1 :: K -> * where F1 :: D1 Foo B1 :: D1 Bar class C (a :: K -> *) where data D2 a :: K -> * foo :: a k -> D2 a k -> Bool instance C D1 where data D2 D1 k where F2 :: D2 D1 Foo B2 :: D2 D1 Bar foo F1 F2 = True foo B1 B2 = True ghc-exactprint-0.6.2/tests/examples/ghc80/T9015.hs0000755000000000000000000000261407346545000017605 0ustar0000000000000000module Main where import GHC import DynFlags import System.Environment import GhcMonad testStrings = [ "import Data.Maybe" , "import qualified Data.Maybe" , "import Data.Maybe (isJust)" , "add a b = a+b" , "data Foo = Foo String" , "deriving instance Show Foo" , "{-# NOVECTORISE foo #-}" , "{-# WARNING Foo \"Just a warning\" #-}" , "{-# ANN foo (Just \"Hello\") #-}" , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}" , "class HasString a where\n\ \ update :: a -> (String -> String) -> a\n\ \ upcase :: a -> a\n\ \ upcase x = update x (fmap toUpper)\n\ \ content :: a -> String\n\ \ default content :: Show a => a -> String\n\ \ content = show" , "instance HasString Foo where\n\ \ update (Foo s) f = Foo (f s)\n\ \ content (Foo s) = s" , "add a b" , "let foo = add a b" , "x <- foo y" , "5 + 8" , "a <-" , "2 +" , "@#" ] main = do [libdir] <- getArgs runGhc (Just libdir) $ do liftIO (putStrLn "Is import:") testWithParser isImport liftIO (putStrLn "Is declaration:") testWithParser isDecl liftIO (putStrLn "Is statement:") testWithParser isStmt where testWithParser parser = do dflags <- getSessionDynFlags liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings testExpr parser expr = do expr ++ ": " ++ show (parser expr) ghc-exactprint-0.6.2/tests/examples/ghc80/T9017.hs0000755000000000000000000000015007346545000017600 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} module T9017 where import Control.Arrow foo :: a b (m b) foo = arr return ghc-exactprint-0.6.2/tests/examples/ghc80/T9177a.hs0000755000000000000000000000005507346545000017754 0ustar0000000000000000module T9177a where foo3 = bar foo4 = Fun ghc-exactprint-0.6.2/tests/examples/ghc80/T9204a.hs0000755000000000000000000000006007346545000017737 0ustar0000000000000000module T9204a where import {-# SOURCE #-} T9204 ghc-exactprint-0.6.2/tests/examples/ghc80/T9204b.hs0000755000000000000000000000006207346545000017742 0ustar0000000000000000module T9204b where import T9204b2 data P a = P ghc-exactprint-0.6.2/tests/examples/ghc80/T9204b2.hs0000755000000000000000000000006307346545000020025 0ustar0000000000000000module T9204b2 where import {-# SOURCE #-} T9204b ghc-exactprint-0.6.2/tests/examples/ghc80/T9233.hs0000755000000000000000000000045707346545000017612 0ustar0000000000000000module T9233 where import T9233a import Data.Functor.Identity upds :: (Monad m) => [String -> Options -> m Options] upds = [ \a o -> return o { flags = (flags o) { f1 = splitComma a ++ " " ++ f1 (flags o) } } ] setAll :: Options -> Options setAll _ = (getOpt upds :: Identity ()) `seq` undefined ghc-exactprint-0.6.2/tests/examples/ghc80/T9233a.hs0000755000000000000000000000375607346545000017760 0ustar0000000000000000module T9233a where data X = X { f1 :: String, f2 :: !Bool, f3 :: !Bool, f4 :: !Bool, f5 :: !Bool, f6 :: !Bool, f7 :: !Bool, f8 :: !Bool, f9 :: !Bool, f10 :: !Bool, f11 :: !Bool, f12 :: !Bool, f13 :: !Bool, f14 :: !Bool, f15 :: !Bool, f16 :: !Bool, f17 :: !Bool, f18 :: !Bool, f19 :: !Bool, f20 :: !Bool, f21 :: !Bool, f22 :: !Bool, f23 :: !Bool, f24 :: !Bool, f25 :: !Bool, f26 :: !Bool, f27 :: !Bool, f28 :: !Bool, f29 :: !Bool, f30 :: !Bool, f31 :: !Bool, f32 :: !Bool, f33 :: !Bool, f34 :: !Bool, f35 :: !Bool, f36 :: !Bool, f37 :: !Bool, f38 :: !Bool, f39 :: !Bool, f40 :: !Bool, f41 :: !Bool, f42 :: !Bool, f43 :: !Bool, f44 :: !Bool, f45 :: !Bool, f46 :: !Bool, f47 :: !Bool, f48 :: !Bool, f49 :: !Bool, f50 :: !Bool, f51 :: !Bool, f52 :: !Bool, f53 :: !Bool, f54 :: !Bool, f55 :: !Bool, f56 :: !Bool, f57 :: !Bool, f58 :: !Bool, f59 :: !Bool, f60 :: !Bool, f61 :: !Bool, f62 :: !Bool, f63 :: !Bool, f64 :: !Bool, f65 :: !Bool, f66 :: !Bool, f67 :: !Bool, f68 :: !Bool, f69 :: !Bool, f70 :: !Bool, f71 :: !Bool, f72 :: !Bool, f73 :: !Bool, f74 :: !Bool, f75 :: !Bool, f76 :: !Bool, f77 :: !Bool, f78 :: !Bool, f79 :: !Bool, f80 :: !Bool, f81 :: !Bool, f82 :: !Bool, f83 :: !Bool, f84 :: !Bool, f85 :: !Bool, f86 :: !Bool, f87 :: !Bool, f88 :: !Bool, f89 :: !Bool, f90 :: !Bool, f91 :: !Bool, f92 :: !Bool, f93 :: !Bool, f94 :: !Bool, f95 :: !Bool, f96 :: !Bool, f97 :: !Bool, f98 :: !Bool, f99 :: !Bool, f100 :: !Bool } data Options = Options { flags :: !X, o2 :: !Bool, o3 :: !Bool, o4 :: !Bool, o5 :: !Bool, o6 :: !Bool, o7 :: !Bool, o8 :: !Bool, o9 :: !Bool, o10 :: !Bool, o11 :: !Bool, o12 :: !Bool } splitComma :: String -> String splitComma _ = "a" {-# NOINLINE splitComma #-} getOpt :: Monad m => [String -> Options -> m Options] -> m () getOpt _ = return () {-# NOINLINE getOpt #-} ghc-exactprint-0.6.2/tests/examples/ghc80/T9238.hs0000755000000000000000000000103207346545000017605 0ustar0000000000000000compareDouble :: Double -> Double -> Ordering compareDouble x y = case (isNaN x, isNaN y) of (True, True) -> EQ (True, False) -> LT (False, True) -> GT (False, False) -> -- Make -0 less than 0 case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of (True, True, True, False) -> LT (True, True, False, True) -> GT _ -> x `compare` y main = do let l = [-0, 0] print [ (x, y, compareDouble x y) | x <- l, y <- l ] ghc-exactprint-0.6.2/tests/examples/ghc80/T9260.hs0000755000000000000000000000153007346545000017603 0ustar0000000000000000{-# LANGUAGE DataKinds, TypeOperators, GADTs #-} module T9260 where import GHC.TypeLits data Fin n where Fzero :: Fin (n + 1) Fsucc :: Fin n -> Fin (n + 1) test :: Fin 1 test = Fsucc Fzero {- Only the second error is legitimate. % ghc --version The Glorious Glasgow Haskell Compilation System, version 7.8.2 % ghc -ignore-dot-ghci /tmp/Error.hs [1 of 1] Compiling Error ( /tmp/Error.hs, /tmp/Error.o ) /tmp/Error.hs:12:8: Couldn't match type ‘0’ with ‘1’ Expected type: Fin 1 Actual type: Fin (0 + 1) In the expression: Fsucc Fzero In an equation for ‘test’: test = Fsucc Fzero /tmp/Error.hs:12:14: Couldn't match type ‘1’ with ‘0’ Expected type: Fin 0 Actual type: Fin (0 + 1) In the first argument of ‘Fsucc’, namely ‘Fzero’ In the expression: Fsucc Fzero -} ghc-exactprint-0.6.2/tests/examples/ghc80/T9430.hs0000755000000000000000000001323107346545000017603 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} module Main where import GHC.Exts checkI :: (Int, Int) -- ^ expected results -> (Int# -> Int# -> (# Int#, Int# #)) -- ^ primop -> Int -- ^ first argument -> Int -- ^ second argument -> Maybe String -- ^ maybe error checkI (expX, expY) op (I# a) (I# b) = case op a b of (# x, y #) | I# x == expX && I# y == expY -> Nothing | otherwise -> Just $ "Expected " ++ show expX ++ " and " ++ show expY ++ " but got " ++ show (I# x) ++ " and " ++ show (I# y) checkW :: (Word, Word) -- ^ expected results -> (Word# -> Word# -> (# Word#, Word# #)) -- ^ primop -> Word -- ^ first argument -> Word -- ^ second argument -> Maybe String -- ^ maybe error checkW (expX, expY) op (W# a) (W# b) = case op a b of (# x, y #) | W# x == expX && W# y == expY -> Nothing | otherwise -> Just $ "Expected " ++ show expX ++ " and " ++ show expY ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) checkW2 :: (Word, Word) -- ^ expected results -> (Word# -> Word# -> Word# -> (# Word#, Word# #)) -- ^ primop -> Word -- ^ first argument -> Word -- ^ second argument -> Word -- ^ third argument -> Maybe String -- ^ maybe error checkW2 (expX, expY) op (W# a) (W# b) (W# c) = case op a b c of (# x, y #) | W# x == expX && W# y == expY -> Nothing | otherwise -> Just $ "Expected " ++ show expX ++ " and " ++ show expY ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y) check :: String -> Maybe String -> IO () check s (Just err) = error $ "Error for " ++ s ++ ": " ++ err check _ Nothing = return () main :: IO () main = do -- First something trivial check "addIntC# maxBound 0" $ checkI (maxBound, 0) addIntC# maxBound 0 check "addIntC# 0 maxBound" $ checkI (maxBound, 0) addIntC# 0 maxBound -- Overflows check "addIntC# maxBound 1" $ checkI (minBound, 1) addIntC# maxBound 1 check "addIntC# 1 maxBound" $ checkI (minBound, 1) addIntC# 1 maxBound check "addIntC# maxBound 2" $ checkI (minBound + 1, 1) addIntC# maxBound 2 check "addIntC# 2 maxBound" $ checkI (minBound + 1, 1) addIntC# 2 maxBound check "addIntC# minBound minBound" $ checkI (0, 1) addIntC# minBound minBound -- First something trivial check "subIntC# minBound 0" $ checkI (minBound, 0) subIntC# minBound 0 -- Overflows check "subIntC# minBound 1" $ checkI (maxBound, 1) subIntC# minBound 1 check "subIntC# minBound 1" $ checkI (maxBound - 1, 1) subIntC# minBound 2 check "subIntC# 0 minBound" $ checkI (minBound, 1) subIntC# 0 minBound check "subIntC# -1 minBound" $ checkI (maxBound, 0) subIntC# (-1) minBound check "subIntC# minBound -1" $ checkI (minBound + 1, 0) subIntC# minBound (-1) -- First something trivial (note that the order of results is different!) check "plusWord2# maxBound 0" $ checkW (0, maxBound) plusWord2# maxBound 0 check "plusWord2# 0 maxBound" $ checkW (0, maxBound) plusWord2# 0 maxBound -- Overflows check "plusWord2# maxBound 1" $ checkW (1, minBound) plusWord2# maxBound 1 check "plusWord2# 1 maxBound" $ checkW (1, minBound) plusWord2# 1 maxBound check "plusWord2# maxBound 2" $ checkW (1, minBound + 1) plusWord2# maxBound 2 check "plusWord2# 2 maxBound" $ checkW (1, minBound + 1) plusWord2# 2 maxBound check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0 check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1 check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound -- Overflows check "timesWord2# " $ checkW (1, 0) timesWord2# (2 ^ 63) 2 check "timesWord2# " $ checkW (2, 0) timesWord2# (2 ^ 63) (2 ^ 2) check "timesWord2# " $ checkW (4, 0) timesWord2# (2 ^ 63) (2 ^ 3) check "timesWord2# " $ checkW (8, 0) timesWord2# (2 ^ 63) (2 ^ 4) check "timesWord2# maxBound 2" $ checkW (1, maxBound - 1) timesWord2# maxBound 2 check "timesWord2# 2 maxBound" $ checkW (1, maxBound - 1) timesWord2# 2 maxBound check "timesWord2# maxBound 3" $ checkW (2, maxBound - 2) timesWord2# maxBound 3 check "timesWord2# 3 maxBound" $ checkW (2, maxBound - 2) timesWord2# 3 maxBound check "quotRemWord2# 0 0 1" $ checkW2 (0, 0) quotRemWord2# 0 0 1 check "quotRemWord2# 0 4 2" $ checkW2 (2, 0) quotRemWord2# 0 4 2 check "quotRemWord2# 0 7 3" $ checkW2 (2, 1) quotRemWord2# 0 7 3 check "quotRemWord2# 1 0 (2 ^ 63)" $ checkW2 (2, 0) quotRemWord2# 1 0 (2 ^ 63) check "quotRemWord2# 1 1 (2 ^ 63)" $ checkW2 (2, 1) quotRemWord2# 1 1 (2 ^ 63) check "quotRemWord2# 1 0 maxBound" $ checkW2 (1, 1) quotRemWord2# 1 0 maxBound check "quotRemWord2# 2 0 maxBound" $ checkW2 (2, 2) quotRemWord2# 2 0 maxBound check "quotRemWord2# 1 maxBound maxBound" $ checkW2 (2, 1) quotRemWord2# 1 maxBound maxBound check "quotRemWord2# (2 ^ 63) 0 maxBound" $ checkW2 (2 ^ 63, 2 ^ 63) quotRemWord2# (2 ^ 63) 0 maxBound check "quotRemWord2# (2 ^ 63) maxBound maxBound" $ checkW2 (2 ^ 63 + 1, 2 ^ 63) quotRemWord2# (2 ^ 63) maxBound maxBound ghc-exactprint-0.6.2/tests/examples/ghc80/T9554.hs0000755000000000000000000000035307346545000017613 0ustar0000000000000000{-# LANGUAGE TypeFamilies, UndecidableInstances #-} module T9554 where import Data.Proxy type family F a where F a = F (F a) foo :: Proxy (F Bool) -> Proxy (F Int) foo x = x main = case foo Proxy of Proxy -> putStrLn "Made it!" ghc-exactprint-0.6.2/tests/examples/ghc80/T9600-1.hs0000755000000000000000000000017307346545000017741 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} import Control.Applicative newtype Foo a = Foo (a -> a) deriving Applicative ghc-exactprint-0.6.2/tests/examples/ghc80/T9600.hs0000755000000000000000000000011607346545000017600 0ustar0000000000000000import Control.Applicative newtype Foo a = Foo (a -> a) deriving Applicative ghc-exactprint-0.6.2/tests/examples/ghc80/T9824.hs0000755000000000000000000000017207346545000017612 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} {-# OPTIONS_GHC -fwarn-unused-matches #-} module T9824 where foo = [p| (x, y) |] ghc-exactprint-0.6.2/tests/examples/ghc80/T9839_02.hs0000755000000000000000000000006207346545000020117 0ustar0000000000000000module Main where main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9839_03.hs0000755000000000000000000000006207346545000020120 0ustar0000000000000000module Main where main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9839_04.hs0000755000000000000000000000006207346545000020121 0ustar0000000000000000module Main where main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9839_05.hs0000755000000000000000000000006207346545000020122 0ustar0000000000000000module Main where main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9839_06.hs0000755000000000000000000000006207346545000020123 0ustar0000000000000000module Main where main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9840.hs0000755000000000000000000000025007346545000017605 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T9840 where import T9840a type family X :: * -> * where type family F (a :: * -> *) where foo :: G (F X) -> G (F X) foo x = x ghc-exactprint-0.6.2/tests/examples/ghc80/T9840a.hs0000755000000000000000000000020307346545000017744 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module T9840a where import {-# SOURCE #-} T9840 type family G a where bar :: X a -> X a bar = id ghc-exactprint-0.6.2/tests/examples/ghc80/T9858a.hs0000755000000000000000000000133507346545000017764 0ustar0000000000000000-- From comment:76 in Trac #9858 -- This exploit still works in GHC 7.10.1. -- By Shachaf Ben-Kiki, Ørjan Johansen and Nathan van Doorn {-# LANGUAGE Safe #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ImpredicativeTypes #-} module T9858a where import Data.Typeable type E = (:~:) type PX = Proxy (((),()) => ()) type PY = Proxy (() -> () -> ()) data family F p a b newtype instance F a b PX = ID (a -> a) newtype instance F a b PY = UC (a -> b) {-# NOINLINE ecast #-} ecast :: E p q -> f p -> f q ecast Refl = id supercast :: F a b PX -> F a b PY supercast = case cast e of Just e' -> ecast e' where e = Refl e :: E PX PX uc :: a -> b uc = case supercast (ID id) of UC f -> f ghc-exactprint-0.6.2/tests/examples/ghc80/T9858b.hs0000755000000000000000000000024407346545000017763 0ustar0000000000000000{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE FlexibleContexts #-} module T9858b where import Data.Typeable test = typeRep (Proxy :: Proxy (Eq Int => Int)) ghc-exactprint-0.6.2/tests/examples/ghc80/T9858c.hs0000755000000000000000000000061107346545000017762 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} module Main(main) where import Data.Typeable import GHC.Exts test1 :: Bool test1 = typeRep (Proxy :: Proxy (() :: *)) == typeRep (Proxy :: Proxy (() :: Constraint)) test2 :: Bool test2 = typeRepTyCon (typeRep (Proxy :: Proxy (Int,Int))) == typeRepTyCon (typeRep (Proxy :: Proxy (Eq Int, Eq Int))) main :: IO () main = print (test1,test2) ghc-exactprint-0.6.2/tests/examples/ghc80/T9858d.hs0000755000000000000000000000023107346545000017761 0ustar0000000000000000{-# LANGUAGE DataKinds #-} module Main where import Data.Typeable data A = A main = print $ typeRep (Proxy :: Proxy A) == typeRep (Proxy :: Proxy 'A) ghc-exactprint-0.6.2/tests/examples/ghc80/T9858e.hs0000755000000000000000000000032107346545000017762 0ustar0000000000000000{-# LANGUAGE ImpredicativeTypes, FlexibleContexts #-} module T9858e where import Data.Typeable i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep i p = typeRep p j = i (Proxy :: Proxy (Eq Int => Int)) ghc-exactprint-0.6.2/tests/examples/ghc80/T9867.hs0000755000000000000000000000014307346545000017617 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-} module T9867 where pattern Nil = [] :: [a] ghc-exactprint-0.6.2/tests/examples/ghc80/T9878b.hs0000755000000000000000000000015407346545000017765 0ustar0000000000000000{-# LANGUAGE StaticPointers #-} module T9878b where import GHC.StaticPtr f = deRefStaticPtr (static True) ghc-exactprint-0.6.2/tests/examples/ghc80/T9938.hs0000755000000000000000000000034207346545000017617 0ustar0000000000000000module Main where import Control.Monad import Control.Monad.Trans.State solve :: Int -> StateT () [] () solve carry | carry > 0 = do guard (0 == carry) solve (carry -1) solve 0 = mzero main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9938B.hs0000755000000000000000000000034207346545000017721 0ustar0000000000000000module Main where import Control.Monad import Control.Monad.Trans.State solve :: Int -> StateT () [] () solve 0 = mzero solve carry | carry > 0 = do guard (0 == carry) solve (carry -1) main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/T9939.hs0000755000000000000000000000066507346545000017630 0ustar0000000000000000{-# LANGUAGE GADTs #-} module T9939 where f1 :: (Eq a, Ord a) => a -> a -> Bool -- Eq a redundant f1 x y = (x == y) && (x > y) f2 :: (Eq a, Ord a) => a -> a -> Bool -- Ord a redundant, but Eq a is reported f2 x y = (x == y) f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool -- Eq b redundant f3 x y = x==y data Equal a b where EQUAL :: Equal a a f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool -- Eq b redundant f4 x y EQUAL = y==y ghc-exactprint-0.6.2/tests/examples/ghc80/T9951.hs0000755000000000000000000000027207346545000017614 0ustar0000000000000000{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T9951 where f :: [a] -> () f x = case x of [] -> () (_:_) -> () ghc-exactprint-0.6.2/tests/examples/ghc80/T9951b.hs0000755000000000000000000000024607346545000017757 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T9951b where f :: String -> Bool f "ab" = True ghc-exactprint-0.6.2/tests/examples/ghc80/T9964.hs0000755000000000000000000000024107346545000017614 0ustar0000000000000000{-# LANGUAGE UnboxedTuples #-} module T9964 where import GHC.Base crash :: IO () crash = IO (\s -> let {-# NOINLINE s' #-} s' = s in (# s', () #)) ghc-exactprint-0.6.2/tests/examples/ghc80/T9968.hs0000755000000000000000000000016507346545000017625 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses #-} module T9968 where class C a b data X = X deriving (C Int) ghc-exactprint-0.6.2/tests/examples/ghc80/T9968a.hs0000755000000000000000000000017507346545000017767 0ustar0000000000000000{-# LANGUAGE DeriveAnyClass #-} module T9968 where import Data.Bifunctor data Blah a b = A a | B b deriving (Bifunctor) ghc-exactprint-0.6.2/tests/examples/ghc80/T9973.hs0000755000000000000000000000106607346545000017622 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-redundant-constraints #-} module T9973 where duplicateDecl :: (Eq t) => t -> IO () -- Trac #9973 was a bogus "redundant constraint" here duplicateDecl sigs = do { newSpan <- return typeSig -- **** commenting out the next three lines causes the original warning to disappear ; let rowOffset = case typeSig of { _ -> 1 } ; undefined } where typeSig = definingSigsNames sigs definingSigsNames :: (Eq t) => t -> () definingSigsNames x = undefined where _ = x == x -- Suppress the complaint on this ghc-exactprint-0.6.2/tests/examples/ghc80/T9975a.hs0000755000000000000000000000023207346545000017757 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternSynonyms #-} module T9975a where data Test = Test { x :: Int } pattern Test wat = Test { x = wat } ghc-exactprint-0.6.2/tests/examples/ghc80/T9975b.hs0000755000000000000000000000023307346545000017761 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternSynonyms #-} module T9975b where data Test = Test { x :: Int } pattern PTest wat = Test { x = wat } ghc-exactprint-0.6.2/tests/examples/ghc80/TH_abstractFamily.hs0000755000000000000000000000045307346545000022422 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module TH_abstractFamily where import Language.Haskell.TH -- Empty closed type families are okay... ds1 :: Q [Dec] ds1 = [d| type family F a where |] -- ...but abstract ones should result in a type error ds2 :: Q [Dec] ds2 = [d| type family G a where .. |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_bracket1.hs0000755000000000000000000000031507346545000021146 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- Check that declarations in a bracket shadow the top-level -- declarations, rather than clashing with them. module TH_bracket1 where foo = 1 bar = [d| foo = 1 |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_bracket2.hs0000755000000000000000000000025007346545000021145 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module TH_bracket2 where d_show = [d| data A = A instance Show A where show _ = "A" |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_bracket3.hs0000755000000000000000000000043507346545000021153 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskellQuotes #-} module TH_bracket3 where d_class = [d| class Classy a b where f :: a -> b instance Classy Int Bool where f x = if x == 0 then True else False |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_finalizer.hs0000755000000000000000000000037107346545000021437 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module ShouldCompile where import Language.Haskell.TH import Language.Haskell.TH.Syntax $( do addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool))) return [] ) $( putQ True >> return [] ) ghc-exactprint-0.6.2/tests/examples/ghc80/TH_localname.hs0000755000000000000000000000012407346545000021403 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module TH_localname where x = \y -> [| y |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_namePackage.hs0000755000000000000000000000100407346545000021642 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH eitherName, fooName, moduleFooName :: Name eitherName = ''Either fooName = mkName "foo" moduleFooName = mkName "Module.foo" main :: IO () main = do print $ nameBase eitherName print $ nameBase fooName print $ nameBase moduleFooName print $ nameModule eitherName print $ nameModule fooName print $ nameModule moduleFooName print $ namePackage eitherName print $ namePackage fooName print $ namePackage moduleFooName ghc-exactprint-0.6.2/tests/examples/ghc80/TH_nameSpace.hs0000755000000000000000000000055407346545000021353 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Data.Maybe (Maybe(..)) import Data.Ord (Ord) import Language.Haskell.TH (mkName, nameSpace) main :: IO () main = mapM_ (print . nameSpace) [ 'Prelude.id , mkName "id" , 'Data.Maybe.Just , ''Data.Maybe.Maybe , ''Data.Ord.Ord ] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_ppr1.hs0000755000000000000000000000154307346545000020340 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} module Main (main) where import Language.Haskell.TH u1 :: a u1 = undefined u2 :: a u2 = undefined f :: a f = undefined (.+.) :: a (.+.) = undefined main :: IO () main = do runQ [| f u1 u2 |] >>= p runQ [| u1 `f` u2 |] >>= p runQ [| (.+.) u1 u2 |] >>= p runQ [| u1 .+. u2 |] >>= p runQ [| (:) u1 u2 |] >>= p runQ [| u1 : u2 |] >>= p runQ [| \((:) x xs) -> x |] >>= p runQ [| \(x : xs) -> x |] >>= p runQ [d| class Foo a b where foo :: a -> b |] >>= p runQ [| \x -> (x, 1 `x` 2) |] >>= p runQ [| \(+) -> ((+), 1 + 2) |] >>= p runQ [| (f, 1 `f` 2) |] >>= p runQ [| ((.+.), 1 .+. 2) |] >>= p p :: Ppr a => a -> IO () p = putStrLn . pprint ghc-exactprint-0.6.2/tests/examples/ghc80/TH_reifyType1.hs0000755000000000000000000000025407346545000021515 0ustar0000000000000000-- test reification of monomorphic types module TH_reifyType1 where import Language.Haskell.TH foo :: Int -> Int foo x = x + 1 type_foo :: InfoQ type_foo = reify 'foo ghc-exactprint-0.6.2/tests/examples/ghc80/TH_reifyType2.hs0000755000000000000000000000022307346545000021512 0ustar0000000000000000-- test reification of polymorphic types module TH_reifyType1 where import Language.Haskell.TH type_length :: InfoQ type_length = reify 'length ghc-exactprint-0.6.2/tests/examples/ghc80/TH_repE1.hs0000755000000000000000000000104707346545000020431 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- test the representation of literals and also explicit type annotations module TH_repE1 where import Language.Haskell.TH integralExpr :: ExpQ integralExpr = [| 42 |] intExpr :: ExpQ intExpr = [| 42 :: Int |] integerExpr :: ExpQ integerExpr = [| 42 :: Integer |] charExpr :: ExpQ charExpr = [| 'x' |] stringExpr :: ExpQ stringExpr = [| "A String" |] fractionalExpr :: ExpQ fractionalExpr = [| 1.2 |] floatExpr :: ExpQ floatExpr = [| 1.2 :: Float |] doubleExpr :: ExpQ doubleExpr = [| 1.2 :: Double |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_repE3.hs0000755000000000000000000000054507346545000020435 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- test the representation of literals and also explicit type annotations module TH_repE1 where import Language.Haskell.TH emptyListExpr :: ExpQ emptyListExpr = [| [] |] singletonListExpr :: ExpQ singletonListExpr = [| [4] |] listExpr :: ExpQ listExpr = [| [4,5,6] |] consExpr :: ExpQ consExpr = [| 4:5:6:[] |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_scope.hs0000755000000000000000000000023707346545000020566 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} -- Test for Trac #2188 module TH_scope where f g = [d| f :: Int f = g g :: Int g = 4 |] ghc-exactprint-0.6.2/tests/examples/ghc80/TH_spliceE5_prof_ext.hs0000755000000000000000000000052607346545000023035 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module Main where import TH_spliceE5_prof_ext_Lib v1 = "foo" main = putStrLn $(expandVars ["v1","v2"]) -- The splice expands to refer to both v1 and v2, -- and the test checks that we don't dependency-analyse -- the program so that one or the other isn't in scope -- to the type checker v2 = "bar" ghc-exactprint-0.6.2/tests/examples/ghc80/TH_spliceE5_prof_ext_Lib.hs0000755000000000000000000000034407346545000023621 0ustar0000000000000000{-# LANGUAGE TemplateHaskellQuotes #-} module TH_spliceE5_prof_ext_Lib where import Language.Haskell.TH expandVars :: [String] -> Q Exp expandVars s = [| concat $(return (ListE (map f s))) |] where f x = VarE (mkName x) ghc-exactprint-0.6.2/tests/examples/ghc80/TH_tf2.hs0000755000000000000000000000105607346545000020150 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -- 'bar' is ambiguous module TH_tf2 where {- $( [d| class C a where data T a foo :: Bool -> T a |] ) $( [d| instance C Int where data T Int = TInt Bool foo b = TInt (b && b) |] ) $( [d| instance C Float where data T Float = TFloat {flag :: Bool} foo b = TFloat {flag = b && b} |] ) -} class D a where type S a bar :: S a -> Int instance D Int where type S Int = Bool bar c = if c then 1 else 2 ghc-exactprint-0.6.2/tests/examples/ghc80/TcCustomSolverSuper.hs0000755000000000000000000000102007346545000023024 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} module TcCustomSolverSuper where import GHC.TypeLits import Data.Typeable {- When solving super-class instances, GHC solves the evidence without using the solver (see `tcSuperClasses` in `TcInstDecls`). However, some classes need to be excepted from this behavior, as they have custom solving rules, and this test checks that we got this right. -} class (Typeable x, KnownNat x) => C x class (Typeable x, KnownSymbol x) => D x instance C 2 instance D "2" ghc-exactprint-0.6.2/tests/examples/ghc80/Templates.hs0000755000000000000000000000571407346545000021025 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, FlexibleInstances, OverlappingInstances, TypeOperators, PatternGuards #-} module Object.Templates( makeName, makeObject, makeObjectFlexible ) where import Object.Letters import Object.Types import Prelude hiding ((.)) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.Char import Data.Maybe -- | -- implements 'makeObject' or 'makeObjectFlexible' depending on the first argument makeObject' :: Bool -> Name -> Q [Dec] makeObject' flexible name = go name where go :: Name -> Q [Dec] go obj = do (name, vars, fields) <- reify name >>= getInfo let objType = foldl AppT (ConT name) (VarT<*vars) outputDecls <- if flexible then return [] else [d| type instance Output $(return objType) (Method m) = MethodOutput $(return objType) (Method m) type instance Output $(return objType) (Method m := input) = MethodOutput $(return objType) (Method m := input) |] fieldDecls <- (sequence $ makeField name vars <* fields) *> concat return $ outputDecls ++ fieldDecls -- "(Object.Example.Foo,[x_1627454179],[(Object.Example._bar,NotStrict,ConT GHC.Types.Int),(Object.Example._baz,NotStrict,ConT GHC.Types.Char),(Object.Example._blub,NotStrict,VarT x_1627454179)])" makeField :: Name -> [Name] -> VarStrictType -> Q [Dec] makeField _ _ (name,_,_) | '_' /= head (nameBase name) = fail $ show name ++ " did not start with underscore" makeField name vars (fName, _, fType) = do (decs1,(typeName,dataName)) <- makeName' (tail $ nameBase fName) methodOutput <- lookupTypeName "Object.Types.MethodOutput" *> fromMaybe (error "no MethodOutput in scope") let objType = foldl AppT (ConT name) (VarT<*vars) let methodOutInst = TySynInstD methodOutput $ TySynEqn [objType, ConT typeName] fType actionInst <- [d| instance Action $(return objType) $(return $ ConT typeName) where object . _ = $(return $ VarE fName) object |] matchType <- [t| $(return $ ConT typeName) := $(return $ VarT $ mkName "value") |] let methodSetOutInst = TySynInstD methodOutput $ TySynEqn [objType, matchType] objType actionSetInst <- [d| instance (value ~ $(return fType)) => Action $(return objType) $(return matchType) where object . ( _ := v) = $(recUpdE [e|object|] [return (fName, VarE $ mkName "v")]) |] return $ [methodOutInst,methodSetOutInst] ++ actionInst ++ actionSetInst ++ decs1 ghc-exactprint-0.6.2/tests/examples/ghc80/Test.hs0000755000000000000000000000021107346545000017771 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Test where import QQ f' = f . (+ 1) [pq| foo |] -- Expands to f :: Int -> Int f x = x + 1 ghc-exactprint-0.6.2/tests/examples/ghc80/Test10255.hs0000755000000000000000000000017207346545000020374 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test10255 where import Data.Maybe fob (f :: (Maybe t -> Int)) = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Test10268.hs0000755000000000000000000000027407346545000020403 0ustar0000000000000000{-# LANGUAGE TemplateHaskell,TypeOperators,DataKinds #-} module Test10268 where th = $footemplate give :: b -> Pattern '[b] a give = undefined pfail :: Pattern '[] a pfail = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Test10269.hs0000755000000000000000000000006407346545000020401 0ustar0000000000000000module Test10269 where (f =*= g) sa i = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Test10276.hs0000755000000000000000000000062207346545000020377 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} module Test10276 where f1 = [| bar |] f2 = [e| bar |] class QQExp a b where qqExp x = [||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] class QQExp2 a b where qqExp x = [e||fst $ runState $$(qqExpM x) ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||] ghc-exactprint-0.6.2/tests/examples/ghc80/Test10278.hs0000755000000000000000000000137707346545000020411 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables,GADTs #-} module Test10278 where extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int extremumNewton = undefined extremumNewton1 :: (Eq a, Fractional a) => (forall tag. forall tag1. Tower tag1 (Tower tag a) -> Tower tag1 (Tower tag a)) -> a -> [a] extremumNewton1 f x0 = zeroNewton (diffUU f) x0 data MaybeDefault v where SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v {- SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a]) -} ghc-exactprint-0.6.2/tests/examples/ghc80/Test10280.hs0000755000000000000000000000014507346545000020372 0ustar0000000000000000{-# LANGUAGE TupleSections #-} module Test10280 where foo2 = atomicModifyIORef ciTokens ((,()) . f) ghc-exactprint-0.6.2/tests/examples/ghc80/Test10307.hs0000755000000000000000000000022307346545000020367 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Test10307 where class Foldable t where type FoldableConstraint t x :: * type FoldableConstraint t x = () ghc-exactprint-0.6.2/tests/examples/ghc80/Test10309.hs0000755000000000000000000000022407346545000020372 0ustar0000000000000000{-# LANGUAGE GADTs #-} module Test10309 where data H1 a b where C3 :: (Num a) => { field :: a -- ^ hello docs } -> H1 Int Int ghc-exactprint-0.6.2/tests/examples/ghc80/Test10312.hs0000755000000000000000000000440307346545000020367 0ustar0000000000000000{-# LANGUAGE ParallelListComp, TransformListComp, RecordWildCards #-} module Test10312 where -- From -- https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html import GHC.Exts import qualified Data.Map as M import Data.Ord (comparing) import Data.List (sortBy) -- Let’s look at a simple, normal list comprehension to start: regularListComp :: [Int] regularListComp = [ x + y * z | x <- [0..10] , y <- [10..20] , z <- [20..30] ] parallelListComp :: [Int] parallelListComp = [ x + y * z | x <- [0..10] | y <- [10..20] | z <- [20..30] ] -- fibs :: [Int] -- fibs = 0 : 1 : zipWith (+) fibs (tail fibs) fibs :: [Int] fibs = 0 : 1 : [ x + y | x <- fibs | y <- tail fibs ] fiblikes :: [Int] fiblikes = 0 : 1 : [ x + y + z | x <- fibs | y <- tail fibs | z <- tail (tail fibs) ] -- TransformListComp data Character = Character { firstName :: String , lastName :: String , birthYear :: Int } deriving (Show, Eq) friends :: [Character] friends = [ Character "Phoebe" "Buffay" 1963 , Character "Chandler" "Bing" 1969 , Character "Rachel" "Green" 1969 , Character "Joey" "Tribbiani" 1967 , Character "Monica" "Geller" 1964 , Character "Ross" "Geller" 1966 ] oldest :: Int -> [Character] -> [String] oldest k tbl = [ firstName ++ " " ++ lastName | Character{..} <- tbl , then sortWith by birthYear , then take k ] groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]] groupByLargest f = sortBy (comparing (negate . length)) . groupWith f bestBirthYears :: [Character] -> [(Int, [String])] bestBirthYears tbl = [ (the birthYear, firstName) | Character{..} <- tbl , then group by birthYear using groupByLargest ] uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs , let d' = ppDir d , then group by Down (p,d') using groupWith ] ghc-exactprint-0.6.2/tests/examples/ghc80/Test10313.hs0000755000000000000000000000164607346545000020376 0ustar0000000000000000{-# LANGUAGE PackageImports #-} {-# LANGUAGE MagicHash, UnliftedFFITypes #-} {-# LANGUAGE ForeignFunctionInterface #-} module Test10313 where import "b\x61se" Data.List {-# WARNING Logic , solverCheckAndGetModel "New Z3 API support is still incomplete and fragile: \ \you may experience segmentation faults!" #-} {-# Deprecated Logic , solverCheckAndGetModel "Deprecation: \ \you may experience segmentation faults!" #-} data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic -- Should warn foo1 x = x {-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-} foreign import prim unsafe "a\x62" a :: IO Int {-# INLINE strictStream #-} strictStream (Bitstream l v) = {-# CORE "Strict Bitstream stre\x61m" #-} S.concatMap stream (GV.stream v) `S.sized` Exact l b = {-# SCC "foo\x64" #-} 006 c = {-# GENERATED "foob\x61r" 1 : 2 - 3 : 4 #-} 0.00 ghc-exactprint-0.6.2/tests/examples/ghc80/Test10354.hs0000755000000000000000000000034707346545000020400 0ustar0000000000000000{-# LANGUAGE PartialTypeSignatures #-} module Test10354 where f :: ((Eq a, _)) => a -> a -> Bool f x y = x == y bar :: ( ) => a-> Bool bar = undefined baz :: _ => a -> String baz = undefined foo :: ForceError foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/Test10357.hs0000755000000000000000000000055407346545000020403 0ustar0000000000000000{-# LANGUAGE ParallelListComp #-} module Test10357 where 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 ] ghc-exactprint-0.6.2/tests/examples/ghc80/Test10358.hs0000755000000000000000000000022107346545000020373 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Test10358 where mtGamma x v d = let !x_2 = x*x; !x_4 = x_2*x_2 v3 = v*v*v dv = d * v3 in 5 ghc-exactprint-0.6.2/tests/examples/ghc80/Test10396.hs0000755000000000000000000000020007346545000020372 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Test10396 where errors :: IO () errors= do let ls :: Int = undefined return () ghc-exactprint-0.6.2/tests/examples/ghc80/Test10399.hs0000755000000000000000000000116107346545000020404 0ustar0000000000000000{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} module Test10399 where type MPI = ?mpi_secret :: MPISecret mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) 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]) [t| Map.Map T.Text $tc |] bar $( [p| x |] ) = x ghc-exactprint-0.6.2/tests/examples/ghc80/Test11018.hs0000755000000000000000000000242607346545000020376 0ustar0000000000000000{-# LANGUAGE Arrows #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnicodeSyntax #-} module Test11018 where nonUnicode :: forall a . a -> IO Int nonUnicode _ = do x <- readChar return 4 -- ^ An opaque ESD handle for recording data from the soundcard via ESD. data Recorder fr ch (r ∷ * -> *) = Recorder { reCloseH :: !(FinalizerHandle r) } f :: Arrow a => a (Int,Int,Int) Int f = proc (x,y,z) -> returnA -< x+y f2 :: Arrow a => a (Int,Int,Int) Int f2 = proc (x,y,z) -> returnA >- x+y g :: ArrowApply a => Int -> a (a Int Int,Int) Int g y = proc (x,z) -> x -<< 2+y g2 :: ArrowApply a => Int -> a (a Int Int,Int) Int g2 y = proc (x,z) -> x >>- 2+y -- ------------------------------------- unicode ∷ ∀ a . a → IO Int unicode _ = do x ← readChar return 4 -- ^ An opaque ESD handle for recording data from the soundcard via ESD. data RecorderU fr ch (r ∷ ★ → ★) = RecorderU { reCloseHU ∷ !(FinalizerHandle r) } fU :: Arrow a ⇒ a (Int,Int,Int) Int fU = proc (x,y,z) -> returnA ⤙ x+y f2U :: Arrow a ⇒ a (Int,Int,Int) Int f2U = proc (x,y,z) -> returnA ⤚ x+y gU :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int gU y = proc (x,z) -> x ⤛ 2+y g2U :: ArrowApply a ⇒ Int -> a (a Int Int,Int) Int g2U y = proc (x,z) -> x ⤜ 2+y ghc-exactprint-0.6.2/tests/examples/ghc80/TestBoolFormula.hs0000755000000000000000000000143507346545000022144 0ustar0000000000000000module TestBoolFormula where class ManyOps a where aOp :: a -> a -> Bool aOp = undefined bOp :: a -> a -> Bool bOp = undefined cOp :: a -> a -> Bool cOp = undefined dOp :: a -> a -> Bool dOp = undefined eOp :: a -> a -> Bool eOp = undefined fOp :: a -> a -> Bool fOp = undefined {-# MINIMAL ( aOp) | ( bOp , cOp) | ((dOp | eOp) , fOp) #-} class Foo a where bar :: a -> a -> Bool foo :: a -> a -> Bool baq :: a -> a -> Bool baq = undefined baz :: a -> a -> Bool baz = undefined quux :: a -> a -> Bool quux = undefined {-# MINIMAL bar, (foo, baq | foo, quux) #-} instance Foo Int where bar = undefined baz = undefined quux = undefined foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc80/TestUtils.hs0000755000000000000000000000010407346545000021013 0ustar0000000000000000 module Math.NumberTheory.TestUtils where class (f `Compose` g) x ghc-exactprint-0.6.2/tests/examples/ghc80/Trac10045.hs0000755000000000000000000000020407346545000020337 0ustar0000000000000000module Trac10045 where newtype Meta = Meta () foo (Meta ws1) = let copy :: _ copy w from = copy w 1 in copy ws1 1 ghc-exactprint-0.6.2/tests/examples/ghc80/TransAssociated.hs0000755000000000000000000000016307346545000022147 0ustar0000000000000000module TransAssociated(A(..)) where import Associated (A(..)) foo = MkA 5 baz = NoA qux (MkA x) = x qux NoA = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/TransBundle.hs0000755000000000000000000000015707346545000021304 0ustar0000000000000000module TransAssociated(A(..)) where import Bundle (A(..)) foo = MkA 5 baz = NoA qux (MkA x) = x qux NoA = 0 ghc-exactprint-0.6.2/tests/examples/ghc80/TypeFamilyInstanceLHS.hs0000755000000000000000000000030507346545000023175 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module TypeFamilyInstanceLHS where type family F (a :: *) (b :: *) :: * type instance F Int _ = Int type instance F Bool _ = Bool foo :: F Int Char -> Int foo = id ghc-exactprint-0.6.2/tests/examples/ghc80/TypeLevelVec.hs0000755000000000000000000000112707346545000021430 0ustar0000000000000000{-# LANGUAGE TypeInType, UnicodeSyntax, GADTs, NoImplicitPrelude, TypeOperators, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} module TypeLevelVec where import Data.Kind data ℕ ∷ Type where O ∷ ℕ S ∷ ℕ → ℕ type family x + y where O + n = n S m + n = S (m + n) infixl 5 + data Vec ∷ ℕ → Type → Type where Nil ∷ Vec O a (:>) ∷ a → Vec n a → Vec (S n) a infixr 8 :> type family (x ∷ Vec n a) ++ (y ∷ Vec m a) ∷ Vec (n + m) a where Nil ++ y = y (x :> xs) ++ y = x :> (xs ++ y) infixl 5 ++ ghc-exactprint-0.6.2/tests/examples/ghc80/TypeSkolEscape.hs0000755000000000000000000000024407346545000021753 0ustar0000000000000000{-# LANGUAGE RankNTypes, PolyKinds, TypeInType #-} module TypeSkolEscape where import GHC.Types import GHC.Exts type Bad = forall (v :: Levity) (a :: TYPE v). a ghc-exactprint-0.6.2/tests/examples/ghc80/TypedSplice.hs0000755000000000000000000000034207346545000021304 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NamedWildCards #-} {-# LANGUAGE PartialTypeSignatures #-} module TypedSplice where import Language.Haskell.TH metaExp :: Q (TExp (Bool -> Bool)) metaExp = [|| not :: _ -> _b ||] ghc-exactprint-0.6.2/tests/examples/ghc80/UnicodeRules.hs0000755000000000000000000000064507346545000021466 0ustar0000000000000000{-# 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) ghc-exactprint-0.6.2/tests/examples/ghc80/Vta1.hs0000755000000000000000000000376607346545000017707 0ustar0000000000000000{-# LANGUAGE TypeApplications, ScopedTypeVariables, PolyKinds, TypeFamilies, RankNTypes, FlexibleContexts #-} -- tests about visible type application module Vta1 where quad :: a -> b -> c -> d -> (a, b, c, d) quad = (,,,) silly = quad @_ @Bool @Char @_ 5 True 'a' "Hello" pairup_nosig x y = (x, y) pairup_sig :: a -> b -> (a,b) pairup_sig u w = (u, w) answer_sig = pairup_sig @Bool @Int False 7 -- -- (False, 7) :: (Bool, Int) answer_read = show (read @Int "3") -- "3" :: String answer_show = show @Integer (read "5") -- "5" :: String answer_showread = show @Int (read @Int "7") -- "7" :: String intcons a = (:) @Int a intpair x y = pairup_sig @Int x y answer_pairup = pairup_sig @Int 5 True -- (5, True) :: (Int, Bool) answer_intpair = intpair 1 "hello" -- (1, "hello") :: (Int, String) answer_intcons = intcons 7 [] -- [7] :: [Int] type family F a type instance F Char = Bool g :: F a -> a g _ = undefined f :: Char f = g True answer = g @Char False mapSame :: forall b. (forall a. a -> a) -> [b] -> [b] mapSame _ [] = [] mapSame fun (x:xs) = fun @b x : (mapSame @b fun xs) pair :: forall a. a-> (forall b. b -> (a, b)) pair x y = (x, y) b = pair @Int 3 @Bool True c = mapSame id [1,2,3] d = pair 3 @Bool True pairnum :: forall a. Num a => forall b. b -> (a, b) pairnum = pair 3 e = (pair 3 :: forall a. Num a => forall b. b -> (a, b)) @Int @Bool True h = pairnum @Int @Bool True data First (a :: * -> *) = F data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable) data Three (a :: * -> k -> *) = T foo :: Proxy a -> Int foo _ = 0 first :: First a -> Int first _ = 0 fTest = first F fMaybe = first @Maybe F test = foo P bar = foo @Bool P -- should work too :: Three a -> Int too _ = 3 threeBase = too T threeOk = too @Either T blah = Nothing @Int newtype N = MkN { unMkN :: forall a. Show a => a -> String } n = MkN show boo = unMkN n @Bool boo2 :: forall (a :: * -> *) . Proxy a -> Bool boo2 _ = False base = boo2 P bar'= boo2 @Maybe P -- should work ghc-exactprint-0.6.2/tests/examples/ghc80/Vta2.hs0000755000000000000000000000061607346545000017677 0ustar0000000000000000{-# LANGUAGE RankNTypes, TypeApplications #-} module Vta2 where checkIf :: Bool -> (forall a. a -> a) -> (Bool, Int) checkIf _ = if True then \f -> (f True, f 5) else \f -> (f False, f @Int 3) checkCase :: Bool -> (forall a. a -> a) -> (Bool, Int) checkCase _ = case True of True -> \f -> (f True, f 5) False -> \f -> (f False, f @Int 3) ghc-exactprint-0.6.2/tests/examples/ghc80/WCompatWarningsNotOn.hs0000755000000000000000000000102207346545000023114 0ustar0000000000000000-- Test purpose: -- Ensure that not using -Wcompat does not enable its warnings -- {-# OPTIONS_GHC -Wcompat #-} -- {-# OPTIONS_GHC -Wno-compat #-} module WCompatWarningsNotOn where import qualified Data.Semigroup as Semi monadFail :: Monad m => m a monadFail = do Just _ <- undefined undefined (<>) = undefined -- Semigroup warnings -- -fwarn-noncanonical-monoid-instances newtype S = S Int instance Semi.Semigroup S where (<>) = mappend instance Semi.Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 ghc-exactprint-0.6.2/tests/examples/ghc80/WCompatWarningsOff.hs0000755000000000000000000000101307346545000022571 0ustar0000000000000000-- Test purpose: -- Ensure that using -Wno-compat does not switch on warnings -- {-# OPTIONS_GHC -Wcompat #-} {-# OPTIONS_GHC -Wno-compat #-} module WCompatWarningsOff where import qualified Data.Semigroup as Semi monadFail :: Monad m => m a monadFail = do Just _ <- undefined undefined (<>) = undefined -- Semigroup warnings -- -fwarn-noncanonical-monoid-instances newtype S = S Int instance Semi.Semigroup S where (<>) = mappend instance Semi.Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 ghc-exactprint-0.6.2/tests/examples/ghc80/WCompatWarningsOn.hs0000755000000000000000000000100407346545000022433 0ustar0000000000000000-- Test purpose: -- Ensure that -Wcompat switches on the right warnings {-# OPTIONS_GHC -Wcompat #-} -- {-# OPTIONS_GHC -Wno-compat #-} module WCompatWarningsOn where import qualified Data.Semigroup as Semi monadFail :: Monad m => m a monadFail = do Just _ <- undefined undefined (<>) = undefined -- Semigroup warnings -- -fwarn-noncanonical-monoid-instances newtype S = S Int instance Semi.Semigroup S where (<>) = mappend instance Semi.Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 ghc-exactprint-0.6.2/tests/examples/ghc80/WCompatWarningsOnOff.hs0000755000000000000000000000101307346545000023066 0ustar0000000000000000-- Test purpose: -- Ensure that -Wno-compat disables a previously set -Wcompat {-# OPTIONS_GHC -Wcompat #-} {-# OPTIONS_GHC -Wno-compat #-} module WCompatWarningsOnOff where import qualified Data.Semigroup as Semi monadFail :: Monad m => m a monadFail = do Just _ <- undefined undefined (<>) = undefined -- Semigroup warnings -- -fwarn-noncanonical-monoid-instances newtype S = S Int instance Semi.Semigroup S where (<>) = mappend instance Semi.Monoid S where S a `mappend` S b = S (a+b) mempty = S 0 ghc-exactprint-0.6.2/tests/examples/ghc80/Zwaluw.hs0000755000000000000000000001121607346545000020352 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} module Web.Zwaluw ( -- * Types Router, (:-)(..), (<>), -- * Running routers parse, unparse, parse1, unparse1, -- * Constructing routers -- | The @constrN@ functions are helper functions to lift constructors of -- datatypes to routers. Their first argument is the constructor; their -- second argument is a (partial) destructor. constr0, constr1, constr2, int, slash, lit ) where import Prelude hiding ((.), id) import Control.Monad import Control.Category import Control.Arrow (first) import Data.Monoid infixr 8 <> infixr 8 :- -- | Infix operator for 'mappend'. (<>) :: Monoid m => m -> m -> m (<>) = mappend data Router a b = Router { ser :: b -> [(a, String)] , prs :: String -> [(a -> b, String)] } data a :- b = a :- b deriving (Eq, Show) xmap :: (b -> a) -> (a -> b) -> Router r a -> Router r b xmap f g (Router s p) = Router (s . f) ((fmap . liftM . first . fmap) g p) instance Category (Router) where id = lit "" Router sf pf . Router sg pg = Router (\a -> do (b, s) <- sf a (c, s') <- sg b return (c, s ++ s')) (\s -> do (f, s') <- pf s (g, s'') <- pg s' return (f . g, s'')) instance Monoid (Router a b) where mempty = Router (const mzero) (const mzero) Router sf pf `mappend` Router sg pg = Router (\s -> sf s `mplus` sg s) (\s -> pf s `mplus` pg s) parse :: Router () a -> String -> [a] parse p = concatMap (\(a, s) -> if (s == "") then [a ()] else []) . prs p parse1 :: Router () (a :- ()) -> String -> [a] parse1 p s = map (\(r :- ()) -> r) (parse p s) unparse :: Router () a -> a -> [String] unparse p = map snd . ser p unparse1 :: Router () (a :- ()) -> a -> [String] unparse1 p x = unparse p (x :- ()) maph :: (b -> a) -> (a -> b) -> Router i (a :- o) -> Router i (b :- o) maph f g = xmap (\(h :- t) -> f h :- t) (\(h :- t) -> g h :- t) opt :: Eq a => a -> Router r (a :- r) -> Router r (a :- r) opt a p = p <> push a nil :: Router r ([a] :- r) nil = constr0 [] $ \x -> do [] <- x; Just () cons :: Router (a :- [a] :- r) ([a] :- r) cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) -- many :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) -- many p = nil <> many1 p -- many1 :: Eq a => (forall r. Router r (a :- r)) -> Router r ([a] :- r) -- many1 p = cons . p . many p satisfy :: (Char -> Bool) -> Router r (Char :- r) satisfy p = Router (\(c :- a) -> if (p c) then return (a, [c]) else mzero) (\s -> case s of [] -> mzero (c:cs) -> if (p c) then return ((c :-), cs) else mzero) char :: Router r (Char :- r) char = satisfy (const True) digitChar :: Router r (Char :- r) digitChar = satisfy (\c -> c >= '0' && c <= '9') digit :: Router r (Int :- r) digit = maph (head . show) (read . (:[])) digitChar -- | Routes a constant string. lit :: String -> Router r r lit l = Router (\b -> return (b, l)) (\s -> let (s1, s2) = splitAt (length l) s in if s1 == l then return (id, s2) else mzero) -- | Routes a slash. slash :: Router r r slash = lit "/" -- | Routes any integer. int :: Router r (Int :- r) -- int = maph show read $ many1 digitChar int = Router (\(i :- a) -> return (a, show i)) (\s -> let l = reads s in map (first (:-)) l) push :: Eq h => h -> Router r (h :- r) push h = Router (\(h' :- t) -> do guard (h == h'); return (t, "")) (\s -> return ((h :-), s)) left :: Router (a :- r) (Either a b :- r) left = constr1 Left $ \x -> do Left a <- x; return a right :: Router (b :- r) (Either a b :- r) right = constr1 Right $ \x -> do Right b <- x; return b eitherP :: Router r (a :- r) -> Router r (b :- r) -> Router r (Either a b :- r) eitherP l r = left . l <> right . r -- | For example: -- -- > nil :: Router r ([a] :- r) -- > nil = constr0 [] $ \x -> do [] <- x; Just () constr0 :: o -> (Maybe o -> Maybe ()) -> Router r (o :- r) constr0 c d = Router (\(a :- t) -> maybe mzero (\_ -> return (t, "")) (d (return a))) (\s -> return ((c :-), s)) -- | For example: -- -- > left :: Router (a :- r) (Either a b :- r) -- > left = constr1 Left $ \x -> do Left a <- x; return a constr1 :: (a -> o) -> (Maybe o -> Maybe a) -> Router (a :- r) (o :- r) constr1 c d = Router (\(a :- t) -> maybe mzero (\a -> return (a :- t, "")) (d (return a))) (\s -> return (\(a :- t) -> c a :- t, s)) -- | For example: -- -- > cons :: Router (a :- [a] :- r) ([a] :- r) -- > cons = constr2 (:) $ \x -> do a:as <- x; return (a, as) constr2 :: (a -> b -> o) -> (Maybe o -> Maybe (a, b)) -> Router (a :- b :- r) (o :- r) constr2 c d = Router (\(a :- t) -> maybe mzero (\(a, b) -> return (a :- b :- t, "")) (d (return a))) (\s -> return (\(a :- b :- t) -> c a b :- t, s)) ghc-exactprint-0.6.2/tests/examples/ghc80/ado001.hs0000755000000000000000000000546707346545000020060 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-} module Main where import Control.Applicative import Text.PrettyPrint (a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..] -- a | b test1 :: M () test1 = do x1 <- a x2 <- b const (return ()) (x1,x2) -- no parallelism test2 :: M () test2 = do x1 <- a x2 <- const g x1 const (return ()) (x1,x2) -- a | (b;g) | e test3 :: M () test3 = do x1 <- a x2 <- b x3 <- const g x2 x4 <- e return () `const` (x1,x2,x3,x4) -- (a ; (b | g)) | c -- or -- ((a | b); g) | c test4 :: M () test4 = do x1 <- a x2 <- b x3 <- const g x1 x4 <- c return () `const` (x2,x3,x4) -- (a | b | c); (g | h) test5 :: M () test5 = do x1 <- a x2 <- b x3 <- c x4 <- const g x1 x5 <- const h x3 return () `const` (x3,x4,x5) -- b/c in parallel, e/f in parallel -- a; (b | (c; (d; (e | (f; g))))) test6 :: M () test6 = do x1 <- a x2 <- const b x1 x3 <- const c x1 x4 <- const d x3 x5 <- const e x4 x6 <- const f x4 x7 <- const g x6 return () `const` (x1,x2,x3,x4,x5,x6,x7) -- (a | b); (c | d) test7 :: M () test7 = do x1 <- a x2 <- b x3 <- const c x1 x4 <- const d x2 return () `const` (x3,x4) -- a; (b | c | d) -- -- alternative (but less good): -- ((a;b) | c); d test8 :: M () test8 = do x1 <- a x2 <- const b x1 x3 <- c x4 <- const d x1 return () `const` (x2,x3,x4) -- test that Lets don't get in the way -- ((a | (b; c)) | d) | e test9 :: M () test9 = do x1 <- a let x = doc "x" -- this shouldn't get in the way of grouping a/b x2 <- b x3 <- const c x2 x4 <- d x5 <- e let y = doc "y" return () -- ((a | b) ; (c | d)) | e test10 :: M () test10 = do x1 <- a x2 <- b let z1 = (x1,x2) x3 <- const c x1 let z2 = (x1,x2) x4 <- const d z1 x5 <- e return (const () (x3,x4,x5)) main = mapM_ run [ test1 , test2 , test3 , test4 , test5 , test6 , test7 , test8 , test9 , test10 ] -- Testing code, prints out the structure of a monad/applicative expression newtype M a = M (Bool -> (Maybe Doc, a)) maybeParen True d = parens d maybeParen _ d = d run :: M a -> IO () run (M m) = print d where (Just d,_) = m False instance Functor M where fmap f m = m >>= return . f instance Applicative M where pure a = M $ \_ -> (Nothing, a) M f <*> M a = M $ \p -> let (Just d1, f') = f True (Just d2, a') = a True in (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a') instance Monad M where return = pure M m >>= k = M $ \p -> let (d1, a) = m True (d2, b) = case k a of M f -> f True in case (d1,d2) of (Nothing,Nothing) -> (Nothing, b) (Just d, Nothing) -> (Just d, b) (Nothing, Just d) -> (Just d, b) (Just d1, Just d2) -> (Just (maybeParen p (d1 <> semi <+> d2)), b) doc :: String -> M () doc d = M $ \_ -> (Just (text d), ()) ghc-exactprint-0.6.2/tests/examples/ghc80/ado002.hs0000755000000000000000000000064307346545000020050 0ustar0000000000000000{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-} module Test where -- Test that type errors aren't affected by ApplicativeDo f :: IO Int f = do x <- getChar y <- getChar 'a' -- type error print (x,y) g :: IO (Int,Int) g = do x <- getChar y <- getChar return (y,x) h :: IO (Int,Int) h = do x1 <- getChar x2 <- getChar x3 <- const (return ()) x1 x4 <- getChar x5 <- getChar x4 return (x2,x4) ghc-exactprint-0.6.2/tests/examples/ghc80/ado003.hs0000755000000000000000000000021407346545000020043 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} module ShouldFail where g :: IO () g = do x <- getChar 'a' <- return (3::Int) -- type error return () ghc-exactprint-0.6.2/tests/examples/ghc80/ado004.hs0000755000000000000000000000633307346545000020054 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -ddump-types #-} module Test where -- This is a do expression that typechecks with only an Applicative constraint test1 :: Applicative f => (Int -> f Int) -> f Int test1 f = do x <- f 3 y <- f 4 return (x + y) -- Test we can also infer the Applicative version of the type test2 f = do x <- f 3 y <- f 4 return (x + y) -- This one will use join test3 f g = do x <- f 3 y <- f 4 g y x -- This one needs a tuple test4 f g = do x <- f 3 y <- f 4 let r = g y x r -- This one used to need a big tuple, now it compiles to ApplicativeLastStmt test5 f g = do x01 <- f 01 x02 <- f 02 x03 <- f 03 x04 <- f 04 x05 <- f 05 x06 <- f 06 x07 <- f 07 x08 <- f 08 x09 <- f 09 x11 <- f 11 x12 <- f 12 x13 <- f 13 x14 <- f 14 x15 <- f 15 x16 <- f 16 x17 <- f 17 x18 <- f 18 x19 <- f 19 x20 <- f 20 x21 <- f 21 x22 <- f 22 x23 <- f 23 x24 <- f 24 x25 <- f 25 x26 <- f 26 x27 <- f 27 x28 <- f 28 x29 <- f 29 x30 <- f 30 x31 <- f 31 x32 <- f 32 x33 <- f 33 x34 <- f 34 x35 <- f 35 x36 <- f 36 x37 <- f 37 x38 <- f 38 x39 <- f 39 x40 <- f 40 x41 <- f 41 x42 <- f 42 x43 <- f 43 x44 <- f 44 x45 <- f 45 x46 <- f 46 x47 <- f 47 x48 <- f 48 x49 <- f 49 x50 <- f 50 x51 <- f 51 x52 <- f 52 x53 <- f 53 x54 <- f 54 x55 <- f 55 x56 <- f 56 x57 <- f 57 x58 <- f 58 x59 <- f 59 x60 <- f 60 x61 <- f 61 x62 <- f 62 x63 <- f 63 x64 <- f 64 x65 <- f 65 x66 <- f 66 x67 <- f 67 x68 <- f 68 x69 <- f 69 x70 <- f 70 let r = g x70 x01 r -- This one needs a big tuple test6 f g = do x01 <- f 01 x02 <- f 02 x03 <- f 03 x04 <- f 04 x05 <- f 05 x06 <- f 06 x07 <- f 07 x08 <- f 08 x09 <- f 09 x11 <- f 11 x12 <- f 12 x13 <- f 13 x14 <- f 14 x15 <- f 15 x16 <- f 16 x17 <- f 17 x18 <- f 18 x19 <- f 19 x20 <- f 20 x21 <- f 21 x22 <- f 22 x23 <- f 23 x24 <- f 24 x25 <- f 25 x26 <- f 26 x27 <- f 27 x28 <- f 28 x29 <- f 29 x30 <- f 30 x31 <- f 31 x32 <- f 32 x33 <- f 33 x34 <- f 34 x35 <- f 35 x36 <- f 36 x37 <- f 37 x38 <- f 38 x39 <- f 39 x40 <- f 40 x41 <- f 41 x42 <- f 42 x43 <- f 43 x44 <- f 44 x45 <- f 45 x46 <- f 46 x47 <- f 47 x48 <- f 48 x49 <- f 49 x50 <- f 50 x51 <- f 51 x52 <- f 52 x53 <- f 53 x54 <- f 54 x55 <- f 55 x56 <- f 56 x57 <- f 57 x58 <- f 58 x59 <- f 59 x60 <- f 60 x61 <- f 61 x62 <- f 62 x63 <- f 63 x64 <- f 64 x65 <- f 65 x66 <- f 66 x67 <- f 67 x68 <- f 68 x69 <- f 69 x70 <- f x01 x71 <- f 70 x71 `const` [ x01 , x02 , x03 , x04 , x05 , x06 , x07 , x08 , x09 , x11 , x12 , x13 , x14 , x15 , x16 , x17 , x18 , x19 , x20 , x21 , x22 , x23 , x24 , x25 , x26 , x27 , x28 , x29 , x30 , x31 , x32 , x33 , x34 , x35 , x36 , x37 , x38 , x39 , x40 , x41 , x42 , x43 , x44 , x45 , x46 , x47 , x48 , x49 , x50 , x51 , x52 , x53 , x54 , x55 , x56 , x57 , x58 , x59 , x60 , x61 , x62 , x63 , x64 , x65 , x66 , x67 , x68 , x69 , x70 , x71 ] ghc-exactprint-0.6.2/tests/examples/ghc80/ado005.hs0000755000000000000000000000035707346545000020055 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} {-# OPTIONS_GHC -ddump-types #-} module Test where -- This should fail to typecheck because it needs Monad test :: Applicative f => (Int -> f Int) -> f Int test f = do x <- f 3 y <- f x return (x + y) ghc-exactprint-0.6.2/tests/examples/ghc80/ado006.hs0000755000000000000000000000030707346545000020051 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} module Test where -- This exposed a bug in zonking ApplicativeLastStmt test :: IO Int test = do x <- return () h <- return (\_ -> 3) return (h ()) ghc-exactprint-0.6.2/tests/examples/ghc80/ado007.hs0000755000000000000000000000060107346545000020047 0ustar0000000000000000{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RebindableSyntax #-} module Test where import Control.Applicative import Control.Monad import Prelude -- Caused a -dcore-lint failure with an earlier version of -- ApplicativeDo due to the polymorphic let binding. test :: IO [Char] test = do x <- return 'a' y <- return 'b' let f | y == 'c' = id | otherwise = id return (map f []) ghc-exactprint-0.6.2/tests/examples/ghc80/boolFormula.hs0000755000000000000000000000022607346545000021341 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/determinism001.hs0000755000000000000000000000100007346545000021610 0ustar0000000000000000module Main where import Digraph main = mapM_ print [ test001 , test002 , test003 , test004 ] -- These check that the result of SCCs doesn't depend on the order of the key -- type (Int here). test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])] test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])] test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])] test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])] testSCC = flattenSCCs . stronglyConnCompFromEdgedVertices ghc-exactprint-0.6.2/tests/examples/ghc80/export-class.hs0000755000000000000000000000020207346545000021476 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo (MyClass(.., P)) where pattern P = Nothing class MyClass a where foo :: a -> Int ghc-exactprint-0.6.2/tests/examples/ghc80/export-ps-rec-sel.hs0000755000000000000000000000015307346545000022350 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo( R(P,x)) where data Q = Q Int data R = R pattern P{x} = Q x ghc-exactprint-0.6.2/tests/examples/ghc80/export-record-selector.hs0000755000000000000000000000020007346545000023463 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo ( A(foo) ) where data A a = A a pattern P :: Int -> A Int pattern P{foo} = A foo ghc-exactprint-0.6.2/tests/examples/ghc80/export-super-class-fail.hs0000755000000000000000000000063407346545000023554 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} module Foo ( B(P) ) where class (f ~ A) => C f a where build :: a -> f a destruct :: f a -> a data A a = A a data B a = B a instance C A Int where build n = A n destruct (A n) = n pattern P :: C f a => a -> f a pattern P x <- (destruct -> x) where P x = build x ghc-exactprint-0.6.2/tests/examples/ghc80/export-super-class.hs0000755000000000000000000000061407346545000022641 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ViewPatterns #-} module Foo ( A(P) ) where class (f ~ A) => C f a where build :: a -> f a destruct :: f a -> a data A a = A a instance C A Int where build n = A n destruct (A n) = n pattern P :: C f a => a -> f a pattern P x <- (destruct -> x) where P x = build x ghc-exactprint-0.6.2/tests/examples/ghc80/export-syntax.hs0000755000000000000000000000011407346545000021721 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo(A(.., B)) where data A = A | B ghc-exactprint-0.6.2/tests/examples/ghc80/export-type-synonym.hs0000755000000000000000000000017507346545000023075 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo ( A(P) ) where data A = A data B = B type C = B pattern P :: C pattern P = B ghc-exactprint-0.6.2/tests/examples/ghc80/export-type.hs0000755000000000000000000000025307346545000021360 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Export (A(..,MyB), B(MyA), C(MyC)) where data A = A data B = B pattern MyB = B pattern MyA = A data C a = C pattern MyC = B ghc-exactprint-0.6.2/tests/examples/ghc80/frontend01.hs0000755000000000000000000000003607346545000021037 0ustar0000000000000000main = putStrLn "hello world" ghc-exactprint-0.6.2/tests/examples/ghc80/haddockA034.hs0000755000000000000000000000020407346545000021001 0ustar0000000000000000{-# LANGUAGE GADTs #-} module Hi where -- | This is a GADT. data Hi where -- | This is a GADT constructor. Hi :: () -> Hi ghc-exactprint-0.6.2/tests/examples/ghc80/listcomps.hs0000755000000000000000000000621407346545000021100 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} -- This program must be called with GHC's libdir as the single command line -- argument. module Main where -- import Data.Generics import Data.Data import Data.List import System.IO import GHC import BasicTypes import DynFlags import MonadUtils import Outputable import ApiAnnotation import Bag (filterBag,isEmptyBag) import System.Directory (removeFile) import System.Environment( getArgs ) import System.Exit import qualified Data.Map as Map import qualified Data.Set as Set import Data.Dynamic ( fromDynamic,Dynamic ) main::IO() main = do [libdir] <- getArgs testOneFile libdir "ListComprehensions" exitSuccess testOneFile libdir fileName = do ((anns,cs),p) <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags dflags let mn =mkModuleName fileName addTarget Target { targetId = TargetModule mn , targetAllowObjCode = True , targetContents = Nothing } load LoadAllTargets modSum <- getModSummary mn p <- parseModule modSum t <- typecheckModule p d <- desugarModule t l <- loadModule d let ts=typecheckedSource l r =renamedSource l return (pm_annotations p,p) let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p) putStrLn (pp spans) putStrLn "--------------------------------" putStrLn (intercalate "\n" [showAnns anns]) where getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))] getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns getAllSrcSpans :: (Data t) => t -> [SrcSpan] getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast where getSrcSpan :: SrcSpan -> [SrcSpan] getSrcSpan ss = [ss] showAnns anns = "[\n" ++ (intercalate "\n" $ map (\((s,k),v) -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) $ Map.toList anns) ++ "]\n" pp a = showPpr unsafeGlobalDynFlags a -- --------------------------------------------------------------------- -- Copied from syb for the test -- | Generic queries of type \"r\", -- i.e., take any \"a\" and return an \"r\" -- type GenericQ r = forall a. Data a => a -> r -- | Make a generic query; -- start from a type-specific case; -- return a constant otherwise -- mkQ :: ( Typeable a , Typeable b ) => r -> (b -> r) -> a -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r -- | Summarise all nodes in top-down, left-to-right order everything :: (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results everything k f x = foldl k (f x) (gmapQ (everything k f) x) ghc-exactprint-0.6.2/tests/examples/ghc80/mixed-pat-syn-record-sels.hs0000755000000000000000000000024607346545000024001 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo where pattern A { a } = Just a pattern B { b } = Just b foo :: Maybe a -> Maybe Bool foo x = x { a = True, b = False } ghc-exactprint-0.6.2/tests/examples/ghc80/multi-export.hs0000755000000000000000000000022207346545000021525 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo (A(B, C)) where data A a = A pattern B :: A Int pattern B = A pattern C :: A String pattern C = A ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedlabelsfail01.hs0000755000000000000000000000054207346545000023365 0ustar0000000000000000{-# LANGUAGE OverloadedLabels, DataKinds, FlexibleContexts #-} import GHC.OverloadedLabels -- No instance for (OverloadedLabel "x" t0) a = #x -- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0) b = #x #y -- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t) c :: IsLabel "x" t => t c = #y main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedlabelsrun01.hs0000755000000000000000000000101207346545000023247 0ustar0000000000000000-- Basic tests of overloaded labels {-# LANGUAGE OverloadedLabels , DataKinds , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses , NoMonomorphismRestriction #-} import GHC.OverloadedLabels instance IsLabel "true" Bool where fromLabel _ = True instance IsLabel "false" Bool where fromLabel _ = False a :: IsLabel "true" t => t a = #true b = #false c :: Bool c = #true main = do print (a :: Bool) print (b :: Bool) print c ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedlabelsrun02.hs0000755000000000000000000000252207346545000023257 0ustar0000000000000000-- Using overloaded labels to provide nice syntactic sugar for a -- term representation using de Bruijn indices {-# LANGUAGE OverloadedLabels , DataKinds , FlexibleContexts , FlexibleInstances , GADTs , KindSignatures , MultiParamTypeClasses , NoMonomorphismRestriction , OverlappingInstances , ScopedTypeVariables , StandaloneDeriving , TypeOperators #-} import GHC.OverloadedLabels import Data.Proxy ( Proxy(..) ) import GHC.TypeLits ( Symbol ) instance x ~ y => IsLabel x (Proxy y) where fromLabel _ = Proxy data Elem (x :: Symbol) g where Top :: Elem x (x ': g) Pop :: Elem x g -> Elem x (y ': g) deriving instance Show (Elem x g) class IsElem x g where which :: Elem x g instance IsElem x (x ': g) where which = Top instance IsElem x g => IsElem x (y ': g) where which = Pop which data Tm g where Var :: Elem x g -> Tm g App :: Tm g -> Tm g -> Tm g Lam :: Tm (x ': g) -> Tm g deriving instance Show (Tm g) instance IsElem x g => IsLabel x (Tm g) where fromLabel _ = Var (which :: Elem x g) lam :: Proxy x -> Tm (x ': g) -> Tm g lam _ = Lam s = lam #x #x t = lam #x (lam #y (#x `App` #y)) u :: IsElem "z" g => Tm g u = #z `App` #z main = do print s print t print (u :: Tm '["z"]) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedlabelsrun03.hs0000755000000000000000000000107307346545000023260 0ustar0000000000000000-- Using overloaded labels as strings, slightly pointlessly {-# LANGUAGE OverloadedLabels , DataKinds , FlexibleContexts , FlexibleInstances , MultiParamTypeClasses , ScopedTypeVariables , TypeFamilies , TypeSynonymInstances #-} import GHC.OverloadedLabels import Data.Proxy ( Proxy(..) ) import GHC.TypeLits ( KnownSymbol, symbolVal ) instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where fromLabel _ = symbolVal (Proxy :: Proxy x) main = do putStrLn #x print $ #x ++ #y ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail01.hs0000755000000000000000000000101007346545000023534 0ustar0000000000000000-- Test ambiguous updates are rejected with appropriate error messages {-# LANGUAGE DuplicateRecordFields #-} data R = MkR { w :: Bool, x :: Int, y :: Bool } data S = MkS { w :: Bool, x :: Int, y :: Bool } data T = MkT { x :: Int, z :: Bool } data U = MkU { y :: Bool } -- Straightforward ambiguous update upd1 r = r { x = 3 } -- No type has all these fields upd2 r = r { x = 3, y = True, z = False } -- User-specified type does not have these fields upd3 r = r { w = True, x = 3, y = True } :: U main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail02.hs0000755000000000000000000000032307346545000023543 0ustar0000000000000000-- Test selectors cannot be used ambiguously {-# LANGUAGE DuplicateRecordFields #-} data R = MkR { x :: Int, y :: Bool } data S = MkS { x :: Int } main = do print (x (MkS 42)) print (y (MkR 42 42)) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail03.hs0000755000000000000000000000027307346545000023550 0ustar0000000000000000-- Test that a top-level definition with the same name as a record -- field is rejected {-# LANGUAGE DuplicateRecordFields #-} foo = True data T = MkT { foo :: Int } main = print foo ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail04.hs0000755000000000000000000000047307346545000023553 0ustar0000000000000000-- Test that importing an overloaded field and using it as a selector -- leads to a suitable error {-# LANGUAGE DuplicateRecordFields #-} import OverloadedRecFldsFail04_A as I -- Qualified overloaded fields are not allowed here x' = I.x -- But this is okay f e = e { I.x = True, I.y = False } main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail05.hs0000755000000000000000000000043107346545000023546 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -fwarn-unused-binds -Werror #-} module Main (main, T(MkT)) where data S = MkS { foo :: Int } data T = MkT { foo :: Int } -- This should count as a use of S(foo) but not T(foo) main = print ((\ MkS{foo=foo} -> foo) (MkS 3)) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail06.hs0000755000000000000000000000124607346545000023554 0ustar0000000000000000-- Check that unused imports are reported correctly in the presence of -- DuplicateRecordFields {-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Werror -fwarn-unused-imports #-} import OverloadedRecFldsFail06_A (U(x, y), V(MkV, MkV2, x, y), Unused(unused), u, getY) import qualified OverloadedRecFldsFail06_A as M (U(x)) import qualified OverloadedRecFldsFail06_A as N (V(x, y)) import qualified OverloadedRecFldsFail06_A as P (U(x), V(x)) v = MkV2 True -- Check that this counts a use of U(x) and V(y) but not U(y) or V(x)... main = do print (u { x = True } :: U) print ((\ MkV2{y=y} -> y) v) print (N.x v) print (getY (v { P.x = 3 })) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail07.hs0000755000000000000000000000023207346545000023547 0ustar0000000000000000-- Test type errors contain field names, not selector names {-# LANGUAGE DuplicateRecordFields #-} data T = MkT { x :: Int } y = x x main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail08.hs0000755000000000000000000000052707346545000023557 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} data family F a data instance F Int = MkFInt { x :: Int } data instance F Bool = MkFBool { y :: Bool } -- No data type has both these fields, but they belong to the same -- lexical parent (F). This used to confuse DuplicateRecordFields. foo e = e { x = 3, y = True } main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail09.hs0000755000000000000000000000054607346545000023561 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} data S = MkS { x :: Int } data T = MkT { x :: Int } -- This tests what happens when an ambiguous record update is used in -- a splice: since it can't be represented in TH, it should error -- cleanly, rather than panicking or silently using one field. foo = [e| (MkS 3) { x = 3 } |] main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail10.hs0000755000000000000000000000052007346545000023541 0ustar0000000000000000-- Modules A and B both declare F(foo) -- Module C declares F($sel:foo:MkFChar) but exports A.F(foo) as well -- Thus we can't export F(..) even with DuplicateRecordFields enabled {-# LANGUAGE DuplicateRecordFields #-} module Main (main, F(..)) where import OverloadedRecFldsFail10_B import OverloadedRecFldsFail10_C main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail11.hs0000755000000000000000000000021007346545000023536 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Werror #-} import OverloadedRecFldsFail11_A main = print (foo (MkS True :: S)) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail12.hs0000755000000000000000000000041507346545000023546 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} {-# OPTIONS_GHC -Werror #-} import OverloadedRecFldsFail12_A data S = MkS { foo :: Bool } -- Use of foo and bar should give deprecation warnings f :: T -> T f e = e { foo = 3, bar = 3 } s :: T -> Int s = foo main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail13.hs0000755000000000000000000000046107346545000023550 0ustar0000000000000000-- Test that giving a stupid type annotation to an ambiguous field -- yields a sensible error message {-# LANGUAGE DuplicateRecordFields #-} data S = MkS { x :: Int } data T = MkT { x :: Bool } data U = MkU a = x (MkU :: U) b = x (MkU :: a) c :: U -> Int c = x d :: a -> Int d = x main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsfail14.hs0000755000000000000000000000035707346545000023555 0ustar0000000000000000{-# LANGUAGE DuplicateRecordFields #-} -- Test that we deal gracefully with non-fields in updates data S = MkS { x :: Int } data T = MkT { x :: Int } y :: Bool y = True -- y isn't a field f r = r { x = 3, y = False } main = return () ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun01.hs0000755000000000000000000000135607346545000023442 0ustar0000000000000000-- Test that unambiguous constructions remain valid when -- DuplicateRecordFields is enabled {-# LANGUAGE DuplicateRecordFields #-} data S = MkS { x :: Int } deriving Show data T = MkT { x :: Bool, y :: Bool -> Bool, tField :: Bool } data U a = MkU { x :: a, y :: a } -- Construction is unambiguous s = MkS { x = 42 } t = MkT { x = True, y = id, tField = False } -- Pattern matching is unambiguous get_x MkS{x=x} = x -- Resolving ambiguous monomorphic updates a = t { x = False, y = not, tField = True } -- only T has all these fields b = s { x = 3 } :: S -- type being pushed in c = (t :: T) { x = False } -- type signature on record expression -- Unambiguous selectors are in scope normally z = tField t main = print (get_x b) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun02.hs0000755000000000000000000000026707346545000023443 0ustar0000000000000000-- This module does not enable -XDuplicateRecordFields, but it should -- still be able to refer to non-overloaded fields like `y` import OverloadedRecFldsRun02_A main = print (y u) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun03.hs0000755000000000000000000000105707346545000023442 0ustar0000000000000000-- Test that DuplicateRecordFields can be used along with -- TypeFamilies (with selectors only if unambiguous) {-# LANGUAGE DuplicateRecordFields, TypeFamilies #-} data family F a data instance F Int = MkFInt { foo :: Int } data instance F Bool = MkFBool { bar :: Bool, baz :: Bool } data family G a data instance G Int = MkGInt { foo :: Int } data instance G Bool = MkGBool { bar :: Bool } x = MkFBool { bar = False, baz = True } y :: F Bool y = x { bar = True } get_bar MkFBool{bar=bar} = bar main = do print (baz y) print (get_bar y) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun04.hs0000755000000000000000000000232507346545000023442 0ustar0000000000000000-- Test that DuplicateRecordFields works with TemplateHaskell {-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} import Language.Haskell.TH import Language.Haskell.TH.Syntax -- Splice in a datatype with field... $(return [DataD [] (mkName "R") [] [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []]) -- New TH story means reify only sees R if we do this: $(return []) -- ... and check that we can inspect it main = do putStrLn $(do { info <- reify ''R ; case info of TyConI (DataD _ _ _ [RecC _ [(n, _, _)]] _) -> do { info' <- reify n ; lift (pprint info ++ "\n" ++ pprint info') } _ -> error "unexpected result of reify" }) putStrLn $(do { info <- reify 'foo ; case info of VarI n _ _ -> do { info' <- reify n ; lift (pprint info ++ "\n" ++ pprint info') } }) print (foo (MkR { foo = 42 })) ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun05.hs0000755000000000000000000000073307346545000023444 0ustar0000000000000000-- Test that DuplicateRecordFields works with NamedFieldPuns and -- RecordWildCards {-# LANGUAGE DuplicateRecordFields, NamedFieldPuns, RecordWildCards #-} data S = MkS { foo :: Int } deriving Show data T = MkT { foo :: Int } deriving Show f MkS{foo} = MkT{foo} g MkT{..} = MkS{..} h e = let foo = 6 in e { foo } :: S main = do print a print b print c print d where foo = 42 a = MkS{foo} b = f a c = g b d = h c ghc-exactprint-0.6.2/tests/examples/ghc80/overloadedrecfldsrun06.hs0000755000000000000000000000063607346545000023447 0ustar0000000000000000-- Test that ambiguous selectors can be disambiguated by providing -- type signatures in various places {-# LANGUAGE DuplicateRecordFields #-} data S = MkS { x :: Int } data T = MkT { x :: Bool } data U a = MkU { x :: a } x_for_s :: S -> Int x_for_s = x x_for_t = x :: T -> Bool x_for_u u = x (u :: U Int) k :: (T -> Bool) -> Bool k f = f (MkT True) main = do print (x_for_s (MkS 42)) print (k x) ghc-exactprint-0.6.2/tests/examples/ghc80/performGC.hs0000755000000000000000000000105207346545000020742 0ustar0000000000000000module Main (main) where -- Test for #10545 import System.Environment import Control.Concurrent import Control.Exception import Control.Monad import RandomPGC import System.Mem import qualified Data.Set as Set main = do [n] <- getArgs forkIO $ doSomeWork forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC doSomeWork :: IO () doSomeWork = forever $ do ns <- replicateM 10000 randomIO :: IO [Int] ms <- replicateM 1000 randomIO let set = Set.fromList ns elems = filter (`Set.member` set) ms evaluate $ sum elems ghc-exactprint-0.6.2/tests/examples/ghc80/plugins07.hs0000755000000000000000000000011207346545000020702 0ustar0000000000000000module Main where {-# NOINLINE x #-} x = "foo" main = putStrLn (show x) ghc-exactprint-0.6.2/tests/examples/ghc80/pmc001.hs0000755000000000000000000000076707346545000020072 0ustar0000000000000000{-# LANGUAGE TypeFamilies, GADTs #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module PMC001 where data family T a data instance T [a] where MkT1 :: T [Int] MkT2 :: Char -> T [Char] MkT3 :: T [a] f :: T [a] -> T [a] -> Bool f MkT1 MkT1 = True f (MkT2 _) (MkT2 _) = True f MkT3 MkT3 = True g :: T [a] -> T [a] -> Bool g x y | MkT1 <- x, MkT1 <- y = True | (MkT2 _) <- x, (MkT2 _) <- y = True | MkT3 <- x, MkT3 <- y = True ghc-exactprint-0.6.2/tests/examples/ghc80/pmc002.hs0000755000000000000000000000026307346545000020062 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module PMC002 where f :: [a] -> Bool f [] = True f x | (_:_) <- x = False -- exhaustive ghc-exactprint-0.6.2/tests/examples/ghc80/pmc003.hs0000755000000000000000000000026007346545000020060 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module PMC003 where f :: Bool -> Bool -> () f _ False = () f True False = () f _ _ = () ghc-exactprint-0.6.2/tests/examples/ghc80/pmc004.hs0000755000000000000000000000040207346545000020057 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} {-# LANGUAGE GADTs #-} module PMC004 where data F a where F1 :: F Int F2 :: F Bool data G a where G1 :: G Int G2 :: G Char h :: F a -> G a -> () h F1 G1 = () h _ G1 = () ghc-exactprint-0.6.2/tests/examples/ghc80/pmc005.hs0000755000000000000000000000035507346545000020067 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} {-# LANGUAGE GADTs #-} module PMC005 where data T a where TList :: T [a] TBool :: T Bool foo :: T c -> T c -> () foo TList _ = () foo _ TList = () ghc-exactprint-0.6.2/tests/examples/ghc80/pmc006.hs0000755000000000000000000000103507346545000020064 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module PMC006 where len :: [a] -> Int len xs = case xs of [] -> 0 (_:ys) -> case () of () | (_:_) <- xs -> 1 + len ys -- -- we would like these to work too but they don't yet -- -- len :: [a] -> Int -- len [] = 0 -- len xs = case xs of -- (_:ys) -> 1 + len ys -- -- len :: [a] -> Int -- len xs = case xs of -- [] -> 0 -- ys -> case ys of -- (_:zs) -> 1 + len zs ghc-exactprint-0.6.2/tests/examples/ghc80/pmc007.hs0000755000000000000000000000056607346545000020075 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} {-# LANGUAGE OverloadedStrings #-} module PMC007 where -- overloaded f "ab" = () f "ac" = () -- non-overloaded g :: String -> () g "ab" = () g "ac" = () -- non-overloaded due to type inference h :: String -> () h s = let s' = s in case s' of "ab" -> () "ac" -> () ghc-exactprint-0.6.2/tests/examples/ghc80/poly-export-fail2.hs0000755000000000000000000000020007346545000022345 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Foo (A(P)) where data A = A data B = B pattern P :: () => (f ~ B) => f pattern P = B ghc-exactprint-0.6.2/tests/examples/ghc80/poly-export.hs0000755000000000000000000000046307346545000021365 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ViewPatterns #-} module Foo (Foo(P)) where data Foo a = Foo a instance C Foo where build a = Foo a destruct (Foo a) = a class C f where build :: a -> f a destruct :: f a -> a pattern P :: C f => a -> f a pattern P x <- (destruct -> x) where P x = build x ghc-exactprint-0.6.2/tests/examples/ghc80/poly-export2.hs0000755000000000000000000000032507346545000021444 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleInstances #-} module Foo (A(P,Q)) where data A a = A a pattern P :: Show a => a -> A a pattern P a = A a pattern Q :: (A ~ f) => a -> f a pattern Q a = A a ghc-exactprint-0.6.2/tests/examples/ghc80/poly-export3.hs0000755000000000000000000000021707346545000021445 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} -- Testing polykindedness module Foo ( A(P) ) where data A a = A pattern P = A ghc-exactprint-0.6.2/tests/examples/ghc80/records-check-sels.hs0000755000000000000000000000026607346545000022544 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Qux where -- Make sure selectors aren't generated for normal synonyms pattern Uni a = Just a pattern a :+: b = (a, b) qux = a (Just True) ghc-exactprint-0.6.2/tests/examples/ghc80/records-compile.hs0000755000000000000000000000027507346545000022153 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module ShouldCompile where pattern Single{x} = [x] -- Selector selector :: Int selector = x [5] update :: [String] update = ["String"] { x = "updated" } ghc-exactprint-0.6.2/tests/examples/ghc80/records-exquant.hs0000755000000000000000000000033407346545000022204 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} module ExQuant where data Showable = forall a . Show a => Showable a pattern Nasty{a} = Showable a qux = a (Showable True) foo = (Showable ()) { a = True } ghc-exactprint-0.6.2/tests/examples/ghc80/records-mixing-fields.hs0000755000000000000000000000042507346545000023257 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} data MyRec = MyRec { foo :: Int, qux :: String } pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} updater,updater1, updater2 :: MyRec -> MyRec updater a = a {f1 = 1 } updater1 a = a {f1 = 1, qux = "two" } updater2 a = a {f1 = 1, foo = 2 } ghc-exactprint-0.6.2/tests/examples/ghc80/records-no-uni-update.hs0000755000000000000000000000020007346545000023174 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module RecordPats where -- No updates pattern Uni{a,b} <- (a, b) foo = ("a","b") { a = "b" } ghc-exactprint-0.6.2/tests/examples/ghc80/records-no-uni-update2.hs0000755000000000000000000000023707346545000023270 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module RecordPats where -- No updates pattern Uni{a} <- Just a qux = a (Just True) qux2 (Uni b) = b foo = Uni { a = "b" } ghc-exactprint-0.6.2/tests/examples/ghc80/records-poly-update.hs0000755000000000000000000000031207346545000022756 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Main where pattern ReqNoProv :: Show a => a -> Maybe a pattern ReqNoProv{j} = Just j data A = A deriving Show p1 = Just True p6 = p1 {j = A} main = print p6 ghc-exactprint-0.6.2/tests/examples/ghc80/records-poly.hs0000755000000000000000000000047707346545000021512 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module PolyPat where -- Testing whether type changing updates work correctly. pattern MyTuple :: a -> b -> (a, b) pattern MyTuple{mfst, msnd} = (mfst, msnd) expr1 :: (Int, String) -> (Int, Int) expr1 a = a { msnd = 2} expr3 a = a { msnd = 2} expr2 :: (a, b) -> a expr2 a = mfst a ghc-exactprint-0.6.2/tests/examples/ghc80/records-prov-req.hs0000755000000000000000000000110707346545000022271 0ustar0000000000000000{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, StandaloneDeriving, FlexibleInstances #-} module ShouldCompile where -- Testing that selectors work properly with prov and req thetas data T a b where MkT :: (Show b) => a -> b -> T a b deriving instance Show (T Int A) data G a b = MkG { care :: a, y :: (Show b => b) } pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b pattern ExNumPat{x} = MkT 42 x data A = A | B deriving (Show, Eq) f3 :: T Int A f3 = (MkT 42 A) { x = B } f5 :: T Int A f5 = (ExNumPat A) { x = B } f4 = (MkG 42 True) { y = False } ghc-exactprint-0.6.2/tests/examples/ghc80/records-req-only.hs0000755000000000000000000000047707346545000022275 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NoImplicitPrelude #-} module Main where import Prelude (Maybe(..), Show(..), String, Bool(..), print) pattern ReqNoProv :: Show a => a -> Maybe a pattern ReqNoProv{j} = Just j p1 = ReqNoProv True p7 (ReqNoProv _) = ReqNoProv False p6 = p1 {j = False} main = print p6 ghc-exactprint-0.6.2/tests/examples/ghc80/records-req.hs0000755000000000000000000000043107346545000021304 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} -- Pattern synonyms module ShouldCompile where data T a where MkT :: (Eq b) => a -> b -> T a f :: (Show a) => a -> Bool f = undefined pattern P{x} <- MkT (f -> True) x ghc-exactprint-0.6.2/tests/examples/ghc80/records-run.hs0000755000000000000000000000032407346545000021322 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module Main where pattern Bi{a, b} = (a, b) foo = ("a","b") main = do print foo print (a foo) print (b foo) print (foo {a = "c"}) print (foo {a = "fst", b = "snd"}) ghc-exactprint-0.6.2/tests/examples/ghc80/spec-inline-determ.hs0000755000000000000000000000222407346545000022544 0ustar0000000000000000module Roman where -- This is a simplified version of simplCore/should_compile/spec-inline.hs -- -- It reproduces a problem where workers get specialized in different ways -- depending on the values of uniques. -- -- Compare: -- -- $s$wgo_s1CN :: Int# -> Int -> Int# -- [LclId, Arity=2, Str=DmdType ] -- $s$wgo_s1CN = -- \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) -> -- case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] { -- False -> -- $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ); -- True -> 0# -- } -- -- vs -- -- $s$wgo_s18mTj :: Int -> Int# -> Int# -- [LclId, Arity=2, Str=DmdType ] -- $s$wgo_s18mTj = -- \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) -> -- case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] { -- False -> -- $wgo_s18mUc -- (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn); -- True -> 0# -- } foo :: Int -> Int foo n = go (Just n) (Just (6::Int)) where go Nothing (Just x) = go (Just 10) (Just x) go (Just n) (Just x) | n <= 0 = 0 | otherwise = go (Just (n-1)) (Just x) ghc-exactprint-0.6.2/tests/examples/ghc80/stringSource.hs0000755000000000000000000001071207346545000021550 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} -- This program must be called with GHC's libdir as the single command line -- argument. module Main where -- import Data.Generics import Data.Data import Data.List import System.IO import GHC import BasicTypes import DynFlags import FastString import ForeignCall import MonadUtils import Outputable import HsDecls import Bag (filterBag,isEmptyBag) import System.Directory (removeFile) import System.Environment( getArgs ) import qualified Data.Map as Map import Data.Dynamic ( fromDynamic,Dynamic ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName testOneFile libdir fileName = do ((anns,cs),p) <- runGhc (Just libdir) $ do dflags <- getSessionDynFlags setSessionDynFlags dflags let mn =mkModuleName fileName addTarget Target { targetId = TargetModule mn , targetAllowObjCode = True , targetContents = Nothing } load LoadAllTargets modSum <- getModSummary mn p <- parseModule modSum return (pm_annotations p,p) let tupArgs = gq (pm_parsed_source p) putStrLn (pp tupArgs) -- putStrLn (intercalate "\n" [showAnns anns]) where gq ast = everything (++) ([] `mkQ` doWarningTxt `extQ` doImportDecl `extQ` doCType `extQ` doRuleDecl `extQ` doCCallTarget `extQ` doHsExpr ) ast doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])] doWarningTxt ((WarningTxt _ ss)) = [("w",map conv ss)] doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)] doImportDecl :: ImportDecl RdrName -> [(String,[Located (SourceText,FastString)])] doImportDecl (ImportDecl _ _ Nothing _ _ _ _ _ _) = [] doImportDecl (ImportDecl _ _ (Just ss) _ _ _ _ _ _) = [("i",[conv (noLoc ss)])] doCType :: CType -> [(String,[Located (SourceText,FastString)])] doCType (CType src (Just (Header hs hf)) c) = [("c",[noLoc (hs,hf),noLoc c])] doCType (CType src Nothing c) = [("c",[noLoc c])] doRuleDecl :: RuleDecl RdrName -> [(String,[Located (SourceText,FastString)])] doRuleDecl (HsRule ss _ _ _ _ _ _) = [("r",[ss])] doCCallTarget :: CCallTarget -> [(String,[Located (SourceText,FastString)])] doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])] doHsExpr :: HsExpr RdrName -> [(String,[Located (SourceText,FastString)])] doHsExpr (HsCoreAnn src ss _) = [("co",[conv (noLoc ss)])] doHsExpr (HsSCC src ss _) = [("sc",[conv (noLoc ss)])] doHsExpr (HsTickPragma src (ss,_,_) _) = [("tp",[conv (noLoc ss)])] doHsExpr _ = [] conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs) showAnns anns = "[\n" ++ (intercalate "\n" $ map (\((s,k),v) -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n")) $ Map.toList anns) ++ "]\n" pp a = showPpr unsafeGlobalDynFlags a -- --------------------------------------------------------------------- -- Copied from syb for the test -- | Generic queries of type \"r\", -- i.e., take any \"a\" and return an \"r\" -- type GenericQ r = forall a. Data a => a -> r -- | Make a generic query; -- start from a type-specific case; -- return a constant otherwise -- mkQ :: ( Typeable a , Typeable b ) => r -> (b -> r) -> a -> r (r `mkQ` br) a = case cast a of Just b -> br b Nothing -> r -- | Extend a generic query by a type-specific case extQ :: ( Typeable a , Typeable b ) => (a -> q) -> (b -> q) -> a -> q extQ f g a = maybe (f a) g (cast a) -- | Summarise all nodes in top-down, left-to-right order everything :: (r -> r -> r) -> GenericQ r -> GenericQ r -- Apply f to x to summarise top-level node; -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results everything k f x = foldl k (f x) (gmapQ (everything k f) x) ghc-exactprint-0.6.2/tests/examples/ghc80/t10255.hs0000755000000000000000000000022607346545000017720 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10268.hs0000755000000000000000000000022607346545000017724 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10269.hs0000755000000000000000000000022607346545000017725 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10278.hs0000755000000000000000000000022607346545000017725 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10280.hs0000755000000000000000000000022607346545000017716 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10307.hs0000755000000000000000000000022607346545000017716 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10309.hs0000755000000000000000000000022607346545000017720 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10312.hs0000755000000000000000000000022607346545000017712 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10354.hs0000755000000000000000000000022607346545000017720 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10357.hs0000755000000000000000000000022607346545000017723 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10358.hs0000755000000000000000000000022607346545000017724 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10396.hs0000755000000000000000000000022607346545000017726 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/t10399.hs0000755000000000000000000000022607346545000017731 0ustar0000000000000000import CheckUtils import System.Environment( getArgs ) main::IO() main = do [libdir,fileName] <- getArgs testOneFile libdir fileName ghc-exactprint-0.6.2/tests/examples/ghc80/tc265.hs0000755000000000000000000000017707346545000017730 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Tc265 where data T a = MkT (F a) type family F a where F (T a) = a F (T Int) = Bool ghc-exactprint-0.6.2/tests/examples/ghc80/tcfail223.hs0000755000000000000000000000043007346545000020546 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module ShouldFail where class Class1 a class Class1 a => Class2 a class Class2 a => Class3 a -- This was wrongfully accepted by ghc-7.0 to ghc-7.10. -- It is missing a `Class1 a` constraint. instance Class3 a => Class2 a ghc-exactprint-0.6.2/tests/examples/ghc80/update-existential.hs0000755000000000000000000000073007346545000022671 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude , ExistentialQuantification #-} module Test where hGetContents handle_ = handle_{ haType=SemiClosedHandle} data HandleType = SemiClosedHandle class Show a where show :: a -> a -- they have to check whether the handle has indeed been closed. data Handle__ = forall dev . (Show dev) => Handle__ { haDevice :: !dev, haType :: HandleType -- type (read/write/append etc.) } ghc-exactprint-0.6.2/tests/examples/ghc82/0000755000000000000000000000000007346545000016523 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc82/Completesig03A.hs0000755000000000000000000000010107346545000021571 0ustar0000000000000000module Completesig03A where data A = A | B {-# COMPLETE A #-} ghc-exactprint-0.6.2/tests/examples/ghc82/Lib.hs0000755000000000000000000000052207346545000017567 0ustar0000000000000000{-# LANGUAGE UnboxedSums, MagicHash #-} module Lib (flip, getInt) where import GHC.Exts import Prelude (Int) {-# NOINLINE flip #-} flip :: (# Int | Int# #) -> (# Int# | Int #) flip (# i | #) = (# | i #) flip (# | i #) = (# i | #) {-# NOINLINE getInt #-} getInt :: (# Int# | Int #) -> Int getInt (# i | #) = I# i getInt (# | i #) = i ghc-exactprint-0.6.2/tests/examples/ghc82/List2.hs0000755000000000000000000000222607346545000020061 0ustar0000000000000000{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- | -- Module : Type.Family.List -- Copyright : Copyright (C) 2015 Kyle Carter -- License : BSD3 -- -- Maintainer : Kyle Carter -- Stability : experimental -- Portability : RankNTypes -- -- Convenient aliases and type families for working with -- type-level lists. ---------------------------------------------------------------------------- module Type.Family.List where import Type.Family.Constraint import Type.Family.Monoid import Type.Family.Tuple hiding (type (<$>),type (<*>),type (<&>)) import Type.Class.Witness type Ø = '[] type (:<) = '(:) infixr 5 :< ghc-exactprint-0.6.2/tests/examples/ghc82/Ppr048.hs0000755000000000000000000000016707346545000020063 0ustar0000000000000000module Ppr048 where {-# SCc foo #-} foo :: Int -> Int foo x = x {-# SCc foo2 "label" #-} foo2 :: () foo2 = () ghc-exactprint-0.6.2/tests/examples/ghc82/T11727.hs0000755000000000000000000000014707346545000017671 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module T11727 where pattern A,B :: Int pattern A = 5 pattern B = 5 ghc-exactprint-0.6.2/tests/examples/ghc82/T13050.hs0000755000000000000000000000014607346545000017657 0ustar0000000000000000module HolesInfix where f, g, q :: Int -> Int -> Int f x y = _ x y g x y = x `_` y q x y = x `_a` y ghc-exactprint-0.6.2/tests/examples/ghc82/T13594.hs0000755000000000000000000000026207346545000017673 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Bug where x :: forall a b. (a ~ Integer, b ~ Integer) => (a, b) !x = (1, 2) ~y = (1, 2) ghc-exactprint-0.6.2/tests/examples/ghc82/brackets.hs0000755000000000000000000000161007346545000020656 0ustar0000000000000000{-# LANGUAGE Arrows #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnicodeSyntax #-} -- See Trac #10162 and #11743 for details module ShouldCompile where import Control.Arrow import Language.Haskell.TH handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s))) f :: ArrowPlus a => a (Int,Int) String f = proc (x,y) -> ⦇handle (returnA -< show y) (\s -> returnA -< s ++ show x) ⦈ g :: ArrowPlus a => a (Int,Int) String g = proc (x,y) -> ⦇handle (\msg -> returnA -< msg ++ show y) (\s msg -> returnA -< s ++ show x) ⦈ ("hello " ++ show x) h :: ArrowPlus a => a (Int,Int) Int h = proc (x,y) -> ( (\z -> returnA -< x + z) <+> (\z -> returnA -< y + z) ) (x*y) matches :: PatQ -> ExpQ matches pat = ⟦\x -> case x of $pat -> True _ -> False ⟧ ghc-exactprint-0.6.2/tests/examples/ghc82/completesig01.hs0000755000000000000000000000044007346545000021534 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wall #-} module Simple where pattern Foo :: () pattern Foo = () a :: () -> () a Foo = () data A = B | C | D {-# COMPLETE Foo #-} {-# COMPLETE B,C #-} {-# COMPLETE B #-} b :: A -> A b B = B b C = C ghc-exactprint-0.6.2/tests/examples/ghc84/0000755000000000000000000000000007346545000016525 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc84/Functors.hs0000755000000000000000000004041607346545000020674 0ustar0000000000000000-- | Types are great. Lifting them into some sort of applicative functor makes -- them even better. This module is an homage to our favorite applicatives, and -- to the semigroups with which they are instrinsically connected. {-# LANGUAGE NoImplicitPrelude #-} -- Prelude is bad {-# LANGUAGE DeriveFunctor #-} -- Writing Functor instances is boring module Acme.Functors ( -- * Lifted-but-why LiftedButWhy (..) -- * Or-not , OrNot (..) -- * Two , Two (..) -- * Any-number-of , AnyNumberOf (..), (~~) -- * One-or-more , OneOrMore (..) -- * Also-extra-thing , Also (..) -- * Or-instead-other-thing , OrInstead (..) -- * Or-instead-other-thing ("first" variant) , OrInsteadFirst (..) -- * Determined-by-parameter , DeterminedBy (..) ) where import Acme.Functors.Classes -------------------------------------------------------------------------------- -- Lifted-but-why -------------------------------------------------------------------------------- -- | __@LiftedButWhy@__ is a boring functor that just has one value and no other -- structure or interesting properties. data LiftedButWhy a = LiftedButWhy a -- ^ A value that has been lifted for some damned reason. -- -- ... Okay, to be honest, this one is /nobody's/ favorite, but it is -- included here for completeness. deriving (Eq, Functor, Show) -- | > pure = LiftedButWhy -- > -- > LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) instance Applicative LiftedButWhy where pure = LiftedButWhy LiftedButWhy f <*> LiftedButWhy a = LiftedButWhy (f a) -- | > LiftedButWhy a >>= f = f a instance Monad LiftedButWhy where LiftedButWhy a >>= f = f a -- | > LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) instance Semigroup a => Semigroup (LiftedButWhy a) where LiftedButWhy x <> LiftedButWhy y = LiftedButWhy (x <> y) -- | > mempty = LiftedButWhy mempty instance Monoid a => Monoid (LiftedButWhy a) where mempty = LiftedButWhy mempty -------------------------------------------------------------------------------- -- Or-not -------------------------------------------------------------------------------- -- | __@OrNot@__ is somehow slightly more interesting than @LiftedButWhy@, even -- though it may actually contain /less/. Instead of a value, there might /not/ -- be a value. -- -- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to -- be present. If any of them are absent, the whole expression evaluates to -- @Nope@. data OrNot a = ActuallyYes a -- ^ Some normal value. | Nope -- ^ Chuck Testa. deriving (Eq, Functor, Show) -- | If you have a function @f@ that might not actually be there, and a value -- @a@ that might not actually be there, lifted application @(\<*\>)@ gives you -- @f a@ only if both of them are actually there. -- -- > pure = ActuallyYes -- > -- > ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) -- > _ <*> _ = Nope instance Applicative OrNot where pure = ActuallyYes ActuallyYes f <*> ActuallyYes a = ActuallyYes (f a) _ <*> _ = Nope instance Monad OrNot where ActuallyYes a >>= f = f a Nope >>= _ = Nope -- | If you have value @a@ that may not actually be there, and another value -- @a'@ that might not actually be there, the lifted semigroup operation -- @(\<\>)@ gives you @a \<\> a'@ only if both of them are actually there. -- -- > ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') -- > _ <> _ = Nope instance Semigroup a => Semigroup (OrNot a) where ActuallyYes a <> ActuallyYes a' = ActuallyYes (a <> a') _ <> _ = Nope -- | > mempty = ActuallyYes mempty instance Monoid a => Monoid (OrNot a) where mempty = ActuallyYes mempty -------------------------------------------------------------------------------- -- Two -------------------------------------------------------------------------------- -- | __@Two@__ is /two/ values. Yep. Just two values. data Two a = Two { firstOfTwo :: a -- ^ One value. , secondOfTwo :: a -- ^ Another value. } deriving (Eq, Functor, Show) -- | If you have two functions @f@ and @g@ and two values @a@ and @a'@, then you -- can apply them with @(\<*\>)@ to get two results @f a@ and @g a'@. -- -- > pure a = Two a a -- > -- > Two f g <*> Two a a' = Two (f a) (g a') instance Applicative Two where pure a = Two a a Two f g <*> Two a a' = Two (f a) (g a') -- | > Two x y <> Two x' y' = Two (x <> x') (y <> y') instance Semigroup a => Semigroup (Two a) where Two x y <> Two x' y' = Two (x <> x') (y <> y') -- | > mempty = Two mempty mempty instance Monoid a => Monoid (Two a) where mempty = Two mempty mempty -------------------------------------------------------------------------------- -- Any-number-of -------------------------------------------------------------------------------- -- | __@AnyNumberOf@__ starts to get exciting. Any number of values you want. -- Zero... one ... two ... three ... four ... five ... The possibilities are -- /truly/ endless. data AnyNumberOf a = OneAndMaybeMore a (AnyNumberOf a) -- ^ One value, and maybe even more after that! | ActuallyNone -- ^ Oh. Well this is less fun. deriving (Eq, Functor, Show) -- | Alias for 'OneAndMaybeMore' which provides some brevity. (~~) :: a -> AnyNumberOf a -> AnyNumberOf a (~~) = OneAndMaybeMore infixr 5 ~~ -- | You can use this to apply any number of functions to any number of -- arguments. -- -- > pure a = OneAndMaybeMore a ActuallyNone -- > -- > OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = -- > OneAndMaybeMore (f x) (fs <*> xs) -- > _ <*> _ = ActuallyNone -- -- Example: -- -- > ( (+ 1) ~~ (* 2) ~~ (+ 5) ~~ ActuallyNone ) -- > <*> ( 1 ~~ 6 ~~ 4 ~~ 37 ~~ ActuallyNone ) -- > = ( 7 ~~ 12 ~~ 9 ~~ ActuallyNone ) -- -- This example demonstrates how when there are more arguments than functions, -- any excess arguments (in this case, the @37@) are ignored. instance Applicative AnyNumberOf where pure a = OneAndMaybeMore a ActuallyNone OneAndMaybeMore f fs <*> OneAndMaybeMore x xs = OneAndMaybeMore (f x) (fs <*> xs) _ <*> _ = ActuallyNone -- | The operation of combining some number of @a@ with some other number of @a@ -- is sometimes referred to as /zipping/. -- -- > OneAndMaybeMore x xs <> OneAndMaybeMore y ys = -- > OneAndMaybeMore (x <> y) (xs <> ys) -- > _ <> _ = ActuallyNone instance Semigroup a => Semigroup (AnyNumberOf a) where OneAndMaybeMore x xs <> OneAndMaybeMore y ys = OneAndMaybeMore (x <> y) (xs <> ys) _ <> _ = ActuallyNone -- | > mempty = mempty ~~ mempty instance Monoid a => Monoid (AnyNumberOf a) where mempty = mempty ~~ mempty -------------------------------------------------------------------------------- -- One-or-more -------------------------------------------------------------------------------- -- | __@OneOrMore@__ is more restrictive than AnyNumberOf, yet somehow actually -- /more/ interesting, because it excludes that dull situation where there -- aren't any values at all. data OneOrMore a = OneOrMore { theFirstOfMany :: a -- ^ Definitely at least this one. , possiblyMore :: AnyNumberOf a -- ^ And perhaps others. } deriving (Eq, Functor, Show) -- | > pure a = OneOrMore a ActuallyNone -- > -- > OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) instance Applicative OneOrMore where pure a = OneOrMore a ActuallyNone OneOrMore f fs <*> OneOrMore x xs = OneOrMore (f x) (fs <*> xs) -- | -- > OneOrMore a more <> OneOrMore a' more' = -- > OneOrMore a (more <> OneAndMaybeMore a' more') instance Semigroup a => Semigroup (OneOrMore a) where OneOrMore a more <> OneOrMore a' more' = OneOrMore a (more <> OneAndMaybeMore a' more') -- | > mempty = OneOrMore mempty ActuallyNone instance Monoid a => Monoid (OneOrMore a) where mempty = OneOrMore mempty ActuallyNone -------------------------------------------------------------------------------- -- Also-extra-thing -------------------------------------------------------------------------------- -- | __@Also extraThing@__ is a functor in which each value has an @extraThing@ -- of some other type that tags along with it. data (Also extraThing) a = Also { withoutExtraThing :: a -- ^ A value. , theExtraThing :: extraThing -- ^ An additional thing that tags along. } deriving (Eq, Functor, Show) -- | Dragging the @extraThing@ along can be a bit of a burden. It prevents @Also -- extraThing@ from being an applicative functor — unless the @extraThing@ can -- pull its weight by bringing a monoid to the table. -- -- > pure = (`Also` mempty) -- > -- > (f `Also` extra1) <*> (a `Also` extra2) = f a -- > `Also` (extra1 <> extra2) instance Monoid extraThing => Applicative (Also extraThing) where pure = (`Also` mempty) (f `Also` extra1) <*> (a `Also` extra2) = f a `Also` (extra1 <> extra2) -- | -- > (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') -- > `Also` (extra1 <> extra2) instance (Semigroup extraThing, Semigroup a) => Semigroup ((Also extraThing) a) where (a `Also` extra1) <> (a' `Also` extra2) = (a <> a') `Also` (extra1 <> extra2) -- | > mempty = Also mempty mempty instance (Monoid extraThing, Monoid a) => Monoid ((Also extraThing) a) where mempty = Also mempty mempty -------------------------------------------------------------------------------- -- Or-instead-other-thing -------------------------------------------------------------------------------- -- | __@OrInstead otherThing@__ is a functor in which, instead of having a -- value, can actually just have some totally unrelated @otherThing@ instead. -- -- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to -- be present. If any of them are the @otherThing@ instead, then the whole -- expression evaluates to the combination of the @otherThing@s. data (OrInstead otherThing) a = NotInstead a -- ^ Some normal value. | Instead otherThing -- ^ Some totally unrelated other thing. deriving (Eq, Functor, Show) -- | The possibility of having an @otherThing@ obstructs this functor's ability -- to be applicative, much like the extra thing in @Also extraThing@ does. In -- this case, since we do not need an empty value for the @otherThing@, it needs -- only a semigroup to be in compliance. -- -- > pure = NotInstead -- > -- > NotInstead f <*> NotInstead a = NotInstead (f a) -- > Instead other1 <*> Instead other2 = Instead (other1 <> other2) -- > Instead other <*> _ = Instead other -- > _ <*> Instead other = Instead other instance Semigroup otherThing => Applicative (OrInstead otherThing) where pure = NotInstead NotInstead f <*> NotInstead a = NotInstead (f a) Instead other1 <*> Instead other2 = Instead (other1 <> other2) Instead other <*> _ = Instead other _ <*> Instead other = Instead other -- | -- > NotInstead a <> NotInstead a' = NotInstead (a <> a') -- > Instead other1 <> Instead other2 = Instead (other1 <> other2) -- > Instead other <> _ = Instead other -- > _ <> Instead other = Instead other instance (Semigroup otherThing, Semigroup a) => Semigroup ((OrInstead otherThing) a) where NotInstead a <> NotInstead a' = NotInstead (a <> a') Instead other1 <> Instead other2 = Instead (other1 <> other2) Instead other <> _ = Instead other _ <> Instead other = Instead other -- > mempty = NotInstead mempty instance (Semigroup otherThing, Monoid a) => Monoid ((OrInstead otherThing) a) where mempty = NotInstead mempty -------------------------------------------------------------------------------- -- Or-instead-first-thing -------------------------------------------------------------------------------- -- | __@OrInsteadFirst otherThing@__ looks a lot like @OrInstead otherThing@, -- but it manages to always be an applicative functor — and even a monad too — -- by handling the @otherThing@s a bit more hamfistedly. -- -- When you combine stuff with @(\<*\>)@ or @(\<\>)@, all of the values need to -- be present. If any of them are the @otherThing@ instead, then the whole -- expression evaluates to the /first/ @otherThing@ encountered, ignoring any -- additional @otherThings@ that may subsequently pop up data (OrInsteadFirst otherThing) a = NotInsteadFirst a -- ^ Some normal value. | InsteadFirst otherThing -- ^ Some totally unrelated other thing. deriving (Eq, Functor, Show) -- | -- > pure = NotInsteadFirst -- > -- > NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) -- > InsteadFirst other <*> _ = InsteadFirst other -- > _ <*> InsteadFirst other = InsteadFirst other instance Applicative (OrInsteadFirst otherThing) where pure = NotInsteadFirst NotInsteadFirst f <*> NotInsteadFirst a = NotInsteadFirst (f a) InsteadFirst other <*> _ = InsteadFirst other _ <*> InsteadFirst other = InsteadFirst other -- | -- > InsteadFirst other >>= _ = InsteadFirst other -- > NotInsteadFirst a >>= f = f a instance Monad (OrInsteadFirst otherThing) where InsteadFirst other >>= _ = InsteadFirst other NotInsteadFirst a >>= f = f a -- | -- > NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') -- > InsteadFirst other <> _ = InsteadFirst other -- > _ <> InsteadFirst other = InsteadFirst other instance (Semigroup otherThing, Semigroup a) => Semigroup ((OrInsteadFirst otherThing) a) where NotInsteadFirst a <> NotInsteadFirst a' = NotInsteadFirst (a <> a') InsteadFirst other <> _ = InsteadFirst other _ <> InsteadFirst other = InsteadFirst other -- | > mempty = NotInsteadFirst mempty instance (Semigroup otherThing, Monoid a) => Monoid ((OrInsteadFirst otherThing) a) where mempty = NotInsteadFirst mempty -------------------------------------------------------------------------------- -- Determined-by-parameter -------------------------------------------------------------------------------- -- | __@DeterminedBy parameter@__ is a value that... well, we're not really sure -- what it is. We'll find out once a @parameter@ is provided. -- -- The mechanism for deciding /how/ the value is determined from the -- @parameter@ is opaque; all you can do is test it with different parameters -- and see what results. There aren't even @Eq@ or @Show@ instances, which is -- annoying. data DeterminedBy parameter a = Determination ((->) parameter a) deriving (Functor) -- | -- > pure a = Determination (\_ -> a) -- > -- > Determination f <*> Determination a = Determination (\x -> f x (a x)) instance Applicative (DeterminedBy parameter) where pure a = Determination (\_ -> a) Determination f <*> Determination a = Determination (\x -> f x (a x)) -- | -- > Determination fa >>= ff = -- > Determination (\x -> let Determination f = ff (fa x) in f x) instance Monad (DeterminedBy parameter) where Determination fa >>= ff = Determination (\x -> let Determination f = ff (fa x) in f x) -- | > Determination f <> Determination g = Determination (\x -> f x <> g x) instance Semigroup a => Semigroup ((DeterminedBy parameter) a) where Determination f <> Determination g = Determination (\x -> f x <> g x) -- | > mempty = Determination (\_ -> mempty) instance Monoid a => Monoid ((DeterminedBy parameter) a) where mempty = Determination (\_ -> mempty) {- -------------------------------------------------------------------------------- -- Notes -------------------------------------------------------------------------------- LiftedButWhy is Identity. OrNot is Maybe, but with a different semigroup and monoid. Two doesn't have an analogue in the standard library as far as I know. AnyNumberOf is ZipList. OneOrMore is NonEmpty. Also is (,), the 2-tuple. OrInstead is AccValidation from the 'validation' package. OrInsteadFirst is Either. DeterminedBy is (->) also known as a function, whose functor is also known as Reader. -} ghc-exactprint-0.6.2/tests/examples/ghc84/Main.hs0000755000000000000000000001262107346545000017752 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, StandaloneDeriving, TypeFamilies, GADTs , ViewPatterns, TypeOperators, TypeApplications, StandaloneDeriving , UnicodeSyntax, PatternSynonyms, FlexibleContexts, DataKinds, UndecidableInstances , TypeFamilyDependencies #-} -- invoke as: ghci Main.hs -ddump-parsed -ddump-rn -- or in GHCi: :set -ddump-parsed -ddump-rn import TyFamWitnesses import Language.Haskell.TH hiding (Type) import Data.Type.Equality hiding (apply) import Type.Reflection import Unsafe.Coerce (unsafeCoerce) import Data.Char (ord) import GHC.TypeLits stuffhave = [d| type family Foo a b where Foo a a = Int Foo (IO a) a = Float Foo (IO a) b = Bool Foo a Char = String Foo a b = Char |] stuffhave1 = [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] stuffhave2 = [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] witnesses [d| type family Foo a b where Foo a a = Int Foo (IO a) a = Float Foo (IO a) b = Bool Foo a Char = String Foo a b = Char |] deriving instance Show (FooRefl a b) -- now you can: -- -- >>> :info FooRefl -- type role FooRefl nominal nominal -- data FooRefl a b where -- Foo0 :: (Foo a a ~ Int) => FooRefl a a -- Foo1 :: (Foo (IO b) b ~ Float) => FooRefl (IO b) b -- Foo2 :: (Foo (IO a1) b ~ Bool) => FooRefl (IO a1) b -- Foo3 :: (Foo a Char ~ String) => FooRefl a Char -- Foo4 :: (Foo a b ~ Char) => FooRefl a b -- -- Defined at Main.hs:13:1 -- instance Show (FooRefl a b) -- Defined at Main.hs:14:1 -- -- >>> :info reify_Foo -- reify_Foo :: TypeRep a -> TypeRep b -> Maybe (FooRefl a b) -- -- Defined at Main.hs:13:1 -- -- >>> reify_Foo (typeOf getChar) (typeRep @Char) -- Just Foo1 -- witnesses [d| type family Bar a where Bar Bool = Bool; Bar a = IO a |] deriving instance Show (BarRefl a) witnesses [d| type family Elim a b where Elim a (a -> b) = b; Elim a (c -> b) = c -> Elim a b |] deriving instance Show (ElimRefl a b) pure [] stuffwant2 = [d| fooRefl :: forall a b . TypeRep a -> TypeRep b -> Maybe (FooRefl a b) fooRefl a b | Just HRefl <- eqTypeRep a b = pure Foo0 fooRefl a b | Refl <- unsafeCoerce Refl :: Foo a b :~: Char = pure Foo1 |] stuffhave3 = [d| data Peano = Z | S Peano type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n |] witnesses [d| data Peano = Z | S Peano type family ToPeano (n :: Nat) :: Peano where ToPeano 0 = Z; ToPeano n = S (ToPeano (n-1)) type family FromPeano (p :: Peano) :: Nat where FromPeano Z = 0; FromPeano (S n) = 1 + FromPeano n |] deriving instance Show (ToPeanoRefl n) deriving instance Show (FromPeanoRefl p) witnesses [d| type family Unspell (w :: Symbol) = (r :: Nat) | r -> w where Unspell "zero" = 0 Unspell "one" = 1 Unspell "two" = 2 Unspell "three" = 3 |] deriving instance Show (UnspellRefl w) main = runQ (witnesses stuffhave2) >>= print test@Just{} = reify_Elim (typeRep @Integer) (typeOf ((+1)::Integer->Integer)) lemma :: v -> TypeRep f -> TypeRep v -> Maybe (TypeRep (v `Elim` f), f -> v `Elim` f) lemma w f v = do d `Fun'` c <- pure f witness <- v `reify_Elim` f case witness of Elim0 -> pure (c, ($ w)) Elim1 -> do (e, g) <- lemma w c v pure (d `Fun` e, (g.)) data Tag = Source | Destination | CheckSource Bool | CheckDest Bool | Cut Bool newtype TaggedAction (t :: Tag) = Tagged (IO ()) data Action where Action :: Typeable t ⇒ TaggedAction t → Action Catalyst :: Typeable (c → d) ⇒ (c → d) → Action pattern A :: forall k a. () => forall b. (TaggedAction b ~~ a) => TypeRep b → TypeRep a pattern A b ← (eqTypeRep (typeRep @TaggedAction) → Just HRefl) `App` b reaction :: Action → Action → Maybe Action reaction (Catalyst f) (Action v) = do (rep, f') ← lemma v (typeOf f) (typeOf v) pure $ case rep of _ `Fun'` _ → withTypeable rep (Catalyst $ f' f) A indx → withTypeable indx (Action $ f' f) member :: Eq a => a -> [a] -> Bool member = elem y $$ x = ($ y).($ x) --Just (t3r, (($ elem) -> t3)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') -- https://ghc.haskell.org/trac/ghc/ticket/14293 Just (t3r, (($ "joe").($ elem) -> t3@True)) = lemma 'j' (typeOf $ member @Char) (typeOf 'j') Just (t4r, (($ 'o').($ elem) -> t4@True)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") -- Just (t4'r, ('x' $$ elem -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") -- Same bug Just (t4'r, (($ 'x').($ elem) -> t4'@False)) = lemma "joe" (typeOf $ member @Char) (typeOf "joe") t0@Nothing = lemma "joe" (typeOf ord) (typeOf "joe") Just u0 = reify_FromPeano (typeRep @Z) Just u1 = reify_FromPeano (typeRep @(S Z)) Just u2 = reify_FromPeano (typeRep @(S (S Z))) Just un0 = reify_Unspell (typeRep @"zero") Just un1 = reify_Unspell (typeRep @"one") Just un2 = reify_Unspell (typeRep @"two") ghc-exactprint-0.6.2/tests/examples/ghc84/T13747.hs0000755000000000000000000000065507346545000017703 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} module T13747 where class C a where type family TC a :: * class D a where data family TD a :: * instance C Int where type instance TC Int = Int instance D Double where data instance TD Double = TDDouble instance D Int where newtype instance TD Int = TDInt Int instance D Char where data instance TD Char where C1 :: TD Char C2 :: TD Char ghc-exactprint-0.6.2/tests/examples/ghc84/Types.hs0000755000000000000000000003615507346545000020202 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-duplicate-exports #-} module Graphics.UI.Threepenny.Editors.Types ( -- * GenericWidgets GenericWidget(..) , edited , contents , widgetControl , widgetTidings -- * Editors , Editor(.., Horizontally, horizontally, Vertically, vertically) , liftElement , dimapE , applyE -- ** Editor composition , (|*|), (|*), (*|) , (-*-), (-*), (*-) , field , fieldLayout -- ** Editor constructors , editorUnit , editorIdentity , editorString , editorText , editorCheckBox , editorReadShow , editorEnumBounded , editorSelection , editorSum , editorJust , EditorCollection(..) , editorCollection , editorList , EditorCollectionConfig(..) , defaultEditorCollectionConfig -- ** Representation of empty values , HasEmpty(..) ) where import Control.Monad import Data.Biapplicative import Data.Maybe import Data.HasEmpty import qualified Data.Foldable as F import Data.Functor.Compose import Data.Functor.Identity import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Profunctor import Data.Text (Text) import qualified Data.Text as Text import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core as UI hiding (empty) import Graphics.UI.Threepenny.Editors.Layout import Graphics.UI.Threepenny.Editors.Utils import Graphics.UI.Threepenny.Elements import Graphics.UI.Threepenny.Events import Graphics.UI.Threepenny.Widgets import Text.Read data GenericWidget control a = GenericWidget { widgetTidings :: Tidings a -- ^ The dynamic contents of the widget. , widgetControl :: control -- ^ The actual widget. } deriving Functor instance Bifunctor GenericWidget where bimap f g (GenericWidget t e) = GenericWidget (g <$> t) (f e) traverseControl :: Applicative f => (control -> f control') -> GenericWidget control a -> f (GenericWidget control' a) traverseControl f (GenericWidget t e) = GenericWidget t <$> f e edited :: GenericWidget el a -> Event a edited = rumors . widgetTidings contents :: GenericWidget el a -> Behavior a contents = facts . widgetTidings instance Widget el => Widget (GenericWidget el a) where getElement = getElement . widgetControl instance Renderable el => Renderable (GenericWidget el a) where render = render . widgetControl renderEditor :: Renderable w => GenericWidget w a -> UI (GenericWidget Element a) renderEditor = traverseControl render -- | An editor for values of type @inner@ inside a datatype @outer@ realized by a @widget@. -- -- All the three type arguments are functorial, but @outer@ is contravariant, so @Editor@ is a 'Biapplicative' functor and a 'Profunctor' (via 'dimapE'). -- -- 'Biapplicative' allows to compose editors on both their @widget@ and @inner@ structure. When @widget@ is monoidal, widget composition is implicit and 'Applicative' suffices. -- -- 'Profunctor' allows to apply an @inner@ editor to an @outer@ datatype. -- -- Once 'create'd, an 'Editor' yields a tuple of an @widget@ and a @Tidings inner@ which can be integrated in a threepenny app. -- newtype Editor outer widget inner = Editor { create :: Behavior outer -> UI (GenericWidget widget inner) } -- | Lift an HTML element into a vacuous editor. liftElement :: UI el -> Editor a el () liftElement el = Editor $ \_ -> GenericWidget (pure ()) <$> el bimapEditor :: (el -> el') -> (b -> b') -> Editor a el b -> Editor a el' b' bimapEditor g h = Editor . fmap (fmap (bimap g h)) . create dimapE :: (a' -> a) -> (b -> b') -> Editor a el b -> Editor a' el b' dimapE g h = unCoer . dimap (fmap g) h . coer where coer = Star . (Compose .) . create unCoer = Editor . fmap getCompose . runStar applyE :: (el1 -> el2 -> el) -> Editor in_ el1 (a -> b) -> Editor in_ el2 a -> Editor in_ el b applyE combineElements a b = Editor $ \s -> do a <- create a s b <- create b s return $ GenericWidget (widgetTidings a <*> widgetTidings b) (widgetControl a `combineElements` widgetControl b) instance Functor (Editor a el) where fmap = dimapE id instance Bifunctor (Editor a) where bimap = bimapEditor instance Biapplicative (Editor a) where bipure w o = Editor $ \_ -> return $ GenericWidget (pure o) w (<<*>>) = applyE ($) instance Monoid el => Applicative (Editor a el) where pure = bipure mempty (<*>) = applyE mappend -- | Applicative modifier for vertical composition of editor factories. -- This can be used in conjunction with ApplicativeDo as: -- -- > editorPerson = vertically $ do -- > firstName <- Vertically $ field "First:" firstName editor -- > lastName <- Vertically $ field "Last:" lastName editor -- > age <- Vertically $ field "Age:" age editor -- > return Person{..} -- -- DEPRECATED: Use the 'Vertical' layout builder instead pattern Vertically :: Editor a Layout b -> Editor a Vertical b pattern Vertically {vertically} <- (withLayout getVertical -> vertically) where Vertically a = withLayout Vertical a -- | Applicative modifier for horizontal composition of editor factories. -- This can be used in conjunction with ApplicativeDo as: -- -- > editorPerson = horizontally $ do -- > firstName <- Horizontally $ field "First:" firstName editor -- > lastName <- Horizontally $ field "Last:" lastName editor -- > age <- Horizontally $ field "Age:" age editor -- > return Person{..} -- -- DEPRECATED: Use the 'Horizontal' layout builder instead pattern Horizontally :: Editor a Layout b -> Editor a Horizontal b pattern Horizontally {horizontally} <- (withLayout getHorizontal -> horizontally) where Horizontally a = withLayout Horizontal a infixl 4 |*|, -*- infixl 5 |*, *|, -*, *- -- | Apply a layout builder. withLayout :: (layout -> layout') -> Editor a layout b -> Editor a layout' b withLayout f = bimap f id -- | Left-right editor composition (|*|) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a a |*| b = withLayout getHorizontal $ withLayout Horizontal a <*> withLayout Horizontal b -- | Left-right composition of an element with a editor (*|) :: UI Element -> Editor s Layout a -> Editor s Layout a e *| a = withLayout getHorizontal $ liftElement(return $ horizontal e) *> withLayout Horizontal a -- | Left-right composition of an element with a editor (|*) :: Editor s Layout a -> UI Element -> Editor s Layout a a |* e = withLayout getHorizontal $ withLayout Horizontal a <* liftElement(return $ horizontal e) -- | Left-right editor composition (-*-) :: Editor s Layout (b -> a) -> Editor s Layout b -> Editor s Layout a a -*- b = withLayout getVertical $ withLayout Vertical a <*> withLayout Vertical b -- | Left-right composition of an element with a editor (*-) :: UI Element -> Editor s Layout a -> Editor s Layout a e *- a = withLayout getVertical $ liftElement(return $ vertical e) *> withLayout Vertical a -- | Left-right composition of an element with a editor (-*) :: Editor s Layout a -> UI Element -> Editor s Layout a a -* e = withLayout getVertical $ withLayout Vertical a <* liftElement(return $ vertical e) -- | A helper that arranges a label and an editor horizontally, -- wrapped in the given monoidal layout builder. fieldLayout :: (Renderable m, Renderable m') => (Layout -> m') -> String -> (out -> inn) -> Editor inn m a -> Editor out m' a fieldLayout l name f e = withLayout l (string name *| first getLayout (dimapE f id e)) -- | A helper that arranges a label -- and an editor horizontally. field :: Renderable m => String -> (out -> inn) -> Editor inn m a -> Editor out Layout a field name f e = string name *| first getLayout (dimapE f id e) editorUnit :: Editor b Element b editorUnit = Editor $ \b -> do t <- new return $ GenericWidget (tidings b never) t editorCheckBox :: Editor Bool Element Bool editorCheckBox = Editor $ \b -> do t <- sink checked b $ input # set type_ "checkbox" return $ GenericWidget (tidings b $ checkedChange t) t editorString :: Editor String TextEntry String editorString = Editor $ \b -> do w <- askWindow t <- entry b liftIOLater $ do initialValue <- currentValue b _ <- runUI w $ set value initialValue (element t) return () return $ GenericWidget (userText t) t editorText :: Editor Text TextEntry Text editorText = dimapE Text.unpack Text.pack editorString editorReadShow :: (Read a, Show a) => Editor (Maybe a) TextEntry (Maybe a) editorReadShow = Editor $ \b -> do e <- create editorString (maybe "" show <$> b) let readIt "" = Nothing readIt x = readMaybe x let t = tidings b (readIt <$> edited e) return $ GenericWidget t (widgetControl e) -- An editor that presents a choice of values. editorEnumBounded :: (Bounded a, Enum a, Ord a, Show a) => Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) editorEnumBounded = editorSelection (pure $ enumFrom minBound) -- | An editor that presents a dynamic choice of values. editorSelection :: Ord a => Behavior [a] -> Behavior(a -> UI Element) -> Editor (Maybe a) (ListBox a) (Maybe a) editorSelection options display = Editor $ \b -> do l <- listBox options b display return $ GenericWidget (tidings b (rumors $ userSelection l)) l -- | Ignores 'Nothing' values and only updates for 'Just' values editorJust :: Editor (Maybe b) el (Maybe b) -> Editor b el b editorJust (Editor editor) = Editor $ \b -> do e <- editor (Just <$> b) let ev = filterJust (edited e) return $ GenericWidget (tidings b ev) (widgetControl e) -- | An editor for union types, built from editors for its constructors. editorSum :: (Ord tag, Show tag, Renderable el) => (Layout -> Layout -> Layout) -> [(tag, Editor a el a)] -> (a -> tag) -> Editor a Layout a editorSum combineLayout options selector = Editor $ \ba -> do options <- mapM (\(tag, Editor mk) -> (tag,) <$> (mk ba >>= renderEditor)) options let tag = selector <$> ba tag' <- calmB tag let build a = lookup a options -- build a tag selector following the current tag l <- listBox (pure $ fmap fst options) (Just <$> tag) (pure (string . show)) -- a placeholder for the constructor editor nestedEditor <- new # sink children ((\x -> [maybe (error "editorSum") widgetControl (build x)]) <$> tag') -- let composed = combineLayout (Single (return $ getElement l)) (Single $ return nestedEditor) -- the result event fires when any of the nested editors or the tag selector fire. let editedEvents = fmap (edited . snd) options eTag = filterJust $ rumors (userSelection l) taggedOptions = sequenceA [(tag, ) <$> contents e | (tag, e) <- options] editedTag = filterJust $ flip lookup <$> taggedOptions <@> eTag editedE = head <$> unions (editedTag : editedEvents) return $ GenericWidget (tidings ba editedE) composed editorIdentity :: Editor a el a -> Editor (Identity a) el (Identity a) editorIdentity = dimapE runIdentity Identity -------------------------- -- EditorCollection data EditorCollection k w = EditorCollection { selector :: ListBox k , add, remove :: Element , selected :: w } instance Renderable w => Renderable (EditorCollection k w) where render EditorCollection{..} = column [row [ element selector, element add, element remove] ,render selected] data EditorCollectionConfig k v = EditorCollectionConfig { eccNewKey :: Behavior k -- ^ Current value to use for creating a new key , eccAfterDelKey :: Behavior (Maybe k) -- ^ Current value to use if the selected key is deleted , eccTemplate :: v -- ^ Value to use for creating new items , eccOptions :: Behavior (Set k) -- ^ Currently user select able keys , eccDisplay :: Behavior (k -> UI Element) -- ^ How to render a key } defaultEditorCollectionConfig :: (Enum k, Ord k, Show k, HasEmpty v) => Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v defaultEditorCollectionConfig db = EditorCollectionConfig { eccTemplate = emptyValue , eccOptions = options , eccDisplay = pure (UI.string . show) , eccNewKey = maybe (toEnum 0) succ . Set.lookupMax <$> options , eccAfterDelKey = deletedKey <$> (fst <$> db) <*> options } where options = Map.keysSet . snd <$> db deletedKey Nothing _ = Nothing deletedKey (Just k) kk = Set.lookupLT k kk `mplus` Set.lookupGT k kk -- | A barebones editor for collections of editable items. -- Displays an index selector, add and delete buttons, and an editor for the selected item. -- Limitations: -- - Won't work with recursive data structures, due to the lack of FRP switch. editorCollection :: forall k v w. (Ord k, Renderable w) => (Behavior (Maybe k, Map k v) -> EditorCollectionConfig k v) -> Editor v w v -> Editor (Maybe k, Map k v) (EditorCollection k w) (Maybe k, Map k v) editorCollection mkConfig editorOne = Editor $ \(ba :: Behavior (Maybe k, Map k v)) -> mdo let EditorCollectionConfig{..} = mkConfig ba (selectedKey, db) = (fst <$> ba, snd <$> ba) sel <- create (editorSelection (Set.toList <$> eccOptions) eccDisplay) (fst <$> ba) one <- create editorOne $ (\(k, db) -> fromMaybe eccTemplate (k >>= (`Map.lookup` db))) <$> ba addB <- button #+ [string "+"] remB <- button #+ [string "-"] let insert i = Map.insert i eccTemplate editsDb = head <$> unions [ replace <$> ba <@> edited one , insert <$> eccNewKey <*> db <@ click addB , delete <$> ba <@ click remB ] editsKey = head <$> unions [ edited sel , Just <$> eccNewKey <@ click addB , eccAfterDelKey <@ click remB ] tids = (,) <$> tidings selectedKey editsKey <*> tidings db editsDb return $ GenericWidget tids (EditorCollection (widgetControl sel) addB remB (widgetControl one)) where replace (Just i,xx) x = Map.alter (const $ Just x) i xx replace (Nothing,x) _ = x delete (Just i,xx) = Map.delete i xx delete (_,xx) = xx -- | A barebones editor for collections of editable items. -- Displays an index selector, add and delete buttons, and an editor for the selected item. -- Limitations: -- - Won't work with recursive data structures, due to the lack of FRP switch. editorList :: (HasEmpty a, Renderable w) => Editor a w a -> Editor (Maybe Int, [a]) (EditorCollection Int w) (Maybe Int, [a]) editorList e = dimapE (second (Map.fromAscList . zip [0 ..])) (second F.toList) $ editorCollection config e where (<&>) = flip (<$>) infixl 1 <&> config ba = (defaultEditorCollectionConfig ba) { eccAfterDelKey = ba <&> (\(i,m) -> i >>= (\i -> if Map.member (i + 1) m then return i else let i' = max 0 (i - 1) in guard(i'>=0) >> return i')) } ghc-exactprint-0.6.2/tests/examples/ghc84/arrowfail003.hs0000755000000000000000000000024307346545000021274 0ustar0000000000000000{-# LANGUAGE Arrows #-} -- Arrow commands where an expression is expected module ShouldFail where import Control.Arrow foo = returnA -< [] bar = (|zeroArrow|) ghc-exactprint-0.6.2/tests/examples/ghc86/0000755000000000000000000000000007346545000016527 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc86/Arith.hs0000755000000000000000000001065107346545000020140 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} module Arith where data E a b = E (a -> b) (b -> a) eqRefl :: E a a eqRefl = E id id -- just to construct unique strings data W data M a -- terms data Var a where VarW :: Var W VarM :: Var (M a) -- expose s in the type level making sure it is a string data Abs s e1 where Abs :: (Var s) -> e1 -> Abs (Var s) e1 data App e1 e2 = App e1 e2 data Lit = Lit data TyBase = TyBase data TyArr t1 t2 = TyArr t1 t2 -- (x:ty) in G data IN g p where INOne :: IN (g,(x,ty)) (x,ty) INShift :: IN g0 (x,ty) -> IN (g0,a) (x,ty) data INEX g x where INEX :: IN g (x,v) -> INEX g x -- G1 subseteq G2 type SUP g1 g2 = forall a. IN g1 a -> IN g2 a -- typing derivations data DER g a ty where DVar :: IN (g,g0) ((Var a),ty) -> DER (g,g0) (Var a) ty -- the g,g0 makes sure that env is non-empty DApp :: DER g a1 (TyArr ty1 ty2) -> DER g a2 ty1 -> DER g (App a1 a2) ty2 DAbs :: DER (g,(Var a,ty1)) e ty2 -> DER g (Abs (Var a) e) (TyArr ty1 ty2) DLit :: DER g Lit TyBase -- G |- \x.x : a -> a test1 :: DER g (Abs (Var W) (Var W)) (TyArr ty ty) test1 = DAbs (DVar INOne) -- G |- (\x.x) Lit : Lit test2 :: DER g (App (Abs (Var W) (Var W)) Lit) TyBase test2 = DApp (DAbs (DVar INOne)) DLit -- G |- \x.\y. x y : (C -> C) -> C -> C test3 :: DER g (Abs (Var W) (Abs (Var (M W)) (App (Var W) (Var (M W))))) (TyArr (TyArr ty ty) (TyArr ty ty)) test3 = DAbs (DAbs (DApp (DVar (INShift INOne)) (DVar INOne))) data ISVAL e where ISVALAbs :: ISVAL (Abs (Var v) e) ISVALLit :: ISVAL Lit data React e1 e2 where SUBSTReact :: React (Abs (Var y) e) v -- evaluation data EDER e1 e2 where -- EVar :: IN (a,val) -> ISVAL val -> EDER c a val EApp1 :: EDER e1 e1' -> EDER (App e1 e2) (App e1' e2) EApp2 :: ISVAL v1 -> EDER e2 e2' -> EDER (App v1 e2) (App v1 e2') EAppAbs :: ISVAL v2 -> React (Abs (Var v) e) v2 -> EDER (App (Abs (Var v) e) v2) e1 -- (\x.x) 3 -> 3 -- test4 :: EDER (App (Abs (Var W) (Var W)) Lit) Lit -- test4 = EAppAbs ISVALLit SUBSTEqVar -- existential data REDUCES e1 where REDUCES :: EDER e1 e2 -> REDUCES e1 -- data WFEnv x c g where -- WFOne :: ISVAL v -> DER g v ty -> WFEnv (Var x) (c,(Var x,v)) (g,(Var x,ty)) -- WFShift :: WFEnv v c0 g0 -> WFEnv v (c0,(y,y1)) (g0,(z,z1)) -- data WFENVWRAP c g where -- WFENVWRAP :: (forall v ty . IN g (v,ty) -> WFEnv v c g) -> WFENVWRAP c g -- data INEXVAL c x where -- INEXVAL :: IN c (x,v) -> ISVAL v -> INEXVAL c x -- -- the first cool theorem! -- fromTEnvToEnv :: IN g (x,ty) -> WFEnv x c g -> INEXVAL c x -- fromTEnvToEnv INOne (WFOne isv _) = INEXVAL INOne isv -- fromTEnvToEnv (INShift ind1) (WFShift ind2) = -- case (fromTEnvToEnv ind1 ind2) of -- INEXVAL i isv -> INEXVAL (INShift i) isv data ISLAMBDA v where ISLAMBDA :: ISLAMBDA (Abs (Var x) e) data ISLIT v where ISLIT :: ISLIT Lit data EXISTAbs where EXISTSAbs :: (Abs (Var x) e) -> EXISTAbs bot = bot canFormsLam :: ISVAL v -> DER g v (TyArr ty1 ty2) -> ISLAMBDA v canFormsLam ISVALAbs _ = ISLAMBDA -- canFormsLam ISVALLit _ = bot <== unfortunately I cannot catch this ... requires some exhaustiveness check :-( canFormsLit :: ISVAL v -> DER g v TyBase -> ISLIT v canFormsLit ISVALLit _ = ISLIT data NULL progress :: DER NULL e ty -> Either (ISVAL e) (REDUCES e) progress (DAbs prem) = Left ISVALAbs progress (DLit) = Left ISVALLit -- progress (DVar iw) = bot <== here is the cool trick! I cannot even wite this down! progress (DApp e1 e2) = case (progress e1) of Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) Left isv1 -> case (progress e2) of Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) Left isv2 -> case (canFormsLam isv1 e1) of ISLAMBDA -> Right (REDUCES (EAppAbs isv2 SUBSTReact)) -- case fromTEnvToEnv iw (f iw) of -- INEXVAL i isv -> Right (REDUCES (EVar i isv)) -- progress (WFENVWRAP f) (DApp e1 e2) = -- case (progress (WFENVWRAP f) e1) of -- Right (REDUCES r1) -> Right (REDUCES (EApp1 r1)) -- Left isv1 -> case (progress (WFENVWRAP f) e2) of -- Right (REDUCES r2) -> Right (REDUCES (EApp2 isv1 r2)) -- Left isv2 -> case (canFormsLam isv1 e1) of -- ISLAMBDA -> EAppAbs isv2 e1 ghc-exactprint-0.6.2/tests/examples/ghc86/BadTelescope.hs0000755000000000000000000000022307346545000021415 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module BadTelescope where import Data.Kind data SameKind :: k -> k -> Type data X a k (b :: k) (c :: SameKind a b) ghc-exactprint-0.6.2/tests/examples/ghc86/BadTelescope2.hs0000755000000000000000000000043707346545000021506 0ustar0000000000000000{-# LANGUAGE TypeInType, ExplicitForAll #-} module BadTelescope2 where import Data.Kind import Data.Proxy data SameKind :: k -> k -> Type foo :: forall a k (b :: k). SameKind a b foo = undefined bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d bar = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/BadTelescope3.hs0000755000000000000000000000023707346545000021505 0ustar0000000000000000{-# LANGUAGE TypeInType, ExplicitForAll #-} module BadTelescope3 where import Data.Kind data SameKind :: k -> k -> Type type S a k (b :: k) = SameKind a b ghc-exactprint-0.6.2/tests/examples/ghc86/BadTelescope4.hs0000755000000000000000000000057607346545000021514 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, TypeInType #-} module BadTelescope4 where import Data.Proxy import Data.Kind data SameKind :: k -> k -> Type data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) data Borked a (b :: k) = forall (c :: k). B (Proxy c) -- this last one is OK. But there was a bug involving renaming -- that failed here, so the test case remains. ghc-exactprint-0.6.2/tests/examples/ghc86/Boot1.hs0000755000000000000000000000013707346545000020053 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Boot where import A data Data = forall n. Class n => D n ghc-exactprint-0.6.2/tests/examples/ghc86/Dep3.hs0000755000000000000000000000071107346545000017660 0ustar0000000000000000{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} module Dep3 where import Data.Kind import GHC.Exts ( Constraint ) type Star1 = Type data Id1 (a :: Star1) where Id1 :: a -> Id1 a data Id1' :: Star1 -> Type where Id1' :: a -> Id1' a type family Star2 x where Star2 x = Type data Id2a (a :: Star2 Constraint) = Id2a a data Id2 (a :: Star2 Constraint) where Id2 :: a -> Id2 a data Id2' :: Star2 Constraint -> Type where Id2' :: a -> Id2' a ghc-exactprint-0.6.2/tests/examples/ghc86/GADT.hs0000755000000000000000000000074507346545000017613 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} data Empty data NonEmpty data SafeList x y where Nil :: SafeList x Empty Cons:: Eq x => x -> SafeList x y -> SafeList x NonEmpty One :: Eq x => x -> SafeList x Empty -> SafeList x NonEmpty safeHead :: SafeList x NonEmpty -> x safeHead (Cons x _) = x foo = Cons 3 (Cons 6 (Cons 9 Nil)) data Dict x where DictN :: Num x => x -> Dict x DictE :: Eq x => x -> Dict x data Exist where Exist :: forall a. a -> Exist ghc-exactprint-0.6.2/tests/examples/ghc86/HashTab.hs0000755000000000000000000002650107346545000020404 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.HashTable -- Copyright : (c) The University of Glasgow 2003 -- License : BSD-style (see the file libraries/base/LICENSE) -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- An implementation of extensible hash tables, as described in -- Per-Ake Larson, /Dynamic Hash Tables/, CACM 31(4), April 1988, -- pp. 446--457. The implementation is also derived from the one -- in GHC's runtime system (@ghc\/rts\/Hash.{c,h}@). -- ----------------------------------------------------------------------------- module Data.HashTab ( -- * Basic hash table operations HashTable, new, insert, delete, lookup, update, -- * Converting to and from lists fromList, toList, -- * Hash functions -- $hash_functions hashInt, hashString, prime, -- * Diagnostics longestChain ) where -- This module is imported by Data.Typeable, which is pretty low down in the -- module hierarchy, so don't import "high-level" modules -- Right now we import high-level modules with gay abandon. import Prelude hiding ( lookup ) import Data.Tuple ( fst ) import Data.Bits import Data.Maybe import Data.List ( maximumBy, partition, concat, foldl ) import Data.Int ( Int32 ) import Data.Array.Base import Data.Array hiding (bounds) import Data.Array.IO import Data.Char ( ord ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Control.Monad ( mapM, sequence_ ) ----------------------------------------------------------------------- readHTArray :: HTArray a -> Int32 -> IO a readMutArray :: MutArray a -> Int32 -> IO a writeMutArray :: MutArray a -> Int32 -> a -> IO () freezeArray :: MutArray a -> IO (HTArray a) thawArray :: HTArray a -> IO (MutArray a) newMutArray :: (Int32, Int32) -> a -> IO (MutArray a) #if defined(DEBUG) || defined(__NHC__) type MutArray a = IOArray Int32 a type HTArray a = MutArray a newMutArray = newArray readHTArray = readArray readMutArray = readArray writeMutArray = writeArray freezeArray = return thawArray = return #else type MutArray a = IOArray Int32 a type HTArray a = Array Int32 a newMutArray = newArray readHTArray arr i = return $! (unsafeAt arr (fromIntegral i)) readMutArray arr i = unsafeRead arr (fromIntegral i) writeMutArray arr i x = unsafeWrite arr (fromIntegral i) x freezeArray = unsafeFreeze thawArray = unsafeThaw #endif newtype HashTable key val = HashTable (IORef (HT key val)) -- TODO: the IORef should really be an MVar. data HT key val = HT { kcount :: !Int32, -- Total number of keys. buckets :: !(HTArray [(key,val)]), bmask :: !Int32, hash_fn :: key -> Int32, cmp :: key -> key -> Bool } -- ----------------------------------------------------------------------------- -- Sample hash functions -- $hash_functions -- -- This implementation of hash tables uses the low-order /n/ bits of the hash -- value for a key, where /n/ varies as the hash table grows. A good hash -- function therefore will give an even distribution regardless of /n/. -- -- If your keyspace is integrals such that the low-order bits between -- keys are highly variable, then you could get away with using 'id' -- as the hash function. -- -- We provide some sample hash functions for 'Int' and 'String' below. -- | A sample hash function for 'Int', implemented as simply @(x `mod` P)@ -- where P is a suitable prime (currently 1500007). Should give -- reasonable results for most distributions of 'Int' values, except -- when the keys are all multiples of the prime! -- hashInt :: Int -> Int32 hashInt = (`rem` prime) . fromIntegral -- | A sample hash function for 'String's. The implementation is: -- -- > hashString = fromIntegral . foldr f 0 -- > where f c m = ord c + (m * 128) `rem` 1500007 -- -- which seems to give reasonable results. -- hashString :: String -> Int32 hashString = fromIntegral . foldl f 0 where f m c = ord c + (m * 128) `rem` fromIntegral prime -- | A prime larger than the maximum hash table size prime :: Int32 prime = 1500007 -- ----------------------------------------------------------------------------- -- Parameters tABLE_MAX = 1024 * 1024 :: Int32 -- Maximum size of hash table #if tABLE_MIN #else tABLE_MIN = 16 :: Int32 hLOAD = 4 :: Int32 -- Maximum average load of a single hash bucket hYSTERESIS = 0 :: Int32 -- entries to ignore in load computation #endif {- Hysteresis favors long association-list-like behavior for small tables. -} -- ----------------------------------------------------------------------------- -- Creating a new hash table -- | Creates a new hash table. The following property should hold for the @eq@ -- and @hash@ functions passed to 'new': -- -- > eq A B => hash A == hash B -- new :: (key -> key -> Bool) -- ^ @eq@: An equality comparison on keys -> (key -> Int32) -- ^ @hash@: A hash function on keys -> IO (HashTable key val) -- ^ Returns: an empty hash table new cmpr hash = do -- make a new hash table with a single, empty, segment let mask = tABLE_MIN-1 bkts' <- newMutArray (0,mask) [] bkts <- freezeArray bkts' let kcnt = 0 ht = HT { buckets=bkts, kcount=kcnt, bmask=mask, hash_fn=hash, cmp=cmpr } table <- newIORef ht return (HashTable table) -- ----------------------------------------------------------------------------- -- Inserting a key\/value pair into the hash table -- | Inserts a key\/value mapping into the hash table. -- -- Note that 'insert' doesn't remove the old entry from the table - -- the behaviour is like an association list, where 'lookup' returns -- the most-recently-inserted mapping for a key in the table. The -- reason for this is to keep 'insert' as efficient as possible. If -- you need to update a mapping, then we provide 'update'. -- insert :: HashTable key val -> key -> val -> IO () insert (HashTable ref) key val = do table@HT{ kcount=k, buckets=bkts, bmask=b } <- readIORef ref let table1 = table{ kcount = k+1 } indx = bucketIndex table key bucket <- readHTArray bkts indx bkts' <- thawArray bkts writeMutArray bkts' indx ((key,val):bucket) freezeArray bkts' table2 <- if tooBig k b then expandHashTable table1 else return table1 writeIORef ref table2 tooBig :: Int32 -> Int32 -> Bool tooBig k b = k-hYSTERESIS > hLOAD * b bucketIndex :: HT key val -> key -> Int32 bucketIndex HT{ hash_fn=hash, bmask=mask } key = let h = hash key in (h .&. mask) expandHashTable :: HT key val -> IO (HT key val) expandHashTable table@HT{ buckets=bkts, bmask=mask } = do let oldsize = mask + 1 newmask = mask + mask + 1 newsize = newmask + 1 -- if newsize > tABLE_MAX then return table else do -- newbkts' <- newMutArray (0,newmask) [] let table'=table{ bmask=newmask } splitBucket oldindex = do bucket <- readHTArray bkts oldindex let (oldb,newb) = partition ((oldindex==).bucketIndex table' . fst) bucket writeMutArray newbkts' oldindex oldb writeMutArray newbkts' (oldindex + oldsize) newb mapM_ splitBucket [0..mask] newbkts <- freezeArray newbkts' return ( table'{ buckets=newbkts } ) -- ----------------------------------------------------------------------------- -- Deleting a mapping from the hash table -- Remove a key from a bucket deleteBucket :: (key -> Bool) -> [(key,val)] -> (Int32, [(key, val)]) deleteBucket _ [] = (0,[]) deleteBucket del (pair@(k,_):bucket) = case deleteBucket del bucket of (dels, bucket') | del k -> dels' `seq` (dels', bucket') | otherwise -> (dels, pair:bucket') where dels' = dels + 1 -- | Remove an entry from the hash table. delete :: HashTable key val -> key -> IO () delete (HashTable ref) key = do table@HT{ buckets=bkts, kcount=kcnt, cmp=cmpr } <- readIORef ref let indx = bucketIndex table key bkts' <- thawArray bkts bucket <- readMutArray bkts' indx let (removed,bucket') = deleteBucket (cmpr key) bucket writeMutArray bkts' indx bucket' freezeArray bkts' writeIORef ref ( table{kcount = kcnt - removed} ) -- ----------------------------------------------------------------------------- -- Updating a mapping in the hash table -- | Updates an entry in the hash table, returning 'True' if there was -- already an entry for this key, or 'False' otherwise. After 'update' -- there will always be exactly one entry for the given key in the table. -- -- 'insert' is more efficient than 'update' if you don't care about -- multiple entries, or you know for sure that multiple entries can't -- occur. However, 'update' is more efficient than 'delete' followed -- by 'insert'. update :: HashTable key val -> key -> val -> IO Bool update (HashTable ref) key val = do table@HT{ kcount=k, buckets=bkts, cmp=cmpr, bmask=b } <- readIORef ref let indx = bucketIndex table key bkts' <- thawArray bkts bucket <- readMutArray bkts' indx let (deleted,bucket') = deleteBucket (cmpr key) bucket k' = k + 1 - deleted table1 = table{ kcount=k' } writeMutArray bkts' indx ((key,val):bucket') freezeArray bkts' table2 <- if tooBig k' b -- off by one from insert's resize heuristic. then expandHashTable table1 else return table1 writeIORef ref table2 return (deleted>0) -- ----------------------------------------------------------------------------- -- Looking up an entry in the hash table -- | Looks up the value of a key in the hash table. lookup :: HashTable key val -> key -> IO (Maybe val) lookup (HashTable ref) key = do table@HT{ buckets=bkts, cmp=cmpr } <- readIORef ref let indx = bucketIndex table key bucket <- readHTArray bkts indx case [ val | (key',val) <- bucket, cmpr key key' ] of [] -> return Nothing (v:_) -> return (Just v) -- ----------------------------------------------------------------------------- -- Converting to/from lists -- | Convert a list of key\/value pairs into a hash table. Equality on keys -- is taken from the Eq instance for the key type. -- fromList :: (Eq key) => (key -> Int32) -> [(key,val)] -> IO (HashTable key val) fromList hash list = do table <- new (==) hash sequence_ [ insert table k v | (k,v) <- list ] return table -- | Converts a hash table to a list of key\/value pairs. -- toList :: (Ord key, Ord val) => HashTable key val -> IO [(key,val)] toList (HashTable ref) = do HT{ buckets=bkts, bmask=b } <- readIORef ref fmap concat (mapM (readHTArray bkts) [0..b]) -- ----------------------------------------------------------------------------- -- Diagnostics -- | This function is useful for determining whether your hash function -- is working well for your data set. It returns the longest chain -- of key\/value pairs in the hash table for which all the keys hash to -- the same bucket. If this chain is particularly long (say, longer -- than 10 elements), then it might be a good idea to try a different -- hash function. -- longestChain :: HashTable key val -> IO [(key,val)] longestChain (HashTable ref) = do HT{ buckets=bkts, bmask=b } <- readIORef ref let lengthCmp (_:x)(_:y) = lengthCmp x y lengthCmp [] [] = EQ lengthCmp [] _ = LT lengthCmp _ [] = GT fmap (maximumBy lengthCmp) (mapM (readHTArray bkts) [0..b]) ghc-exactprint-0.6.2/tests/examples/ghc86/KindEqualities2.hs0000755000000000000000000000222207346545000022061 0ustar0000000000000000{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, TemplateHaskell, UndecidableInstances, ScopedTypeVariables, TypeInType #-} module KindEqualities2 where import Data.Kind import GHC.Exts ( Any ) data Kind = Star | Arr Kind Kind data Ty :: Kind -> Type where TInt :: Ty Star TBool :: Ty Star TMaybe :: Ty (Arr Star Star) TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 data TyRep (k :: Kind) (t :: Ty k) where TyInt :: TyRep Star TInt TyBool :: TyRep Star TBool TyMaybe :: TyRep (Arr Star Star) TMaybe TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) type family IK (k :: Kind) type instance IK Star = Type type instance IK (Arr k1 k2) = IK k1 -> IK k2 $(return []) -- necessary because the following instances depend on the -- previous ones. type family I (t :: Ty k) :: IK k type instance I TInt = Int type instance I TBool = Bool type instance I TMaybe = Maybe type instance I (TApp a b) = (I a) (I b) zero :: forall (a :: Ty 'Star). TyRep Star a -> I a zero TyInt = 0 zero TyBool = False zero (TyApp TyMaybe TyInt) = Nothing main = print $ zero (TyApp TyMaybe TyInt) ghc-exactprint-0.6.2/tests/examples/ghc86/LiftedConstructors.hs0000755000000000000000000000136407346545000022732 0ustar0000000000000000{-# 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 :: [Type] -> Type 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 ghc-exactprint-0.6.2/tests/examples/ghc86/Parser.hs0000755000000000000000000001221607346545000020324 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Weverything -fno-warn-unsafe -fno-warn-implicit-prelude -fno-warn-missing-import-lists -fno-warn-noncanonical-monoid-instances -O2 #-} module Packed.Bytes.Parser ( Parser(..) , Result(..) , Leftovers(..) , parseStreamST , any , failure ) where import Control.Applicative import Data.Primitive (ByteArray(..)) import GHC.Int (Int(I#)) import GHC.ST (ST(..),runST) import GHC.Types (TYPE) import GHC.Word (Word8(W8#)) import Packed.Bytes (Bytes(..)) import Packed.Bytes.Stream.ST (ByteStream(..)) import Prelude hiding (any,replicate) import qualified Data.Primitive as PM import qualified Control.Monad import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#) type Bytes# = (# ByteArray#, Int#, Int# #) type Maybe# (a :: TYPE r) = (# (# #) | a #) type Leftovers# s = (# Bytes# , ByteStream s #) type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #) data Result s a = Result { resultLeftovers :: !(Maybe (Leftovers s)) , resultValue :: !(Maybe a) } data Leftovers s = Leftovers { leftoversChunk :: {-# UNPACK #-} !Bytes -- ^ The last chunk pulled from the stream , leftoversStream :: ByteStream s -- ^ The remaining stream } data PureResult a = PureResult { pureResultLeftovers :: {-# UNPACK #-} !Bytes , pureResultValue :: !(Maybe a) } deriving (Show) emptyByteArray :: ByteArray emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray) parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a) parseStreamST stream (Parser f) = ST $ \s0 -> case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of (# s1, r #) -> (# s1, boxResult r #) boxResult :: Result# s a -> Result s a boxResult (# leftovers, val #) = case val of (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing (# | a #) -> Result (boxLeftovers leftovers) (Just a) boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s) boxLeftovers (# (# #) | #) = Nothing boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream) instance Functor Parser where fmap = mapParser -- Remember to write liftA2 by hand at some point. instance Applicative Parser where pure = pureParser (<*>) = Control.Monad.ap instance Monad Parser where return = pure (>>=) = bindLifted newtype Parser a = Parser { getParser :: forall s. Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s a #) } nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #) nextNonEmpty (ByteStream f) s0 = case f s0 of (# s1, r #) -> case r of (# (# #) | #) -> (# s1, (# (# #) | #) #) (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of 0# -> nextNonEmpty stream s1 _ -> (# s1, (# | (# theBytes, stream #) #) #) withNonEmpty :: forall s b. Maybe# (Leftovers# s) -> State# s -> (State# s -> (# State# s, Result# s b #)) -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #)) -- The first argument is a Word8, not a full machine word. -- The second argument is the complete,non-empty chunk -- with the head byte still intact. -> (# State# s, Result# s b #) withNonEmpty (# (# #) | #) s0 g _ = g s0 withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of 1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0 _ -> case nextNonEmpty stream0 s0 of (# s1, r #) -> case r of (# (# #) | #) -> g s1 (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) -> f (indexWord8Array# arr1 off1) bytes1 stream1 s1 -- | Consume the next byte from the input. any :: Parser Word8 any = Parser go where go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #) go m s0 = withNonEmpty m s0 (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #)) (\theByte theBytes stream s -> (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #) ) -- TODO: improve this mapParser :: (a -> b) -> Parser a -> Parser b mapParser f p = bindLifted p (pureParser . f) pureParser :: a -> Parser a pureParser a = Parser $ \leftovers0 s0 -> (# s0, (# leftovers0, (# | a #) #) #) bindLifted :: Parser a -> (a -> Parser b) -> Parser b bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of (# s1, (# leftovers1, val #) #) -> case val of (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #) (# | x #) -> case g x of Parser k -> k leftovers1 s1 -- This assumes that the Bytes is longer than the index. It also does -- not eliminate zero-length references to byte arrays. unsafeDrop# :: Int# -> Bytes# -> Bytes# unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #) unboxByteArray :: ByteArray -> ByteArray# unboxByteArray (ByteArray arr) = arr boxBytes :: Bytes# -> Bytes boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) failure :: Parser a failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #)) ghc-exactprint-0.6.2/tests/examples/ghc86/RAE_T32a.hs0000755000000000000000000000234407346545000020271 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, PolyKinds, TypeFamilies, GADTs, TypeInType #-} module RAE_T32a where import Data.Kind data family Sing (k :: Type) :: k -> Type data TyArr' (a :: Type) (b :: Type) :: Type type TyArr (a :: Type) (b :: Type) = TyArr' a b -> Type type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 data TyPi' (a :: Type) (b :: TyArr a Type) :: Type type TyPi (a :: Type) (b :: TyArr a Type) = TyPi' a b -> Type type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b $(return []) data MkStar (p :: Type) (x :: TyArr' p Type) type instance MkStar p @@ x = Type $(return []) data Sigma (p :: Type) (r :: TyPi p (MkStar p)) :: Type where Sigma :: forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). Sing Type p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r $(return []) data instance Sing Sigma (Sigma p r) x where SSigma :: forall (p :: Type) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) (sp :: Sing Type p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). Sing (Sing (r @@@ a) b) sb -> Sing (Sigma p r) ('Sigma sp sr sa sb) -- I (RAE) believe this last definition is ill-typed. ghc-exactprint-0.6.2/tests/examples/ghc86/RAE_T32b.hs0000755000000000000000000000165007346545000020271 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, RankNTypes, TypeOperators, TypeInType #-} module RAE_T32b where import Data.Kind data family Sing (k :: Type) :: k -> Type data TyArr (a :: Type) (b :: Type) :: Type type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2 $(return []) data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a). Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r $(return []) data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type) (a :: p) (b :: r @@ a) (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). Sing (Sing (r @@ a) b) sb -> Sing (Sigma p r) ('Sigma sp sr sa sb) ghc-exactprint-0.6.2/tests/examples/ghc86/Rae31.hs0000755000000000000000000000160507346545000017743 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, TypeFamilies, TypeInType #-} module A where import Data.Kind data family Sing (k :: Type) :: k -> Type type Sing' (x :: k) = Sing k x data TyFun' (a :: Type) (b :: Type) :: Type type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 data TyPi' (a :: Type) (b :: TyFun a Type) :: Type type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b $(return []) data A (a :: Type) (b :: a) (c :: TyFun' a Type) -- A :: forall a -> a -> a ~> Type type instance (@@) (A a b) c = Type $(return []) data B (a :: Type) (b :: TyFun' a Type) -- B :: forall a -> a ~> Type type instance (@@) (B a) b = TyPi a (A a b) $(return []) data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) Type) ghc-exactprint-0.6.2/tests/examples/ghc86/RaeBlogPost.hs0000755000000000000000000000300607346545000021246 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, TypeInType #-} {-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} module RaeBlogPost where import Data.Kind -- a Proxy type with an explicit kind data Proxy k (a :: k) = P prox :: Proxy * Bool prox = P prox2 :: Proxy Bool 'True prox2 = P -- implicit kinds still work data A data B :: A -> Type data C :: B a -> Type data D :: C b -> Type data E :: D c -> Type -- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type -- a kind-indexed GADT data TypeRep (a :: k) where TInt :: TypeRep Int TMaybe :: TypeRep Maybe TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) zero :: TypeRep a -> a zero TInt = 0 zero (TApp TMaybe _) = Nothing data Nat = Zero | Succ Nat type family a + b where 'Zero + b = b ('Succ a) + b = 'Succ (a + b) data Vec :: Type -> Nat -> Type where Nil :: Vec a 'Zero (:>) :: a -> Vec a n -> Vec a ('Succ n) infixr 5 :> -- promoted GADT, and using + as a "kind family": type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where 'Nil ++ y = y (h ':> t) ++ y = h ':> (t ++ y) -- datatype that mentions Type data U = Star (Type) | Bool Bool -- kind synonym type Monadish = Type -> Type class MonadTrans (t :: Monadish -> Monadish) where lift :: Monad m => m a -> t m a data Free :: Monadish where Return :: a -> Free a Bind :: Free a -> (a -> Free b) -> Free b -- yes, Type really does have type Type. type Star = (Type :: (Type :: (Type :: Type))) ghc-exactprint-0.6.2/tests/examples/ghc86/RenamingStar.hs0000755000000000000000000000011107346545000021451 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module RenamingStar where data Foo :: Type ghc-exactprint-0.6.2/tests/examples/ghc86/ST.hs0000755000000000000000000000347607346545000017426 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnboxedSums #-} {-# OPTIONS_GHC -O2 #-} module Packed.Bytes.Stream.ST ( ByteStream(..) , empty , unpack , fromBytes ) where import Data.Primitive (Array,ByteArray(..)) import Data.Semigroup (Semigroup) import Data.Word (Word8) import GHC.Exts (RealWorld,State#,Int#,ByteArray#) import GHC.Int (Int(I#)) import GHC.ST (ST(..)) import Packed.Bytes (Bytes(..)) import System.IO (Handle) import qualified Data.Primitive as PM import qualified Data.Semigroup as SG import qualified Packed.Bytes as B type Bytes# = (# ByteArray#, Int#, Int# #) newtype ByteStream s = ByteStream (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) ) fromBytes :: Bytes -> ByteStream s fromBytes b = ByteStream (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #)) nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s)) nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of (# s1, r #) -> case r of (# (# #) | #) -> (# s1, Nothing #) (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #) empty :: ByteStream s empty = ByteStream (\s -> (# s, (# (# #) | #) #) ) boxBytes :: Bytes# -> Bytes boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c) unboxBytes :: Bytes -> Bytes# unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #) unpack :: ByteStream s -> ST s [Word8] unpack stream = ST (unpackInternal stream) unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #) unpackInternal (ByteStream f) s0 = case f s0 of (# s1, r #) -> case r of (# (# #) | #) -> (# s1, [] #) (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #) ghc-exactprint-0.6.2/tests/examples/ghc86/SlidingTypeSyn.hs0000755000000000000000000000063107346545000022013 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LiberalTypeSynonyms #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} type ( f :-> g) (r :: Type -> Type) 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 ghc-exactprint-0.6.2/tests/examples/ghc86/T10134a.hs0000755000000000000000000000037407346545000020027 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module T10134a where import GHC.TypeLits data Vec :: Nat -> Type -> Type where Nil :: Vec 0 a (:>) :: a -> Vec n a -> Vec (n + 1) a ghc-exactprint-0.6.2/tests/examples/ghc86/T10279.hs0000755000000000000000000000077307346545000017703 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T10279 where import Language.Haskell.TH import Language.Haskell.TH.Syntax -- NB: rts-1.0 is used here because it doesn't change. -- You do need to pick the right version number, otherwise the -- error message doesn't recognize it as a source package ID, -- (This is OK, since it will look obviously wrong when they -- try to find the package in their package database.) blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A")))) ghc-exactprint-0.6.2/tests/examples/ghc86/T10321.hs0000755000000000000000000000043007346545000017655 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} module T10321 where import GHC.TypeLits data Vec :: Nat -> Type -> Type where Nil :: Vec 0 a (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5 :> ghc-exactprint-0.6.2/tests/examples/ghc86/T10638.hs0000755000000000000000000000202707346545000017674 0ustar0000000000000000{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-} {-# LANGUAGE TemplateHaskell #-} import Language.Haskell.TH import Language.Haskell.TH.Syntax import GHC.Exts {- the prim and javascript calling conventions do not support headers and the static keyword. -} -- check that quasiquoting roundtrips successfully and that the declaration -- does not include the static keyword test1 :: String test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <- [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |] addTopDecls ds case p of "test1" -> return (LitE . stringL $ p) _ -> error $ "unexpected value: " ++ show p ) -- check that constructed prim imports with the static keyword are rejected test2 :: String test2 = $(do t <- [t| Int# -> Int# |] cmm_test2 <- newName "cmm_test2" addTopDecls [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)] [| test1 |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/T10689a.hs0000755000000000000000000001010707346545000020041 0ustar0000000000000000{-# LANGUAGE TypeOperators , DataKinds , PolyKinds , TypeFamilies , GADTs , UndecidableInstances , RankNTypes , ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Werror #-} {-# OPTIONS_GHC -O1 -fspec-constr #-} {- ghc-stage2: panic! (the 'impossible' happened) (GHC version 7.11.20150723 for x86_64-unknown-linux): Template variable unbound in rewrite rule -} module List (sFoldr1) where data Proxy t data family Sing (a :: k) data TyFun (a :: Type) (b :: Type) type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 data instance Sing (f :: TyFun k1 k2 -> Type) = SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) singFun2 :: Proxy f -> SingFunction2 f -> Sing f singFun2 _ f = SLambda (\x -> SLambda (f x)) data (:$$) (j :: a) (i :: TyFun [a] [a]) type instance Apply ((:$$) j) i = (:) j i data (:$) (l :: TyFun a (TyFun [a] [a] -> Type)) type instance Apply (:$) l = (:$$) l data instance Sing (z :: [a]) = z ~ '[] => SNil | forall (m :: a) (n :: [a]). z ~ (:) m n => SCons (Sing m) (Sing n) data ErrorSym0 (t1 :: TyFun k1 k2) type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh type Let1627448493Xs f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec = Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (t_afdZ :: [a_afdP]) = Foldr1 t_afdY t_afdZ data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (l_afe2 :: TyFun [a_afdP] a_afdP) type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (TyFun [a_afdP] a_afdP -> Type)) type instance Apply Foldr1Sym0 l = Foldr1Sym1 l type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (a_afe6 :: [a_afdP]) :: a_afdP where Foldr1 z_afe7 '[x_afe8] = x_afe8 Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" sFoldr1 :: forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (y :: [a_afdP]). Sing x -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) sFoldr1 _ (SCons _sX SNil) = undefined sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) = let lambda_afeC :: forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. Sing f_afe9 -> Sing x_afea -> Sing wild_1627448474_afeb -> Sing wild_1627448476_afec -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG = let sXs :: Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) sXs = applySing (applySing (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) wild_1627448476_afeG in applySing (applySing f_afeD x_afeE) (applySing (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) sXs) in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 sFoldr1 _ SNil = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/T10819.hs0000755000000000000000000000073707346545000017703 0ustar0000000000000000{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module T10819 where import T10819_Lib import Language.Haskell.TH.Syntax class C a b | b -> a where f :: b -> a data D = X instance C Int D where f X = 2 $(doSomeTH "N" (mkName "D") [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]]) thing :: N thing = N X thing1 :: Int thing1 = f thing ghc-exactprint-0.6.2/tests/examples/ghc86/T10891.hs0000755000000000000000000000116707346545000017701 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module T10891 where import Language.Haskell.TH import System.IO class C a where f :: a -> Int class C' a where type F a :: * type F a = a f' :: a -> Int class C'' a where data Fd a :: * instance C' Int where type F Int = Bool f' = id instance C'' Int where data Fd Int = B Bool | C Char $(return []) test :: () test = $(let display :: Name -> Q () display q = do i <- reify q runIO (hPutStrLn stderr (pprint i) >> hFlush stderr) in do display ''C display ''C' display ''C'' [| () |]) ghc-exactprint-0.6.2/tests/examples/ghc86/T10934.hs0000755000000000000000000000172107346545000017673 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables , DataKinds , GADTs , RankNTypes , TypeOperators , PolyKinds -- Comment out PolyKinds and the bug goes away. #-} {-# OPTIONS_GHC -O #-} -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it module KeyValue where data AccValidation err a = AccFailure err | AccSuccess a data KeyValueError = MissingValue type WithKeyValueError = AccValidation [KeyValueError] missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs missing = rpure missingField where missingField :: forall x. (WithKeyValueError :. f) x missingField = Compose $ AccFailure [MissingValue] data Rec :: (u -> Type) -> [u] -> Type where RNil :: Rec f '[] (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k) = Compose { getCompose :: f (g x) } type (:.) f g = Compose f g class RecApplicative rs where rpure :: (forall x. f x) -> Rec f rs ghc-exactprint-0.6.2/tests/examples/ghc86/T11142.hs0000755000000000000000000000027207346545000017663 0ustar0000000000000000{-# LANGUAGE TypeInType, RankNTypes #-} module T11142 where import Data.Kind data SameKind :: k -> k -> Type foo :: forall b. (forall k (a :: k). SameKind a b) -> () foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/T11484.hs0000755000000000000000000000026507346545000017676 0ustar0000000000000000{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} module T11484 where import Data.Kind type TySyn (k :: *) (a :: k) = () $([d| type TySyn2 (k :: *) (a :: k) = () |]) ghc-exactprint-0.6.2/tests/examples/ghc86/T12478_5.hs0000755000000000000000000000126607346545000020130 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UnboxedSums #-} module T12478_5 where import Language.Haskell.TH foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) foo $(conP (unboxedSumDataName 1 2) [conP '() []]) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) foo $(conP (unboxedSumDataName 2 2) [conP '() []]) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) foo2 :: (# () | () #) -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''()) foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '()) foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #) ghc-exactprint-0.6.2/tests/examples/ghc86/T14164.hs0000755000000000000000000000046007346545000017671 0ustar0000000000000000{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} module T14164 where data G (x :: a) = GNil | GCons (G x) type family F (xs :: [a]) (g :: G (z :: a)) = (res :: [a]) | res -> a where F (x:xs) GNil = x:xs F (x:xs) (GCons rest) = x:F xs rest ghc-exactprint-0.6.2/tests/examples/ghc86/T14650.hs0000755000000000000000000000503307346545000017672 0ustar0000000000000000module MergeSort ( msortBy ) where infixl 7 :% infixr 6 :& data LenList a = LL {-# UNPACK #-} !Int Bool [a] data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b data Stack a = End | {-# UNPACK #-} !(LenList a) :& (Stack a) msortBy :: (a -> a -> Ordering) -> [a] -> [a] msortBy cmp = mergeSplit End where splitAsc n _ _ _ | n `seq` False = undefined splitAsc n as _ [] = LL n True as :% [] splitAsc n as a bs@(b:bs') = case cmp a b of GT -> LL n False as :% bs _ -> splitAsc (n + 1) as b bs' splitDesc n _ _ _ | n `seq` False = undefined splitDesc n rs a [] = LL n True (a:rs) :% [] splitDesc n rs a bs@(b:bs') = case cmp a b of GT -> splitDesc (n + 1) (a:rs) b bs' _ -> LL n True (a:rs) :% bs mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where mergeLs nx _ ny _ | nx `seq` ny `seq` False = undefined mergeLs 0 _ ny ys = if fb then ys else take ny ys mergeLs _ [] ny ys = if fb then ys else take ny ys mergeLs nx xs 0 _ = if fa then xs else take nx xs mergeLs nx xs _ [] = if fa then xs else take nx xs mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of GT -> y:mergeLs nx xs (ny - 1) ys' _ -> x:mergeLs (nx - 1) xs' ny ys push ssx px@(LL nx _ _) = case ssx of End -> px :% ssx py@(LL ny _ _) :& ssy -> case ssy of End | nx >= ny -> mergeLL py px :% ssy pz@(LL nz _ _) :& ssz | nx >= ny || nx + ny >= nz -> case nx > nz of False -> push ssy $ mergeLL py px _ -> case push ssz $ mergeLL pz py of pz' :% ssz' -> push (pz' :& ssz') px _ -> px :% ssx mergeAll _ px | px `seq` False = undefined mergeAll ssx px@(LL nx _ xs) = case ssx of End -> xs py@(LL _ _ _) :& ssy -> case ssy of End -> case mergeLL py px of LL _ _ xys -> xys pz@(LL nz _ _) :& ssz -> case nx > nz of False -> mergeAll ssy $ mergeLL py px _ -> case push ssz $ mergeLL pz py of pz' :% ssz' -> mergeAll (pz' :& ssz') px mergeSplit ss _ | ss `seq` False = undefined mergeSplit ss [] = case ss of End -> [] px :& ss' -> mergeAll ss' px mergeSplit ss as@(a:as') = case as' of [] -> mergeAll ss $ LL 1 True as b:bs -> case cmp a b of GT -> case splitDesc 2 [a] b bs of px :% rs -> case push ss px of px' :% ss' -> mergeSplit (px' :& ss') rs _ -> case splitAsc 2 as b bs of px :% rs -> case push ss px of px' :% ss' -> mergeSplit (px' :& ss') rs {-# INLINABLE mergeSplit #-} ghc-exactprint-0.6.2/tests/examples/ghc86/T2632.hs0000755000000000000000000000034307346545000017606 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- Trac #2632 module MkData where import Language.Haskell.TH op :: Num v => v -> v -> v op a b = a + b decl1 = [d| func = 0 `op` 3 |] decl2 = [d| op x y = x func = 0 `op` 3 |] ghc-exactprint-0.6.2/tests/examples/ghc86/T3263-2.hs0000755000000000000000000000123007346545000017742 0ustar0000000000000000-- Trac #3263. New kind of warning on monadic bindings that discard a monadic result {-# LANGUAGE RankNTypes #-} module T3263 where import Control.Monad.Fix -- No warning t1 :: Monad m => m Int t1 = do return 10 -- No warning t2 :: Monad m => m (m Int) t2 = return (return 10) -- No warning t3 :: Monad m => m (m Int) t3 = do return 10 return (return 10) -- Warning t4 :: forall m. Monad m => m Int t4 = do return (return 10 :: m Int) return 10 -- No warning t5 :: forall m. Monad m => m Int t5 = do _ <- return (return 10 :: m Int) return 10 -- Warning t6 :: forall m. MonadFix m => m Int t6 = mdo return (return 10 :: m Int) return 10 ghc-exactprint-0.6.2/tests/examples/ghc86/T3391.hs0000755000000000000000000000041207346545000017606 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -v0 #-} -- We should only generate one set of generic to/from functions -- for T, despite the multiple chunks caused by the TH splices -- See Trac #3391 module T3391 where data T = MkT $(return []) $(return []) ghc-exactprint-0.6.2/tests/examples/ghc86/T3572.hs0000755000000000000000000000032307346545000017610 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TemplateHaskell #-} -- Trac #3572 module Main where import Language.Haskell.TH import Language.Haskell.TH.Ppr main = putStrLn . pprint =<< runQ [d| data Void |] ghc-exactprint-0.6.2/tests/examples/ghc86/T3927b.hs0000755000000000000000000000425507346545000017766 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T3927b where import Data.Proxy import GHC.Exts data Message data SocketType = Dealer | Push | Pull data SocketOperation = Read | Write type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where Restrict a (a ': as) = () Restrict x (a ': as) = Restrict x as Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") type family Implements (t :: SocketType) :: [SocketOperation] where Implements Dealer = ['Read, Write] Implements Push = '[Write] Implements Pull = '[ 'Read] data SockOp :: SocketType -> SocketOperation -> Type where SRead :: SockOp sock 'Read SWrite :: SockOp sock Write data Socket :: SocketType -> Type where Socket :: proxy sock -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) -> Socket sock type family Operation (op :: SocketOperation) :: Type where Operation 'Read = IO Message Operation Write = Message -> IO () class Restrict 'Read (Implements t) => Readable t where readSocket :: Socket t -> Operation 'Read readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) instance Readable Dealer type family Writable (t :: SocketType) :: Constraint where Writable Dealer = () Writable Push = () dealer :: Socket Dealer dealer = Socket (Proxy :: Proxy Dealer) f where f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op f SRead = undefined f SWrite = undefined push :: Socket Push push = Socket (Proxy :: Proxy Push) f where f :: Restrict op (Implements Push) => SockOp Push op -> Operation op f SWrite = undefined pull :: Socket Pull pull = Socket (Proxy :: Proxy Pull) f where f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op f SRead = undefined foo :: IO Message foo = readSocket dealer ghc-exactprint-0.6.2/tests/examples/ghc86/T4056.hs0000755000000000000000000000045707346545000017616 0ustar0000000000000000{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} module T4056 where import Language.Haskell.TH astTest :: Q [Dec] astTest = [d| class C t where op :: [t] -> [t] op = undefined |] class D t where bop :: [t] -> [t] bop = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/T4169.hs0000755000000000000000000000035507346545000017620 0ustar0000000000000000-- Crashed GHC 6.12 {-# LANGUAGE TemplateHaskell #-} module T4165 where import Language.Haskell.TH class Numeric a where fromIntegerNum :: a fromIntegerNum = undefined ast :: Q [Dec] ast = [d| instance Numeric Int |] ghc-exactprint-0.6.2/tests/examples/ghc86/T4170.hs0000755000000000000000000000024607346545000017607 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T4170 where import Language.Haskell.TH class LOL a lol :: Q [Dec] lol = [d| instance LOL Int |] instance LOL Int ghc-exactprint-0.6.2/tests/examples/ghc86/T5217.hs0000755000000000000000000000044707346545000017615 0ustar0000000000000000{-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} module T5217 where import Language.Haskell.TH $([d| data T a b where { T1 :: Int -> T Int Char ; T2 :: a -> T a a ; T3 :: a -> T [a] a ; T4 :: a -> b -> T b [a] } |]) ghc-exactprint-0.6.2/tests/examples/ghc86/T6018th.hs0000755000000000000000000001023207346545000020142 0ustar0000000000000000{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances, PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} module T6018th where import Language.Haskell.TH -- Test that injectivity works correct with TH. This test is not as exhaustive -- as the original T6018 test. -- type family F a b c = (result :: k) | result -> a b c -- type instance F Int Char Bool = Bool -- type instance F Char Bool Int = Int -- type instance F Bool Int Char = Char $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "F") [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) (Just $ InjectivityAnn (mkName "result") [(mkName "a"), (mkName "b"), (mkName "c") ])) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Char"), ConT (mkName "Bool") , ConT (mkName "Int")] ( ConT (mkName "Int"))) , TySynInstD (mkName "F") (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Char")] ( ConT (mkName "Char"))) ] ) -- this is injective - a type variables mentioned on LHS is not mentioned on RHS -- but we don't claim injectivity in that argument. -- -- type family J a (b :: k) = r | r -> a ---type instance J Int b = Char $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "J") [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [mkName "a"])) , TySynInstD (mkName "J") (TySynEqn [ ConT (mkName "Int"), VarT (mkName "b") ] ( ConT (mkName "Int"))) ] ) -- Closed type families -- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where -- IClosed Int Char Bool = Bool -- IClosed Int Char Int = Bool -- IClosed Bool Int Int = Int $( return [ ClosedTypeFamilyD (TypeFamilyHead (mkName "I") [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT , KindedTV (mkName "c") StarT ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")])) [ TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool")) , TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Int")] ( ConT (mkName "Bool")) , TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Int")) ] ] ) -- reification test $( do { decl@([ClosedTypeFamilyD (TypeFamilyHead _ _ _ (Just inj)) _]) <- [d| type family Bak a = r | r -> a where Bak Int = Char Bak Char = Int Bak a = a |] ; return decl } ) -- Check whether incorrect injectivity declarations are caught -- type family I a b c = r | r -> a b -- type instance I Int Char Bool = Bool -- type instance I Int Int Int = Bool -- type instance I Bool Int Int = Int $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "H") [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b") ])) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Char") , ConT (mkName "Bool")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Int"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Bool"))) , TySynInstD (mkName "H") (TySynEqn [ ConT (mkName "Bool"), ConT (mkName "Int") , ConT (mkName "Int")] ( ConT (mkName "Int"))) ] ) ghc-exactprint-0.6.2/tests/examples/ghc86/T6062.hs0000755000000000000000000000011207346545000017601 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module T6062 where x = [| False True |] ghc-exactprint-0.6.2/tests/examples/ghc86/T8455.hs0000755000000000000000000000014007346545000017612 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE TemplateHaskell #-} module T8455 where ty = [t| 5 |] ghc-exactprint-0.6.2/tests/examples/ghc86/T8759a.hs0000755000000000000000000000017007346545000017765 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} module T8759a where foo = [d| pattern Q = False |] ghc-exactprint-0.6.2/tests/examples/ghc86/T8807.hs0000755000000000000000000000036307346545000017622 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE ConstraintKinds, RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module T8807 where import Data.Proxy foo :: $( [t| forall a b. a b => Proxy a -> b -> b |] ) foo = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/T9367.hs0000755000000000000000000000016007346545000017617 0ustar0000000000000000x = "abc" main = print x -- This file has Windows line endings (CRLF) on purpose. Do not remove. -- See #9367. ghc-exactprint-0.6.2/tests/examples/ghc86/T9632.hs0000755000000000000000000000021107346545000017607 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module T9632 where import Data.Kind data B = T | F data P :: B -> Type type B' = B data P' :: B' -> Type ghc-exactprint-0.6.2/tests/examples/ghc86/T9662.hs0000755000000000000000000000222707346545000017623 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module T9662 where data Exp a = Exp data (a:.b) = a:.b type family Plain e :: Type type instance Plain (Exp a) = a type instance Plain (a:.b) = Plain a :. Plain b class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where type Unlifted pattern type Tuple pattern modify :: (Unlift pattern) => pattern -> (Unlifted pattern -> a) -> Exp (Tuple pattern) -> Exp (Plain a) modify p f = undefined data Atom a = Atom atom :: Atom a atom = Atom instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where type Unlifted (pa :. int) = Unlifted pa :. Exp Int type Tuple (pa :. int) = Tuple pa :. Int data Shape sh = Shape backpermute :: (Exp sh -> Exp sh') -> (Exp sh' -> Exp sh) -> Shape sh -> Shape sh' backpermute = undefined test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k) test = backpermute (modify (atom:.atom:.atom:.atom) (\(sh:.k:.m:.n) -> (sh:.m:.n:.k))) id -- With this arg instead of just 'id', it worked -- (modify (atom:.atom:.atom:.atom) -- (\(ix:.m:.n:.k) -> (ix:.k:.m:.n))) ghc-exactprint-0.6.2/tests/examples/ghc86/T9824.hs0000755000000000000000000000016507346545000017622 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-unused-matches #-} {-# LANGUAGE TemplateHaskell #-} module T9824 where foo = [p| (x, y) |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_abstractFamily.hs0000755000000000000000000000044607346545000022432 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_abstractFamily where import Language.Haskell.TH -- Empty closed type families are okay... ds1 :: Q [Dec] ds1 = [d| type family F a where |] -- ...but abstract ones should result in a type error ds2 :: Q [Dec] ds2 = [d| type family G a where .. |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_bracket1.hs0000755000000000000000000000031007346545000021147 0ustar0000000000000000-- Check that declarations in a bracket shadow the top-level {-# LANGUAGE TemplateHaskell #-} -- declarations, rather than clashing with them. module TH_bracket1 where foo = 1 bar = [d| foo = 1 |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_bracket2.hs0000755000000000000000000000024407346545000021156 0ustar0000000000000000 {-# LANGUAGE TemplateHaskell #-} module TH_bracket2 where d_show = [d| data A = A instance Show A where show _ = "A" |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_bracket3.hs0000755000000000000000000000043007346545000021154 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module TH_bracket3 where d_class = [d| class Classy a b where f :: a -> b instance Classy Int Bool where f x = if x == 0 then True else False |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_class1.hs0000755000000000000000000000033307346545000020646 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE TemplateHaskell #-} module TH_class1 where $( [d| class Classy a b c d | a -> b c, c -> d where f :: a -> b -> c -> d |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_dataD1.hs0000755000000000000000000000041407346545000020556 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_dataD1 where import Language.Haskell.TH ds :: Q [Dec] ds = [d| $(do { d <- dataD (cxt []) (mkName "D") [] Nothing [normalC (mkName "K") []] [] ; return [d]}) |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_localname.hs0000755000000000000000000000011707346545000021413 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_localname where x = \y -> [| y |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_lookupName.hs0000755000000000000000000000222107346545000021570 0ustar0000000000000000-- test 'lookupTypeName' and 'lookupValueName' {-# LANGUAGE TemplateHaskell #-} import Language.Haskell.TH import qualified TH_lookupName_Lib import qualified TH_lookupName_Lib as TheLib f :: String f = "TH_lookupName.f" data D = D $(return []) main = mapM_ print [ -- looking up values $(do { Just n <- lookupValueName "f" ; varE n }), $(do { Nothing <- lookupTypeName "f"; [| "" |] }), -- looking up types $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }), $(do { Nothing <- lookupValueName "String"; [| "" |] }), -- namespacing $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }), $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }), -- qualified lookup $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }), $(do { Just n <- lookupValueName "TheLib.f"; varE n }), -- shadowing $(TheLib.lookup_f), $( [| let f = "local f" in $(TheLib.lookup_f) |] ), $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ), $( [| let f = "local f" in $(varE 'f) |] ), let f = "local f" in $(TheLib.lookup_f), let f = "local f" in $(varE 'f) ] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_ppr1.hs0000755000000000000000000000153507346545000020347 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} module Main (main) where import Language.Haskell.TH u1 :: a u1 = undefined u2 :: a u2 = undefined f :: a f = undefined (.+.) :: a (.+.) = undefined main :: IO () main = do runQ [| f u1 u2 |] >>= p runQ [| u1 `f` u2 |] >>= p runQ [| (.+.) u1 u2 |] >>= p runQ [| u1 .+. u2 |] >>= p runQ [| (:) u1 u2 |] >>= p runQ [| u1 : u2 |] >>= p runQ [| \((:) x xs) -> x |] >>= p runQ [| \(x : xs) -> x |] >>= p runQ [d| class Foo a b where foo :: a -> b |] >>= p runQ [| \x -> (x, 1 `x` 2) |] >>= p runQ [| \(+) -> ((+), 1 + 2) |] >>= p runQ [| (f, 1 `f` 2) |] >>= p runQ [| ((.+.), 1 .+. 2) |] >>= p p :: Ppr a => a -> IO () p = putStrLn . pprint ghc-exactprint-0.6.2/tests/examples/ghc86/TH_raiseErr1.hs0000755000000000000000000000022407346545000021314 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_raiseErr1 where import Language.Haskell.TH foo = $(do { report True "Error test succeeded"; fail "" }) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_recover.hs0000755000000000000000000000044607346545000021132 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH -- The recover successfully find that 'ola' is not in scope -- and use '1' instead y = $(recover (return (LitE (IntegerL 1))) (reify (mkName ("ola")) >> return (LitE (IntegerL 2)))) main = print y ghc-exactprint-0.6.2/tests/examples/ghc86/TH_reifyDecl1.hs0000755000000000000000000000310307346545000021445 0ustar0000000000000000-- test reification of data declarations {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module TH_reifyDecl1 where import System.IO import Language.Haskell.TH import Text.PrettyPrint.HughesPJ infixl 3 `m1` -- simple data T = A | B -- parametric data R a = C a | D -- recursive data List a = Nil | Cons a (List a) -- infix operator data Tree a = Leaf | Tree a :+: Tree a -- type declaration type IntList = [Int] -- newtype declaration newtype Length = Length Int -- simple class class C1 a where m1 :: a -> Int -- class with instances class C2 a where m2 :: a -> Int instance C2 Int where m2 x = x -- associated types class C3 a where type AT1 a data AT2 a instance C3 Int where type AT1 Int = Bool data AT2 Int = AT2Int -- type family type family TF1 a -- type family, with instances type family TF2 a type instance TF2 Bool = Bool -- data family data family DF1 a -- data family, with instances data family DF2 a data instance DF2 Bool = DBool $(return []) test :: () test = $(let display :: Name -> Q () display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } in do { display ''T ; display ''R ; display ''List ; display ''Tree ; display ''IntList ; display ''Length ; display 'Leaf ; display 'm1 ; display ''C1 ; display ''C2 ; display ''C3 ; display ''AT1 ; display ''AT2 ; display ''TF1 ; display ''TF2 ; display ''DF1 ; display ''DF2 ; [| () |] }) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_reifyDecl2.hs0000755000000000000000000000030707346545000021451 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_reifyDecl2 where import Language.Haskell.TH import System.IO $( do x <- reify ''Maybe runIO $ hPutStrLn stderr $ pprint x return [] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_reifyInstances.hs0000755000000000000000000000206507346545000022452 0ustar0000000000000000-- test reifyInstances {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module TH_reifyInstances where import System.IO import Language.Haskell.TH import Text.PrettyPrint.HughesPJ -- classes class C1 a where f1 :: a class C2 a where f2 :: a instance C2 Int where f2 = 0 instance C2 Bool where f2 = True -- type families type family T1 a type family T2 a type instance T2 Int = Char type instance T2 Bool = Int -- data families data family D1 a data family D2 a data instance D2 Int = DInt | DInt2 data instance D2 Bool = DBool $(return []) test :: () test = $(let display :: Name -> Q () display n = do { intTy <- [t| Int |] ; is1 <- reifyInstances n [intTy] ; runIO $ hPutStrLn stderr (nameBase n) ; runIO $ hPutStrLn stderr (pprint is1) } in do { display ''C1 ; display ''C2 ; display ''T1 ; display ''T2 ; display ''D1 ; display ''D2 ; [| () |] }) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_reifyMkName.hs0000755000000000000000000000032107346545000021664 0ustar0000000000000000-- Trac #2339 {-# LANGUAGE TemplateHaskell #-} module Foo where import System.IO import Language.Haskell.TH type C = Int $(do a <- reify $ mkName "C" runIO $ hPutStrLn stderr (show a) return [] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repE1.hs0000755000000000000000000000104207346545000020432 0ustar0000000000000000-- test the representation of literals and also explicit type annotations {-# LANGUAGE TemplateHaskell #-} module TH_repE1 where import Language.Haskell.TH integralExpr :: ExpQ integralExpr = [| 42 |] intExpr :: ExpQ intExpr = [| 42 :: Int |] integerExpr :: ExpQ integerExpr = [| 42 :: Integer |] charExpr :: ExpQ charExpr = [| 'x' |] stringExpr :: ExpQ stringExpr = [| "A String" |] fractionalExpr :: ExpQ fractionalExpr = [| 1.2 |] floatExpr :: ExpQ floatExpr = [| 1.2 :: Float |] doubleExpr :: ExpQ doubleExpr = [| 1.2 :: Double |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repE2.hs0000755000000000000000000000145107346545000020437 0ustar0000000000000000-- test the representation of literals and also explicit type annotations {-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH main :: IO () main = mapM_ putStrLn [show an_integral, show an_int, show an_integer, show an_char, show an_string, show an_fractional, show an_float, show an_double] an_integral :: Integer an_integral = $( [| 42 |] ) an_int :: Int an_int = $( [| 42 :: Int |] ) an_integer :: Integer an_integer = $( [| 98765432123456789876 :: Integer |] ) an_char :: Char an_char = $( [| 'x' |] ) an_string :: String an_string = $( [| "A String" |] ) an_fractional :: Double an_fractional = $( [| 1.2 |] ) an_float :: Float an_float = $( [| 1.2 :: Float |] ) an_double :: Double an_double = $( [| 1.2 :: Double |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repE3.hs0000755000000000000000000000053707346545000020444 0ustar0000000000000000-- test the representation of literals and also explicit type annotations {-# LANGUAGE TemplateHaskell #-} module TH_repE1 where import Language.Haskell.TH emptyListExpr :: ExpQ emptyListExpr = [| [] |] singletonListExpr :: ExpQ singletonListExpr = [| [4] |] listExpr :: ExpQ listExpr = [| [4,5,6] |] consExpr :: ExpQ consExpr = [| 4:5:6:[] |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repGuard.hs0000755000000000000000000000117507346545000021236 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH import System.IO $( do ds <- [d| foo :: Int -> Int foo x | x == 5 = 6 foo x = 7 |] runIO $ do { putStrLn (pprint ds); hFlush stdout } return ds ) $( do ds <- [d| bar :: Maybe Int -> Int bar x | Just y <- x = y bar _ = 9 |] runIO $ do { putStrLn (pprint ds) ; hFlush stdout } return ds ) main :: IO () main = do putStrLn $ show $ foo 5 putStrLn $ show $ foo 8 putStrLn $ show $ bar (Just 2) putStrLn $ show $ bar Nothing ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repGuardOutput.hs0000755000000000000000000000074307346545000022457 0ustar0000000000000000-- test the representation of unboxed literals {-# LANGUAGE TemplateHaskell #-} module Main where $( [d| foo :: Int -> Int foo x | x == 5 = 6 foo x = 7 |] ) $( [d| bar :: Maybe Int -> Int bar x | Just y <- x = y bar _ = 9 |] ) main :: IO () main = do putStrLn $ show $ foo 5 putStrLn $ show $ foo 8 putStrLn $ show $ bar (Just 2) putStrLn $ show $ bar Nothing ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPatSig.hs0000755000000000000000000000054607346545000021364 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Main where import TH_repPatSig_asserts assertFoo [d| foo :: Int -> Int foo (x :: Int) = x |] assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |] assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |] main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPatSigTVar.hs0000755000000000000000000000034007346545000022151 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH $([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |]) main :: IO () main = return () ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPrim.hs0000755000000000000000000000250607346545000021102 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MagicHash #-} -- test the representation of unboxed literals module Main where import GHC.Exts import GHC.Float import Language.Haskell.TH import Text.PrettyPrint import System.IO main :: IO () main = do putStrLn $ show $ $( do e <- [| I# 20# |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout return e ) putStrLn $ show $ $( do e <- [| W# 32## |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout return e ) putStrLn $ show $ $( do e <- [| F# 12.3# |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout return e ) putStrLn $ show $ $( do e <- [| D# 24.6## |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout return e ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPrim2.hs0000755000000000000000000000257207346545000021167 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# LANGUAGE TemplateHaskell #-} -- test the representation of unboxed literals module Main where import GHC.Exts import GHC.Float import Language.Haskell.TH import Text.PrettyPrint import System.IO main :: IO () main = do putStrLn $ show $ $( do e <- [| 20# |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout [| I# $( return e) |] ) putStrLn $ show $ $( do e <- [| 32## |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout [| W# $(return e) |] ) putStrLn $ show $ $( do e <- [| 12.3# |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout [| F# $(return e) |] ) putStrLn $ show $ $( do e <- [| 24.6## |] runIO $ putStrLn $ show e runIO $ putStrLn $ pprint e runIO $ hFlush stdout [| D# $(return e) |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPrimOutput.hs0000755000000000000000000000117607346545000022325 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} -- test the representation of unboxed literals module Main where import GHC.Exts import GHC.Float import Language.Haskell.TH import Text.PrettyPrint import System.IO main :: IO () main = do putStrLn $ show $ $( do e <- [| I# 20# |] return e ) putStrLn $ show $ $( do e <- [| W# 32## |] return e ) putStrLn $ show $ $( do e <- [| F# 12.3# |] return e ) putStrLn $ show $ $( do e <- [| D# 24.6## |] return e ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_repPrimOutput2.hs0000755000000000000000000000126107346545000022402 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# LANGUAGE TemplateHaskell #-} -- test the representation of unboxed literals module Main where import GHC.Exts import GHC.Float import Language.Haskell.TH import Text.PrettyPrint import System.IO main :: IO () main = do putStrLn $ show $ $( do e <- [| 20# |] [| I# $(return e) |] ) putStrLn $ show $ $( do e <- [| 32## |] [| W# $(return e) |] ) putStrLn $ show $ $( do e <- [| 12.3# |] [| F# $(return e) |] ) putStrLn $ show $ $( do e <- [| 24.6## |] [| D# $(return e) |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_scope.hs0000755000000000000000000000023207346545000020567 0ustar0000000000000000-- Test for Trac #2188 {-# LANGUAGE TemplateHaskell #-} module TH_scope where f g = [d| f :: Int f = g g :: Int g = 4 |] ghc-exactprint-0.6.2/tests/examples/ghc86/TH_sections.hs0000755000000000000000000000024107346545000021305 0ustar0000000000000000-- Test for trac #2956 {-# LANGUAGE TemplateHaskell #-} module TH_sections where two :: Int two = $( [| (1 +) 1 |] ) three :: Int three = $( [| (+ 2) 1 |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceD2.hs0000755000000000000000000000020707346545000021125 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_spliceD2 where import qualified TH_spliceD2_Lib $( [d| data T = T TH_spliceD2_Lib.T |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceDecl1.hs0000755000000000000000000000037507346545000021616 0ustar0000000000000000-- test splicing of a generated data declarations {-# LANGUAGE TemplateHaskell #-} module TH_spliceDecl1 where import Language.Haskell.TH -- splice a simple data declaration $(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []]) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceDecl2.hs0000755000000000000000000000037207346545000021614 0ustar0000000000000000-- test splicing of quoted data and newtype declarations {-# LANGUAGE TemplateHaskell #-} module TH_spliceDecl2 where import Language.Haskell.TH -- splice a simple quoted declaration (x 2) $([d| data T1 = C1 |]) $([d| newtype T2 = C2 String |]) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceDecl3.hs0000755000000000000000000000034607346545000021616 0ustar0000000000000000-- test splicing of reified and renamed data declarations {-# LANGUAGE TemplateHaskell #-} module TH_spliceDecl3 where import Language.Haskell.TH import TH_spliceDecl3_Lib data T = C $(do { TyConI d <- reify ''T; rename' d}) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE1.hs0000755000000000000000000000017207346545000021126 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where my_id :: a -> a my_id x = $( [| x |] ) main = print (my_id "hello") ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE3.hs0000755000000000000000000000107607346545000021134 0ustar0000000000000000-- test the representation of literals and also explicit type annotations {-# LANGUAGE TemplateHaskell #-} module TH_repE1 where import Language.Haskell.TH $( do let emptyListExpr :: ExpQ emptyListExpr = [| [] |] singletonListExpr :: ExpQ singletonListExpr = [| [4] |] listExpr :: ExpQ listExpr = [| [4,5,6] |] consExpr :: ExpQ consExpr = [| 4:5:6:[] |] [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |] ) bar = $( [| case undefined of [1] -> 1 |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE4.hs0000755000000000000000000000030407346545000021126 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Main where import Language.Haskell.TH $( do let h x = x foo = [| \x -> $(h [| x |]) |] [d| baz = $foo |] ) main = print (baz "Hello") ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE5_Lib.hs0000755000000000000000000000032607346545000021721 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_spliceE5_Lib where import Language.Haskell.TH expandVars :: [String] -> Q Exp expandVars s = [| concat $(return (ListE (map f s))) |] where f x = VarE (mkName x) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE5_prof_Lib.hs0000755000000000000000000000033307346545000022745 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_spliceE5_prof_Lib where import Language.Haskell.TH expandVars :: [String] -> Q Exp expandVars s = [| concat $(return (ListE (map f s))) |] where f x = VarE (mkName x) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceE5_prof_ext_Lib.hs0000755000000000000000000000033707346545000023631 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_spliceE5_prof_ext_Lib where import Language.Haskell.TH expandVars :: [String] -> Q Exp expandVars s = [| concat $(return (ListE (map f s))) |] where f x = VarE (mkName x) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_spliceExpr1.hs0000755000000000000000000000032607346545000021661 0ustar0000000000000000-- test representation and splicing of left-parenthesised right infix operators {-# LANGUAGE TemplateHaskell #-} module TH_spliceExpr1 where import Language.Haskell.TH foo :: Int foo = $( [| ((+) $ 2) $ 2 |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_tf1.hs0000755000000000000000000000067607346545000020164 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} module TH_tf1 where $( [d| data family T a |] ) $( [d| data instance T Int = TInt Bool |] ) foo :: Bool -> T Int foo b = TInt (b && b) $( [d| type family S a |] ) $( [d| type instance S Int = Bool |] ) bar :: S Int -> Int bar c = if c then 1 else 2 $( [d| type family R (a :: * -> *) :: * -> * |] ) $( [d| type instance R Maybe = [] |] ) baz :: R Maybe Int -> Int baz = head ghc-exactprint-0.6.2/tests/examples/ghc86/TH_tf3.hs0000755000000000000000000000046407346545000020161 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} module TH_tf3 where type family T a $( [d| foo :: T [a] ~ Bool => a -> a foo x = x |] ) $( [d| class C a instance a ~ Int => C a |] ) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_unresolvedInfix.hs0000755000000000000000000001215307346545000022647 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} module Main where import TH_unresolvedInfix_Lib import Language.Haskell.TH -------------------------------------------------------------------------------- -- Expressions -- -------------------------------------------------------------------------------- exprs = [ -------------- Completely-unresolved bindings $( n +? (n *? n) ), $( (n +? n) *? n ), $( n +? (n +? n) ), $( (n +? n) +? n ), -- VarE version $( uInfixE n plus2 (uInfixE n plus2 n) ), $( uInfixE (uInfixE n plus2 n) plus2 n ), $( uInfixE n plus3 (uInfixE n plus3 n) ), $( uInfixE (uInfixE n plus3 n) plus3 n ), --------------- Completely-resolved bindings $( n +! (n *! n) ), $( (n +! n) *! n ), $( n +! (n +! n) ), $( (n +! n) +! n ), -------------- Mixed resolved/unresolved $( (n +! n) *? (n +? n) ), $( (n +? n) *? (n +! n) ), $( (n +? n) *! (n +! n) ), $( (n +? n) *! (n +? n) ), -------------- Parens $( ((parensE ((n +? n) *? n)) +? n) *? n ), $( (parensE (n +? n)) *? (parensE (n +? n)) ), $( parensE ((n +? n) *? (n +? n)) ), -------------- Sections $( infixE (Just $ n +? n) plus Nothing ) N, -- see B.hs for the (non-compiling) other version of the above $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N, -------------- Dropping constructors $( n *? tupE [n +? n] ) ] -------------------------------------------------------------------------------- -- Patterns -- -------------------------------------------------------------------------------- patterns = [ -------------- Completely-unresolved patterns case N :+ (N :* N) of [p1|unused|] -> True, case N :+ (N :* N) of [p2|unused|] -> True, case (N :+ N) :+ N of [p3|unused|] -> True, case (N :+ N) :+ N of [p4|unused|] -> True, -------------- Completely-resolved patterns case N :+ (N :* N) of [p5|unused|] -> True, case (N :+ N) :* N of [p6|unused|] -> True, case N :+ (N :+ N) of [p7|unused|] -> True, case (N :+ N) :+ N of [p8|unused|] -> True, -------------- Mixed resolved/unresolved case ((N :+ N) :* N) :+ N of [p9|unused|] -> True, case N :+ (N :* (N :+ N)) of [p10|unused|] -> True, case (N :+ N) :* (N :+ N) of [p11|unused|] -> True, case (N :+ N) :* (N :+ N) of [p12|unused|] -> True, -------------- Parens case (N :+ (N :* N)) :+ (N :* N) of [p13|unused|] -> True, case (N :+ N) :* (N :+ N) of [p14|unused|] -> True, case (N :+ (N :* N)) :+ N of [p15|unused|] -> True, -------------- Dropping constructors case (N :* (N :+ N)) of [p16|unused|] -> True ] -------------------------------------------------------------------------------- -- Types -- -------------------------------------------------------------------------------- -------------- Completely-unresolved types _t1 = 1 `Plus` (1 `Times` 1) :: $( int $+? (int $*? int) ) _t2 = 1 `Plus` (1 `Times` 1) :: $( (int $+? int) $*? int ) _t3 = (1 `Plus` 1) `Plus` 1 :: $( int $+? (int $+? int) ) _t4 = (1 `Plus` 1) `Plus` 1 :: $( (int $+? int) $+? int ) -------------- Completely-resolved types _t5 = 1 `Plus` (1 `Times` 1) :: $( int $+! (int $*! int) ) _t6 = (1 `Plus` 1) `Times` 1 :: $( (int $+! int) $*! int ) _t7 = 1 `Plus` (1 `Plus` 1) :: $( int $+! (int $+! int) ) _t8 = (1 `Plus` 1) `Plus` 1 :: $( (int $+! int) $+! int ) -------------- Mixed resolved/unresolved _t9 = ((1 `Plus` 1) `Times` 1) `Plus` 1 :: $( (int $+! int) $*? (int $+? int) ) _t10 = 1 `Plus` (1 `Times` (1 `Plus` 1)) :: $( (int $+? int) $*? (int $+! int) ) _t11 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+! int) ) _t12 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (int $+? int) $*! (int $+? int) ) -------------- Parens _t13 = (1 `Plus` (1 `Times` 1)) `Plus` (1 `Times` 1) :: $( ((parensT ((int $+? int) $*? int)) $+? int) $*? int ) _t14 = (1 `Plus` 1) `Times` (1 `Plus` 1) :: $( (parensT (int $+? int)) $*? (parensT (int $+? int)) ) _t15 = (1 `Plus` (1 `Times` 1)) `Plus` 1 :: $( parensT ((int $+? int) $*? (int $+? int)) ) main = do mapM_ print exprs mapM_ print patterns -- check that there are no Parens or UInfixes in the output runQ [|N :* N :+ N|] >>= print runQ [|(N :* N) :+ N|] >>= print runQ [p|N :* N :+ N|] >>= print runQ [p|(N :* N) :+ N|] >>= print runQ [t|Int * Int + Int|] >>= print runQ [t|(Int * Int) + Int|] >>= print -- pretty-printing of unresolved infix expressions let ne = ConE $ mkName "N" np = ConP (mkName "N") [] nt = ConT (mkName "Int") plusE = ConE (mkName ":+") plusP = (mkName ":+") plusT = (mkName "+") putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) putStrLn $ pprint (ParensE ne) putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) putStrLn $ pprint (ParensP np) putStrLn $ pprint (InfixT nt plusT (UInfixT nt plusT (UInfixT nt plusT nt))) putStrLn $ pprint (ParensT nt) ghc-exactprint-0.6.2/tests/examples/ghc86/TH_unresolvedInfix2.hs0000755000000000000000000000046207346545000022731 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TH_unresolvedInfix2 where import Language.Haskell.TH infixl 6 :+ data Tree = N | Tree :+ Tree | Tree :* Tree $(return []) -- Should fail expr = $( let plus = conE '(:+) n = conE 'N in infixE Nothing plus (Just $ uInfixE n plus n) ) ghc-exactprint-0.6.2/tests/examples/ghc86/TensorTests.hs0000755000000000000000000000200207346545000021355 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module TensorTests (tensorTests) where import Apply.Cyc import Tests import Utils import TestTypes import Crypto.Lol import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor import Crypto.Lol.Types import Control.Applicative import Data.Maybe import Data.Singletons import Data.Promotion.Prelude.Eq import Data.Singletons.TypeRepStar () import qualified Test.Framework as TF type TMRParams = ( '(,) <$> Tensors) <*> MRCombos tmrParams :: Proxy TMRParams tmrParams = Proxy --type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos tremParams :: Proxy TrEmParams tremParams = Proxy type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) data Liftable :: TyFun (Factored, Type) Bool -> Type type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) ghc-exactprint-0.6.2/tests/examples/ghc86/Test.hs0000755000000000000000000002232507346545000020011 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Test -- Copyright : (c) Simon Marlow 2002 -- License : BSD-style -- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- This module illustrates & tests most of the features of Haddock. -- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. -- ----------------------------------------------------------------------------- -- This is plain comment, ignored by Haddock. module Test ( -- Section headings are introduced with '-- *': -- * Type declarations -- Subsection headings are introduced with '-- **' and so on. -- ** Data types T(..), T2, T3(..), T4(..), T5(..), T6(..), N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), -- ** Records R(..), R1(..), -- | test that we can export record selectors on their own: p, q, u, -- * Class declarations C(a,b), D(..), E, F(..), -- | Test that we can export a class method on its own: a, -- * Function types f, g, -- * Auxiliary stuff -- $aux1 -- $aux2 -- $aux3 -- $aux4 -- $aux5 -- $aux6 -- $aux7 -- $aux8 -- $aux9 -- $aux10 -- $aux11 -- $aux12 -- | This is some inline documentation in the export list -- -- > a code block using bird-tracks -- > each line must begin with > (which isn't significant unless it -- > is at the beginning of the line). -- * A hidden module module Hidden, -- * A visible module module Visible, {-| nested-style doc comments -} -- * Existential \/ Universal types Ex(..), -- * Type signatures with argument docs k, l, m, o, -- * A section -- and without an intervening comma: -- ** A subsection {-| > a literal line $ a non /literal/ line $ -} f', ) where import Hidden import Visible -- | This comment applies to the /following/ declaration -- and it continues until the next non-comment line data T a b = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor | -- | This comment describes the 'B' constructor B (T a b, T Int Float) -- ^ -- | An abstract data declaration data T2 a b = T2 a b -- | A data declaration with no documentation annotations on the constructors data T3 a b = A1 a | B1 b -- A data declaration with no documentation annotations at all data T4 a b = A2 a | B2 b -- A data declaration documentation on the constructors only data T5 a b = A3 a -- ^ documents 'A3' | B3 b -- ^ documents 'B3' -- | Testing alternative comment styles data T6 -- | This is the doc for 'A4' = A4 | B4 | -- ^ This is the doc for 'B4' -- | This is the doc for 'C4' C4 -- | A newtype newtype N1 a = N1 a -- | A newtype with a fieldname newtype N2 a b = N2 {n :: a b} -- | A newtype with a fieldname, documentation on the field newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field } -- | An abstract newtype - we show this one as data rather than newtype because -- the difference isn\'t visible to the programmer for an abstract type. newtype N4 a b = N4 a newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor } newtype N6 a b = N6 {n6 :: a b } -- ^ docs on the constructor only -- | docs on the newtype and the constructor newtype N7 a b = N7 {n7 :: a b } -- ^ The 'N7' constructor class (D a) => C a where -- |this is a description of the 'a' method a :: IO a b :: [a] -- ^ this is a description of the 'b' method c :: a -- c is hidden in the export list -- ^ This comment applies to the /previous/ declaration (the 'C' class) class D a where d :: T a b e :: (a,a) -- ^ This is a class declaration with no separate docs for the methods instance D Int where d = undefined e = undefined -- instance with a qualified class name instance Test.D Float where d = undefined e = undefined class E a where ee :: a -- ^ This is a class declaration with no methods (or no methods exported) -- This is a class declaration with no documentation at all class F a where ff :: a -- | This is the documentation for the 'R' record, which has four fields, -- 'p', 'q', 'r', and 's'. data R = -- | This is the 'C1' record constructor, with the following fields: C1 { p :: Int -- ^ This comment applies to the 'p' field , q :: forall a . a->a -- ^ This comment applies to the 'q' field , -- | This comment applies to both 'r' and 's' r,s :: Int } | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), u,v :: Int } -- ^ This is the 'C2' record constructor, also with some fields: -- | Testing different record commenting styles data R1 -- | This is the 'C3' record constructor = C3 { -- | The 's1' record selector s1 :: Int -- | The 's2' record selector , s2 :: Int , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. -- Since GHC doesn't allow that, I have removed it in this file. -- ^ The 's3' record selector } -- These section headers are only used when there is no export list to -- give the structure of the documentation: -- * This is a section header (level 1) -- ** This is a section header (level 2) -- *** This is a section header (level 3) {-| In a comment string we can refer to identifiers in scope with single quotes like this: 'T', and we can refer to modules by using double quotes: "Foo". We can add emphasis /like this/. * This is a bulleted list - This is the next item (different kind of bullet) (1) This is an ordered list 2. This is the next item (different kind of bullet) @ This is a block of code, which can include other markup: 'R' formatting is significant @ > this is another block of code We can also include URLs in documentation: . -} f :: C a => a -> Int -- | we can export foreign declarations too foreign import ccall "header.h" g :: Int -> IO CInt -- | this doc string has a parse error in it: \' h :: Int h = 42 -- $aux1 This is some documentation that is attached to a name ($aux1) -- rather than a source declaration. The documentation may be -- referred to in the export list using its name. -- -- @ code block in named doc @ -- $aux2 This is some documentation that is attached to a name ($aux2) -- $aux3 -- @ code block on its own in named doc @ -- $aux4 -- -- @ code block on its own in named doc (after newline) @ {- $aux5 a nested, named doc comment with a paragraph, @ and a code block @ -} -- some tests for various arrangements of code blocks: {- $aux6 >test >test1 @ test2 test3 @ -} {- $aux7 @ test1 test2 @ -} {- $aux8 >test3 >test4 -} {- $aux9 @ test1 test2 @ >test3 >test4 -} {- $aux10 >test3 >test4 @ test1 test2 @ -} -- This one is currently wrong (Haddock 0.4). The @...@ part is -- interpreted as part of the bird-tracked code block. {- $aux11 aux11: >test3 >test4 @ test1 test2 @ -} -- $aux12 -- > foo -- -- > bar -- -- | A data-type using existential\/universal types data Ex a = forall b . C b => Ex1 b | forall b . Ex2 b | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file | Ex4 (forall a . a -> a) -- | This is a function with documentation for each argument k :: T () () -- ^ This argument has type 'T' -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ -> T5 () () -- ^ This argument has a very long description that should -- hopefully cause some wrapping to happen when it is finally -- rendered by Haddock in the generated HTML page. -> IO () -- ^ This is the result type -- This function has arg docs but no docs for the function itself l :: (Int, Int, Float) -- ^ takes a triple -> Int -- ^ returns an 'Int' -- | This function has some arg docs m :: R -> N1 () -- ^ one of the arguments -> IO Int -- ^ and the return value -- | This function has some arg docs but not a return value doc -- can't use the original name ('n') with GHC newn :: R -- ^ one of the arguments, an 'R' -> N1 () -- ^ one of the arguments -> IO Int newn = undefined -- | A foreign import with argument docs foreign import ccall unsafe "header.h" o :: Float -- ^ The input float -> IO Float -- ^ The output float -- | We should be able to escape this: \#\#\# -- p :: Int -- can't use the above original definition with GHC newp :: Int newp = undefined -- | a function with a prime can be referred to as 'f'' -- but f' doesn't get link'd 'f\'' f' :: Int -- Add some definitions here so that this file can be compiled with GHC data T1 f = undefined f' = undefined type CInt = Int k = undefined l = undefined m = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/Test12417.hs0000755000000000000000000000074307346545000020410 0ustar0000000000000000{-# LANGUAGE UnboxedSums, MagicHash #-} module Test12417 where import GHC.Prim import GHC.Types import System.Mem (performMajorGC) type Either1 a b = (# a | b #) showEither1 :: (Show a, Show b) => Either1 a b -> String showEither1 (# left | #) = "Left " ++ show left showEither1 (# | right #) = "Right " ++ show right type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #) showEither4 :: T -> String showEither4 (# | b | | | | | #) = "Alt1: " ++ show b ghc-exactprint-0.6.2/tests/examples/ghc86/TupleN.hs0000755000000000000000000000054207346545000020276 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module TupleN where import Language.Haskell.TH tuple :: Int -> ExpQ tuple n = [|\list -> $(tupE (exprs [|list|])) |] where exprs list = id [infixE (Just (list)) (varE '(!!)) (Just (litE $ integerL (toInteger num))) | num <- [0..(n - 1)]] ghc-exactprint-0.6.2/tests/examples/ghc86/UnicodeSyntax.hs0000755000000000000000000001332307346545000021665 0ustar0000000000000000{-# 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) } -- from ghc-prim -- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' -- type * = TYPE 'PtrRepLifted -- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' -- type ★ = TYPE 'PtrRepLifted ghc-exactprint-0.6.2/tests/examples/ghc86/Webhook.hs0000755000000000000000000001506407346545000020472 0ustar0000000000000000{-| Module : Servant.GitHub.Webhook Description : Easily write safe GitHub webhook handlers with Servant Copyright : (c) Jacob Thomas Errington, 2016 License : MIT Maintainer : servant-github-webhook@mail.jerrington.me Stability : experimental The GitHub webhook machinery will attach three headers to the HTTP requests that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. The former two headers correspond with the 'GitHubEvent' and 'GitHubSignedReqBody''' routing combinators. This library ignores the @X-Github-Delivery@ header; if you would like to access its value, then use the builtin 'Header' combinator from Servant. Usage of the library is straightforward: protect routes with the 'GitHubEvent' combinator to ensure that the route is only reached for specific 'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write under that route with 'GitHubSignedReqBody'. It is advised to always include a 'GitHubSignedReqBody''', as this is the only way you can be sure that it is GitHub who is sending the request, and not a malicious user. If you don't care about the request body, then simply use Aeson\'s 'Object' type as the deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and ignore the @Object@ in the handler. The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in order to extract the signing key. This is the same key that must be entered in the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. In order to support multiple keys on a per-route basis, the basic combinator @GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, create a datatype, e.g. @KeyIndex@ whose constructors identify the different keys you will be using. Generally, this means one constructor per repository. Use the @DataKinds@ extension to promote this datatype to a kind, and write an instance of 'Reflect' for each promoted constructor of your datatype. Finally, create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is the datatype you've built up. Thus, your function can determine which key to retrieve. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- GHC 8 seems to have improved its decidability check for type family -- instances and class instances. In particular, without UndecidableInstances -- enabled, the Demote' instance for lists, which we need, will not compile. -- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, -- won't compile on GHC < 8 because the instance head is no smaller than the -- instance head. #if __GLASGOW_HASKELL__ < 800 {-# LANGUAGE UndecidableInstances #-} #endif module Servant.GitHub.Webhook ( -- * Servant combinators GitHubSignedReqBody'' , GitHubSignedReqBody' , GitHubSignedReqBody , GitHubEvent -- ** Security , GitHubKey'(..) , GitHubKey , gitHubKey -- * Reexports -- -- | We reexport a few datatypes that are typically needed to use the -- library. , RepoWebhookEvent(..) , KProxy(..) -- * Implementation details -- ** Type-level programming machinery , Demote , Demote' , Reflect(..) -- ** Stringy stuff , parseHeaderMaybe , matchEvent -- * Examples -- -- $example1 -- -- $example2 ) where import Control.Monad.IO.Class ( liftIO ) import Data.Aeson ( decode', encode ) import qualified Data.ByteString as BS import Data.ByteString.Lazy ( fromStrict, toStrict ) import qualified Data.ByteString.Base16 as B16 import Data.HMAC ( hmac_sha1 ) import Data.List ( intercalate ) import Data.Maybe ( catMaybes, fromMaybe ) import Data.Monoid ( (<>) ) import Data.Proxy import Data.String.Conversions ( cs ) import qualified Data.Text.Encoding as E import GHC.TypeLits import GitHub.Data.Webhooks import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Wai ( requestHeaders, strictRequestBody ) import Servant import Servant.API.ContentTypes ( AllCTUnrender(..) ) import Servant.Server.Internal -- | A clone of Servant's 'ReqBody' combinator, except that it will also -- verify the signature provided by GitHub in the @X-Hub-Signature@ header by -- computing the SHA1 HMAC of the request body and comparing. -- -- The use of this combinator will require that the router context contain an -- appropriate 'GitHubKey'' entry. Specifically, the type parameter of -- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the -- index @key@ used here. Consequently, it will be necessary to use -- 'serveWithContext' instead of 'serve'. -- -- Other routes are not tried upon the failure of this combinator, and a 401 -- response is generated. -- -- Use of this datatype directly is discouraged, since the choice of the index -- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use -- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just -- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for -- the implementation of the 'HasServer' instance for the datatype. data GitHubSignedReqBody'' (proxy :: KProxy k) (key :: k) (list :: [Type]) (result :: Type) where -- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first -- type argument given just the second one. -- -- Use this type synonym if you are creating a webhook server to handle -- webhooks from multiple repositories, with different secret keys. type GitHubSignedReqBody' (key :: k) = GitHubSignedReqBody'' ('KProxy :: KProxy k) key -- | A convenient alias for a trivial key index. -- -- USe this type synonym if you are creating a webhook server to handle only -- webhooks from a single repository, or for mutliple repositories using the -- same secret key. type GitHubSignedReqBody = GitHubSignedReqBody' '() -- | A routing combinator that succeeds only for a webhook request that matches -- one of the given 'RepoWebhookEvent' given in the type-level list @events@. -- -- If the list contains 'WebhookWildcardEvent', then all events will be -- matched. -- -- The combinator will require that its associated handler take a -- 'RepoWebhookEvent' parameter, and the matched event will be passed to the -- handler. This allows the handler to determine which event triggered it from -- the list. -- -- Other routes are tried if there is a mismatch. data GitHubEvent (events :: [RepoWebhookEvent]) where ghc-exactprint-0.6.2/tests/examples/ghc86/deriving-via-compile.hs0000755000000000000000000002762407346545000023113 0ustar0000000000000000{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} module DerivingViaCompile where import Data.Void import Data.Complex import Data.Functor.Const import Data.Functor.Identity import Data.Ratio import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Applicative hiding (WrappedMonad(..)) import Data.Bifunctor import Data.Monoid import Data.Kind type f ~> g = forall xx. f xx -> g xx ----- -- Simple example ----- data Foo a = MkFoo a a deriving Show via (Identity (Foo a)) ----- -- Eta reduction at work ----- newtype Flip p a b = Flip { runFlip :: p b a } instance Bifunctor p => Bifunctor (Flip p) where bimap f g = Flip . bimap g f . runFlip instance Bifunctor p => Functor (Flip p a) where fmap f = Flip . first f . runFlip newtype Bar a = MkBar (Either a Int) deriving Functor via (Flip Either Int) ----- -- Monad transformers ----- type MTrans = (Type -> Type) -> (Type -> Type) -- From `constraints' data Dict c where Dict :: c => Dict c newtype a :- b = Sub (a => Dict b) infixl 1 \\ (\\) :: a => (b => r) -> (a :- b) -> r r \\ Sub Dict = r -- With `-XQuantifiedConstraints' this just becomes -- -- type Lifting cls trans = forall mm. cls mm => cls (trans mm) -- -- type LiftingMonad trans = Lifting Monad trans -- class LiftingMonad (trans :: MTrans) where proof :: Monad m :- Monad (trans m) instance LiftingMonad (StateT s :: MTrans) where proof :: Monad m :- Monad (StateT s m) proof = Sub Dict instance Monoid w => LiftingMonad (WriterT w :: MTrans) where proof :: Monad m :- Monad (WriterT w m) proof = Sub Dict instance (LiftingMonad trans, LiftingMonad trans') => LiftingMonad (ComposeT trans trans' :: MTrans) where proof :: forall m. Monad m :- Monad (ComposeT trans trans' m) proof = Sub (Dict \\ proof @trans @(trans' m) \\ proof @trans' @m) newtype Stack :: MTrans where Stack :: ReaderT Int (StateT Bool (WriterT String m)) a -> Stack m a deriving newtype ( Functor , Applicative , Monad , MonadReader Int , MonadState Bool , MonadWriter String ) deriving (MonadTrans, MFunctor) via (ReaderT Int `ComposeT` StateT Bool `ComposeT` WriterT String) class MFunctor (trans :: MTrans) where hoist :: Monad m => (m ~> m') -> (trans m ~> trans m') instance MFunctor (ReaderT r :: MTrans) where hoist :: Monad m => (m ~> m') -> (ReaderT r m ~> ReaderT r m') hoist nat = ReaderT . fmap nat . runReaderT instance MFunctor (StateT s :: MTrans) where hoist :: Monad m => (m ~> m') -> (StateT s m ~> StateT s m') hoist nat = StateT . fmap nat . runStateT instance MFunctor (WriterT w :: MTrans) where hoist :: Monad m => (m ~> m') -> (WriterT w m ~> WriterT w m') hoist nat = WriterT . nat . runWriterT infixr 9 `ComposeT` newtype ComposeT :: MTrans -> MTrans -> MTrans where ComposeT :: { getComposeT :: f (g m) a } -> ComposeT f g m a deriving newtype (Functor, Applicative, Monad) instance (MonadTrans f, MonadTrans g, LiftingMonad g) => MonadTrans (ComposeT f g) where lift :: forall m. Monad m => m ~> ComposeT f g m lift = ComposeT . lift . lift \\ proof @g @m instance (MFunctor f, MFunctor g, LiftingMonad g) => MFunctor (ComposeT f g) where hoist :: forall m m'. Monad m => (m ~> m') -> (ComposeT f g m ~> ComposeT f g m') hoist f = ComposeT . hoist (hoist f) . getComposeT \\ proof @g @m ----- -- Using tuples in a `via` type ----- newtype X a = X (a, a) deriving (Semigroup, Monoid) via (Product a, Sum a) deriving (Show, Eq) via (a, a) ----- -- Abstract data types ----- class C f where c :: f a -> Int newtype X2 f a = X2 (f a) instance C (X2 f) where c = const 0 deriving via (X2 IO) instance C IO ---- -- Testing parser ---- newtype P0 a = P0 a deriving Show via a newtype P1 a = P1 [a] deriving Show via [a] newtype P2 a = P2 (a, a) deriving Show via (a, a) newtype P3 a = P3 (Maybe a) deriving Show via (First a) newtype P4 a = P4 (Maybe a) deriving Show via (First $ a) newtype P5 a = P5 a deriving Show via (Identity $ a) newtype P6 a = P6 [a] deriving Show via ([] $ a) newtype P7 a = P7 (a, a) deriving Show via (Identity $ (a, a)) newtype P8 a = P8 (Either () a) deriving Functor via (($) (Either ())) newtype f $ a = APP (f a) deriving newtype Show deriving newtype Functor ---- -- From Baldur's notes ---- ---- -- 1 ---- newtype WrapApplicative f a = WrappedApplicative (f a) deriving (Functor, Applicative) instance (Applicative f, Num a) => Num (WrapApplicative f a) where (+) = liftA2 (+) (*) = liftA2 (*) negate = fmap negate fromInteger = pure . fromInteger abs = fmap abs signum = fmap signum instance (Applicative f, Fractional a) => Fractional (WrapApplicative f a) where recip = fmap recip fromRational = pure . fromRational instance (Applicative f, Floating a) => Floating (WrapApplicative f a) where pi = pure pi sqrt = fmap sqrt exp = fmap exp log = fmap log sin = fmap sin cos = fmap cos asin = fmap asin atan = fmap atan acos = fmap acos sinh = fmap sinh cosh = fmap cosh asinh = fmap asinh atanh = fmap atanh acosh = fmap acosh instance (Applicative f, Semigroup s) => Semigroup (WrapApplicative f s) where (<>) = liftA2 (<>) instance (Applicative f, Monoid m) => Monoid (WrapApplicative f m) where mempty = pure mempty ---- -- 2 ---- class Pointed p where pointed :: a -> p a newtype WrapMonad f a = WrappedMonad (f a) deriving newtype (Pointed, Monad) instance (Monad m, Pointed m) => Functor (WrapMonad m) where fmap = liftM instance (Monad m, Pointed m) => Applicative (WrapMonad m) where pure = pointed (<*>) = ap -- data data Sorted a = Sorted a a a deriving (Functor, Applicative) via (WrapMonad Sorted) deriving (Num, Fractional, Floating, Semigroup, Monoid) via (WrapApplicative Sorted a) instance Monad Sorted where (>>=) :: Sorted a -> (a -> Sorted b) -> Sorted b Sorted a b c >>= f = Sorted a' b' c' where Sorted a' _ _ = f a Sorted _ b' _ = f b Sorted _ _ c' = f c instance Pointed Sorted where pointed :: a -> Sorted a pointed a = Sorted a a a ---- -- 3 ---- class IsZero a where isZero :: a -> Bool newtype WrappedNumEq a = WrappedNumEq a newtype WrappedShow a = WrappedShow a newtype WrappedNumEq2 a = WrappedNumEq2 a instance (Num a, Eq a) => IsZero (WrappedNumEq a) where isZero :: WrappedNumEq a -> Bool isZero (WrappedNumEq a) = 0 == a instance Show a => IsZero (WrappedShow a) where isZero :: WrappedShow a -> Bool isZero (WrappedShow a) = "0" == show a instance (Num a, Eq a) => IsZero (WrappedNumEq2 a) where isZero :: WrappedNumEq2 a -> Bool isZero (WrappedNumEq2 a) = a + a == a newtype INT = INT Int deriving newtype Show deriving IsZero via (WrappedNumEq Int) newtype VOID = VOID Void deriving IsZero via (WrappedShow Void) ---- -- 4 ---- class Bifunctor p => Biapplicative p where bipure :: a -> b -> p a b biliftA2 :: (a -> b -> c) -> (a' -> b' -> c') -> p a a' -> p b b' -> p c c' instance Biapplicative (,) where bipure = (,) biliftA2 f f' (a, a') (b, b') = (f a b, f' a' b') newtype WrapBiapp p a b = WrapBiap (p a b) deriving newtype (Bifunctor, Biapplicative, Eq) instance (Biapplicative p, Num a, Num b) => Num (WrapBiapp p a b) where (+) = biliftA2 (+) (+) (-) = biliftA2 (*) (*) (*) = biliftA2 (*) (*) negate = bimap negate negate abs = bimap abs abs signum = bimap signum signum fromInteger n = fromInteger n `bipure` fromInteger n newtype INT2 = INT2 (Int, Int) deriving IsZero via (WrappedNumEq2 (WrapBiapp (,) Int Int)) ---- -- 5 ---- class Monoid a => MonoidNull a where null :: a -> Bool newtype WrpMonNull a = WRM a deriving (Eq, Semigroup, Monoid) instance (Eq a, Monoid a) => MonoidNull (WrpMonNull a) where null :: WrpMonNull a -> Bool null = (== mempty) deriving via (WrpMonNull Any) instance MonoidNull Any deriving via () instance MonoidNull () deriving via Ordering instance MonoidNull Ordering ---- -- 6 ---- -- https://github.com/mikeizbicki/subhask/blob/f53fd8f465747681c88276c7dabe3646fbdf7d50/src/SubHask/Algebra.hs#L635 class Lattice a where sup :: a -> a -> a (.>=) :: a -> a -> Bool (.>) :: a -> a -> Bool newtype WrapOrd a = WrappedOrd a deriving newtype (Eq, Ord) instance Ord a => Lattice (WrapOrd a) where sup = max (.>=) = (>=) (.>) = (>) deriving via [a] instance Ord a => Lattice [a] deriving via (a, b) instance (Ord a, Ord b) => Lattice (a, b) --mkLattice_(Bool) deriving via Bool instance Lattice Bool --mkLattice_(Char) deriving via Char instance Lattice Char --mkLattice_(Int) deriving via Int instance Lattice Int --mkLattice_(Integer) deriving via Integer instance Lattice Integer --mkLattice_(Float) deriving via Float instance Lattice Float --mkLattice_(Double) deriving via Double instance Lattice Double --mkLattice_(Rational) deriving via Rational instance Lattice Rational ---- -- 7 ---- -- https://hackage.haskell.org/package/linear-1.20.7/docs/src/Linear-Affine.html class Functor f => Additive f where zero :: Num a => f a (^+^) :: Num a => f a -> f a -> f a (^+^) = liftU2 (+) (^-^) :: Num a => f a -> f a -> f a x ^-^ y = x ^+^ fmap negate y liftU2 :: (a -> a -> a) -> f a -> f a -> f a instance Additive [] where zero = [] liftU2 f = go where go (x:xs) (y:ys) = f x y : go xs ys go [] ys = ys go xs [] = xs instance Additive Maybe where zero = Nothing liftU2 f (Just a) (Just b) = Just (f a b) liftU2 _ Nothing ys = ys liftU2 _ xs Nothing = xs instance Applicative f => Additive (WrapApplicative f) where zero = pure 0 liftU2 = liftA2 deriving via (WrapApplicative ((->) a)) instance Additive ((->) a) deriving via (WrapApplicative Complex) instance Additive Complex deriving via (WrapApplicative Identity) instance Additive Identity instance Additive ZipList where zero = ZipList [] liftU2 f (ZipList xs) (ZipList ys) = ZipList (liftU2 f xs ys) class Additive (Diff p) => Affine p where type Diff p :: Type -> Type (.-.) :: Num a => p a -> p a -> Diff p a (.+^) :: Num a => p a -> Diff p a -> p a (.-^) :: Num a => p a -> Diff p a -> p a p .-^ v = p .+^ fmap negate v -- #define ADDITIVEC(CTX,T) instance CTX => Affine T where type Diff T = T ; \ -- (.-.) = (^-^) ; {-# INLINE (.-.) #-} ; (.+^) = (^+^) ; {-# INLINE (.+^) #-} ; \ -- (.-^) = (^-^) ; {-# INLINE (.-^) #-} -- #define ADDITIVE(T) ADDITIVEC((), T) newtype WrapAdditive f a = WrappedAdditive (f a) instance Additive f => Affine (WrapAdditive f) where type Diff (WrapAdditive f) = f WrappedAdditive a .-. WrappedAdditive b = a ^-^ b WrappedAdditive a .+^ b = WrappedAdditive (a ^+^ b) WrappedAdditive a .-^ b = WrappedAdditive (a ^-^ b) -- ADDITIVE(((->) a)) deriving via (WrapAdditive ((->) a)) instance Affine ((->) a) -- ADDITIVE([]) deriving via (WrapAdditive []) instance Affine [] -- ADDITIVE(Complex) deriving via (WrapAdditive Complex) instance Affine Complex -- ADDITIVE(Maybe) deriving via (WrapAdditive Maybe) instance Affine Maybe -- ADDITIVE(ZipList) deriving via (WrapAdditive ZipList) instance Affine ZipList -- ADDITIVE(Identity) deriving via (WrapAdditive Identity) instance Affine Identity ---- -- 8 ---- class C2 a b c where c2 :: a -> b -> c instance C2 a b (Const a b) where c2 x _ = Const x newtype Fweemp a = Fweemp a deriving (C2 a b) via (Const a (b :: Type)) ghc-exactprint-0.6.2/tests/examples/ghc86/determ004.hs0000755000000000000000000003261607346545000020602 0ustar0000000000000000{-# LANGUAGE TypeOperators , DataKinds , PolyKinds , TypeFamilies , GADTs , UndecidableInstances , RankNTypes , ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Werror #-} {-# OPTIONS_GHC -O1 -fspec-constr #-} {- With reversed order of allocated uniques the type variables would be in wrong order: *** Core Lint errors : in result of SpecConstr *** determ004.hs:88:12: warning: [in body of lambda with binder m_azbFg :: a_afdP_azbON] @ (a_afdP_azbON :: BOX) is out of scope *** Offending Program *** ... Rec { $s$wsFoldr1_szbtK :: forall (m_azbFg :: a_afdP_azbON) (x_azbOM :: TyFun a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) -> Type) (a_afdP_azbON :: BOX) (ipv_szbwN :: a_afdP_azbON) (ipv_szbwO :: [a_afdP_azbON]). R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) -> Sing ipv_szbwO -> Sing ipv_szbwN -> (forall (t_azbNM :: a_afdP_azbON). Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) [LclId, Arity=4, Str=DmdType ] $s$wsFoldr1_szbtK = \ (@ (m_azbFg :: a_afdP_azbON)) (@ (x_azbOM :: TyFun a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> Type) -> Type)) (@ (a_afdP_azbON :: BOX)) (@ (ipv_szbwN :: a_afdP_azbON)) (@ (ipv_szbwO :: [a_afdP_azbON])) (sg_szbtL :: R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) (sc_szbtM :: Sing ipv_szbwO) (sc_szbtN :: Sing ipv_szbwN) (sc_szbtP :: forall (t_azbNM :: a_afdP_azbON). Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> case (SCons @ a_afdP_azbON @ (ipv_szbwN : ipv_szbwO) @ ipv_szbwO @ ipv_szbwN @~ (_N :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) sc_szbtN sc_szbtM) `cast` (sg_szbtL ; TFCo:R:Sing[]z[0] _N _N :: R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# R:Sing[]z (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) of wild_XD { SNil dt_dzbxX -> (lvl_szbwi @ a_afdP_azbON) `cast` ((Sing (Sym (TFCo:R:Foldr1[2] _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N <'[]>_N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) (Sym dt_dzbxX))_N))_R :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH ds_dzbyu [Dmd=] -> case ds_dzbyu `cast` (TFCo:R:Sing[]z[0] _N _N :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) of wild_Xo { SNil dt_dzbxk -> (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) `cast` ((Sing (Sym (TFCo:R:Foldr1[0] _N _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N <'[m_XzbGe]>_N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R :: Sing m_XzbGe ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> case (sc_szbtP @ m_XzbGe _sX_azbOH) `cast` (TFCo:R:Sing(->)f[0] _N _N _N :: Sing (Apply x_azbOM m_XzbGe) ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) of wild_X3X { SLambda ds_XzbBr [Dmd=] -> (ds_XzbBr @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) (($wsFoldr1_szbuc @ a_afdP_azbON @ x_azbOM @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) sc_szbtP ((SCons @ a_afdP_azbON @ (ipv_XzbyV : ipv_XzbxR) @ ipv_XzbxR @ ipv_XzbyV @~ (_N :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) ipv_szbwL ipv_szbwK) `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym (TFCo:R:Apply[][]:$$i[0] _N _N _N) ; (Apply (Sym (TFCo:R:Applyk(->):$l[0] _N _N)) _N)_N) :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) `cast` ((Sing ((Apply (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) _N)_N ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N ((Apply (TFCo:R:Applyk(->):$l[0] _N _N) _N)_N ; TFCo:R:Apply[][]:$$i[0] _N _N _N) _N))_R :: Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) `cast` ((Sing ((Apply _N (Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N _N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) (Sym (TFCo:R:Apply[][]:$$i[0] _N _N _N) ; (Apply (Sym (TFCo:R:Applyk(->):$l[0] _N _N)) _N)_N))_N))_N ; Sym (TFCo:R:Foldr1[1] _N _N _N _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N _N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R :: Sing (Apply (Apply x_azbOM m_XzbGe) (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) } } } ... -} module List (sFoldr1) where data Proxy t data family Sing (a :: k) data TyFun (a :: Type) (b :: Type) type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2 data instance Sing (f :: TyFun k1 k2 -> Type) = SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) singFun2 :: Proxy f -> SingFunction2 f -> Sing f singFun2 _ f = SLambda (\x -> SLambda (f x)) data (:$$) (j :: a) (i :: TyFun [a] [a]) type instance Apply ((:$$) j) i = (:) j i data (:$) (l :: TyFun a (TyFun [a] [a] -> Type)) type instance Apply (:$) l = (:$$) l data instance Sing (z :: [a]) = z ~ '[] => SNil | forall (m :: a) (n :: [a]). z ~ (:) m n => SCons (Sing m) (Sing n) data ErrorSym0 (t1 :: TyFun k1 k2) type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh type Let1627448493Xs f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec = Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (t_afdZ :: [a_afdP]) = Foldr1 t_afdY t_afdZ data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (l_afe2 :: TyFun [a_afdP] a_afdP) type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (TyFun [a_afdP] a_afdP -> Type)) type instance Apply Foldr1Sym0 l = Foldr1Sym1 l type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (a_afe6 :: [a_afdP]) :: a_afdP where Foldr1 z_afe7 '[x_afe8] = x_afe8 Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" sFoldr1 :: forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type) (y :: [a_afdP]). Sing x -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) sFoldr1 _ (SCons _sX SNil) = undefined sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) = let lambda_afeC :: forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. Sing f_afe9 -> Sing x_afea -> Sing wild_1627448474_afeb -> Sing wild_1627448476_afec -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG = let sXs :: Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) sXs = applySing (applySing (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) wild_1627448476_afeG in applySing (applySing f_afeD x_afeE) (applySing (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) sXs) in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 sFoldr1 _ SNil = undefined ghc-exactprint-0.6.2/tests/examples/ghc86/dynamic-paper.hs0000755000000000000000000002307407346545000021625 0ustar0000000000000000{- This is the code extracted from "A reflection on types", by Simon PJ, Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} {-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, ScopedTypeVariables, GADTs, FlexibleInstances, UndecidableInstances, RebindableSyntax, DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} module Dynamic where import Data.Map ( Map ) import qualified Data.Map as Map import Unsafe.Coerce ( unsafeCoerce ) import Control.Monad ( (<=<) ) import Prelude hiding ( lookup, fromInteger, replicate ) import qualified Prelude import qualified Data.Typeable import qualified Data.Data import Data.Kind lookupMap = Map.lookup insertMap = Map.insert -- let's ignore overloaded numbers fromInteger :: Integer -> Int fromInteger = Prelude.fromInteger insertStore = undefined schema = undefined withTypeable = undefined throw# = undefined toDynamicST = undefined fromDynamicST = undefined extendStore :: Typeable a => STRef s a -> a -> Store -> Store lookupStore :: Typeable a => STRef s a -> Store -> Maybe a type Key = Int data STRef s a = STR Key type Store = Map Key Dynamic extendStore (STR k) v s = insertMap k (toDynamicST v) s lookupStore (STR k) s = case lookupMap k s of Just d -> fromDynamicST d Nothing -> Nothing toDynamicST :: Typeable a => a -> Dynamic fromDynamicST :: Typeable a => Dynamic -> Maybe a eval = undefined data Term data DynamicSilly = DIntSilly Int | DBoolSilly Bool | DCharSilly Char | DPairSilly DynamicSilly DynamicSilly toDynInt :: Int -> DynamicSilly toDynInt = DIntSilly fromDynInt :: DynamicSilly -> Maybe Int fromDynInt (DIntSilly n) = Just n fromDynInt _ = Nothing toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly toDynPair = DPairSilly dynFstSilly :: DynamicSilly -> Maybe DynamicSilly dynFstSilly (DPairSilly x1 x2) = Just x1 dynFstSilly _ = Nothing eval :: Term -> DynamicSilly eqT = undefined instance Typeable (->) instance Typeable Maybe instance Typeable Bool instance Typeable Int instance (Typeable a, Typeable b) => Typeable (a b) instance Typeable (,) instance Eq TypeRepX data Dynamic where Dyn :: TypeRep a -> a -> Dynamic toDynamic :: Typeable a => a -> Dynamic toDynamic x = Dyn typeRep x eqTNoKind = undefined eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) -- Primitive; implemented by compiler data a :***: b where ReflNoKind :: a :***: a fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) = case eqT ra (typeRep :: TypeRep d) of Nothing -> Nothing Just Refl -> Just x fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d fromDynamicMonad (Dyn ra x) = do Refl <- eqT ra (typeRep :: TypeRep d) return x cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b cast x = do Refl <- eqT (typeRep :: TypeRep a) (typeRep :: TypeRep b) return x gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) gcast x = do Refl <- eqT (typeRep :: TypeRep a) (typeRep :: TypeRep b) return x data SameKind :: k -> k -> Type type CheckAppResult = SameKind AppResult AppResultNoKind -- not the most thorough check foo :: AppResult x -> AppResultNoKind x foo (App y z) = AppNoKind y z splitApp :: TypeRep a -> Maybe (AppResult a) splitApp = undefined splitAppNoKind = undefined splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) -- Primitive; implemented by compiler data AppResultNoKind t where AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) dynFstNoKind :: Dynamic -> Maybe Dynamic dynFstNoKind (Dyn rpab x) = do AppNoKind rpa rb <- splitAppNoKind rpab AppNoKind rp ra <- splitAppNoKind rpa Refl <- eqT rp (typeRep :: TypeRep (,)) return (Dyn ra (fst x)) dynApply :: Dynamic -> Dynamic -> Maybe Dynamic dynApply (Dyn rf f) (Dyn rx x) = do App ra rt2 <- splitApp rf App rtc rt1 <- splitApp ra Refl <- eqT rtc (typeRep :: TypeRep (->)) Refl <- eqT rt1 rx return (Dyn rt2 (f x)) data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind class Typeable (a :: k) where typeRep :: TypeRep a data AppResult (t :: k) where App :: forall k1 k (a :: k1 -> k) (b :: k1). TypeRep a -> TypeRep b -> AppResult (a b) dynFst :: Dynamic -> Maybe Dynamic dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| Refl <- eqT rp (typeRep :: TypeRep (,)) -- introduces |p ~ (,)| and |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)| return (Dyn ra (fst x)) eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) data (a :: k1) :~: (b :: k2) where Refl :: forall k (a :: k). a :~: a castDance :: (Typeable a, Typeable b) => a -> Maybe b castDance = castR typeRep typeRep withTypeable :: TypeRep a -> (Typeable a => r) -> r castR :: TypeRep a -> TypeRep b -> a -> Maybe b castR ta tb = withTypeable ta (withTypeable tb castDance) cmpT = undefined compareTypeRep = undefined data TypeRepX where TypeRepX :: TypeRep a -> TypeRepX type TyMapLessTyped = Map TypeRepX Dynamic insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) instance Ord TypeRepX where compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive data TyMap = Empty | Node Dynamic TyMap TyMap lookup :: TypeRep a -> TyMap -> Maybe a lookup tr1 (Node (Dyn tr2 v) left right) = case compareTypeRep tr1 tr2 of LT -> lookup tr1 left EQ -> castR tr2 tr1 v -- know this cast will succeed GT -> lookup tr1 right lookup tr1 Empty = Nothing cmpT :: TypeRep a -> TypeRep b -> OrderingT a b -- definition is primitive data OrderingT a b where LTT :: OrderingT a b EQT :: OrderingT t t GTT :: OrderingT a b data TypeRep (a :: k) where TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) data TyCon = TyCon { tc_module :: Module, tc_name :: String } data Module = Module { mod_pkg :: String, mod_name :: String } tcMaybe :: TyCon tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" , mod_name = "Data.Maybe" } , tc_name = "Maybe" } rt = undefined delta1 :: Dynamic -> Dynamic delta1 dn = case fromDynamic dn of Just f -> f dn Nothing -> dn loop1 = delta1 (toDynamic delta1) data Rid = MkT (forall a. TypeRep a -> a -> a) rt :: TypeRep Rid delta :: forall a. TypeRep a -> a -> a delta ra x = case (eqT ra rt) of Just Refl -> case x of MkT y -> y rt x Nothing -> x loop = delta rt (MkT delta) throw# :: SomeException -> a data SomeException where SomeException :: Exception e => e -> SomeException class (Typeable e, Show e) => Exception e where { } data Company data Salary incS :: Float -> Salary -> Salary incS = undefined -- some impedance matching with SYB instance Data.Data.Data Company instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a mkT f x = case (cast f) of Just g -> g x Nothing -> x data Expr a frontEnd = undefined data DynExp where DE :: TypeRep a -> Expr a -> DynExp frontEnd :: String -> DynExp data TyConOld typeOf = undefined eqTOld = undefined funTcOld = undefined :: TyConOld splitTyConApp = undefined mkTyCon3 = undefined boolTcOld = undefined tupleTc = undefined mkTyConApp = undefined instance Eq TypeRepOld instance Eq TyConOld data TypeRepOld -- Abstract class TypeableOld a where typeRepOld :: proxy a -> TypeRepOld data DynamicOld where DynOld :: TypeRepOld -> a -> DynamicOld data Proxy a = Proxy fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d fromDynamicOld (DynOld trx x) | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) | otherwise = Nothing dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld dynApplyOld (DynOld trf f) (DynOld trx x) = case splitTyConApp trf of (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> Just (DynOld t2 ((unsafeCoerce f) x)) _ -> Nothing data DynamicClosed where DynClosed :: TypeRepClosed a -> a -> DynamicClosed data TypeRepClosed (a :: Type) where TBool :: TypeRepClosed Bool TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) lookupPil = undefined lookupPil :: Typeable a => [Dynamic] -> Maybe a data Dyn1 = Dyn1 Int | DynFun (Dyn1 -> Dyn1) | DynPair (Dyn1, Dyn1) data TypeEnum = IntType | FloatType | BoolType | DateType | StringType data Schema = Object [Schema] | Field TypeEnum | Array Schema schema :: Typeable a => a -> Schema ghc-exactprint-0.6.2/tests/examples/ghc86/dynbrk005.hs0000755000000000000000000000014007346545000020577 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} import TupleN tuple3 x = $(tuple 3) x normal_fn x = tuple3 x ghc-exactprint-0.6.2/tests/examples/ghc86/ffi1.hs0000755000000000000000000000061007346545000017710 0ustar0000000000000000{-# LANGUAGE UnboxedSums, UnboxedTuples, MagicHash #-} module Lib where import GHC.Prim -- Can't unboxed tuples and sums to FFI, we should fail appropriately. foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int ghc-exactprint-0.6.2/tests/examples/ghc86/ghci006.hs0000755000000000000000000000032407346545000020225 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Ghci006 where data Q = forall x . Show x => Q x showQ (Q x) = show x -- associated bug is that at the interpreter command line, -- showQ (Q "foo") crashed the interpreter. ghc-exactprint-0.6.2/tests/examples/ghc86/haddockA026.hs0000755000000000000000000000035307346545000021015 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} module ShouldCompile where test :: (Eq a) => [a] -- ^ doc1 -> forall b . [b] {-^ doc2 -} -> [a] -- ^ doc3 test xs ys = xs ghc-exactprint-0.6.2/tests/examples/ghc86/haddockA027.hs0000755000000000000000000000040407346545000021013 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} module ShouldCompile where test :: [a] -- ^ doc1 -> forall b. (Ord b) => [b] {-^ doc2 -} -> forall c. (Num c) => [c] -- ^ doc3 -> [a] test xs ys zs = xs ghc-exactprint-0.6.2/tests/examples/ghc86/haddockA031.hs0000755000000000000000000000023707346545000021012 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module ShouldCompile where data A = A | {-| comment for B -} forall a. B a a | forall a. Num a => C a {-^ comment for C -} ghc-exactprint-0.6.2/tests/examples/ghc86/haddockC026.hs0000755000000000000000000000035307346545000021017 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} module ShouldCompile where test :: (Eq a) => [a] -- ^ doc1 -> forall b . [b] {-^ doc2 -} -> [a] -- ^ doc3 test xs ys = xs ghc-exactprint-0.6.2/tests/examples/ghc86/haddockC027.hs0000755000000000000000000000124307346545000021017 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} {-# LANGUAGE RankNTypes #-} module ShouldCompile where -- I bet this test is a mistake! From the layout it -- looks as if 'test' takes three args, the latter two -- of higher rank. But the parens around these args are -- missing, so it parses as -- test :: [a] -- -> forall a. Ord a -- => [b] -- -> forall c. Num c -- => [c] -- -> [a] -- -- But maybe that what was intended; I'm not sure -- Anyway it should typecheck! test :: [a] -- ^ doc1 -> forall b. (Ord b) => [b] {-^ doc2 -} -> forall c. (Num c) => [c] -- ^ doc3 -> [a] test xs ys zs = xs ghc-exactprint-0.6.2/tests/examples/ghc86/haddockC031.hs0000755000000000000000000000023707346545000021014 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module ShouldCompile where data A = A | {-| comment for B -} forall a. B a a | forall a. Num a => C a {-^ comment for C -} ghc-exactprint-0.6.2/tests/examples/ghc86/mdo.hs0000755000000000000000000000206407346545000017647 0ustar0000000000000000{-# LANGUAGE RecursiveDo #-} import Control.Monad.Fix import Data.IORef import Prelude hiding (traverse) data N a = N (IORef Bool, N a, a, N a) newNode :: N a -> a -> N a -> IO (N a) newNode b c f = do v <- newIORef False return (N (v, b, c, f)) ll = mdo n0 <- newNode n3 0 n1 n1 <- newNode n0 1 n2 n2 <- newNode n1 2 n3 n3 <- newNode n2 3 n0 return n0 data Dir = F | B deriving Eq traverse :: Dir -> N a -> IO [a] traverse d (N (v, b, i, f)) = do visited <- readIORef v if visited then return [] else do writeIORef v True let next = if d == F then f else b is <- traverse d next return (i:is) l2dll :: [a] -> IO (N a) l2dll (x:xs) = mdo c <- newNode l x f (f, l) <- l2dll' c xs return c l2dll' :: N a -> [a] -> IO (N a, N a) l2dll' p [] = return (p, p) l2dll' p (x:xs) = mdo c <- newNode p x f (f, l) <- l2dll' c xs return (c, l) ghc-exactprint-0.6.2/tests/examples/ghc86/mkGADTVars.hs0000755000000000000000000000030107346545000020763 0ustar0000000000000000{-# LANGUAGE GADTs, TypeInType #-} module GADTVars where import Data.Kind import Data.Proxy data T (k1 :: Type) (k2 :: Type) (a :: k2) (b :: k2) where MkT :: T x1 * (Proxy (y :: x1), z) z ghc-exactprint-0.6.2/tests/examples/ghc86/overloadedrecflds_generics.hs0000755000000000000000000000350707346545000024441 0ustar0000000000000000-- Test that DuplicateRecordFields doesn't affect the metadata -- generated by GHC.Generics or Data.Data -- Based on a Stack Overflow post by bennofs -- (http://stackoverflow.com/questions/24474581) -- licensed under cc by-sa 3.0 {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} import GHC.Generics import Data.Data import Data.Proxy type family FirstSelector (f :: Type -> Type) :: Meta type instance FirstSelector (M1 D x f) = FirstSelector f type instance FirstSelector (M1 C x f) = FirstSelector f type instance FirstSelector (a :*: b) = FirstSelector a type instance FirstSelector (M1 S s f) = s data SelectorProxy (s :: Meta) (f :: Type -> Type) a = SelectorProxy type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () -- Extract the first selector name using GHC.Generics firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) => Proxy a -> String firstSelectorName _ = selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) -- Extract the list of selector names for a constructor using Data.Data selectorNames :: Data a => a -> [String] selectorNames = constrFields . toConstr data T = MkT { foo :: Int } deriving (Data, Generic) data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) main = do -- This should yield "foo", not "$sel:foo:MkT" print (firstSelectorName (Proxy :: Proxy T)) -- Similarly this should yield "foo" print (firstSelectorName (Proxy :: Proxy U)) -- This should yield ["foo"] print (selectorNames (MkT 3)) -- And this should yield ["foo","bar"] print (selectorNames (MkU 3 True)) ghc-exactprint-0.6.2/tests/examples/ghc88/0000755000000000000000000000000007346545000016531 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/ghc88/ClassParens.hs0000755000000000000000000000043607346545000021311 0ustar0000000000000000module ClassParens where class LiftingMonad (trans :: MTrans) where proof :: Monad m :- Monad (trans m) class LiftingMonad2 ((trans :: MTrans)) where proof :: Monad m :- Monad (trans m) data Nat (t :: NatKind) where ZeroNat :: Nat Zero SuccNat :: Nat t -> Nat (Succ t) ghc-exactprint-0.6.2/tests/examples/ghc88/DumpParsedAst.hs0000755000000000000000000000071107346545000021603 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies , TypeApplications, TypeInType #-} module DumpParsedAst where import Data.Kind data Peano = Zero | Succ Peano type family Length (as :: [k]) :: Peano where Length (a : as) = Succ (Length as) Length '[] = Zero -- vis kind app data T f (a :: k) = MkT (f a) type family F1 (a :: k) (f :: k -> Type) :: Type where F1 @Peano a f = T @Peano f a main = putStrLn "hello" ghc-exactprint-0.6.2/tests/examples/ghc88/EmptyCase008.hs0000755000000000000000000000205307346545000021212 0ustar0000000000000000{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-} -- Check interaction between Newtypes and DataFamilies module EmptyCase008 where import Data.Kind (Type) data family DA a newtype Foo3 a = Foo3 (DA a) data instance DA Int = MkDA1 Char | MkDA2 -- Non-exhaustive. Missing: MkDA1 Char, MkDA2 f11 :: Foo3 Int -> () f11 = \case -- Non-exhaustive. (no info about a) f12 :: Foo3 a -> () f12 = \case data instance DA () -- Empty data type -- Exhaustive. f13 :: Foo3 () -> () f13 = \case -- ---------------- data family DB a :: Type -> Type data instance DB Int a where MkDB1 :: DB Int () MkDB2 :: DB Int Bool newtype Foo4 a b = Foo4 (DB a b) -- Non-exhaustive. Missing: Foo4 MkDB1 f14 :: Foo4 Int () -> () f14 = \case -- Exhaustive f15 :: Foo4 Int [a] -> () f15 = \case -- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b) f16 :: Foo4 a b -> () f16 = \case data instance DB Char Bool -- Empty data type -- Exhaustive (empty data type) f17 :: Foo4 Char Bool -> () f17 = \case ghc-exactprint-0.6.2/tests/examples/ghc88/Exp.hs0000755000000000000000000001274007346545000017630 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} module Data.Array.Accelerate.Utility.Lift.Exp ( Unlift, Unlifted, Tuple, unlift, modify, modify2, modify3, modify4, Exp(Exp), expr, atom, unliftPair, unliftTriple, unliftQuadruple, asExp, mapFst, mapSnd, fst3, snd3, thd3, indexCons, ) where import qualified Data.Array.Accelerate.Data.Complex as Complex import qualified Data.Array.Accelerate as A import Data.Complex (Complex((:+))) import Data.Array.Accelerate ((:.)((:.))) import qualified Data.Tuple.HT as Tuple import Data.Tuple.HT (mapTriple) {- | This class simplifies untupling of expressions. If you have a function > g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f) you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'. Here, the 'modify' function helps: > modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f) The 'expr'-pattern tells, how deep the tuple shall be unlifted. This way you can write: > A.map > (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd)) > arr 'modify' is based on 'unlift'. In contrast to 'A.unlift' it does not only unlift one level of tupels, but is guided by an 'expr'-pattern. In the example I have demonstrated, how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not. For the result tuple, 'modify' simply calls 'A.lift'. In contrast to 'A.unlift', 'A.lift' lifts over all tupel levels until it obtains a single 'Exp'. -} class (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where type Unlifted pattern type Tuple pattern unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern modify :: (A.Lift A.Exp a, Unlift pattern) => pattern -> (Unlifted pattern -> a) -> A.Exp (Tuple pattern) -> A.Exp (A.Plain a) modify p f = A.lift . f . unlift p modify2 :: (A.Lift A.Exp a, Unlift patternA, Unlift patternB) => patternA -> patternB -> (Unlifted patternA -> Unlifted patternB -> a) -> A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a) modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b) modify3 :: (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) => patternA -> patternB -> patternC -> (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) -> A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (Tuple patternC) -> A.Exp (A.Plain a) modify3 pa pb pc f a b c = A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) modify4 :: (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) => patternA -> patternB -> patternC -> patternD -> (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> Unlifted patternD -> a) -> A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a) modify4 pa pb pc pd f a b c d = A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d) instance (A.Elt a) => Unlift (Exp a) where type Unlifted (Exp a) = A.Exp a type Tuple (Exp a) = a unlift _ = id data Exp e = Exp expr :: Exp e expr = Exp {-# DEPRECATED atom "use expr instead" #-} -- | for compatibility with accelerate-utility-0.0 atom :: Exp e atom = expr instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb) type Tuple (pa,pb) = (Tuple pa, Tuple pb) unlift (pa,pb) ab = (unlift pa $ A.fst ab, unlift pb $ A.snd ab) instance (Unlift pa, Unlift pb, Unlift pc) => Unlift (pa,pb,pc) where type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc) type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc) unlift (pa,pb,pc) = mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int type Tuple (pa :. int) = Tuple pa :. Int unlift (pa:.pb) ab = (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab) instance (Unlift p) => Unlift (Complex p) where type Unlifted (Complex p) = Complex (Unlifted p) type Tuple (Complex p) = Complex (Tuple p) unlift (preal:+pimag) z = unlift preal (Complex.real z) :+ unlift pimag (Complex.imag z) unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b) unliftPair = A.unlift unliftTriple :: (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c) unliftTriple = A.unlift unliftQuadruple :: (A.Elt a, A.Elt b, A.Elt c, A.Elt d) => A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d) unliftQuadruple = A.unlift asExp :: A.Exp a -> A.Exp a asExp = id mapFst :: (A.Elt a, A.Elt b, A.Elt c) => (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c) mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c) mapSnd :: (A.Elt a, A.Elt b, A.Elt c) => (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c) mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b) fst3 :: (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> A.Exp a fst3 = modify (expr,expr,expr) Tuple.fst3 snd3 :: (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> A.Exp b snd3 = modify (expr,expr,expr) Tuple.snd3 thd3 :: (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> A.Exp c thd3 = modify (expr,expr,expr) Tuple.thd3 indexCons :: (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int) indexCons ix n = A.lift $ ix:.n ghc-exactprint-0.6.2/tests/examples/ghc88/ExplicitForAllRules1.hs0000755000000000000000000000205507346545000023047 0ustar0000000000000000{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeApplications #-} module ExplicitForAllRules1 where import Data.Proxy import Data.Kind -- From Proposal 0007 (w/ fix to "example") {-# RULES "example" forall a b. forall. map @a @b f = f "example2" forall a. forall (x :: a). id x = x #-} {-# NOINLINE f #-} f :: a -> b f = undefined -- More tests {-# RULES "example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = () "example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @() "example5" forall (a :: Type). forall. h @a = id @a "example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x #-} {-# NOINLINE g #-} g :: a -> b -> () g _ _ = () {-# NOINLINE h #-} h :: a -> a h x = x -- Should NOT have a parse error :( {-# RULES "example6" forall a forall. g a forall = () #-} -- Should generate a warning {-# RULES "example7" forall a b. forall (x :: a). id x = x #-} ghc-exactprint-0.6.2/tests/examples/ghc88/Internal.hs0000755000000000000000000002466607346545000020662 0ustar0000000000000000{-# language GADTs, RankNTypes #-} {-# language FlexibleContexts, DefaultSignatures #-} {-# language TypeOperators #-} {-# language LambdaCase #-} {-# language EmptyCase #-} module Hedgehog.Function.Internal where import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Bifunctor (first) import Data.Functor.Contravariant (Contravariant(..)) import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..)) import Data.Functor.Identity (Identity(..)) import Data.Int (Int8, Int16, Int32, Int64) import Data.Maybe (fromJust) import Data.Void (Void, absurd) import Data.Word (Word8, Word64) import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT) import Hedgehog.Internal.Seed (Seed(..)) import Hedgehog.Internal.Tree (Tree(..), Node(..)) import Hedgehog.Internal.Property (PropertyT, forAll) import GHC.Generics import qualified Hedgehog.Internal.Tree as Tree infixr 5 :-> -- | Shrinkable, showable functions -- -- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl). -- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM. data a :-> c where Unit :: c -> () :-> c Nil :: a :-> c Pair :: a :-> b :-> c -> (a, b) :-> c Sum :: a :-> c -> b :-> c -> Either a b :-> c Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c instance Functor ((:->) r) where fmap f (Unit c) = Unit $ f c fmap _ Nil = Nil fmap f (Pair a) = Pair $ fmap (fmap f) a fmap f (Sum a b) = Sum (fmap f a) (fmap f b) fmap f (Map a b c) = Map a b (fmap f c) -- | Tabulate the function table :: a :-> c -> [(a, c)] table (Unit c) = [((), c)] table Nil = [] table (Pair f) = do (a, bc) <- table f (b, c) <- table bc pure ((a, b), c) table (Sum a b) = [(Left x, c) | (x, c) <- table a] ++ [(Right x, c) | (x, c) <- table b] table (Map _ g a) = first g <$> table a class GArg a where gbuild' :: (a x -> c) -> a x :-> c -- | Reify a function whose domain has an instance of 'Generic' gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c gbuild = gvia from to -- | @instance Arg A where@ allows functions which take @A@s to be reified class Arg a where build :: (a -> c) -> a :-> c default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c build = gbuild variant :: Word64 -> GenT m b -> GenT m b variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n}) variant' :: Word64 -> CoGenT m b -> CoGenT m b variant' n (CoGenT f) = CoGenT $ \a -> variant n . f a class GVary a where gvary' :: CoGenT m (a x) instance GVary V1 where gvary' = conquer instance GVary U1 where gvary' = conquer instance (GVary a, GVary b) => GVary (a :+: b) where gvary' = choose (\case; L1 a -> Left a; R1 a -> Right a) (variant' 0 gvary') (variant' 1 gvary') instance (GVary a, GVary b) => GVary (a :*: b) where gvary' = divide (\(a :*: b) -> (a, b)) (variant' 0 gvary') (variant' 1 gvary') instance GVary c => GVary (M1 a b c) where gvary' = contramap unM1 gvary' instance Vary b => GVary (K1 a b) where gvary' = contramap unK1 vary -- | Build a co-generator for a type which has a 'Generic' instance gvary :: (Generic a, GVary (Rep a)) => CoGenT m a gvary = CoGenT $ \a -> applyCoGenT gvary' (from a) -- | 'Vary' provides a canonical co-generator for a type. -- -- While technically there are many possible co-generators for a given type, we don't get any -- benefit from caring. class Vary a where vary :: CoGenT m a default vary :: (Generic a, GVary (Rep a)) => CoGenT m a vary = gvary -- | Build a co-generator for an 'Integral' type varyIntegral :: Integral a => CoGenT m a varyIntegral = CoGenT $ variant . fromIntegral -- | -- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way, -- the generated function will have a varying (but still deterministic) right hand side. -- -- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to -- derive 'Generic' and use the default instance of the 'Vary' type class. -- -- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@ newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b } type CoGen = CoGenT Identity instance Contravariant (CoGenT m) where contramap f (CoGenT g) = CoGenT (g . f) instance Divisible (CoGenT m) where divide f (CoGenT gb) (CoGenT gc) = CoGenT $ \a -> let (b, c) = f a in gc c . gb b conquer = CoGenT $ const id instance Decidable (CoGenT m) where choose f (CoGenT gb) (CoGenT gc) = CoGenT $ \a -> case f a of Left b -> gb b . variant 0 Right c -> gc c . variant 1 lose f = CoGenT $ \a -> absurd (f a) instance (Show a, Show b) => Show (a :-> b) where show = show . table -- | Evaluate a possibly partial function apply' :: a :-> b -> a -> Maybe b apply' (Unit c) () = Just c apply' Nil _ = Nothing apply' (Pair f) (a, b) = do f' <- apply' f a apply' f' b apply' (Sum f _) (Left a) = apply' f a apply' (Sum _ g) (Right a) = apply' g a apply' (Map f _ g) a = apply' g (f a) -- | Evaluate a total function. Unsafe. unsafeApply :: a :-> b -> a -> b unsafeApply f = fromJust . apply' f -- | The type of randomly-generated functions data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b) -- | Extract the root value from a 'Tree'. Unsafe. unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a unsafeFromTree = fmap (maybe (error "empty generator in function") nodeValue) . runMaybeT . runTree instance (Show a, Show b) => Show (Fn a b) where show (Fn b a) = case table a of [] -> "_ -> " ++ show b ta -> showTable ta ++ "_ -> " ++ show b where showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String showTable [] = "\n" showTable (x : xs) = unlines (showCase <$> x : xs) where showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs) -- | Shrink the function shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b] shrinkFn shr (Unit a) = Unit <$> shr a shrinkFn _ Nil = [] shrinkFn shr (Pair f) = (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f shrinkFn shr (Sum a b) = fmap (\case; Sum Nil Nil -> Nil; x -> x) $ [ Sum a Nil | notNil b ] ++ [ Sum Nil b | notNil a ] ++ fmap (`Sum` b) (shrinkFn shr a) ++ fmap (a `Sum`) (shrinkFn shr b) where notNil Nil = False notNil _ = True shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a] shrinkTree (Tree m) = do a <- runMaybeT m case a of Nothing -> pure [] Just (Node _ cs) -> pure cs -- | Evaluate an 'Fn' apply :: Fn a b -> a -> b apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f -- | Generate a function using the user-supplied co-generator fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b) fnWith cg gb = Fn <$> gb <*> genFn (\a -> applyCoGenT cg a gb) where genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b) genFn g = GenT $ \sz sd -> Tree.unfold (shrinkFn $ runIdentity . shrinkTree) . fmap (runGenT sz sd) $ build g -- | Generate a function fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b) fn = fnWith vary -- | Run the function generator to retrieve a function forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b) forAllFn = fmap apply . forAll instance Vary () instance (Vary a, Vary b) => Vary (Either a b) instance (Vary a, Vary b) => Vary (a, b) instance Vary Void instance Vary Bool instance Vary Ordering instance Vary a => Vary (Maybe a) instance Vary a => Vary [a] instance Vary Int8 where; vary = varyIntegral instance Vary Int16 where; vary = varyIntegral instance Vary Int32 where; vary = varyIntegral instance Vary Int64 where; vary = varyIntegral instance Vary Int where; vary = varyIntegral instance Vary Integer where; vary = varyIntegral instance Vary Word8 where; vary = varyIntegral -- | Reify a function via an isomorphism. -- -- If your function's domain has no instance of 'Generic' then you can still reify it using -- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral' -- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element -- is the sign, and the second element is the bit-string. -- -- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@ via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c via a b f = Map a b . build $ f . b instance Arg Void where build _ = Nil instance Arg () where build f = Unit $ f () instance (Arg a, Arg b) => Arg (a, b) where build f = Pair . build $ \a -> build $ \b -> f (a, b) instance (Arg a, Arg b) => Arg (Either a b) where build f = Sum (build $ f . Left) (build $ f . Right) gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c gvia a b f = Map a b . gbuild' $ f . b instance GArg V1 where gbuild' _ = Nil instance GArg U1 where gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1) instance (GArg a, GArg b) => GArg (a :*: b) where gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b) where fromPair (a :*: b) = (a, b) toPair (a, b) = (a :*: b) instance (GArg a, GArg b) => GArg (a :+: b) where gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1) where fromSum = \case; L1 a -> Left a; R1 a -> Right a toSum = either L1 R1 instance GArg c => GArg (M1 a b c) where gbuild' = gvia unM1 M1 instance Arg b => GArg (K1 a b) where gbuild' f = Map unK1 K1 . build $ f . K1 -- | Reify a function on 'Integral's buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c) buildIntegral = via toBits fromBits where toBits :: Integral a => a -> (Bool, [Bool]) toBits n | n >= 0 = (True, go n) | otherwise = (False, go $ -n - 1) where go 0 = [] go m = let (q, r) = quotRem m 2 in (r == 1) : go q fromBits :: Integral a => (Bool, [Bool]) -> a fromBits (pos, bts) | pos = go bts | otherwise = negate $ go bts + 1 where go [] = 0 go (x:xs) = (if x then 1 else 0) + 2 * go xs instance Arg Bool instance Arg Ordering instance Arg a => Arg (Maybe a) instance Arg a => Arg [a] instance Arg Int8 where; build = buildIntegral instance Arg Int16 where; build = buildIntegral instance Arg Int32 where; build = buildIntegral instance Arg Int64 where; build = buildIntegral instance Arg Int where; build = buildIntegral instance Arg Integer where; build = buildIntegral ghc-exactprint-0.6.2/tests/examples/ghc88/StarBinder.hs0000755000000000000000000000024107346545000021122 0ustar0000000000000000{-# LANGUAGE TypeOperators, TypeFamilies #-} {-# OPTIONS -Wno-star-is-type #-} module X (type (X.*)) where type family (*) a b where { (*) a b = Either b a } ghc-exactprint-0.6.2/tests/examples/ghc88/T12045TH1.hs0000755000000000000000000000072207346545000020205 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds , TypeInType, TypeApplications, TypeFamilies #-} module T12045TH1 where import Data.Kind import Language.Haskell.TH hiding (Type) $([d| type family F (a :: k) :: Type where F @Type Int = Bool F @(Type->Type) Maybe = Char |]) $([d| data family D (a :: k) |]) $([d| data instance D @Type a = DBool |]) $([d| data instance D @(Type -> Type) b = DChar |]) ghc-exactprint-0.6.2/tests/examples/ghc88/T12045TH2.hs0000755000000000000000000000224607346545000020211 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds , TypeFamilies, DataKinds #-} module T12045TH2 where import Data.Kind import Language.Haskell.TH hiding (Type) import System.IO type family Foo (a :: k) :: Type where Foo @Type a = Bool type family Baz (a :: k) type instance Baz @(Type->Type->Type) a = Char $( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1]) [] <- reify ''Foo FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2)) [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz runIO $ putStrLn $ pprint foo runIO $ putStrLn $ pprint baz runIO $ putStrLn $ pprint inst runIO $ hFlush stdout return [ ClosedTypeFamilyD (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1] , OpenTypeFamilyD (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2) , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] ) ghc-exactprint-0.6.2/tests/examples/ghc88/T12045a.hs0000755000000000000000000000310607346545000020030 0ustar0000000000000000{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds, RankNTypes, ConstraintKinds, TypeFamilies #-} module T12045a where import Data.Kind import Data.Typeable data T (f :: k -> Type) a = MkT (f a) newtype TType f a= MkTType (T @Type f a) t1 :: TType Maybe Bool t1 = MkTType (MkT (Just True)) t2 :: TType Maybe a t2 = MkTType (MkT Nothing) data Nat = O | S Nat data T1 :: forall k1 k2. k1 -> k2 -> Type where MkT1 :: T1 a b x :: T1 @_ @Nat False n x = MkT1 -- test from trac 12045 type Cat k = k -> k -> Type data FreeCat :: Cat k -> Cat k where Nil :: FreeCat f a a Cons :: f a b -> FreeCat f b c -> FreeCat f a c liftCat :: f a b -> FreeCat f a b liftCat x = Cons x Nil data Node = Unit | N data NatGraph :: Cat Node where One :: NatGraph Unit N Succ :: NatGraph N N one :: (FreeCat @Node NatGraph) Unit N one = liftCat One type Typeable1 = Typeable @(Type -> Type) type Typeable2 = Typeable @(Type -> Type -> Type) type Typeable3 = Typeable @(Cat Bool) type family F a where F Type = Type -> Type F (Type -> Type) = Type F other = other data T2 :: F k -> Type foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type foo a b = undefined data family D (a :: k) data instance D @Type a = DBool data instance D @(Type -> Type) b = DChar class C a where tc :: (D a) -> Int instance C Int where tc DBool = 5 instance C Bool where tc DBool = 6 instance C Maybe where tc DChar = 7 -- Tests from D5229 data P a = MkP type MkPTrue = MkP @Bool type BoolEmpty = '[] @Bool type family F1 (a :: k) :: Type type G2 (a :: Bool) = F1 @Bool a ghc-exactprint-0.6.2/tests/examples/ghc88/T13087.hs0000755000000000000000000000025007346545000017673 0ustar0000000000000000{-# LANGUAGE AlternativeLayoutRule #-} {-# LANGUAGE LambdaCase #-} isOne :: Int -> Bool isOne = \case 1 -> True _ -> False main = return () ghc-exactprint-0.6.2/tests/examples/ghc88/T15365.hs0000755000000000000000000000114007346545000017673 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module T15365 where $([d| type (|||) = Either (&&&) :: Bool -> Bool -> Bool (&&&) = (&&) type role (***) data (***) class (???) instance (???) data family ($$$) data instance ($$$) type family (^^^) type instance (^^^) = Int type family (###) where (###) = Int pattern (:!!!) :: Bool pattern (:!!!) = True |]) ghc-exactprint-0.6.2/tests/examples/ghc88/T4437.hs0000755000000000000000000000441507346545000017621 0ustar0000000000000000-- | A test for ensuring that GHC's supporting language extensions remains in -- sync with Cabal's own extension list. -- -- If you have ended up here due to a test failure, please see -- Note [Adding a language extension] in compiler/main/DynFlags.hs. module Main (main) where import Control.Monad import Data.List import DynFlags import Language.Haskell.Extension main :: IO () main = do let ghcExtensions = map flagSpecName xFlags cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ] ghcOnlyExtensions = ghcExtensions \\ cabalExtensions cabalOnlyExtensions = cabalExtensions \\ ghcExtensions check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions check :: String -> [String] -> [String] -> IO () check title expected got = do let unexpected = got \\ expected missing = expected \\ got showProblems problemType problems = unless (null problems) $ do putStrLn (title ++ ": " ++ problemType) putStrLn "-----" mapM_ putStrLn problems putStrLn "-----" putStrLn "" showProblems "Unexpected flags" unexpected showProblems "Missing flags" missing -- See Note [Adding a language extension] in compiler/main/DynFlags.hs. expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "EmptyDataDeriving", "GeneralisedNewtypeDeriving"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", "ExtensibleRecords", "RestrictedTypeSynonyms", "HereDocuments", "NewQualifiedOperators", "XmlSyntax", "RegularPatterns", "SafeImports", "Safe", "Unsafe", "Trustworthy"] ghc-exactprint-0.6.2/tests/examples/ghc88/TH_recover_warns.hs0000755000000000000000000000043507346545000022344 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} module Bug where import Language.Haskell.TH -- Warnings should be preserved through recover main :: IO () main = putStrLn $(recover (stringE "splice failed") [| let x = "a" in let x = "b" in x |]) ghc-exactprint-0.6.2/tests/examples/ghc88/TH_recursiveDoImport.hs0000755000000000000000000000074307346545000023154 0ustar0000000000000000{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} module TH_recursiveDoImport where import Data.IORef import Language.Haskell.TH data SelfRef = SelfRef (IORef (IORef SelfRef)) recIO :: ExpQ recIO = [e| do rec r1 <- newIORef r2 r2 <- newIORef (SelfRef r1) readIORef r2 |] mdoIO :: ExpQ mdoIO = [e| mdo r1 <- return r2 r2 <- return (const 1 r1) return r1 |] emptyRecIO :: ExpQ emptyRecIO = [e| do rec {} return () |] ghc-exactprint-0.6.2/tests/examples/ghc88/TH_reifyDecl1.hs0000755000000000000000000000340207346545000021451 0ustar0000000000000000-- test reification of data declarations {-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} module TH_reifyDecl1 where import Data.Kind as K import System.IO import Language.Haskell.TH import Text.PrettyPrint.HughesPJ infixl 3 `m1` -- simple data T = A | B -- parametric data R a = C a | D -- recursive data List a = Nil | Cons a (List a) -- infix operator data Tree a = Leaf | Tree a :+: Tree a -- type declaration type IntList = [Int] -- newtype declaration newtype Length = Length Int -- simple class class C1 a where m1 :: a -> Int -- class with instances class C2 a where m2 :: a -> Int instance C2 Int where m2 x = x -- associated types class C3 a where type AT1 a data AT2 a instance C3 Int where type AT1 Int = Bool data AT2 Int = AT2Int -- type family type family TF1 a -- type family, with instances type family TF2 a type instance TF2 Bool = Bool -- data family data family DF1 a -- data family, with instances data family DF2 a data instance DF2 Bool = DBool data family DF3 (a :: k) data instance DF3 @K.Type a = DF3Bool data instance DF3 @(K.Type -> K.Type) b = DF3Char $(return []) test :: () test = $(let display :: Name -> Q () display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } in do { display ''T ; display ''R ; display ''List ; display ''Tree ; display ''IntList ; display ''Length ; display 'Leaf ; display 'm1 ; display ''C1 ; display ''C2 ; display ''C3 ; display ''AT1 ; display ''AT2 ; display ''TF1 ; display ''TF2 ; display ''DF1 ; display ''DF2 ; display ''DF3 ; [| () |] }) ghc-exactprint-0.6.2/tests/examples/ghc88/Utils.hs0000755000000000000000000011373407346545000020201 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.Utils -- Copyright : Isaac Jones, Simon Marlow 2003-2004 -- portions Copyright (c) 2007, Galois Inc. -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- A large and somewhat miscellaneous collection of utility functions used -- throughout the rest of the Cabal lib and in other tools that use the Cabal -- lib like @cabal-install@. It has a very simple set of logging actions. It -- has low level functions for running programs, a bunch of wrappers for -- various directory and file functions that do extra logging. {- All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Isaac Jones nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Distribution.Simple.Utils ( -- * logging and errors die, dieWithLocation, topHandler, warn, notice, info, debug, debugNoWrap, chattyTry, -- * running programs rawSystemExit, rawSystemExitCode, rawSystemExitWithEnv, rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, maybeExit, xargs, findProgramLocation, -- * copying files createDirectoryIfMissingVerbose, copyFileVerbose, copyDirectoryRecursiveVerbose, copyFiles, -- * installing files installOrdinaryFile, installExecutableFile, installOrdinaryFiles, installDirectoryContents, -- * File permissions setFileOrdinary, setFileExecutable, -- * file names currentDir, -- * finding files findFile, findFirstFile, findFileWithExtension, findFileWithExtension', -- * environment variables isInSearchPath, -- * simple file globbing matchFileGlob, matchDirFileGlob, parseFileGlob, FileGlob(..), -- * temp files and dirs withTempFile, withTempDirectory, -- * .cabal and .buildinfo files defaultPackageDesc, findPackageDesc, defaultHookedPackageDesc, findHookedPackageDesc, -- * reading and writing files safely withFileContents, writeFileAtomic, rewriteFile, -- * Unicode fromUTF8, toUTF8, readUTF8File, withUTF8FileContents, writeUTF8File, normaliseLineEndings, -- * generic utils equating, comparing, isInfixOf, intercalate, lowercase, wrapText, wrapLine, ) where import Control.Monad ( when, unless, filterM ) import Control.Concurrent.MVar ( newEmptyMVar, putMVar, takeMVar ) import Data.List ( nub, unfoldr, isPrefixOf, tails, intercalate ) import Data.Char as Char ( toLower, chr, ord ) import Data.Bits ( Bits((.|.), (.&.), shiftL, shiftR) ) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile , findExecutable ) import System.Environment ( getProgName ) import System.Cmd ( rawSystem ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath ( normalise, (), (<.>) , getSearchPath, takeDirectory, splitFileName , splitExtension, splitExtensions, splitDirectories ) import System.Directory ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO ( Handle, openFile, openBinaryFile, openBinaryTempFile , IOMode(ReadMode), hSetBinaryMode , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error ( isDoesNotExistError, isAlreadyExistsError , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) import System.IO.Error ( ioeSetLocation, ioeGetLocation ) import System.IO.Unsafe ( unsafeInterleaveIO ) import qualified Control.Exception as Exception import Distribution.Text ( display ) import Control.Exception (evaluate) import System.Process (runProcess) import Control.Concurrent (forkIO) import System.Process (runInteractiveProcess, waitForProcess) #if __GLASGOW_HASKELL__ >= 702 import System.Process (showCommandForUser) #endif import Distribution.Compat.CopyFile ( copyFile, copyOrdinaryFile, copyExecutableFile , setFileOrdinary, setFileExecutable, setDirOrdinary ) import Distribution.Compat.TempFile ( openTempFile, createTempDirectory ) import Distribution.Compat.Exception ( IOException, throwIOIO, tryIO, catchIO, catchExit ) import Distribution.Verbosity -- ---------------------------------------------------------------------------- -- Exception and logging utils dieWithLocation :: FilePath -> Maybe Int -> String -> IO a dieWithLocation filename lineno msg = ioError . setLocation lineno . flip ioeSetFileName (normalise filename) $ userError msg where setLocation Nothing err = err setLocation (Just n) err = ioeSetLocation err (show n) die :: String -> IO a die msg = ioError (userError msg) topHandler :: IO a -> IO a topHandler prog = catchIO prog handle where handle ioe = do hFlush stdout pname <- getProgName hPutStr stderr (mesage pname) exitWith (ExitFailure 1) where mesage pname = wrapText (pname ++ ": " ++ file ++ detail) file = case ioeGetFileName ioe of Nothing -> "" Just path -> path ++ location ++ ": " location = case ioeGetLocation ioe of l@(n:_) | n >= '0' && n <= '9' -> ':' : l _ -> "" detail = ioeGetErrorString ioe -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. -- warn :: Verbosity -> String -> IO () warn verbosity msg = when (verbosity >= normal) $ do hFlush stdout hPutStr stderr (wrapText ("Warning: " ++ msg)) -- | Useful status messages. -- -- We display these at the 'normal' verbosity level. -- -- This is for the ordinary helpful status messages that users see. Just -- enough information to know that things are working but not floods of detail. -- notice :: Verbosity -> String -> IO () notice verbosity msg = when (verbosity >= normal) $ putStr (wrapText msg) -- | More detail on the operation of some action. -- -- We display these messages when the verbosity level is 'verbose' -- info :: Verbosity -> String -> IO () info verbosity msg = when (verbosity >= verbose) $ putStr (wrapText msg) -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' -- debug :: Verbosity -> String -> IO () debug verbosity msg = when (verbosity >= deafening) $ do putStr (wrapText msg) hFlush stdout -- | A variant of 'debug' that doesn't perform the automatic line -- wrapping. Produces better output in some cases. debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = when (verbosity >= deafening) $ do putStrLn msg hFlush stdout -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. chattyTry :: String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO () chattyTry desc action = catchIO action $ \exception -> putStrLn $ "Error while " ++ desc ++ ": " ++ show exception -- ----------------------------------------------------------------------------- -- Helper functions -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines . map (intercalate "\n" . map unwords . wrapLine 79 . words) . lines -- | Wraps a list of words to a list of lines of words of a particular width. wrapLine :: Int -> [String] -> [[String]] wrapLine width = wrap 0 [] where wrap :: Int -> [String] -> [String] -> [[String]] wrap 0 [] (w:ws) | length w + 1 > width = wrap (length w) [w] ws wrap col line (w:ws) | col + length w + 1 > width = reverse line : wrap 0 [] (w:ws) wrap col line (w:ws) = let col' = col + length w + 1 in wrap col' (w:line) ws wrap _ [] [] = [] wrap _ line [] = [reverse line] -- ----------------------------------------------------------------------------- -- rawSystem variants maybeExit :: IO ExitCode -> IO () maybeExit cmd = do res <- cmd unless (res == ExitSuccess) $ exitWith res printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args | verbosity >= deafening = print (path, args) | verbosity >= verbose = #if __GLASGOW_HASKELL__ >= 702 putStrLn $ showCommandForUser path args #else putStrLn $ unwords (path : args) #endif | otherwise = return () printRawCommandAndArgsAndEnv :: Verbosity -> FilePath -> [String] -> [(String, String)] -> IO () printRawCommandAndArgsAndEnv verbosity path args env | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) print (path, args) | verbosity >= verbose = putStrLn $ unwords (path : args) | otherwise = return () -- Exit with the same exitcode if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () rawSystemExit verbosity path args = do printRawCommandAndArgs verbosity path args hFlush stdout exitcode <- rawSystem path args unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode rawSystemExitCode verbosity path args = do printRawCommandAndArgs verbosity path args hFlush stdout exitcode <- rawSystem path args unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode return exitcode rawSystemExitWithEnv :: Verbosity -> FilePath -> [String] -> [(String, String)] -> IO () rawSystemExitWithEnv verbosity path args env = do printRawCommandAndArgsAndEnv verbosity path args env hFlush stdout ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode -- Closes the passed in handles before returning. rawSystemIOWithEnv :: Verbosity -> FilePath -> [String] -> [(String, String)] -> Maybe Handle -- ^ stdin -> Maybe Handle -- ^ stdout -> Maybe Handle -- ^ stderr -> IO ExitCode rawSystemIOWithEnv verbosity path args env inp out err = do printRawCommandAndArgsAndEnv verbosity path args env hFlush stdout ph <- runProcess path args Nothing (Just env) inp out err exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode return exitcode -- | Run a command and return its output. -- -- The output is assumed to be text in the locale encoding. -- rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = do (output, errors, exitCode) <- rawSystemStdInOut verbosity path args Nothing False when (exitCode /= ExitSuccess) $ die errors return output -- | Run a command and return its output, errors and exit status. Optionally -- also supply some input. Also provides control over whether the binary/text -- mode of the input and output. -- rawSystemStdInOut :: Verbosity -> FilePath -> [String] -> Maybe (String, Bool) -- ^ input text and binary mode -> Bool -- ^ output in binary mode -> IO (String, String, ExitCode) -- ^ output, errors, exit rawSystemStdInOut verbosity path args input outputBinary = do printRawCommandAndArgs verbosity path args Exception.bracket (runInteractiveProcess path args Nothing Nothing) (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) $ \(inh,outh,errh,pid) -> do -- output mode depends on what the caller wants hSetBinaryMode outh outputBinary -- but the errors are always assumed to be text (in the current locale) hSetBinaryMode errh False -- fork off a couple threads to pull on the stderr and stdout -- so if the process writes to stderr we do not block. err <- hGetContents errh out <- hGetContents outh mv <- newEmptyMVar let force str = (evaluate (length str) >> return ()) `Exception.finally` putMVar mv () --TODO: handle exceptions like text decoding. _ <- forkIO $ force out _ <- forkIO $ force err -- push all the input, if any case input of Nothing -> return () Just (inputStr, inputBinary) -> do -- input mode depends on what the caller wants hSetBinaryMode inh inputBinary hPutStr inh inputStr hClose inh --TODO: this probably fails if the process refuses to consume -- or if it closes stdin (eg if it exits) -- wait for both to finish, in either order takeMVar mv takeMVar mv -- wait for the program to terminate exitcode <- waitForProcess pid unless (exitcode == ExitSuccess) $ debug verbosity $ path ++ " returned " ++ show exitcode ++ if null err then "" else " with error message:\n" ++ err ++ case input of Nothing -> "" Just ("", _) -> "" Just (inp, _) -> "\nstdin input:\n" ++ inp return (out, err, exitcode) -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgramLocation verbosity prog = do debug verbosity $ "searching for " ++ prog ++ " in path." res <- findExecutable prog case res of Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) return res -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. -- -- Use it with either of the rawSystem variants above. For example: -- -- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs -- xargs :: Int -> ([String] -> IO ()) -> [String] -> [String] -> IO () xargs maxSize rawSystemFun fixedArgs bigArgs = let fixedArgSize = sum (map length fixedArgs) + length fixedArgs chunkSize = maxSize - fixedArgSize in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) where chunks len = unfoldr $ \s -> if null s then Nothing else Just (chunk [] len s) chunk acc _ [] = (reverse acc,[]) chunk acc len (s:ss) | len' < len = chunk (s:acc) (len-len'-1) ss | otherwise = (reverse acc, s:ss) where len' = length s -- ------------------------------------------------------------ -- * File Utilities -- ------------------------------------------------------------ ---------------- -- Finding files -- | Find a file by looking in a search path. The file path must match exactly. -- findFile :: [FilePath] -- ^search locations -> FilePath -- ^File Name -> IO FilePath findFile searchPath fileName = findFirstFile id [ path fileName | path <- nub searchPath] >>= maybe (die $ fileName ++ " doesn't exist") return -- | Find a file by looking in a search path with one of a list of possible -- file extensions. The file base name should be given and it will be tried -- with each of the extensions in each element of the search path. -- findFileWithExtension :: [String] -> [FilePath] -> FilePath -> IO (Maybe FilePath) findFileWithExtension extensions searchPath baseName = findFirstFile id [ path baseName <.> ext | path <- nub searchPath , ext <- nub extensions ] -- | Like 'findFileWithExtension' but returns which element of the search path -- the file was found in, and the file path relative to that base directory. -- findFileWithExtension' :: [String] -> [FilePath] -> FilePath -> IO (Maybe (FilePath, FilePath)) findFileWithExtension' extensions searchPath baseName = findFirstFile (uncurry ()) [ (path, baseName <.> ext) | path <- nub searchPath , ext <- nub extensions ] findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) findFirstFile file = findFirst where findFirst [] = return Nothing findFirst (x:xs) = do exists <- doesFileExist (file x) if exists then return (Just x) else findFirst xs -- | List all the files in a directory and all subdirectories. -- -- The order places files in sub-directories after all the files in their -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. -- getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive topdir = recurseDirectories [""] where recurseDirectories :: [FilePath] -> IO [FilePath] recurseDirectories [] = return [] recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') where collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' (entry:entries) | ignore entry = collect files dirs' entries collect files dirs' (entry:entries) = do let dirEntry = dir entry isDirectory <- doesDirectoryExist (topdir dirEntry) if isDirectory then collect files (dirEntry:dirs') entries else collect (dirEntry:files) dirs' entries ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False ------------------------ -- Environment variables -- | Is this directory in the system search path? isInSearchPath :: FilePath -> IO Bool isInSearchPath path = fmap (elem path) getSearchPath ---------------- -- File globbing data FileGlob -- | No glob at all, just an ordinary file = NoGlob FilePath -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to -- @FileGlob \"foo\/bar\" \".baz\"@ | FileGlob FilePath String parseFileGlob :: FilePath -> Maybe FileGlob parseFileGlob filepath = case splitExtensions filepath of (filepath', ext) -> case splitFileName filepath' of (dir, "*") | '*' `elem` dir || '*' `elem` ext || null ext -> Nothing | null dir -> Just (FileGlob "." ext) | otherwise -> Just (FileGlob dir ext) _ | '*' `elem` filepath -> Nothing | otherwise -> Just (NoGlob filepath) matchFileGlob :: FilePath -> IO [FilePath] matchFileGlob = matchDirFileGlob "." matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] matchDirFileGlob dir filepath = case parseFileGlob filepath of Nothing -> die $ "invalid file glob '" ++ filepath ++ "'. Wildcards '*' are only allowed in place of the file" ++ " name, not in the directory name or file extension." ++ " If a wildcard is used it must be with an file extension." Just (NoGlob filepath') -> return [filepath'] Just (FileGlob dir' ext) -> do files <- getDirectoryContents (dir dir') case [ dir' file | file <- files , let (name, ext') = splitExtensions file , not (null name) && ext' == ext ] of [] -> die $ "filepath wildcard '" ++ filepath ++ "' does not match any files." matches -> return matches ---------------------------------------- -- Copying and installing files and dirs -- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. -- createDirectoryIfMissingVerbose :: Verbosity -> Bool -- ^ Create its parents too? -> FilePath -> IO () createDirectoryIfMissingVerbose verbosity create_parents path0 | create_parents = createDirs (parents path0) | otherwise = createDirs (take 1 (parents path0)) where parents = reverse . scanl1 () . splitDirectories . normalise createDirs [] = return () createDirs (dir:[]) = createDir dir throwIOIO createDirs (dir:dirs) = createDir dir $ \_ -> do createDirs dirs createDir dir throwIOIO createDir :: FilePath -> (IOException -> IO ()) -> IO () createDir dir notExistHandler = do r <- tryIO $ createDirectoryVerbose verbosity dir case (r :: Either IOException ()) of Right () -> return () Left e | isDoesNotExistError e -> notExistHandler e -- createDirectory (and indeed POSIX mkdir) does not distinguish -- between a dir already existing and a file already existing. So we -- check for it here. Unfortunately there is a slight race condition -- here, but we think it is benign. It could report an exeption in -- the case that the dir did exist but another process deletes the -- directory and creates a file in its place before we can check -- that the directory did indeed exist. | isAlreadyExistsError e -> (do isDir <- doesDirectoryExist dir if isDir then return () else throwIOIO e ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) | otherwise -> throwIOIO e createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = do info verbosity $ "creating " ++ dir createDirectory dir setDirOrdinary dir -- | Copies a file without copying file permissions. The target file is created -- with default permissions. Any existing target file is replaced. -- -- At higher verbosity levels it logs an info message. -- copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyFileVerbose verbosity src dest = do info verbosity ("copy " ++ src ++ " to " ++ dest) copyFile src dest -- | Install an ordinary file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" -- while on Windows it uses the default permissions for the target directory. -- installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () installOrdinaryFile verbosity src dest = do info verbosity ("Installing " ++ src ++ " to " ++ dest) copyOrdinaryFile src dest -- | Install an executable file. This is like a file copy but the permissions -- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" -- while on Windows it uses the default permissions for the target directory. -- installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () installExecutableFile verbosity src dest = do info verbosity ("Installing executable " ++ src ++ " to " ++ dest) copyExecutableFile src dest -- | Copies a bunch of files to a target directory, preserving the directory -- structure in the target location. The target directories are created if they -- do not exist. -- -- The files are identified by a pair of base directory and a path relative to -- that base. It is only the relative part that is preserved in the -- destination. -- -- For example: -- -- > copyFiles normal "dist/src" -- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] -- -- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and -- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". -- -- This operation is not atomic. Any IO failure during the copy (including any -- missing source files) leaves the target in an unknown state so it is best to -- use it with a freshly created directory so that it can be simply deleted if -- anything goes wrong. -- copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () copyFiles verbosity targetDir srcFiles = do -- Create parent directories for everything let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs -- Copy all the files sequence_ [ let src = srcBase srcFile dest = targetDir srcFile in copyFileVerbose verbosity src dest | (srcBase, srcFile) <- srcFiles ] -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. -- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () installOrdinaryFiles verbosity targetDir srcFiles = do -- Create parent directories for everything let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs -- Copy all the files sequence_ [ let src = srcBase srcFile dest = targetDir srcFile in installOrdinaryFile verbosity src dest | (srcBase, srcFile) <- srcFiles ] -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary -- rather than executable files. -- installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () installDirectoryContents verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] --------------------------------- -- Deprecated file copy functions {-# DEPRECATED copyDirectoryRecursiveVerbose "You probably want installDirectoryContents instead" #-} copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () copyDirectoryRecursiveVerbose verbosity srcDir destDir = do info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") srcFiles <- getDirectoryContentsRecursive srcDir copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] --------------------------- -- Temporary files and dirs -- | Use a temporary filename that doesn't already exist. -- withTempFile :: Bool -- ^ Keep temporary files? -> FilePath -- ^ Temp dir to create the file in -> String -- ^ File name template. See 'openTempFile'. -> (FilePath -> Handle -> IO a) -> IO a withTempFile keepTempFiles tmpDir template action = Exception.bracket (openTempFile tmpDir template) (\(name, handle) -> do hClose handle unless keepTempFiles $ removeFile name) (uncurry action) -- | Create and use a temporary directory. -- -- Creates a new temporary directory inside the given directory, making use -- of the template. The temp directory is deleted after use. For example: -- -- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... -- -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. -- withTempDirectory :: Verbosity -> Bool -- ^ Keep temporary files? -> FilePath -> String -> (FilePath -> IO a) -> IO a withTempDirectory _verbosity keepTempFiles targetDir template = Exception.bracket (createTempDirectory targetDir template) (unless keepTempFiles . removeDirectoryRecursive) ----------------------------------- -- Safely reading and writing files -- | Gets the contents of a file, but guarantee that it gets closed. -- -- The file is read lazily but if it is not fully consumed by the action then -- the remaining input is truncated and the file is closed. -- withFileContents :: FilePath -> (String -> IO a) -> IO a withFileContents name action = Exception.bracket (openFile name ReadMode) hClose (\hnd -> hGetContents hnd >>= action) -- | Writes a file atomically. -- -- The file is either written sucessfully or an IO exception is raised and -- the original file is left unchanged. -- -- On windows it is not possible to delete a file that is open by a process. -- This case will give an IO exception but the atomic property is not affected. -- writeFileAtomic :: FilePath -> BS.ByteString -> IO () writeFileAtomic targetPath content = do let (targetDir, targetFile) = splitFileName targetPath Exception.bracketOnError (openBinaryTempFile targetDir $ targetFile <.> "tmp") (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) (\(tmpPath, handle) -> do BS.hPut handle content hClose handle renameFile tmpPath targetPath) -- | Write a file but only if it would have new content. If we would be writing -- the same as the existing content then leave the file as is so that we do not -- update the file's modification time. -- rewriteFile :: FilePath -> String -> IO () rewriteFile path newContent = flip catchIO mightNotExist $ do existingContent <- readFile path _ <- evaluate (length existingContent) unless (existingContent == newContent) $ writeFileAtomic path (BS.Char8.pack newContent) where mightNotExist e | isDoesNotExistError e = writeFileAtomic path (BS.Char8.pack newContent) | otherwise = ioError e -- | The path name that represents the current directory. -- In Unix, it's @\".\"@, but this is system-specific. -- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) currentDir :: FilePath currentDir = "." -- ------------------------------------------------------------ -- * Finding the description file -- ------------------------------------------------------------ -- |Package description file (/pkgname/@.cabal@) defaultPackageDesc :: Verbosity -> IO FilePath defaultPackageDesc _verbosity = findPackageDesc currentDir -- |Find a package description file in the given directory. Looks for -- @.cabal@ files. findPackageDesc :: FilePath -- ^Where to look -> IO FilePath -- ^.cabal findPackageDesc dir = do files <- getDirectoryContents dir -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal -- file we filter to exclude dirs and null base file names: cabalFiles <- filterM doesFileExist [ dir file | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == ".cabal" ] case cabalFiles of [] -> noDesc [cabalFile] -> return cabalFile multiple -> multiDesc multiple where noDesc :: IO a noDesc = die $ "No cabal file found.\n" ++ "Please create a package description file .cabal" multiDesc :: [String] -> IO a multiDesc l = die $ "Multiple cabal files found.\n" ++ "Please use only one of: " ++ intercalate ", " l -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) defaultHookedPackageDesc = findHookedPackageDesc currentDir -- |Find auxiliary package information in the given directory. -- Looks for @.buildinfo@ files. findHookedPackageDesc :: FilePath -- ^Directory to search -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present findHookedPackageDesc dir = do files <- getDirectoryContents dir buildInfoFiles <- filterM doesFileExist [ dir file | file <- files , let (name, ext) = splitExtension file , not (null name) && ext == buildInfoExt ] case buildInfoFiles of [] -> return Nothing [f] -> return (Just f) _ -> die ("Multiple files with extension " ++ buildInfoExt) buildInfoExt :: String buildInfoExt = ".buildinfo" -- ------------------------------------------------------------ -- * Unicode stuff -- ------------------------------------------------------------ -- This is a modification of the UTF8 code from gtk2hs and the -- utf8-string package. fromUTF8 :: String -> String fromUTF8 [] = [] fromUTF8 (c:cs) | c <= '\x7F' = c : fromUTF8 cs | c <= '\xBF' = replacementChar : fromUTF8 cs | c <= '\xDF' = twoBytes c cs | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) | otherwise = replacementChar : fromUTF8 cs where twoBytes c0 (c1:cs') | ord c1 .&. 0xC0 == 0x80 = let d = ((ord c0 .&. 0x1F) `shiftL` 6) .|. (ord c1 .&. 0x3F) in if d >= 0x80 then chr d : fromUTF8 cs' else replacementChar : fromUTF8 cs' twoBytes _ cs' = replacementChar : fromUTF8 cs' moreBytes :: Int -> Int -> [Char] -> Int -> [Char] moreBytes 1 overlong cs' acc | overlong <= acc && acc <= 0x10FFFF && (acc < 0xD800 || 0xDFFF < acc) && (acc < 0xFFFE || 0xFFFF < acc) = chr acc : fromUTF8 cs' | otherwise = replacementChar : fromUTF8 cs' moreBytes byteCount overlong (cn:cs') acc | ord cn .&. 0xC0 == 0x80 = moreBytes (byteCount-1) overlong cs' ((acc `shiftL` 6) .|. ord cn .&. 0x3F) moreBytes _ _ cs' _ = replacementChar : fromUTF8 cs' replacementChar = '\xfffd' toUTF8 :: String -> String toUTF8 [] = [] toUTF8 (c:cs) | c <= '\x07F' = c : toUTF8 cs | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs | otherwise = chr (0xf0 .|. (w `shiftR` 18)) : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) : chr (0x80 .|. (w .&. 0x3F)) : toUTF8 cs where w = ord c -- | Ignore a Unicode byte order mark (BOM) at the beginning of the input -- ignoreBOM :: String -> String ignoreBOM ('\xFEFF':string) = string ignoreBOM string = string -- | Reads a UTF8 encoded text file as a Unicode String -- -- Reads lazily using ordinary 'readFile'. -- readUTF8File :: FilePath -> IO String readUTF8File f = fmap (ignoreBOM . fromUTF8) . hGetContents =<< openBinaryFile f ReadMode -- | Reads a UTF8 encoded text file as a Unicode String -- -- Same behaviour as 'withFileContents'. -- withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a withUTF8FileContents name action = Exception.bracket (openBinaryFile name ReadMode) hClose (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) -- | Writes a Unicode String as a UTF8 encoded text file. -- -- Uses 'writeFileAtomic', so provides the same guarantees. -- writeUTF8File :: FilePath -> String -> IO () writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8 -- | Fix different systems silly line ending conventions normaliseLineEndings :: String -> String normaliseLineEndings [] = [] normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx normaliseLineEndings ( c :s) = c : normaliseLineEndings s -- ------------------------------------------------------------ -- * Common utils -- ------------------------------------------------------------ equating :: Eq a => (b -> a) -> b -> b -> Bool equating p x y = p x == p y comparing :: Ord a => (b -> a) -> b -> b -> Ordering comparing p x y = p x `compare` p y isInfixOf :: String -> String -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) lowercase :: String -> String lowercase = map Char.toLower ghc-exactprint-0.6.2/tests/examples/ghc88/hie010.hs0000755000000000000000000000077707346545000020071 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} module MoreExplicitForalls where import Data.Proxy data family F1 a data instance forall (x :: Bool). F1 (Proxy x) = MkF class C a where type F2 a b instance forall a. C [a] where type forall b. F2 [a] b = Int type family G a b where forall x y. G [x] (Proxy y) = Double forall z. G z z = Bool ghc-exactprint-0.6.2/tests/examples/pre-ghc86/0000755000000000000000000000000007346545000017313 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/pre-ghc86/BadTelescope.hs0000755000000000000000000000022007346545000022176 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module BadTelescope where import Data.Kind data SameKind :: k -> k -> * data X a k (b :: k) (c :: SameKind a b) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/BadTelescope2.hs0000755000000000000000000000043407346545000022267 0ustar0000000000000000{-# LANGUAGE TypeInType, ExplicitForAll #-} module BadTelescope2 where import Data.Kind import Data.Proxy data SameKind :: k -> k -> * foo :: forall a k (b :: k). SameKind a b foo = undefined bar :: forall a (c :: Proxy b) (d :: Proxy a). Proxy c -> SameKind b d bar = undefined ghc-exactprint-0.6.2/tests/examples/pre-ghc86/BadTelescope3.hs0000755000000000000000000000023407346545000022266 0ustar0000000000000000{-# LANGUAGE TypeInType, ExplicitForAll #-} module BadTelescope3 where import Data.Kind data SameKind :: k -> k -> * type S a k (b :: k) = SameKind a b ghc-exactprint-0.6.2/tests/examples/pre-ghc86/BadTelescope4.hs0000755000000000000000000000057307346545000022275 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, TypeInType #-} module BadTelescope4 where import Data.Proxy import Data.Kind data SameKind :: k -> k -> * data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d) data Borked a (b :: k) = forall (c :: k). B (Proxy c) -- this last one is OK. But there was a bug involving renaming -- that failed here, so the test case remains. ghc-exactprint-0.6.2/tests/examples/pre-ghc86/Dep3.hs0000755000000000000000000000067507346545000020455 0ustar0000000000000000{-# LANGUAGE TypeFamilies, TypeInType, GADTs #-} module Dep3 where import Data.Kind import GHC.Exts ( Constraint ) type Star1 = * data Id1 (a :: Star1) where Id1 :: a -> Id1 a data Id1' :: Star1 -> * where Id1' :: a -> Id1' a type family Star2 x where Star2 x = * data Id2a (a :: Star2 Constraint) = Id2a a data Id2 (a :: Star2 Constraint) where Id2 :: a -> Id2 a data Id2' :: Star2 Constraint -> * where Id2' :: a -> Id2' a ghc-exactprint-0.6.2/tests/examples/pre-ghc86/KindEqualities2.hs0000755000000000000000000000221407346545000022646 0ustar0000000000000000{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll, TemplateHaskell, UndecidableInstances, ScopedTypeVariables, TypeInType #-} module KindEqualities2 where import Data.Kind import GHC.Exts ( Any ) data Kind = Star | Arr Kind Kind data Ty :: Kind -> * where TInt :: Ty Star TBool :: Ty Star TMaybe :: Ty (Arr Star Star) TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2 data TyRep (k :: Kind) (t :: Ty k) where TyInt :: TyRep Star TInt TyBool :: TyRep Star TBool TyMaybe :: TyRep (Arr Star Star) TMaybe TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b) type family IK (k :: Kind) type instance IK Star = * type instance IK (Arr k1 k2) = IK k1 -> IK k2 $(return []) -- necessary because the following instances depend on the -- previous ones. type family I (t :: Ty k) :: IK k type instance I TInt = Int type instance I TBool = Bool type instance I TMaybe = Maybe type instance I (TApp a b) = (I a) (I b) zero :: forall (a :: Ty 'Star). TyRep Star a -> I a zero TyInt = 0 zero TyBool = False zero (TyApp TyMaybe TyInt) = Nothing main = print $ zero (TyApp TyMaybe TyInt) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/LiftedConstructors.hs0000755000000000000000000000135607346545000023517 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/pre-ghc86/RAE_T32a.hs0000755000000000000000000000223707346545000021056 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, PolyKinds, TypeFamilies, GADTs, TypeInType #-} module RAE_T32a where import Data.Kind data family Sing (k :: *) :: k -> * data TyArr' (a :: *) (b :: *) :: * type TyArr (a :: *) (b :: *) = TyArr' a b -> * type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2 data TyPi' (a :: *) (b :: TyArr a *) :: * type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> * type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b $(return []) data MkStar (p :: *) (x :: TyArr' p *) type instance MkStar p @@ x = * $(return []) data Sigma (p :: *) (r :: TyPi p (MkStar p)) :: * where Sigma :: forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a). Sing * p -> Sing (TyPi p (MkStar p)) r -> Sing p a -> Sing (r @@@ a) b -> Sigma p r $(return []) data instance Sing Sigma (Sigma p r) x where SSigma :: forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a) (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) r) (sa :: Sing p a) (sb :: Sing (r @@@ a) b). Sing (Sing (r @@@ a) b) sb -> Sing (Sigma p r) ('Sigma sp sr sa sb) -- I (RAE) believe this last definition is ill-typed. ghc-exactprint-0.6.2/tests/examples/pre-ghc86/RAE_T32b.hs0000755000000000000000000000154307346545000021056 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, DataKinds, PolyKinds, RankNTypes, TypeOperators, TypeInType #-} module RAE_T32b where import Data.Kind data family Sing (k :: *) :: k -> * data TyArr (a :: *) (b :: *) :: * type family (a :: TyArr k1 k2 -> *) @@ (b :: k1) :: k2 $(return []) data Sigma (p :: *) (r :: TyArr p * -> *) :: * where Sigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a). Sing * p -> Sing (TyArr p * -> *) r -> Sing p a -> Sing (r @@ a) b -> Sigma p r $(return []) data instance Sing (Sigma p r) (x :: Sigma p r) :: * where SSigma :: forall (p :: *) (r :: TyArr p * -> *) (a :: p) (b :: r @@ a) (sp :: Sing * p) (sr :: Sing (TyArr p * -> *) r) (sa :: Sing p a) (sb :: Sing (r @@ a) b). Sing (Sing (r @@ a) b) sb -> Sing (Sigma p r) ('Sigma sp sr sa sb) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/Rae31.hs0000755000000000000000000000150007346545000020521 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeOperators, PolyKinds, DataKinds, TypeFamilies, TypeInType #-} module A where import Data.Kind data family Sing (k :: *) :: k -> * type Sing' (x :: k) = Sing k x data TyFun' (a :: *) (b :: *) :: * type TyFun (a :: *) (b :: *) = TyFun' a b -> * type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2 data TyPi' (a :: *) (b :: TyFun a *) :: * type TyPi (a :: *) (b :: TyFun a *) = TyPi' a b -> * type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b $(return []) data A (a :: *) (b :: a) (c :: TyFun' a *) -- A :: forall a -> a -> a ~> * type instance (@@) (A a b) c = * $(return []) data B (a :: *) (b :: TyFun' a *) -- B :: forall a -> a ~> * type instance (@@) (B a) b = TyPi a (A a b) $(return []) data C (a :: *) (b :: TyPi a (B a)) (c :: a) (d :: a) (e :: TyFun' (b @@@ c @@@ d) *) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/RaeBlogPost.hs0000755000000000000000000000272307346545000022037 0ustar0000000000000000{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies, TypeInType #-} {-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} module RaeBlogPost where import Data.Kind -- a Proxy type with an explicit kind data Proxy k (a :: k) = P prox :: Proxy * Bool prox = P prox2 :: Proxy Bool 'True prox2 = P -- implicit kinds still work data A data B :: A -> * data C :: B a -> * data D :: C b -> * data E :: D c -> * -- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> * -- a kind-indexed GADT data TypeRep (a :: k) where TInt :: TypeRep Int TMaybe :: TypeRep Maybe TApp :: TypeRep a -> TypeRep b -> TypeRep (a b) zero :: TypeRep a -> a zero TInt = 0 zero (TApp TMaybe _) = Nothing data Nat = Zero | Succ Nat type family a + b where 'Zero + b = b ('Succ a) + b = 'Succ (a + b) data Vec :: * -> Nat -> * where Nil :: Vec a 'Zero (:>) :: a -> Vec a n -> Vec a ('Succ n) infixr 5 :> -- promoted GADT, and using + as a "kind family": type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where 'Nil ++ y = y (h ':> t) ++ y = h ':> (t ++ y) -- datatype that mentions * data U = Star (*) | Bool Bool -- kind synonym type Monadish = * -> * class MonadTrans (t :: Monadish -> Monadish) where lift :: Monad m => m a -> t m a data Free :: Monadish where Return :: a -> Free a Bind :: Free a -> (a -> Free b) -> Free b -- yes, * really does have type *. type Star = (* :: (* :: (* :: *))) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/RenamingStar.hs0000755000000000000000000000010607346545000022241 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module RenamingStar where data Foo :: * ghc-exactprint-0.6.2/tests/examples/pre-ghc86/SlidingTypeSyn.hs0000755000000000000000000000062307346545000022600 0ustar0000000000000000{-# 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 ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T10134a.hs0000755000000000000000000000036607346545000020614 0ustar0000000000000000{-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} module T10134a where import GHC.TypeLits data Vec :: Nat -> * -> * where Nil :: Vec 0 a (:>) :: a -> Vec n a -> Vec (n + 1) a ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T10321.hs0000755000000000000000000000042207346545000020442 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} module T10321 where import GHC.TypeLits data Vec :: Nat -> * -> * where Nil :: Vec 0 a (:>) :: a -> Vec n a -> Vec (n + 1) a infixr 5 :> ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T10689a.hs0000755000000000000000000001002607346545000020625 0ustar0000000000000000{-# LANGUAGE TypeOperators , DataKinds , PolyKinds , TypeFamilies , GADTs , UndecidableInstances , RankNTypes , ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Werror #-} {-# OPTIONS_GHC -O1 -fspec-constr #-} {- ghc-stage2: panic! (the 'impossible' happened) (GHC version 7.11.20150723 for x86_64-unknown-linux): Template variable unbound in rewrite rule -} module List (sFoldr1) where data Proxy t data family Sing (a :: k) data TyFun (a :: *) (b :: *) type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 data instance Sing (f :: TyFun k1 k2 -> *) = SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) singFun2 :: Proxy f -> SingFunction2 f -> Sing f singFun2 _ f = SLambda (\x -> SLambda (f x)) data (:$$) (j :: a) (i :: TyFun [a] [a]) type instance Apply ((:$$) j) i = (:) j i data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) type instance Apply (:$) l = (:$$) l data instance Sing (z :: [a]) = z ~ '[] => SNil | forall (m :: a) (n :: [a]). z ~ (:) m n => SCons (Sing m) (Sing n) data ErrorSym0 (t1 :: TyFun k1 k2) type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh type Let1627448493Xs f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec = Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (t_afdZ :: [a_afdP]) = Foldr1 t_afdY t_afdZ data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (l_afe2 :: TyFun [a_afdP] a_afdP) type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (TyFun [a_afdP] a_afdP -> *)) type instance Apply Foldr1Sym0 l = Foldr1Sym1 l type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (a_afe6 :: [a_afdP]) :: a_afdP where Foldr1 z_afe7 '[x_afe8] = x_afe8 Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" sFoldr1 :: forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (y :: [a_afdP]). Sing x -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) sFoldr1 _ (SCons _sX SNil) = undefined sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) = let lambda_afeC :: forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. Sing f_afe9 -> Sing x_afea -> Sing wild_1627448474_afeb -> Sing wild_1627448476_afec -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG = let sXs :: Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) sXs = applySing (applySing (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) wild_1627448476_afeG in applySing (applySing f_afeD x_afeE) (applySing (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) sXs) in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 sFoldr1 _ SNil = undefined ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T10934.hs0000755000000000000000000000171007346545000020455 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables , DataKinds , GADTs , RankNTypes , TypeOperators , PolyKinds -- Comment out PolyKinds and the bug goes away. #-} {-# OPTIONS_GHC -O #-} -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it module KeyValue where data AccValidation err a = AccFailure err | AccSuccess a data KeyValueError = MissingValue type WithKeyValueError = AccValidation [KeyValueError] missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs missing = rpure missingField where missingField :: forall x. (WithKeyValueError :. f) x missingField = Compose $ AccFailure [MissingValue] data Rec :: (u -> *) -> [u] -> * where RNil :: Rec f '[] (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs) newtype Compose (f :: l -> *) (g :: k -> l) (x :: k) = Compose { getCompose :: f (g x) } type (:.) f g = Compose f g class RecApplicative rs where rpure :: (forall x. f x) -> Rec f rs ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T11142.hs0000755000000000000000000000026707346545000020453 0ustar0000000000000000{-# LANGUAGE TypeInType, RankNTypes #-} module T11142 where import Data.Kind data SameKind :: k -> k -> * foo :: forall b. (forall k (a :: k). SameKind a b) -> () foo = undefined ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T3927b.hs0000755000000000000000000000424407346545000020550 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-} module T3927b where import Data.Proxy import GHC.Exts data Message data SocketType = Dealer | Push | Pull data SocketOperation = Read | Write type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where Restrict a (a ': as) = () Restrict x (a ': as) = Restrict x as Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!") type family Implements (t :: SocketType) :: [SocketOperation] where Implements Dealer = ['Read, Write] Implements Push = '[Write] Implements Pull = '[ 'Read] data SockOp :: SocketType -> SocketOperation -> * where SRead :: SockOp sock 'Read SWrite :: SockOp sock Write data Socket :: SocketType -> * where Socket :: proxy sock -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op) -> Socket sock type family Operation (op :: SocketOperation) :: * where Operation 'Read = IO Message Operation Write = Message -> IO () class Restrict 'Read (Implements t) => Readable t where readSocket :: Socket t -> Operation 'Read readSocket (Socket _ f) = f (SRead :: SockOp t 'Read) instance Readable Dealer type family Writable (t :: SocketType) :: Constraint where Writable Dealer = () Writable Push = () dealer :: Socket Dealer dealer = Socket (Proxy :: Proxy Dealer) f where f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op f SRead = undefined f SWrite = undefined push :: Socket Push push = Socket (Proxy :: Proxy Push) f where f :: Restrict op (Implements Push) => SockOp Push op -> Operation op f SWrite = undefined pull :: Socket Pull pull = Socket (Proxy :: Proxy Pull) f where f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op f SRead = undefined foo :: IO Message foo = readSocket dealer ghc-exactprint-0.6.2/tests/examples/pre-ghc86/T9632.hs0000755000000000000000000000020307346545000020374 0ustar0000000000000000{-# LANGUAGE TypeInType #-} module T9632 where import Data.Kind data B = T | F data P :: B -> * type B' = B data P' :: B' -> * ghc-exactprint-0.6.2/tests/examples/pre-ghc86/TensorTests.hs0000755000000000000000000000207707346545000022155 0ustar0000000000000000{-# LANGUAGE ConstraintKinds, FlexibleContexts, DataKinds, NoImplicitPrelude, RebindableSyntax, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module TensorTests (tensorTests) where import Apply.Cyc import Tests import Utils import TestTypes import Crypto.Lol import Crypto.Lol.CRTrans import Crypto.Lol.Cyclotomic.Tensor import Crypto.Lol.Types import Control.Applicative import Data.Maybe import Data.Singletons import Data.Promotion.Prelude.Eq import Data.Singletons.TypeRepStar () import qualified Test.Framework as TF type TMRParams = ( '( , ,) <$> Tensors <*> Tensors) <*> MRCombos type TMRParams = ( '(,) <$> Tensors) <*> MRCombos tmrParams :: Proxy TMRParams tmrParams = Proxy --type ExtParams = ( '(,) <$> Tensors) <*> MRExtCombos type TrEmParams = ( '(,) <$> Tensors) <*> MM'RCombos tremParams :: Proxy TrEmParams tremParams = Proxy type NormParams = ( '(,) <$> '[RT]) <*> (Filter Liftable MRCombos) data Liftable :: TyFun (Factored, *) Bool -> * type instance Apply Liftable '(m,zq) = Int64 :== (LiftOf zq) ghc-exactprint-0.6.2/tests/examples/pre-ghc86/UnicodeSyntax.hs0000755000000000000000000001331507346545000022452 0ustar0000000000000000{-# 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) } -- from ghc-prim -- | A backward-compatible (pre-GHC 8.0) synonym for 'Type' type * = TYPE 'PtrRepLifted -- | A unicode backward-compatible (pre-GHC 8.0) synonym for 'Type' type ★ = TYPE 'PtrRepLifted ghc-exactprint-0.6.2/tests/examples/pre-ghc86/Vect.hs0000755000000000000000000000263107346545000020555 0ustar0000000000000000{-# LANGUAGE ParallelArrays #-} {-# OPTIONS_GHC -fvectorise #-} {-# LANGUAGE UnboxedTuples #-} module Vect where -- import Data.Array.Parallel {-# VECTORISe isFive = blah #-} {-# NoVECTORISE isEq #-} {-# VECTORISE SCALAR type Int #-} {-# VECTORISE type Char #-} {-# VECTORISE type ( ) #-} {-# VECTORISE type (# #) #-} {-# VECTORISE SCALAR type Integer = Int #-} {-# VECTORISE type Bool = String #-} {-# Vectorise class Eq #-} blah = 5 data MyBool = MyTrue | MyFalse class Eq a => Cmp a where cmp :: a -> a -> Bool -- FIXME: -- instance Cmp Int where -- cmp = (==) -- isFive :: (Eq a, Num a) => a -> Bool isFive :: Int -> Bool isFive x = x == 5 isEq :: Eq a => a -> Bool isEq x = x == x fiveEq :: Int -> Bool fiveEq x = isFive x && isEq x cmpArrs :: PArray Int -> PArray Int -> Bool {-# NOINLINE cmpArrs #-} cmpArrs v w = cmpArrs' (fromPArrayP v) (fromPArrayP w) cmpArrs' :: [:Int:] -> [:Int:] -> Bool cmpArrs' xs ys = andP [:x == y | x <- xs | y <- ys:] isFives :: PArray Int -> Bool {-# NOINLINE isFives #-} isFives xs = isFives' (fromPArrayP xs) isFives' :: [:Int:] -> Bool isFives' xs = andP (mapP isFive xs) isEqs :: PArray Int -> Bool {-# NOINLINE isEqs #-} isEqs xs = isEqs' (fromPArrayP xs) isEqs' :: [:Int:] -> Bool isEqs' xs = undefined -- andP (mapP isEq xs) -- fudge for compiler fromPArrayP = undefined andP = undefined mapP = undefined data PArray a = PArray a ghc-exactprint-0.6.2/tests/examples/pre-ghc86/Webhook.hs0000755000000000000000000001505607346545000021257 0ustar0000000000000000{-| Module : Servant.GitHub.Webhook Description : Easily write safe GitHub webhook handlers with Servant Copyright : (c) Jacob Thomas Errington, 2016 License : MIT Maintainer : servant-github-webhook@mail.jerrington.me Stability : experimental The GitHub webhook machinery will attach three headers to the HTTP requests that it fires: @X-Github-Event@, @X-Hub-Signature@, and @X-Github-Delivery@. The former two headers correspond with the 'GitHubEvent' and 'GitHubSignedReqBody''' routing combinators. This library ignores the @X-Github-Delivery@ header; if you would like to access its value, then use the builtin 'Header' combinator from Servant. Usage of the library is straightforward: protect routes with the 'GitHubEvent' combinator to ensure that the route is only reached for specific 'RepoWebhookEvent's, and replace any 'ReqBody' combinators you would write under that route with 'GitHubSignedReqBody'. It is advised to always include a 'GitHubSignedReqBody''', as this is the only way you can be sure that it is GitHub who is sending the request, and not a malicious user. If you don't care about the request body, then simply use Aeson\'s 'Object' type as the deserialization target -- @GitHubSignedReqBody' key '[JSON] Object@ -- and ignore the @Object@ in the handler. The 'GitHubSignedReqBody''' combinator makes use of the Servant 'Context' in order to extract the signing key. This is the same key that must be entered in the configuration of the webhook on GitHub. See 'GitHubKey'' for more details. In order to support multiple keys on a per-route basis, the basic combinator @GitHubSignedReqBody''@ takes as a type parameter as a key index. To use this, create a datatype, e.g. @KeyIndex@ whose constructors identify the different keys you will be using. Generally, this means one constructor per repository. Use the @DataKinds@ extension to promote this datatype to a kind, and write an instance of 'Reflect' for each promoted constructor of your datatype. Finally, create a 'Context' containing 'GitHubKey'' whose wrapped function's domain is the datatype you've built up. Thus, your function can determine which key to retrieve. -} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- GHC 8 seems to have improved its decidability check for type family -- instances and class instances. In particular, without UndecidableInstances -- enabled, the Demote' instance for lists, which we need, will not compile. -- Similarly, the Reflect instance for Symbol, which just requires KnownSymbol, -- won't compile on GHC < 8 because the instance head is no smaller than the -- instance head. #if __GLASGOW_HASKELL__ < 800 {-# LANGUAGE UndecidableInstances #-} #endif module Servant.GitHub.Webhook ( -- * Servant combinators GitHubSignedReqBody'' , GitHubSignedReqBody' , GitHubSignedReqBody , GitHubEvent -- ** Security , GitHubKey'(..) , GitHubKey , gitHubKey -- * Reexports -- -- | We reexport a few datatypes that are typically needed to use the -- library. , RepoWebhookEvent(..) , KProxy(..) -- * Implementation details -- ** Type-level programming machinery , Demote , Demote' , Reflect(..) -- ** Stringy stuff , parseHeaderMaybe , matchEvent -- * Examples -- -- $example1 -- -- $example2 ) where import Control.Monad.IO.Class ( liftIO ) import Data.Aeson ( decode', encode ) import qualified Data.ByteString as BS import Data.ByteString.Lazy ( fromStrict, toStrict ) import qualified Data.ByteString.Base16 as B16 import Data.HMAC ( hmac_sha1 ) import Data.List ( intercalate ) import Data.Maybe ( catMaybes, fromMaybe ) import Data.Monoid ( (<>) ) import Data.Proxy import Data.String.Conversions ( cs ) import qualified Data.Text.Encoding as E import GHC.TypeLits import GitHub.Data.Webhooks import Network.HTTP.Types hiding (Header, ResponseHeaders) import Network.Wai ( requestHeaders, strictRequestBody ) import Servant import Servant.API.ContentTypes ( AllCTUnrender(..) ) import Servant.Server.Internal -- | A clone of Servant's 'ReqBody' combinator, except that it will also -- verify the signature provided by GitHub in the @X-Hub-Signature@ header by -- computing the SHA1 HMAC of the request body and comparing. -- -- The use of this combinator will require that the router context contain an -- appropriate 'GitHubKey'' entry. Specifically, the type parameter of -- 'GitHubKey'' must correspond with @Demote k@ where @k@ is the kind of the -- index @key@ used here. Consequently, it will be necessary to use -- 'serveWithContext' instead of 'serve'. -- -- Other routes are not tried upon the failure of this combinator, and a 401 -- response is generated. -- -- Use of this datatype directly is discouraged, since the choice of the index -- @key@ determines its kind @k@ and hence @proxy@, which is . Instead, use -- 'GitHubSignedReqBody'', which computes the @proxy@ argument given just -- @key@. The proxy argument is necessary to avoid @UndecidableInstances@ for -- the implementation of the 'HasServer' instance for the datatype. data GitHubSignedReqBody'' (proxy :: KProxy k) (key :: k) (list :: [*]) (result :: *) where -- | Convenient synonym for 'GitHubSignedReqBody''' that computes its first -- type argument given just the second one. -- -- Use this type synonym if you are creating a webhook server to handle -- webhooks from multiple repositories, with different secret keys. type GitHubSignedReqBody' (key :: k) = GitHubSignedReqBody'' ('KProxy :: KProxy k) key -- | A convenient alias for a trivial key index. -- -- USe this type synonym if you are creating a webhook server to handle only -- webhooks from a single repository, or for mutliple repositories using the -- same secret key. type GitHubSignedReqBody = GitHubSignedReqBody' '() -- | A routing combinator that succeeds only for a webhook request that matches -- one of the given 'RepoWebhookEvent' given in the type-level list @events@. -- -- If the list contains 'WebhookWildcardEvent', then all events will be -- matched. -- -- The combinator will require that its associated handler take a -- 'RepoWebhookEvent' parameter, and the matched event will be passed to the -- handler. This allows the handler to determine which event triggered it from -- the list. -- -- Other routes are tried if there is a mismatch. data GitHubEvent (events :: [RepoWebhookEvent]) where ghc-exactprint-0.6.2/tests/examples/pre-ghc86/determ004.hs0000755000000000000000000003252207346545000021362 0ustar0000000000000000{-# LANGUAGE TypeOperators , DataKinds , PolyKinds , TypeFamilies , GADTs , UndecidableInstances , RankNTypes , ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Werror #-} {-# OPTIONS_GHC -O1 -fspec-constr #-} {- With reversed order of allocated uniques the type variables would be in wrong order: *** Core Lint errors : in result of SpecConstr *** determ004.hs:88:12: warning: [in body of lambda with binder m_azbFg :: a_afdP_azbON] @ (a_afdP_azbON :: BOX) is out of scope *** Offending Program *** ... Rec { $s$wsFoldr1_szbtK :: forall (m_azbFg :: a_afdP_azbON) (x_azbOM :: TyFun a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) -> *) (a_afdP_azbON :: BOX) (ipv_szbwN :: a_afdP_azbON) (ipv_szbwO :: [a_afdP_azbON]). R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO) -> Sing ipv_szbwO -> Sing ipv_szbwN -> (forall (t_azbNM :: a_afdP_azbON). Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) [LclId, Arity=4, Str=DmdType ] $s$wsFoldr1_szbtK = \ (@ (m_azbFg :: a_afdP_azbON)) (@ (x_azbOM :: TyFun a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *) -> *)) (@ (a_afdP_azbON :: BOX)) (@ (ipv_szbwN :: a_afdP_azbON)) (@ (ipv_szbwO :: [a_afdP_azbON])) (sg_szbtL :: R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)) (sc_szbtM :: Sing ipv_szbwO) (sc_szbtN :: Sing ipv_szbwN) (sc_szbtP :: forall (t_azbNM :: a_afdP_azbON). Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) -> case (SCons @ a_afdP_azbON @ (ipv_szbwN : ipv_szbwO) @ ipv_szbwO @ ipv_szbwN @~ (_N :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO)) sc_szbtN sc_szbtM) `cast` (sg_szbtL ; TFCo:R:Sing[]z[0] _N _N :: R:Sing[]z (ipv_szbwN : ipv_szbwO) ~R# R:Sing[]z (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)) of wild_XD { SNil dt_dzbxX -> (lvl_szbwi @ a_afdP_azbON) `cast` ((Sing (Sym (TFCo:R:Foldr1[2] _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N <'[]>_N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) (Sym dt_dzbxX))_N))_R :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list") ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH ds_dzbyu [Dmd=] -> case ds_dzbyu `cast` (TFCo:R:Sing[]z[0] _N _N :: Sing n_azbFh ~R# R:Sing[]z n_azbFh) of wild_Xo { SNil dt_dzbxk -> (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe) `cast` ((Sing (Sym (TFCo:R:Foldr1[0] _N _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N <'[m_XzbGe]>_N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) ((_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R :: Sing m_XzbGe ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))); SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK -> case (sc_szbtP @ m_XzbGe _sX_azbOH) `cast` (TFCo:R:Sing(->)f[0] _N _N _N :: Sing (Apply x_azbOM m_XzbGe) ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe)) of wild_X3X { SLambda ds_XzbBr [Dmd=] -> (ds_XzbBr @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR)) (($wsFoldr1_szbuc @ a_afdP_azbON @ x_azbOM @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR) sc_szbtP ((SCons @ a_afdP_azbON @ (ipv_XzbyV : ipv_XzbxR) @ ipv_XzbxR @ ipv_XzbyV @~ (_N :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR)) ipv_szbwL ipv_szbwK) `cast` (Sym (TFCo:R:Sing[]z[0] _N) (Sym (TFCo:R:Apply[][]:$$i[0] _N _N _N) ; (Apply (Sym (TFCo:R:Applyk(->):$l[0] _N _N)) _N)_N) :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR) ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR)))) `cast` ((Sing ((Apply (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N) _N)_N ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N ((Apply (TFCo:R:Applyk(->):$l[0] _N _N) _N)_N ; TFCo:R:Apply[][]:$$i[0] _N _N _N) _N))_R :: Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)) ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))))) `cast` ((Sing ((Apply _N (Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N _N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) (Sym (TFCo:R:Apply[][]:$$i[0] _N _N _N) ; (Apply (Sym (TFCo:R:Applyk(->):$l[0] _N _N)) _N)_N))_N))_N ; Sym (TFCo:R:Foldr1[1] _N _N _N _N _N) ; Sym (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0] _N _N _N) ; (Apply (Sym (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] _N _N)) ((_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R :: Sing (Apply (Apply x_azbOM m_XzbGe) (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR))) ~R# Sing (Apply (Apply Foldr1Sym0 x_azbOM) (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))) } } } ... -} module List (sFoldr1) where data Proxy t data family Sing (a :: k) data TyFun (a :: *) (b :: *) type family Apply (f :: TyFun k1 k2 -> *) (x :: k1) :: k2 data instance Sing (f :: TyFun k1 k2 -> *) = SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) } type SingFunction1 f = forall t. Sing t -> Sing (Apply f t) type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t) singFun2 :: Proxy f -> SingFunction2 f -> Sing f singFun2 _ f = SLambda (\x -> SLambda (f x)) data (:$$) (j :: a) (i :: TyFun [a] [a]) type instance Apply ((:$$) j) i = (:) j i data (:$) (l :: TyFun a (TyFun [a] [a] -> *)) type instance Apply (:$) l = (:$$) l data instance Sing (z :: [a]) = z ~ '[] => SNil | forall (m :: a) (n :: [a]). z ~ (:) m n => SCons (Sing m) (Sing n) data ErrorSym0 (t1 :: TyFun k1 k2) type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh type Let1627448493Xs f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec = Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (t_afdZ :: [a_afdP]) = Foldr1 t_afdY t_afdZ data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (l_afe2 :: TyFun [a_afdP] a_afdP) type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2 data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (TyFun [a_afdP] a_afdP -> *)) type instance Apply Foldr1Sym0 l = Foldr1Sym1 l type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (a_afe6 :: [a_afdP]) :: a_afdP where Foldr1 z_afe7 '[x_afe8] = x_afe8 Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)) Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list" sFoldr1 :: forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> *) -> *) (y :: [a_afdP]). Sing x -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y) sFoldr1 _ (SCons _sX SNil) = undefined sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476)) = let lambda_afeC :: forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec. Sing f_afe9 -> Sing x_afea -> Sing wild_1627448474_afeb -> Sing wild_1627448476_afec -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec))) lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG = let sXs :: Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec) sXs = applySing (applySing (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF) wild_1627448476_afeG in applySing (applySing f_afeD x_afeE) (applySing (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD) sXs) in lambda_afeC sF sX sWild_1627448474 sWild_1627448476 sFoldr1 _ SNil = undefined ghc-exactprint-0.6.2/tests/examples/pre-ghc86/dynamic-paper.hs0000755000000000000000000002305207346545000022405 0ustar0000000000000000{- This is the code extracted from "A reflection on types", by Simon PJ, Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -} {-# LANGUAGE RankNTypes, PolyKinds, TypeOperators, ScopedTypeVariables, GADTs, FlexibleInstances, UndecidableInstances, RebindableSyntax, DataKinds, MagicHash, AutoDeriveTypeable, TypeInType #-} {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-redundant-constraints #-} module Dynamic where import Data.Map ( Map ) import qualified Data.Map as Map import Unsafe.Coerce ( unsafeCoerce ) import Control.Monad ( (<=<) ) import Prelude hiding ( lookup, fromInteger, replicate ) import qualified Prelude import qualified Data.Typeable import qualified Data.Data import Data.Kind lookupMap = Map.lookup insertMap = Map.insert -- let's ignore overloaded numbers fromInteger :: Integer -> Int fromInteger = Prelude.fromInteger insertStore = undefined schema = undefined withTypeable = undefined throw# = undefined toDynamicST = undefined fromDynamicST = undefined extendStore :: Typeable a => STRef s a -> a -> Store -> Store lookupStore :: Typeable a => STRef s a -> Store -> Maybe a type Key = Int data STRef s a = STR Key type Store = Map Key Dynamic extendStore (STR k) v s = insertMap k (toDynamicST v) s lookupStore (STR k) s = case lookupMap k s of Just d -> fromDynamicST d Nothing -> Nothing toDynamicST :: Typeable a => a -> Dynamic fromDynamicST :: Typeable a => Dynamic -> Maybe a eval = undefined data Term data DynamicSilly = DIntSilly Int | DBoolSilly Bool | DCharSilly Char | DPairSilly DynamicSilly DynamicSilly toDynInt :: Int -> DynamicSilly toDynInt = DIntSilly fromDynInt :: DynamicSilly -> Maybe Int fromDynInt (DIntSilly n) = Just n fromDynInt _ = Nothing toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly toDynPair = DPairSilly dynFstSilly :: DynamicSilly -> Maybe DynamicSilly dynFstSilly (DPairSilly x1 x2) = Just x1 dynFstSilly _ = Nothing eval :: Term -> DynamicSilly eqT = undefined instance Typeable (->) instance Typeable Maybe instance Typeable Bool instance Typeable Int instance (Typeable a, Typeable b) => Typeable (a b) instance Typeable (,) instance Eq TypeRepX data Dynamic where Dyn :: TypeRep a -> a -> Dynamic toDynamic :: Typeable a => a -> Dynamic toDynamic x = Dyn typeRep x eqTNoKind = undefined eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b) -- Primitive; implemented by compiler data a :***: b where ReflNoKind :: a :***: a fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d fromDynamic (Dyn (ra :: TypeRep a) (x :: a)) = case eqT ra (typeRep :: TypeRep d) of Nothing -> Nothing Just Refl -> Just x fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d fromDynamicMonad (Dyn ra x) = do Refl <- eqT ra (typeRep :: TypeRep d) return x cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b cast x = do Refl <- eqT (typeRep :: TypeRep a) (typeRep :: TypeRep b) return x gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) gcast x = do Refl <- eqT (typeRep :: TypeRep a) (typeRep :: TypeRep b) return x data SameKind :: k -> k -> * type CheckAppResult = SameKind AppResult AppResultNoKind -- not the most thorough check foo :: AppResult x -> AppResultNoKind x foo (App y z) = AppNoKind y z splitApp :: TypeRep a -> Maybe (AppResult a) splitApp = undefined splitAppNoKind = undefined splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a) -- Primitive; implemented by compiler data AppResultNoKind t where AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b) dynFstNoKind :: Dynamic -> Maybe Dynamic dynFstNoKind (Dyn rpab x) = do AppNoKind rpa rb <- splitAppNoKind rpab AppNoKind rp ra <- splitAppNoKind rpa Refl <- eqT rp (typeRep :: TypeRep (,)) return (Dyn ra (fst x)) dynApply :: Dynamic -> Dynamic -> Maybe Dynamic dynApply (Dyn rf f) (Dyn rx x) = do App ra rt2 <- splitApp rf App rtc rt1 <- splitApp ra Refl <- eqT rtc (typeRep :: TypeRep (->)) Refl <- eqT rt1 rx return (Dyn rt2 (f x)) data TypeRepAbstract (a :: k) -- primitive, indexed by type and kind class Typeable (a :: k) where typeRep :: TypeRep a data AppResult (t :: k) where App :: forall k1 k (a :: k1 -> k) (b :: k1). TypeRep a -> TypeRep b -> AppResult (a b) dynFst :: Dynamic -> Maybe Dynamic dynFst (Dyn (rpab :: TypeRep pab) (x :: pab)) = do App (rpa :: TypeRep pa ) (rb :: TypeRep b) <- splitApp rpab -- introduces kind |k2|, and types |pa :: k2 -> *|, |b :: k2| App (rp :: TypeRep p ) (ra :: TypeRep a) <- splitApp rpa -- introduces kind |k1|, and types |p :: k1 -> k2 -> *|, |a :: k1| Refl <- eqT rp (typeRep :: TypeRep (,)) -- introduces |p ~ (,)| and |(k1 -> k2 -> *) ~ (* -> * -> *)| return (Dyn ra (fst x)) eqT :: forall k1 k2 (a :: k1) (b :: k2). TypeRep a -> TypeRep b -> Maybe (a :~: b) data (a :: k1) :~: (b :: k2) where Refl :: forall k (a :: k). a :~: a castDance :: (Typeable a, Typeable b) => a -> Maybe b castDance = castR typeRep typeRep withTypeable :: TypeRep a -> (Typeable a => r) -> r castR :: TypeRep a -> TypeRep b -> a -> Maybe b castR ta tb = withTypeable ta (withTypeable tb castDance) cmpT = undefined compareTypeRep = undefined data TypeRepX where TypeRepX :: TypeRep a -> TypeRepX type TyMapLessTyped = Map TypeRepX Dynamic insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) instance Ord TypeRepX where compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive data TyMap = Empty | Node Dynamic TyMap TyMap lookup :: TypeRep a -> TyMap -> Maybe a lookup tr1 (Node (Dyn tr2 v) left right) = case compareTypeRep tr1 tr2 of LT -> lookup tr1 left EQ -> castR tr2 tr1 v -- know this cast will succeed GT -> lookup tr1 right lookup tr1 Empty = Nothing cmpT :: TypeRep a -> TypeRep b -> OrderingT a b -- definition is primitive data OrderingT a b where LTT :: OrderingT a b EQT :: OrderingT t t GTT :: OrderingT a b data TypeRep (a :: k) where TrApp :: TypeRep a -> TypeRep b -> TypeRep (a b) TrTyCon :: TyCon -> TypeRep k -> TypeRep (a :: k) data TyCon = TyCon { tc_module :: Module, tc_name :: String } data Module = Module { mod_pkg :: String, mod_name :: String } tcMaybe :: TyCon tcMaybe = TyCon { tc_module = Module { mod_pkg = "base" , mod_name = "Data.Maybe" } , tc_name = "Maybe" } rt = undefined delta1 :: Dynamic -> Dynamic delta1 dn = case fromDynamic dn of Just f -> f dn Nothing -> dn loop1 = delta1 (toDynamic delta1) data Rid = MkT (forall a. TypeRep a -> a -> a) rt :: TypeRep Rid delta :: forall a. TypeRep a -> a -> a delta ra x = case (eqT ra rt) of Just Refl -> case x of MkT y -> y rt x Nothing -> x loop = delta rt (MkT delta) throw# :: SomeException -> a data SomeException where SomeException :: Exception e => e -> SomeException class (Typeable e, Show e) => Exception e where { } data Company data Salary incS :: Float -> Salary -> Salary incS = undefined -- some impedance matching with SYB instance Data.Data.Data Company instance {-# INCOHERENT #-} Data.Typeable.Typeable a => Typeable a mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a mkT f x = case (cast f) of Just g -> g x Nothing -> x data Expr a frontEnd = undefined data DynExp where DE :: TypeRep a -> Expr a -> DynExp frontEnd :: String -> DynExp data TyConOld typeOf = undefined eqTOld = undefined funTcOld = undefined :: TyConOld splitTyConApp = undefined mkTyCon3 = undefined boolTcOld = undefined tupleTc = undefined mkTyConApp = undefined instance Eq TypeRepOld instance Eq TyConOld data TypeRepOld -- Abstract class TypeableOld a where typeRepOld :: proxy a -> TypeRepOld data DynamicOld where DynOld :: TypeRepOld -> a -> DynamicOld data Proxy a = Proxy fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d fromDynamicOld (DynOld trx x) | typeRepOld (Proxy :: Proxy d) == trx = Just (unsafeCoerce x) | otherwise = Nothing dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld dynApplyOld (DynOld trf f) (DynOld trx x) = case splitTyConApp trf of (tc, [t1,t2]) | tc == funTcOld && t1 == trx -> Just (DynOld t2 ((unsafeCoerce f) x)) _ -> Nothing data DynamicClosed where DynClosed :: TypeRepClosed a -> a -> DynamicClosed data TypeRepClosed (a :: *) where TBool :: TypeRepClosed Bool TFun :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b) TProd :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b) lookupPil = undefined lookupPil :: Typeable a => [Dynamic] -> Maybe a data Dyn1 = Dyn1 Int | DynFun (Dyn1 -> Dyn1) | DynPair (Dyn1, Dyn1) data TypeEnum = IntType | FloatType | BoolType | DateType | StringType data Schema = Object [Schema] | Field TypeEnum | Array Schema schema :: Typeable a => a -> Schema ghc-exactprint-0.6.2/tests/examples/pre-ghc86/mkGADTVars.hs0000755000000000000000000000027307346545000021557 0ustar0000000000000000{-# LANGUAGE GADTs, TypeInType #-} module GADTVars where import Data.Kind import Data.Proxy data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where MkT :: T x1 * (Proxy (y :: x1), z) z ghc-exactprint-0.6.2/tests/examples/pre-ghc86/overloadedrecflds_generics.hs0000755000000000000000000000347307346545000025227 0ustar0000000000000000-- Test that DuplicateRecordFields doesn't affect the metadata -- generated by GHC.Generics or Data.Data -- Based on a Stack Overflow post by bennofs -- (http://stackoverflow.com/questions/24474581) -- licensed under cc by-sa 3.0 {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} import GHC.Generics import Data.Data import Data.Proxy type family FirstSelector (f :: * -> *) :: Meta type instance FirstSelector (M1 D x f) = FirstSelector f type instance FirstSelector (M1 C x f) = FirstSelector f type instance FirstSelector (a :*: b) = FirstSelector a type instance FirstSelector (M1 S s f) = s data SelectorProxy (s :: Meta) (f :: * -> *) a = SelectorProxy type SelectorProxy' (s :: Meta) = SelectorProxy s Proxy () -- Extract the first selector name using GHC.Generics firstSelectorName :: forall a. Selector (FirstSelector (Rep a)) => Proxy a -> String firstSelectorName _ = selName (SelectorProxy :: SelectorProxy' (FirstSelector (Rep a))) -- Extract the list of selector names for a constructor using Data.Data selectorNames :: Data a => a -> [String] selectorNames = constrFields . toConstr data T = MkT { foo :: Int } deriving (Data, Generic) data U = MkU { foo :: Int, bar :: Bool } deriving (Data, Generic) main = do -- This should yield "foo", not "$sel:foo:MkT" print (firstSelectorName (Proxy :: Proxy T)) -- Similarly this should yield "foo" print (firstSelectorName (Proxy :: Proxy U)) -- This should yield ["foo"] print (selectorNames (MkT 3)) -- And this should yield ["foo","bar"] print (selectorNames (MkU 3 True)) ghc-exactprint-0.6.2/tests/examples/transform/0000755000000000000000000000000007346545000017623 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/transform/AddDecl.hs0000755000000000000000000000020207346545000021434 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddDecl.hs.expected0000755000000000000000000000021307346545000023236 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddHiding1.hs0000755000000000000000000000012407346545000022053 0ustar0000000000000000module AddHiding1 where import Data.Maybe import Data.Maybe hiding (n1,n2) f = 1 ghc-exactprint-0.6.2/tests/examples/transform/AddHiding1.hs.expected0000755000000000000000000000014307346545000023654 0ustar0000000000000000module AddHiding1 where import Data.Maybe hiding (n1,n2) import Data.Maybe hiding (n1,n2) f = 1 ghc-exactprint-0.6.2/tests/examples/transform/AddHiding2.hs0000755000000000000000000000010107346545000022047 0ustar0000000000000000module AddHiding2 where import Data.Maybe hiding (f1,f2) f = 1 ghc-exactprint-0.6.2/tests/examples/transform/AddHiding2.hs.expected0000755000000000000000000000010707346545000023655 0ustar0000000000000000module AddHiding2 where import Data.Maybe hiding (f1,f2,n1,n2) f = 1 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl1.hs0000755000000000000000000000017407346545000022500 0ustar0000000000000000module AddLocalDecl1 where -- |This is a function foo = x -- comment1 -- |Another fun x = a -- comment2 where a = 3 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl1.hs.expected0000755000000000000000000000021707346545000024276 0ustar0000000000000000module AddLocalDecl1 where -- |This is a function foo = x -- comment1 where nn = 2 -- |Another fun x = a -- comment2 where a = 3 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl2.hs0000755000000000000000000000026307346545000022500 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl2.hs.expected0000755000000000000000000000030207346545000024272 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl3.hs0000755000000000000000000000026307346545000022501 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl3.hs.expected0000755000000000000000000000030207346545000024273 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl4.hs0000755000000000000000000000005707346545000022503 0ustar0000000000000000module AddLocalDecl4 where toplevel x = c * x ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl4.hs.expected0000755000000000000000000000012007346545000024272 0ustar0000000000000000module AddLocalDecl4 where toplevel x = c * x where nn :: Int nn = 2 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl5.hs0000755000000000000000000000015507346545000022503 0ustar0000000000000000module AddLocalDecl5 where toplevel :: Integer -> Integer toplevel x = c * x -- c,d :: Integer c = 7 d = 9 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl5.hs.expected0000755000000000000000000000017507346545000024305 0ustar0000000000000000module AddLocalDecl5 where toplevel :: Integer -> Integer toplevel x = c * x where -- c,d :: Integer c = 7 d = 9 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl6.hs0000755000000000000000000000021707346545000022503 0ustar0000000000000000module AddLocalDecl6 where foo [] = 1 -- comment 0 foo xs = 2 -- comment 1 bar [] = 1 -- comment 2 where x = 3 bar xs = 2 -- comment 3 ghc-exactprint-0.6.2/tests/examples/transform/AddLocalDecl6.hs.expected0000755000000000000000000000024107346545000024300 0ustar0000000000000000module AddLocalDecl6 where foo [] = 1 -- comment 0 where x = 3 foo xs = 2 -- comment 1 bar [] = 1 -- comment 2 where x = 3 bar xs = 2 -- comment 3 ghc-exactprint-0.6.2/tests/examples/transform/C.hs0000755000000000000000000000041707346545000020346 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/C.hs.expected0000755000000000000000000000043407346545000022145 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/CloneDecl1.hs0000755000000000000000000000014307346545000022071 0ustar0000000000000000module CloneDecl1 where z = 3 foo a b = let x = a + b + z y = a * b - z in x + y ghc-exactprint-0.6.2/tests/examples/transform/CloneDecl1.hs.expected0000755000000000000000000000024707346545000023676 0ustar0000000000000000module CloneDecl1 where z = 3 foo a b = let x = a + b + z y = a * b - z in x + y foo a b = let x = a + b + z y = a * b - z in x + y ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn1.hs0000755000000000000000000000035407346545000022011 0ustar0000000000000000module LayoutIn1 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'sq' to 'square'. sumSquares x y= sq x + sq y where sq x= x^pow --There is a comment. pow=2 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn1.hs.expected0000755000000000000000000000040407346545000023605 0ustar0000000000000000module LayoutIn1 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'sq' to 'square'. sumSquares x y= square x + square y where sq x= x^pow --There is a comment. pow=2 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3.hs0000755000000000000000000000103207346545000022005 0ustar0000000000000000module LayoutIn3 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let x = 12 in (let y = 3 z = 2 in x * y * z * w) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3.hs.expected0000755000000000000000000000114707346545000023614 0ustar0000000000000000module LayoutIn3 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let anotherX = 12 in (let y = 3 z = 2 in anotherX * y * z * w) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3a.hs0000755000000000000000000000102207346545000022145 0ustar0000000000000000module LayoutIn3a where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let x = 12 in ( x ) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3a.hs.expected0000755000000000000000000000107407346545000023754 0ustar0000000000000000module LayoutIn3a where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let anotherX = 12 in ( anotherX ) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3b.hs0000755000000000000000000000077207346545000022161 0ustar0000000000000000module LayoutIn3b where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let x = 12 in ( x ) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn3b.hs.expected0000755000000000000000000000110007346545000023743 0ustar0000000000000000module LayoutIn3b where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'x' after 'let' to 'anotherX'. foo x = let anotherX = 12 in ( anotherX ) where y = 2 --there is a comment. w = x where x = let y = 5 in y + 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn4.hs0000755000000000000000000000064407346545000022016 0ustar0000000000000000module LayoutIn4 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'ioFun' to 'io' main = ioFun "hello" where ioFun s= do let k = reverse s --There is a comment s <- getLine let q = (k ++ s) putStr q putStr "foo" ghc-exactprint-0.6.2/tests/examples/transform/LayoutIn4.hs.expected0000755000000000000000000000060507346545000023613 0ustar0000000000000000module LayoutIn4 where --Layout rule applies after 'where','let','do' and 'of' --In this Example: rename 'ioFun' to 'io' main = io "hello" where io s= do let k = reverse s --There is a comment s <- getLine let q = (k ++ s) putStr q putStr "foo" ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet2.hs0000755000000000000000000000041207346545000022163 0ustar0000000000000000module LayoutLet2 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxx = let a = 1 b = 2 in xxx + a + b ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet2.hs.expected0000755000000000000000000000043407346545000023767 0ustar0000000000000000module LayoutLet2 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxxlonger = let a = 1 b = 2 in xxxlonger + a + b ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet3.hs0000755000000000000000000000042407346545000022167 0ustar0000000000000000module LayoutLet3 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxx = let a = 1 b = 2 in xxx + a + b ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet3.hs.expected0000755000000000000000000000045407346545000023772 0ustar0000000000000000module LayoutLet3 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxxlonger = let a = 1 b = 2 in xxxlonger + a + b ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet4.hs0000755000000000000000000000043407346545000022171 0ustar0000000000000000module LayoutLet4 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxx = let a = 1 b = 2 in xxx + a + b bar = 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet4.hs.expected0000755000000000000000000000046407346545000023774 0ustar0000000000000000module LayoutLet4 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxxlonger = let a = 1 b = 2 in xxxlonger + a + b bar = 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet5.hs0000755000000000000000000000043407346545000022172 0ustar0000000000000000module LayoutLet5 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo xxx = let a = 1 b = 2 in xxx + a + b bar = 3 ghc-exactprint-0.6.2/tests/examples/transform/LayoutLet5.hs.expected0000755000000000000000000000042407346545000023771 0ustar0000000000000000module LayoutLet5 where -- Simple let expression, rename xxx to something longer or shorter -- and the let/in layout should adjust accordingly -- In this case the tokens for xxx + a + b should also shift out foo x = let a = 1 b = 2 in x + a + b bar = 3 ghc-exactprint-0.6.2/tests/examples/transform/LetIn1.hs0000755000000000000000000000100507346545000021252 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/LetIn1.hs.expected0000755000000000000000000000075207346545000023062 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/LocToName.hs0000755000000000000000000000023207346545000022000 0ustar0000000000000000module LocToName where {- -} sumSquares (x:xs) = x ^2 + sumSquares xs -- where sq x = x ^pow -- pow = 2 sumSquares [] = 0 ghc-exactprint-0.6.2/tests/examples/transform/LocToName.hs.expected0000755000000000000000000000026207346545000023603 0ustar0000000000000000module LocToName where {- -} LocToName.newPoint (x:xs) = x ^2 + LocToName.newPoint xs -- where sq x = x ^pow -- pow = 2 LocToName.newPoint [] = 0 ghc-exactprint-0.6.2/tests/examples/transform/LocalDecls.hs0000755000000000000000000000014407346545000022166 0ustar0000000000000000module LocalDecls where foo a = bar a where bar :: Int -> Int bar x = x + 2 baz = 4 ghc-exactprint-0.6.2/tests/examples/transform/LocalDecls.hs.expected0000755000000000000000000000017607346545000023773 0ustar0000000000000000module LocalDecls where foo a = bar a where nn :: Int nn = 2 bar :: Int -> Int bar x = x + 2 baz = 4 ghc-exactprint-0.6.2/tests/examples/transform/LocalDecls2.hs0000755000000000000000000000005007346545000022244 0ustar0000000000000000module LocalDecls2 where foo a = bar a ghc-exactprint-0.6.2/tests/examples/transform/LocalDecls2.hs.expected0000755000000000000000000000011107346545000024042 0ustar0000000000000000module LocalDecls2 where foo a = bar a where nn :: Int nn = 2 ghc-exactprint-0.6.2/tests/examples/transform/NormaliseLayout.hs0000755000000000000000000000011507346545000023306 0ustar0000000000000000module Main where foo x = baz where foo = 2 two = 4 where bax = 4 ghc-exactprint-0.6.2/tests/examples/transform/NormaliseLayout.hs.expected0000755000000000000000000000002207346545000025103 0ustar0000000000000000module Main where ghc-exactprint-0.6.2/tests/examples/transform/Rename1.hs0000755000000000000000000000005707346545000021454 0ustar0000000000000000 foo x y = do c <- getChar return c ghc-exactprint-0.6.2/tests/examples/transform/Rename1.hs.expected0000755000000000000000000000006007346545000023246 0ustar0000000000000000 bar2 x y = do c <- getChar return c ghc-exactprint-0.6.2/tests/examples/transform/Rename2.hs0000755000000000000000000000007407346545000021454 0ustar0000000000000000 foo' x = case (odd x) of True -> "Odd" False -> "Even" ghc-exactprint-0.6.2/tests/examples/transform/Rename2.hs.expected0000755000000000000000000000007307346545000023253 0ustar0000000000000000 joe x = case (odd x) of True -> "Odd" False -> "Even" ghc-exactprint-0.6.2/tests/examples/transform/RenameCase1.hs0000755000000000000000000000011507346545000022243 0ustar0000000000000000module RenameCase1 where foo x = case (baz x) of 1 -> "a" _ -> "b" ghc-exactprint-0.6.2/tests/examples/transform/RenameCase1.hs.expected0000755000000000000000000000012307346545000024042 0ustar0000000000000000module RenameCase1 where foo x = case (bazLonger x) of 1 -> "a" _ -> "b" ghc-exactprint-0.6.2/tests/examples/transform/RenameCase2.hs0000755000000000000000000000011507346545000022244 0ustar0000000000000000module RenameCase2 where foo x = case (baz x) of 1 -> "a" _ -> "b" ghc-exactprint-0.6.2/tests/examples/transform/RenameCase2.hs.expected0000755000000000000000000000012307346545000024043 0ustar0000000000000000module RenameCase2 where fooLonger x = case (baz x) of 1 -> "a" _ -> "b" ghc-exactprint-0.6.2/tests/examples/transform/RmDecl1.hs0000755000000000000000000000033707346545000021414 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/RmDecl1.hs.expected0000755000000000000000000000022207346545000023205 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/RmDecl2.hs0000755000000000000000000000027407346545000021415 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/RmDecl2.hs.expected0000755000000000000000000000024107346545000023207 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/RmDecl3.hs0000755000000000000000000000022207346545000021407 0ustar0000000000000000module RmDecl3 where -- Remove last declaration from a where clause, where should disappear too ff y = y + zz where zz = 1 foo = 3 -- EOF ghc-exactprint-0.6.2/tests/examples/transform/RmDecl3.hs.expected0000755000000000000000000000020707346545000023212 0ustar0000000000000000module RmDecl3 where -- Remove last declaration from a where clause, where should disappear too ff y = y + zz zz = 1 foo = 3 -- EOF ghc-exactprint-0.6.2/tests/examples/transform/RmDecl4.hs0000755000000000000000000000023607346545000021415 0ustar0000000000000000module RmDecl4 where -- Remove first declaration from a where clause, last should still be indented ff y = y + zz + xx where zz = 1 xx = 2 -- EOF ghc-exactprint-0.6.2/tests/examples/transform/RmDecl4.hs.expected0000755000000000000000000000023307346545000023212 0ustar0000000000000000module RmDecl4 where -- Remove first declaration from a where clause, last should still be indented ff y = y + zz + xx where xx = 2 zz = 1 -- EOF ghc-exactprint-0.6.2/tests/examples/transform/RmDecl5.hs0000755000000000000000000000021507346545000021413 0ustar0000000000000000module RmDecl5 where sumSquares x y = let sq 0=0 sq z=z^pow pow=2 in sq x + sq y ghc-exactprint-0.6.2/tests/examples/transform/RmDecl5.hs.expected0000755000000000000000000000012107346545000023207 0ustar0000000000000000module RmDecl5 where sumSquares x y = let pow=2 in sq x + sq y ghc-exactprint-0.6.2/tests/examples/transform/RmDecl6.hs0000755000000000000000000000020707346545000021415 0ustar0000000000000000module RmDecl6 where foo a = baz where baz :: Int baz = x + a x = 1 y :: Int -> Int -> Int y a b = undefined ghc-exactprint-0.6.2/tests/examples/transform/RmDecl6.hs.expected0000755000000000000000000000014607346545000023217 0ustar0000000000000000module RmDecl6 where foo a = baz where x = 1 y :: Int -> Int -> Int y a b = undefined ghc-exactprint-0.6.2/tests/examples/transform/RmDecl7.hs0000755000000000000000000000014707346545000021421 0ustar0000000000000000module RmDecl7 where toplevel :: Integer -> Integer toplevel x = c * x -- c,d :: Integer c = 7 d = 9 ghc-exactprint-0.6.2/tests/examples/transform/RmDecl7.hs.expected0000755000000000000000000000011707346545000023216 0ustar0000000000000000module RmDecl7 where toplevel :: Integer -> Integer toplevel x = c * x d = 9 ghc-exactprint-0.6.2/tests/examples/transform/RmTypeSig1.hs0000755000000000000000000000013507346545000022125 0ustar0000000000000000module RmTypeSig1 where sq,anotherFun :: Int -> Int sq 0 = 0 sq z = z^2 anotherFun x = x^2 ghc-exactprint-0.6.2/tests/examples/transform/RmTypeSig1.hs.expected0000755000000000000000000000013207346545000023722 0ustar0000000000000000module RmTypeSig1 where anotherFun :: Int -> Int sq 0 = 0 sq z = z^2 anotherFun x = x^2 ghc-exactprint-0.6.2/tests/examples/transform/RmTypeSig2.hs0000755000000000000000000000013607346545000022127 0ustar0000000000000000module RmTypeSig2 where -- Pattern bind tup@(h,t) = (1,ff) where ff :: Int ff = 15 ghc-exactprint-0.6.2/tests/examples/transform/RmTypeSig2.hs.expected0000755000000000000000000000012007346545000023720 0ustar0000000000000000module RmTypeSig2 where -- Pattern bind tup@(h,t) = (1,ff) where ff = 15 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn3.hs0000755000000000000000000000116107346545000021605 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn3.hs.expected0000755000000000000000000000101007346545000023376 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn3a.hs0000755000000000000000000000115007346545000021744 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn3a.hs.expected0000755000000000000000000000136507346545000023554 0ustar0000000000000000module 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 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn4.hs0000755000000000000000000000113307346545000021605 0ustar0000000000000000module WhereIn4 where --A definition can be demoted to the local 'where' binding of a friend declaration, --if it is only used by this friend declaration. --Demoting a definition narrows down the scope of the definition. --In this example, demote the top level 'sq' to 'sumSquares' --In this case (there is single matches), if possible, --the parameters will be folded after demoting and type sigature will be removed. sumSquares x y = sq p x + sq p y where p=2 {-There is a comment-} sq::Int->Int->Int sq pow z = z^pow --there is a comment anotherFun 0 y = sq y where sq x = x^2 ghc-exactprint-0.6.2/tests/examples/transform/WhereIn4.hs.expected0000755000000000000000000000113507346545000023407 0ustar0000000000000000module WhereIn4 where --A definition can be demoted to the local 'where' binding of a friend declaration, --if it is only used by this friend declaration. --Demoting a definition narrows down the scope of the definition. --In this example, demote the top level 'sq' to 'sumSquares' --In this case (there is single matches), if possible, --the parameters will be folded after demoting and type sigature will be removed. sumSquares x y = sq p x + sq p y where p_2=2 {-There is a comment-} sq::Int->Int->Int sq pow z = z^pow --there is a comment anotherFun 0 y = sq y where sq x = x^2 ghc-exactprint-0.6.2/tests/examples/vect/0000755000000000000000000000000007346545000016551 5ustar0000000000000000ghc-exactprint-0.6.2/tests/examples/vect/DiophantineVect.hs0000755000000000000000000000230007346545000022167 0ustar0000000000000000{-# LANGUAGE ParallelArrays #-} {-# OPTIONS -fvectorise -XParallelListComp #-} module DiophantineVect (solution3) where import Data.Array.Parallel import Data.Array.Parallel.Prelude.Int as I import qualified Prelude as P solution3' = let pow x i = productP (replicateP i x) primes = [: 2,3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71,73 :] a `cutTo` b = sliceP 0 (lengthP b) a sumpri xx = productP [: pow p x | p <- primes `cutTo` xx | x <- xx :] distinct xx = productP [: x I.+ 1 | x <- xx :] series :: [:Int:] -> Int -> [:[:Int:]:] series xs n | n == 1 = [: [: 0 :] :] | otherwise = [: [: x :] +:+ ps | x <- xs , ps <- series (I.enumFromToP 0 x) (n I.- 1) :] prob x y = let xx = [: (sumpri m ,m) | m <- series (I.enumFromToP 1 3) x , distinct [: x I.* 2 | x <- m :] > y :] i = minIndexP [: a | (a, b) <- xx :] in xx !: i in prob 5 200 solution3 :: (Int, PArray Int) {-# NOINLINE solution3 #-} solution3 = let (i, is) = solution3' in (i, toPArrayP is)