diff --git a/.travis.yml b/.travis.yml index fc67cae..58a4ab2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -257,8 +257,8 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project - echo 'package brittany' > cabal.project.local - echo ' ghc-options: -Werror -with-rtsopts=-N1' >> cabal.project.local + echo 'package brittany' > cabal.project.local + echo ' ghc-options: -Werror' >> cabal.project.local rm -f cabal.project.freeze cabal new-build -j$JOBS --enable-test --enable-benchmarks --dep cabal new-build -j$JOBS --disable-tests --disable-benchmarks --dep @@ -271,13 +271,13 @@ script: set -ex case "$BUILD" in stack) - better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts=-N1" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror -with-rtsopts -N1" ;; cabal) if [ -f configure.ac ]; then autoreconf -i; fi cabal configure --enable-tests --enable-benchmarks -v # -v2 provides useful information for debugging better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) - time cabal test --ghc-options="-with-rtsopts=-N1" + time cabal test --ghc-options="-with-rtsopts -N1" ;; cabaldist) # cabal check @@ -292,7 +292,7 @@ script: canew) better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --disable-tests --disable-benchmarks better_wait cabal new-build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS" --enable-tests --enable-benchmarks - time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS" + time cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS -with-rtsopts -N1" ;; esac set +ex diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index 1597c4b..83dfc61 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -906,6 +906,99 @@ import qualified Data.List as L -- Test import Test ( test ) + +############################################################################### +############################################################################### +############################################################################### +#group type synonyms +############################################################################### +############################################################################### +############################################################################### + +#test simple-synonym + +type MySynonym = String + +#test parameterised-synonym + +type MySynonym a = [a] + +#test long-function-synonym + +-- | Important comment thrown in +type MySynonym b a + = MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b + +#test overflowing-function-synonym + +type MySynonym3 b a + = MySynonym a b + -> MySynonym a b + -- ^ RandomComment + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-kind-sig + +type MySynonym (a :: * -> *) + = MySynonym a b + -> MySynonym a b + -> MyParamType a b + -> MyParamType a b + -> MySynonym2 b a + +#test synonym-with-constraint + +type MySynonym a = Num a => a -> Int + +#test synonym-overflowing-with-constraint + +type MySynonym a + = Num a + => AReallyLongTypeName + -> AnotherReallyLongTypeName + -> AThirdTypeNameToOverflow + +#test synonym-forall + +{-# LANGUAGE RankNTypes #-} + +type MySynonym = forall a . [a] + +#test synonym-operator + +type (:+:) a b = (a, b) + +#test synonym-infix + +type a `MySynonym` b = a -> b + +#test synonym-infix-operator + +type a :+: b = (a, b) + +#test synonym-infix-parens + +type (a `Foo` b) c = (a, b, c) + +#test synonym-comments + +type Foo a -- fancy type comment + = -- strange comment + Int + +#test synonym-type-operators +#pending + +type (a :+: b) = (a, b) + +#test synonym-multi-parens +#pending + +type ((a :+: b) c) = (a, c) + + ############################################################################### ############################################################################### ############################################################################### diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs index 16a9362..1061f0e 100644 --- a/src/Language/Haskell/Brittany/Internal/Backend.hs +++ b/src/Language/Haskell/Brittany/Internal/Backend.hs @@ -19,6 +19,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Annotate as ExactPrint.Annotate import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Types ( AnnKey, Annotation ) +import GHC ( AnnKeywordId (..) ) + import Language.Haskell.Brittany.Internal.LayouterBasics import Language.Haskell.Brittany.Internal.BackendUtils import Language.Haskell.Brittany.Internal.Utils @@ -170,9 +172,13 @@ layoutBriDocM = \case priors `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP + "(" -> pure () + ")" -> pure () + -- ^ these two fix the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline @@ -241,9 +247,12 @@ layoutBriDocM = \case Just comments -> do comments `forM_` \(ExactPrint.Types.Comment comment _ _, ExactPrint.Types.DP (y, x)) -> do - -- evil hack for CPP: case comment of ('#':_) -> layoutMoveToCommentPos y (-999) + -- ^ evil hack for CPP + ")" -> pure () + -- ^ fixes the formatting of parens + -- on the lhs of type alias defs _ -> layoutMoveToCommentPos y x -- fixedX <- fixMoveToLineByIsNewline x -- replicateM_ fixedX layoutWriteNewline diff --git a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs index a7d8594..0a2792c 100644 --- a/src/Language/Haskell/Brittany/Internal/BackendUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/BackendUtils.hs @@ -188,19 +188,20 @@ layoutMoveToCommentPos y x = do { _lstate_curYOrAddNewline = case _lstate_curYOrAddNewline state of Left i -> if y == 0 then Left i else Right y Right{} -> Right y - , _lstate_addSepSpace = if Data.Maybe.isJust (_lstate_commentCol state) - then Just $ case _lstate_curYOrAddNewline state of - Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x - Right{} -> _lstate_indLevelLinger state + x - else Just $ if y == 0 then x else _lstate_indLevelLinger state + x - , _lstate_commentCol = Just $ case _lstate_commentCol state of - Just existing -> existing - Nothing -> case _lstate_curYOrAddNewline state of - Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) - Right{} -> lstate_baseY state + , _lstate_addSepSpace = + Just $ if Data.Maybe.isJust (_lstate_commentCol state) + then case _lstate_curYOrAddNewline state of + Left{} -> if y == 0 then x else _lstate_indLevelLinger state + x + Right{} -> _lstate_indLevelLinger state + x + else if y == 0 then x else _lstate_indLevelLinger state + x + , _lstate_commentCol = + Just $ case _lstate_commentCol state of + Just existing -> existing + Nothing -> case _lstate_curYOrAddNewline state of + Left i -> i + fromMaybe 0 (_lstate_addSepSpace state) + Right{} -> lstate_baseY state } - -- | does _not_ add spaces to again reach the current base column. layoutWriteNewline :: ( MonadMultiWriter Text.Builder.Builder m diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index bfb129a..458f7ed 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -63,6 +63,8 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , docSharedWrapper , hasAnyCommentsBelow , hasAnyCommentsConnected + , hasAnyCommentsPrior + , hasAnnKeywordComment , hasAnnKeyword ) where @@ -296,18 +298,35 @@ hasAnyCommentsConnected ast = do $ Map.elems $ anns +hasAnyCommentsPrior :: Data ast => GHC.Located ast -> ToBriDocM Bool +hasAnyCommentsPrior ast = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ priors _ _ _ _) -> not $ null priors + +hasAnnKeywordComment + :: Data ast => GHC.Located ast -> AnnKeywordId -> ToBriDocM Bool +hasAnnKeywordComment ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just ann -> any hasK (extractAllComments ann) + where hasK = (== Just annKeyword) . ExactPrint.Types.commentOrigin . fst + hasAnnKeyword :: (Data a, MonadMultiReader (Map AnnKey Annotation) m) => Located a -> AnnKeywordId -> m Bool -hasAnnKeyword ast annKeyword = do - anns <- mAsk - let hasK (ExactPrint.Types.G x, _) = x == annKeyword - hasK _ = False - pure $ case Map.lookup (ExactPrint.Types.mkAnnKey ast) anns of - Nothing -> False - Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks +hasAnnKeyword ast annKeyword = astAnn ast <&> \case + Nothing -> False + Just (ExactPrint.Types.Ann _ _ _ aks _ _) -> any hasK aks + where + hasK (ExactPrint.Types.G x, _) = x == annKeyword + hasK _ = False + +astAnn + :: (Data ast, MonadMultiReader (Map AnnKey Annotation) m) + => GHC.Located ast + -> m (Maybe Annotation) +astAnn ast = Map.lookup (ExactPrint.Types.mkAnnKey ast) <$> mAsk -- new BriDoc stuff diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs index 2ece967..cf7da4f 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs @@ -26,7 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint import Language.Haskell.Brittany.Internal.ExactPrintUtils import Language.Haskell.Brittany.Internal.Utils -import GHC ( runGhc, GenLocated(L), moduleNameString ) +import GHC ( runGhc + , GenLocated(L) + , moduleNameString + , AnnKeywordId (..) + ) import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc ) import HsSyn import Name @@ -34,6 +38,9 @@ import BasicTypes ( InlinePragma(..) , Activation(..) , InlineSpec(..) , RuleMatchInfo(..) +#if MIN_VERSION_ghc(8,2,0) + , LexicalFixity(..) +#endif ) import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey ) @@ -43,6 +50,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt import Language.Haskell.Brittany.Internal.Layouters.Pattern import Bag ( mapBagM, bagToList, emptyBag ) +import Data.Char (isUpper) @@ -52,6 +60,7 @@ layoutDecl d@(L loc decl) = case decl of ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case Left ns -> docLines $ return <$> ns Right n -> return n + TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl) InstD (TyFamInstD{}) -> do -- this is a (temporary (..)) workaround for "type instance" decls -- that do not round-trip through exactprint properly. @@ -69,6 +78,10 @@ layoutDecl d@(L loc decl) = case decl of _ -> briDocByExactNoComment d +-------------------------------------------------------------------------------- +-- Sig +-------------------------------------------------------------------------------- + layoutSig :: ToBriDoc Sig layoutSig lsig@(L _loc sig) = case sig of #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ @@ -168,6 +181,11 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of ] _ -> unknownNodeError "" lgstmt -- TODO + +-------------------------------------------------------------------------------- +-- HsBind +-------------------------------------------------------------------------------- + layoutBind :: ToBriDocC (HsBindLR GhcPs GhcPs) @@ -595,6 +613,103 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha ] ++ wherePartMultiLine + +-------------------------------------------------------------------------------- +-- TyClDecl +-------------------------------------------------------------------------------- + +layoutTyCl :: ToBriDoc TyClDecl +layoutTyCl ltycl@(L _loc tycl) = case tycl of +#if MIN_VERSION_ghc(8,2,0) + SynDecl name vars fixity typ _ -> do + let isInfix = case fixity of + Prefix -> False + Infix -> True +#else + SynDecl name vars typ _ -> do + nameStr <- lrdrNameToTextAnn name + let isInfixTypeOp = case Text.uncons nameStr of + Nothing -> False + Just (c, _) -> not (c == '(' || isUpper c) + isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote +#endif + -- hasTrailingParen <- hasAnnKeywordComment ltycl AnnCloseP + -- let parenWrapper = if hasTrailingParen + -- then appSep . docWrapNodeRest ltycl + -- else id + let wrapNodeRest = docWrapNodeRest ltycl + docWrapNodePrior ltycl + $ layoutSynDecl isInfix wrapNodeRest name (hsq_explicit vars) typ + _ -> briDocByExactNoComment ltycl + +layoutSynDecl + :: Bool + -> (ToBriDocM BriDocNumbered -> ToBriDocM BriDocNumbered) + -> Located (IdP GhcPs) + -> [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> ToBriDocM BriDocNumbered +layoutSynDecl isInfix wrapNodeRest name vars typ = do + nameStr <- lrdrNameToTextAnn name + let + lhs = appSep . wrapNodeRest $ if isInfix + then do + let (a : b : rest) = vars + hasOwnParens <- hasAnnKeywordComment a AnnOpenP + -- This isn't quite right, but does give syntactically valid results + let needsParens = not $ null rest || hasOwnParens + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + ] + ++ [ docParenL | needsParens ] + ++ [ layoutTyVarBndr False a + , docSeparator + , docLit nameStr + , docSeparator + , layoutTyVarBndr False b + ] + ++ [ docParenR | needsParens ] + ++ fmap (layoutTyVarBndr True) rest + else + docSeq + $ [ docLit $ Text.pack "type" + , docSeparator + , docWrapNode name $ docLit nameStr + ] + ++ fmap (layoutTyVarBndr True) vars + sharedLhs <- docSharedWrapper id lhs + typeDoc <- docSharedWrapper layoutType typ + hasComments <- hasAnyCommentsConnected typ + runFilteredAlternative $ do + addAlternativeCond (not hasComments) $ docSeq + [sharedLhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc] + addAlternative $ docAddBaseY BrIndentRegular $ docPar + sharedLhs + (docCols ColTyOpPrefix [appSep $ docLit $ Text.pack "=", typeDoc]) + +layoutTyVarBndr :: Bool -> ToBriDoc HsTyVarBndr +layoutTyVarBndr needsSep lbndr@(L _ bndr) = do + docWrapNodePrior lbndr $ case bndr of + UserTyVar name -> do + nameStr <- lrdrNameToTextAnn name + docSeq $ [docSeparator | needsSep] ++ [docLit nameStr] + KindedTyVar name kind -> do + nameStr <- lrdrNameToTextAnn name + docSeq + $ [ docSeparator | needsSep ] + ++ [ docLit $ Text.pack "(" + , appSep $ docLit nameStr + , appSep . docLit $ Text.pack "::" + , docForceSingleline $ layoutType kind + , docLit $ Text.pack ")" + ] + + +-------------------------------------------------------------------------------- +-- ClsInstDecl +-------------------------------------------------------------------------------- + -- | Layout an @instance@ declaration -- -- Layout signatures and bindings using the corresponding layouters from the diff --git a/src/Language/Haskell/Brittany/Internal/Prelude.hs b/src/Language/Haskell/Brittany/Internal/Prelude.hs index 2d8a038..6b93bf0 100644 --- a/src/Language/Haskell/Brittany/Internal/Prelude.hs +++ b/src/Language/Haskell/Brittany/Internal/Prelude.hs @@ -1,3 +1,8 @@ +#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +{-# LANGUAGE TypeFamilies #-} +#endif + + module Language.Haskell.Brittany.Internal.Prelude ( module E , module Language.Haskell.Brittany.Internal.Prelude @@ -400,5 +405,8 @@ todo = error "todo" #if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */ +type family IdP p +type instance IdP GhcPs = RdrName + type GhcPs = RdrName #endif