diff --git a/.travis.yml b/.travis.yml index 58a0f33..e1c64bf 100644 --- a/.travis.yml +++ b/.travis.yml @@ -178,7 +178,7 @@ before_install: # echo 'jobs: $ncpus' >> $HOME/.cabal/config #fi - PKGNAME='brittany' -- JOBS='2' +- JOBS='1' - | function better_wait() { date @@ -209,7 +209,7 @@ install: set -ex case "$BUILD" in stack) - stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies + stack -j$JOBS --no-terminal --install-ghc $ARGS test --bench --only-dependencies ;; cabal*) cabal --version @@ -250,6 +250,8 @@ install: cabal --version travis_retry cabal update -v echo 'packages: .' > cabal.project + 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 @@ -262,12 +264,12 @@ script: set -ex case "$BUILD" in stack) - better_wait stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS" + better_wait stack -j$JOBS --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --ghc-options="-j1 +RTS -M500M -RTS -Werror" ;; 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" # this builds all libraries and executables (including tests/benchmarks) + better_wait cabal build -j$JOBS --ghc-options="-j1 +RTS -M500M -RTS -Werror" # this builds all libraries and executables (including tests/benchmarks) cabal test ;; cabaldist) diff --git a/doc-svg-gen/doc-svg-gen.cabal b/doc-svg-gen/doc-svg-gen.cabal index cb093c9..424b841 100644 --- a/doc-svg-gen/doc-svg-gen.cabal +++ b/doc-svg-gen/doc-svg-gen.cabal @@ -5,12 +5,12 @@ extra-source-files: ChangeLog.md cabal-version: >=1.10 executable doc-svg-gen - buildable: True + buildable: False main-is: Main.hs -- other-modules: -- other-extensions: build-depends: - { base >=4.9 && <4.10 + { base >=4.9 && <4.11 , text , graphviz >=2999.19.0.0 } diff --git a/src-literatetests/10-tests.blt b/src-literatetests/10-tests.blt index e560296..123eccc 100644 --- a/src-literatetests/10-tests.blt +++ b/src-literatetests/10-tests.blt @@ -476,9 +476,23 @@ func = (`abc` 1) #group tuples ### -#test 1 +#test pair func = (abc, def) +#test pair section left +func = (abc, ) + +#test pair section right +func = (, abc) + +#test quintuple section long +myTupleSection = + ( verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargefirstelement + , + , verylaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaargethirdelement + , + ) + #test 2 #pending func = (lakjsdlajsdljasdlkjasldjasldjasldjalsdjlaskjd diff --git a/src/Language/Haskell/Brittany/Internal.hs b/src/Language/Haskell/Brittany/Internal.hs index 73a6799..25b7b9a 100644 --- a/src/Language/Haskell/Brittany/Internal.hs +++ b/src/Language/Haskell/Brittany/Internal.hs @@ -62,6 +62,11 @@ import qualified GHC.LanguageExtensions.Type as GHC -- -- Note that this function ignores/resets all config values regarding -- debugging, i.e. it will never use `trace`/write to stderr. +-- +-- Note that the ghc parsing function used internally currently is wrapped in +-- `mask_`, so cannot be killed easily. If you don't control the input, you +-- may wish to put some proper upper bound on the input's size as a timeout +-- won't do. parsePrintModule :: Config -> Text -> IO (Either [BrittanyError] Text) parsePrintModule configRaw inputText = runExceptT $ do let config = configRaw { _conf_debug = _conf_debug staticDefaultConfig } diff --git a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs index 081032d..d0f481c 100644 --- a/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs +++ b/src/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs @@ -37,6 +37,8 @@ import qualified Language.Haskell.GHC.ExactPrint.Preprocess as ExactPrint import qualified Language.Haskell.GHC.ExactPrint.Delta as ExactPrint import qualified Data.Generics as SYB + +import Control.Exception -- import Data.Generics.Schemes @@ -85,7 +87,14 @@ parseModuleFromString -> String -> IO (Either String (ExactPrint.Anns, GHC.ParsedSource, a)) parseModuleFromString args fp dynCheck str = - ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do + -- We mask here because otherwise using `throwTo` (i.e. for a timeout) will + -- produce nasty looking errors ("ghc panic"). The `mask_` makes it so we + -- cannot kill the parsing thread - not very nice. But i'll + -- optimistically assume that most of the time brittany uses noticable or + -- longer time, the majority of the time is not spend in parsing, but in + -- bridoc transformation stuff. + -- (reminder to update note on `parsePrintModule` if this changes.) + mask_ $ ExactPrint.ghcWrapper $ ExceptT.runExceptT $ do dflags0 <- lift $ ExactPrint.initDynFlagsPure fp str (dflags1, leftover, warnings) <- lift $ GHC.parseDynamicFlagsCmdLine dflags0 (GHC.noLoc <$> args) diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs index 0ed8a31..2eb1863 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs @@ -341,9 +341,9 @@ layoutExpr lexpr@(L _ expr) = do opDoc <- docSharedWrapper layoutExpr op rightDoc <- docSharedWrapper layoutExpr right docSeq [opDoc, docSeparator, rightDoc] - ExplicitTuple args boxity - | Just argExprs <- args `forM` (\case (L _ (Present e)) -> Just e; _ -> Nothing) -> do - argDocs <- docSharedWrapper layoutExpr `mapM` argExprs + ExplicitTuple args boxity -> do + let argExprs = fmap (\case (L _ (Present e)) -> Just e; (L _ (Missing PlaceHolder)) -> Nothing) args + argDocs <- docSharedWrapper (maybe docEmpty layoutExpr) `mapM` argExprs hasComments <- hasAnyCommentsBelow lexpr let (openLit, closeLit) = case boxity of Boxed -> (docLit $ Text.pack "(", docLit $ Text.pack ")") @@ -385,8 +385,6 @@ layoutExpr lexpr@(L _ expr) = do end = closeLit in docSetBaseY $ docLines $ [start] ++ linesM ++ [lineN] ++ [end] ] - ExplicitTuple{} -> - unknownNodeError "ExplicitTuple|.." lexpr HsCase cExp (MG lmatches@(L _ matches) _ _ _) -> do cExpDoc <- docSharedWrapper layoutExpr cExp binderDoc <- docLit $ Text.pack "->" diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs index 3f66932..ebdd91d 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs @@ -24,12 +24,26 @@ import Language.Haskell.Brittany.Internal.Layouters.Type +-- | layouts patterns (inside function bindings, case alternatives, let +-- bindings or do notation). E.g. for input +-- > case computation of +-- > (warnings, Success a b) -> .. +-- This part ^^^^^^^^^^^^^^^^^^^^^^^ of the syntax tree is layouted by +-- 'layoutPat'. Similarly for +-- > func abc True 0 = [] +-- ^^^^^^^^^^ this part +-- We will use `case .. of` as the imagined prefix to the examples used in +-- the different cases below. layoutPat :: ToBriDocC (Pat RdrName) (Seq BriDocNumbered) layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of WildPat _ -> fmap Seq.singleton $ docLit $ Text.pack "_" + -- _ -> expr VarPat n -> fmap Seq.singleton $ docLit $ lrdrNameToText n + -- abc -> expr LitPat lit -> fmap Seq.singleton $ allocateNode $ litBriDoc lit + -- 0 -> expr ParPat inner -> do + -- (nestedpat) -> expr left <- docLit $ Text.pack "(" right <- docLit $ Text.pack ")" innerDocs <- colsWrapPat =<< layoutPat inner @@ -49,6 +63,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of -- xN' <- docSeq [return xN, docLit $ Text.pack ")"] -- return $ (x1' Seq.<| middle) Seq.|> xN' ConPatIn lname (PrefixCon args) -> do + -- Abc a b c -> expr let nameDoc = lrdrNameToText lname argDocs <- layoutPat `mapM` args if null argDocs @@ -61,15 +76,19 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of $ fmap colsWrapPat argDocs return $ x1 Seq.<| xR ConPatIn lname (InfixCon left right) -> do + -- a :< b -> expr let nameDoc = lrdrNameToText lname leftDoc <- colsWrapPat =<< layoutPat left rightDoc <- colsWrapPat =<< layoutPat right middle <- docLit nameDoc return $ Seq.empty Seq.|> leftDoc Seq.|> middle Seq.|> rightDoc ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do + -- Abc{} -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docLit $ t <> Text.pack "{}" ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do + -- Abc { a = locA, b = locB, c = locC } -> expr1 + -- Abc { a, b, c } -> expr2 let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do fExpDoc <- if pun @@ -91,12 +110,14 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docLit $ Text.pack "}" ] ConPatIn lname (RecCon (HsRecFields [] (Just 0))) -> do + -- Abc { .. } -> expr let t = lrdrNameToText lname fmap Seq.singleton $ docSeq [ appSep $ docLit t , docLit $ Text.pack "{..}" ] ConPatIn lname (RecCon (HsRecFields fs@(_:_) (Just dotdoti))) | dotdoti == length fs -> do + -- Abc { a = locA, .. } let t = lrdrNameToText lname fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat pun)) -> do fExpDoc <- if pun @@ -117,16 +138,20 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of , docLit $ Text.pack "..}" ] TuplePat args boxity _ -> do + -- (nestedpat1, nestedpat2, nestedpat3) -> expr + -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr case boxity of Boxed -> wrapPatListy args "(" ")" Unboxed -> wrapPatListy args "(#" "#)" AsPat asName asPat -> do + -- bind@nestedpat -> expr wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@") #if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */ SigPatIn pat1 (HsWC _ (HsIB _ ty1 _)) -> do #else /* ghc-8.0 */ SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do #endif + -- i :: Int -> expr patDocs <- layoutPat pat1 tyDoc <- docSharedWrapper layoutType ty1 case Seq.viewr patDocs of @@ -146,12 +171,17 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of ] return $ xR Seq.|> xN' ListPat elems _ _ -> + -- [] -> expr1 + -- [nestedpat1, nestedpat2, nestedpat3] -> expr2 wrapPatListy elems "[" "]" BangPat pat1 -> do + -- !nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "!") LazyPat pat1 -> do + -- ~nestedpat -> expr wrapPatPrepend pat1 (docLit $ Text.pack "~") NPat llit@(L _ (OverLit olit _ _ _)) mNegative _ _ -> do + -- -13 -> expr litDoc <- docWrapNode llit $ allocateNode $ overLitValBriDoc olit negDoc <- docLit $ Text.pack "-" pure $ case mNegative of