Merge branch 'dev' into import

.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)

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
     }

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

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 }

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)

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 "->"

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