comprehensions-ghc (empty) → 0.1.0.0
raw patch · 5 files changed
+186/−0 lines, 5 filesdep +basedep +base-unicode-symbolsdep +comprehensions-ghc
Dependencies added: base, base-unicode-symbols, comprehensions-ghc, ghc, syb, util
Files
- Comprehension/Plugin.hs +68/−0
- LICENSE +30/−0
- README.md +1/−0
- comprehensions-ghc.cabal +74/−0
- test/Main.hs +13/−0
+ Comprehension/Plugin.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ViewPatterns #-}++module Comprehension.Plugin (plugin) where++import Prelude hiding (init, last)+import Data.Bool+import Data.Data+import Data.Generics as SYB+import Data.String (fromString)+import Type.Reflection as R++import qualified GhcPlugins as GHC+import HsExtension (GhcPs, NoExt (..))+import HsSyn+import qualified HsTypes+import Outputable (SDoc, ppr)+import qualified Outputable as Ppr+import SrcLoc++plugin :: GHC.Plugin+plugin = GHC.defaultPlugin { GHC.parsedResultAction = \ _ -> go } where+ go :: GHC.ModSummary -> GHC.HsParsedModule -> GHC.Hsc GHC.HsParsedModule+ go _ m =+ [m { GHC.hpm_module = hpm_module' }+ | dflags <- GHC.getDynFlags+ , hpm_module' <- transform dflags (GHC.hpm_module m)]++transform :: GHC.DynFlags -> GHC.Located (HsModule GhcPs) -> GHC.Hsc (GHC.Located (HsModule GhcPs))+transform _dflags = Ppr.pprTraceDebug "comprehensions-ghc:Comprehension.Plugin:" . gppr' <*> SYB.everywhereM (SYB.mkM transform') where+ transform' :: LHsExpr GhcPs -> GHC.Hsc (LHsExpr GhcPs)+ transform' = pure . \ case+ L l (HsDo _ comp (L l' (reverse -> L l'' (LastStmt _ body _ x):ss)))+ | case comp of ListComp -> True+ MonadComp -> True+ _ -> False ->+ L l . HsDo NoExt DoExpr . L l' . reverse $ L l'' (BodyStmt NoExt (noLoc $ HsApp NoExt pureExpr body) x x):ss+ xl -> xl++ pureExpr :: GenLocated SrcSpan (HsExpr GhcPs)+ pureExpr =+ noLoc . HsVar NoExt . noLoc . GHC.mkOrig (GHC.Module (GHC.stringToUnitId "base") $ GHC.mkModuleName "GHC.Base") . GHC.mkVarOcc $+ "pure"++gppr' :: Data a => a -> Ppr.SDoc+gppr' = gpprPrec' 0++gpprPrec' :: Data a => Rational -> a -> SDoc+gpprPrec' prec t+ | headTyConOf (L () ()) == headTyConOf t = gmapQi 1 (gpprPrec' prec) t+ | headTyConOf [()] == headTyConOf t = pprList $ asList t+ | Just NoExt <- cast t = Ppr.empty+ | Just _ <- cast t :: Maybe GHC.SourceText = Ppr.empty+ | Just _ <- cast t :: Maybe HsTypes.Promoted = Ppr.empty+ | Just l <- cast t :: Maybe (HsLit GhcPs) = ppr l+ | Just n <- cast t :: Maybe GHC.RdrName = Ppr.doubleQuotes $ ppr n+ | otherwise = Ppr.sdocWithDynFlags $ \ dflags ->+ let sdocs = filter (not . Ppr.isEmpty dflags) $+ (:) <$> fromString . showConstr . toConstr <*> gmapQ (gpprPrec' (prec + 1)) $ t+ in bool id Ppr.parens (prec > 0 && length sdocs > 1) $ Ppr.fsep sdocs+ where+ pprList = Ppr.brackets . Ppr.pprWithCommas id++ headTyConOf :: Typeable a => a -> TyCon+ headTyConOf = fst . splitApps . R.typeOf++ asList :: Data a => a -> [SDoc]+ asList t | [] <- gmapQ (pure ()) t = []+ | otherwise = gmapQi 0 gppr' t : gmapQi 1 asList t
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright M Farkas-Dyck © 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of M Farkas-Dyck nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# comprehensions-ghc
+ comprehensions-ghc.cabal view
@@ -0,0 +1,74 @@+name: comprehensions-ghc+version: 0.1.0.0+synopsis: Plugin to generalize comprehensions+-- description:+license: BSD3+license-file: LICENSE+author: M Farkas-Dyck+maintainer: strake888@gmail.com+copyright: 2019 M Farkas-Dyck+-- category: +build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: .+ exposed-modules: Comprehension.Plugin+ build-depends: base >= 4.7 && < 5+ , base-unicode-symbols+ , ghc+ , syb+ , util+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods+ -Wno-partial-type-signatures++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends: base >=4.11 && <5+ , comprehensions-ghc+ default-language: Haskell2010+ default-extensions: UnicodeSyntax+ , LambdaCase+ , EmptyCase+ , InstanceSigs+ , PartialTypeSignatures+ , PolyKinds+ , ConstraintKinds+ , FlexibleContexts+ , FlexibleInstances+ , MonadComprehensions+ , StandaloneDeriving+ , DeriveFunctor, DeriveFoldable, DeriveTraversable+ ghc-options: -Wall -Wcompat -Wredundant-constraints -Wno-name-shadowing+ -Wincomplete-record-updates -Wincomplete-uni-patterns+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates+ -Werror=missing-fields+ -Werror=missing-methods++source-repository head+ type: git+ location: https://github.com/strake/comprehensions-ghc.hs
+ test/Main.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fplugin=Comprehension.Plugin #-}+{-# LANGUAGE ApplicativeDo, RecursiveDo #-}++module Main where++main :: IO ()+main = test1 pure ()++test1 :: Functor f => (a -> f b) -> a -> f b+test1 f a = [b | b <- f a]++test2 :: Applicative p => (a -> p x) -> (a -> p y) -> a -> p (x, y)+test2 f g a = [(x, y) | x <- f a, y <- g a]