From 7bfe740a8f87cba5b9d5db84c89a432af827c0ef Mon Sep 17 00:00:00 2001 From: Samuel Evans-Powell Date: Mon, 23 Mar 2020 15:22:08 +0800 Subject: [PATCH] Support versions of haskell-src-exts >= 1.20.0 - Add Pretty implementation of: - UnboxedSum patterns, expressions, and types (since haskell-src-exts 1.20.0). - DerivingVia (since haskell-src-exts 1.21.0). - Typed Template Haskell splices and expressions (since haskell-src-exts 1.22.0). - Update "Pretty Asst" instance to match new "Asst" structure in haskell-src-exts 1.22.0. - Move stackage snapshot to "lts-15.5" and use "MonadFail". - Use "error" in "src/main/Test.hs" instead of "fail" as "SpecM" does not have an instance of MonadFail (yet). - Remove unused functions "isRecord", "recDecl", and "qualConDecl". --- TESTS.md | 65 +++++++++++++++++++++ src/HIndent/Pretty.hs | 132 +++++++++++++++++++++++++++--------------- src/HIndent/Types.hs | 5 ++ src/main/Test.hs | 2 +- stack.yaml | 5 +- 5 files changed, 158 insertions(+), 51 deletions(-) diff --git a/TESTS.md b/TESTS.md index 287e65a5e..d8e917861 100644 --- a/TESTS.md +++ b/TESTS.md @@ -431,6 +431,27 @@ type family Closed (a :: k) :: Bool where Closed x = 'True ``` +Unboxed sum types + +```haskell +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +f :: (# (# Int, String #) | String #) -> (# Int | String #) +f (# (# n, _ #) | #) = (# n | #) +f (# | b #) = (# | b #) + +f' :: + (# (# Int, String #) + | Either Bool Int + | Either Bool Int + | Either Bool Int + | Either Bool Int + | Either Bool Int + | String #) + -> (# Int | String #) +``` + # Template Haskell Expression brackets @@ -439,6 +460,12 @@ Expression brackets add1 x = [|x + 1|] ``` +Typed expression brackets + +```haskell +add1 x = [||x + 1||] +``` + Pattern brackets ```haskell @@ -451,6 +478,12 @@ Type brackets foo :: $([t|Bool|]) -> a ``` +Typed variable splice + +```haskell +add2Typed = [||$$myFuncTyped . $$(myFuncTyped)||] +``` + Quoted data constructors ```haskell @@ -1418,6 +1451,38 @@ newtype Number a = deriving anyclass (Typeable) ``` +Deriving via +```haskell +{-# LANGUAGE DerivingVia #-} + +import Numeric + +newtype Hex a = + Hex a + +instance (Integral a, Show a) => Show (Hex a) where + show (Hex a) = "0x" ++ showHex a "" + +newtype Unicode = + U Int + deriving (Show) via (Hex Int) + deriving ( Functor + , Applicative + , Monad + , Semigroup + , Monoid + , Alternative + , MonadPlus + , Foldable + , Traversable + ) via (Hex Int) + +-- >>> euroSign +-- 0x20ac +euroSign :: Unicode +euroSign = U 0x20ac +``` + neongreen "{" is lost when formatting "Foo{}" #366 ```haskell diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index 46d825483..4a0c0d4f7 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -16,11 +16,11 @@ module HIndent.Pretty import Control.Applicative import Control.Monad.State.Strict hiding (state) import qualified Data.ByteString.Builder as S -import Data.Foldable (for_, forM_, traverse_) +import Data.Foldable (for_, traverse_) import Data.Int import Data.List -import Data.Maybe import Data.Monoid ((<>)) +import Data.Maybe import Data.Typeable import HIndent.Types import qualified Language.Haskell.Exts as P @@ -412,6 +412,9 @@ instance Pretty Pat where PXRPats{} -> pretty' x PVar{} -> pretty' x PSplice _ s -> pretty s +#if MIN_VERSION_haskell_src_exts(1,20,0) + (PUnboxedSum _ nLeft nRight p) -> unboxedSumValuePattern nLeft nRight p +#endif -- | Pretty infix application of a name (identifier or symbol). prettyInfixName :: Name NodeInfo -> Printer () @@ -485,7 +488,9 @@ exp (TupleSection _ boxed mexps) = do parensHorB Unboxed = wrap "(# " " #)" parensVerB Boxed = parens parensVerB Unboxed = wrap "(#" "#)" -exp (UnboxedSum{}) = error "FIXME: No implementation for UnboxedSum." +#if MIN_VERSION_haskell_src_exts(1,20,0) +exp (UnboxedSum _ nLeft nRight e) = unboxedSumValuePattern nLeft nRight e +#endif -- | Infix apps, same algorithm as ChrisDone at the moment. exp e@(InfixApp _ a op b) = infixApp e a op b Nothing @@ -936,19 +941,23 @@ instance Pretty TypeEqn where instance Pretty Deriving where prettyInternal (Deriving _ strategy heads) = - depend (write "deriving" >> space >> writeStrategy) $ do - let heads' = - if length heads == 1 - then map stripParens heads - else heads - maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads')) - case maybeDerives of - Nothing -> formatMultiLine heads' - Just derives -> put derives + depend (write "deriving" >> space) $ + case strategy of + Nothing -> printHeads +#if MIN_VERSION_haskell_src_exts(1,21,0) + Just st@(DerivVia _ _) -> printHeads >> space >> pretty st +#endif + Just st -> depend (pretty st >> space) $ printHeads where - writeStrategy = case strategy of - Nothing -> return () - Just st -> pretty st >> space + printHeads = do + let heads' = + if length heads == 1 + then map stripParens heads + else heads + maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads')) + case maybeDerives of + Nothing -> formatMultiLine heads' + Just derives -> put derives stripParens (IParen _ iRule) = stripParens iRule stripParens x = x formatMultiLine derives = do @@ -962,6 +971,9 @@ instance Pretty DerivStrategy where DerivStock _ -> return () DerivAnyclass _ -> write "anyclass" DerivNewtype _ -> write "newtype" +#if MIN_VERSION_haskell_src_exts(1,21,0) + DerivVia _ t -> depend (write "via" >> space) $ pretty t +#endif instance Pretty Alt where prettyInternal x = @@ -976,6 +988,14 @@ instance Pretty Alt where indentedBlock (depend (write "where ") (pretty binds)) +#if MIN_VERSION_haskell_src_exts(1,22,0) +instance Pretty Asst where + prettyInternal x = + case x of + ParenA _ asst -> parens $ pretty asst + IParam _ name ty -> pretty name >> write " :: " >> pretty ty + TypeA _ ty -> pretty ty +#else instance Pretty Asst where prettyInternal x = case x of @@ -998,6 +1018,7 @@ instance Pretty Asst where Just n -> do write "_" pretty n +#endif instance Pretty BangType where prettyInternal x = @@ -1182,9 +1203,19 @@ instance Pretty Splice where IdSplice _ str -> do write "$" string str +#if MIN_VERSION_haskell_src_exts(1,22,0) + TIdSplice _ str -> + do write "$$" + string str +#endif ParenSplice _ e -> depend (write "$") (parens (pretty e)) +#if MIN_VERSION_haskell_src_exts(1,22,0) + TParenSplice _ e -> + depend (write "$$") + (parens (pretty e)) +#endif instance Pretty InstRule where prettyInternal (IParen _ rule) = parens $ pretty rule @@ -1408,6 +1439,14 @@ instance Pretty Bracket where prettyInternal x = case x of ExpBracket _ p -> quotation "" (pretty p) +#if MIN_VERSION_haskell_src_exts(1,22,0) + TExpBracket _ p -> + brackets + (depend + (write "||") + (do pretty p + write "||")) +#endif PatBracket _ p -> quotation "p" (pretty p) TypeBracket _ ty -> quotation "t" (pretty ty) d@(DeclBracket _ _) -> pretty' d @@ -1847,7 +1886,12 @@ typ (TyWildCard _ name) = do write "_" pretty n typ (TyQuasiQuote _ n s) = quotation n (string s) -typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum." +#if MIN_VERSION_haskell_src_exts(1,20,0) +typ (TyUnboxedSum _ types) = do + let horVar = wrap "(# " " #)" $ inter (write " | ") (map pretty types) + let verVar = wrap "(# " " #)" $ prefixedLined "|" (map (depend space . pretty) types) + horVar `ifFitsOnOneLineOrElse` verVar +#endif #if MIN_VERSION_haskell_src_exts(1,21,0) typ (TyStar _) = write "*" #endif @@ -1954,15 +1998,6 @@ declTy dty = tys -> prefixedLined "-> " (map pretty tys) Just st -> put st --- | Use special record display, used by 'dataDecl' in a record scenario. -qualConDecl :: QualConDecl NodeInfo -> Printer () -qualConDecl (QualConDecl _ tyvars ctx d) = - depend (unless (null (fromMaybe [] tyvars)) - (do write "forall " - spaced (map pretty (fromMaybe [] tyvars)) - write ". ")) - (withCtx ctx (recDecl d)) - -- | Fields are preceded with a space. conDecl :: ConDecl NodeInfo -> Printer () conDecl (RecDecl _ name fields) = do @@ -1987,22 +2022,6 @@ conDecl (ConDecl _ name bangty) = do conDecl (InfixConDecl _ a f b) = inter space [pretty a, pretty f, pretty b] --- | Record decls are formatted like: Foo --- { bar :: X --- } -recDecl :: ConDecl NodeInfo -> Printer () -recDecl (RecDecl _ name fields) = - do pretty name - indentSpaces <- getIndentSpaces - newline - column indentSpaces - (do depend (write "{!") - (prefixedLined "," - (map (depend space . pretty) fields)) - newline - write "}") -recDecl r = prettyInternal r - recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer () recUpdateExpr expWriter updates = do ifFitsOnOneLineOrElse hor $ do @@ -2023,11 +2042,6 @@ recUpdateExpr expWriter updates = do -------------------------------------------------------------------------------- -- Predicates --- | Is the decl a record? -isRecord :: QualConDecl t -> Bool -isRecord (QualConDecl _ _ _ RecDecl{}) = True -isRecord _ = False - -- | If the given operator is an element of line breaks in configuration. isLineBreak :: QName NodeInfo -> Printer Bool isLineBreak (UnQual _ (Symbol _ s)) = do @@ -2145,3 +2159,29 @@ quotation quoter body = write "|") (do body write "|")) + +-- | Write an UnboxedSum value/pattern. +-- +-- >>> unboxedSumValuePattern 0 1 (Var (UnQual (Ident "n"))) +-- (# n | #) +-- >>> unboxedSumValuePattern 0 1 (PTuple Unboxed [PVar (Ident "n"),PWildCard ]) +-- (# (# n, _ #) | #) +-- >>> unboxedSumValuePattern 1 0 (PVar (Ident "b")) +-- (# | b #) +-- >>> unboxedSumValuePattern 1 0 (Var (UnQual (Ident "b"))) +-- (# | b #) +unboxedSumValuePattern + :: (Pretty ast, Show (ast NodeInfo)) + => Int + -- ^ Number of types from the left. + -> Int + -- ^ Number of types from the right. + -> ast NodeInfo + -- ^ Value/Pattern. + -> Printer () + -- ^ UnboxedSum Printer. +unboxedSumValuePattern nLeft nRight e = do + wrap "(# " " #)" $ do + replicateM_ nLeft (write "| ") + pretty e + replicateM_ nRight (write " |") diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs index 78d1ceb35..4d4ea11ff 100644 --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} -- | All types. @@ -70,8 +71,12 @@ data Config = Config -- ^ Extra language extensions enabled by default. } +#if __GLASGOW_HASKELL__ >= 808 -- | Parse an extension. +readExtension :: MonadFail m => String -> m Extension +#else readExtension :: Monad m => String -> m Extension +#endif readExtension x = case classifyExtension x -- Foo of diff --git a/src/main/Test.hs b/src/main/Test.hs index 5a8484e6a..750fdbf99 100644 --- a/src/main/Test.hs +++ b/src/main/Test.hs @@ -61,7 +61,7 @@ toSpec = go shouldBeReadable (reformat cfg code) (L.fromStrict codeExpect) go next' _ -> - fail + error "'haskell given' block must be followed by a 'haskell expect' block" "haskell pending" -> do it (UTF8.toString desc) pending diff --git a/stack.yaml b/stack.yaml index dd632ad2e..a9bc04568 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,6 @@ -resolver: lts-11.8 +resolver: lts-15.5 packages: - '.' extra-deps: -- haskell-src-exts-1.20.2 -- path-0.5.9 -- path-io-1.2.0 allow-newer: True