From 34b9b716015b26a8f9292273bca127e427391923 Mon Sep 17 00:00:00 2001 From: mrkkrp Date: Mon, 27 May 2019 22:20:09 +0200 Subject: [PATCH] Build the project with Nix and switct to GHC 8.6.4 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit It was decided that we're going to make the project compatible with just one GHC version at a time. Right now this version is going to be 8.6.4. A small refactoring included, plus support for the “deriving via” feature. --- .circleci/config.yml | 45 +++---- .../data/deriving-strategies-out.hs | 6 +- .../declaration/data/deriving-strategies.hs | 3 + .../declaration/data/gadt/multiline-out.hs | 4 +- .../data/multiline-arg-parens-out.hs | 4 +- .../declaration/data/multiline-out.hs | 3 +- data/examples/declaration/data/multiline.hs | 3 +- .../declaration/data/simple-broken-out.hs | 4 +- .../closed-type-family/multi-line-out.hs | 12 +- default.nix | 24 ++++ nix/nixpkgs/default.nix | 8 ++ ormolu.cabal | 8 +- src/Ormolu/Imports.hs | 23 ++-- src/Ormolu/Printer/Combinators.hs | 4 +- src/Ormolu/Printer/Comments.hs | 12 +- src/Ormolu/Printer/Meat/Declaration.hs | 8 +- src/Ormolu/Printer/Meat/Declaration/Data.hs | 126 ++++++++++++------ src/Ormolu/Printer/Meat/Declaration/Pat.hs | 28 ++-- .../Printer/Meat/Declaration/Signature.hs | 3 +- .../Printer/Meat/Declaration/TypeFamily.hs | 32 +++-- src/Ormolu/Printer/Meat/Declaration/Value.hs | 76 ++++++----- src/Ormolu/Printer/Meat/ImportExport.hs | 30 +++-- src/Ormolu/Printer/Meat/Module.hs | 2 +- src/Ormolu/Printer/Meat/Type.hs | 124 +++++++++-------- 24 files changed, 343 insertions(+), 249 deletions(-) create mode 100644 default.nix create mode 100644 nix/nixpkgs/default.nix diff --git a/.circleci/config.yml b/.circleci/config.yml index 14541e9..96d2886 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,34 +1,31 @@ version: 2 + jobs: - build: + build_ghc864: docker: - - image: mrkkrp/haskell-ghc-8.4.4:0.1.0 + - image: nixos/nix:2.1.3 steps: - checkout - - restore_cache: - keys: - - cabal-packages-{{ checksum "ormolu.cabal" }} - - cabal-packages- - - restore_cache: - keys: - - cabal-store-{{ checksum "ormolu.cabal" }} - - cabal-store- - - run: cabal --version - - run: ghc --version - - run: cabal update - - run: cabal new-build --enable-tests --flags=dev - - run: cabal new-test --enable-tests --flags=dev - - run: cabal new-haddock - - run: cabal new-sdist - - save_cache: - key: cabal-packages-{{ checksum "ormolu.cabal" }} - paths: "~/.cabal/packages" - - save_cache: - key: cabal-store-{{ checksum "ormolu.cabal" }} - paths: "~/.cabal/store" + - run: + name: Setup Cachix + command: | + nix-env -f nix/nixpkgs/ -iA cachix + USER=dummy cachix use tweag + - run: + name: Build environment + command: | + nix-shell --pure --run : + - run: + name: Push Cachix + command: | + nix-store -qR --include-outputs $(nix-instantiate default.nix) | cachix push tweag + - run: + name: Build the package (includes running the tests) + command: nix-build workflows: version: 2 build: jobs: - - build + - build_ghc864: + context: org-global diff --git a/data/examples/declaration/data/deriving-strategies-out.hs b/data/examples/declaration/data/deriving-strategies-out.hs index 19bce31..b07cf58 100644 --- a/data/examples/declaration/data/deriving-strategies-out.hs +++ b/data/examples/declaration/data/deriving-strategies-out.hs @@ -5,4 +5,8 @@ newtype Foo = Foo Int ( ToJSON , FromJSON ) - deriving newtype (Num) + deriving newtype Num + deriving Monoid via (Sum Int) + deriving + Semigroup + via (Sum Int) diff --git a/data/examples/declaration/data/deriving-strategies.hs b/data/examples/declaration/data/deriving-strategies.hs index 99c16b1..6dc836a 100644 --- a/data/examples/declaration/data/deriving-strategies.hs +++ b/data/examples/declaration/data/deriving-strategies.hs @@ -7,3 +7,6 @@ newtype Foo = Foo Int , FromJSON ) deriving newtype (Num) + deriving Monoid via (Sum Int) + deriving Semigroup + via (Sum Int) diff --git a/data/examples/declaration/data/gadt/multiline-out.hs b/data/examples/declaration/data/gadt/multiline-out.hs index 79c55f3..2d3e213 100644 --- a/data/examples/declaration/data/gadt/multiline-out.hs +++ b/data/examples/declaration/data/gadt/multiline-out.hs @@ -5,8 +5,8 @@ data Foo a where -- | 'Foo' is wonderful. Foo :: forall a b. (Show a, Eq b) -- foo - => -- bar - a + -- bar + => a -> b -> Foo 'Int -- | But 'Bar' is also not too bad. diff --git a/data/examples/declaration/data/multiline-arg-parens-out.hs b/data/examples/declaration/data/multiline-arg-parens-out.hs index ec6a65f..99bc87f 100644 --- a/data/examples/declaration/data/multiline-arg-parens-out.hs +++ b/data/examples/declaration/data/multiline-arg-parens-out.hs @@ -3,6 +3,6 @@ data Foo = Foo Bar (Set Baz) -- and here we go - -- and that's it + -- and that's it Text - deriving (Eq) + deriving Eq diff --git a/data/examples/declaration/data/multiline-out.hs b/data/examples/declaration/data/multiline-out.hs index 26ed2ca..8d9f852 100644 --- a/data/examples/declaration/data/multiline-out.hs +++ b/data/examples/declaration/data/multiline-out.hs @@ -3,4 +3,5 @@ data Foo = Foo -- ^ One | Bar Int -- ^ Two | Baz -- ^ Three - deriving (Eq, Show) + deriving + (Eq, Show) diff --git a/data/examples/declaration/data/multiline.hs b/data/examples/declaration/data/multiline.hs index 9ec71bd..8b843bb 100644 --- a/data/examples/declaration/data/multiline.hs +++ b/data/examples/declaration/data/multiline.hs @@ -4,4 +4,5 @@ data Foo = Foo -- ^ One | Bar Int -- ^ Two | Baz -- ^ Three - deriving (Eq, Show) + deriving + (Eq, Show) diff --git a/data/examples/declaration/data/simple-broken-out.hs b/data/examples/declaration/data/simple-broken-out.hs index 412c384..49c91d3 100644 --- a/data/examples/declaration/data/simple-broken-out.hs +++ b/data/examples/declaration/data/simple-broken-out.hs @@ -1,8 +1,8 @@ -- | Here we go. data Foo = Foo {unFoo :: Int} - deriving (Eq) + deriving Eq -- | And once again. data Bar = Bar {unBar :: Int} - deriving (Eq) + deriving Eq diff --git a/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs b/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs index 5ca5474..2b22702 100644 --- a/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs +++ b/data/examples/declaration/type-families/closed-type-family/multi-line-out.hs @@ -1,16 +1,16 @@ type family Id a = result | result -> a where - Id a - = a + Id a = + a type family G (a :: k) b c = foo | foo -> k b where - G a b c - = (a, b) + G a b c = + (a, b) type family F a :: * -> * where F Int = Double - F Bool - = Char + F Bool = + Char F a = String diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..d60bf8e --- /dev/null +++ b/default.nix @@ -0,0 +1,24 @@ +let pkgs = import ./nix/nixpkgs; + compiler = "ghc864"; + sourceRegex = [ + "^app.*$" + "^data.*$" + "^ormolu.cabal$" + "^src.*$" + "^tests.*$" + "^.*\.md$" + ]; + haskellPackages = pkgs.haskell.packages.${compiler}.override + { overrides = (self: super: + super // + { "ormolu" = super.callCabal2nix "ormolu" (pkgs.lib.sourceByRegex ./. sourceRegex) {}; + }); + }; +in if pkgs.lib.inNixShell + then haskellPackages.shellFor + { packages = (ps: [ ps.ormolu ]); + buildInputs = [ + pkgs.cabal-install + ]; + } + else haskellPackages.ormolu diff --git a/nix/nixpkgs/default.nix b/nix/nixpkgs/default.nix new file mode 100644 index 0000000..16dba35 --- /dev/null +++ b/nix/nixpkgs/default.nix @@ -0,0 +1,8 @@ +let + rev = "f52505fac8c82716872a616c501ad9eff188f97f"; + sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; + pkgs = import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + inherit sha256; + }) { config.allowUnfree = true; }; +in pkgs diff --git a/ormolu.cabal b/ormolu.cabal index 0f3705b..415ec69 100644 --- a/ormolu.cabal +++ b/ormolu.cabal @@ -1,7 +1,7 @@ name: ormolu version: 0.0.1.0 cabal-version: 1.18 -tested-with: GHC==8.4.4 +tested-with: GHC==8.6.4 license: BSD3 license-file: LICENSE.md maintainer: Mark Karpov @@ -35,7 +35,7 @@ flag dev library hs-source-dirs: src - build-depends: base >= 4.8 && < 5.0 + build-depends: base >= 4.12 && < 5.0 , containers >= 0.5 && < 0.7 , dlist >= 0.8 && < 0.9 , exceptions >= 0.6 && < 0.11 @@ -84,7 +84,7 @@ test-suite tests main-is: Spec.hs hs-source-dirs: tests type: exitcode-stdio-1.0 - build-depends: base >= 4.8 && < 5.0 + build-depends: base >= 4.12 && < 5.0 , containers >= 0.5 && < 0.7 , filepath >= 1.2 && < 1.5 , hspec >= 2.0 && < 3.0 @@ -106,7 +106,7 @@ test-suite tests executable ormolu main-is: Main.hs hs-source-dirs: app - build-depends: base >= 4.8 && < 5.0 + build-depends: base >= 4.12 && < 5.0 , ghc >= 8.4.3 , gitrev >= 1.3 && < 1.4 , optparse-applicative >= 0.14 && < 0.15 diff --git a/src/Ormolu/Imports.hs b/src/Ormolu/Imports.hs index 42c95de..b33176c 100644 --- a/src/Ormolu/Imports.hs +++ b/src/Ormolu/Imports.hs @@ -14,7 +14,7 @@ import Data.List (sortBy) import GHC hiding (GhcPs, IE) import HsExtension import HsImpExp (IE (..)) -import Ormolu.Utils (unL) +import Ormolu.Utils (unL, notImplemented) -- | Sort imports by module name. This also sorts explicit import lists for -- each declaration. @@ -50,8 +50,8 @@ sortLies = sortBy (compareIE `on` unL) . fmap (fmap sortThings) sortThings :: IE GhcPs -> IE GhcPs sortThings = \case - IEThingWith x w xs fl -> - IEThingWith x w (sortBy (compareIewn `on` unL) xs) fl + IEThingWith NoExt x w xs fl -> + IEThingWith NoExt x w (sortBy (compareIewn `on` unL) xs) fl other -> other -- | Compare two located imports or exports. @@ -63,14 +63,15 @@ compareIE = compareIewn `on` getIewn getIewn :: IE GhcPs -> IEWrappedName RdrName getIewn = \case - IEVar x -> unL x - IEThingAbs x -> unL x - IEThingAll x -> unL x - IEThingWith x _ _ _ -> unL x - IEModuleContents _ -> error "Ormolu.Imports.projectName: IEModuleContents" - IEGroup _ _ -> error "Ormolu.Imports.projectName: IEGroup" - IEDoc _ -> error "Ormolu.Imports.projectName: IEGroup" - IEDocNamed _ -> error "Ormolu.Imports.projectName: IEGroup" + IEVar NoExt x -> unL x + IEThingAbs NoExt x -> unL x + IEThingAll NoExt x -> unL x + IEThingWith NoExt x _ _ _ -> unL x + IEModuleContents NoExt _ -> notImplemented "IEModuleContents" + IEGroup NoExt _ _ -> notImplemented "IEGroup" + IEDoc NoExt _ -> notImplemented "IEDoc" + IEDocNamed NoExt _ -> notImplemented "IEDocNamed" + XIE NoExt -> notImplemented "XIE" -- | Compare two @'IEWrapppedName' 'RdrName'@ things. diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs index 36dd405..4761da7 100644 --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -162,9 +162,7 @@ velt xs = sequence_ (intersperse sep (sitcc <$> xs)) -- line. velt' :: [R ()] -> R () -velt' xs = sitcc $ sequence_ (intersperse sep (sitcc <$> xs)) - where - sep = vlayout (spit " ") newline +velt' xs = sitcc $ sequence_ (intersperse breakpoint (sitcc <$> xs)) -- | Put separator between renderings of items of a list. diff --git a/src/Ormolu/Printer/Comments.hs b/src/Ormolu/Printer/Comments.hs index dd8c659..d9856bb 100644 --- a/src/Ormolu/Printer/Comments.hs +++ b/src/Ormolu/Printer/Comments.hs @@ -167,7 +167,10 @@ commentFollowsElt -> Bool commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) = -- A comment follows a AST element if all 4 conditions are satisfied: - goesAfter && logicallyFollows && noEltBetween && supersedesParentElt + goesAfter + && logicallyFollows + && noEltBetween + && (continuation || supersedesParentElt) where -- 1) The comment starts after end of the AST element: goesAfter = @@ -176,20 +179,22 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) = logicallyFollows = theSameLine l ref -- a) it's on the same line || isPrevHaddock comment -- b) it's a Haddock string starting with -- ^ - || isJust mlastSpn -- c) it's a continuation of a comment block + || continuation -- c) it's a continuation of a comment block -- 3) There is no other AST element between this element and the comment: noEltBetween = case mnSpn of Nothing -> True Just nspn -> realSrcSpanStart nspn >= realSrcSpanEnd l - -- Less obvious: if column of comment is closer to the start of + -- 4) Less obvious: if column of comment is closer to the start of -- enclosing element, it probably related to that parent element, not to -- the current child element. This rule is important because otherwise -- all comments would end up assigned to closest inner elements, and -- parent elements won't have a chance to get any comments assigned to -- them. This is not OK because comments will get indented according to -- the AST elements they are attached to. + -- + -- Skip this rule if the comment is a continuation of a comment block. supersedesParentElt = case meSpn of Nothing -> True @@ -197,6 +202,7 @@ commentFollowsElt ref mnSpn meSpn mlastSpn (L l comment) = let startColumn = srcLocCol . realSrcSpanStart in abs (startColumn espn - startColumn l) > abs (startColumn ref - startColumn l) + continuation = isJust mlastSpn -- | Output a 'Comment'. This is a low-level printing function. diff --git a/src/Ormolu/Printer/Meat/Declaration.hs b/src/Ormolu/Printer/Meat/Declaration.hs index 0db34df..e83201f 100644 --- a/src/Ormolu/Printer/Meat/Declaration.hs +++ b/src/Ormolu/Printer/Meat/Declaration.hs @@ -19,14 +19,14 @@ import Ormolu.Utils p_hsDecl :: HsDecl GhcPs -> R () p_hsDecl = \case - TyClD x -> p_tyClDecl x - ValD x -> p_valDecl x - SigD x -> p_sigDecl x + TyClD NoExt x -> p_tyClDecl x + ValD NoExt x -> p_valDecl x + SigD NoExt x -> p_sigDecl x _ -> notImplemented "certain kinds of declarations" p_tyClDecl :: TyClDecl GhcPs -> R () p_tyClDecl = \case - FamDecl x -> p_famDecl x + FamDecl NoExt x -> p_famDecl x SynDecl {..} -> p_synDecl tcdLName tcdTyVars tcdRhs DataDecl {..} -> p_dataDecl tcdLName tcdTyVars tcdDataDefn _ -> notImplemented "certain kinds of declarations" diff --git a/src/Ormolu/Printer/Meat/Declaration/Data.hs b/src/Ormolu/Printer/Meat/Declaration/Data.hs index 6aba1b7..b6182f0 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Data.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Data.hs @@ -9,7 +9,6 @@ module Ormolu.Printer.Meat.Declaration.Data ) where -import BasicTypes (DerivStrategy (..)) import Control.Monad import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (isJust) @@ -17,7 +16,7 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type -import Ormolu.Utils (unL, getSpan, combineSrcSpans') +import Ormolu.Utils import RdrName (RdrName (..)) import SrcLoc (Located) @@ -55,32 +54,34 @@ p_dataDecl name tvars HsDataDefn {..} = do newline inci . located dd_derivs $ \xs -> forM_ xs (line . located' p_hsDerivingClause) +p_dataDecl _ _ (XHsDataDefn NoExt) = notImplemented "XHsDataDefn" p_conDecl :: ConDecl GhcPs -> R () p_conDecl = \case - ConDeclGADT {..} -> velt' - [ spaceSep (located' p_rdrName) con_names - , inci $ do - txt ":: " - locatedVia Nothing (hsib_body con_type) p_hsType - ] + ConDeclGADT {..} -> do + spaceSep (located' p_rdrName) con_names + breakpoint + inci $ do + txt ":: " + p_forallBndrs (hsq_explicit con_qvars) + forM_ con_mb_cxt p_lhsContext + case con_args of + PrefixCon xs -> do + velt' (located' p_hsType <$> xs) + unless (null xs) $ do + breakpoint + txt "-> " + RecCon l -> do + located l p_conDeclFields + unless (null $ unL l) $ do + breakpoint + txt "-> " + InfixCon _ _ -> notImplemented "InfixCon" + locatedVia Nothing con_res_ty p_hsType ConDeclH98 {..} -> do - case hsq_explicit <$> con_qvars of - Nothing -> return () - Just bndrs -> do - txt "forall " - spaceSep (located' p_hsTyVarBndr) bndrs - txt "." - breakpoint - case con_cxt of - Nothing -> return () - Just ctx -> located ctx $ \case - [] -> pure () - xs -> do - p_hsContext xs - breakpoint - txt "=> " - case con_details of + p_forallBndrs con_ex_tvs + forM_ con_mb_cxt p_lhsContext + case con_args of PrefixCon xs -> do located con_name p_rdrName unless (null xs) breakpoint @@ -89,33 +90,74 @@ p_conDecl = \case located con_name p_rdrName breakpoint inci $ located l p_conDeclFields - InfixCon x y -> velt' - [ located x p_hsType - , inci $ velt' - [ backticks (located con_name p_rdrName) - , inci $ located y p_hsType - ] - ] + InfixCon x y -> do + located x p_hsType + breakpoint + inci $ do + backticks (located con_name p_rdrName) + breakpoint + inci (located y p_hsType) + XConDecl NoExt -> notImplemented "XConDecl" + +p_forallBndrs + :: [LHsTyVarBndr GhcPs] + -> R () +p_forallBndrs = \case + [] -> return () + bndrs -> do + txt "forall " + spaceSep (located' p_hsTyVarBndr) bndrs + txt ". " + +p_lhsContext + :: LHsContext GhcPs + -> R () +p_lhsContext = \case + L _ [] -> pure () + ctx -> do + located ctx p_hsContext + breakpoint + txt "=> " isGadt :: ConDecl GhcPs -> Bool isGadt = \case ConDeclGADT {} -> True ConDeclH98 {} -> False + XConDecl {} -> False p_hsDerivingClause :: HsDerivingClause GhcPs -> R () p_hsDerivingClause HsDerivingClause {..} = do txt "deriving" + let derivingWhat = located deriv_clause_tys $ \case + [] -> txt "()" + [x] -> located (hsib_body x) p_hsType + xs -> parens . velt $ withSep comma (located' p_hsType . hsib_body) xs case deriv_clause_strategy of - Nothing -> return () - Just l -> do - space - located l $ \case - StockStrategy -> txt "stock" - AnyclassStrategy -> txt "anyclass" - NewtypeStrategy -> txt "newtype" - breakpoint - inci . located deriv_clause_tys $ \case - [] -> txt "()" - xs -> parens . velt $ withSep comma (located' p_hsType . hsib_body) xs + Nothing -> do + breakpoint + inci derivingWhat + Just l -> locatedVia Nothing l $ \case + StockStrategy -> do + txt " stock" + breakpoint + inci derivingWhat + AnyclassStrategy -> do + txt " anyclass" + breakpoint + inci derivingWhat + NewtypeStrategy -> do + txt " newtype" + breakpoint + inci derivingWhat + ViaStrategy HsIB {..} -> do + breakpoint + inci $ do + derivingWhat + breakpoint + txt "via " + located hsib_body p_hsType + ViaStrategy (XHsImplicitBndrs NoExt) -> + notImplemented "XHsImplicitBndrs" +p_hsDerivingClause (XHsDerivingClause NoExt) = notImplemented "XHsDerivingClause" diff --git a/src/Ormolu/Printer/Meat/Declaration/Pat.hs b/src/Ormolu/Printer/Meat/Declaration/Pat.hs index 53df8a5..ddffbe4 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Pat.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Pat.hs @@ -16,33 +16,31 @@ import Ormolu.Utils p_pat :: Pat GhcPs -> R () p_pat = \case - WildPat _ -> txt "_" - VarPat name -> located name p_rdrName - LazyPat pat -> do + WildPat NoExt -> txt "_" + VarPat NoExt name -> located name p_rdrName + LazyPat NoExt pat -> do txt "~" located pat p_pat - AsPat name pat -> do + AsPat NoExt name pat -> do located name p_rdrName txt "@" located pat p_pat - ParPat pat -> + ParPat NoExt pat -> located pat (parens . p_pat) - BangPat pat -> do + BangPat NoExt pat -> do txt "!" located pat p_pat - ListPat pats _ _ -> do + ListPat NoExt pats -> do brackets $ velt (withSep comma (located' p_pat) pats) - TuplePat pats boxing _ -> do + TuplePat NoExt pats boxing -> do let f = case boxing of Boxed -> parens Unboxed -> parensHash f $ velt (withSep comma (located' p_pat) pats) - SumPat pat _ _ _ -> do + SumPat NoExt pat _ _ -> do -- XXX I'm not sure about this one. located pat p_pat - PArrPat pats _ -> do - bracketsPar $ velt (withSep comma (located' p_pat) pats) ConPatIn pat details -> case details of PrefixCon xs -> do @@ -63,12 +61,12 @@ p_pat = \case ConPatOut {} -> notImplemented "ConPatOut" ViewPat {} -> notImplemented "ViewPat" SplicePat {} -> notImplemented "SplicePat" - LitPat p -> atom p - NPat v _ _ _ -> located v (atom . ol_val) + LitPat NoExt p -> atom p + NPat NoExt v _ _ -> located v (atom . ol_val) NPlusKPat {} -> notImplemented "NPlusKPat" - SigPatIn {} -> notImplemented "SigPatIn" - SigPatOut {} -> notImplemented "SigPatOut" + SigPat {} -> notImplemented "SigPat" CoPat {} -> notImplemented "CoPat" + XPat NoExt -> notImplemented "XPat" p_hsRecField :: HsRecField' (FieldOcc GhcPs) (LPat GhcPs) -> R () p_hsRecField HsRecField {..} = diff --git a/src/Ormolu/Printer/Meat/Declaration/Signature.hs b/src/Ormolu/Printer/Meat/Declaration/Signature.hs index e91ba1f..a135684 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Signature.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Signature.hs @@ -21,7 +21,7 @@ p_sigDecl = line . p_sigDecl' p_sigDecl' :: Sig GhcPs -> R () p_sigDecl' = \case - TypeSig names hswc -> p_typeSig names hswc + TypeSig NoExt names hswc -> p_typeSig names hswc _ -> notImplemented "certain types of signature declarations" p_typeSig @@ -34,3 +34,4 @@ p_typeSig names HsWC {..} = do inci $ do txt ":: " located (hsib_body hswc_body) p_hsType +p_typeSig _ (XHsWildCardBndrs NoExt) = notImplemented "XHsWildCardBndrs" diff --git a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs index d0d3f95..75c0811 100644 --- a/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs +++ b/src/Ormolu/Printer/Meat/Declaration/TypeFamily.hs @@ -15,6 +15,7 @@ import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common import Ormolu.Printer.Meat.Type +import Ormolu.Utils import SrcLoc (Located, GenLocated (..)) p_famDecl :: FamilyDecl GhcPs -> R () @@ -42,18 +43,24 @@ p_famDecl FamilyDecl {..} = do Just eqs -> do newline forM_ eqs (located' (line . inci . p_tyFamInstEqn)) +p_famDecl (XFamilyDecl NoExt) = notImplemented "XFamilyDecl" -p_familyResultSigL :: Bool -> Located (FamilyResultSig GhcPs) -> Maybe (R ()) +p_familyResultSigL + :: Bool + -> Located (FamilyResultSig GhcPs) + -> Maybe (R ()) p_familyResultSigL injAnn l = case l of L _ a -> case a of - NoSig -> Nothing - KindSig k -> Just $ do + NoSig NoExt -> Nothing + KindSig NoExt k -> Just $ do if injAnn then txt "= " else txt ":: " located k p_hsType - TyVarSig bndr -> Just $ do + TyVarSig NoExt bndr -> Just $ do if injAnn then txt "= " else txt ":: " located bndr p_hsTyVarBndr + XFamilyResultSig NoExt -> + notImplemented "XFamilyResultSig" p_injectivityAnn :: InjectivityAnn GhcPs -> R () p_injectivityAnn (InjectivityAnn a bs) = do @@ -64,11 +71,12 @@ p_injectivityAnn (InjectivityAnn a bs) = do spaceSep (located' p_rdrName) bs p_tyFamInstEqn :: TyFamInstEqn GhcPs -> R () -p_tyFamInstEqn HsIB {..} = velt' - [ do located feqn_tycon p_rdrName - space - spaceSep (located' p_hsType) feqn_pats - , inci $ txt "= " >> inci (located feqn_rhs p_hsType) - ] - where - FamEqn {..} = hsib_body +p_tyFamInstEqn HsIB {..} = do + let FamEqn {..} = hsib_body + located feqn_tycon p_rdrName + space + spaceSep (located' p_hsType) feqn_pats + txt " =" + breakpoint + inci (located feqn_rhs p_hsType) +p_tyFamInstEqn (XHsImplicitBndrs NoExt) = notImplemented "XHsImplicitBndrs" diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs index 2dd6c84..f54c081 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -25,7 +25,7 @@ p_valDecl = line . p_valDecl' p_valDecl' :: HsBindLR GhcPs GhcPs -> R () p_valDecl' = \case - FunBind funId funMatches _ _ _ -> p_funBind funId funMatches + FunBind NoExt funId funMatches _ _ -> p_funBind funId funMatches _ -> notImplemented "certain kinds of binding declarations" p_funBind @@ -48,6 +48,7 @@ p_matchGroup p_matchGroup style MG {..} = locatedVia Nothing mg_alts $ newlineSep (located' (p_match style)) +p_matchGroup _ (XMatchGroup NoExt) = notImplemented "XMatchGroup" p_match :: MatchGroupStyle @@ -97,13 +98,14 @@ p_match style Match {..} = do Lambda -> return () _ -> breakpoint newlineSep (located' p_grhs) grhssGRHSs - unless (GHC.isEmptyLocalBinds (unL grhssLocalBinds)) $ do + unless (GHC.isEmptyLocalBindsPR (unL grhssLocalBinds)) $ do newline line (txt "where") inci (located grhssLocalBinds p_hsLocalBinds) +p_match _ (XMatch NoExt) = notImplemented "XMatchGroup" p_grhs :: GRHS GhcPs (LHsExpr GhcPs) -> R () -p_grhs (GRHS guards body) = +p_grhs (GRHS NoExt guards body) = case guards of [] -> p_body xs -> do @@ -114,21 +116,23 @@ p_grhs (GRHS guards body) = inci p_body where p_body = located body p_hsExpr +p_grhs (XGRHS NoExt) = notImplemented "XGRHS" p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R () p_stmt = \case LastStmt {} -> notImplemented "do notation" BindStmt {} -> notImplemented "do notation" ApplicativeStmt {} -> notImplemented "applicative stmt" - BodyStmt body _ _ _ -> located body p_hsExpr - LetStmt binds -> located binds p_hsLocalBinds + BodyStmt NoExt body _ _ -> located body p_hsExpr + LetStmt NoExt binds -> located binds p_hsLocalBinds ParStmt {} -> notImplemented "ParStmt" TransStmt {} -> notImplemented "TransStmt" RecStmt {} -> notImplemented "RecStmt" + XStmtLR {} -> notImplemented "XStmtLR" p_hsLocalBinds :: HsLocalBindsLR GhcPs GhcPs -> R () p_hsLocalBinds = \case - HsValBinds (ValBindsIn bag lsigs) -> do + HsValBinds NoExt (ValBinds NoExt bag lsigs) -> do let ssStart = either (srcSpanStart . getSpan) (srcSpanStart . getSpan) @@ -137,62 +141,63 @@ p_hsLocalBinds = \case p_item (Left x) = located x p_valDecl' p_item (Right x) = located x p_sigDecl' newlineSep p_item (sortOn ssStart items) - HsValBinds _ -> notImplemented "HsValBinds" - HsIPBinds _ -> notImplemented "HsIPBinds" - EmptyLocalBinds -> return () + HsValBinds NoExt _ -> notImplemented "HsValBinds" + HsIPBinds NoExt _ -> notImplemented "HsIPBinds" + EmptyLocalBinds NoExt -> return () + XHsLocalBindsLR _ -> notImplemented "XHsLocalBindsLR" p_hsExpr :: HsExpr GhcPs -> R () p_hsExpr = \case - HsVar name -> located name p_rdrName' - HsUnboundVar _ -> notImplemented "HsUnboundVar" - HsConLikeOut _ -> notImplemented "HsConLikeOut" - HsRecFld x -> + HsVar NoExt name -> located name p_rdrName' + HsUnboundVar NoExt _ -> notImplemented "HsUnboundVar" + HsConLikeOut NoExt _ -> notImplemented "HsConLikeOut" + HsRecFld NoExt x -> case x of - Unambiguous name _ -> located name p_rdrName' - Ambiguous name _ -> located name p_rdrName' - HsOverLabel _ _ -> notImplemented "HsOverLabel" - HsIPVar (HsIPName name) -> atom name - HsOverLit v -> atom (ol_val v) - HsLit lit -> atom lit - HsLam mgroup -> + Unambiguous NoExt name -> located name p_rdrName' + Ambiguous NoExt name -> located name p_rdrName' + XAmbiguousFieldOcc NoExt -> notImplemented "XAmbiguousFieldOcc" + HsOverLabel NoExt _ _ -> notImplemented "HsOverLabel" + HsIPVar NoExt (HsIPName name) -> atom name + HsOverLit NoExt v -> atom (ol_val v) + HsLit NoExt lit -> atom lit + HsLam NoExt mgroup -> p_matchGroup Lambda mgroup - HsLamCase mgroup -> do + HsLamCase NoExt mgroup -> do txt "\\case" newline inci (p_matchGroup LambdaCase mgroup) - HsApp f x -> do + HsApp NoExt f x -> do located f p_hsExpr breakpoint inci (located x p_hsExpr) HsAppType a e -> do - located a p_hsExpr + located e p_hsExpr breakpoint inci $ do txt "@" - located (hswc_body e) p_hsType - HsAppTypeOut {} -> notImplemented "HsAppTypeOut" - OpApp x op _ y -> do + located (hswc_body a) p_hsType + OpApp NoExt x op y -> do located x p_hsExpr breakpoint inci $ do located op p_hsExpr space located y p_hsExpr - NegApp e _ -> do + NegApp NoExt e _ -> do txt "-" located e p_hsExpr - HsPar e -> parens (located e p_hsExpr) + HsPar NoExt e -> parens (located e p_hsExpr) SectionL {} -> notImplemented "SectionL" SectionR {} -> notImplemented "SectionR" ExplicitTuple {} -> notImplemented "ExplicitTuple" ExplicitSum {} -> notImplemented "ExplicitSum" - HsCase e mgroup -> do + HsCase NoExt e mgroup -> do txt "case " located e p_hsExpr txt " of" breakpoint inci (p_matchGroup Case mgroup) - HsIf _ if' then' else' -> do + HsIf NoExt _ if' then' else' -> do txt "if " located if' p_hsExpr breakpoint @@ -206,7 +211,7 @@ p_hsExpr = \case breakpoint inci (p_hsExpr x) HsMultiIf {} -> notImplemented "MulitiIf" - HsLet localBinds e -> do + HsLet NoExt localBinds e -> do txt "let " sitcc (located localBinds p_hsLocalBinds) breakpoint @@ -215,13 +220,10 @@ p_hsExpr = \case HsDo {} -> notImplemented "HsDo" ExplicitList _ _ xs -> do brackets $ velt (withSep comma (located' p_hsExpr) xs) - ExplicitPArr {} -> notImplemented "ExplicitPArr" RecordCon {} -> notImplemented "RecordCon" RecordUpd {} -> notImplemented "RecordUpd" ExprWithTySig {} -> notImplemented "ExprWithTySig" - ExprWithTySigOut {} -> notImplemented "ExprWithTySigOut" ArithSeq {} -> notImplemented "ArithSeq" - PArrSeq {} -> notImplemented "PArrSeq" HsSCC {} -> notImplemented "HsSCC" HsCoreAnn {} -> notImplemented "HsCoreAnn" HsBracket {} -> notImplemented "HsBracket" @@ -238,14 +240,16 @@ p_hsExpr = \case HsTick {} -> notImplemented "HsTick" HsBinTick {} -> notImplemented "HsBinTick" HsTickPragma {} -> notImplemented "HsTickPragma" - EWildPat -> notImplemented "EWildPat" + EWildPat NoExt -> notImplemented "EWildPat" EAsPat {} -> notImplemented "EAsPat" EViewPat {} -> notImplemented "EViewPat" ELazyPat {} -> notImplemented "ELazyPat" HsWrap {} -> notImplemented "HsWrap" + XExpr {} -> notImplemented "XExpr" ---------------------------------------------------------------------------- -- Helpers getGRHSSpan :: GRHS GhcPs (LHsExpr GhcPs) -> SrcSpan -getGRHSSpan (GRHS _ body) = getSpan body +getGRHSSpan (GRHS NoExt _ body) = getSpan body +getGRHSSpan (XGRHS NoExt) = notImplemented "XGRHS" diff --git a/src/Ormolu/Printer/Meat/ImportExport.hs b/src/Ormolu/Printer/Meat/ImportExport.hs index 1d02edf..faa7b05 100644 --- a/src/Ormolu/Printer/Meat/ImportExport.hs +++ b/src/Ormolu/Printer/Meat/ImportExport.hs @@ -15,6 +15,7 @@ import GHC import HsImpExp (IE (..)) import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Utils p_hsmodExports :: [LIE GhcPs] -> R () p_hsmodExports xs = do @@ -51,24 +52,25 @@ p_hsmodImport ImportDecl {..} = line $ do breakpoint inci . locatedVia Nothing l $ parens . velt . withSep comma (located' p_lie) +p_hsmodImport (XImportDecl NoExt) = notImplemented "XImportDecl" p_lie :: IE GhcPs -> R () p_lie = \case - IEVar l1 -> located l1 p_ieWrappedName - IEThingAbs l1 -> located l1 p_ieWrappedName - IEThingAll l1 -> do + IEVar NoExt l1 -> located l1 p_ieWrappedName + IEThingAbs NoExt l1 -> located l1 p_ieWrappedName + IEThingAll NoExt l1 -> do located l1 p_ieWrappedName txt " (..)" - IEThingWith l1 w xs _ -> velt' - [ located l1 p_ieWrappedName - , inci $ do - p_ieWildcard w - parens . velt $ withSep comma (located' p_ieWrappedName) xs - ] + IEThingWith NoExt l1 w xs _ -> sitcc $ do + located l1 p_ieWrappedName + breakpoint -- XXX I have no idea what field labels are in this context. - -- parens . velt $ withSep comma (located' p_FieldLbl) fls - IEModuleContents l1 -> located l1 p_hsmodName + inci $ do + p_ieWildcard w + parens . velt $ withSep comma (located' p_ieWrappedName) xs + IEModuleContents NoExt l1 -> located l1 p_hsmodName -- XXX I have no idea what these things are for. - IEGroup _ _ -> return () - IEDoc _ -> return () - IEDocNamed _ -> return () + IEGroup NoExt _ _ -> return () + IEDoc NoExt _ -> return () + IEDocNamed NoExt _ -> return () + XIE NoExt -> notImplemented "XIE" diff --git a/src/Ormolu/Printer/Meat/Module.hs b/src/Ormolu/Printer/Meat/Module.hs index a5e38dc..2a3345b 100644 --- a/src/Ormolu/Printer/Meat/Module.hs +++ b/src/Ormolu/Printer/Meat/Module.hs @@ -64,6 +64,6 @@ separatedDecls :: HsDecl GhcPs -> HsDecl GhcPs -> Bool -separatedDecls (SigD (TypeSig (n:_) _)) (ValD (FunBind n' _ _ _ _)) = +separatedDecls (SigD NoExt (TypeSig NoExt (n:_) _)) (ValD NoExt (FunBind NoExt n' _ _ _)) = unL n /= unL n' separatedDecls _ _ = True diff --git a/src/Ormolu/Printer/Meat/Type.hs b/src/Ormolu/Printer/Meat/Type.hs index 4c84b8b..3d4515c 100644 --- a/src/Ormolu/Printer/Meat/Type.hs +++ b/src/Ormolu/Printer/Meat/Type.hs @@ -15,33 +15,30 @@ where import GHC import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common +import Ormolu.Utils p_hsType :: HsType GhcPs -> R () p_hsType = \case - HsForAllTy bndrs t -> do + HsForAllTy NoExt bndrs t -> do txt "forall " spaceSep (located' p_hsTyVarBndr) bndrs txt ". " locatedVia Nothing t p_hsType - HsQualTy qs t -> do + HsQualTy NoExt qs t -> do located qs p_hsContext breakpoint txt "=> " locatedVia Nothing t p_hsType - HsTyVar p n -> do + HsTyVar NoExt p n -> do case p of Promoted -> txt "'" NotPromoted -> return () - located n p_rdrName - HsAppsTy apps -> - velt' $ case apps of - [] -> [] - (x:xs) -> located' p_hsAppType x : (located' (inci . p_hsAppType) <$> xs) - HsAppTy f x -> velt' - [ located f p_hsType - , inci $ located x p_hsType - ] - HsFunTy f x@(L _ x') -> do + located n p_rdrName' + HsAppTy NoExt f x -> sitcc $ do + located f p_hsType + breakpoint + inci (located x p_hsType) + HsFunTy NoExt f x@(L _ x') -> do located f p_hsType breakpoint txt "-> " @@ -49,9 +46,8 @@ p_hsType = \case HsFunTy{} -> locatedVia Nothing _ -> located located_ x p_hsType - HsListTy t -> located t (brackets . p_hsType) - HsPArrTy t -> located t (bracketsPar . p_hsType) - HsTupleTy tsort xs -> + HsListTy NoExt t -> located t (brackets . p_hsType) + HsTupleTy NoExt tsort xs -> let parens' = case tsort of HsUnboxedTuple -> parensHash @@ -59,29 +55,32 @@ p_hsType = \case HsConstraintTuple -> parens HsBoxedOrConstraintTuple -> parens in parens' . velt $ withSep comma (located' p_hsType) xs - HsSumTy xs -> + HsSumTy NoExt xs -> parensHash . velt $ withSep (txt "| ") (located' p_hsType) xs - HsOpTy x op y -> velt' - [ located x p_hsType - , inci $ located op p_rdrName >> space >> located y p_hsType - ] - HsParTy t -> + HsOpTy NoExt x op y -> do + located x p_hsType + breakpoint + inci $ do + located op p_rdrName' + space + located y p_hsType + HsParTy NoExt t -> parens (located t p_hsType) - HsIParamTy n t -> velt' - [ located n atom - , inci $ txt ":: " >> located t p_hsType - ] - HsEqTy x y -> velt' - [ located x p_hsType - , inci $ txt "~ " >> located y p_hsType - ] - HsKindSig t k -> velt' - [ located t p_hsType - , inci $ txt ":: " >> located k p_hsType - ] + HsIParamTy NoExt n t -> do + located n atom + breakpoint + inci $ do + txt ":: " + located t p_hsType + HsStarTy NoExt _ -> txt "*" + HsKindSig NoExt t k -> do + located t p_hsType + inci $ do + txt ":: " + located k p_hsType HsSpliceTy _ _ -> error "HsSpliceTy" - HsDocTy _ _ -> error "HsDocTy" - HsBangTy (HsSrcBang _ u s) t -> do + HsDocTy NoExt _ _ -> error "HsDocTy" + HsBangTy NoExt (HsSrcBang _ u s) t -> do case u of SrcUnpack -> txt "{-# UNPACK #-} " SrcNoUnpack -> txt "{-# NOUNPACK #-} " @@ -91,19 +90,19 @@ p_hsType = \case SrcStrict -> txt "!" NoSrcStrict -> return () located t p_hsType - HsRecTy fields -> + HsRecTy NoExt fields -> p_conDeclFields fields - HsCoreTy t -> atom t - HsExplicitListTy p _ xs -> do - case p of -- XXX not sure about this one + HsExplicitListTy NoExt p xs -> do + case p of Promoted -> txt "'" NotPromoted -> return () brackets . velt $ withSep comma (located' p_hsType) xs - HsExplicitTupleTy _ xs -> do + HsExplicitTupleTy NoExt xs -> do txt "'" parens . velt $ withSep comma (located' p_hsType) xs - HsTyLit t -> atom t - HsWildCardTy (AnonWildCard PlaceHolder) -> txt "_" + HsTyLit NoExt t -> atom t + HsWildCardTy NoExt -> txt "_" + XHsType (NHsCoreTy t) -> atom t p_hsContext :: HsContext GhcPs -> R () p_hsContext = \case @@ -113,31 +112,28 @@ p_hsContext = \case p_hsTyVarBndr :: HsTyVarBndr GhcPs -> R () p_hsTyVarBndr = \case - UserTyVar l -> + UserTyVar NoExt l -> located l p_rdrName - KindedTyVar l k -> parens $ velt' - [ located l atom - , inci $ txt ":: " >> located k p_hsType - ] - -p_hsAppType :: HsAppType GhcPs -> R () -p_hsAppType = \case - HsAppInfix l -> - located l p_rdrName' - HsAppPrefix l -> - located l p_hsType + KindedTyVar NoExt l k -> parens $ do + located l atom + breakpoint + inci $ do + txt ":: " + located k p_hsType + XTyVarBndr NoExt -> notImplemented "XTyVarBndr" p_conDeclFields :: [LConDeclField GhcPs] -> R () p_conDeclFields = braces . velt . withSep comma (sitcc . located' p_conDeclField) p_conDeclField :: ConDeclField GhcPs -> R () -p_conDeclField ConDeclField {..} = velt' - [ velt $ withSep - comma - (located' (located' p_rdrName . rdrNameFieldOcc)) - cd_fld_names - , inci $ do - txt ":: " - locatedVia Nothing cd_fld_type p_hsType - ] +p_conDeclField ConDeclField {..} = do + sitcc . velt $ withSep + comma + (located' (located' p_rdrName . rdrNameFieldOcc)) + cd_fld_names + breakpoint + sitcc . inci $ do + txt ":: " + locatedVia Nothing cd_fld_type p_hsType +p_conDeclField (XConDeclField NoExt) = notImplemented "XConDeclField"