├── .gitignore ├── stack.yaml.lock ├── test └── Main.hs ├── package.yaml ├── src ├── Control │ └── Early.hs ├── Data │ └── Early.hs └── EarlyPlugin.hs ├── LICENSE ├── early.cabal ├── stack.yaml ├── README.md └── app └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 524154 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/20.yaml 11 | sha256: 2f5099f69ddb6abfe64400fe1e6a604e8e628f55e6837211cd70a81eb0a8fa4d 12 | original: lts-14.20 13 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -F -pgmF=early #-} 2 | 3 | module Main (main) where 4 | 5 | import Control.Early 6 | import System.Environment 7 | 8 | data Error = 9 | MissingEnv String 10 | deriving (Show) 11 | 12 | grabEnv :: String -> IO (Either Error String) 13 | grabEnv key = do 14 | result <- lookupEnv key 15 | pure (maybe (Left (MissingEnv key)) Right result) 16 | 17 | main :: IO () 18 | main = do 19 | result <- app 20 | print result 21 | 22 | app :: IO (Either Error String) 23 | app = do 24 | path <- fmap (maybe (Left (MissingEnv "PATH")) Right) $ lookupEnv "PATH"? 25 | grabEnv "PWD"? 26 | magic <- grabEnv "PATH"? 27 | pure (Right (path ++ magic)) 28 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: early 2 | version: 0.0.0 3 | github: "inflex-io/early" 4 | license: BSD3 5 | author: Sky Above Limited 6 | maintainer: chris@skyabove.io 7 | copyright: "2021 Chris Done" 8 | description: Please see the README on GitHub at 9 | extra-source-files: README.md 10 | license-file: LICENSE 11 | category: Development 12 | synopsis: Early return syntax in do-notation (GHC plugin) 13 | 14 | dependencies: 15 | - base >= 4.7 && < 5 16 | 17 | library: 18 | source-dirs: src 19 | ghc-options: 20 | - -Wall 21 | dependencies: 22 | - ghc 23 | - syb 24 | - text 25 | - transformers 26 | - containers 27 | - vector 28 | 29 | executables: 30 | early: 31 | main: Main.hs 32 | source-dirs: app 33 | ghc-options: 34 | - -threaded 35 | - -rtsopts 36 | - -with-rtsopts=-N 37 | - -Wall 38 | dependencies: 39 | - ghc-lib-parser 40 | - text 41 | - unordered-containers 42 | 43 | tests: 44 | early-test: 45 | main: Main.hs 46 | source-dirs: test 47 | ghc-options: 48 | - -threaded 49 | - -rtsopts 50 | - -with-rtsopts=-N 51 | - -Wall 52 | dependencies: 53 | - early 54 | -------------------------------------------------------------------------------- /src/Control/Early.hs: -------------------------------------------------------------------------------- 1 | -- | Early return in monads. 2 | 3 | module Control.Early 4 | ( Early(..) 5 | , early 6 | , earlyThen 7 | ) where 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Class providing different early return types 11 | 12 | -- | A class for things which can offer branching for early return. 13 | -- 14 | -- The most obvious two types are 'Either' and 'Maybe'. 15 | class Functor f => Early f where 16 | dispatch :: Applicative m => f a -> (a -> m (f b)) -> m (f b) 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Top-level API 20 | 21 | -- | Early return specialized on f (for now). 22 | early :: (Monad m, Early f) => m (f a) -> (a -> m (f b)) -> m (f b) 23 | early m f = do 24 | r <- m 25 | dispatch r f 26 | {-# INLINE early #-} 27 | 28 | -- | Early return specialized on f (for now). 29 | earlyThen :: (Monad m, Early f) => m (f a) -> m (f b) -> m (f b) 30 | earlyThen m f = early m (const f) 31 | {-# INLINE earlyThen #-} 32 | 33 | -------------------------------------------------------------------------------- 34 | -- Instances 35 | 36 | instance Early (Either e) where 37 | dispatch r f = 38 | case r of 39 | Left e -> pure (Left e) 40 | Right x -> f x 41 | {-# INLINE dispatch #-} 42 | 43 | instance Early Maybe where 44 | dispatch r f = 45 | case r of 46 | Nothing -> pure Nothing 47 | Just x -> f x 48 | {-# INLINE dispatch #-} 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2020 Sky Above Limited 2 | Copyright © 2018 Mark Karpov 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, 10 | this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | * Neither the name Sky Above Limited, Mark Karpov nor the names of 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 22 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN 23 | NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 24 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 26 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 27 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 28 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, 29 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /early.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.33.0. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | -- 7 | -- hash: fa3ce7ce90a72a5a699ad41a749210c36604174a194d2ef4e9c615a07a020ceb 8 | 9 | name: early 10 | version: 0.0.0 11 | synopsis: Early return syntax in do-notation (GHC plugin) 12 | description: Please see the README on GitHub at 13 | category: Development 14 | homepage: https://github.com/inflex-io/early#readme 15 | bug-reports: https://github.com/inflex-io/early/issues 16 | author: Sky Above Limited 17 | maintainer: chris@skyabove.io 18 | copyright: 2021 Chris Done 19 | license: BSD3 20 | license-file: LICENSE 21 | build-type: Simple 22 | extra-source-files: 23 | README.md 24 | 25 | source-repository head 26 | type: git 27 | location: https://github.com/inflex-io/early 28 | 29 | library 30 | exposed-modules: 31 | Control.Early 32 | Data.Early 33 | EarlyPlugin 34 | other-modules: 35 | Paths_early 36 | hs-source-dirs: 37 | src 38 | ghc-options: -Wall 39 | build-depends: 40 | base >=4.7 && <5 41 | , containers 42 | , ghc 43 | , syb 44 | , text 45 | , transformers 46 | , vector 47 | default-language: Haskell2010 48 | 49 | executable early 50 | main-is: Main.hs 51 | other-modules: 52 | Paths_early 53 | hs-source-dirs: 54 | app 55 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 56 | build-depends: 57 | base >=4.7 && <5 58 | , ghc-lib-parser 59 | , text 60 | , unordered-containers 61 | default-language: Haskell2010 62 | 63 | test-suite early-test 64 | type: exitcode-stdio-1.0 65 | main-is: Main.hs 66 | other-modules: 67 | Paths_early 68 | hs-source-dirs: 69 | test 70 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 71 | build-depends: 72 | base >=4.7 && <5 73 | , early 74 | default-language: Haskell2010 75 | -------------------------------------------------------------------------------- /src/Data/Early.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Data.Early 4 | ( FoldableEarly(..) 5 | , TraversableEarly(..) 6 | ) where 7 | 8 | import Control.Early 9 | import Data.Foldable 10 | import Data.Sequence (Seq) 11 | import qualified Data.Sequence as Seq 12 | import Data.Vector (Vector) 13 | import qualified Data.Vector as V 14 | 15 | class Foldable t => FoldableEarly t where 16 | foldE :: (Monad m, Early f, Applicative f) 17 | => (x -> a -> m (f x)) -> x -> t a -> m (f x) 18 | 19 | instance FoldableEarly [] where 20 | foldE cons nil0 = go nil0 21 | where 22 | go nil [] = pure (pure nil) 23 | go nil (x:xs) = early (cons nil x) (\x' -> go x' xs) 24 | 25 | instance FoldableEarly Seq where 26 | foldE cons nil0 = go nil0 27 | where 28 | go nil Seq.Empty = pure (pure nil) 29 | go nil (x Seq.:<| xs) = early (cons nil x) (\x' -> go x' xs) 30 | 31 | class Traversable t => TraversableEarly t where 32 | traverseE :: (Monad m, Early f, Applicative f) 33 | => (a -> m (f b)) -> t a -> m (f (t b)) 34 | traverseE_ :: (Monad m, Early f, Applicative f) 35 | => (a -> m (f b)) -> t a -> m (f ()) 36 | 37 | instance TraversableEarly [] where 38 | traverseE f = go [] 39 | where 40 | go acc [] = pure (pure (reverse acc)) 41 | go acc (x:xs) = early (f x) (\x' -> go (x' : acc) xs) 42 | traverseE_ f = go 43 | where 44 | go [] = pure (pure ()) 45 | go (x:xs) = early (f x) (const (go xs)) 46 | 47 | instance TraversableEarly Vector where 48 | traverseE f = fmap (fmap V.fromList) . traverseE f . toList 49 | traverseE_ f = traverseE_ f . toList 50 | 51 | instance TraversableEarly Seq where 52 | traverseE f = go mempty 53 | where 54 | go acc Seq.Empty = pure (pure acc) 55 | go acc (x Seq.:<| xs) = early (f x) (\x' -> go (acc Seq.:|> x') xs) 56 | traverseE_ f = go 57 | where 58 | go Seq.Empty = pure (pure ()) 59 | go (x Seq.:<| xs) = early (f x) (const (go xs)) 60 | 61 | instance TraversableEarly Maybe where 62 | traverseE f = 63 | \case 64 | Just x -> early (f x) (pure . pure . Just) 65 | Nothing -> pure (pure Nothing) 66 | traverseE_ f = 67 | \case 68 | Just x -> early (f x) (const (pure (pure ()))) 69 | Nothing -> pure (pure ()) 70 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # 15 | # The location of a snapshot can be provided as a file or url. Stack assumes 16 | # a snapshot provided as a file might change, whereas a url resource does not. 17 | # 18 | # resolver: ./custom-snapshot.yaml 19 | # resolver: https://example.com/snapshots/2018-01-01.yaml 20 | resolver: lts-14.20 21 | 22 | # User packages to be built. 23 | # Various formats can be used as shown in the example below. 24 | # 25 | # packages: 26 | # - some-directory 27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 28 | # subdirs: 29 | # - auto-update 30 | # - wai 31 | packages: 32 | - . 33 | # Dependency packages to be pulled from upstream that are not in the resolver. 34 | # These entries can reference officially published versions as well as 35 | # forks / in-progress versions pinned to a git hash. For example: 36 | # 37 | # extra-deps: 38 | # - acme-missiles-0.3 39 | # - git: https://github.com/commercialhaskell/stack.git 40 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 41 | # 42 | # extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | # flags: {} 46 | 47 | # Extra package databases containing global packages 48 | # extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=2.4" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # early 2 | 3 | Add early return to any `do`-expression 4 | 5 | 6 | **Table of Contents** 7 | 8 | - [early](#early) 9 | - [Description](#description) 10 | - [How it works](#how-it-works) 11 | - [Details](#details) 12 | - [Why not `ExceptT` or exceptions?](#why-not-exceptt-or-exceptions) 13 | - [Inspiration](#inspiration) 14 | - [Special thanks](#special-thanks) 15 | 16 | 17 | 18 | 19 | ## Description 20 | 21 | This package is a GHC plugin to add special syntax for early return in 22 | `do`-notation. It provides a way to terminate the current 23 | `do`-expression with a result, usually a failure result, but not 24 | necessarily. It should not be confused with an exception handler. It 25 | uses regular values everywhere. 26 | 27 | ## How it works 28 | 29 | The plugin is enabled in any module via a pragma. 30 | 31 | ``` haskell 32 | {-# OPTIONS -F -pgmF=early #-} 33 | ``` 34 | 35 | The syntax `?` can be added to the end of any `do` statement to make 36 | it short-circuit when the action produces a certain "stop" result 37 | (such as `Left`, or `Nothing`; **the particular type is type-class 38 | based**, see the Details section below). 39 | 40 | Suppose that `grabEnv :: String -> IO (Either Error String)`, then you 41 | can write this: 42 | 43 | ```haskell 44 | app :: IO (Either Error String) 45 | app = do 46 | path <- grabEnv "PATH"? 47 | putStrLn "Look ma, no lifts!" 48 | magic <- grabEnv "MAGIC"? 49 | pure (Right (path ++ magic)) 50 | ``` 51 | 52 | Note the final `pure` in the do should wrap the type, as the type of 53 | the whole `do`-block has changed. 54 | 55 | That's it! See `test/Main.hs` for full example. 56 | 57 | ## Details 58 | 59 | The syntax `stmt?` is desugared in this way: 60 | 61 | * `do stmt?; next` becomes `do earlyThen stmt next` 62 | * `do pat <- stmt?; next; next2` becomes `do early stmt (\pat -> do next; next2; ...)` 63 | 64 | The `early` and `earlyThen` are driven by the `Early` class, which any 65 | functor-like data type can implement. 66 | 67 | ``` haskell 68 | early :: (Monad m, Early f) => m (f a) -> (a -> m (f b)) -> m (f b) 69 | earlyThen :: (Monad m, Early f) => m (f a) -> m (f b) -> m (f b) 70 | ``` 71 | 72 | ``` haskell 73 | class Functor f => Early f where 74 | dispatch :: Applicative m => f a -> (a -> m (f b)) -> m (f b) 75 | ``` 76 | 77 | Two provided instances out of the box are `Either e` and `Maybe`, but 78 | others can be added freely, such as a `Failure e a` type of your 79 | library, etc. 80 | 81 | ### Why not `ExceptT` or exceptions? 82 | 83 | Full explanation here: 84 | [my recoverable errors post](https://chrisdone.com/posts/recoverable-errors-in-haskell/). 85 | 86 | Because `ExceptT` (or `ContT`) cannot be an 87 | instance of `MonadUnliftIO`. It is not unliftable; this means that 88 | exceptions, cleanup and concurrency don't have an interpretation. This 89 | is an area where monad transformers in `mtl`/`transformers` don't 90 | compose. Other free monads commute, but then you have to use a free 91 | monad which has a complicated story regarding performance. 92 | 93 | ## Inspiration 94 | 95 | The syntax and concept of using simple return values for early 96 | termination and failure handling is inspired 97 | [by Rust's error handling](https://doc.rust-lang.org/rust-by-example/error/result/enter_question_mark.html). The 98 | `Early` class resembles the 99 | [Try trait](https://doc.rust-lang.org/std/ops/trait.Try.html), but is 100 | slightly different, as Haskell has higher-kinded types. 101 | 102 | Additionally, one can take a Rust-like view of error handling in 103 | Haskell: 104 | 105 | |Use-case|Haskell|Rust| 106 | |---:|---:|---:| 107 | |Unrecoverable errors|Throwing exceptions|Panics| 108 | |Recoverable errors|Return `Either`/`Maybe`|Return `Result`/`Some`| 109 | 110 | This plugin allows one to structure their code in such a way. 111 | 112 | ## Future Work 113 | 114 | A small library of short-circuiting `traverse`/`fold` would let one 115 | use actions that return `Either`/`Maybe`. 116 | 117 | ## Special thanks 118 | 119 | The following people's work helped me a lot to get my work done faster: 120 | 121 | * Shayne Fletcher and Neil Mitchell https://github.com/digital-asset/ghc-lib 122 | * Oleg Grenrus https://github.com/phadej/idioms-plugins 123 | * Mark Karpov https://github.com/mrkkrp/ghc-syntax-highlighter 124 | -------------------------------------------------------------------------------- /src/EarlyPlugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE PackageImports #-} 5 | module EarlyPlugin (plugin) where 6 | 7 | import Control.Monad.IO.Class (MonadIO (..)) 8 | import Control.Monad.Trans.State.Strict 9 | import qualified Data.Generics as SYB 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import qualified "ghc" GhcPlugins as GHC 13 | import "ghc" HsExtension (GhcPs) 14 | import "ghc" HsSyn 15 | import "ghc" OccName 16 | import "ghc" SrcLoc 17 | import Text.Read 18 | 19 | plugin :: GHC.Plugin 20 | plugin = GHC.defaultPlugin 21 | { GHC.parsedResultAction = \cliOptions -> pluginImpl cliOptions 22 | , GHC.pluginRecompile = GHC.purePlugin 23 | } 24 | 25 | pluginImpl :: [GHC.CommandLineOption] -> GHC.ModSummary -> GHC.HsParsedModule -> GHC.Hsc GHC.HsParsedModule 26 | pluginImpl options _modSummary m = do 27 | case parseLocs (foldMap T.pack options) of 28 | Left err -> error err 29 | Right [] -> pure m 30 | Right locs -> do 31 | dflags <- GHC.getDynFlags 32 | debug $ GHC.showPpr dflags (GHC.hpm_module m) 33 | debug "===>" 34 | (hpm_module', locs_found) <- 35 | runStateT (transform locs dflags (GHC.hpm_module m)) 0 36 | if locs_found == length locs 37 | then do 38 | debug $ show locs 39 | debug $ GHC.showPpr dflags (hpm_module') 40 | let module' = m {GHC.hpm_module = hpm_module'} 41 | return module' 42 | else do 43 | -- Later, we can collect the offending locations instead of 44 | -- simply counting, and emit a more useful error message. 45 | error "There is a question-mark used in a non-statement position!" 46 | 47 | debug :: MonadIO m => String -> m () 48 | -- debug = liftIO . putStrLn 49 | debug _ = pure () 50 | 51 | transform :: 52 | [Loc] 53 | -> GHC.DynFlags 54 | -> GHC.Located (HsModule GhcPs) 55 | -> StateT Int GHC.Hsc (GHC.Located (HsModule GhcPs)) 56 | transform locs dflags = SYB.everywhereM (SYB.mkM (transformDo dflags locs)) 57 | 58 | transformDo :: 59 | GHC.DynFlags 60 | -> [Loc] 61 | -> LHsExpr GhcPs 62 | -> StateT Int GHC.Hsc (LHsExpr GhcPs) 63 | transformDo dflags locs = 64 | \case 65 | (L l (HsDo xdo DoExpr (L l' stmts@(_:_)))) -> do 66 | stmts' <- transformStmts dflags locs stmts 67 | pure (L l (HsDo xdo DoExpr (L l' stmts'))) 68 | e -> pure e 69 | 70 | transformStmts :: 71 | GHC.DynFlags 72 | -> [Loc] 73 | -> [LStmt GhcPs (LHsExpr GhcPs)] 74 | -> StateT Int GHC.Hsc [LStmt GhcPs (LHsExpr GhcPs)] 75 | transformStmts _ _ [] = pure [] 76 | transformStmts dflags locs (current:rest) 77 | | stmtIsEarly locs current = do 78 | modify' (+1) 79 | stmts <- transformStmts dflags locs rest 80 | pure (transformStmt current stmts) 81 | | otherwise = fmap (current :) (transformStmts dflags locs rest) 82 | 83 | transformStmt :: 84 | LStmt GhcPs (LHsExpr GhcPs) 85 | -> [LStmt GhcPs (LHsExpr GhcPs)] 86 | -> [LStmt GhcPs (LHsExpr GhcPs)] 87 | transformStmt (L stmtloc current) rest = 88 | case current of 89 | BodyStmt x lexpr l r -> 90 | [ L stmtloc 91 | (BodyStmt 92 | x 93 | (L GHC.noSrcSpan 94 | (HsApp 95 | NoExt 96 | (L GHC.noSrcSpan 97 | (HsApp 98 | NoExt 99 | (L GHC.noSrcSpan 100 | (HsVar NoExt (L GHC.noSrcSpan earlyThenName))) 101 | lexpr)) 102 | (L GHC.noSrcSpan (HsDo NoExt DoExpr (L GHC.noSrcSpan rest))))) 103 | l 104 | r) 105 | ] 106 | BindStmt x lpat lexpr l r -> 107 | [ L stmtloc 108 | (BodyStmt 109 | x 110 | (L GHC.noSrcSpan 111 | (HsApp 112 | NoExt 113 | (L GHC.noSrcSpan 114 | (HsApp 115 | NoExt 116 | (L GHC.noSrcSpan 117 | (HsVar NoExt (L GHC.noSrcSpan earlyName))) 118 | lexpr)) 119 | (makeLambda 120 | lpat 121 | (L GHC.noSrcSpan 122 | (HsDo NoExt DoExpr (L GHC.noSrcSpan rest)))))) 123 | l 124 | r) 125 | ] 126 | _ -> L stmtloc current : rest 127 | 128 | -- | Making a lambda took me like 15 minutes of endless types. So this 129 | -- is in a function. 130 | makeLambda :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 131 | makeLambda lpat lexpr = 132 | L GHC.noSrcSpan 133 | (HsLam 134 | NoExt 135 | (MG 136 | NoExt 137 | (L GHC.noSrcSpan 138 | [ L GHC.noSrcSpan 139 | (Match 140 | NoExt 141 | LambdaExpr 142 | [lpat] 143 | (GRHSs 144 | NoExt 145 | [L GHC.noSrcSpan (GRHS NoExt [] lexpr)] 146 | (L GHC.noSrcSpan (EmptyLocalBinds NoExt)))) 147 | ]) 148 | GHC.Generated)) 149 | 150 | stmtIsEarly :: [Loc] -> LStmt GhcPs (LHsExpr GhcPs) -> Bool 151 | stmtIsEarly locs (L l BindStmt {}) = any (flip srcSpanFollowedBy l) locs 152 | stmtIsEarly locs (L l BodyStmt {}) = any (flip srcSpanFollowedBy l) locs 153 | stmtIsEarly _ _ = False 154 | 155 | -------------------------------------------------------------------------------- 156 | -- Names 157 | 158 | earlyName :: GHC.RdrName 159 | earlyName = GHC.mkQual OccName.varName ("Control.Early","early") 160 | 161 | earlyThenName :: GHC.RdrName 162 | earlyThenName = GHC.mkQual OccName.varName ("Control.Early","earlyThen") 163 | 164 | -------------------------------------------------------------------------------- 165 | -- Locations 166 | 167 | srcSpanFollowedBy :: Loc -> SrcSpan -> Bool 168 | srcSpanFollowedBy (Loc line col) sp = 169 | case sp of 170 | RealSrcSpan s -> srcSpanEndLine s == line && srcSpanEndCol s == col 171 | _ -> False 172 | 173 | data Loc = Loc 174 | { line, col :: !Int 175 | } deriving (Eq, Ord, Show) 176 | 177 | parseLocs :: Text -> Either String [Loc] 178 | parseLocs = 179 | mapM 180 | ((\case 181 | [x, y] -> do 182 | line <- readEither (T.unpack x) 183 | col <- readEither (T.unpack y) 184 | pure (Loc {line, col}) 185 | _ -> Left "Expected line:col pattern for input.") . 186 | T.splitOn ":") . 187 | T.splitOn "," 188 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE PackageImports #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TupleSections #-} 9 | {-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-orphans #-} 10 | 11 | -- | This is the preprocessor that extracts ? from the module, retaining 12 | -- their positions, and then passes them to the compiler plugin. 13 | -- 14 | 15 | -- © 2020 Sky Above Limited 16 | -- © 2018 Mark Karpov 17 | 18 | module Main (main) where 19 | import Control.Monad 20 | import Data.HashMap.Strict (HashMap) 21 | import qualified Data.HashMap.Strict as HM 22 | import Data.List (foldl') 23 | import qualified Data.List as List 24 | import Data.Maybe 25 | import Data.Text (Text) 26 | import qualified Data.Text as T 27 | import qualified Data.Text.IO as T 28 | import "ghc-lib-parser" DynFlags 29 | import qualified "ghc-lib-parser" EnumSet as ES 30 | import "ghc-lib-parser" FastString (mkFastString) 31 | import "ghc-lib-parser" GHC.LanguageExtensions 32 | import qualified "ghc-lib-parser" Lexer as L 33 | import "ghc-lib-parser" SrcLoc 34 | import "ghc-lib-parser" StringBuffer 35 | import System.Environment 36 | 37 | main :: IO () 38 | main = do 39 | _:input:output:_ <- getArgs 40 | contents <- T.readFile input -- gather metadata, transform content 41 | case tokenizeHaskellLoc contents of 42 | Nothing -> error "Bad lex!" 43 | Just tokens -> do 44 | T.writeFile 45 | output 46 | (T.concat 47 | [ "{-# OPTIONS -fplugin=EarlyPlugin -fplugin-opt=EarlyPlugin:" 48 | , T.intercalate 49 | "," 50 | (map 51 | (\Loc {..} -> 52 | T.intercalate ":" (map (T.pack . show) [line, col])) 53 | qs) 54 | , " #-} " 55 | , "\n{-# LINE 1 " <> T.pack (show input) <> " #-}\n" 56 | , strip (buildlocs qs) contents 57 | ]) 58 | where qs = questions (filter (not . isComment . fst) tokens) 59 | 60 | isComment :: L.Token -> Bool 61 | isComment = 62 | \case 63 | L.ITcomment_line_prag -> True 64 | L.ITdocCommentNext _ -> True 65 | L.ITdocCommentPrev _ -> True 66 | L.ITdocCommentNamed _ -> True 67 | L.ITdocSection _ _ -> True 68 | L.ITdocOptions _ -> True 69 | L.ITlineComment _ -> True 70 | L.ITblockComment _ -> True 71 | _ -> False 72 | 73 | buildlocs :: [Loc] -> HashMap Int [Int] 74 | buildlocs = HM.fromListWith (<>) . map (\Loc{line,col} -> (line,pure col)) 75 | 76 | -- Keep a running map of lines to cols to delete. Clear the lines 77 | -- after applying them, reducing the map size. Perhaps that's a 78 | -- premature optimization, but it's clean. 79 | strip :: HashMap Int [Int] -> Text -> Text 80 | strip locs0 = T.unlines . snd . List.mapAccumL cut locs0 . zip [1 ..] . T.lines 81 | where 82 | cut locs (line, text) = 83 | if HM.null locs 84 | then (locs, text) 85 | else case HM.lookup line locs of 86 | Nothing -> (locs, text) 87 | Just cols -> (HM.delete line locs, text') 88 | where !text' = 89 | foldl' 90 | (\text'' col -> 91 | T.take (col - 1) text'' <> " " <> 92 | T.drop col text'') 93 | text 94 | cols 95 | 96 | questions :: [(L.Token, Maybe t)] -> [t] 97 | questions tokens = 98 | mapMaybe 99 | (\((tok, loc), (ntok, _)) -> do 100 | guard (tok == (L.ITvarsym "?") && isEndOfStatement ntok) 101 | loc) 102 | (zip tokens (drop 1 tokens)) 103 | 104 | -- False negatives are an error, but false positives are fine, they 105 | -- will be rejected in a later stage when more information is 106 | -- available. 107 | -- 108 | -- A question-mark can only appear BEFORE the last do statement, 109 | -- therefore the only legitimate token following is a semi! which 110 | -- separates do statements, explicitly or implicitly. 111 | -- 112 | -- This would permit also @where x = 1?; y = 2@, but that's fine. It 113 | -- will be flagged up as invalid during the parsing phase in the 114 | -- plugin. We will complain loudly as an error when any remaining ?'s 115 | -- are not resolved during that stage. 116 | -- 117 | -- Additionally, it's not in operator position (e.g. x?y); we do not 118 | -- want to pick up valid syntax. 119 | isEndOfStatement :: L.Token -> Bool 120 | isEndOfStatement = 121 | \case 122 | L.ITsemi -> True 123 | _ -> False 124 | 125 | deriving instance Eq L.Token 126 | data Loc = Loc 127 | { line, col :: !Int 128 | } deriving (Eq, Ord, Show) 129 | 130 | tokenizeHaskellLoc :: Text -> Maybe [(L.Token, Maybe Loc)] 131 | tokenizeHaskellLoc input = 132 | case L.unP pLexer parseState of 133 | L.PFailed {} -> Nothing 134 | L.POk _ x -> Just x 135 | where 136 | location = mkRealSrcLoc (mkFastString "") 1 1 137 | buffer = stringToStringBuffer (T.unpack input) 138 | parseState = L.mkPStatePure parserFlags buffer location 139 | parserFlags = L.mkParserFlags (foldl' xopt_set initialDynFlags enabledExts) 140 | initialDynFlags = 141 | DynFlags 142 | { warningFlags = ES.empty, 143 | generalFlags = 144 | ES.fromList 145 | [ Opt_Haddock, 146 | Opt_KeepRawTokenStream 147 | ], 148 | extensions = [], 149 | extensionFlags = ES.empty, 150 | safeHaskell = Sf_Safe, 151 | language = Just Haskell2010 152 | } 153 | 154 | pLexer :: L.P [(L.Token, Maybe Loc)] 155 | pLexer = go 156 | where 157 | go = do 158 | r <- L.lexer False return 159 | case r of 160 | L _ L.ITeof -> return [] 161 | _ -> 162 | case fixupToken r of 163 | x -> (x :) <$> go 164 | 165 | fixupToken :: Located L.Token -> (L.Token, Maybe Loc) 166 | fixupToken (L srcSpan tok) = (tok,srcSpanToLoc srcSpan) 167 | 168 | srcSpanToLoc :: SrcSpan -> Maybe Loc 169 | srcSpanToLoc (RealSrcSpan rss) = 170 | let start = realSrcSpanStart rss 171 | in Just $ 172 | Loc (srcLocLine start) (srcLocCol start) 173 | srcSpanToLoc _ = Nothing 174 | 175 | ---------------------------------------------------------------------------- 176 | -- Language extensions 177 | 178 | -- | Language extensions we enable by default. 179 | enabledExts :: [Extension] 180 | enabledExts = 181 | [ ForeignFunctionInterface, 182 | InterruptibleFFI, 183 | CApiFFI, 184 | Arrows, 185 | TemplateHaskell, 186 | TemplateHaskellQuotes, 187 | ImplicitParams, 188 | OverloadedLabels, 189 | ExplicitForAll, 190 | BangPatterns, 191 | PatternSynonyms, 192 | MagicHash, 193 | RecursiveDo, 194 | UnicodeSyntax, 195 | UnboxedTuples, 196 | UnboxedSums, 197 | DatatypeContexts, 198 | TransformListComp, 199 | QuasiQuotes, 200 | LambdaCase, 201 | BinaryLiterals, 202 | NegativeLiterals, 203 | HexFloatLiterals, 204 | TypeApplications, 205 | StaticPointers, 206 | NumericUnderscores, 207 | StarIsType 208 | ] 209 | --------------------------------------------------------------------------------