August 2017 - openSUSE Commits - openSUSE Mailing Lists

commit ghc-hsinstall for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hsinstall for openSUSE:Factory checked in at 2017-08-31 20:56:19 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hsinstall (Old) and /work/SRC/openSUSE:Factory/.ghc-hsinstall.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hsinstall" Thu Aug 31 20:56:19 2017 rev:2 rq:513388 version:1.6 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hsinstall/ghc-hsinstall.changes 2017-04-12 18:07:03.135704903 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hsinstall.new/ghc-hsinstall.changes 2017-08-31 20:56:24.415893379 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:05:54 UTC 2017 - psimons(a)suse.com + +- Update to version 1.6. + +------------------------------------------------------------------- Old: ---- hsinstall-1.5.tar.gz New: ---- hsinstall-1.6.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hsinstall.spec ++++++ --- /var/tmp/diff_new_pack.v9leQy/_old 2017-08-31 20:56:25.467745590 +0200 +++ /var/tmp/diff_new_pack.v9leQy/_new 2017-08-31 20:56:25.487742781 +0200 @@ -18,7 +18,7 @@ %global pkg_name hsinstall Name: ghc-%{pkg_name} -Version: 1.5 +Version: 1.6 Release: 0 Summary: Install Haskell software License: ISC @@ -76,6 +76,6 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) -%doc README.md changelog.md +%doc README.md changelog.md doc %changelog ++++++ hsinstall-1.5.tar.gz -> hsinstall-1.6.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/LICENSE new/hsinstall-1.6/LICENSE --- old/hsinstall-1.5/LICENSE 2016-09-20 18:17:19.000000000 +0200 +++ new/hsinstall-1.6/LICENSE 2017-07-02 02:52:58.000000000 +0200 @@ -1,4 +1,4 @@ -Copyright (c) 2016, Dino Morelli <dino(a)ui3.info> +Copyright (c) 2016-2017, Dino Morelli <dino(a)ui3.info> Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/README.md new/hsinstall-1.6/README.md --- old/hsinstall-1.5/README.md 2016-10-07 21:54:59.000000000 +0200 +++ new/hsinstall-1.6/README.md 2017-07-02 02:52:58.000000000 +0200 @@ -79,10 +79,10 @@ packages: - '.' - - location: /path/to/hsinstall-1.3 + - location: /path/to/hsinstall-x.y extra-dep: true extra-deps: - - hsinstall-1.3 + - hsinstall-x.y And then you should be able to build against this copy of hsinstall. Of course, these are just examples, the version numbers diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/changelog.md new/hsinstall-1.6/changelog.md --- old/hsinstall-1.5/changelog.md 2016-10-16 21:50:57.000000000 +0200 +++ new/hsinstall-1.6/changelog.md 2017-07-02 02:52:58.000000000 +0200 @@ -1,3 +1,13 @@ +1.6 (2017-07-01) + + * Changed base lower bound from 4.9 to 4.8 + * Updated stack snapshot to lts-8.21 + * Added HCAR listing content + * Removed defunct cabal stability field + * Adjusted some documentation in the README + * Moved copyright date up to 2017 + + 1.5 (2016-10-16) * Now creating bin directory prior to stack install diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/doc/hcar/hsinstall.tex new/hsinstall-1.6/doc/hcar/hsinstall.tex --- old/hsinstall-1.5/doc/hcar/hsinstall.tex 1970-01-01 01:00:00.000000000 +0100 +++ new/hsinstall-1.6/doc/hcar/hsinstall.tex 2017-07-02 01:32:53.000000000 +0200 @@ -0,0 +1,86 @@ +% hsinstall.tex +\begin{hcarentry}[new]{hsinstall} +\report{Dino Morelli} +\status{stable, actively developed} +\makeheader + +\vspace{5mm} + +This is a utility to install Haskell programs on a system using +stack. Although stack does have an `install` command, it only copies +binaries. Sometimes more is needed, other files and some directory +structure. hsinstall tries to install the binaries, the LICENSE +file and also the resources directory if it finds one. + +\vspace{5mm} + +Installations can be performed in one of two directory +structures. FHS, or the Filesystem Hierarchy Standard (most UNIX-like +systems) and what I call "bundle" which is a portable directory +for the app and all of its files. They look like this: + +\vspace{5mm} + +bundle is sort-of a self-contained structure like this: + +\vspace{5mm} + +\begin{verbatim} + $PREFIX/ + $PROJECT-$VERSION/ + bin/... + doc/LICENSE + resources/... +\end{verbatim} + +\vspace{5mm} + +fhs is the more traditional UNIX structure like this: + +\vspace{5mm} + +\begin{verbatim} + $PREFIX/ + bin/... + share/ + $PROJECT-$VERSION/ + doc/LICENSE + resources/... +\end{verbatim} + +\vspace{5mm} + +There are two parts to hsinstall that are intended to work +together. The first part is a Haskell shell script, +`util/install.hs`. Take a copy of this script and check it into +a project you're working on. This will be your installation +script. Running the script with the `--help` switch will explain +the options. Near the top of the script are default values for +these options that should be tuned to what your project needs. + +\vspace{5mm} + +The other part of hsinstall is a library. The install script will try +to install a `resources` directory if it finds one. the HSInstall +library can then be used in your code to locate the resources +at runtime. + +\vspace{5mm} + +Note that you only need the library if your software has data files +it needs to locate at runtime in the installation directories. Many +programs don't have this requirement and can ignore the library +altogether. + +\vspace{5mm} + +Source code is available on darcshub, Hackage and Stackage + +\FurtherReading +\begin{compactitem} + \item hsinstall on darcshub \url{http://hub.darcs.net/dino/hsinstall} + \item hsinstall on Hackage \url{https://hackage.haskell.org/package/hsinstall} + \item hsinstall on Stackage \url{https://www.stackage.org/package/hsinstall} +\end{compactitem} + +\end{hcarentry} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/hsinstall.cabal new/hsinstall-1.6/hsinstall.cabal --- old/hsinstall-1.5/hsinstall.cabal 2016-10-16 18:41:32.000000000 +0200 +++ new/hsinstall-1.6/hsinstall.cabal 2017-07-02 17:09:47.000000000 +0200 @@ -1,5 +1,5 @@ name: hsinstall -version: 1.5 +version: 1.6 synopsis: Install Haskell software description: This is a utility to install Haskell programs on a system using stack. Even though stack has an `install` command, I found it to be not enough for my needs. This software tries to install the binaries, the LICENSE file and also the resources directory if it finds one. There is also an optional library component to assist with locating installed data files at runtime. homepage: @@ -7,14 +7,14 @@ license-file: LICENSE author: Dino Morelli maintainer: Dino Morelli <dino(a)ui3.info> -copyright: 2016 Dino Morelli -stability: experimental +copyright: 2016-2017 Dino Morelli category: Utility build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 8.0.1 data-files: resources/foo extra-source-files: changelog.md + doc/hcar/hsinstall.tex README.md resources/foo stack.yaml @@ -25,7 +25,7 @@ hs-source-dirs: app main-is: Main.hs ghc-options: -Wall - build-depends: base >= 4.9 && < 5.0 + build-depends: base >= 4.8 && < 5.0 , directory , filepath , hsinstall @@ -35,7 +35,7 @@ hs-source-dirs: src exposed-modules: HSInstall ghc-options: -Wall - build-depends: base >= 4.9 && < 5.0 + build-depends: base >= 4.8 && < 5.0 , directory , filepath default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hsinstall-1.5/stack.yaml new/hsinstall-1.6/stack.yaml --- old/hsinstall-1.5/stack.yaml 2016-10-16 18:43:24.000000000 +0200 +++ new/hsinstall-1.6/stack.yaml 2017-07-02 02:52:58.000000000 +0200 @@ -1,4 +1,4 @@ -resolver: lts-7.2 +resolver: lts-8.21 packages: - '.'

1 0

commit ghc-hjsonschema for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hjsonschema for openSUSE:Factory checked in at 2017-08-31 20:56:17 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hjsonschema (Old) and /work/SRC/openSUSE:Factory/.ghc-hjsonschema.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hjsonschema" Thu Aug 31 20:56:17 2017 rev:2 rq:513382 version:1.6.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hjsonschema/ghc-hjsonschema.changes 2017-04-12 18:06:56.284673605 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hjsonschema.new/ghc-hjsonschema.changes 2017-08-31 20:56:18.660702002 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:02 UTC 2017 - psimons(a)suse.com + +- Update to version 1.6.3. + +------------------------------------------------------------------- Old: ---- hjsonschema-1.5.0.1.tar.gz New: ---- hjsonschema-1.6.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hjsonschema.spec ++++++ --- /var/tmp/diff_new_pack.brwxMR/_old 2017-08-31 20:56:19.800541851 +0200 +++ /var/tmp/diff_new_pack.brwxMR/_new 2017-08-31 20:56:19.804541289 +0200 @@ -19,7 +19,7 @@ %global pkg_name hjsonschema %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.5.0.1 +Version: 1.6.3 Release: 0 Summary: JSON Schema library License: MIT ++++++ hjsonschema-1.5.0.1.tar.gz -> hjsonschema-1.6.3.tar.gz ++++++ ++++ 1874 lines of diff (skipped)

1 0

commit ghc-hint for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hint for openSUSE:Factory checked in at 2017-08-31 20:56:15 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hint (Old) and /work/SRC/openSUSE:Factory/.ghc-hint.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hint" Thu Aug 31 20:56:15 2017 rev:2 rq:513380 version:0.7.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hint/ghc-hint.changes 2017-05-16 14:38:47.764738601 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hint.new/ghc-hint.changes 2017-08-31 20:56:16.816961054 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:03 UTC 2017 - psimons(a)suse.com + +- Update to version 0.7.0. + +------------------------------------------------------------------- Old: ---- hint-0.6.0.tar.gz New: ---- hint-0.7.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hint.spec ++++++ --- /var/tmp/diff_new_pack.zDgNuP/_old 2017-08-31 20:56:17.708835743 +0200 +++ /var/tmp/diff_new_pack.zDgNuP/_new 2017-08-31 20:56:17.712835181 +0200 @@ -19,7 +19,7 @@ %global pkg_name hint %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.6.0 +Version: 0.7.0 Release: 0 Summary: Runtime Haskell interpreter (GHC API wrapper) License: BSD-3-Clause ++++++ hint-0.6.0.tar.gz -> hint-0.7.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/CHANGELOG.md new/hint-0.7.0/CHANGELOG.md --- old/hint-0.6.0/CHANGELOG.md 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/CHANGELOG.md 2017-06-13 11:27:30.000000000 +0200 @@ -1,3 +1,10 @@ +### 0.7.0 + +* Support for GHC 8.2 +* Support use in a dynamically-linked executable +* Add `normalizeType`, like ghci's :kind! +* Drop support for GHC 7.6 + ### 0.6.0 * Support for GHC 8.0 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/hint.cabal new/hint-0.7.0/hint.cabal --- old/hint-0.6.0/hint.cabal 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/hint.cabal 2017-06-13 11:27:30.000000000 +0200 @@ -1,5 +1,5 @@ name: hint -version: 0.6.0 +version: 0.7.0 description: This library defines an Interpreter monad. It allows to load Haskell modules, browse them, type-check and evaluate strings with Haskell @@ -30,7 +30,7 @@ type: git location: https://github.com/mvdan/hint -Test-Suite unit-tests +test-suite unit-tests type: exitcode-stdio-1.0 hs-source-dirs: unit-tests main-is: run-unit-tests.hs @@ -43,9 +43,9 @@ extensible-exceptions, exceptions -Library +library build-depends: base == 4.*, - ghc >= 7.6 && < 8.2, + ghc >= 7.6 && < 8.4, ghc-paths, mtl, filepath, @@ -63,7 +63,6 @@ other-modules: Hint.GHC Hint.Base Hint.InterpreterT - Hint.Compat Hint.CompatPlatform Hint.Configuration Hint.Extension diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Control/Monad/Ghc.hs new/hint-0.7.0/src/Control/Monad/Ghc.hs --- old/hint-0.6.0/src/Control/Monad/Ghc.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Control/Monad/Ghc.hs 2017-06-13 11:27:30.000000000 +0200 @@ -38,12 +38,6 @@ instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where liftIO = GhcT . GHC.liftIO -#if __GLASGOW_HASKELL__ < 708 - -- ghc started using transformers at some point -instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where - liftIO = MTL.liftIO -#endif - instance MonadCatch m => MonadThrow (GhcT m) where throwM = lift . throwM diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Base.hs new/hint-0.7.0/src/Hint/Base.hs --- old/hint-0.6.0/src/Hint/Base.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Base.hs 2017-06-13 11:27:30.000000000 +0200 @@ -34,10 +34,10 @@ -- | Version of the underlying ghc api. Values are: -- --- * @708@ for GHC 7.8.x --- -- * @710@ for GHC 7.10.x -- +-- * @800@ for GHC 8.0.x +-- -- * etc... ghcVersion :: Int ghcVersion = __GLASGOW_HASKELL__ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Compat.hs new/hint-0.7.0/src/Hint/Compat.hs --- old/hint-0.6.0/src/Hint/Compat.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Compat.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,34 +0,0 @@ -module Hint.Compat where - -import qualified Hint.GHC as GHC - --- Kinds became a synonym for Type in GHC 6.8. We define this wrapper --- to be able to define a FromGhcRep instance for both versions -newtype Kind = Kind GHC.Kind - -supportedExtensions :: [String] -supportedExtensions = map f GHC.xFlags - where -#if (__GLASGOW_HASKELL__ >= 710) - f = GHC.flagSpecName -#else - f (e,_,_) = e -#endif - -configureDynFlags :: GHC.DynFlags -> GHC.DynFlags -configureDynFlags dflags = dflags{GHC.ghcMode = GHC.CompManager, - GHC.hscTarget = GHC.HscInterpreted, - GHC.ghcLink = GHC.LinkInMemory, - GHC.verbosity = 0} - -parseDynamicFlags :: GHC.GhcMonad m - => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) -parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc - where firstTwo (a,b,_) = (a, map GHC.unLoc b) - -pprType :: GHC.Type -> GHC.SDoc -#if __GLASGOW_HASKELL__ < 708 -pprType = GHC.pprTypeForUser False -- False means drop explicit foralls -#else -pprType = GHC.pprTypeForUser -#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Configuration.hs new/hint-0.7.0/src/Hint/Configuration.hs --- old/hint-0.6.0/src/Hint/Configuration.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Configuration.hs 2017-06-13 11:27:30.000000000 +0200 @@ -8,7 +8,10 @@ languageExtensions, availableExtensions, Extension(..), installedModulesInScope, - searchPath + searchPath, + + configureDynFlags, parseDynamicFlags, + ) where import Control.Monad @@ -17,7 +20,6 @@ import Data.List (intercalate) import qualified Hint.GHC as GHC -import qualified Hint.Compat as Compat import Hint.Base import Hint.Util (quote) @@ -26,7 +28,7 @@ setGhcOptions :: MonadInterpreter m => [String] -> m () setGhcOptions opts = do old_flags <- runGhc GHC.getSessionDynFlags - (new_flags,not_parsed) <- runGhc2 Compat.parseDynamicFlags old_flags opts + (new_flags,not_parsed) <- runGhc2 parseDynamicFlags old_flags opts unless (null not_parsed) $ throwM $ UnknownError $ concat ["flags: ", unwords $ map quote not_parsed, @@ -127,3 +129,16 @@ => (InterpreterConfiguration -> InterpreterConfiguration) -> m () onConf f = onState $ \st -> st{configuration = f (configuration st)} + +configureDynFlags :: GHC.DynFlags -> GHC.DynFlags +configureDynFlags dflags = + (if GHC.dynamicGhc then GHC.addWay' GHC.WayDyn else id) + dflags{GHC.ghcMode = GHC.CompManager, + GHC.hscTarget = GHC.HscInterpreted, + GHC.ghcLink = GHC.LinkInMemory, + GHC.verbosity = 0} + +parseDynamicFlags :: GHC.GhcMonad m + => GHC.DynFlags -> [String] -> m (GHC.DynFlags, [String]) +parseDynamicFlags d = fmap firstTwo . GHC.parseDynamicFlags d . map GHC.noLoc + where firstTwo (a,b,_) = (a, map GHC.unLoc b) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Conversions.hs new/hint-0.7.0/src/Hint/Conversions.hs --- old/hint-0.6.0/src/Hint/Conversions.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Conversions.hs 2017-06-13 11:27:30.000000000 +0200 @@ -5,7 +5,6 @@ import qualified Hint.GHC as GHC import Hint.Base -import qualified Hint.Compat as Compat -- --------- Types / Kinds ----------------------- @@ -15,12 +14,12 @@ -- (i.e., do not expose internals) unqual <- runGhc GHC.getPrintUnqual withDynFlags $ \df -> - return $ GHC.showSDocForUser df unqual (Compat.pprType t) + return $ GHC.showSDocForUser df unqual (GHC.pprTypeForUser t) -kindToString :: MonadInterpreter m => Compat.Kind -> m String -kindToString (Compat.Kind k) +kindToString :: MonadInterpreter m => GHC.Kind -> m String +kindToString k = withDynFlags $ \df -> - return $ GHC.showSDoc df (Compat.pprType k) + return $ GHC.showSDoc df (GHC.pprTypeForUser k) -- ---------------- Modules -------------------------- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Extension.hs new/hint-0.7.0/src/Hint/Extension.hs --- old/hint-0.6.0/src/Hint/Extension.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Extension.hs 2017-06-13 11:27:30.000000000 +0200 @@ -1,14 +1,23 @@ -- this module was automatically generated. do not edit! -- edit util/mk_extensions_mod.hs instead module Hint.Extension ( - Extension(..), availableExtensions, asExtension + Extension(..), supportedExtensions, availableExtensions, asExtension ) where -import Hint.Compat as Compat +import qualified Hint.GHC as GHC + +supportedExtensions :: [String] +supportedExtensions = map f GHC.xFlags + where +#if (__GLASGOW_HASKELL__ >= 710) + f = GHC.flagSpecName +#else + f (e,_,_) = e +#endif -- | List of the extensions known by the interpreter. availableExtensions :: [Extension] -availableExtensions = map asExtension Compat.supportedExtensions +availableExtensions = map asExtension supportedExtensions asExtension :: String -> Extension asExtension s = if isKnown s @@ -139,6 +148,7 @@ | MonadFailDesugaring | TemplateHaskellQuotes | OverloadedLabels + | TypeFamilyDependencies | NoOverlappingInstances | NoUndecidableInstances | NoIncoherentInstances @@ -257,6 +267,7 @@ | NoMonadFailDesugaring | NoTemplateHaskellQuotes | NoOverloadedLabels + | NoTypeFamilyDependencies | UnknownExtension String deriving (Eq, Show, Read) @@ -379,6 +390,7 @@ MonadFailDesugaring, TemplateHaskellQuotes, OverloadedLabels, + TypeFamilyDependencies, NoOverlappingInstances, NoUndecidableInstances, NoIncoherentInstances, @@ -496,5 +508,6 @@ NoUndecidableSuperClasses, NoMonadFailDesugaring, NoTemplateHaskellQuotes, - NoOverloadedLabels + NoOverloadedLabels, + NoTypeFamilyDependencies ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/GHC.hs new/hint-0.7.0/src/Hint/GHC.hs --- old/hint-0.6.0/src/Hint/GHC.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/GHC.hs 2017-06-13 11:27:30.000000000 +0200 @@ -25,11 +25,15 @@ import DynFlags as X (xFlags, xopt, LogAction) #endif +#if __GLASGOW_HASKELL__ >= 800 +import DynFlags as X (WarnReason(NoReason)) +#endif + import PprTyThing as X (pprTypeForUser) import SrcLoc as X (mkRealSrcLoc) -#if __GLASGOW_HASKELL__ >= 708 import ConLike as X (ConLike(RealDataCon)) -#endif + +import DynFlags as X (addWay', Way(..), dynamicGhc) type Message = MsgDoc diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/InterpreterT.hs new/hint-0.7.0/src/Hint/InterpreterT.hs --- old/hint-0.6.0/src/Hint/InterpreterT.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/InterpreterT.hs 2017-06-13 11:27:30.000000000 +0200 @@ -25,7 +25,6 @@ import qualified GHC.Paths import qualified Hint.GHC as GHC -import qualified Hint.Compat as Compat type Interpreter = InterpreterT IO @@ -84,8 +83,8 @@ -- Set a custom log handler, to intercept error messages :S df0 <- runGhc GHC.getSessionDynFlags - let df1 = Compat.configureDynFlags df0 - (df2, extra) <- runGhc2 Compat.parseDynamicFlags df1 args + let df1 = configureDynFlags df0 + (df2, extra) <- runGhc2 parseDynamicFlags df1 args unless (null extra) $ throwM $ UnknownError (concat [ "flags: '" , unwords extra @@ -103,7 +102,7 @@ let toOpt e = let err = error ("init error: unknown ext:" ++ show e) in fromMaybe err (lookup e extMap) let getOptVal e = (asExtension e, GHC.xopt (toOpt e) df2) - let defExts = map getOptVal Compat.supportedExtensions + let defExts = map getOptVal supportedExtensions onState (\s -> s{defaultExts = defExts}) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Parsers.hs new/hint-0.7.0/src/Hint/Parsers.hs --- old/hint-0.6.0/src/Hint/Parsers.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Parsers.hs 2017-06-13 11:27:30.000000000 +0200 @@ -8,10 +8,6 @@ import qualified Hint.GHC as GHC -#if __GLASGOW_HASKELL__ >= 800 -import qualified DynFlags as GHC -#endif - data ParseResult = ParseOk | ParseError GHC.SrcSpan GHC.Message parseExpr :: MonadInterpreter m => String -> m ParseResult diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Reflection.hs new/hint-0.7.0/src/Hint/Reflection.hs --- old/hint-0.6.0/src/Hint/Reflection.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Reflection.hs 2017-06-13 11:27:30.000000000 +0200 @@ -47,11 +47,7 @@ ( [asModElem df c | c(a)(GHC.ATyCon c') <- xs, GHC.isClassTyCon c'], [asModElem df t | t(a)(GHC.ATyCon c') <- xs, (not . GHC.isClassTyCon) c'], -#if __GLASGOW_HASKELL__ < 708 - [asModElem df d | d(a)GHC.ADataCon{} <- xs], -#else [asModElem df d | d(a)(GHC.AConLike (GHC.RealDataCon{})) <- xs], -#endif [asModElem df f | f(a)GHC.AnId{} <- xs] ) cs' = [Class n $ filter (alsoIn fs) ms | Class n ms <- cs] @@ -60,11 +56,7 @@ asModElem :: GHC.DynFlags -> GHC.TyThing -> ModuleElem asModElem df (GHC.AnId f) = Fun $ getUnqualName df f -#if __GLASGOW_HASKELL__ < 708 -asModElem df (GHC.ADataCon dc) = Fun $ getUnqualName df dc -#else asModElem df (GHC.AConLike (GHC.RealDataCon dc)) = Fun $ getUnqualName df dc -#endif asModElem df (GHC.ATyCon tc) = if GHC.isClassTyCon tc then Class (getUnqualName df tc) (map (getUnqualName df) $ (GHC.classMethods . fromJust . GHC.tyConClass_maybe) tc) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Hint/Typecheck.hs new/hint-0.7.0/src/Hint/Typecheck.hs --- old/hint-0.6.0/src/Hint/Typecheck.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Hint/Typecheck.hs 2017-06-13 11:27:30.000000000 +0200 @@ -1,5 +1,5 @@ module Hint.Typecheck ( - typeOf, typeChecks, kindOf, + typeOf, typeChecks, kindOf, normalizeType ) where import Control.Monad.Catch @@ -8,7 +8,6 @@ import Hint.Parsers import Hint.Conversions -import qualified Hint.Compat as Compat import qualified Hint.GHC as GHC -- | Returns a string representation of the type of the expression. @@ -37,17 +36,34 @@ -- kind of errors failOnParseError parseType type_expr -- - kind <- mayFail $ runGhc1 typeKind type_expr + (_, kind) <- mayFail $ runGhc1 typeKind type_expr -- - kindToString (Compat.Kind kind) + kindToString kind + +-- | Returns a string representation of the normalized type expression. +-- This is what the @:kind!@ GHCi command prints after @=@. +normalizeType :: MonadInterpreter m => String -> m String +normalizeType type_expr = + do -- First, make sure the expression has no syntax errors, + -- for this is the only way we have to "intercept" this + -- kind of errors + failOnParseError parseType type_expr + -- + (ty, _) <- mayFail $ runGhc1 typeKind type_expr + -- + typeToString ty -- add a bogus Maybe, in order to use it with mayFail exprType :: GHC.GhcMonad m => String -> m (Maybe GHC.Type) +#if __GLASGOW_HASKELL__ < 802 exprType = fmap Just . GHC.exprType +#else +exprType = fmap Just . GHC.exprType GHC.TM_Inst +#endif -- add a bogus Maybe, in order to use it with mayFail -typeKind :: GHC.GhcMonad m => String -> m (Maybe GHC.Kind) -typeKind = fmap (Just . snd) . GHC.typeKind True +typeKind :: GHC.GhcMonad m => String -> m (Maybe (GHC.Type, GHC.Kind)) +typeKind = fmap Just . GHC.typeKind True onCompilationError :: MonadInterpreter m => ([GhcError] -> m a) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Language/Haskell/Interpreter/Unsafe.hs new/hint-0.7.0/src/Language/Haskell/Interpreter/Unsafe.hs --- old/hint-0.6.0/src/Language/Haskell/Interpreter/Unsafe.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Language/Haskell/Interpreter/Unsafe.hs 2017-06-13 11:27:30.000000000 +0200 @@ -38,7 +38,7 @@ -- containers, etc.) can be found. This allows you to run hint on -- a machine in which GHC is not installed. -- --- A typical libdir value would be "/opt/ghc/7.10.3/lib/ghc-7.10.3". +-- A typical libdir value could be "/usr/lib/ghc-8.0.1/ghc-8.0.1". unsafeRunInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m #if __GLASGOW_HASKELL__ < 800 , Functor m diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/src/Language/Haskell/Interpreter.hs new/hint-0.7.0/src/Language/Haskell/Interpreter.hs --- old/hint-0.6.0/src/Language/Haskell/Interpreter.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/src/Language/Haskell/Interpreter.hs 2017-06-13 11:27:30.000000000 +0200 @@ -34,7 +34,7 @@ -- pragmas inline in the code since GHC scarfs them up. getModuleAnnotations, getValAnnotations, -- ** Type inference - typeOf, typeChecks, kindOf, + typeOf, typeChecks, kindOf, normalizeType, -- ** Evaluation interpret, as, infer, eval, -- * Error handling diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hint-0.6.0/unit-tests/run-unit-tests.hs new/hint-0.7.0/unit-tests/run-unit-tests.hs --- old/hint-0.6.0/unit-tests/run-unit-tests.hs 2016-06-05 15:15:50.000000000 +0200 +++ new/hint-0.7.0/unit-tests/run-unit-tests.hs 2017-06-13 11:27:30.000000000 +0200 @@ -200,6 +200,19 @@ _ <- forkIO $ Control.Monad.void concurrent readMVar r @? "concurrent instance did not fail" +test_normalize_type :: TestCase +test_normalize_type = TestCase "normalize_type" [mod_file] $ do + liftIO $ writeFile mod_file mod_text + loadModules [mod_file] + setTopLevelModules ["T"] + normalizeType "Foo Int" @@?= "()" + + where mod_text = unlines ["{-# LANGUAGE TypeFamilies #-}" + ,"module T where" + ,"type family Foo x" + ,"type instance Foo x = ()"] + mod_file = "TEST_NormalizeType.hs" + tests :: [TestCase] tests = [test_reload_modified ,test_lang_exts @@ -215,6 +228,7 @@ ,test_search_path_dot ,test_catch ,test_only_one_instance + ,test_normalize_type ] main :: IO ()

1 0

commit ghc-hdaemonize for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hdaemonize for openSUSE:Factory checked in at 2017-08-31 20:56:13 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hdaemonize (Old) and /work/SRC/openSUSE:Factory/.ghc-hdaemonize.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hdaemonize" Thu Aug 31 20:56:13 2017 rev:4 rq:513378 version:0.5.4 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hdaemonize/ghc-hdaemonize.changes 2017-06-04 01:57:36.175069994 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hdaemonize.new/ghc-hdaemonize.changes 2017-08-31 20:56:14.733253822 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:49 UTC 2017 - psimons(a)suse.com + +- Update to version 0.5.4. + +------------------------------------------------------------------- Old: ---- hdaemonize-0.5.3.tar.gz New: ---- hdaemonize-0.5.4.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hdaemonize.spec ++++++ --- /var/tmp/diff_new_pack.ixZMsY/_old 2017-08-31 20:56:15.581134692 +0200 +++ /var/tmp/diff_new_pack.ixZMsY/_new 2017-08-31 20:56:15.605131321 +0200 @@ -18,7 +18,7 @@ %global pkg_name hdaemonize Name: ghc-%{pkg_name} -Version: 0.5.3 +Version: 0.5.4 Release: 0 Summary: Library to handle the details of writing daemons for UNIX License: BSD-3-Clause ++++++ hdaemonize-0.5.3.tar.gz -> hdaemonize-0.5.4.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdaemonize-0.5.3/System/Posix/Daemonize.hs new/hdaemonize-0.5.4/System/Posix/Daemonize.hs --- old/hdaemonize-0.5.3/System/Posix/Daemonize.hs 2017-05-14 11:07:37.000000000 +0200 +++ new/hdaemonize-0.5.4/System/Posix/Daemonize.hs 2017-05-29 00:46:01.000000000 +0200 @@ -6,41 +6,9 @@ -- * Building system services serviced, CreateDaemon(..), simpleDaemon, -- * Intradaemon utilities - fatalError, exitCleanly - -- * An example - -- - -- | Here is an example of a full program which writes a message to - -- syslog once a second proclaiming its continued existance, and - -- which installs its own SIGHUP handler. Note that you won't - -- actually see the message once a second in the log on most - -- systems. @syslogd@ detects repeated messages and prints the - -- first one, then delays for the rest and eventually writes a line - -- about how many times it has seen it. - -- - -- > {-# LANGUAGE OverloadedStrings #-} - -- > module Main where - -- > - -- > import System.Posix.Daemonize (CreateDaemon(..), serviced, simpleDaemon) - -- > import System.Posix.Signals (installHandler, Handler(Catch), sigHUP, fullSignalSet) - -- > import System.Posix.Syslog (syslogUnsafe, Facility(DAEMON), Priority(Notice)) - -- > import Control.Concurrent (threadDelay) - -- > import Control.Monad (forever) - -- > - -- > main :: IO () - -- > main = serviced stillAlive - -- > - -- > stillAlive :: CreateDaemon () - -- > stillAlive = simpleDaemon { program = stillAliveMain } - -- > - -- > stillAliveMain :: () -> IO () - -- > stillAliveMain _ = do - -- > installHandler sigHUP (Catch taunt) (Just fullSignalSet) - -- > forever $ do threadDelay (10^6) - -- > syslog DAEMON Notice "I'm still alive!" - -- > - -- > taunt :: IO () - -- > taunt = syslogUnsafe DAEMON Notice "I sneeze in your general direction, you and your SIGHUP." - + fatalError, exitCleanly, + -- * Logging utilities + syslog ) where {- originally based on code from @@ -64,15 +32,17 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Maybe (isNothing, fromMaybe, fromJust) import System.Environment import System.Exit import System.Posix -import System.Posix.Syslog (withSyslog,SyslogConfig(..),Option(..),Priority(..),PriorityMask(..),Facility(..),syslogUnsafe) +import System.Posix.Syslog (Priority(..), Facility(Daemon), Option, withSyslog) +import qualified System.Posix.Syslog as Log import System.FilePath.Posix (joinPath) syslog :: Priority -> ByteString -> IO () -syslog = syslogUnsafe DAEMON +syslog pri msg = unsafeUseAsCStringLen msg (Log.syslog (Just Daemon) pri) -- | Turning a process into a daemon involves a fixed set of -- operations on unix systems, described in section 13.3 of Stevens @@ -153,7 +123,7 @@ args <- getArgs process daemon' args where - program' daemon = withSyslog (SyslogConfig (ByteString.pack $ fromJust $ name daemon) (syslogOptions daemon) DAEMON NoMask) $ \_ -> + program' daemon = withSyslog (fromJust (name daemon)) (syslogOptions daemon) Daemon $ do let log = syslog Notice log "starting" pidWrite daemon diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hdaemonize-0.5.3/hdaemonize.cabal new/hdaemonize-0.5.4/hdaemonize.cabal --- old/hdaemonize-0.5.3/hdaemonize.cabal 2017-05-14 11:07:37.000000000 +0200 +++ new/hdaemonize-0.5.4/hdaemonize.cabal 2017-05-29 00:46:01.000000000 +0200 @@ -1,5 +1,5 @@ Name: hdaemonize -Version: 0.5.3 +Version: 0.5.4 Cabal-Version: >= 1.6 License: BSD3 License-file: LICENSE @@ -15,13 +15,13 @@ command line handling, dropping privileges). Build-Type: Simple Extra-Source-Files: README.md -Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 Library Build-Depends: base >= 4 && < 5 , bytestring , unix - , hsyslog == 4 + , hsyslog == 5.* , extensible-exceptions , filepath , mtl

1 0

commit ghc-hasql for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-hasql for openSUSE:Factory checked in at 2017-08-31 20:56:11 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hasql (Old) and /work/SRC/openSUSE:Factory/.ghc-hasql.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-hasql" Thu Aug 31 20:56:11 2017 rev:3 rq:513377 version:0.19.18 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hasql/ghc-hasql.changes 2017-03-15 02:00:13.584915044 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-hasql.new/ghc-hasql.changes 2017-08-31 20:56:11.977640995 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:04:31 UTC 2017 - psimons(a)suse.com + +- Update to version 0.19.18. + +------------------------------------------------------------------- Old: ---- hasql-0.19.16.tar.gz New: ---- hasql-0.19.18.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hasql.spec ++++++ --- /var/tmp/diff_new_pack.xJcWZj/_old 2017-08-31 20:56:13.229465109 +0200 +++ /var/tmp/diff_new_pack.xJcWZj/_new 2017-08-31 20:56:13.233464548 +0200 @@ -19,7 +19,7 @@ %global pkg_name hasql %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.19.16 +Version: 0.19.18 Release: 0 Summary: An efficient PostgreSQL driver and a flexible mapping API License: MIT @@ -27,11 +27,10 @@ Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: ghc-Cabal-devel -BuildRequires: ghc-aeson-devel BuildRequires: ghc-attoparsec-devel BuildRequires: ghc-base-prelude-devel BuildRequires: ghc-bytestring-devel -BuildRequires: ghc-bytestring-tree-builder-devel +BuildRequires: ghc-bytestring-strict-builder-devel BuildRequires: ghc-contravariant-devel BuildRequires: ghc-contravariant-extras-devel BuildRequires: ghc-data-default-class-devel @@ -46,12 +45,9 @@ BuildRequires: ghc-postgresql-libpq-devel BuildRequires: ghc-profunctors-devel BuildRequires: ghc-rpm-macros -BuildRequires: ghc-scientific-devel BuildRequires: ghc-semigroups-devel BuildRequires: ghc-text-devel -BuildRequires: ghc-time-devel BuildRequires: ghc-transformers-devel -BuildRequires: ghc-uuid-devel BuildRequires: ghc-vector-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} ++++++ hasql-0.19.16.tar.gz -> hasql-0.19.18.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/benchmark/Main/Prelude.hs new/hasql-0.19.18/benchmark/Main/Prelude.hs --- old/hasql-0.19.16/benchmark/Main/Prelude.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/benchmark/Main/Prelude.hs 2017-03-20 23:32:14.000000000 +0100 @@ -52,18 +52,6 @@ ------------------------- import Data.ByteString as Exports (ByteString) --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - -- vector ------------------------- import Data.Vector as Exports (Vector) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/hasql.cabal new/hasql-0.19.18/hasql.cabal --- old/hasql-0.19.16/hasql.cabal 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/hasql.cabal 2017-03-20 23:32:14.000000000 +0100 @@ -1,7 +1,7 @@ name: hasql version: - 0.19.16 + 0.19.18 category: Hasql, Database, PostgreSQL synopsis: @@ -74,18 +74,14 @@ -- parsing: attoparsec >= 0.10 && < 0.14, -- database: - postgresql-binary >= 0.9.1.1 && < 0.10, + postgresql-binary >= 0.12.1 && < 0.13, postgresql-libpq == 0.9.*, -- builders: - bytestring-tree-builder >= 0.2.5 && < 0.3, + bytestring-strict-builder >= 0.4 && < 0.5, -- data: dlist >= 0.7 && < 0.9, - aeson >= 0.7 && < 2, - uuid == 1.3.*, vector >= 0.10 && < 0.13, - time >= 1.4 && < 2, hashtables >= 1.1 && < 2, - scientific >= 0.2 && < 0.4, text >= 1 && < 2, bytestring >= 0.10 && < 0.11, hashable >= 1.2 && < 1.3, diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Decoders.hs new/hasql-0.19.18/library/Hasql/Decoders.hs --- old/hasql-0.19.16/library/Hasql/Decoders.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Decoders.hs 2017-03-20 23:32:14.000000000 +0100 @@ -37,6 +37,7 @@ timetz, interval, uuid, + inet, json, jsonBytes, jsonb, @@ -59,9 +60,9 @@ where import Hasql.Private.Prelude hiding (maybe, bool) -import qualified Data.Aeson as Aeson import qualified Data.Vector as Vector -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A +import qualified PostgreSQL.Binary.Data as B import qualified Hasql.Private.Decoders.Results as Results import qualified Hasql.Private.Decoders.Result as Result import qualified Hasql.Private.Decoders.Row as Row @@ -70,7 +71,6 @@ import qualified Hasql.Private.Decoders.Composite as Composite import qualified Hasql.Private.Prelude as Prelude - -- * Result ------------------------- @@ -272,7 +272,7 @@ {-# INLINABLE bool #-} bool :: Value Bool bool = - Value (Value.decoder (const Decoder.bool)) + Value (Value.decoder (const A.bool)) -- | -- Decoder of the @INT2@ values. @@ -280,7 +280,7 @@ {-# INLINABLE int2 #-} int2 :: Value Int16 int2 = - Value (Value.decoder (const Decoder.int)) + Value (Value.decoder (const A.int)) -- | -- Decoder of the @INT4@ values. @@ -288,7 +288,7 @@ {-# INLINABLE int4 #-} int4 :: Value Int32 int4 = - Value (Value.decoder (const Decoder.int)) + Value (Value.decoder (const A.int)) -- | -- Decoder of the @INT8@ values. @@ -297,7 +297,7 @@ int8 :: Value Int64 int8 = {-# SCC "int8" #-} - Value (Value.decoder (const ({-# SCC "int8.int" #-} Decoder.int))) + Value (Value.decoder (const ({-# SCC "int8.int" #-} A.int))) -- | -- Decoder of the @FLOAT4@ values. @@ -305,7 +305,7 @@ {-# INLINABLE float4 #-} float4 :: Value Float float4 = - Value (Value.decoder (const Decoder.float4)) + Value (Value.decoder (const A.float4)) -- | -- Decoder of the @FLOAT8@ values. @@ -313,15 +313,15 @@ {-# INLINABLE float8 #-} float8 :: Value Double float8 = - Value (Value.decoder (const Decoder.float8)) + Value (Value.decoder (const A.float8)) -- | -- Decoder of the @NUMERIC@ values. -- {-# INLINABLE numeric #-} -numeric :: Value Scientific +numeric :: Value B.Scientific numeric = - Value (Value.decoder (const Decoder.numeric)) + Value (Value.decoder (const A.numeric)) -- | -- Decoder of the @CHAR@ values. @@ -329,7 +329,7 @@ {-# INLINABLE char #-} char :: Value Char char = - Value (Value.decoder (const Decoder.char)) + Value (Value.decoder (const A.char)) -- | -- Decoder of the @TEXT@ values. @@ -337,7 +337,7 @@ {-# INLINABLE text #-} text :: Value Text text = - Value (Value.decoder (const Decoder.text_strict)) + Value (Value.decoder (const A.text_strict)) -- | -- Decoder of the @BYTEA@ values. @@ -345,23 +345,23 @@ {-# INLINABLE bytea #-} bytea :: Value ByteString bytea = - Value (Value.decoder (const Decoder.bytea_strict)) + Value (Value.decoder (const A.bytea_strict)) -- | -- Decoder of the @DATE@ values. -- {-# INLINABLE date #-} -date :: Value Day +date :: Value B.Day date = - Value (Value.decoder (const Decoder.date)) + Value (Value.decoder (const A.date)) -- | -- Decoder of the @TIMESTAMP@ values. -- {-# INLINABLE timestamp #-} -timestamp :: Value LocalTime +timestamp :: Value B.LocalTime timestamp = - Value (Value.decoder (Prelude.bool Decoder.timestamp_float Decoder.timestamp_int)) + Value (Value.decoder (Prelude.bool A.timestamp_float A.timestamp_int)) -- | -- Decoder of the @TIMESTAMPTZ@ values. @@ -374,17 +374,17 @@ -- However this library bypasses the silent conversions -- and communicates with Postgres using the UTC values directly. {-# INLINABLE timestamptz #-} -timestamptz :: Value UTCTime +timestamptz :: Value B.UTCTime timestamptz = - Value (Value.decoder (Prelude.bool Decoder.timestamptz_float Decoder.timestamptz_int)) + Value (Value.decoder (Prelude.bool A.timestamptz_float A.timestamptz_int)) -- | -- Decoder of the @TIME@ values. -- {-# INLINABLE time #-} -time :: Value TimeOfDay +time :: Value B.TimeOfDay time = - Value (Value.decoder (Prelude.bool Decoder.time_float Decoder.time_int)) + Value (Value.decoder (Prelude.bool A.time_float A.time_int)) -- | -- Decoder of the @TIMETZ@ values. @@ -395,33 +395,41 @@ -- that fits the task, so we use a pair of 'TimeOfDay' and 'TimeZone' -- to represent a value on the Haskell's side. {-# INLINABLE timetz #-} -timetz :: Value (TimeOfDay, TimeZone) +timetz :: Value (B.TimeOfDay, B.TimeZone) timetz = - Value (Value.decoder (Prelude.bool Decoder.timetz_float Decoder.timetz_int)) + Value (Value.decoder (Prelude.bool A.timetz_float A.timetz_int)) -- | -- Decoder of the @INTERVAL@ values. -- {-# INLINABLE interval #-} -interval :: Value DiffTime +interval :: Value B.DiffTime interval = - Value (Value.decoder (Prelude.bool Decoder.interval_float Decoder.interval_int)) + Value (Value.decoder (Prelude.bool A.interval_float A.interval_int)) -- | -- Decoder of the @UUID@ values. -- {-# INLINABLE uuid #-} -uuid :: Value UUID +uuid :: Value B.UUID uuid = - Value (Value.decoder (const Decoder.uuid)) + Value (Value.decoder (const A.uuid)) + +-- | +-- Decoder of the @INET@ values. +-- +{-# INLINABLE inet #-} +inet :: Value (B.NetAddr B.IP) +inet = + Value (Value.decoder (const A.inet)) -- | -- Decoder of the @JSON@ values into a JSON AST. -- {-# INLINABLE json #-} -json :: Value Aeson.Value +json :: Value B.Value json = - Value (Value.decoder (const Decoder.json_ast)) + Value (Value.decoder (const A.json_ast)) -- | -- Decoder of the @JSON@ values into a raw JSON 'ByteString'. @@ -429,15 +437,15 @@ {-# INLINABLE jsonBytes #-} jsonBytes :: (ByteString -> Either Text a) -> Value a jsonBytes fn = - Value (Value.decoder (const (Decoder.json_bytes fn))) + Value (Value.decoder (const (A.json_bytes fn))) -- | -- Decoder of the @JSONB@ values into a JSON AST. -- {-# INLINABLE jsonb #-} -jsonb :: Value Aeson.Value +jsonb :: Value B.Value jsonb = - Value (Value.decoder (const Decoder.jsonb_ast)) + Value (Value.decoder (const A.jsonb_ast)) -- | -- Decoder of the @JSONB@ values into a raw JSON 'ByteString'. @@ -445,7 +453,7 @@ {-# INLINABLE jsonbBytes #-} jsonbBytes :: (ByteString -> Either Text a) -> Value a jsonbBytes fn = - Value (Value.decoder (const (Decoder.jsonb_bytes fn))) + Value (Value.decoder (const (A.jsonb_bytes fn))) -- | -- Lifts a custom value decoder function to a 'Value' decoder. @@ -489,14 +497,14 @@ {-# INLINABLE hstore #-} hstore :: (forall m. Monad m => Int -> m (Text, Maybe Text) -> m a) -> Value a hstore replicateM = - Value (Value.decoder (const (Decoder.hstore replicateM Decoder.text_strict Decoder.text_strict))) + Value (Value.decoder (const (A.hstore replicateM A.text_strict A.text_strict))) -- | -- Given a partial mapping from text to value, -- produces a decoder of that value. enum :: (Text -> Maybe a) -> Value a enum mapping = - Value (Value.decoder (const (Decoder.enum mapping))) + Value (Value.decoder (const (A.enum mapping))) -- ** Instances @@ -546,7 +554,7 @@ -- | -- Maps to 'numeric'. -instance Default (Value Scientific) where +instance Default (Value B.Scientific) where {-# INLINE def #-} def = numeric @@ -574,56 +582,56 @@ -- | -- Maps to 'date'. -instance Default (Value Day) where +instance Default (Value B.Day) where {-# INLINE def #-} def = date -- | -- Maps to 'timestamp'. -instance Default (Value LocalTime) where +instance Default (Value B.LocalTime) where {-# INLINE def #-} def = timestamp -- | -- Maps to 'timestamptz'. -instance Default (Value UTCTime) where +instance Default (Value B.UTCTime) where {-# INLINE def #-} def = timestamptz -- | -- Maps to 'time'. -instance Default (Value TimeOfDay) where +instance Default (Value B.TimeOfDay) where {-# INLINE def #-} def = time -- | -- Maps to 'timetz'. -instance Default (Value (TimeOfDay, TimeZone)) where +instance Default (Value (B.TimeOfDay, B.TimeZone)) where {-# INLINE def #-} def = timetz -- | -- Maps to 'interval'. -instance Default (Value DiffTime) where +instance Default (Value B.DiffTime) where {-# INLINE def #-} def = interval -- | -- Maps to 'uuid'. -instance Default (Value UUID) where +instance Default (Value B.UUID) where {-# INLINE def #-} def = uuid -- | -- Maps to 'json'. -instance Default (Value Aeson.Value) where +instance Default (Value B.Value) where {-# INLINE def #-} def = json diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Encoders.hs new/hasql-0.19.18/library/Hasql/Encoders.hs --- old/hasql-0.19.16/library/Hasql/Encoders.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Encoders.hs 2017-03-20 23:32:14.000000000 +0100 @@ -26,6 +26,7 @@ timetz, interval, uuid, + inet, json, jsonBytes, jsonb, @@ -42,15 +43,14 @@ where import Hasql.Private.Prelude hiding (bool) -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Data.Aeson as Aeson +import qualified PostgreSQL.Binary.Encoding as A +import qualified PostgreSQL.Binary.Data as B import qualified Hasql.Private.Encoders.Params as Params import qualified Hasql.Private.Encoders.Value as Value import qualified Hasql.Private.Encoders.Array as Array import qualified Hasql.Private.PTI as PTI import qualified Hasql.Private.Prelude as Prelude - -- * Parameters Product Encoder ------------------------- @@ -185,49 +185,49 @@ {-# INLINABLE bool #-} bool :: Value Bool bool = - Value (Value.unsafePTI PTI.bool (const Encoder.bool)) + Value (Value.unsafePTI PTI.bool (const A.bool)) -- | -- Encoder of @INT2@ values. {-# INLINABLE int2 #-} int2 :: Value Int16 int2 = - Value (Value.unsafePTI PTI.int2 (const Encoder.int2_int16)) + Value (Value.unsafePTI PTI.int2 (const A.int2_int16)) -- | -- Encoder of @INT4@ values. {-# INLINABLE int4 #-} int4 :: Value Int32 int4 = - Value (Value.unsafePTI PTI.int4 (const Encoder.int4_int32)) + Value (Value.unsafePTI PTI.int4 (const A.int4_int32)) -- | -- Encoder of @INT8@ values. {-# INLINABLE int8 #-} int8 :: Value Int64 int8 = - Value (Value.unsafePTI PTI.int8 (const Encoder.int8_int64)) + Value (Value.unsafePTI PTI.int8 (const A.int8_int64)) -- | -- Encoder of @FLOAT4@ values. {-# INLINABLE float4 #-} float4 :: Value Float float4 = - Value (Value.unsafePTI PTI.float4 (const Encoder.float4)) + Value (Value.unsafePTI PTI.float4 (const A.float4)) -- | -- Encoder of @FLOAT8@ values. {-# INLINABLE float8 #-} float8 :: Value Double float8 = - Value (Value.unsafePTI PTI.float8 (const Encoder.float8)) + Value (Value.unsafePTI PTI.float8 (const A.float8)) -- | -- Encoder of @NUMERIC@ values. {-# INLINABLE numeric #-} -numeric :: Value Scientific +numeric :: Value B.Scientific numeric = - Value (Value.unsafePTI PTI.numeric (const Encoder.numeric)) + Value (Value.unsafePTI PTI.numeric (const A.numeric)) -- | -- Encoder of @CHAR@ values. @@ -236,98 +236,105 @@ {-# INLINABLE char #-} char :: Value Char char = - Value (Value.unsafePTI PTI.text (const Encoder.char)) + Value (Value.unsafePTI PTI.text (const A.char_utf8)) -- | -- Encoder of @TEXT@ values. {-# INLINABLE text #-} text :: Value Text text = - Value (Value.unsafePTI PTI.text (const Encoder.text_strict)) + Value (Value.unsafePTI PTI.text (const A.text_strict)) -- | -- Encoder of @BYTEA@ values. {-# INLINABLE bytea #-} bytea :: Value ByteString bytea = - Value (Value.unsafePTI PTI.bytea (const Encoder.bytea_strict)) + Value (Value.unsafePTI PTI.bytea (const A.bytea_strict)) -- | -- Encoder of @DATE@ values. {-# INLINABLE date #-} -date :: Value Day +date :: Value B.Day date = - Value (Value.unsafePTI PTI.date (const Encoder.date)) + Value (Value.unsafePTI PTI.date (const A.date)) -- | -- Encoder of @TIMESTAMP@ values. {-# INLINABLE timestamp #-} -timestamp :: Value LocalTime +timestamp :: Value B.LocalTime timestamp = - Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_float Encoder.timestamp_int)) + Value (Value.unsafePTI PTI.timestamp (Prelude.bool A.timestamp_float A.timestamp_int)) -- | -- Encoder of @TIMESTAMPTZ@ values. {-# INLINABLE timestamptz #-} -timestamptz :: Value UTCTime +timestamptz :: Value B.UTCTime timestamptz = - Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_float Encoder.timestamptz_int)) + Value (Value.unsafePTI PTI.timestamptz (Prelude.bool A.timestamptz_float A.timestamptz_int)) -- | -- Encoder of @TIME@ values. {-# INLINABLE time #-} -time :: Value TimeOfDay +time :: Value B.TimeOfDay time = - Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_float Encoder.time_int)) + Value (Value.unsafePTI PTI.time (Prelude.bool A.time_float A.time_int)) -- | -- Encoder of @TIMETZ@ values. {-# INLINABLE timetz #-} -timetz :: Value (TimeOfDay, TimeZone) +timetz :: Value (B.TimeOfDay, B.TimeZone) timetz = - Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_float Encoder.timetz_int)) + Value (Value.unsafePTI PTI.timetz (Prelude.bool A.timetz_float A.timetz_int)) -- | -- Encoder of @INTERVAL@ values. {-# INLINABLE interval #-} -interval :: Value DiffTime +interval :: Value B.DiffTime interval = - Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_float Encoder.interval_int)) + Value (Value.unsafePTI PTI.interval (Prelude.bool A.interval_float A.interval_int)) -- | -- Encoder of @UUID@ values. {-# INLINABLE uuid #-} -uuid :: Value UUID +uuid :: Value B.UUID uuid = - Value (Value.unsafePTI PTI.uuid (const Encoder.uuid)) + Value (Value.unsafePTI PTI.uuid (const A.uuid)) + +-- | +-- Encoder of @INET@ values. +{-# INLINABLE inet #-} +inet :: Value (B.NetAddr B.IP) +inet = + Value (Value.unsafePTI PTI.inet (const A.inet)) -- | -- Encoder of @JSON@ values from JSON AST. {-# INLINABLE json #-} -json :: Value Aeson.Value +json :: Value B.Value json = - Value (Value.unsafePTI PTI.json (const Encoder.json_ast)) + Value (Value.unsafePTI PTI.json (const A.json_ast)) -- | -- Encoder of @JSON@ values from raw JSON. {-# INLINABLE jsonBytes #-} jsonBytes :: Value ByteString jsonBytes = - Value (Value.unsafePTI PTI.json (const Encoder.json_bytes)) + Value (Value.unsafePTI PTI.json (const A.json_bytes)) -- | -- Encoder of @JSONB@ values from JSON AST. {-# INLINABLE jsonb #-} -jsonb :: Value Aeson.Value +jsonb :: Value B.Value jsonb = - Value (Value.unsafePTI PTI.jsonb (const Encoder.jsonb_ast)) + Value (Value.unsafePTI PTI.jsonb (const A.jsonb_ast)) -- | -- Encoder of @JSONB@ values from raw JSON. {-# INLINABLE jsonbBytes #-} jsonbBytes :: Value ByteString jsonbBytes = - Value (Value.unsafePTI PTI.jsonb (const Encoder.jsonb_bytes)) + Value (Value.unsafePTI PTI.jsonb (const A.jsonb_bytes)) -- | -- Unlifts the 'Array' encoder to the plain 'Value' encoder. @@ -344,7 +351,7 @@ {-# INLINABLE enum #-} enum :: (a -> Text) -> Value a enum mapping = - Value (Value.unsafePTI PTI.text (const (Encoder.enum mapping))) + Value (Value.unsafePTI PTI.text (const (A.text_strict . mapping))) -- | -- Identifies the value with the PostgreSQL's \"unknown\" type, @@ -361,7 +368,7 @@ {-# INLINABLE unknown #-} unknown :: Value ByteString unknown = - Value (Value.unsafePTI PTI.unknown (const Encoder.bytea_strict)) + Value (Value.unsafePTI PTI.unknown (const A.bytea_strict)) -- ** Instances @@ -404,7 +411,7 @@ float8 -- | Maps to 'numeric'. -instance Default (Value Scientific) where +instance Default (Value B.Scientific) where {-# INLINE def #-} def = numeric @@ -428,49 +435,49 @@ bytea -- | Maps to 'date'. -instance Default (Value Day) where +instance Default (Value B.Day) where {-# INLINE def #-} def = date -- | Maps to 'timestamp'. -instance Default (Value LocalTime) where +instance Default (Value B.LocalTime) where {-# INLINE def #-} def = timestamp -- | Maps to 'timestamptz'. -instance Default (Value UTCTime) where +instance Default (Value B.UTCTime) where {-# INLINE def #-} def = timestamptz -- | Maps to 'time'. -instance Default (Value TimeOfDay) where +instance Default (Value B.TimeOfDay) where {-# INLINE def #-} def = time -- | Maps to 'timetz'. -instance Default (Value (TimeOfDay, TimeZone)) where +instance Default (Value (B.TimeOfDay, B.TimeZone)) where {-# INLINE def #-} def = timetz -- | Maps to 'interval'. -instance Default (Value DiffTime) where +instance Default (Value B.DiffTime) where {-# INLINE def #-} def = interval -- | Maps to 'uuid'. -instance Default (Value UUID) where +instance Default (Value B.UUID) where {-# INLINE def #-} def = uuid -- | Maps to 'json'. -instance Default (Value Aeson.Value) where +instance Default (Value B.Value) where {-# INLINE def #-} def = json diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Decoders/Array.hs new/hasql-0.19.18/library/Hasql/Private/Decoders/Array.hs --- old/hasql-0.19.16/library/Hasql/Private/Decoders/Array.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Decoders/Array.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,31 +1,30 @@ module Hasql.Private.Decoders.Array where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A newtype Array a = - Array (ReaderT Bool Decoder.ArrayDecoder a) + Array (ReaderT Bool A.Array a) deriving (Functor) {-# INLINE run #-} -run :: Array a -> Bool -> Decoder.Decoder a +run :: Array a -> Bool -> A.Value a run (Array imp) env = - Decoder.array (runReaderT imp env) + A.array (runReaderT imp env) {-# INLINE dimension #-} dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b dimension replicateM (Array imp) = - Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env) + Array $ ReaderT $ \env -> A.dimensionArray replicateM (runReaderT imp env) {-# INLINE value #-} -value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a) +value :: (Bool -> A.Value a) -> Array (Maybe a) value decoder' = - Array $ ReaderT $ Decoder.arrayValue . decoder' + Array $ ReaderT $ A.nullableValueArray . decoder' {-# INLINE nonNullValue #-} -nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a +nonNullValue :: (Bool -> A.Value a) -> Array a nonNullValue decoder' = - Array $ ReaderT $ Decoder.arrayNonNullValue . decoder' + Array $ ReaderT $ A.valueArray . decoder' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Decoders/Composite.hs new/hasql-0.19.18/library/Hasql/Private/Decoders/Composite.hs --- old/hasql-0.19.16/library/Hasql/Private/Decoders/Composite.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Decoders/Composite.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,26 +1,25 @@ module Hasql.Private.Decoders.Composite where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A newtype Composite a = - Composite (ReaderT Bool Decoder.CompositeDecoder a) + Composite (ReaderT Bool A.Composite a) deriving (Functor, Applicative, Monad) {-# INLINE run #-} -run :: Composite a -> Bool -> Decoder.Decoder a +run :: Composite a -> Bool -> A.Value a run (Composite imp) env = - Decoder.composite (runReaderT imp env) + A.composite (runReaderT imp env) {-# INLINE value #-} -value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a) +value :: (Bool -> A.Value a) -> Composite (Maybe a) value decoder' = - Composite $ ReaderT $ Decoder.compositeValue . decoder' + Composite $ ReaderT $ A.nullableValueComposite . decoder' {-# INLINE nonNullValue #-} -nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a +nonNullValue :: (Bool -> A.Value a) -> Composite a nonNullValue decoder' = - Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder' + Composite $ ReaderT $ A.valueComposite . decoder' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Decoders/Row.hs new/hasql-0.19.18/library/Hasql/Private/Decoders/Row.hs --- old/hasql-0.19.16/library/Hasql/Private/Decoders/Row.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Decoders/Row.hs 2017-03-20 23:32:14.000000000 +0100 @@ -2,7 +2,7 @@ import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A import qualified Hasql.Private.Decoders.Value as Value @@ -53,7 +53,7 @@ Right Nothing Just value -> fmap Just $ mapLeft ValueError $ - {-# SCC "decode" #-} Decoder.run (Value.run valueDec integerDatetimes) value + {-# SCC "decode" #-} A.valueParser (Value.run valueDec integerDatetimes) value else pure (Left EndOfInput) -- | diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Decoders/Value.hs new/hasql-0.19.18/library/Hasql/Private/Decoders/Value.hs --- old/hasql-0.19.16/library/Hasql/Private/Decoders/Value.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Decoders/Value.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,22 +1,21 @@ module Hasql.Private.Decoders.Value where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified PostgreSQL.Binary.Decoding as A newtype Value a = - Value (ReaderT Bool Decoder.Decoder a) + Value (ReaderT Bool A.Value a) deriving (Functor) {-# INLINE run #-} -run :: Value a -> Bool -> Decoder.Decoder a +run :: Value a -> Bool -> A.Value a run (Value imp) integerDatetimes = runReaderT imp integerDatetimes {-# INLINE decoder #-} -decoder :: (Bool -> Decoder.Decoder a) -> Value a +decoder :: (Bool -> A.Value a) -> Value a decoder = {-# SCC "decoder" #-} Value . ReaderT @@ -24,5 +23,5 @@ {-# INLINE decoderFn #-} decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a decoderFn fn = - Value $ ReaderT $ \integerDatetimes -> Decoder.fn $ fn integerDatetimes + Value $ ReaderT $ \integerDatetimes -> A.fn $ fn integerDatetimes diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Encoders/Array.hs new/hasql-0.19.18/library/Hasql/Private/Encoders/Array.hs --- old/hasql-0.19.16/library/Hasql/Private/Encoders/Array.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Encoders/Array.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,31 +1,30 @@ module Hasql.Private.Encoders.Array where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Hasql.Private.PTI as PTI +import qualified PostgreSQL.Binary.Encoding as A +import qualified Hasql.Private.PTI as B data Array a = - Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a) + Array B.OID B.OID (Bool -> a -> A.Array) {-# INLINE run #-} -run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a) -run (Array valueOID arrayOID encoder') = - (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env)) +run :: Array a -> (B.OID, Bool -> a -> A.Encoding) +run (Array valueOID arrayOID encoder) = + (arrayOID, \env input -> A.array (B.oidWord32 valueOID) (encoder env input)) {-# INLINE value #-} -value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a -value valueOID arrayOID encoder' = - Array valueOID arrayOID (Encoder.arrayValue . encoder') +value :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array a +value valueOID arrayOID encoder = + Array valueOID arrayOID (\params -> A.encodingArray . encoder params) {-# INLINE nullableValue #-} -nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a) -nullableValue valueOID arrayOID encoder' = - Array valueOID arrayOID (Encoder.arrayNullableValue . encoder') +nullableValue :: B.OID -> B.OID -> (Bool -> a -> A.Encoding) -> Array (Maybe a) +nullableValue valueOID arrayOID encoder = + Array valueOID arrayOID (\params -> maybe A.nullArray (A.encodingArray . encoder params)) {-# INLINE dimension #-} dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c -dimension foldl (Array valueOID arrayOID encoder') = - Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder') +dimension fold (Array valueOID arrayOID encoder) = + Array valueOID arrayOID (\params -> A.dimensionArray fold (encoder params)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Encoders/Params.hs new/hasql-0.19.18/library/Hasql/Private/Encoders/Params.hs --- old/hasql-0.19.16/library/Hasql/Private/Encoders/Params.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Encoders/Params.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,26 +1,26 @@ module Hasql.Private.Encoders.Params where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Hasql.Private.Encoders.Value as Value -import qualified Hasql.Private.PTI as PTI +import qualified Database.PostgreSQL.LibPQ as A +import qualified PostgreSQL.Binary.Encoding as B +import qualified Hasql.Private.Encoders.Value as C +import qualified Hasql.Private.PTI as D -- | -- Encoder of some representation of a parameters product. newtype Params a = - Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a) + Params (Op (DList (A.Oid, Bool -> Maybe ByteString)) a) deriving (Contravariant, Divisible, Decidable, Monoid) instance Semigroup (Params a) -run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString) +run :: Params a -> a -> DList (A.Oid, Bool -> Maybe ByteString) run (Params (Op op)) params = {-# SCC "run" #-} op params -run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)]) +run' :: Params a -> a -> Bool -> ([A.Oid], [Maybe (ByteString, A.Format)]) run' (Params (Op op)) params integerDatetimes = {-# SCC "run'" #-} foldr step ([], []) (op params) @@ -28,9 +28,9 @@ step (oid, bytesGetter) ~(oidList, bytesAndFormatList) = (,) (oid : oidList) - (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList) + (fmap (\bytes -> (bytes, A.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList) -run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] +run'' :: Params a -> a -> Bool -> [Maybe (A.Oid, ByteString, A.Format)] run'' (Params (Op op)) params integerDatetimes = {-# SCC "run''" #-} foldr step [] (op params) @@ -39,13 +39,13 @@ mapping a : b where mapping (oid, bytesGetter) = - (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary + (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure A.Binary -value :: Value.Value a -> Params a +value :: C.Value a -> Params a value = contramap Just . nullableValue -nullableValue :: Value.Value a -> Params (Maybe a) -nullableValue (Value.Value valueOID arrayOID encoder') = +nullableValue :: C.Value a -> Params (Maybe a) +nullableValue (C.Value valueOID arrayOID encoder) = Params $ Op $ \input -> - pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input) + pure (D.oidPQ valueOID, \env -> fmap (B.encodingBytes . encoder env) input) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Encoders/Value.hs new/hasql-0.19.18/library/Hasql/Private/Encoders/Value.hs --- old/hasql-0.19.16/library/Hasql/Private/Encoders/Value.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Encoders/Value.hs 2017-03-20 23:32:14.000000000 +0100 @@ -1,13 +1,12 @@ module Hasql.Private.Encoders.Value where import Hasql.Private.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified PostgreSQL.Binary.Encoding as B import qualified Hasql.Private.PTI as PTI data Value a = - Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a) + Value PTI.OID PTI.OID (Bool -> a -> B.Encoding) instance Contravariant Value where {-# INLINE contramap #-} @@ -15,12 +14,12 @@ Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input)) {-# INLINE run #-} -run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a) +run :: Value a -> (PTI.OID, PTI.OID, Bool -> a -> B.Encoding) run (Value valueOID arrayOID encoder') = (valueOID, arrayOID, encoder') {-# INLINE unsafePTI #-} -unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a +unsafePTI :: PTI.PTI -> (Bool -> a -> B.Encoding) -> Value a unsafePTI pti encoder' = Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/Prelude.hs new/hasql-0.19.18/library/Hasql/Private/Prelude.hs --- old/hasql-0.19.16/library/Hasql/Private/Prelude.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/Prelude.hs 2017-03-20 23:32:14.000000000 +0100 @@ -16,7 +16,7 @@ -- base-prelude ------------------------- -import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error, (<>), First(..), Last(..)) +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error, (<>), First(..), Last(..), new) -- transformers ------------------------- @@ -69,18 +69,6 @@ ------------------------- import Data.ByteString as Exports (ByteString) --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - -- vector ------------------------- import Data.Vector as Exports (Vector) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hasql-0.19.16/library/Hasql/Private/PreparedStatementRegistry.hs new/hasql-0.19.18/library/Hasql/Private/PreparedStatementRegistry.hs --- old/hasql-0.19.16/library/Hasql/Private/PreparedStatementRegistry.hs 2017-01-31 17:36:30.000000000 +0100 +++ new/hasql-0.19.18/library/Hasql/Private/PreparedStatementRegistry.hs 2017-03-20 23:32:14.000000000 +0100 @@ -9,7 +9,7 @@ import Hasql.Private.Prelude hiding (lookup) import qualified Data.HashTable.IO as A -import qualified ByteString.TreeBuilder as B +import qualified ByteString.StrictBuilder as B data PreparedStatementRegistry = @@ -39,7 +39,7 @@ return result where remoteKey = - B.toByteString . B.asciiIntegral $ n + B.builderBytes . B.asciiIntegral $ n old = onOldRemoteKey

1 0

commit ghc-haskell-tools-rewrite for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-rewrite for openSUSE:Factory checked in at 2017-08-31 20:56:09 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-rewrite (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-rewrite.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-rewrite" Thu Aug 31 20:56:09 2017 rev:2 rq:513376 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-rewrite/ghc-haskell-tools-rewrite.changes 2017-04-12 18:06:47.681889994 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-rewrite.new/ghc-haskell-tools-rewrite.changes 2017-08-31 20:56:10.933787661 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:37 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-rewrite-0.5.0.0.tar.gz New: ---- haskell-tools-rewrite-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-rewrite.spec ++++++ --- /var/tmp/diff_new_pack.TeA7qa/_old 2017-08-31 20:56:11.645687635 +0200 +++ /var/tmp/diff_new_pack.TeA7qa/_new 2017-08-31 20:56:11.645687635 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-rewrite %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Facilities for generating new parts of the Haskell-Tools AST License: BSD-3-Clause ++++++ haskell-tools-rewrite-0.5.0.0.tar.gz -> haskell-tools-rewrite-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/ElementTypes.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/ElementTypes.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/ElementTypes.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/ElementTypes.hs 2017-05-03 22:13:56.000000000 +0200 @@ -2,8 +2,8 @@ import Language.Haskell.Tools.AST -type AnnList node dom = AnnListG node dom SrcTemplateStage -type AnnMaybe node dom = AnnMaybeG node dom SrcTemplateStage +type AnnList node dom = AnnListG node dom SrcTemplateStage +type AnnMaybe node dom = AnnMaybeG node dom SrcTemplateStage -- * Modules @@ -26,13 +26,13 @@ -- | Marks how related names will be imported or exported with a given name type SubSpec dom = Ann USubSpec dom SrcTemplateStage --- | Pragmas that must be used after the module head +-- | Pragmas that must be used after the module head type ModulePragma dom = Ann UModulePragma dom SrcTemplateStage --- | Pragmas that must be used before defining the module +-- | Pragmas that must be used before defining the module type FilePragma dom = Ann UFilePragma dom SrcTemplateStage --- | An import declaration: @import Module.Name@ +-- | An import declaration: @import Module.Name@ type ImportDecl dom = Ann UImportDecl dom SrcTemplateStage -- | Restriction on the imported names @@ -67,7 +67,7 @@ -- | The list of declarations that can appear in a typeclass type ClassBody dom = Ann UClassBody dom SrcTemplateStage --- | Members of a class declaration +-- | Members of a class declaration type ClassElement dom = Ann UClassElement dom SrcTemplateStage -- The declared (possibly parameterized) type (@ A x :+: B y @). @@ -88,10 +88,10 @@ -- | Marker for a field wildcard. Only needed to attach semantic information in a type-safe way. type FieldWildcard dom = Ann UFieldWildcard dom SrcTemplateStage --- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas +-- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas type FunDeps dom = Ann UFunDeps dom SrcTemplateStage --- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ +-- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ type FunDep dom = Ann UFunDep dom SrcTemplateStage -- | A constructor declaration for a datatype @@ -112,7 +112,7 @@ -- | The specification of the class instance declaration type InstanceHead dom = Ann UInstanceHead dom SrcTemplateStage --- | Overlap pragmas. Can be applied to class declarations and class instance declarations. +-- | Overlap pragmas. Can be applied to class declarations and class instance declarations. type OverlapPragma dom = Ann UOverlapPragma dom SrcTemplateStage -- | Type equations as found in closed type families (@ T A = S @) @@ -124,7 +124,10 @@ -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) type Rule dom = Ann URule dom SrcTemplateStage --- | Annotation allows you to connect an expression to any declaration. +-- | A variable for a rewrite rule. With or without type signature. +type RuleVar dom = Ann URuleVar dom SrcTemplateStage + +-- | Annotation allows you to connect an expression to any declaration. type AnnotationSubject dom = Ann UAnnotationSubject dom SrcTemplateStage -- | Formulas of minimal annotations declaring which functions should be defined. @@ -177,7 +180,7 @@ -- | Value binding for top-level and local bindings type ValueBind dom = Ann UValueBind dom SrcTemplateStage --- | Clause of function binding +-- | Clause of function binding type Match dom = Ann UMatch dom SrcTemplateStage -- | Something on the left side of the match @@ -186,7 +189,7 @@ -- | Right hand side of a value binding (possible with guards): (@ = 3 @ or @ | x == 1 = 3; | otherwise = 4 @) type Rhs dom = Ann URhs dom SrcTemplateStage --- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) type GuardedRhs dom = Ann UGuardedRhs dom SrcTemplateStage -- | Guards for value bindings and pattern matches (@ Just v <- x, v > 1 @) @@ -195,7 +198,7 @@ -- | Bindings that are enabled in local blocks (where or let). type LocalBind dom = Ann ULocalBind dom SrcTemplateStage --- | Local bindings attached to a declaration (@ where x = 42 @) +-- | Local bindings attached to a declaration (@ where x = 42 @) type LocalBinds dom = Ann ULocalBinds dom SrcTemplateStage -- | A fixity signature (@ infixl 5 +, - @). @@ -241,7 +244,7 @@ -- | Right hand side of a match (possible with guards): (@ -> 3 @ or @ | x == 1 -> 3; | otherwise -> 4 @) type CaseRhs dom = Ann UCaseRhs dom SrcTemplateStage --- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) +-- | A guarded right-hand side of pattern matches binding (@ | x > 3 -> 2 @) type GuardedCaseRhs dom = Ann UGuardedCaseRhs dom SrcTemplateStage -- | Field update expressions @@ -289,13 +292,13 @@ -- * Template Haskell --- | A template haskell splice +-- | A template haskell splice type Splice dom = Ann USplice dom SrcTemplateStage -- | Template Haskell bracket expressions type Bracket dom = Ann UBracket dom SrcTemplateStage --- | Template haskell quasi-quotation: @[quoter|str]@ +-- | Template haskell quasi-quotation: @[quoter|str]@ type QuasiQuote dom = Ann UQuasiQuote dom SrcTemplateStage -- * Literals @@ -315,7 +318,7 @@ -- Linear implicit parameter: @%x@. Non-linear implicit parameter: @?x@. type QualifiedName dom = Ann UQualifiedName dom SrcTemplateStage --- | Parts of a qualified name. +-- | Parts of a qualified name. type NamePart dom = Ann UNamePart dom SrcTemplateStage -- | Program elements formatted as string literals (import packages, pragma texts) @@ -381,6 +384,7 @@ type AssertionList dom = AnnList UAssertion dom type CompStmtList dom = AnnList UCompStmt dom type RuleList dom = AnnList URule dom +type RuleVarList dom = AnnList URuleVar dom type RoleList dom = AnnList URole dom type MinimalFormulaList dom = AnnList UMinimalFormula dom type FunDepList dom = AnnList UFunDep dom diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Binds.hs 2017-05-03 22:13:56.000000000 +0200 @@ -29,10 +29,10 @@ mkFunctionBind' :: Name dom -> [([Pattern dom], Expr dom)] -> ValueBind dom mkFunctionBind' name matches = mkFunctionBind $ map (\(args, rhs) -> mkMatch (mkMatchLhs name args) (mkUnguardedRhs rhs) Nothing) matches --- | Creates a clause of function binding +-- | Creates a clause of function binding mkMatch :: MatchLhs dom -> Rhs dom -> Maybe (LocalBinds dom) -> Match dom -mkMatch lhs rhs locs - = mkAnn (child <> child <> child) +mkMatch lhs rhs locs + = mkAnn (child <> child <> child) $ UMatch lhs rhs (mkAnnMaybe (after " " opt) locs) -- | Creates a match lhs with the function name and parameter names (@ f a b @) @@ -41,12 +41,11 @@ -- | Creates an infix match lhs for an operator (@ a + b @) mkInfixLhs :: Pattern dom -> Operator dom -> Pattern dom -> [Pattern dom] -> MatchLhs dom -mkInfixLhs lhs op rhs pats +mkInfixLhs lhs op rhs pats = mkAnn (child <> child <> child <> child) $ UInfixLhs lhs op rhs (mkAnnList (after " " $ separatedBy " " list) pats) -- | Local bindings attached to a declaration (@ where x = 42 @) mkLocalBinds :: [LocalBind dom] -> MaybeLocalBinds dom --- TODO: make the indentation automatic mkLocalBinds = mkAnnMaybe (relativeIndented 2 $ after "\nwhere " opt) . Just . mkAnn child . ULocalBinds . mkAnnList (indented list) @@ -71,17 +70,17 @@ -- | Creates a left-associative fixity declaration (@ infixl 5 +, - @). mkInfixL :: Int -> Operator dom -> FixitySignature dom -mkInfixL prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfixL prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infixl" AssocLeft) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates a right-associative fixity declaration (@ infixr 5 +, - @). mkInfixR :: Int -> Operator dom -> FixitySignature dom -mkInfixR prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfixR prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infixr" AssocRight) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates a non-associative fixity declaration (@ infix 5 +, - @). mkInfix :: Int -> Operator dom -> FixitySignature dom -mkInfix prec op = mkAnn (child <> " " <> child <> " " <> child) +mkInfix prec op = mkAnn (child <> " " <> child <> " " <> child) $ UFixitySignature (mkAnn "infix" AssocNone) (mkAnnMaybe opt $ Just $ mkAnn (fromString (show prec)) (Precedence prec)) (mkAnnList (separatedBy ", " list) [op]) -- | Creates an unguarded right-hand-side (@ = 3 @) @@ -92,7 +91,7 @@ mkGuardedRhss :: [GuardedRhs dom] -> Rhs dom mkGuardedRhss = mkAnn child . UGuardedRhss . mkAnnList (indented list) --- | Creates a guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | Creates a guarded right-hand side of a value binding (@ | x > 3 = 2 @) mkGuardedRhs :: [RhsGuard dom] -> Expr dom -> GuardedRhs dom mkGuardedRhs guards expr = mkAnn ("| " <> child <> " = " <> child) $ UGuardedRhs (mkAnnList (separatedBy ", " list) guards) expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Decls.hs 2017-05-17 13:32:17.000000000 +0200 @@ -8,16 +8,16 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.ElementTypes -import Language.Haskell.Tools.AST.Gen.Utils (mkAnn, mkAnnList, mkAnnMaybe) +import Language.Haskell.Tools.AST.Gen.Utils import Language.Haskell.Tools.Transform -- | Creates a type synonym ( @type String = [Char]@ ) -mkTypeDecl :: DeclHead dom -> Type dom -> Decl dom +mkTypeDecl :: DeclHead dom -> Type dom -> Decl dom mkTypeDecl dh typ = mkAnn (child <> " :: " <> child) $ UTypeDecl dh typ -- | Creates a standalone deriving declaration (@ deriving instance X T @) mkStandaloneDeriving :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Decl dom -mkStandaloneDeriving overlap instRule = mkAnn ("deriving instance" <> child <> child) +mkStandaloneDeriving overlap instRule = mkAnn ("deriving instance" <> child <> child) $ UDerivDecl (mkAnnMaybe (after " " opt) overlap) instRule -- | Creates a fixity declaration (@ infixl 5 +, - @) @@ -44,44 +44,45 @@ -- | Creates a data or newtype declaration. mkDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkDataDecl keyw ctx dh cons derivs - = mkAnn (child <> " " <> child <> child <> child <> child) - $ UDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh +mkDataDecl keyw ctx dh cons derivs + = mkAnn (child <> " " <> child <> child <> child <> child) + $ UDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT-style data or newtype declaration. mkGADTDataDecl :: DataOrNewtypeKeyword dom -> Maybe (Context dom) -> DeclHead dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkGADTDataDecl keyw ctx dh kind cons derivs - = mkAnn (child <> " " <> child <> child <> child <> child <> child) - $ UGDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh - (mkAnnMaybe (after " " opt) kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkGADTDataDecl keyw ctx dh kind cons derivs + = mkAnn (child <> " " <> child <> child <> child <> child <> child) + $ UGDataDecl keyw (mkAnnMaybe (after " " opt) ctx) dh + (mkAnnMaybe (after " " opt) kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT constructor declaration (@ D1 :: Int -> T String @) mkGadtConDecl :: [Name dom] -> Type dom -> GadtConDecl dom -mkGadtConDecl names typ = mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) - (mkAnn child $ UGadtNormalType typ) +mkGadtConDecl names typ + = mkAnn (child <> " :: " <> child <> child <> child) + $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) emptyList noth (mkAnn child $ UGadtNormalType typ) -- | Creates a GADT constructor declaration with record syntax (@ D1 :: { val :: Int } -> T String @) mkGadtRecordConDecl :: [Name dom] -> [FieldDecl dom] -> Type dom -> GadtConDecl dom -mkGadtRecordConDecl names flds typ - = mkAnn (child <> " :: " <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) - $ mkAnn (child <> " -> " <> child) +mkGadtRecordConDecl names flds typ + = mkAnn (child <> " :: " <> child <> child <> child) $ UGadtConDecl (mkAnnList (separatedBy ", " list) names) emptyList noth + $ mkAnn (child <> " -> " <> child) $ UGadtRecordType (mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) flds) typ -- | Creates an ordinary data constructor (@ C t1 t2 @) mkConDecl :: Name dom -> [Type dom] -> ConDecl dom -mkConDecl name args = mkAnn (child <> child) $ UConDecl name (mkAnnList (after " " $ separatedBy " " $ list) args) +mkConDecl name args = mkAnn (child <> child <> child <> child) $ UConDecl emptyList noth name (mkAnnList (after " " $ separatedBy " " $ list) args) -- | Creates a record data constructor (@ Point { x :: Double, y :: Double } @) mkRecordConDecl :: Name dom -> [FieldDecl dom] -> ConDecl dom -mkRecordConDecl name fields - = mkAnn (child <> " { " <> child <> " }") $ URecordDecl name (mkAnnList (separatedBy ", " list) fields) +mkRecordConDecl name fields + = mkAnn (child <> child <> child <> " { " <> child <> " }") $ URecordDecl emptyList noth name (mkAnnList (separatedBy ", " list) fields) -- | Creates an infix data constructor (@ t1 :+: t2 @) mkInfixConDecl :: Type dom -> Operator dom -> Type dom -> ConDecl dom -mkInfixConDecl lhs op rhs = mkAnn (child <> " " <> child <> " " <> child) $ UInfixConDecl lhs op rhs +mkInfixConDecl lhs op rhs = mkAnn (child <> child <> child <> " " <> child <> " " <> child) $ UInfixConDecl emptyList noth lhs op rhs -- | Creates a field declaration (@ fld :: Int @) for a constructor mkFieldDecl :: [Name dom] -> Type dom -> FieldDecl dom @@ -104,11 +105,11 @@ -- | Creates a type class declaration (@ class X a where f = ... @) mkClassDecl :: Maybe (Context dom) -> DeclHead dom -> [FunDep dom] -> Maybe (ClassBody dom) -> Decl dom -mkClassDecl ctx dh funDeps body +mkClassDecl ctx dh funDeps body = let fdeps = case funDeps of [] -> Nothing _ -> Just $ mkAnn child $ UFunDeps $ mkAnnList (separatedBy ", " list) funDeps - in mkAnn ("class " <> child <> child <> child <> child) - $ UClassDecl (mkAnnMaybe (followedBy " " opt) ctx) dh (mkAnnMaybe (after " | " opt) fdeps) (mkAnnMaybe opt body) + in mkAnn ("class " <> child <> child <> child <> child) + $ UClassDecl (mkAnnMaybe (followedBy " " opt) ctx) dh (mkAnnMaybe (after " | " opt) fdeps) (mkAnnMaybe opt body) -- | Creates the list of declarations that can appear in a typeclass mkClassBody :: [ClassElement dom] -> ClassBody dom @@ -122,11 +123,11 @@ mkClassElemDef :: ValueBind dom -> ClassElement dom mkClassElemDef = mkAnn child . UClsDef --- | Creates an associated type synonym in class: @ type T y :: * @ +-- | Creates an associated type synonym in class: @ type T y :: * @ mkClassElemTypeFam :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> ClassElement dom mkClassElemTypeFam dh tfSpec = mkAnn ("type " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe opt tfSpec)) --- | Creates an associated data synonym in class: @ data T y :: * @ +-- | Creates an associated data synonym in class: @ data T y :: * @ mkClassElemDataFam :: DeclHead dom -> Maybe (KindConstraint dom) -> ClassElement dom mkClassElemDataFam dh kind = mkAnn ("data " <> child) $ UClsTypeFam (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe opt kind)) @@ -140,7 +141,7 @@ -- | Creates a functional dependency, given on the form @l1 ... ln -> r1 ... rn@ mkFunDep :: [Name dom] -> [Name dom] -> FunDep dom -mkFunDep lhss rhss = mkAnn (child <> " -> " <> child) +mkFunDep lhss rhss = mkAnn (child <> " -> " <> child) $ UFunDep (mkAnnList (separatedBy ", " list) lhss) (mkAnnList (separatedBy ", " list) rhss) -- | Minimal pragma: @ {-\# MINIMAL (==) | (/=) \#-} @ in a class @@ -183,12 +184,12 @@ -- | Creates a type class instance declaration (@ instance X T [where f = ...] @) mkInstanceDecl :: Maybe (OverlapPragma dom) -> InstanceRule dom -> Maybe (InstBody dom) -> Decl dom -mkInstanceDecl overlap instRule body = mkAnn ("instance " <> child <> child <> child) +mkInstanceDecl overlap instRule body = mkAnn ("instance " <> child <> child <> child) $ UInstDecl (mkAnnMaybe (after " " opt) overlap) instRule (mkAnnMaybe opt body) -- | The instance declaration rule, which is, roughly, the part of the instance declaration before the where keyword. mkInstanceRule :: Maybe (Context dom) -> InstanceHead dom -> InstanceRule dom -mkInstanceRule ctx ih +mkInstanceRule ctx ih = mkAnn (child <> child <> child) $ UInstanceRule (mkAnnMaybe (after " " opt) Nothing) (mkAnnMaybe (after " " opt) ctx) ih -- | Type or class name as a part of the instance declaration @@ -196,7 +197,7 @@ mkInstanceHead = mkAnn child . UInstanceHeadCon -- | Infix application of the type/class name to the left operand as a part of the instance declaration -mkInfixInstanceHead :: Type dom -> Name dom -> InstanceHead dom +mkInfixInstanceHead :: Type dom -> Operator dom -> InstanceHead dom mkInfixInstanceHead typ n = mkAnn (child <> child) $ UInstanceHeadInfix typ n -- | Parenthesized instance head as a part of the instance declaration @@ -225,17 +226,17 @@ -- | An associated data type implementation (@ data A X = C1 | C2 @) int a type class instance mkInstanceDataFamilyDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> InstBodyDecl dom -mkInstanceDataFamilyDef keyw instRule cons derivs - = mkAnn (child <> " " <> child <> child <> child) - $ UInstBodyDataDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkInstanceDataFamilyDef keyw instRule cons derivs + = mkAnn (child <> " " <> child <> child <> child) + $ UInstBodyDataDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | An associated data type implemented using GADT style int a type class instance -mkInstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] +mkInstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Maybe (Deriving dom) -> InstBodyDecl dom -mkInstanceDataFamilyGADTDef keyw instRule kind cons derivs - = mkAnn (child <> " " <> child <> child <> child) - $ UInstBodyGadtDataDecl keyw instRule (mkAnnMaybe opt kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkInstanceDataFamilyGADTDef keyw instRule kind cons derivs + = mkAnn (child <> " " <> child <> child <> child) + $ UInstBodyGadtDataDecl keyw instRule (mkAnnMaybe opt kind) (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Specialize instance pragma (no phase selection is allowed) in a type class instance @@ -243,39 +244,39 @@ mkInstanceSpecializePragma = mkAnn ("{-# SPECIALIZE " <> child <> " #-}") . USpecializeInstance -- | @OVERLAP@ pragma for type instance definitions -mkEnableOverlap :: OverlapPragma dom +mkEnableOverlap :: OverlapPragma dom mkEnableOverlap = mkAnn "{-# OVERLAP #-}" UEnableOverlap -- | @NO_OVERLAP@ pragma for type instance definitions -mkDisableOverlap :: OverlapPragma dom +mkDisableOverlap :: OverlapPragma dom mkDisableOverlap = mkAnn "{-# NO_OVERLAP #-}" UDisableOverlap -- | @OVERLAPPABLE@ pragma for type instance definitions -mkOverlappable :: OverlapPragma dom +mkOverlappable :: OverlapPragma dom mkOverlappable = mkAnn "{-# OVERLAPPABLE #-}" UOverlappable -- | @OVERLAPPING@ pragma for type instance definitions -mkOverlapping :: OverlapPragma dom +mkOverlapping :: OverlapPragma dom mkOverlapping = mkAnn "{-# OVERLAPPING #-}" UOverlapping -- | @OVERLAPS@ pragma for type instance definitions -mkOverlaps :: OverlapPragma dom +mkOverlaps :: OverlapPragma dom mkOverlaps = mkAnn "{-# OVERLAPS #-}" UOverlaps -- | @INCOHERENT@ pragma for type instance definitions -mkIncoherentOverlap :: OverlapPragma dom +mkIncoherentOverlap :: OverlapPragma dom mkIncoherentOverlap = mkAnn "{-# INCOHERENT #-}" UIncoherentOverlap -- * Type roles -- | Creates a role annotations (@ type role Ptr representational @) mkRoleDecl :: QualifiedName dom -> [Role dom] -> Decl dom -mkRoleDecl name roles +mkRoleDecl name roles = mkAnn ("type role " <> child <> child) $ URoleDecl name $ mkAnnList (separatedBy " " $ after " " list) roles -- | Marks a given type parameter as @nominal@. mkNominalRole :: Role dom -mkNominalRole = mkAnn "nominal" UNominal +mkNominalRole = mkAnn "nominal" UNominal -- | Marks a given type parameter as @representational@. mkRepresentationalRole :: Role dom @@ -289,7 +290,7 @@ -- | Creates a foreign import (@ foreign import foo :: Int -> IO Int @) mkForeignImport :: CallConv dom -> Maybe (Safety dom) -> Name dom -> Type dom -> Decl dom -mkForeignImport cc safety name typ = mkAnn (child <> child <> " " <> child <> " :: " <> child) +mkForeignImport cc safety name typ = mkAnn (child <> child <> " " <> child <> " :: " <> child) $ UForeignImport cc (mkAnnMaybe (after " " opt) safety) name typ -- | Creates a foreign export (@ foreign export ccall foo :: Int -> IO Int @) @@ -310,7 +311,7 @@ -- | Specifies that the given foreign import is @unsafe@. mkUnsafe :: Safety dom -mkUnsafe = mkAnn "unsafe" UUnsafe +mkUnsafe = mkAnn "unsafe" UUnsafe -- * Type and data families @@ -319,11 +320,11 @@ mkTypeFamily dh famSpec = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UTypeFamily dh (mkAnnMaybe (after " " opt) famSpec)) -- | Creates a closed type family declaration ( @type family F x where F Int = (); F a = Int@ ) -mkClosedTypeFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> [TypeEqn dom] -> Decl dom -mkClosedTypeFamily dh kind typeqs = mkAnn (child <> child <> " where " <> child) +mkClosedTypeFamily :: DeclHead dom -> Maybe (TypeFamilySpec dom) -> [TypeEqn dom] -> Decl dom +mkClosedTypeFamily dh kind typeqs = mkAnn (child <> child <> " where " <> child) $ UClosedTypeFamilyDecl dh (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) typeqs) --- | Creates a data family declaration (@ data family A a :: * -> * @) +-- | Creates a data family declaration (@ data family A a :: * -> * @) mkDataFamily :: DeclHead dom -> Maybe (KindConstraint dom) -> Decl dom mkDataFamily dh kind = mkAnn child $ UTypeFamilyDecl (mkAnn (child <> child) $ UDataFamily dh (mkAnnMaybe (after " " opt) kind)) @@ -332,8 +333,8 @@ mkTypeFamilyKindSpec = mkAnn child . UTypeFamilyKind -- | Specifies the injectivity of a type family (@ = r | r -> a @) -mkTypeFamilyInjectivitySpec :: Name dom -> [Name dom] -> TypeFamilySpec dom -mkTypeFamilyInjectivitySpec res dependent +mkTypeFamilyInjectivitySpec :: TyVar dom -> [Name dom] -> TypeFamilySpec dom +mkTypeFamilyInjectivitySpec res dependent = mkAnn child (UTypeFamilyInjectivity $ mkAnn (child <> " -> " <> child) $ UInjectivityAnn res (mkAnnList (separatedBy " " list) dependent)) -- | Type equations as found in closed type families (@ T A = S @) @@ -346,22 +347,22 @@ -- | Creates a data instance declaration (@ data instance Fam T = Con1 | Con2 @) mkDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> [ConDecl dom] -> Maybe (Deriving dom) -> Decl dom -mkDataInstance keyw instRule cons derivs - = mkAnn (child <> " instance " <> child <> " = " <> child <> child) - $ UDataInstDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) +mkDataInstance keyw instRule cons derivs + = mkAnn (child <> " instance " <> child <> " = " <> child <> child) + $ UDataInstDecl keyw instRule (mkAnnList (after " = " $ separatedBy " | " list) cons) (mkAnnMaybe (after " deriving " opt) derivs) -- | Creates a GADT-style data instance declaration (@ data instance Fam T where ... @) mkGadtDataInstance :: DataOrNewtypeKeyword dom -> InstanceRule dom -> Maybe (KindConstraint dom) -> [GadtConDecl dom] -> Decl dom -mkGadtDataInstance keyw instRule kind cons - = mkAnn (child <> " instance " <> child <> child <> " where " <> child) +mkGadtDataInstance keyw instRule kind cons + = mkAnn (child <> " instance " <> child <> child <> " where " <> child) $ UGDataInstDecl keyw instRule (mkAnnMaybe (after " " opt) kind) (mkAnnList (indented list) cons) -- * Pattern synonyms -- | Creates a pattern synonym (@ pattern Arrow t1 t2 = App \"->\" [t1, t2] @) mkPatternSynonym :: PatSynLhs dom -> PatSynRhs dom -> Decl dom -mkPatternSynonym lhs rhs = mkAnn child $ UPatternSynonymDecl $ mkAnn ("pattern " <> child <> " " <> child) +mkPatternSynonym lhs rhs = mkAnn child $ UPatternSynonymDecl $ mkAnn ("pattern " <> child <> " " <> child) $ UPatternSynonym lhs rhs -- | Creates a left hand side of a pattern synonym with a constructor name and arguments (@ Arrow t1 t2 @) @@ -374,7 +375,7 @@ -- | Creates a record-style pattern synonym left-hand side (@ Arrow { arrowFrom, arrowTo } @) mkRecordPatSyn :: Name dom -> [Name dom] -> PatSynLhs dom -mkRecordPatSyn con args +mkRecordPatSyn con args = mkAnn (child <> child) $ URecordPatSyn con $ mkAnnList (after "{ " $ separatedBy ", " $ followedBy " }" list) args -- | Creates an automatically two-way pattern synonym (@ = App \"Int\" [] @) @@ -385,9 +386,9 @@ mkOneWayPatSyn :: Pattern dom -> PatSynRhs dom mkOneWayPatSyn = mkAnn ("<- " <> child) . UOneDirectionalPatSyn --- | Creates a pattern synonym with the other direction explicitely specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) +-- | Creates a pattern synonym with the other direction explicitly specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) mkTwoWayPatSyn :: Pattern dom -> [Match dom] -> PatSynRhs dom -mkTwoWayPatSyn pat match = mkAnn ("<- " <> child <> child) $ UBidirectionalPatSyn pat $ mkAnnMaybe (after " where " opt) +mkTwoWayPatSyn pat match = mkAnn ("<- " <> child <> child) $ UBidirectionalPatSyn pat $ mkAnnMaybe (after " where " opt) $ Just $ mkAnn child $ UPatSynWhere $ mkAnnList (indented list) match -- | Creates a pattern type signature declaration (@ pattern Succ :: Int -> Int @) @@ -409,13 +410,15 @@ -- | A pragma that marks definitions as deprecated (@ {-\# DEPRECATED f "f will be replaced by g" \#-} @) mkDeprPragma :: [Name dom] -> String -> TopLevelPragma dom -mkDeprPragma defs msg = mkAnn ("{-# DEPRECATED " <> child <> " " <> child <> " #-}") - $ UDeprPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg +mkDeprPragma defs msg = mkAnn ("{-# DEPRECATED " <> child <> " " <> child <> " #-}") + $ UDeprPragma (mkAnnList (separatedBy ", " list) defs) + (mkAnnList (separatedBy ", " list) [mkAnn ("\"" <> child <> "\"") $ UStringNode msg]) -- | A pragma that marks definitions as deprecated (@ {-\# WARNING unsafePerformIO "you should know what you are doing" \#-} @) mkWarningPragma :: [Name dom] -> String -> TopLevelPragma dom -mkWarningPragma defs msg = mkAnn ("{-# WARNING " <> child <> " " <> child <> " #-}") - $ UWarningPragma (mkAnnList (separatedBy ", " list) defs) $ mkAnn ("\"" <> child <> "\"") $ UStringNode msg +mkWarningPragma defs msg = mkAnn ("{-# WARNING " <> child <> " " <> child <> " #-}") + $ UWarningPragma (mkAnnList (separatedBy ", " list) defs) + (mkAnnList (separatedBy ", " list) [mkAnn ("\"" <> child <> "\"") $ UStringNode msg]) -- | A pragma that annotates a definition with an arbitrary value (@ {-\# ANN f 42 \#-} @) mkAnnPragma :: AnnotationSubject dom -> Expr dom -> TopLevelPragma dom @@ -423,7 +426,7 @@ -- | A pragma that marks a function for inlining to the compiler (@ {-\# INLINE thenUs \#-} @) mkInlinePragma :: Maybe (ConlikeAnnot dom) -> Maybe (PhaseControl dom) -> Name dom -> TopLevelPragma dom -mkInlinePragma conlike phase name +mkInlinePragma conlike phase name = mkAnn ("{-# INLINE " <> child <> child <> child <> " #-}") $ UInlinePragmaDecl $ mkAnn child $ UInlinePragma (mkAnnMaybe (followedBy " " opt) conlike) (mkAnnMaybe (followedBy " " opt) phase) name @@ -440,33 +443,37 @@ -- | A pragma for maintaining line numbers in generated sources (@ {-\# LINE 123 "somefile" \#-} @) mkLinePragma :: Int -> Maybe (StringNode dom) -> TopLevelPragma dom -mkLinePragma line filename - = mkAnn ("{-# LINE " <> child <> child <> " #-}") +mkLinePragma line filename + = mkAnn ("{-# LINE " <> child <> child <> " #-}") $ ULinePragma (mkAnn child $ LineNumber line) (mkAnnMaybe (after " " opt) filename) -- | A pragma that tells the compiler that a polymorph function should be optimized for a given type (@ {-\# SPECIALISE f :: Int -> b -> b \#-} @) mkSpecializePragma :: Maybe (PhaseControl dom) -> Name dom -> [Type dom] -> TopLevelPragma dom -mkSpecializePragma phase def specTypes - = mkAnn ("{-# SPECIALIZE " <> child <> child <> " " <> child <> " #-}") - $ USpecializePragma (mkAnnMaybe (after " " opt) phase) def $ mkAnnList (separatedBy ", " list) specTypes +mkSpecializePragma phase def specTypes + = mkAnn child (USpecializeDecl + $ mkAnn ("{-# SPECIALIZE " <> child <> child <> " " <> child <> " #-}") + $ USpecializePragma (mkAnnMaybe (after " " opt) phase) def $ mkAnnList (separatedBy ", " list) specTypes) -- | Marks that the pragma should be applied from a given compile phase (@ [2] @) mkPhaseControlFrom :: Integer -> PhaseControl dom -mkPhaseControlFrom phaseNum - = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt Nothing) (mkAnn child $ PhaseNumber phaseNum) +mkPhaseControlFrom phaseNum + = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt Nothing) (mkAnnMaybe opt $ Just $ mkAnn child $ PhaseNumber phaseNum) -- | Marks that the pragma should be applied until a given compile phase (@ [~2] @) mkPhaseControlUntil :: Integer -> PhaseControl dom -mkPhaseControlUntil phaseNum - = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt $ Just $ mkAnn "~" PhaseInvert) - (mkAnn child $ PhaseNumber phaseNum) +mkPhaseControlUntil phaseNum + = mkAnn ("[" <> child <> child <> "]") $ UPhaseControl (mkAnnMaybe opt $ Just $ mkAnn "~" PhaseInvert) + (mkAnnMaybe opt $ Just $ mkAnn child $ PhaseNumber phaseNum) -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) -mkRewriteRule :: String -> Maybe (PhaseControl dom) -> [TyVar dom] -> Expr dom -> Expr dom -> Rule dom +mkRewriteRule :: String -> Maybe (PhaseControl dom) -> [RuleVar dom] -> Expr dom -> Expr dom -> Rule dom mkRewriteRule name phase vars lhs rhs = mkAnn (child <> " " <> child <> child <> child <> " = " <> child) $ URule (mkAnn ("\"" <> child <> "\"") $ UStringNode name) (mkAnnMaybe (followedBy " " opt) phase) - (mkAnnList (after "forall " $ separatedBy " " $ followedBy ". " list) vars) lhs rhs + (mkAnnList (after "forall " $ separatedBy " " $ followedBy ". " list) (vars)) lhs rhs + +mkRuleVar :: Name dom -> RuleVar dom +mkRuleVar name = mkAnn child (URuleVar name) -- | The definition with the given name is annotated mkNameAnnotation :: Name dom -> AnnotationSubject dom diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Types.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Types.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Gen/Types.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Gen/Types.hs 2017-05-03 22:13:56.000000000 +0200 @@ -2,7 +2,7 @@ -- The bindings defined here create a the annotated version of the AST constructor with the same name. -- For example, @mkTyForall@ creates the annotated version of the @TyForall@ AST constructor. {-# LANGUAGE OverloadedStrings - , TypeFamilies + , TypeFamilies #-} module Language.Haskell.Tools.AST.Gen.Types where @@ -56,7 +56,7 @@ -- | Infix type constructor (@ (a <: b) @) mkInfixTypeApp :: Type dom -> Operator dom -> Type dom -> Type dom mkInfixTypeApp left op right = mkAnn (child <> " " <> child <> " " <> child) (UTyInfix left op right) - + -- | Type surrounded by parentheses (@ (T a) @) mkParenType :: Type dom -> Type dom mkParenType = mkAnn ("(" <> child <> ")") . UTyParen @@ -124,27 +124,23 @@ -- | A list of elements as a kind. mkPromotedListType :: [Type dom] -> Type dom -mkPromotedListType +mkPromotedListType = mkAnn child . UTyPromoted . mkAnn ("[" <> child <> "]") . UPromotedList . mkAnnList (separatedBy ", " list) -- | A tuple of elements as a kind. mkPromotedTupleType :: [Type dom] -> Type dom -mkPromotedTupleType +mkPromotedTupleType = mkAnn child . UTyPromoted . mkAnn ("(" <> child <> ")") . UPromotedTuple . mkAnnList (separatedBy ", " list) --- | Kind of the unit value @()@. +-- | Kind of the unit value @()@. mkPromotedUnitType :: Type dom mkPromotedUnitType = mkAnn child $ UTyPromoted $ mkAnn "()" UPromotedUnit -- * Generation of contexts --- | Creates a context of one assertion (@ C a => ... @) -mkContextOne :: Assertion dom -> Context dom -mkContextOne = mkAnn (child <> " =>") . UContextOne - --- | Creates a context of a set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) -mkContextMulti :: [Assertion dom] -> Context dom -mkContextMulti = mkAnn ("(" <> child <> ") =>") . UContextMulti . mkAnnList (separatedBy ", " list) +-- | Creates a context of assertions (@ C a => ... @) +mkContext :: Assertion dom -> Context dom +mkContext = mkAnn (child <> " =>") . UContext -- * Generation of assertions @@ -161,3 +157,6 @@ mkImplicitAssert :: Name dom -> Type dom -> Assertion dom mkImplicitAssert n t = mkAnn (child <> " :: " <> child) $ UImplicitAssert n t +-- | Creates a list of assertions (@ (Eq a, Show a) @) +mkTupleAssertion :: [Assertion dom] -> Assertion dom +mkTupleAssertion ass = mkAnn ("(" <> child <> ")") $ UTupleAssert $ mkAnnList (separatedBy ", " list) ass diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Binds.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Binds.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Binds.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Binds.hs 2017-05-03 22:13:56.000000000 +0200 @@ -5,7 +5,7 @@ import Language.Haskell.Tools.AST import Language.Haskell.Tools.AST.ElementTypes --- | Non-function binding (@ v = "12" @) +-- | Non-function binding (@ v = "12" @) pattern SimpleBind :: Pattern dom -> Rhs dom -> MaybeLocalBinds dom -> ValueBind dom pattern SimpleBind p r l <- Ann _ (USimpleBind p r l) @@ -13,7 +13,7 @@ pattern FunctionBind :: MatchList dom -> ValueBind dom pattern FunctionBind matches <- Ann _ (UFunBind matches) --- | Clause of function binding +-- | Clause of function binding pattern Match :: MatchLhs dom -> Rhs dom -> MaybeLocalBinds dom -> Match dom pattern Match lhs rhs locs <- Ann _ (UMatch lhs rhs locs) @@ -45,8 +45,6 @@ pattern TypeSignature :: NameList dom -> Type dom -> TypeSignature dom pattern TypeSignature n t <- Ann _ (UTypeSignature n t) --- TODO: match precedence with maybe - -- | A left-associative fixity declaration (@ infixl 5 +, - @). pattern InfixL :: OperatorList dom -> FixitySignature dom pattern InfixL op <- Ann _ (UFixitySignature (Ann _ AssocLeft) _ op) @@ -67,7 +65,7 @@ pattern GuardedRhss :: GuardedRhsList dom -> Rhs dom pattern GuardedRhss rhss <- Ann _ (UGuardedRhss rhss) --- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) +-- | A guarded right-hand side of a value binding (@ | x > 3 = 2 @) pattern GuardedRhs :: RhsGuardList dom -> Expr dom -> GuardedRhs dom pattern GuardedRhs guards expr <- Ann _ (UGuardedRhs guards expr) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Decls.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Decls.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Decls.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Decls.hs 2017-05-17 13:32:17.000000000 +0200 @@ -10,7 +10,7 @@ -- * Declarations -- | A type synonym ( @type String = [Char]@ ) -pattern TypeDecl :: DeclHead dom -> Type dom -> Decl dom +pattern TypeDecl :: DeclHead dom -> Type dom -> Decl dom pattern TypeDecl dh typ <- Ann _ (UTypeDecl dh typ) -- | Standalone deriving declaration (@ deriving instance X T @) @@ -39,7 +39,7 @@ -- * Data type definitions --- | A data or newtype declaration. Empty data type declarations without +-- | A data or newtype declaration. Empty data type declarations without -- where keyword are always belong to DataDecl. pattern DataDecl :: DataOrNewtypeKeyword dom -> MaybeContext dom -> DeclHead dom -> ConDeclList dom -> MaybeDeriving dom -> Decl dom pattern DataDecl keyw ctx dh cons derivs <- Ann _ (UDataDecl keyw ctx dh cons derivs) @@ -50,23 +50,23 @@ -- | GADT constructor declaration (@ D1 :: Int -> T String @) pattern GadtConDecl :: NameList dom -> Type dom -> GadtConDecl dom -pattern GadtConDecl names typ <- Ann _ (UGadtConDecl names (Ann _ (UGadtNormalType typ))) +pattern GadtConDecl names typ <- Ann _ (UGadtConDecl names _ _ (Ann _ (UGadtNormalType typ))) -- | GADT constructor declaration with record syntax (@ D1 :: { val :: Int } -> T String @) pattern GadtRecordConDecl :: NameList dom -> FieldDeclList dom -> Type dom -> GadtConDecl dom -pattern GadtRecordConDecl names fields typ <- Ann _ (UGadtConDecl names (Ann _ (UGadtRecordType fields typ))) +pattern GadtRecordConDecl names fields typ <- Ann _ (UGadtConDecl names _ _ (Ann _ (UGadtRecordType fields typ))) -- | Ordinary data constructor (@ C t1 t2 @) pattern ConDecl :: Name dom -> TypeList dom -> ConDecl dom -pattern ConDecl name args <- Ann _ (UConDecl name args) +pattern ConDecl name args <- Ann _ (UConDecl _ _ name args) -- | Creates a record data constructor (@ Point { x :: Double, y :: Double } @) pattern RecordConDecl :: Name dom -> FieldDeclList dom -> ConDecl dom -pattern RecordConDecl name fields <- Ann _ (URecordDecl name fields) +pattern RecordConDecl name fields <- Ann _ (URecordDecl _ _ name fields) -- | Infix data constructor (@ t1 :+: t2 @) pattern InfixConDecl :: Type dom -> Operator dom -> Type dom -> ConDecl dom -pattern InfixConDecl lhs op rhs <- Ann _ (UInfixConDecl lhs op rhs) +pattern InfixConDecl lhs op rhs <- Ann _ (UInfixConDecl _ _ lhs op rhs) -- | Field declaration (@ fld :: Int @) pattern FieldDecl :: NameList dom -> Type dom -> FieldDecl dom @@ -86,11 +86,11 @@ pattern NewtypeKeyword :: DataOrNewtypeKeyword dom pattern NewtypeKeyword <- Ann _ UNewtypeKeyword --- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas +-- | A list of functional dependencies: @ | a -> b, c -> d @ separated by commas pattern FunDeps :: FunDepList dom -> FunDeps dom pattern FunDeps fds <- Ann _ (UFunDeps fds) --- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ +-- | A functional dependency, given on the form @l1 ... ln -> r1 ... rn@ pattern FunDep :: NameList dom -> NameList dom -> FunDep dom pattern FunDep lhs rhs <- Ann _ (UFunDep lhs rhs) @@ -191,7 +191,7 @@ pattern InstanceDataFamilyDef keyw instRule cons derivs <- Ann _ (UInstBodyDataDecl keyw instRule cons derivs ) -- | An associated data definition as a GADT (@ data A X where B :: Int -> A X @) in a class instance -pattern InstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> MaybeKindConstraint dome -> AnnListG UGadtConDecl dom stage +pattern InstanceDataFamilyGADTDef :: DataOrNewtypeKeyword dom -> InstanceRule dom -> MaybeKindConstraint dome -> AnnListG UGadtConDecl dom stage -> MaybeDeriving dom -> InstBodyDecl dom pattern InstanceDataFamilyGADTDef keyw instRule kind cons derivs <- Ann _ (UInstBodyGadtDataDecl keyw instRule kind cons derivs) @@ -208,40 +208,40 @@ pattern InstanceHead name <- Ann _ (UInstanceHeadCon name) -- | Infix application of the type/class name to the left operand as an instance head -pattern InfixInstanceHead :: Type dom -> Name dom -> InstanceHead dom +pattern InfixInstanceHead :: Type dom -> Operator dom -> InstanceHead dom pattern InfixInstanceHead typ n <- Ann _ (UInstanceHeadInfix typ n) -- | Parenthesized instance head pattern ParenInstanceHead :: InstanceHead dom -> InstanceHead dom pattern ParenInstanceHead ih <- Ann _ (UInstanceHeadParen ih) --- | Type application as an instance head +-- | Type application as an instance head pattern AppInstanceHead :: InstanceHead dom -> Type dom -> InstanceHead dom pattern AppInstanceHead fun arg <- Ann _ (UInstanceHeadApp fun arg) -- | @OVERLAP@ pragma -pattern EnableOverlap :: OverlapPragma dom -pattern EnableOverlap <- Ann _ UEnableOverlap +pattern EnableOverlap :: OverlapPragma dom +pattern EnableOverlap <- Ann _ UEnableOverlap -- | @NO_OVERLAP@ pragma -pattern DisableOverlap :: OverlapPragma dom -pattern DisableOverlap <- Ann _ UDisableOverlap +pattern DisableOverlap :: OverlapPragma dom +pattern DisableOverlap <- Ann _ UDisableOverlap -- | @OVERLAPPABLE@ pragma -pattern Overlappable :: OverlapPragma dom -pattern Overlappable <- Ann _ UOverlappable +pattern Overlappable :: OverlapPragma dom +pattern Overlappable <- Ann _ UOverlappable -- | @OVERLAPPING@ pragma -pattern Overlapping :: OverlapPragma dom -pattern Overlapping <- Ann _ UOverlapping +pattern Overlapping :: OverlapPragma dom +pattern Overlapping <- Ann _ UOverlapping -- | @OVERLAPS@ pragma -pattern Overlaps :: OverlapPragma dom -pattern Overlaps <- Ann _ UOverlaps +pattern Overlaps :: OverlapPragma dom +pattern Overlaps <- Ann _ UOverlaps -- | @INCOHERENT@ pragma -pattern IncoherentOverlap :: OverlapPragma dom -pattern IncoherentOverlap <- Ann _ UIncoherentOverlap +pattern IncoherentOverlap :: OverlapPragma dom +pattern IncoherentOverlap <- Ann _ UIncoherentOverlap -- * Type roles @@ -282,7 +282,7 @@ -- | Specifies that the given foreign import is @unsafe@. pattern Unsafe :: Safety dom -pattern Unsafe <- Ann _ UUnsafe +pattern Unsafe <- Ann _ UUnsafe -- * Pattern synonyms @@ -310,7 +310,7 @@ pattern OneWayPatSyn :: Pattern dom -> PatSynRhs dom pattern OneWayPatSyn pat <- Ann _ (UOneDirectionalPatSyn pat) --- | A pattern synonym with the other direction explicitely specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) +-- | A pattern synonym with the other direction explicitly specified (@ <- App \"Int\" [] where Int = App \"Int\" [] @) pattern TwoWayPatSyn :: Pattern dom -> MatchList dom -> PatSynRhs dom pattern TwoWayPatSyn pat match <- Ann _ (UBidirectionalPatSyn pat (AnnJust (Ann _ (UPatSynWhere match)))) @@ -344,7 +344,7 @@ pattern GadtDataInstance keyw instRule kind cons <- Ann _ (UGDataInstDecl keyw instRule kind cons ) -- | A closed type family declaration -pattern ClosedTypeFamily :: DeclHead dom -> MaybeKindConstraint dom -> TypeEqnList dom -> Decl dom +pattern ClosedTypeFamily :: DeclHead dom -> MaybeTypeFamilySpec dom -> TypeEqnList dom -> Decl dom pattern ClosedTypeFamily dh kind typeqs <- Ann _ (UClosedTypeFamilyDecl dh kind typeqs) -- | Specifies the kind of a type family (@ :: * -> * @) @@ -352,7 +352,7 @@ pattern TypeFamilyKindSpec kind <- Ann _ (UTypeFamilyKind kind) -- | Specifies the injectivity of a type family (@ = r | r -> a @) -pattern TypeFamilyInjectivitySpec :: Name dom -> NameList dom -> TypeFamilySpec dom +pattern TypeFamilyInjectivitySpec :: TyVar dom -> NameList dom -> TypeFamilySpec dom pattern TypeFamilyInjectivitySpec res dependent <- Ann _ (UTypeFamilyInjectivity (Ann _ (UInjectivityAnn res dependent))) -- | Type equations as found in closed type families (@ T A = S @) @@ -371,11 +371,11 @@ -- | A pragma that marks definitions as deprecated (@ {-\# DEPRECATED f "f will be replaced by g" \#-} @) pattern DeprPragma :: NameList dom -> String -> TopLevelPragma dom -pattern DeprPragma defs msg <- Ann _ (UDeprPragma defs (Ann _ (UStringNode msg))) +pattern DeprPragma defs msg <- Ann _ (UDeprPragma defs (AnnList [Ann _ (UStringNode msg)])) -- | A pragma that marks definitions as deprecated (@ {-\# WARNING unsafePerformIO "you should know what you are doing" \#-} @) pattern WarningPragma :: NameList dom -> String -> TopLevelPragma dom -pattern WarningPragma defs msg <- Ann _ (UWarningPragma defs (Ann _ (UStringNode msg))) +pattern WarningPragma defs msg <- Ann _ (UWarningPragma defs (AnnList [Ann _ (UStringNode msg)])) -- | A pragma that annotates a definition with an arbitrary value (@ {-\# ANN f 42 \#-} @) pattern AnnPragma :: AnnotationSubject dom -> Expr dom -> TopLevelPragma dom @@ -399,18 +399,18 @@ -- | A pragma that tells the compiler that a polymorph function should be optimized for a given type (@ {-\# SPECIALISE f :: Int -> b -> b \#-} @) pattern SpecializePragma :: MaybePhaseControl dom -> Name dom -> TypeList dom -> TopLevelPragma dom -pattern SpecializePragma phase def specTypes <- Ann _ (USpecializePragma phase def specTypes) +pattern SpecializePragma phase def specTypes <- Ann _ (USpecializeDecl (Ann _ (USpecializePragma phase def specTypes))) -- | Marks that the pragma should be applied from a given compile phase (@ [2] @) pattern PhaseControlFrom :: Integer -> PhaseControl dom -pattern PhaseControlFrom phaseNum <- Ann _ (UPhaseControl AnnNothing (Ann _ (PhaseNumber phaseNum))) +pattern PhaseControlFrom phaseNum <- Ann _ (UPhaseControl AnnNothing (AnnJust (Ann _ (PhaseNumber phaseNum)))) -- | Marks that the pragma should be applied until a given compile phase (@ [~2] @) pattern PhaseControlUntil :: Integer -> PhaseControl dom -pattern PhaseControlUntil phaseNum <- Ann _ (UPhaseControl (AnnJust _) (Ann _ (PhaseNumber phaseNum))) +pattern PhaseControlUntil phaseNum <- Ann _ (UPhaseControl (AnnJust _) (AnnJust (Ann _ (PhaseNumber phaseNum)))) -- | A rewrite rule (@ "map/map" forall f g xs. map f (map g xs) = map (f.g) xs @) -pattern RewriteRule :: String -> MaybePhaseControl dom -> TyVarList dom -> Expr dom -> Expr dom -> Rule dom +pattern RewriteRule :: String -> MaybePhaseControl dom -> RuleVarList dom -> Expr dom -> Expr dom -> Rule dom pattern RewriteRule name phase vars lhs rhs <- Ann _ (URule (Ann _ (UStringNode name)) phase vars lhs rhs) -- | The definition with the given name is annotated @@ -427,4 +427,4 @@ -- | A @CONLIKE@ modifier for an @INLINE@ pragma. pattern ConlikeAnnotation :: ConlikeAnnot dom -pattern ConlikeAnnotation <- Ann _ UConlikeAnnot \ No newline at end of file +pattern ConlikeAnnotation <- Ann _ UConlikeAnnot diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Types.hs new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Types.hs --- old/haskell-tools-rewrite-0.5.0.0/Language/Haskell/Tools/AST/Match/Types.hs 2017-01-31 20:47:42.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/Language/Haskell/Tools/AST/Match/Types.hs 2017-05-03 22:13:56.000000000 +0200 @@ -108,7 +108,7 @@ pattern PromotedTupleType :: TypeList dom -> Type dom pattern PromotedTupleType elems <- Ann _ (UTyPromoted (Ann _ (UPromotedTuple elems))) --- | Kind of the unit value @()@. +-- | Kind of the unit value @()@. pattern PromotedUnitType :: Type dom pattern PromotedUnitType <- Ann _ (UTyPromoted (Ann _ UPromotedUnit)) @@ -124,13 +124,9 @@ -- * Contexts --- | One assertion (@ C a => ... @) -pattern ContextOne :: Assertion dom -> Context dom -pattern ContextOne n <- Ann _ (UContextOne n) - --- | A set of assertions (@ (C1 a, C2 b) => ... @, but can be one: @ (C a) => ... @) -pattern ContextMulti :: AssertionList dom -> Context dom -pattern ContextMulti n <- Ann _ (UContextMulti n) +-- | A context of assertions (@ C a => ... @) +pattern Context :: Assertion dom -> Context dom +pattern Context n <- Ann _ (UContext n) -- * Assertions @@ -145,3 +141,7 @@ -- | Assertion for implicit parameter binding (@ ?cmp :: a -> a -> Bool @) pattern ImplicitAssert :: Name dom -> Type dom -> Assertion dom pattern ImplicitAssert n t <- Ann _ (UImplicitAssert n t) + +-- | A list of assertions (@ (Eq a, Show a) @) +pattern TupleAssert :: [Assertion dom] -> Assertion dom +pattern TupleAssert ass <- Ann _ (UTupleAssert (AnnList ass)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/haskell-tools-rewrite.cabal new/haskell-tools-rewrite-0.8.0.0/haskell-tools-rewrite.cabal --- old/haskell-tools-rewrite-0.5.0.0/haskell-tools-rewrite.cabal 2017-01-31 20:55:16.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/haskell-tools-rewrite.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-rewrite -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Facilities for generating new parts of the Haskell-Tools AST description: Contains utility functions to generate parts of the Haskell-Tools AST. Generates these elements to be compatible with the source annotations that are already present on the AST. The package is divided into modules based on which language elements can the given module generate. This packages should be used during the transformations to generate parts of the new AST. homepage: https://github.com/haskell-tools/haskell-tools @@ -12,7 +12,6 @@ cabal-version: >=1.10 library - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.AST.Rewrite , Language.Haskell.Tools.AST.ElementTypes , Language.Haskell.Tools.AST.Gen @@ -45,21 +44,21 @@ , containers >= 0.5 && < 0.6 , references >= 0.3 && < 0.4 , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 default-language: Haskell2010 test-suite haskell-tools-rewrite-tests type: exitcode-stdio-1.0 ghc-options: -with-rtsopts=-M2g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 , filepath >= 1.4 && < 2.0 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-rewrite >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-rewrite >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-rewrite-0.5.0.0/test/Main.hs new/haskell-tools-rewrite-0.8.0.0/test/Main.hs --- old/haskell-tools-rewrite-0.5.0.0/test/Main.hs 2017-01-31 20:34:13.000000000 +0100 +++ new/haskell-tools-rewrite-0.8.0.0/test/Main.hs 2017-05-03 22:13:56.000000000 +0200 @@ -11,11 +11,11 @@ main = defaultMain genTests genTests :: TestTree -genTests = testGroup "ast generation tests" +genTests = testGroup "ast generation tests" [ testGroup "name tests" testBase , testGroup "expression tests" (map makeGenTest testExprs) , testGroup "pattern tests" (map makeGenTest testPatterns) - , testGroup "type tests" (map makeGenTest testType) + , testGroup "type tests" (map makeGenTest testType) , testGroup "binding tests" (map makeGenTest testBinds) , testGroup "declaration tests" (map makeGenTest testDecls) , testGroup "module tests" (map makeGenTest testModules) @@ -31,26 +31,26 @@ , makeGenTest ("operator name", "(+)", mkParenName $ mkSimpleName "+") ] -testExprs - = [ ("infix", "a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) +testExprs + = [ ("infix", "a + 3", mkInfixApp (mkVar (mkName "a")) (mkUnqualOp "+") (mkLit $ mkIntLit 3)) , ("section", "(\"xx\" ++)", mkLeftSection (mkLit (mkStringLit "xx")) (mkUnqualOp "++")) , ("tuple", "(1, [2, 3])", mkTuple [ mkLit (mkIntLit 1), mkList [ mkLit (mkIntLit 2), mkLit (mkIntLit 3) ] ]) , ("record constructor", "P { x = 1 }", mkRecCon (mkName "P") [ mkFieldUpdate (mkName "x") (mkLit $ mkIntLit 1) ]) , ("if", "if f a then x else y" , mkIf (mkApp (mkVar $ mkName "f") (mkVar $ mkName "a")) (mkVar $ mkName "x") (mkVar $ mkName "y")) , ("let", "let nat = [0..] in !z" - , mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] + , mkLet [mkLocalValBind $ mkSimpleBind' (mkName "nat") (mkEnum (mkLit (mkIntLit 0)) Nothing Nothing)] (mkPrefixApp (mkUnqualOp "!") (mkVar $ mkName "z")) ) , ("case", "case x of Just y -> y\n" ++ " Nothing -> 0" - , mkCase (mkVar (mkName "x")) + , mkCase (mkVar (mkName "x")) [ mkAlt (mkAppPat (mkName "Just") [mkVarPat (mkName "y")]) (mkCaseRhs $ mkVar (mkName "y")) Nothing , mkAlt (mkVarPat $ mkName "Nothing") (mkCaseRhs $ mkLit $ mkIntLit 0) Nothing ]) , ("multiway if", "if | x > y -> x\n" ++ " | otherwise -> y" - , mkMultiIf [ mkGuardedCaseRhs - [ mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] + , mkMultiIf [ mkGuardedCaseRhs + [ mkGuardCheck $ mkInfixApp (mkVar (mkName "x")) (mkUnqualOp ">") (mkVar (mkName "y"))] (mkVar (mkName "x")) , mkGuardedCaseRhs [mkGuardCheck $ mkVar (mkName "otherwise")] (mkVar (mkName "y")) ]) @@ -64,7 +64,7 @@ testPatterns = [ ("irrefutable pattern", "~[0, a]", mkIrrefutablePat $ mkListPat [ mkLitPat (mkIntLit 0), mkVarPat (mkName "a") ]) , ("named pattern", "p@Point{ x = 1 }" - , mkAsPat (mkName "p") $ mkRecPat (mkName "Point") + , mkAsPat (mkName "p") $ mkRecPat (mkName "Point") [ mkPatternField (mkName "x") (mkLitPat (mkIntLit 1)) ]) , ("bang pattern", "!(_, f -> 3)" , mkBangPat $ mkTuplePat [mkWildPat, mkViewPat (mkVar $ mkName "f") (mkLitPat (mkIntLit 3))]) @@ -72,8 +72,8 @@ testType = [ ("forall type", "forall x . Eq x => x -> ()" - , mkForallType [mkTypeVar (mkName "x")] - $ mkCtxType (mkContextOne (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) + , mkForallType [mkTypeVar (mkName "x")] + $ mkCtxType (mkContext (mkClassAssert (mkName "Eq") [mkVarType (mkName "x")])) $ mkFunctionType (mkVarType (mkName "x")) (mkVarType (mkName "()"))) , ("type operators", "(A :+: B) (x, x)" , mkTypeApp (mkParenType $ mkInfixTypeApp (mkVarType (mkName "A")) (mkUnqualOp ":+:") (mkVarType (mkName "B"))) @@ -100,23 +100,23 @@ , ("binding", "id x = x" , mkValueBinding $ mkFunctionBind' (mkName "id") [([mkVarPat $ mkName "x"], mkVar $ mkName "x")]) , ("datatype definition", "data A a = A a deriving Show" - , mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) + , mkDataDecl mkDataKeyword Nothing (mkDeclHeadApp (mkNameDeclHead (mkName "A")) (mkTypeVar (mkName "a"))) [mkConDecl (mkName "A") [mkVarType (mkName "a")]] (Just $ mkDeriving [mkInstanceHead (mkName "Show")])) , ("record definition", "data A = A { x :: Int }" - , mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) + , mkDataDecl mkDataKeyword Nothing (mkNameDeclHead (mkName "A")) [mkRecordConDecl (mkName "A") [mkFieldDecl [mkName "x"] (mkVarType (mkName "Int"))]] Nothing) , ("typeclass definition", "class A t => C t where f :: t\n" ++ " type T t :: *" - , mkClassDecl (Just $ mkContextOne (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) + , mkClassDecl (Just $ mkContext (mkClassAssert (mkName "A") [mkVarType (mkName "t")])) (mkDeclHeadApp (mkNameDeclHead (mkName "C")) (mkTypeVar (mkName "t"))) [] (Just $ mkClassBody [ mkClassElemSig $ mkTypeSignature (mkName "f") (mkVarType (mkName "t")) - , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) - (mkTypeVar (mkName "t"))) + , mkClassElemTypeFam (mkDeclHeadApp (mkNameDeclHead (mkName "T")) + (mkTypeVar (mkName "t"))) (Just $ mkTypeFamilyKindSpec $ mkKindConstraint $ mkKindStar) ]) ) , ( "instance definition", "instance C Int where f = 0" - , mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) + , mkInstanceDecl Nothing (mkInstanceRule Nothing $ mkAppInstanceHead (mkInstanceHead $ mkName "C") (mkVarType (mkName "Int"))) (Just $ mkInstanceBody [mkInstanceBind $ mkSimpleBind' (mkName "f") (mkLit $ mkIntLit 0)])) , ("fixity definition", "infixl 6 +", mkFixityDecl $ mkInfixL 6 (mkUnqualOp "+")) ] @@ -124,7 +124,7 @@ testModules = [ ("empty module", "", G.mkModule [] Nothing [] []) , ("exports", "module Test(x, A(a), B(..)) where" - , G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") Nothing + , G.mkModule [] (Just $ mkModuleHead (G.mkModuleName "Test") Nothing (Just $ mkExportSpecs [ mkExportSpec $ mkIESpec (mkName "x") Nothing , mkExportSpec $ mkIESpec (mkName "A") (Just $ mkSubList [mkName "a"]) @@ -133,11 +133,11 @@ , ("imports", "\nimport qualified A\n" ++ "import B as BB(x)\n" ++ "import B hiding (x)" - , G.mkModule [] Nothing + , G.mkModule [] Nothing [ mkImportDecl False True False Nothing (G.mkModuleName "A") Nothing Nothing - , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") + , mkImportDecl False False False Nothing (G.mkModuleName "B") (Just $ G.mkModuleName "BB") (Just $ mkImportSpecList [mkIESpec (mkName "x") Nothing]) - , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing + , mkImportDecl False False False Nothing (G.mkModuleName "B") Nothing (Just $ mkImportHidingList [mkIESpec (mkName "x") Nothing]) ] []) ]

1 0

commit ghc-haskell-tools-refactor for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-refactor for openSUSE:Factory checked in at 2017-08-31 20:56:07 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-refactor (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-refactor.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-refactor" Thu Aug 31 20:56:07 2017 rev:2 rq:513375 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-refactor/ghc-haskell-tools-refactor.changes 2017-04-12 18:06:46.993987260 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-refactor.new/ghc-haskell-tools-refactor.changes 2017-08-31 20:56:09.106044464 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:05 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-refactor-0.5.0.0.tar.gz New: ---- haskell-tools-refactor-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-refactor.spec ++++++ --- /var/tmp/diff_new_pack.TjmYid/_old 2017-08-31 20:56:09.877936011 +0200 +++ /var/tmp/diff_new_pack.TjmYid/_new 2017-08-31 20:56:09.885934887 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-refactor %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Refactoring Tool for Haskell License: BSD-3-Clause ++++++ haskell-tools-refactor-0.5.0.0.tar.gz -> haskell-tools-refactor-0.8.0.0.tar.gz ++++++ ++++ 4614 lines of diff (skipped)

1 0

commit ghc-haskell-tools-prettyprint for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-prettyprint for openSUSE:Factory checked in at 2017-08-31 20:56:06 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-prettyprint" Thu Aug 31 20:56:06 2017 rev:2 rq:513374 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-prettyprint/ghc-haskell-tools-prettyprint.changes 2017-04-12 18:06:46.450064168 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-prettyprint.new/ghc-haskell-tools-prettyprint.changes 2017-08-31 20:56:07.286300144 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:13 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-prettyprint-0.5.0.0.tar.gz New: ---- haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-prettyprint.spec ++++++ --- /var/tmp/diff_new_pack.UgMxUS/_old 2017-08-31 20:56:08.066190567 +0200 +++ /var/tmp/diff_new_pack.UgMxUS/_new 2017-08-31 20:56:08.070190006 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-prettyprint Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Pretty printing of Haskell-Tools AST License: BSD-3-Clause @@ -33,6 +33,7 @@ BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-split-devel +BuildRequires: ghc-text-devel BuildRequires: ghc-uniplate-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build ++++++ haskell-tools-prettyprint-0.5.0.0.tar.gz -> haskell-tools-prettyprint-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/PrettyPrint.hs 2017-05-17 18:59:17.000000000 +0200 @@ -1,11 +1,11 @@ {-# LANGUAGE FlexibleInstances , FlexibleContexts , UndecidableInstances - , NamedFieldPuns + , NamedFieldPuns #-} -- | Pretty printing the AST -module Language.Haskell.Tools.PrettyPrint (prettyPrint) where +module Language.Haskell.Tools.PrettyPrint (prettyPrint, toRoseTree) where import FastString (fsLit) import SrcLoc @@ -15,16 +15,18 @@ import Language.Haskell.Tools.Transform.SourceTemplate import Control.Monad.State +import Control.Reference import Data.Foldable (Foldable(..), concat) import Data.List as List import Data.List.Split (splitOn) import Data.Sequence hiding (null, replicate) +import Debug.Trace -- | Pretty prints an AST by using source templates stored as node info prettyPrint :: (SourceInfoTraversal node) => node dom SrcTemplateStage -> String prettyPrint = toList . printRose . toRoseTree -printRose :: RoseTree SrcTemplateStage -> Seq Char +printRose :: RoseTree SrcTemplateStage -> Seq Char printRose rt = evalState (printRose' startLoc rt) startLoc where startLoc = mkRealSrcLoc (fsLit "") 1 1 @@ -34,10 +36,11 @@ printRose' :: RealSrcLoc -> RoseTree SrcTemplateStage -> PPState (Seq Char) -- simple implementation could be optimized a bit -- warning: the length of the file should not exceed maxbound::Int -printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children) +printRose' parent (RoseTree (RoseSpan (SourceTemplateNode rng elems minInd relInd)) children) = do slide <- calculateSlide rng let printTemplateElems :: [SourceTemplateElem] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) - printTemplateElems (TextElem txt : rest) children = putString slide min txt >+< printTemplateElems rest children + printTemplateElems (TextElem txtElems _ : rest) children = putString slide min txt >+< printTemplateElems rest children + where txt = concatMap (^. sourceTemplateText) txtElems printTemplateElems (ChildElem : rest) (child : children) = printRose' parent child >+< printTemplateElems rest children printTemplateElems [] [] = return empty printTemplateElems _ [] = error $ "More child elem in template than actual children (elems: " ++ show elems ++ ", children: " ++ show children ++ ")" @@ -46,81 +49,87 @@ min = minInd `max` getPosByRelative parent relInd printTemplateElems elems children - + printRose' _ (RoseTree (RoseList (SourceTemplateList {})) []) = return empty -printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) +printRose' parent (RoseTree (RoseList (SourceTemplateList rng bef aft defSep indented seps minInd relInd)) children) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd - putString slide min bef - >+< (if indented then printListWithSepsIndented else printListWithSeps) actRng slide min actualSeps children + putString slide min bef + >+< (maybe printListWithSeps printListWithSepsIndented indented) actRng slide min actualSeps children >+< putString slide min aft - where actualSeps = case seps of [] -> repeat defSep - _ -> seps ++ repeat (last seps) + where stringSeps :: [String] + stringSeps = map (concatMap (^. sourceTemplateText)) (map fst seps) + actualSeps = case stringSeps of [] -> repeat defSep + _ -> stringSeps ++ repeat (last stringSeps) printRose' _ (RoseTree (RoseOptional (SourceTemplateOpt {})) []) = return empty -printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child]) +printRose' parent (RoseTree (RoseOptional (SourceTemplateOpt rng bef aft minInd relInd)) [child]) = do slide <- calculateSlide rng actRng <- get let min = minInd `max` getPosByRelative parent relInd putString slide min bef >+< printRose' actRng child >+< putString slide min aft printRose' _ (RoseTree (RoseOptional _) _) = error "More than one child element in an optional node." - + getPosByRelative :: RealSrcLoc -> Maybe Int -> Int getPosByRelative sp (Just i) = srcLocCol sp + i - 1 getPosByRelative _ _ = 0 calculateSlide :: SrcSpan -> PPState Int -calculateSlide (RealSrcSpan originalSpan) = do +calculateSlide (RealSrcSpan originalSpan) = do actualSpan <- get return $ srcLocCol actualSpan - srcLocCol (realSrcSpanStart originalSpan) calculateSlide _ = return 0 putString :: Int -> Int -> String -> PPState (Seq Char) -putString slide minInd s +putString slide minInd s = do modify $ advanceStr newStr return (fromList newStr) where start:rest = splitOn "\n" s newStr = concat $ intersperse ("\n" ++ replicate slide ' ') (start : map (extendToNSpaces minInd) rest) extendToNSpaces n str = replicate n ' ' ++ (List.dropWhile (== ' ') $ List.take n str) ++ List.drop n str - + advanceStr :: String -> RealSrcLoc -> RealSrcLoc advanceStr s loc = foldl advanceSrcLoc loc s untilReaches :: String -> RealSrcLoc -> RealSrcLoc -> (String, Int) -untilReaches s start end - = let ls = splitOn "\n" s - in case ls of _:_:_ -> (unlines (init ls) ++) - `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end - _ -> (s, srcLocCol start) +untilReaches s start end + = let ls = splitOn "\n" s + in case ls of _:_:_ -> (unlines (init ls) ++) + `mapFst` untilReaches' (last ls) (advanceSrcLoc start '\n') end + _ -> (s, srcLocCol $ foldl advanceSrcLoc start s) where untilReaches' [] curr _ = ([], srcLocCol curr) untilReaches' (c:rest) curr until | srcLocCol advancedLoc <= srcLocCol until = (c:) `mapFst` untilReaches' rest advancedLoc until where advancedLoc = advanceSrcLoc curr c untilReaches' _ curr _ = ([], srcLocCol curr) - + mapFst :: (a -> b) -> (a, x) -> (b, x) mapFst f (a, x) = (f a, x) (>+<) :: PPState (Seq Char) -> PPState (Seq Char) -> PPState (Seq Char) (>+<) = liftM2 (><) - + printListWithSeps :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps = printListWithSeps' putString +printListWithSeps = printListWithSeps' (const putString) 0 -- | Prints the elements of a list where the elements must be printed in the same line (do stmts, case alts, let binds, ...) -printListWithSepsIndented :: RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSepsIndented parent slide minInd seps children +printListWithSepsIndented :: [Bool] -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSepsIndented indentedChildren parent slide minInd seps children = do base <- get - let putCorrectSep _ min s = do curr <- get - let (shortened, currCol) = untilReaches s curr base - putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' - printListWithSeps' putCorrectSep parent slide minInd seps children - -printListWithSeps' :: (Int -> Int -> String -> PPState (Seq Char)) -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) -printListWithSeps' _ _ _ _ _ [] = return empty -printListWithSeps' _ parent _ _ _ [child] = printRose' parent child -printListWithSeps' putCorrectSep parent slide minInd (sep:seps) (child:children) - = printRose' parent child >+< putCorrectSep slide minInd sep >+< printListWithSeps' putCorrectSep parent slide minInd seps children -printListWithSeps' _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" + let putCorrectSep i _ min s | isIndented i + = do curr <- get + let (shortened, currCol) = untilReaches s curr base + putString 0 min $ shortened ++ replicate (srcLocCol base - currCol) ' ' + putCorrectSep _ slide minInd s = putString slide minInd s + printListWithSeps' putCorrectSep 0 parent slide minInd seps children + where -- the ith separator is before the ith element + isIndented i = case List.drop i indentedChildren of False:_ -> False; _ -> True + +printListWithSeps' :: (Int -> Int -> Int -> String -> PPState (Seq Char)) -> Int -> RealSrcLoc -> Int -> Int -> [String] -> [RoseTree SrcTemplateStage] -> PPState (Seq Char) +printListWithSeps' _ _ _ _ _ _ [] = return empty +printListWithSeps' _ _ parent _ _ _ [child] = printRose' parent child +printListWithSeps' putCorrectSep i parent slide minInd (sep:seps) (child:children) + = printRose' parent child >+< putCorrectSep i slide minInd sep >+< printListWithSeps' putCorrectSep (i+1) parent slide minInd seps children +printListWithSeps' _ _ _ _ _ [] _ = error "printListWithSeps': the number of elements and separators does not match" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/PlaceComments.hs 2017-06-05 18:15:07.000000000 +0200 @@ -1,68 +1,78 @@ {-# LANGUAGE ScopedTypeVariables - , FlexibleContexts - , LambdaCase + , FlexibleContexts + , LambdaCase #-} -- | This transformation expands nodes to contain the comments that should be attached to them. After this, a -- normalizing transformation should be performed that expands parents to contain their children. module Language.Haskell.Tools.Transform.PlaceComments where +import Control.Monad.Reader import Control.Monad.State import Control.Monad.Writer import Control.Reference hiding (element) import Data.Char (isSpace, isAlphaNum) import qualified Data.Map as Map +import Data.Map (Map) import Data.Maybe -import qualified Data.Set as Set (lookupLE, lookupGE, fromList) +import qualified Data.Set as Set +import Data.Set (Set) -import ApiAnnotation (AnnotationComment(..)) +import ApiAnnotation (ApiAnnKey, AnnotationComment(..)) import SrcLoc import Language.Haskell.Tools.AST -getNormalComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] +getNormalComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map SrcSpan [Located AnnotationComment] getNormalComments = Map.map (filter (not . isPragma . unLoc)) -getPragmaComments :: Map.Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] -getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) - $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms +getPragmaComments :: Map SrcSpan [Located AnnotationComment] -> Map.Map String [Located String] +getPragmaComments comms = Map.fromListWith (++) $ map (\(L l (AnnBlockComment str)) -> (getPragmaCommand str, [L l str])) + $ filter (isPragma . unLoc) $ concatMap snd $ Map.toList comms where getPragmaCommand = takeWhile (\c -> isAlphaNum c || c == '_') . dropWhile isSpace . drop 3 isPragma :: AnnotationComment -> Bool isPragma (AnnBlockComment str) = take 3 str == "{-#" && take 3 (reverse str) == "}-#" isPragma _ = False --- | Puts comments in the nodes they should be attached to. Leaves the AST in a state where parent nodes --- does not contain all of their children. -placeComments :: RangeInfo stage => Map.Map SrcSpan [Located AnnotationComment] - -> Ann UModule dom stage - -> Ann UModule dom stage -placeComments comms mod - = resizeAnnots (concatMap (map nextSrcLoc . snd) (Map.toList comms)) mod +-- | Puts comments in the nodes they should be attached to. Watches for lexical tokens +-- that may divide the comment and the supposed element. +-- Leaves the AST in a state where parent nodes does not contain all of their children. +placeComments :: RangeInfo stage => Map ApiAnnKey [SrcSpan] -> Map.Map SrcSpan [Located AnnotationComment] + -> Ann UModule dom stage -> Ann UModule dom stage +placeComments tokens comms mod + = resizeAnnots (Set.filter (\rng -> srcSpanStart rng /= srcSpanEnd rng) $ Set.fromList $ concat (Map.elems tokens)) + (concatMap (map nextSrcLoc . snd) (Map.toList cleanedComments)) mod where spans = allElemSpans mod sortedElemStarts = Set.fromList $ map srcSpanStart spans sortedElemEnds = Set.fromList $ map srcSpanEnd spans - nextSrcLoc comm@(L sp _) + nextSrcLoc comm@(L sp _) = let after = fromMaybe noSrcLoc (Set.lookupLE (srcSpanStart sp) sortedElemEnds) before = fromMaybe noSrcLoc (Set.lookupGE (srcSpanEnd sp) sortedElemStarts) in ((after,before),comm) - + cleanedComments = Map.map (map cleanComment) comms + cleanComment (L loc (AnnLineComment txt)) + | last txt `elem` "\n\r" = L (mkSrcSpan (srcSpanStart loc) (decreaseCol (srcSpanEnd loc))) (AnnLineComment (init txt)) + cleanComment c = c + decreaseCol (RealSrcLoc l) = mkSrcLoc (srcLocFile l) (srcLocLine l) (srcLocCol l - 1) + decreaseCol l = l + allElemSpans :: (SourceInfoTraversal node, RangeInfo stage) => Ann node dom stage -> [SrcSpan] allElemSpans = execWriter . sourceInfoTraverse (SourceInfoTrf (\ni -> tell [ni ^. nodeSpan] >> pure ni) pure pure) - -resizeAnnots :: RangeInfo stage => [((SrcLoc, SrcLoc), Located AnnotationComment)] + +resizeAnnots :: RangeInfo stage => Set SrcSpan -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> Ann UModule dom stage -> Ann UModule dom stage -resizeAnnots comments elem - = flip evalState comments $ - -- if a comment that could be attached to more than one documentable element (possibly nested) +resizeAnnots tokens comments elem + = flip evalState comments $ flip runReaderT tokens $ + -- if a comment that could be attached to more than one documentable element (possibly nested) -- the order of different documentable elements here decide which will be chosen - + modImports&annList !~ expandAnnot -- expand imports to cover their comments >=> modDecl&annList !~ expandTopLevelDecl -- expand declarations to cover their comments >=> expandAnnot -- expand the module itself to cover its comments $ elem -type ExpandType elem dom stage = Ann elem dom stage -> State [((SrcLoc, SrcLoc), Located AnnotationComment)] (Ann elem dom stage) +type ExpandType elem dom stage = Ann elem dom stage -> ReaderT (Set SrcSpan) (State [((SrcLoc, SrcLoc), Located AnnotationComment)]) (Ann elem dom stage) expandTopLevelDecl :: RangeInfo stage => ExpandType UDecl dom stage expandTopLevelDecl @@ -84,14 +94,14 @@ expandValueBind :: RangeInfo stage => ExpandType UValueBind dom stage expandValueBind - = valBindLocals & annJust & localBinds & annList !~ expandLocalBind + = valBindLocals & annJust & localBinds & annList !~ expandLocalBind >=> funBindMatches & annList & matchBinds & annJust & localBinds & annList !~ expandLocalBind >=> expandAnnot expandLocalBind :: RangeInfo stage => ExpandType ULocalBind dom stage expandLocalBind - = localVal !~ expandValueBind - >=> localSig !~ expandTypeSig + = localVal !~ expandValueBind + >=> localSig !~ expandTypeSig >=> expandAnnot expandConDecl :: RangeInfo stage => ExpandType UConDecl dom stage @@ -106,48 +116,56 @@ expandAnnot :: forall elem dom stage . RangeInfo stage => ExpandType elem dom stage expandAnnot elem = do let Just sp = elem ^? annotation&sourceInfo&nodeSpan - applicable <- gets (applicableComments (srcSpanStart sp) (srcSpanEnd sp)) - + tokens <- ask + applicable <- lift $ gets (applicableComments tokens (srcSpanStart sp) (srcSpanEnd sp)) + -- this check is just for performance (quick return if no modification is needed) if not (null applicable) then do -- the new span is the original plus all the covered spans - let newSp@(RealSrcSpan newSpan) + let newSp@(RealSrcSpan newSpan) = foldl combineSrcSpans (fromJust $ elem ^? nodeSp) (map (getLoc . snd) applicable) -- take out all comments that are now covered - modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) + lift $ modify (filter (not . (\case RealSrcSpan s -> newSpan `containsSpan` s; _ -> True) . getLoc . snd)) return $ nodeSp .= newSp $ elem else return elem where nodeSp :: Simple Partial (Ann elem dom stage) SrcSpan nodeSp = annotation&sourceInfo&nodeSpan - --- This classification does not prefer inline comments to previous line comments, this is implicitely done + +-- This classification does not prefer inline comments to previous line comments, this is implicitly done -- by the order in which the elements are traversed. -applicableComments :: SrcLoc -> SrcLoc - -> [((SrcLoc, SrcLoc), Located AnnotationComment)] +applicableComments :: Set SrcSpan -> SrcLoc -> SrcLoc + -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -> [((SrcLoc, SrcLoc), Located AnnotationComment)] -applicableComments start end = filter applicableComment +applicableComments tokens start end = filter applicableComment where -- A comment that starts with | binds to the next documented element - applicableComment ((_, before), L _ comm) - | isCommentOnNext comm = before == start + applicableComment ((_, before), L sp comm) + | isCommentOnNext comm = before == start && noTokenBetween (srcSpanEnd sp) start -- A comment that starts with ^ binds to the previous documented element - applicableComment ((after, _), L _ comm) - | isCommentOnPrev comm = after == end + applicableComment ((after, _), L sp comm) + | isCommentOnPrev comm = after == end && noTokenBetween end (srcSpanStart sp) -- All other comment binds to the previous definition if it is on the same line - applicableComment ((after, _), L (RealSrcSpan loc) _) + applicableComment ((after, _), L sp@(RealSrcSpan loc) _) | after == end && srcLocLine (realSrcSpanStart loc) == getLineLocDefault end = True + && noTokenBetween end (srcSpanStart sp) -- or the next one if that is on the next line and the columns line up - applicableComment ((_, before), L (RealSrcSpan loc) _) + applicableComment ((_, before), L sp@(RealSrcSpan loc) _) | before == start && srcLocLine (realSrcSpanEnd loc) + 1 == getLineLocDefault start && srcLocCol (realSrcSpanStart loc) == getLineColDefault start + && noTokenBetween (srcSpanEnd sp) start = True applicableComment _ = False - + getLineLocDefault (RealSrcLoc l) = srcLocLine l getLineLocDefault _ = -1 getLineColDefault (RealSrcLoc l) = srcLocCol l getLineColDefault _ = -1 + noTokenBetween start end + = case Set.lookupGE (srcLocSpan start) tokens of + Just tok -> srcSpanStart tok >= end + Nothing -> True + -- * GHC mistakenly parses -- ^ and -- | comments as simple line comments. -- These functions check if a given comment is attached to the previous or next comment. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -15,14 +15,14 @@ instance SourceInfo RngTemplateStage where data SpanInfo RngTemplateStage = RangeTemplateNode { _rngTemplateNodeRange :: RealSrcSpan - , _rngTemplateNodeElems :: [RangeTemplateElem] + , _rngTemplateNodeElems :: [RangeTemplateElem] } deriving Data data ListInfo RngTemplateStage = RangeTemplateList { _rngTemplateListRange :: RealSrcSpan , _rngTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _rngTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated , _rngTmpDefaultSeparator :: String -- ^ The default separator if the list were empty - , _rngTmpIndented :: Bool -- ^ True, if the elements need to be aligned in the same column + , _rngTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned , _rngTmpSeparators :: [RealSrcSpan] -- ^ The actual separators that were found in the source code } deriving Data @@ -51,7 +51,7 @@ rngTmpDefaultSeparator :: Simple Lens (ListInfo RngTemplateStage) String rngTmpDefaultSeparator = lens _rngTmpDefaultSeparator (\v s -> s { _rngTmpDefaultSeparator = v }) -rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) Bool +rngTmpIndented :: Simple Lens (ListInfo RngTemplateStage) (Maybe [Bool]) rngTmpIndented = lens _rngTmpIndented (\v s -> s { _rngTmpIndented = v }) rngTmpSeparators :: Simple Lens (ListInfo RngTemplateStage) [RealSrcSpan] @@ -75,19 +75,19 @@ getRangeElemSpan (RangeElem sp) = Just sp getRangeElemSpan _ = Nothing -instance HasRange (SpanInfo RngTemplateStage) where +instance HasRange (SpanInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateNodeRange) setRange (RealSrcSpan sp) = rngTemplateNodeRange .= sp setRange _ = id -instance HasRange (ListInfo RngTemplateStage) where - getRange = RealSrcSpan . (^. rngTemplateListRange) - setRange (RealSrcSpan sp) = rngTemplateListRange .= sp +instance HasRange (ListInfo RngTemplateStage) where + getRange = RealSrcSpan . (^. rngTemplateListRange) + setRange (RealSrcSpan sp) = rngTemplateListRange .= sp setRange _ = id -instance HasRange (OptionalInfo RngTemplateStage) where +instance HasRange (OptionalInfo RngTemplateStage) where getRange = RealSrcSpan . (^. rngTemplateOptRange) - setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp + setRange (RealSrcSpan sp) = rngTemplateOptRange .= sp setRange _ = id instance Show (SpanInfo RngTemplateStage) where @@ -96,7 +96,7 @@ show RangeTemplateList{..} = "<*" ++ shortShowSpan (RealSrcSpan _rngTemplateListRange) ++ " " ++ show _rngTmpListBefore ++ " " ++ show _rngTmpDefaultSeparator ++ " " ++ show _rngTmpListAfter ++ "*>" instance Show (OptionalInfo RngTemplateStage) where show RangeTemplateOpt{..} = "<?" ++ shortShowSpan (RealSrcSpan _rngTemplateOptRange) ++ " " ++ show _rngTmpOptBefore ++ " " ++ show _rngTmpOptAfter ++ "?>" - + instance Show RangeTemplateElem where show (RangeElem sp) = shortShowSpan (RealSrcSpan sp) show RangeChildElem = "<.>" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeTemplateToSourceTemplate.hs 2017-05-24 19:51:13.000000000 +0200 @@ -1,65 +1,107 @@ -{-# LANGUAGE LambdaCase +{-# LANGUAGE LambdaCase , FlexibleContexts #-} --- | This module converts range templates into source templates. +-- | This module converts range templates into source templates. -- Basically it reads the source file and attaches parts of the source file to the AST elements that have the range of the given source code fragment. module Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate where +import Control.Monad.Identity import Control.Monad.State -import Control.Reference ((^.)) -import Data.Map +import Control.Reference +import Data.Map as Map +import Data.Ord (Ord(..), Ordering(..)) +import Data.Set as Set +import Data.List +import Data.List.Split +import FastString (mkFastString) import Language.Haskell.Tools.AST import Language.Haskell.Tools.Transform.RangeTemplate import Language.Haskell.Tools.Transform.SourceTemplate import SrcLoc import StringBuffer (StringBuffer, nextChar, atEnd) +import Debug.Trace rangeToSource :: SourceInfoTraversal node => StringBuffer -> Ann node dom RngTemplateStage -> Ann node dom SrcTemplateStage rangeToSource srcInput tree = let locIndices = getLocIndices tree srcMap = mapLocIndices srcInput locIndices - in applyFragments (elems srcMap) tree + in applyFragments (Map.elems srcMap) tree -- maps could be strict -- | Assigns an index (in the order they are used) for each range -getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Map OrdSrcSpan Int -getLocIndices = snd . flip execState (0, empty) . - sourceInfoTraverseDown (SourceInfoTrf +getLocIndices :: SourceInfoTraversal e => Ann e dom RngTemplateStage -> Set (RealSrcLoc, Int) +getLocIndices = snd . flip execState (0, Set.empty) . + sourceInfoTraverseDown (SourceInfoTrf (\ni -> do { mapM_ (\el -> case getRangeElemSpan el of Just sp -> modify (insertElem sp); _ -> return ()) (ni ^. rngTemplateNodeElems); return ni }) (\ni -> do { mapM_ (modify . insertElem) (ni ^. rngTmpSeparators); return ni }) - pure ) + pure ) (return ()) (return ()) - where insertElem sp (i,m) = (i+1, insert (OrdSrcSpan sp) i m) - - + where insertElem sp (i,m) = (i+1, Set.insert (realSrcSpanEnd sp, i) m) + -- | Partitions the source file in the order where the parts are used in the AST -mapLocIndices :: Ord k => StringBuffer -> Map OrdSrcSpan k -> Map k String -mapLocIndices inp = fst . foldlWithKey (\(new, str) sp k -> let (rem, val) = takeSpan str sp - in (insert k (reverse val) new, rem)) (empty, inp) - where takeSpan :: StringBuffer -> OrdSrcSpan -> (StringBuffer, String) - takeSpan str (OrdSrcSpan sp) = takeSpan' (realSrcSpanStart sp) (realSrcSpanEnd sp) (str,"") - takeSpan _ (NoOrdSrcSpan {}) = error "takeSpan: missing source span" - - takeSpan' :: RealSrcLoc -> RealSrcLoc -> (StringBuffer, String) -> (StringBuffer, String) - takeSpan' start end (sb, taken) | start < end && not (atEnd sb) - = let (c,rem) = nextChar sb in takeSpan' (advanceSrcLoc start c) end (rem, c:taken) - takeSpan' _ _ (rem, taken) = (rem, taken) - +mapLocIndices :: Ord k => StringBuffer -> Set (RealSrcLoc, k) -> Map k String +mapLocIndices inp = (^. _1) . Set.foldl (\(new, str, pos) (sp, k) -> let (rem, val, newPos) = takeSpan str pos sp + in (Map.insert k (reverse val) new, rem, newPos)) + (Map.empty, inp, mkRealSrcLoc (mkFastString "") 1 1) + where takeSpan :: StringBuffer -> RealSrcLoc -> RealSrcLoc -> (StringBuffer, String, RealSrcLoc) + takeSpan str pos end = takeSpan' end (str,"", pos) + + takeSpan' :: RealSrcLoc -> (StringBuffer, String, RealSrcLoc) -> (StringBuffer, String, RealSrcLoc) + takeSpan' end (sb, taken, pos) | (srcLocLine pos `compare` srcLocLine end) `thenCmp` (srcLocCol pos `compare` srcLocCol end) == LT && not (atEnd sb) + = let (c,rem) = nextChar sb in takeSpan' end (rem, c:taken, advanceSrcLoc pos c) + takeSpan' _ (rem, taken, pos) = (rem, taken, pos) + + thenCmp EQ o2 = o2 + thenCmp o1 _ = o1 + -- | Replaces the ranges in the AST with the source file parts applyFragments :: SourceInfoTraversal node => [String] -> Ann node dom RngTemplateStage -> Ann node dom SrcTemplateStage applyFragments srcs = flip evalState srcs . sourceInfoTraverseDown (SourceInfoTrf (\ni -> do template <- mapM getTextFor (ni ^. rngTemplateNodeElems) - return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) template 0 Nothing) - (\(RangeTemplateList rng bef aft sep indented seps) - -> do (own, rest) <- splitAt (length seps) <$> get + return $ SourceTemplateNode (RealSrcSpan $ ni ^. rngTemplateNodeRange) (concat template) 0 Nothing) + (\(RangeTemplateList rng bef aft sep indented seps) + -> do (own, rest) <- splitAt (length seps) <$> get put rest - return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented own 0 Nothing)) - (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 0 Nothing))) + return (SourceTemplateList (RealSrcSpan rng) bef aft sep indented (Prelude.zip (Prelude.map ((:[]) . NormalText) own) (Prelude.map RealSrcSpan seps)) 0 Nothing)) + (\(RangeTemplateOpt rng bef aft) -> return (SourceTemplateOpt (RealSrcSpan rng) bef aft 0 Nothing))) (return ()) (return ()) - where getTextFor RangeChildElem = return ChildElem - getTextFor (RangeElem _) = do (src:rest) <- get - put rest - return (TextElem src) \ No newline at end of file + where getTextFor RangeChildElem = return [ChildElem] + getTextFor (RangeElem rng) = do (src:rest) <- get + put rest + return [TextElem [NormalText src] (RealSrcSpan rng)] + +-- | Marks template elements in the AST that should always be present in the source code, regardless of their +-- containing elements being deleted. +-- Currently it recognizes CPP pragmas (lines starting with #) +-- This function should only be applied to an AST if CPP is enabled. +extractStayingElems :: SourceInfoTraversal node => Ann node dom SrcTemplateStage -> Ann node dom SrcTemplateStage +extractStayingElems = runIdentity . sourceInfoTraverse (SourceInfoTrf + (sourceTemplateNodeElems & traversal & sourceTemplateTextElem !- breakStaying) + (srcTmpSeparators & traversal & _1 !- breakStaying) + pure) + + where -- splits the elements into separate lines and then recombines them + breakStaying :: [SourceTemplateTextElem] -> [SourceTemplateTextElem] + breakStaying = concat . Prelude.map (\(NormalText s) -> toTxtElems s) + + toTxtElems :: String -> [SourceTemplateTextElem] + toTxtElems str = extractStaying $ splitOn "\n" $ str + where + extractStaying lines | not (any ("#" `isPrefixOf`) lines) = [NormalText str] + extractStaying lines = Prelude.foldr appendTxt [] + $ Prelude.map (\ln -> if "#" `isPrefixOf` ln then StayingText ln "\n" else NormalText ln) lines + -- recombines the lines if they are both normal text + -- otherwise it moves the windows '\r' characters to the correct position + appendTxt (NormalText n1) (NormalText n2 : rest) = NormalText (n1 ++ '\n':n2) : rest + appendTxt e (next@NormalText{} : ls) = case reverse (e ^. sourceTemplateText) of + -- fix '\r' characters that are separated from '\n' + '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : (sourceTemplateText .- ("\r\n" ++) $ next) : ls + _ -> e : (sourceTemplateText .- ('\n':) $ next) : ls + appendTxt e (next : ls) = case reverse (e ^. sourceTemplateText) of + -- fix '\r' characters that are separated from '\n' + '\r':_ -> ((sourceTemplateText .- init) . (lineEndings .= "\r\n") $ e) : NormalText "\r\n" : next : ls + _ -> e : NormalText "\n" : next : ls + appendTxt e [] = [e] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/RangeToRangeTemplate.hs 2017-06-14 16:16:01.000000000 +0200 @@ -11,7 +11,7 @@ import Control.Monad.State import Control.Reference ((^.)) import Data.List -import Data.Maybe (Maybe(..), maybe, mapMaybe) +import Data.Maybe (Maybe(..), mapMaybe) import FastString as GHC (unpackFS) import SrcLoc @@ -20,17 +20,17 @@ -- | Creates a source template from the ranges and the input file. -- All source ranges must be good ranges. -cutUpRanges :: forall node dom . SourceInfoTraversal node +cutUpRanges :: forall node dom . SourceInfoTraversal node => Ann node dom NormRangeStage -> Ann node dom RngTemplateStage cutUpRanges n = evalState (cutUpRanges' n) [[],[]] where cutUpRanges' :: Ann node dom NormRangeStage -> State [[SrcSpan]] (Ann node dom RngTemplateStage) cutUpRanges' = sourceInfoTraverseUp (SourceInfoTrf (trf cutOutElemSpan) (trf cutOutElemList) (trf cutOutElemOpt)) desc asc - + -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + -- combine the current node with its children, and add it to the list of current nodes trf :: HasRange (x RngTemplateStage) => ([SrcSpan] -> x NormRangeStage -> x RngTemplateStage) -> x NormRangeStage -> State [[SrcSpan]] (x RngTemplateStage) @@ -44,12 +44,12 @@ cutOutElemSpan sps (NormNodeInfo (RealSrcSpan sp)) = RangeTemplateNode sp $ foldl breakFirstHit (foldl breakFirstHit [RangeElem sp] loc) span where (loc,span) = partition (\sp -> srcSpanStart sp == srcSpanEnd sp) sps - breakFirstHit (elem:rest) sp + breakFirstHit (elem:rest) sp = case breakUpRangeElem elem sp of -- only continue if the correct place for the child range is not found Just pieces -> pieces ++ rest Nothing -> elem : breakFirstHit rest sp - breakFirstHit [] sp = error ("breakFirstHit: " ++ maybe "" unpackFS (srcSpanFileName_maybe sp) ++ " didn't find correct place for " ++ shortShowSpan sp ++ " in " ++ shortShowSpan sp ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") + breakFirstHit [] inner = error ("breakFirstHit: " ++ unpackFS (srcSpanFile sp) ++ " didn't find correct place for " ++ shortShowSpan inner ++ " in " ++ shortShowSpan (RealSrcSpan sp) ++ " with [" ++ concat (intersperse "," (map shortShowSpan sps)) ++ "]") cutOutElemSpan _ (NormNodeInfo (UnhelpfulSpan {})) = error "cutOutElemSpan: no real span" cutOutElemList :: [SrcSpan] -> ListInfo NormRangeStage -> ListInfo RngTemplateStage @@ -63,9 +63,9 @@ = mapMaybe getRangeElemSpan (cutOutElemSpan infos (NormNodeInfo (RealSrcSpan sp)) ^. rngTemplateNodeElems) -- at least two elements needed or there can be no separators getSeparators _ _ = [] - + cutOutElemOpt :: [SrcSpan] -> OptionalInfo NormRangeStage -> OptionalInfo RngTemplateStage -cutOutElemOpt sps (NormOptInfo bef aft sp) +cutOutElemOpt sps (NormOptInfo bef aft sp) = let RealSrcSpan wholeRange = foldl1 combineSrcSpans $ sp : sps in RangeTemplateOpt wholeRange bef aft @@ -73,49 +73,49 @@ -- if it is inside the range of the template element. Returns Nothing if the second argument is not inside. breakUpRangeElem :: RangeTemplateElem -> SrcSpan -> Maybe [RangeTemplateElem] breakUpRangeElem (RangeElem outer) (RealSrcSpan inner) - | outer `containsSpan` inner - = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) + | outer `containsSpan` inner + = Just $ (if (realSrcSpanStart outer) < (realSrcSpanStart inner) then [ RangeElem (mkRealSrcSpan (realSrcSpanStart outer) (realSrcSpanStart inner)) ] else []) ++ [ RangeChildElem ] ++ - (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) + (if (realSrcSpanEnd inner) < (realSrcSpanEnd outer) then [ RangeElem (mkRealSrcSpan (realSrcSpanEnd inner) (realSrcSpanEnd outer)) ] else []) breakUpRangeElem _ _ = Nothing -- | Modifies ranges to contain their children -fixRanges :: SourceInfoTraversal node - => Ann node dom RangeStage +fixRanges :: SourceInfoTraversal node + => Ann node dom RangeStage -> Ann node dom NormRangeStage fixRanges node = evalState (sourceInfoTraverseUp (SourceInfoTrf (trf expandToContain) (trf expandListToContain) (trf expandOptToContain)) desc asc node) [[],[]] where -- keep the stack to contain the children elements on the place of the parent element desc = modify ([]:) asc = modify tail - + trf :: HasRange (x NormRangeStage) => ([SrcSpan] -> x RangeStage -> x NormRangeStage) -> x RangeStage -> State [[SrcSpan]] (x NormRangeStage) trf f ni = do (below : top : xs) <- get let res = f below ni resRange = getRange res endOfSiblings = srcSpanEnd (collectSpanRanges (srcSpanStart resRange) top) - correctedRange = if endOfSiblings > srcSpanStart resRange - then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) + correctedRange = if endOfSiblings > srcSpanStart resRange + then mkSrcSpan endOfSiblings (max endOfSiblings (srcSpanEnd resRange)) else resRange put ([] : (top ++ [ correctedRange ]) : xs) return $ setRange correctedRange res -- | Expand a simple node to contain its children expandToContain :: [SrcSpan] -> SpanInfo RangeStage -> SpanInfo NormRangeStage -expandToContain cont (NodeSpan sp) +expandToContain cont (NodeSpan sp) = NormNodeInfo (checkSpans cont $ foldl1 combineSrcSpans $ sp : cont) expandListToContain :: [SrcSpan] -> ListInfo RangeStage -> ListInfo NormRangeStage -expandListToContain cont (ListPos bef aft def ind sp) +expandListToContain cont (ListPos bef aft def ind sp) = NormListInfo bef aft def ind (checkSpans cont $ collectSpanRanges sp cont) expandOptToContain :: [SrcSpan] -> OptionalInfo RangeStage -> OptionalInfo NormRangeStage -expandOptToContain cont (OptionalPos bef aft sp) +expandOptToContain cont (OptionalPos bef aft sp) = NormOptInfo bef aft (checkSpans cont $ collectSpanRanges sp cont) collectSpanRanges :: SrcLoc -> [SrcSpan] -> SrcSpan @@ -124,8 +124,7 @@ -- | Checks the contained source ranges to detect the convertion problems where we can see their location. checkSpans :: [SrcSpan] -> SrcSpan -> SrcSpan -checkSpans spans res - = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res +checkSpans spans res + = if any (not . isGoodSrcSpan) spans && isGoodSrcSpan res then error $ "Wrong src spans in " ++ show res else res - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplate.hs 2017-05-03 22:13:56.000000000 +0200 @@ -5,7 +5,7 @@ , RecordWildCards , TypeFamilies #-} --- | The final version of the source annotation. Each node contains its original textual format, with the places of +-- | The final version of the source annotation. Each node contains its original textual format, with the places of -- the children specified by placeholders. module Language.Haskell.Tools.Transform.SourceTemplate where @@ -15,25 +15,25 @@ import SrcLoc instance SourceInfo SrcTemplateStage where - data SpanInfo SrcTemplateStage + data SpanInfo SrcTemplateStage = SourceTemplateNode { _sourceTemplateNodeRange :: SrcSpan -- ^ The (original) range of the given element , _sourceTemplateNodeElems :: [SourceTemplateElem] -- ^ The children of the given node, could be text or child nodes , _srcTmpMinInd :: Int -- ^ Minimum indentation for the element , _srcTmpRelPos :: Maybe Int -- ^ Relative indentation for newly created elements } deriving (Eq, Ord, Data) - data ListInfo SrcTemplateStage + data ListInfo SrcTemplateStage = SourceTemplateList { _sourceTemplateListRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpListBefore :: String -- ^ Text that should be put before the first element if the list becomes populated , _srcTmpListAfter :: String -- ^ Text that should be put after the last element if the list becomes populated , _srcTmpDefaultSeparator :: String -- ^ The default separator if the list were empty - , _srcTmpIndented :: Bool -- ^ True, if the elements need to be aligned in the same column - , _srcTmpSeparators :: [String] -- ^ The actual separators that were found in the source code + , _srcTmpIndented :: Maybe [Bool] -- ^ False for elements that should be not aligned + , _srcTmpSeparators :: [([SourceTemplateTextElem], SrcSpan)] -- ^ The actual separators that were found in the source code , _srcTmpListMinInd :: Int -- ^ Minimum indentation for the element , _srcTmpListRelPos :: Maybe Int -- ^ Relative indentation for newly created elements } deriving (Eq, Ord, Data) - data OptionalInfo SrcTemplateStage + data OptionalInfo SrcTemplateStage = SourceTemplateOpt { _sourceTemplateOptRange :: SrcSpan -- ^ The (original) range of the given element , _srcTmpOptBefore :: String -- ^ Text that should be put before the element if it appears , _srcTmpOptAfter :: String -- ^ Text that should be put after the element if it appears @@ -70,10 +70,10 @@ srcTmpDefaultSeparator :: Simple Lens (ListInfo SrcTemplateStage) String srcTmpDefaultSeparator = lens _srcTmpDefaultSeparator (\v s -> s { _srcTmpDefaultSeparator = v }) -srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) Bool +srcTmpIndented :: Simple Lens (ListInfo SrcTemplateStage) (Maybe [Bool]) srcTmpIndented = lens _srcTmpIndented (\v s -> s { _srcTmpIndented = v }) -srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [String] +srcTmpSeparators :: Simple Lens (ListInfo SrcTemplateStage) [([SourceTemplateTextElem], SrcSpan)] srcTmpSeparators = lens _srcTmpSeparators (\v s -> s { _srcTmpSeparators = v }) srcTmpListMinimalIndent :: Simple Lens (ListInfo SrcTemplateStage) Int @@ -95,39 +95,54 @@ srcTmpOptMinimalIndent :: Simple Lens (OptionalInfo SrcTemplateStage) Int srcTmpOptMinimalIndent = lens _srcTmpOptMinInd (\v s -> s { _srcTmpOptMinInd = v }) - + srcTmpOptRelPos :: Simple Lens (OptionalInfo SrcTemplateStage) (Maybe Int) srcTmpOptRelPos = lens _srcTmpOptRelPos (\v s -> s { _srcTmpOptRelPos = v }) - + -- | An element of a source template for a singleton AST node. data SourceTemplateElem - = TextElem { _sourceTemplateText :: String } -- ^ Source text belonging to the current node + = TextElem { _sourceTemplateTextElem :: [SourceTemplateTextElem] + , _sourceTemplateTextRange :: SrcSpan + } -- ^ Source text belonging to the current node | ChildElem -- ^ Placeholder for the next children of the node deriving (Eq, Ord, Data) +isStayingText :: SourceTemplateTextElem -> Bool +isStayingText StayingText{} = True +isStayingText _ = False + +data SourceTemplateTextElem + = NormalText { _sourceTemplateText :: String } + | StayingText { _sourceTemplateText :: String, _lineEndings :: String } + deriving (Eq, Ord, Data) + makeReferences ''SourceTemplateElem +makeReferences ''SourceTemplateTextElem -instance HasRange (SpanInfo SrcTemplateStage) where - getRange = (^. sourceTemplateNodeRange) - setRange = (sourceTemplateNodeRange .=) - -instance HasRange (ListInfo SrcTemplateStage) where - getRange = (^. sourceTemplateListRange) - setRange = (sourceTemplateListRange .=) - -instance HasRange (OptionalInfo SrcTemplateStage) where +instance HasRange (SpanInfo SrcTemplateStage) where + getRange = (^. sourceTemplateNodeRange) + setRange = (sourceTemplateNodeRange .=) + +instance HasRange (ListInfo SrcTemplateStage) where + getRange = (^. sourceTemplateListRange) + setRange = (sourceTemplateListRange .=) + +instance HasRange (OptionalInfo SrcTemplateStage) where getRange = (^. sourceTemplateOptRange) - setRange = (sourceTemplateOptRange .=) - + setRange = (sourceTemplateOptRange .=) + instance Show (SpanInfo SrcTemplateStage) where show (SourceTemplateNode _ sp _ _) = concatMap show sp instance Show (ListInfo SrcTemplateStage) where - show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ "*>" + show SourceTemplateList{..} = "<*" ++ show _srcTmpListBefore ++ " " ++ show _srcTmpDefaultSeparator ++ " " ++ show _srcTmpListAfter ++ " " ++ show _srcTmpSeparators ++ "*>" instance Show (OptionalInfo SrcTemplateStage) where show SourceTemplateOpt{..} = "<?" ++ show _srcTmpOptBefore ++ " " ++ show _srcTmpOptAfter ++ "?>" instance Show SourceTemplateElem where - show (TextElem s) = s + show (TextElem s _) = show s show ChildElem = "<.>" +instance Show SourceTemplateTextElem where + show (NormalText s) = show s + show (StayingText s _) = "|" ++ show s ++ "|" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-01-31 20:47:41.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform/SourceTemplateHelpers.hs 2017-05-03 22:13:56.000000000 +0200 @@ -16,7 +16,7 @@ type ASTMulti node dom = AnnListG node dom SrcTemplateStage instance IsString (SpanInfo SrcTemplateStage) where - fromString s = SourceTemplateNode noSrcSpan [TextElem s] 0 Nothing + fromString s = SourceTemplateNode noSrcSpan [TextElem [NormalText s] noSrcSpan] 0 Nothing -- * Basic elements child :: SpanInfo SrcTemplateStage @@ -26,7 +26,7 @@ opt = SourceTemplateOpt noSrcSpan "" "" 0 Nothing list :: ListInfo SrcTemplateStage -list = SourceTemplateList noSrcSpan "" "" "" False [] 0 Nothing +list = SourceTemplateList noSrcSpan "" "" "" Nothing [] 0 Nothing -- * Modifiers @@ -77,7 +77,7 @@ -- | The elements of the list should be indented on the same column indented :: ListInfo SrcTemplateStage -> ListInfo SrcTemplateStage -indented = (srcTmpIndented .= True) . (srcTmpDefaultSeparator .= "\n") +indented = (srcTmpIndented .= Just []) . (srcTmpDefaultSeparator .= "\n") -- | Concatenates two source templates to produce a new template with all child elements. (<>) :: SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage -> SpanInfo SrcTemplateStage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs --- old/haskell-tools-prettyprint-0.5.0.0/Language/Haskell/Tools/Transform.hs 2017-01-31 20:47:40.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/Language/Haskell/Tools/Transform.hs 2017-05-24 22:37:50.000000000 +0200 @@ -1,6 +1,6 @@ -- | A module for preparing the representation of the AST for pretty printing. module Language.Haskell.Tools.Transform - ( prepareAST + ( prepareAST, prepareASTCpp -- comment handling , placeComments, getNormalComments, getPragmaComments -- generating source templates @@ -9,20 +9,32 @@ , sourceTemplateNodeRange, sourceTemplateNodeElems , sourceTemplateListRange, srcTmpListBefore, srcTmpListAfter, srcTmpDefaultSeparator, srcTmpIndented, srcTmpSeparators , sourceTemplateOptRange, srcTmpOptBefore, srcTmpOptAfter + , SourceTemplateElem(..), sourceTemplateTextElem, sourceTemplateTextRange, SourceTemplateTextElem(..), sourceTemplateText, lineEndings, isStayingText -- parts of the transformation, used for debugging purposes - , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices + , rangeToSource, fixRanges, cutUpRanges, getLocIndices, mapLocIndices, fixMainRange, extractStayingElems ) where import Language.Haskell.Tools.Transform.PlaceComments (getNormalComments, getPragmaComments, placeComments) import Language.Haskell.Tools.Transform.RangeTemplate () -import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices) +import Language.Haskell.Tools.Transform.RangeTemplateToSourceTemplate (rangeToSource, getLocIndices, mapLocIndices, extractStayingElems) import Language.Haskell.Tools.Transform.RangeToRangeTemplate (cutUpRanges, fixRanges) import Language.Haskell.Tools.Transform.SourceTemplate import Language.Haskell.Tools.Transform.SourceTemplateHelpers +import FastString (mkFastString) import Language.Haskell.Tools.AST -import StringBuffer (StringBuffer) +import SrcLoc +import StringBuffer (StringBuffer, nextChar, atEnd) -- | Prepares the AST for pretty printing -prepareAST :: SourceInfoTraversal node => StringBuffer -> Ann node dom RangeStage -> Ann node dom SrcTemplateStage +prepareAST :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage prepareAST srcBuffer = rangeToSource srcBuffer . cutUpRanges . fixRanges + +prepareASTCpp :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom SrcTemplateStage +prepareASTCpp srcBuffer = extractStayingElems . rangeToSource srcBuffer . cutUpRanges . fixRanges . fixMainRange srcBuffer + +fixMainRange :: StringBuffer -> Ann UModule dom RangeStage -> Ann UModule dom RangeStage +fixMainRange buffer mod = setRange (mkSrcSpan (srcSpanStart $ getRange mod) (RealSrcLoc (endPos startPos buffer))) mod + where startPos = mkRealSrcLoc (mkFastString "") 1 1 + endPos pos buf | atEnd buf = pos + endPos pos buf = let (ch,buf') = nextChar buf in endPos (advanceSrcLoc pos ch) buf' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal --- old/haskell-tools-prettyprint-0.5.0.0/haskell-tools-prettyprint.cabal 2017-01-31 20:55:48.000000000 +0100 +++ new/haskell-tools-prettyprint-0.8.0.0/haskell-tools-prettyprint.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-prettyprint -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Pretty printing of Haskell-Tools AST description: Converts the Haskell-Tools AST to text. Prepares the AST for this conversion. If the AST was created from the GHC AST this pretty printing will result in the original source code. Generated AST parts will get the default formatting. Works using the source annotations that are present in the AST. Creates a rose tree first to simplify the conversion. homepage: https://github.com/haskell-tools/haskell-tools @@ -12,7 +12,7 @@ cabal-version: >=1.10 library - ghc-options: -O2 + ghc-options: -O2 exposed-modules: Language.Haskell.Tools.PrettyPrint , Language.Haskell.Tools.Transform , Language.Haskell.Tools.IndentationUtils @@ -29,6 +29,7 @@ , references >= 0.3 && < 0.4 , uniplate >= 1.6 && < 1.7 , split >= 0.2 && < 0.3 + , text >= 1.2 && < 1.3 , ghc >= 8.0 && < 8.1 - , haskell-tools-ast >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , haskell-tools-ast >= 0.8 && < 0.9 + default-language: Haskell2010

1 0

commit ghc-haskell-tools-demo for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-demo for openSUSE:Factory checked in at 2017-08-31 20:56:04 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-demo" Thu Aug 31 20:56:04 2017 rev:2 rq:513373 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-demo/ghc-haskell-tools-demo.changes 2017-04-12 18:06:45.838150689 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-demo.new/ghc-haskell-tools-demo.changes 2017-08-31 20:56:06.042474906 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:08:14 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-demo-0.5.0.0.tar.gz New: ---- haskell-tools-demo-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-demo.spec ++++++ --- /var/tmp/diff_new_pack.T1hxQe/_old 2017-08-31 20:56:06.774372073 +0200 +++ /var/tmp/diff_new_pack.T1hxQe/_new 2017-08-31 20:56:06.790369825 +0200 @@ -19,7 +19,7 @@ %global pkg_name haskell-tools-demo %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: A web-based demo for Haskell-tools Refactor License: BSD-3-Clause ++++++ haskell-tools-demo-0.5.0.0.tar.gz -> haskell-tools-demo-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal --- old/haskell-tools-demo-0.5.0.0/haskell-tools-demo.cabal 2017-01-31 20:57:57.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/haskell-tools-demo.cabal 2017-07-01 12:51:24.000000000 +0200 @@ -1,6 +1,6 @@ name: haskell-tools-demo -version: 0.5.0.0 -synopsis: A web-based demo for Haskell-tools Refactor. +version: 0.8.0.0 +synopsis: A web-based demo for Haskell-tools Refactor. description: Allows websocket clients to connect and performs refactorings on demand. The clients maintain a continous connection with the server, sending changes in the source files. When a refactor request is received, it performs the changes and sends the modified source files to the client. homepage: https://github.com/haskell-tools/haskell-tools license: BSD3 @@ -11,9 +11,8 @@ build-type: Simple cabal-version: >=1.10 -library +library hs-source-dirs: src - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Demo other-modules: Language.Haskell.Tools.ASTDebug , Language.Haskell.Tools.ASTDebug.Instances @@ -22,38 +21,38 @@ , transformers >= 0.5 && < 0.6 , directory >= 1.2 && < 1.4 , containers >= 0.5 && < 0.6 - , aeson >= 1.0 && < 1.2 + , aeson >= 1.0 && < 1.3 , bytestring >= 0.10 && < 0.11 , http-types >= 0.9 && < 0.10 , warp >= 3.2 && < 3.3 , wai >= 3.2 && < 3.3 - , websockets >= 0.10 && < 0.11 + , websockets >= 0.10 && < 0.12 , wai-websockets >= 3.0 && < 3.1 , references >= 0.3 && < 0.4 - , ghc >= 8.0 && < 8.1 + , ghc >= 8.0.2 && < 8.1 , ghc-paths >= 0.1 && < 0.2 , filepath >= 1.4 && < 1.5 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-backend-ghc >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 default-language: Haskell2010 executable ht-demo main-is: Main.hs hs-source-dirs: exe - ghc-options: -with-rtsopts=-M1500m -O2 + ghc-options: -with-rtsopts=-M1500m build-depends: base >= 4.9 && < 4.10 - , haskell-tools-demo >= 0.5 && < 0.6 + , haskell-tools-demo >= 0.8 && < 0.9 default-language: Haskell2010 test-suite haskell-tools-demo-tests type: exitcode-stdio-1.0 - ghc-options: -with-rtsopts=-M2g -O2 + ghc-options: -with-rtsopts=-M2g hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: base >= 4.9 && < 4.10 - , HUnit >= 1.5 && < 1.6 + , HUnit >= 1.5 && < 1.7 , tasty >= 0.11 && < 0.12 , tasty-hunit >= 0.9 && < 0.10 , directory >= 1.2 && < 1.4 @@ -61,6 +60,6 @@ , bytestring >= 0.10 && < 0.11 , network >= 2.6 && < 2.7 , websockets >= 0.10 && < 0.11 - , aeson >= 1.0 && < 1.2 - , haskell-tools-demo >= 0.5 && < 0.6 - default-language: Haskell2010 \ No newline at end of file + , aeson >= 1.0 && < 1.3 + , haskell-tools-demo >= 0.8 && < 0.9 + default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug/Instances.hs 2017-05-17 10:56:29.000000000 +0200 @@ -3,7 +3,7 @@ , MultiParamTypeClasses , StandaloneDeriving , DeriveGeneric - , UndecidableInstances + , UndecidableInstances , TypeFamilies #-} module Language.Haskell.Tools.ASTDebug.Instances where @@ -40,7 +40,7 @@ instance (ASTDebug e dom st) => ASTDebug (AnnListG e) dom st where astDebug' (AnnListG a ls) = [TreeNode "" (TreeDebugNode "*" (DefaultInfoType (getRange (a ^. sourceInfo))) (concatMap astDebug' ls))] - + instance (ASTDebug e dom st) => ASTDebug (AnnMaybeG e) dom st where astDebug' (AnnMaybeG a e) = [TreeNode "" (TreeDebugNode "?" (DefaultInfoType (getRange (a ^. sourceInfo))) (maybe [] astDebug' e))] @@ -103,6 +103,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug UBracket dom st instance (Domain dom, SourceInfo st) => ASTDebug UTopLevelPragma dom st instance (Domain dom, SourceInfo st) => ASTDebug URule dom st +instance (Domain dom, SourceInfo st) => ASTDebug URuleVar dom st instance (Domain dom, SourceInfo st) => ASTDebug UAnnotationSubject dom st instance (Domain dom, SourceInfo st) => ASTDebug UMinimalFormula dom st instance (Domain dom, SourceInfo st) => ASTDebug UExprPragma dom st @@ -131,6 +132,7 @@ instance (Domain dom, SourceInfo st) => ASTDebug ULanguageExtension dom st instance (Domain dom, SourceInfo st) => ASTDebug UMatchLhs dom st instance (Domain dom, SourceInfo st) => ASTDebug UInlinePragma dom st +instance (Domain dom, SourceInfo st) => ASTDebug USpecializePragma dom st -- ULiteral instance (Domain dom, SourceInfo st) => ASTDebug ULiteral dom st diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/ASTDebug.hs 2017-05-22 15:12:54.000000000 +0200 @@ -53,11 +53,11 @@ deriving instance Domain dom => Show (TreeDebugNode dom) -data SemanticInfoType dom - = DefaultInfoType { semaInfoTypeRng :: SrcSpan +data SemanticInfoType dom + = DefaultInfoType { semaInfoTypeRng :: SrcSpan } | NameInfoType { semaInfoTypeName :: SemanticInfo' dom SameInfoNameCls - , semaInfoTypeRng :: SrcSpan + , semaInfoTypeRng :: SrcSpan } | ExprInfoType { semaInfoTypeExpr :: SemanticInfo' dom SameInfoExprCls , semaInfoTypeRng :: SrcSpan @@ -88,7 +88,7 @@ astDebugToJson :: AssocSema dom => [DebugNode dom] -> Seq Char astDebugToJson nodes = fromList "[ " >< childrenJson >< fromList " ]" where treeNodes = List.filter (\case TreeNode {} -> True; _ -> False) nodes - childrenJson = case map debugTreeNode treeNodes of + childrenJson = case map debugTreeNode treeNodes of first:rest -> first >< foldl (><) Seq.empty (fmap (fromList ", " ><) (fromList rest)) [] -> Seq.empty debugTreeNode (TreeNode "" s) = astDebugElemJson s @@ -96,20 +96,20 @@ debugTreeNode (SimpleNode {}) = error "debugTreeNode: simple SimpleNode not allowed" astDebugElemJson :: AssocSema dom => TreeDebugNode dom -> Seq Char -astDebugElemJson (TreeDebugNode name info children) - = fromList "{ \"text\" : \"" >< fromList name - >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" +astDebugElemJson (TreeDebugNode name info children) + = fromList "{ \"text\" : \"" >< fromList name + >< fromList "\", \"state\" : { \"opened\" : true }, \"a_attr\" : { \"data-range\" : \"" >< fromList (shortShowSpan (semaInfoTypeRng info)) - >< fromList "\", \"data-elems\" : \"" + >< fromList "\", \"data-elems\" : \"" >< foldl (><) Seq.empty dataElems - >< fromList "\", \"data-sema\" : \"" + >< fromList "\", \"data-sema\" : \"" >< fromList (showSema info) - >< fromList "\" }, \"children\" : " + >< fromList "\" }, \"children\" : " >< astDebugToJson children >< fromList " }" where dataElems = catMaybes (map (\case SimpleNode l v -> Just (fromList (formatScalarElem l v)); _ -> Nothing) children) formatScalarElem l v = "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ tail (init (show v)) ++ "</div>" - showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" - ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) + showSema info = "<div class='semaname'>" ++ assocName info ++ "</div>" + ++ concatMap (\(l,i) -> "<div class='scalarelem'><span class='astlab'>" ++ l ++ "</span>: " ++ i ++ "</div>") (toAssoc info) class AssocData a where assocName :: a -> String @@ -140,15 +140,15 @@ toAssoc ni = [ ("name", maybe "<ambiguous>" inspect (semanticsName ni)) , ("isDefined", show (semanticsDefining ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance AssocData CNameInfo where assocName _ = "CNameInfo" toAssoc ni = [ ("name", inspect (semanticsId ni)) , ("isDefined", show (semanticsDefining ni)) - , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) - , ("namesInScope", inspectScope (semanticsScope ni)) + , ("fixity", maybe "" (showSDocUnsafe . ppr) (semanticsFixity ni)) + , ("namesInScope", inspectScope (semanticsScope ni)) ] instance (HasModuleInfo' (ModuleInfo n)) => AssocData (ModuleInfo n) where @@ -157,25 +157,28 @@ , ("isBoot", show (isBootModule mi)) , ("implicitImports", concat (intersperse ", " (map inspect (semanticsImplicitImports mi)))) ] - + instance (HasImportInfo' (ImportInfo n)) => AssocData (ImportInfo n) where assocName _ = "ImportInfo" - toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) - , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) - , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) - ] - + toAssoc ii = [ ("moduleName", showSDocUnsafe (ppr (semanticsImportedModule ii))) + , ("availableNames", concat (intersperse ", " (map inspect (semanticsAvailable ii)))) + , ("importedNames", concat (intersperse ", " (map inspect (semanticsImported ii)))) + ] + instance AssocData ImplicitFieldInfo where assocName _ = "ImplicitFieldInfo" toAssoc ifi = [ ("bindings", concat (intersperse ", " (map (\(from,to) -> "(" ++ inspect from ++ " -> " ++ inspect to ++ ")") (semanticsImplicitFlds ifi)))) - ] + ] -inspectScope :: InspectableName n => [[n]] -> String +inspectScope :: InspectableName n => [[(n, Maybe [UsageSpec])]] -> String inspectScope = concat . intersperse " | " . map (concat . intersperse ", " . map inspect) class InspectableName n where inspect :: n -> String +instance InspectableName n => InspectableName (n, Maybe [UsageSpec]) where + inspect (n,usage) = inspect n ++ showSDocUnsafe (ppr usage) + instance InspectableName GHC.Name where inspect name = showSDocUnsafe (ppr name) ++ "[" ++ show (getUnique name) ++ "]" @@ -193,35 +196,35 @@ | Just (_, t') <- splitForAllTy_maybe t = getTVs t' | otherwise = [] -class (Domain dom, SourceInfo st) +class (Domain dom, SourceInfo st) => ASTDebug e dom st where astDebug' :: e dom st -> [DebugNode dom] default astDebug' :: (GAstDebug (Rep (e dom st)) dom, Generic (e dom st)) => e dom st -> [DebugNode dom] astDebug' = gAstDebug . from -class GAstDebug f dom where +class GAstDebug f dom where gAstDebug :: f p -> [DebugNode dom] - + instance GAstDebug V1 dom where gAstDebug _ = error "GAstDebug V1" - + instance GAstDebug U1 dom where - gAstDebug U1 = [] - + gAstDebug U1 = [] + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :+: g) dom where gAstDebug (L1 x) = gAstDebug x gAstDebug (R1 x) = gAstDebug x - + instance (GAstDebug f dom, GAstDebug g dom) => GAstDebug (f :*: g) dom where - gAstDebug (x :*: y) + gAstDebug (x :*: y) = gAstDebug x ++ gAstDebug y instance {-# OVERLAPPING #-} ASTDebug e dom st => GAstDebug (K1 i (e dom st)) dom where gAstDebug (K1 x) = astDebug' x - + instance {-# OVERLAPPABLE #-} Show x => GAstDebug (K1 i x) dom where gAstDebug (K1 x) = [SimpleNode "" (show x)] - + instance (GAstDebug f dom, Constructor c) => GAstDebug (M1 C c f) dom where gAstDebug c@(M1 x) = [TreeNode "" (TreeDebugNode (conName c) undefined (gAstDebug x))] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs --- old/haskell-tools-demo-0.5.0.0/src/Language/Haskell/Tools/Demo.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-demo-0.8.0.0/src/Language/Haskell/Tools/Demo.hs 2017-06-07 10:55:20.000000000 +0200 @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings - , DeriveGeneric + , DeriveGeneric , TypeApplications , TupleSections , ScopedTypeVariables @@ -52,13 +52,13 @@ import Language.Haskell.Tools.PrettyPrint import Language.Haskell.Tools.Refactor.Perform import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase +import Language.Haskell.Tools.Refactor.RefactorBase hiding (initSession) type ClientId = Int data RefactorSessionState - = RefactorSessionState { _refSessMods :: Map.Map (String, String, IsBoot) (UnnamedModule IdDom) - , _actualMod :: Maybe (String, String, IsBoot) + = RefactorSessionState { _refSessMods :: Map.Map (String, String, FilePath) (UnnamedModule IdDom) + , _actualMod :: Maybe (String, String, FilePath) , _isDisconnecting :: Bool } @@ -75,7 +75,7 @@ wd <- case args of dir:_ -> return dir [] -> return "." counter <- newMVar [] - let settings = setPort 8206 $ setTimeout 20 $ defaultSettings + let settings = setPort 8206 $ setTimeout 20 $ defaultSettings runSettings settings (app counter wd) -- | The application that is evoked for each incoming request @@ -96,10 +96,10 @@ do Text msg <- receiveDataMessage conn respondTo wd sessId ghcSess state (sendTextData conn) msg currState <- readMVar state - if currState ^. isDisconnecting + if currState ^. isDisconnecting then sendClose conn ("" :: ByteString) else serverLoop sessId ghcSess state conn - `catch` \(_ :: ConnectionException) -> do + `catch` \(_ :: ConnectionException) -> do modifyMVar_ sessions (return . delete sessId) liftIO $ removeDirectoryIfPresent (userDir wd sessId) @@ -129,9 +129,9 @@ return Nothing updateClient dir (ModuleDeleted name) = do lift $ removeTarget (TargetModule (GHC.mkModuleName name)) - modify $ refSessMods .- Map.delete (dir, name, NormalHs) + modify $ refSessMods .- Map.delete (dir, name, dir </> moduleSourceFile name) return Nothing -updateClient dir (InitialProject modules) = do +updateClient dir (InitialProject modules) = do -- clean the workspace to remove source files from earlier sessions liftIO $ removeDirectoryIfPresent dir liftIO $ createDirectoryIfMissing True dir @@ -148,24 +148,29 @@ updateClient dir (PerformRefactoring refact modName selection args) = do mod <- gets (find ((modName ==) . (\(_,m,_) -> m) . fst) . Map.assocs . (^. refSessMods)) allModules <- gets (filter ((modName /=) . (^. sfkModuleName) . fst) . map moduleNameAndContent . Map.assocs . (^. refSessMods)) - let command = analyzeCommand refact (selection:args) - case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules - case res of - Left err -> return $ Just $ ErrorMessage err - Right diff -> do applyChanges diff - return $ Just $ RefactorChanges (map trfDiff diff) - Nothing -> return $ Just $ ErrorMessage "The module is not found" + case analyzeCommand refact (selection:args) of + Right command -> + case mod of Just m -> do res <- lift $ performCommand command (moduleNameAndContent m) allModules + case res of + Left err -> return $ Just $ ErrorMessage err + Right diff -> do applyChanges diff + return $ Just $ RefactorChanges (map trfDiff diff) + Nothing -> return $ Just $ ErrorMessage "The module is not found" + Left err -> return $ Just $ ErrorMessage err where trfDiff (ContentChanged (key,cont)) = (key ^. sfkModuleName, Just (prettyPrint cont)) trfDiff (ModuleCreated name mod _) = (name, Just (prettyPrint mod)) trfDiff (ModuleRemoved name) = (name, Nothing) applyChanges diff - = do forM_ diff $ \case - ModuleCreated n m _ -> writeModule n m - ContentChanged (n,m) -> writeModule (n ^. sfkModuleName) m + = do forM_ diff $ \case + ModuleCreated n m _ -> do + writeModule n m + lift $ addTarget (Target (TargetModule (GHC.mkModuleName n)) True Nothing) + ContentChanged (n,m) -> + writeModule (n ^. sfkModuleName) m ModuleRemoved mod -> do liftIO $ removeFile (toFileName dir mod) - modify $ refSessMods .- Map.delete (dir, mod, NormalHs) + modify $ refSessMods .- Map.delete (dir, mod, dir </> moduleSourceFile mod) lift $ removeTarget (TargetModule (GHC.mkModuleName mod)) reloadAllMods dir @@ -173,22 +178,23 @@ reloadAllMods :: FilePath -> StateT RefactorSessionState Ghc () reloadAllMods dir = do + wd <- liftIO getCurrentDirectory void $ lift $ load LoadAllTargets targets <- lift getTargets forM_ (map ((\case (TargetModule n) -> n) . targetId) targets) $ \modName -> do - mod <- lift $ getModSummary modName >>= parseTyped - modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, NormalHs) mod + mod <- lift $ getModSummary modName >>= parseTyped wd + modify $ refSessMods .- Map.insert (dir, GHC.moduleNameString modName, dir </> moduleSourceFile (GHC.moduleNameString modName)) mod createFileForModule :: FilePath -> String -> String -> IO () createFileForModule dir name newContent = do let fname = toFileName dir name createDirectoryIfMissing True (takeDirectory fname) - withBinaryFile fname WriteMode (`hPutStr` newContent) + withBinaryFile fname WriteMode (`hPutStr` newContent) removeDirectoryIfPresent :: FilePath -> IO () removeDirectoryIfPresent dir = removeDirectoryRecursive dir `catch` \e -> if isDoesNotExistError e then return () else throwIO e -moduleNameAndContent :: ((String,String,IsBoot), mod) -> (SourceFileKey, mod) +moduleNameAndContent :: ((String,String,FilePath), mod) -> (SourceFileKey, mod) moduleNameAndContent ((_,name,isBoot), mod) = (SourceFileKey isBoot name, mod) dataDirs :: FilePath -> FilePath @@ -198,25 +204,30 @@ userDir wd id = dataDirs wd </> show id initGhcSession :: FilePath -> IO Session -initGhcSession workingDir +initGhcSession workingDir = Session <$> (newIORef =<< runGhc (Just libdir) (initGhcFlagsForTest >> useDirs [workingDir] >> getSession)) handleErrors :: FilePath -> ClientMessage -> (ResponseMsg -> IO ()) -> IO () -> IO () handleErrors wd req next io = io `catch` (next <=< handleException) where handleException :: SomeException -> IO ResponseMsg - handleException e - | Just (se :: SourceError) <- fromException e - = return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) + handleException e + | Just (se :: SourceError) <- fromException e + = if isReloading + then do logToFile wd (show e) req + return $ ErrorMessage ("The generated code cannot be compiled. The problem had been reported. Please restart the demo or correct the results manually.") + else return $ CompilationProblem (concatMap (\msg -> showMsg msg ++ "\n\n") $ bagToList $ srcErrorMessages se) | Just (ae :: AsyncException) <- fromException e = throw ae | Just (ge :: GhcException) <- fromException e = return $ ErrorMessage $ show ge | Just (re :: RefactorException) <- fromException e = return $ ErrorMessage $ displayException re | otherwise = do logToFile wd (show e) req return $ ErrorMessage (showInternalError e) - + showMsg msg = showSpan (errMsgSpan msg) ++ "\n" ++ show msg showSpan (RealSrcSpan sp) = showFileName (srcLocFile (realSrcSpanStart sp)) ++ " " ++ show (srcLocLine (realSrcSpanStart sp)) ++ ":" ++ show (srcLocCol (realSrcSpanStart sp)) showSpan _ = "" + isReloading = case req of PerformRefactoring {} -> True; _ -> False + showFileName = joinPath . drop 2 . splitPath . makeRelative wd . unpackFS showInternalError :: SomeException -> String @@ -228,8 +239,8 @@ withFile logFile AppendMode $ \handle -> do size <- hFileSize handle when (size < logSizeLimit) $ hPutStrLn handle ("\n### " ++ msg) - `catch` \e -> print ("The error message cannot be logged because: " - ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) + `catch` \e -> print ("The error message cannot be logged because: " + ++ show (e :: IOException) ++ "\nHere is the message:\n" ++ msg) where logFile = wd </> "error-log.txt" logSizeLimit = 100 * 1024 * 1024 -- 100 MB @@ -248,7 +259,7 @@ | Disconnect deriving (Show, Generic) -instance FromJSON ClientMessage +instance FromJSON ClientMessage data ResponseMsg = RefactorChanges { moduleChanges :: [(String, Maybe String)] }

1 0

commit ghc-haskell-tools-debug for openSUSE:Factory
by root＠hilbert.suse.de 31 Aug '17

31 Aug '17

Hello community, here is the log from the commit of package ghc-haskell-tools-debug for openSUSE:Factory checked in at 2017-08-31 20:56:00 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-haskell-tools-debug (Old) and /work/SRC/openSUSE:Factory/.ghc-haskell-tools-debug.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-haskell-tools-debug" Thu Aug 31 20:56:00 2017 rev:2 rq:513372 version:0.8.0.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-haskell-tools-debug/ghc-haskell-tools-debug.changes 2017-04-12 18:06:45.078258134 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-haskell-tools-debug.new/ghc-haskell-tools-debug.changes 2017-08-31 20:56:04.310718224 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:41 UTC 2017 - psimons(a)suse.com + +- Update to version 0.8.0.0. + +------------------------------------------------------------------- Old: ---- haskell-tools-debug-0.5.0.0.tar.gz New: ---- haskell-tools-debug-0.8.0.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-haskell-tools-debug.spec ++++++ --- /var/tmp/diff_new_pack.78zVec/_old 2017-08-31 20:56:05.278582236 +0200 +++ /var/tmp/diff_new_pack.78zVec/_new 2017-08-31 20:56:05.282581674 +0200 @@ -18,7 +18,7 @@ %global pkg_name haskell-tools-debug Name: ghc-%{pkg_name} -Version: 0.5.0.0 +Version: 0.8.0.0 Release: 0 Summary: Debugging Tools for Haskell-tools License: BSD-3-Clause @@ -27,6 +27,7 @@ Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{ve… BuildRequires: chrpath BuildRequires: ghc-Cabal-devel +BuildRequires: ghc-filepath-devel BuildRequires: ghc-ghc-devel BuildRequires: ghc-ghc-paths-devel BuildRequires: ghc-haskell-tools-ast-devel @@ -35,6 +36,7 @@ BuildRequires: ghc-haskell-tools-refactor-devel BuildRequires: ghc-references-devel BuildRequires: ghc-rpm-macros +BuildRequires: ghc-template-haskell-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %description ++++++ haskell-tools-debug-0.5.0.0.tar.gz -> haskell-tools-debug-0.8.0.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/Debug.hs new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/Debug.hs --- old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/Debug.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/Debug.hs 2017-06-07 10:55:20.000000000 +0200 @@ -1,14 +1,21 @@ {-# LANGUAGE StandaloneDeriving , DeriveGeneric + , LambdaCase #-} module Language.Haskell.Tools.Debug where +import Control.Monad +import Control.Reference import Control.Monad.IO.Class (MonadIO(..)) import Data.Maybe (Maybe(..), fromJust) import GHC.Generics (Generic(..)) +import System.FilePath (pathSeparator, (</>), (<.>)) +import DynFlags (xopt) import GHC hiding (loadModule) import GHC.Paths ( libdir ) +import Language.Haskell.TH.LanguageExtensions (Extension(..)) +import StringBuffer (hGetStringBuffer) import Language.Haskell.Tools.AST (NodeInfo(..)) import Language.Haskell.Tools.AST.FromGHC @@ -17,24 +24,30 @@ import Language.Haskell.Tools.RangeDebug (srcInfoDebug) import Language.Haskell.Tools.RangeDebug.Instances () import Language.Haskell.Tools.Refactor.Perform (performCommand, readCommand) +import Language.Haskell.Tools.Refactor.RefactorBase import Language.Haskell.Tools.Refactor.Prepare -import Language.Haskell.Tools.Refactor.RefactorBase (RefactorChange(..), IsBoot(..), SourceFileKey(..)) +import Language.Haskell.Tools.Refactor.RefactorBase (RefactorChange(..), SourceFileKey(..)) import Language.Haskell.Tools.Transform -- | Should be only used for testing demoRefactor :: String -> String -> [String] -> String -> IO () -demoRefactor command workingDir args moduleName = +demoRefactor command workingDir args moduleName = runGhc (Just libdir) $ do initGhcFlags _ <- useFlags args useDirs [workingDir] - modSum <- loadModule workingDir moduleName + ms <- loadModule workingDir moduleName + let modSum = ms { ms_hspp_opts = (ms_hspp_opts ms) { hscTarget = HscAsm, ghcLink = LinkInMemory } } p <- parseModule modSum t <- typecheckModule p - + let annots = pm_annotations $ tm_parsed_module t + hasCPP = Cpp `xopt` ms_hspp_opts modSum - liftIO $ putStrLn $ show annots + liftIO $ putStrLn "=========== tokens:" + liftIO $ putStrLn $ show (fst annots) + liftIO $ putStrLn "=========== comments:" + liftIO $ putStrLn $ show (snd annots) liftIO $ putStrLn "=========== parsed source:" liftIO $ putStrLn $ show (pm_parsed_source p) liftIO $ putStrLn "=========== renamed source:" @@ -49,34 +62,45 @@ transformed <- addTypeInfos (typecheckedSource t) =<< (runTrf (fst annots) (getPragmaComments $ snd annots) $ trfModuleRename modSum parseTrf (fromJust $ tm_renamed_source t) (pm_parsed_source p)) liftIO $ putStrLn $ srcInfoDebug transformed liftIO $ putStrLn "=========== ranges fixed:" - let commented = fixRanges $ placeComments (getNormalComments $ snd annots) transformed + sourceOrigin <- if hasCPP then liftIO $ hGetStringBuffer (workingDir </> map (\case '.' -> pathSeparator; c -> c) moduleName <.> "hs") + else return (fromJust $ ms_hspp_buf $ pm_mod_summary p) + let commented = fixRanges $ placeComments (fst annots) (getNormalComments $ snd annots) $ fixMainRange sourceOrigin transformed liftIO $ putStrLn $ srcInfoDebug commented liftIO $ putStrLn "=========== cut up:" let cutUp = cutUpRanges commented liftIO $ putStrLn $ srcInfoDebug cutUp liftIO $ putStrLn $ show $ getLocIndices cutUp - liftIO $ putStrLn $ show $ mapLocIndices (fromJust $ ms_hspp_buf $ pm_mod_summary p) (getLocIndices cutUp) + + liftIO $ putStrLn $ show $ mapLocIndices sourceOrigin (getLocIndices cutUp) liftIO $ putStrLn "=========== sourced:" - let sourced = rangeToSource (fromJust $ ms_hspp_buf $ pm_mod_summary p) cutUp + let sourced = (if hasCPP then extractStayingElems else id) $ rangeToSource sourceOrigin cutUp liftIO $ putStrLn $ srcInfoDebug sourced liftIO $ putStrLn "=========== pretty printed:" let prettyPrinted = prettyPrint sourced liftIO $ putStrLn prettyPrinted - transformed <- performCommand (readCommand command) ((SourceFileKey NormalHs moduleName), sourced) [] - case transformed of - Right [ContentChanged (_, correctlyTransformed)] -> do - liftIO $ putStrLn "=========== transformed AST:" - liftIO $ putStrLn $ srcInfoDebug correctlyTransformed - liftIO $ putStrLn "=========== transformed & prettyprinted:" - let prettyPrinted = prettyPrint correctlyTransformed - liftIO $ putStrLn prettyPrinted - liftIO $ putStrLn "===========" - -- TODO: implement - Right _ -> error "The output shoud be one module changed" + transformed <- performCommand (either error id $ readCommand command) ((SourceFileKey (moduleSourceFile moduleName) moduleName), sourced) [] + case transformed of + Right changes -> do + forM_ changes $ \case + ContentChanged (mod, correctlyTransformed) -> do + liftIO $ putStrLn $ "=========== transformed AST (" ++ (mod ^. sfkModuleName) ++ "):" + liftIO $ putStrLn $ srcInfoDebug correctlyTransformed + liftIO $ putStrLn $ "=========== transformed & prettyprinted (" ++ (mod ^. sfkModuleName) ++ "):" + let prettyPrinted = prettyPrint correctlyTransformed + liftIO $ putStrLn prettyPrinted + liftIO $ putStrLn "===========" + ModuleRemoved mod -> do + liftIO $ putStrLn $ "=========== module removed: " ++ mod + ModuleCreated mod cont _ -> do + liftIO $ putStrLn $ "=========== created AST (" ++ mod ++ "):" + liftIO $ putStrLn $ srcInfoDebug cont + liftIO $ putStrLn $ "=========== created & prettyprinted (" ++ mod ++ "):" + let prettyPrinted = prettyPrint cont + liftIO $ putStrLn prettyPrinted Left transformProblem -> do liftIO $ putStrLn "===========" liftIO $ putStrLn transformProblem liftIO $ putStrLn "===========" - + deriving instance Generic SrcSpan deriving instance Generic (NodeInfo sema src) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs --- old/haskell-tools-debug-0.5.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs 2017-01-31 20:47:45.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/Language/Haskell/Tools/RangeDebug/Instances.hs 2017-05-17 11:30:04.000000000 +0200 @@ -3,7 +3,7 @@ , MultiParamTypeClasses , StandaloneDeriving , DeriveGeneric - , UndecidableInstances + , UndecidableInstances #-} module Language.Haskell.Tools.RangeDebug.Instances where @@ -17,16 +17,16 @@ -- Annotations instance TreeDebug e dom st => TreeDebug (Ann e) dom st where treeDebug' i (Ann a e) = identLine i ++ show (a ^. sourceInfo) ++ " " ++ take 40 (show e) ++ "..." ++ treeDebug' (i+1) e - + identLine :: Int -> String identLine i = "\n" ++ replicate (i*2) ' ' - + instance TreeDebug e dom st => TreeDebug (AnnListG e) dom st where - treeDebug' i (AnnListG a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls - + treeDebug' i (AnnListG a ls) = identLine i ++ show (a ^. sourceInfo) ++ " <*>" ++ concatMap (treeDebug' (i + 1)) ls + instance TreeDebug e dom st => TreeDebug (AnnMaybeG e) dom st where treeDebug' i (AnnMaybeG a e) = identLine i ++ show (a ^. sourceInfo) ++ " <?>" ++ maybe "" (\e -> treeDebug' (i + 1) e) e - + -- Modules instance (SourceInfo st, Domain dom) => TreeDebug UModule dom st instance (SourceInfo st, Domain dom) => TreeDebug UModuleHead dom st @@ -85,6 +85,7 @@ instance (SourceInfo st, Domain dom) => TreeDebug UBracket dom st instance (SourceInfo st, Domain dom) => TreeDebug UTopLevelPragma dom st instance (SourceInfo st, Domain dom) => TreeDebug URule dom st +instance (SourceInfo st, Domain dom) => TreeDebug URuleVar dom st instance (SourceInfo st, Domain dom) => TreeDebug UAnnotationSubject dom st instance (SourceInfo st, Domain dom) => TreeDebug UMinimalFormula dom st instance (SourceInfo st, Domain dom) => TreeDebug UExprPragma dom st @@ -113,6 +114,7 @@ instance (SourceInfo st, Domain dom) => TreeDebug ULanguageExtension dom st instance (SourceInfo st, Domain dom) => TreeDebug UMatchLhs dom st instance (SourceInfo st, Domain dom) => TreeDebug UInlinePragma dom st +instance (SourceInfo st, Domain dom) => TreeDebug USpecializePragma dom st -- ULiteral instance (SourceInfo st, Domain dom) => TreeDebug ULiteral dom st @@ -138,4 +140,4 @@ instance (SourceInfo st, Domain dom) => TreeDebug LineNumber dom st instance (SourceInfo st, Domain dom) => TreeDebug UPhaseControl dom st instance (SourceInfo st, Domain dom) => TreeDebug PhaseNumber dom st -instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st \ No newline at end of file +instance (SourceInfo st, Domain dom) => TreeDebug PhaseInvert dom st diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/haskell-tools-debug-0.5.0.0/haskell-tools-debug.cabal new/haskell-tools-debug-0.8.0.0/haskell-tools-debug.cabal --- old/haskell-tools-debug-0.5.0.0/haskell-tools-debug.cabal 2017-01-31 20:56:03.000000000 +0100 +++ new/haskell-tools-debug-0.8.0.0/haskell-tools-debug.cabal 2017-07-01 12:39:07.000000000 +0200 @@ -1,5 +1,5 @@ name: haskell-tools-debug -version: 0.5.0.0 +version: 0.8.0.0 synopsis: Debugging Tools for Haskell-tools description: Debugging Tools for Haskell-tools homepage: https://github.com/haskell-tools/haskell-tools @@ -12,24 +12,25 @@ cabal-version: >=1.10 library - ghc-options: -O2 exposed-modules: Language.Haskell.Tools.Debug other-modules: Language.Haskell.Tools.DebugGhcAST , Language.Haskell.Tools.RangeDebug , Language.Haskell.Tools.RangeDebug.Instances build-depends: base >= 4.9 && < 4.10 + , filepath >= 1.4 && < 1.5 + , template-haskell >= 2.11 && < 2.12 , references >= 0.3 && < 0.4 , ghc >= 8.0 && < 8.1 , ghc-paths >= 0.1 && < 0.2 - , haskell-tools-ast >= 0.5 && < 0.6 - , haskell-tools-backend-ghc >= 0.5 && < 0.6 - , haskell-tools-refactor >= 0.5 && < 0.6 - , haskell-tools-prettyprint >= 0.5 && < 0.6 + , haskell-tools-ast >= 0.8 && < 0.9 + , haskell-tools-backend-ghc >= 0.8 && < 0.9 + , haskell-tools-refactor >= 0.8 && < 0.9 + , haskell-tools-prettyprint >= 0.8 && < 0.9 default-language: Haskell2010 - + executable ht-debug build-depends: base >= 4.9 && < 5.0 - , haskell-tools-debug >= 0.5 && < 0.6 + , haskell-tools-debug >= 0.8 && < 0.9 hs-source-dirs: exe main-is: Main.hs - default-language: Haskell2010 \ No newline at end of file + default-language: Haskell2010

1 0