Merge pull request #186 from sergv/unboxed-tuples

Unboxed tuples

.travis.yml

@@ -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
-      cabal new-test --ghc-options="-j1 +RTS -M500M -RTS"
+      cabal new-test -j1 --ghc-options="-j1 +RTS -M500M -RTS"
       ;;
   esac
   set +ex

brittany.cabal

@@ -335,8 +335,9 @@ test-suite littests
   ghc-options: {
     -Wall
     -fno-warn-unused-imports
+    -threaded
     -rtsopts
-    -with-rtsopts "-M2G"
+    -with-rtsopts "-M2G -N"
   }
 
 test-suite libinterfacetests

src-literatetests/14-extensions.blt

@@ -81,3 +81,17 @@ import           Test                                     ( type (++)
                                                           , pattern Foo
                                                           , pattern (:.)
                                                           )
+
+###############################################################################
+## UnboxedTuples + MagicHash
+#test unboxed-tuple and vanilla names
+{-# LANGUAGE UnboxedTuples #-}
+spanKey :: (# Int, Int #) -> (# Int, Int #)
+spanKey = case foo of
+  (# bar, baz #) -> (# baz, bar #)
+
+#test unboxed-tuple and hashed name
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+spanKey :: (# Int#, Int# #) -> (# Int#, Int# #)
+spanKey = case foo of
+  (# bar#, baz# #) -> (# baz# +# bar#, bar# #)

src-literatetests/Main.hs

@@ -1,12 +1,13 @@
 {-# LANGUAGE QuasiQuotes #-}
 
-module Main where
+module Main (main) where
 
 
 
 #include "prelude.inc"
 
 import Test.Hspec
+import Test.Hspec.Runner ( hspecWith, defaultConfig, configConcurrentJobs )
 
 import NeatInterpolation
 
@@ -22,6 +23,7 @@ import Language.Haskell.Brittany.Internal.Config.Types
 import Language.Haskell.Brittany.Internal.Config
 
 import Data.Coerce ( coerce )
+import GHC.Conc    ( getNumCapabilities )
 
 import qualified Data.Text.IO as Text.IO
 import           System.FilePath ( (</>) )
@@ -48,7 +50,8 @@ main = do
   let groups = createChunks =<< inputs
   inputCtxFree <- Text.IO.readFile "src-literatetests/30-tests-context-free.blt"
   let groupsCtxFree = createChunks inputCtxFree
-  hspec $ do
+  jobs <- getNumCapabilities
+  hspecWith (defaultConfig { configConcurrentJobs = Just jobs }) $ do
     groups `forM_` \(groupname, tests) -> do
       describe (Text.unpack groupname) $ tests `forM_` \(name, pend, inp) -> do
         (if pend then before_ pending else id)

src/Language/Haskell/Brittany/Internal/LayouterBasics.hs

@@ -50,7 +50,12 @@ module Language.Haskell.Brittany.Internal.LayouterBasics
   , appSep
   , docCommaSep
   , docParenLSep
+  , docParenL
   , docParenR
+  , docParenHashLSep
+  , docParenHashRSep
+  , docBracketL
+  , docBracketR
   , docTick
   , spacifyDocs
   , briDocMToPPM
@@ -530,11 +535,33 @@ docCommaSep :: ToBriDocM BriDocNumbered
 docCommaSep = appSep $ docLit $ Text.pack ","
 
 docParenLSep :: ToBriDocM BriDocNumbered
-docParenLSep = appSep $ docLit $ Text.pack "("
+docParenLSep = appSep docParenL
+
+-- TODO: we don't make consistent use of these (yet). However, I think the
+-- most readable approach overall might be something else: define
+-- `lit = docLit . Text.pack` and `prepSep = docSeq [docSeparator, x]`.
+-- I think those two would make the usage most readable.
+-- lit "("  and  appSep (lit "(")  are understandable and short without
+-- introducing a new top-level binding for all types of parentheses.
+docParenL :: ToBriDocM BriDocNumbered
+docParenL = docLit $ Text.pack "("
 
 docParenR :: ToBriDocM BriDocNumbered
 docParenR = docLit $ Text.pack ")"
 
+docParenHashLSep :: ToBriDocM BriDocNumbered
+docParenHashLSep =  docSeq [docLit $ Text.pack "(#", docSeparator]
+
+docParenHashRSep :: ToBriDocM BriDocNumbered
+docParenHashRSep = docSeq [docSeparator, docLit $ Text.pack "#)"]
+
+docBracketL :: ToBriDocM BriDocNumbered
+docBracketL = docLit $ Text.pack "["
+
+docBracketR :: ToBriDocM BriDocNumbered
+docBracketR = docLit $ Text.pack "]"
+
+
 docTick :: ToBriDocM BriDocNumbered
 docTick = docLit $ Text.pack "'"
 

src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs

@@ -372,7 +372,7 @@ layoutExpr lexpr@(L _ expr) = do
       hasComments <- hasAnyCommentsBelow lexpr
       let (openLit, closeLit) = case boxity of
             Boxed   -> (docLit $ Text.pack "(", docLit $ Text.pack ")")
-            Unboxed -> (docLit $ Text.pack "(#", docLit $ Text.pack "#)")
+            Unboxed -> (docParenHashLSep, docParenHashRSep)
       case splitFirstLast argDocs of
         FirstLastEmpty -> docSeq
           [ openLit

src/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs

@@ -140,8 +140,8 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
     -- (nestedpat1, nestedpat2, nestedpat3) -> expr
     -- (#nestedpat1, nestedpat2, nestedpat3#) -> expr
     case boxity of
-      Boxed   -> wrapPatListy args "(" ")"
+      Boxed   -> wrapPatListy args "()" docParenL docParenR
-      Unboxed -> wrapPatListy args "(#" "#)"
+      Unboxed -> wrapPatListy args "(##)" docParenHashLSep docParenHashRSep
   AsPat asName asPat -> do
     -- bind@nestedpat -> expr
     wrapPatPrepend asPat (docLit $ lrdrNameToText asName <> Text.pack "@")
@@ -172,7 +172,7 @@ layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
   ListPat elems _ _ ->
     -- [] -> expr1
     -- [nestedpat1, nestedpat2, nestedpat3] -> expr2
-    wrapPatListy elems "[" "]"
+    wrapPatListy elems "[]" docBracketL docBracketR
   BangPat pat1 -> do
     -- !nestedpat -> expr
     wrapPatPrepend pat1 (docLit $ Text.pack "!")
@@ -212,18 +212,18 @@ wrapPatPrepend pat prepElem = do
 wrapPatListy
   :: [Located (Pat GhcPs)]
   -> String
-  -> String
+  -> ToBriDocM BriDocNumbered
+  -> ToBriDocM BriDocNumbered
   -> ToBriDocM (Seq BriDocNumbered)
-wrapPatListy elems start end = do
+wrapPatListy elems both start end = do
   elemDocs <- Seq.fromList elems `forM` (layoutPat >=> colsWrapPat)
-  sDoc <- docLit $ Text.pack start
-  eDoc <- docLit $ Text.pack end
   case Seq.viewl elemDocs of
-    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack $ start ++ end
+    Seq.EmptyL -> fmap Seq.singleton $ docLit $ Text.pack both
     x1 Seq.:< rest -> do
+      sDoc <- start
+      eDoc <- end
       rest' <- rest `forM` \bd -> docSeq
-          [ docLit $ Text.pack ","
+        [ docCommaSep
-          , docSeparator
         , return bd
         ]
       return $ (sDoc Seq.<| x1 Seq.<| rest') Seq.|> eDoc

src/Language/Haskell/Brittany/Internal/Layouters/Type.hs

@@ -392,32 +392,32 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
     unitL = docLit $ Text.pack "()"
     simpleL = do
       docs <- docSharedWrapper layoutType `mapM` typs
+      let end = docLit $ Text.pack ")"
+          lines = List.tail docs <&> \d ->
+                  docCols ColTyOpPrefix [docCommaSep, d]
       docAlt
         [ docSeq $ [docLit $ Text.pack "("]
                ++ List.intersperse docCommaSep (docForceSingleline <$> docs)
-               ++ [docLit $ Text.pack ")"]
+               ++ [end]
-        , let
+        , let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
-            start = docCols ColTyOpPrefix [docParenLSep, head docs]
-            lines = List.tail docs <&> \d ->
-                    docCols ColTyOpPrefix [docCommaSep, d]
-            end   = docLit $ Text.pack ")"
           in docPar
-            (docAddBaseY (BrIndentSpecial 2) $ start)
+            (docAddBaseY (BrIndentSpecial 2) $ line1)
             (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
         ]
     unboxedL = do
       docs <- docSharedWrapper layoutType `mapM` typs
+      let start = docParenHashLSep
+          end   = docParenHashRSep
       docAlt
-        [ docSeq $ [docLit $ Text.pack "(#"]
+        [ docSeq $ [start]
                 ++ List.intersperse docCommaSep docs
-               ++ [docLit $ Text.pack "#)"]
+                ++ [end]
         , let
-            start = docCols ColTyOpPrefix [docLit $ Text.pack "(#", head docs]
+            line1 = docCols ColTyOpPrefix [start, head docs]
             lines  = List.tail docs <&> \d ->
                      docCols ColTyOpPrefix [docCommaSep, d]
-            end   = docLit $ Text.pack "#)"
           in docPar
-            (docAddBaseY (BrIndentSpecial 2) start)
+            (docAddBaseY (BrIndentSpecial 2) line1)
             (docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
         ]
   HsOpTy{} -> -- TODO