diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright © 2020 Sky Above Limited +Copyright © 2018 Mark Karpov + +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 Sky Above Limited, Mark Karpov nor the names of + 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 “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 HOLDERS 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,123 @@ +# early + +Add early return to any `do`-expression + + +**Table of Contents** + +- [early](#early) + - [Description](#description) + - [How it works](#how-it-works) + - [Details](#details) + - [Why not `ExceptT` or exceptions?](#why-not-exceptt-or-exceptions) + - [Inspiration](#inspiration) + - [Special thanks](#special-thanks) + + + + +## Description + +This package is a GHC plugin to add special syntax for early return in +`do`-notation. It provides a way to terminate the current +`do`-expression with a result, usually a failure result, but not +necessarily. It should not be confused with an exception handler. It +uses regular values everywhere. + +## How it works + +The plugin is enabled in any module via a pragma. + +``` haskell +{-# OPTIONS -F -pgmF=early #-} +``` + +The syntax `?` can be added to the end of any `do` statement to make +it short-circuit when the action produces a certain "stop" result +(such as `Left`, or `Nothing`; **the particular type is type-class +based**, see the Details section below). + +Suppose that `grabEnv :: String -> IO (Either Error String)`, then you +can write this: + +```haskell +app :: IO (Either Error String) +app = do + path <- grabEnv "PATH"? + putStrLn "Look ma, no lifts!" + magic <- grabEnv "MAGIC"? + pure (Right (path ++ magic)) +``` + +Note the final `pure` in the do should wrap the type, as the type of +the whole `do`-block has changed. + +That's it! See `test/Main.hs` for full example. + +## Details + +The syntax `stmt?` is desugared in this way: + +* `do stmt?; next` becomes `do earlyThen stmt next` +* `do pat <- stmt?; next; next2` becomes `do early stmt (\pat -> do next; next2; ...)` + +The `early` and `earlyThen` are driven by the `Early` class, which any +functor-like data type can implement. + +``` haskell +early :: (Monad m, Early f) => m (f a) -> (a -> m (f b)) -> m (f b) +earlyThen :: (Monad m, Early f) => m (f a) -> m (f b) -> m (f b) +``` + +``` haskell +class Functor f => Early f where + dispatch :: Applicative m => f a -> (a -> m (f b)) -> m (f b) +``` + +Two provided instances out of the box are `Either e` and `Maybe`, but +others can be added freely, such as a `Failure e a` type of your +library, etc. + +### Why not `ExceptT` or exceptions? + +Full explanation here: +[my recoverable errors post](https://chrisdone.com/posts/recoverable-errors-in-haskell/). + +Because `ExceptT` (or `ContT`) cannot be an +instance of `MonadUnliftIO`. It is not unliftable; this means that +exceptions, cleanup and concurrency don't have an interpretation. This +is an area where monad transformers in `mtl`/`transformers` don't +compose. Other free monads commute, but then you have to use a free +monad which has a complicated story regarding performance. + +## Inspiration + +The syntax and concept of using simple return values for early +termination and failure handling is inspired +[by Rust's error handling](https://doc.rust-lang.org/rust-by-example/error/result/enter_question_mark.html). The +`Early` class resembles the +[Try trait](https://doc.rust-lang.org/std/ops/trait.Try.html), but is +slightly different, as Haskell has higher-kinded types. + +Additionally, one can take a Rust-like view of error handling in +Haskell: + +|Use-case|Haskell|Rust| +|---:|---:|---:| +|Unrecoverable errors|Throwing exceptions|Panics| +|Recoverable errors|Return `Either`/`Maybe`|Return `Result`/`Some`| + +This plugin allows one to structure their code in such a way. + +## Future Work + +A small library of short-circuiting `traverse`/`fold` would let one +use actions that return `Either`/`Maybe`. + +## Special thanks + +The following people's work helped me a lot to get my work done faster: + +* Shayne Fletcher and Neil Mitchell https://github.com/digital-asset/ghc-lib +* Oleg Grenrus https://github.com/phadej/idioms-plugins +* Mark Karpov https://github.com/mrkkrp/ghc-syntax-highlighter diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-orphans #-} + +-- | This is the preprocessor that extracts ? from the module, retaining +-- their positions, and then passes them to the compiler plugin. +-- + +-- © 2020 Sky Above Limited +-- © 2018 Mark Karpov + +module Main (main) where +import Control.Monad +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.List (foldl') +import qualified Data.List as List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import "ghc-lib-parser" DynFlags +import qualified "ghc-lib-parser" EnumSet as ES +import "ghc-lib-parser" FastString (mkFastString) +import "ghc-lib-parser" GHC.LanguageExtensions +import qualified "ghc-lib-parser" Lexer as L +import "ghc-lib-parser" SrcLoc +import "ghc-lib-parser" StringBuffer +import System.Environment + +main :: IO () +main = do + _:input:output:_ <- getArgs + contents <- T.readFile input -- gather metadata, transform content + case tokenizeHaskellLoc contents of + Nothing -> error "Bad lex!" + Just tokens -> do + T.writeFile + output + (T.concat + [ "{-# LINE 1 \"" <> T.pack input <> "\" #-}\n" + , "{-# OPTIONS -fplugin=EarlyPlugin -fplugin-opt=EarlyPlugin:" + , T.intercalate + "," + (map + (\Loc {..} -> + T.intercalate ":" (map (T.pack . show) [line, col])) + qs) + , " #-}\n" + , strip (buildlocs qs) contents + ]) + where qs = questions (filter (not . isComment . fst) tokens) + +isComment :: L.Token -> Bool +isComment = + \case + L.ITcomment_line_prag -> True + L.ITdocCommentNext _ -> True + L.ITdocCommentPrev _ -> True + L.ITdocCommentNamed _ -> True + L.ITdocSection _ _ -> True + L.ITdocOptions _ -> True + L.ITlineComment _ -> True + L.ITblockComment _ -> True + _ -> False + +buildlocs :: [Loc] -> HashMap Int [Int] +buildlocs = HM.fromListWith (<>) . map (\Loc{line,col} -> (line,pure col)) + +-- Keep a running map of lines to cols to delete. Clear the lines +-- after applying them, reducing the map size. Perhaps that's a +-- premature optimization, but it's clean. +strip :: HashMap Int [Int] -> Text -> Text +strip locs0 = T.unlines . snd . List.mapAccumL cut locs0 . zip [1 ..] . T.lines + where + cut locs (line, text) = + if HM.null locs + then (locs, text) + else case HM.lookup line locs of + Nothing -> (locs, text) + Just cols -> (HM.delete line locs, text') + where !text' = + foldl' + (\text'' col -> + T.take (col - 1) text'' <> " " <> + T.drop col text'') + text + cols + +questions :: [(L.Token, Maybe t)] -> [t] +questions tokens = + mapMaybe + (\((tok, loc), (ntok, _)) -> do + guard (tok == (L.ITvarsym "?") && isEndOfStatement ntok) + loc) + (zip tokens (drop 1 tokens)) + +-- False negatives are an error, but false positives are fine, they +-- will be rejected in a later stage when more information is +-- available. +-- +-- A question-mark can only appear BEFORE the last do statement, +-- therefore the only legitimate token following is a semi! which +-- separates do statements, explicitly or implicitly. +-- +-- This would permit also @where x = 1?; y = 2@, but that's fine. It +-- will be flagged up as invalid during the parsing phase in the +-- plugin. We will complain loudly as an error when any remaining ?'s +-- are not resolved during that stage. +-- +-- Additionally, it's not in operator position (e.g. x?y); we do not +-- want to pick up valid syntax. +isEndOfStatement :: L.Token -> Bool +isEndOfStatement = + \case + L.ITsemi -> True + _ -> False + +deriving instance Eq L.Token +data Loc = Loc + { line, col :: !Int + } deriving (Eq, Ord, Show) + +tokenizeHaskellLoc :: Text -> Maybe [(L.Token, Maybe Loc)] +tokenizeHaskellLoc input = + case L.unP pLexer parseState of + L.PFailed {} -> Nothing + L.POk _ x -> Just x + where + location = mkRealSrcLoc (mkFastString "") 1 1 + buffer = stringToStringBuffer (T.unpack input) + parseState = L.mkPStatePure parserFlags buffer location + parserFlags = L.mkParserFlags (foldl' xopt_set initialDynFlags enabledExts) + initialDynFlags = + DynFlags + { warningFlags = ES.empty, + generalFlags = + ES.fromList + [ Opt_Haddock, + Opt_KeepRawTokenStream + ], + extensions = [], + extensionFlags = ES.empty, + safeHaskell = Sf_Safe, + language = Just Haskell2010 + } + +pLexer :: L.P [(L.Token, Maybe Loc)] +pLexer = go + where + go = do + r <- L.lexer False return + case r of + L _ L.ITeof -> return [] + _ -> + case fixupToken r of + x -> (x :) <$> go + +fixupToken :: Located L.Token -> (L.Token, Maybe Loc) +fixupToken (L srcSpan tok) = (tok,srcSpanToLoc srcSpan) + +srcSpanToLoc :: SrcSpan -> Maybe Loc +srcSpanToLoc (RealSrcSpan rss) = + let start = realSrcSpanStart rss + in Just $ + Loc (srcLocLine start) (srcLocCol start) +srcSpanToLoc _ = Nothing + +---------------------------------------------------------------------------- +-- Language extensions + +-- | Language extensions we enable by default. +enabledExts :: [Extension] +enabledExts = + [ ForeignFunctionInterface, + InterruptibleFFI, + CApiFFI, + Arrows, + TemplateHaskell, + TemplateHaskellQuotes, + ImplicitParams, + OverloadedLabels, + ExplicitForAll, + BangPatterns, + PatternSynonyms, + MagicHash, + RecursiveDo, + UnicodeSyntax, + UnboxedTuples, + UnboxedSums, + DatatypeContexts, + TransformListComp, + QuasiQuotes, + LambdaCase, + BinaryLiterals, + NegativeLiterals, + HexFloatLiterals, + TypeApplications, + StaticPointers, + NumericUnderscores, + StarIsType + ] diff --git a/early.cabal b/early.cabal new file mode 100644 --- /dev/null +++ b/early.cabal @@ -0,0 +1,73 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 7c267bac1eef5336a088a22b865353f3c8f7ac23d785d3fe187d43fb7b5454d4 + +name: early +version: 0.0.0 +synopsis: Early return syntax in do-notation (GHC plugin) +description: Please see the README on GitHub at +category: Development +homepage: https://github.com/inflex-io/early#readme +bug-reports: https://github.com/inflex-io/early/issues +author: Sky Above Limited +maintainer: chris@skyabove.io +copyright: 2021 Chris Done +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/inflex-io/early + +library + exposed-modules: + Control.Early + Data.Early + EarlyPlugin + other-modules: + Paths_early + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers + , ghc + , syb + , text + , transformers + default-language: Haskell2010 + +executable early + main-is: Main.hs + other-modules: + Paths_early + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , ghc-lib-parser + , text + , unordered-containers + default-language: Haskell2010 + +test-suite early-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_early + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , early + default-language: Haskell2010 diff --git a/src/Control/Early.hs b/src/Control/Early.hs new file mode 100644 --- /dev/null +++ b/src/Control/Early.hs @@ -0,0 +1,48 @@ +-- | Early return in monads. + +module Control.Early + ( Early(..) + , early + , earlyThen + ) where + +-------------------------------------------------------------------------------- +-- Class providing different early return types + +-- | A class for things which can offer branching for early return. +-- +-- The most obvious two types are 'Either' and 'Maybe'. +class Functor f => Early f where + dispatch :: Applicative m => f a -> (a -> m (f b)) -> m (f b) + +-------------------------------------------------------------------------------- +-- Top-level API + +-- | Early return specialized on f (for now). +early :: (Monad m, Early f) => m (f a) -> (a -> m (f b)) -> m (f b) +early m f = do + r <- m + dispatch r f +{-# INLINE early #-} + +-- | Early return specialized on f (for now). +earlyThen :: (Monad m, Early f) => m (f a) -> m (f b) -> m (f b) +earlyThen m f = early m (const f) +{-# INLINE earlyThen #-} + +-------------------------------------------------------------------------------- +-- Instances + +instance Early (Either e) where + dispatch r f = + case r of + Left e -> pure (Left e) + Right x -> f x + {-# INLINE dispatch #-} + +instance Early Maybe where + dispatch r f = + case r of + Nothing -> pure Nothing + Just x -> f x + {-# INLINE dispatch #-} diff --git a/src/Data/Early.hs b/src/Data/Early.hs new file mode 100644 --- /dev/null +++ b/src/Data/Early.hs @@ -0,0 +1,40 @@ +module Data.Early + ( FoldableEarly(..) + , TraversableEarly(..) + ) where + +import Control.Early +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq + +class Foldable t => FoldableEarly t where + foldE :: (Monad m, Early f, Applicative f) + => (x -> a -> m (f x)) -> x -> t a -> m (f x) + +instance FoldableEarly [] where + foldE cons nil0 = go nil0 + where + go nil [] = pure (pure nil) + go nil (x:xs) = early (cons nil x) (\x' -> go x' xs) + +instance FoldableEarly Seq where + foldE cons nil0 = go nil0 + where + go nil Seq.Empty = pure (pure nil) + go nil (x Seq.:<| xs) = early (cons nil x) (\x' -> go x' xs) + +class Traversable t => TraversableEarly t where + traverseE :: (Monad m, Early f, Applicative f) + => (a -> m (f b)) -> t a -> m (f (t b)) + +instance TraversableEarly [] where + traverseE f = go [] + where + go acc [] = pure (pure (reverse acc)) + go acc (x:xs) = early (f x) (\x' -> go (x' : acc) xs) + +instance TraversableEarly Seq where + traverseE f = go mempty + where + go acc Seq.Empty = pure (pure acc) + go acc (x Seq.:<| xs) = early (f x) (\x' -> go (acc Seq.:|> x') xs) diff --git a/src/EarlyPlugin.hs b/src/EarlyPlugin.hs new file mode 100644 --- /dev/null +++ b/src/EarlyPlugin.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +module EarlyPlugin (plugin) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Trans.State.Strict +import qualified Data.Generics as SYB +import Data.Text (Text) +import qualified Data.Text as T +import qualified "ghc" GhcPlugins as GHC +import "ghc" HsExtension (GhcPs) +import "ghc" HsSyn +import "ghc" OccName +import "ghc" SrcLoc +import Text.Read + +plugin :: GHC.Plugin +plugin = GHC.defaultPlugin + { GHC.parsedResultAction = \cliOptions -> pluginImpl cliOptions + , GHC.pluginRecompile = GHC.purePlugin + } + +pluginImpl :: [GHC.CommandLineOption] -> GHC.ModSummary -> GHC.HsParsedModule -> GHC.Hsc GHC.HsParsedModule +pluginImpl options _modSummary m = do + case parseLocs (foldMap T.pack options) of + Left err -> error err + Right [] -> pure m + Right locs -> do + dflags <- GHC.getDynFlags + debug $ GHC.showPpr dflags (GHC.hpm_module m) + debug "===>" + (hpm_module', locs_found) <- + runStateT (transform locs dflags (GHC.hpm_module m)) 0 + if locs_found == length locs + then do + debug $ show locs + debug $ GHC.showPpr dflags (hpm_module') + let module' = m {GHC.hpm_module = hpm_module'} + return module' + else do + -- Later, we can collect the offending locations instead of + -- simply counting, and emit a more useful error message. + error "There is a question-mark used in a non-statement position!" + +debug :: MonadIO m => String -> m () +-- debug = liftIO . putStrLn +debug _ = pure () + +transform :: + [Loc] + -> GHC.DynFlags + -> GHC.Located (HsModule GhcPs) + -> StateT Int GHC.Hsc (GHC.Located (HsModule GhcPs)) +transform locs dflags = SYB.everywhereM (SYB.mkM (transformDo dflags locs)) + +transformDo :: + GHC.DynFlags + -> [Loc] + -> LHsExpr GhcPs + -> StateT Int GHC.Hsc (LHsExpr GhcPs) +transformDo dflags locs = + \case + (L l (HsDo xdo DoExpr (L l' stmts@(_:_)))) -> do + stmts' <- transformStmts dflags locs stmts + pure (L l (HsDo xdo DoExpr (L l' stmts'))) + e -> pure e + +transformStmts :: + GHC.DynFlags + -> [Loc] + -> [LStmt GhcPs (LHsExpr GhcPs)] + -> StateT Int GHC.Hsc [LStmt GhcPs (LHsExpr GhcPs)] +transformStmts _ _ [] = pure [] +transformStmts dflags locs (current:rest) + | stmtIsEarly locs current = do + modify' (+1) + stmts <- transformStmts dflags locs rest + pure (transformStmt current stmts) + | otherwise = fmap (current :) (transformStmts dflags locs rest) + +transformStmt :: + LStmt GhcPs (LHsExpr GhcPs) + -> [LStmt GhcPs (LHsExpr GhcPs)] + -> [LStmt GhcPs (LHsExpr GhcPs)] +transformStmt (L stmtloc current) rest = + case current of + BodyStmt x lexpr l r -> + [ L stmtloc + (BodyStmt + x + (L GHC.noSrcSpan + (HsApp + NoExt + (L GHC.noSrcSpan + (HsApp + NoExt + (L GHC.noSrcSpan + (HsVar NoExt (L GHC.noSrcSpan earlyThenName))) + lexpr)) + (L GHC.noSrcSpan (HsDo NoExt DoExpr (L GHC.noSrcSpan rest))))) + l + r) + ] + BindStmt x lpat lexpr l r -> + [ L stmtloc + (BodyStmt + x + (L GHC.noSrcSpan + (HsApp + NoExt + (L GHC.noSrcSpan + (HsApp + NoExt + (L GHC.noSrcSpan + (HsVar NoExt (L GHC.noSrcSpan earlyName))) + lexpr)) + (makeLambda + lpat + (L GHC.noSrcSpan + (HsDo NoExt DoExpr (L GHC.noSrcSpan rest)))))) + l + r) + ] + _ -> L stmtloc current : rest + +-- | Making a lambda took me like 15 minutes of endless types. So this +-- is in a function. +makeLambda :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +makeLambda lpat lexpr = + L GHC.noSrcSpan + (HsLam + NoExt + (MG + NoExt + (L GHC.noSrcSpan + [ L GHC.noSrcSpan + (Match + NoExt + LambdaExpr + [lpat] + (GRHSs + NoExt + [L GHC.noSrcSpan (GRHS NoExt [] lexpr)] + (L GHC.noSrcSpan (EmptyLocalBinds NoExt)))) + ]) + GHC.Generated)) + +stmtIsEarly :: [Loc] -> LStmt GhcPs (LHsExpr GhcPs) -> Bool +stmtIsEarly locs (L l BindStmt {}) = any (flip srcSpanFollowedBy l) locs +stmtIsEarly locs (L l BodyStmt {}) = any (flip srcSpanFollowedBy l) locs +stmtIsEarly _ _ = False + +-------------------------------------------------------------------------------- +-- Names + +earlyName :: GHC.RdrName +earlyName = GHC.mkQual OccName.varName ("Control.Early","early") + +earlyThenName :: GHC.RdrName +earlyThenName = GHC.mkQual OccName.varName ("Control.Early","earlyThen") + +-------------------------------------------------------------------------------- +-- Locations + +srcSpanFollowedBy :: Loc -> SrcSpan -> Bool +srcSpanFollowedBy (Loc line col) sp = + case sp of + RealSrcSpan s -> srcSpanEndLine s == line + 1 && srcSpanEndCol s == col + _ -> False + +data Loc = Loc + { line, col :: !Int + } deriving (Eq, Ord, Show) + +parseLocs :: Text -> Either String [Loc] +parseLocs = + mapM + ((\case + [x, y] -> do + line <- readEither (T.unpack x) + col <- readEither (T.unpack y) + pure (Loc {line, col}) + _ -> Left "Expected line:col pattern for input.") . + T.splitOn ":") . + T.splitOn "," diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -F -pgmF=early #-} + +module Main (main) where + +import Control.Early +import System.Environment + +data Error = + MissingEnv String + deriving (Show) + +grabEnv :: String -> IO (Either Error String) +grabEnv key = do + result <- lookupEnv key + pure (maybe (Left (MissingEnv key)) Right result) + +main :: IO () +main = do + result <- app + print result + +app :: IO (Either Error String) +app = do + path <- fmap (maybe (Left (MissingEnv "PATH")) Right) $ lookupEnv "PATH"? + grabEnv "PWD"? + magic <- grabEnv "PATH"? + pure (Right (path ++ magic))