diff --git a/TESTS.md b/TESTS.md index 836e87425..eeb12481d 100644 --- a/TESTS.md +++ b/TESTS.md @@ -1638,14 +1638,6 @@ foo = undefined go = undefined ``` -`UnboxedSums` - -```haskell -{-# LANGUAGE UnboxedSums #-} - -f :: (# Int | Bool | String #) -``` - #### Promoted types Promoted lists @@ -1761,6 +1753,42 @@ f :: (a :?: b) => (a, b) f' :: ((:?:) a b) => (a, b) ``` +#### Unboxed types + +Short unboxed sums + +```haskell +{-# LANGUAGE UnboxedSums #-} + +f :: (# (# Int, String #) | String #) -> (# Int | String #) +``` + +Long unboxed sums + +```haskell +{-# LANGUAGE UnboxedSums #-} + +f' :: + (# (# Int, String #) + | Either Bool Int + | Either Bool Int + | Either Bool Int + | Either Bool Int + | Either Bool Int + | String #) + -> (# Int | String #) +``` + +Large unboxed tuples + +```haskell +{-# LANGUAGE UnboxedTuples #-} + +f :: (# Looooooooooooooooooooooooooooooooooooooooooooong + , Looooooooooooooooooooooooooooooooooooooooooooong + , Looooooooooooooooooooooooooooooooooooooooooooong #) +``` + ### Type synonym declarations Short diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs index 0fb4b5609..48890e3c5 100644 --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -520,7 +520,7 @@ prettyHsExpr (ExplicitTuple _ full _) = horizontal <-|> vertical isMissing Missing {} = True isMissing _ = False prettyHsExpr (ExplicitSum _ _ _ expr) = - unboxedSums $ spaced [string "|", pretty expr] + unboxedParens $ spaced [string "|", pretty expr] prettyHsExpr (HsCase _ cond arms) = do string "case " |=> do pretty cond @@ -1019,9 +1019,12 @@ prettyHsType (HsAppTy _ l r) = spaced $ fmap pretty [l, r] prettyHsType (HsAppKindTy _ l r) = pretty l >> string " @" >> pretty r prettyHsType (HsFunTy _ _ a b) = (pretty a >> string " -> ") |=> pretty b prettyHsType (HsListTy _ xs) = brackets $ pretty xs -prettyHsType (HsTupleTy _ _ []) = string "()" -prettyHsType (HsTupleTy _ _ xs) = hvTuple' $ fmap pretty xs -prettyHsType (HsSumTy _ xs) = unboxedSums $ hBarSep $ fmap pretty xs +prettyHsType (HsTupleTy _ HsUnboxedTuple []) = string "(# #)" +prettyHsType (HsTupleTy _ HsBoxedOrConstraintTuple []) = string "()" +prettyHsType (HsTupleTy _ HsUnboxedTuple xs) = hvUnboxedTuple' $ fmap pretty xs +prettyHsType (HsTupleTy _ HsBoxedOrConstraintTuple xs) = + hvTuple' $ fmap pretty xs +prettyHsType (HsSumTy _ xs) = hvUnboxedSum' $ fmap pretty xs -- For `HsOpTy`, we do not need a single quote for the infix operator. An -- explicit promotion is necessary if there is a data constructor and -- a type with the same name. However, infix data constructors never diff --git a/src/HIndent/Pretty/Combinators/Lineup.hs b/src/HIndent/Pretty/Combinators/Lineup.hs index 6f3482e7b..6baafce54 100644 --- a/src/HIndent/Pretty/Combinators/Lineup.hs +++ b/src/HIndent/Pretty/Combinators/Lineup.hs @@ -7,6 +7,10 @@ module HIndent.Pretty.Combinators.Lineup , vTuple , vTuple' , hPromotedTuple + , -- * Unboxed tuples + hvUnboxedTuple' + , -- * Unboxed sums + hvUnboxedSum' , -- * Records hvFields , hFields @@ -58,17 +62,51 @@ hTuple = parens . hCommaSep -- | Runs printers to construct a tuple where elements are aligned -- vertically. vTuple :: [Printer ()] -> Printer () -vTuple = vLineup ("(", ")") +vTuple = vCommaSepWrapped ("(", ")") -- | Similar to 'vTuple', but the closing parenthesis is in the last -- element. vTuple' :: [Printer ()] -> Printer () -vTuple' = vLineup' ("(", ")") +vTuple' = vCommaSepWrapped' ("(", ")") -- | Runs printers to construct a promoted tuple in a line. hPromotedTuple :: [Printer ()] -> Printer () hPromotedTuple = promotedTupleParens . hCommaSep +-- | Runs printers to construct an unboxed tuple. The elements are aligned +-- either in a line or vertically. +hvUnboxedTuple' :: [Printer ()] -> Printer () +hvUnboxedTuple' = (<-|>) <$> hUnboxedTuple <*> vUnboxedTuple' + +-- | Runs printers to construct an unboxed tuple in a line. +hUnboxedTuple :: [Printer ()] -> Printer () +hUnboxedTuple = unboxedParens . hCommaSep + +-- | Runs printers to construct an unboxed tuple where the elements are +-- aligned vertically. +vUnboxedTuple' :: [Printer ()] -> Printer () +vUnboxedTuple' = vCommaSepWrapped' ("(#", " #)") + +-- | Runs printers to construct an unboxed sum. The elements are aligned +-- either in a line or vertically. +-- +-- The enclosing parenthesis will be printed on the same line as the last +-- element. +hvUnboxedSum' :: [Printer ()] -> Printer () +hvUnboxedSum' = (<-|>) <$> hUnboxedSum <*> vUnboxedSum' + +-- | Runs printers to construct an unboxed sum in a line. +hUnboxedSum :: [Printer ()] -> Printer () +hUnboxedSum = unboxedParens . hBarSep + +-- | Runs printers to construct an unboxed sum where the elements are +-- aligned vertically. +-- +-- The enclosing parenthesis will be printed on the same line as the last +-- element. +vUnboxedSum' :: [Printer ()] -> Printer () +vUnboxedSum' = vWrappedLineup' '|' ("(#", " #)") + -- | Applies 'hFields' if the result fits in a line or 'vFields' otherwise. hvFields :: [Printer ()] -> Printer () hvFields = (<-|>) <$> hFields <*> vFields @@ -80,12 +118,12 @@ hFields = braces . hCommaSep -- | Runs printers to construct a record where elements are aligned -- vertically. vFields :: [Printer ()] -> Printer () -vFields = vLineup ("{", "}") +vFields = vCommaSepWrapped ("{", "}") -- | Similar to 'vFields', but the closing brace is in the same line as the -- last element. vFields' :: [Printer ()] -> Printer () -vFields' = vLineup' ("{", "}") +vFields' = vCommaSepWrapped' ("{", "}") -- | Runs printers to construct a list in a line. hList :: [Printer ()] -> Printer () @@ -94,30 +132,12 @@ hList = brackets . hCommaSep -- | Runs printers to construct a list where elements are aligned -- vertically. vList :: [Printer ()] -> Printer () -vList = vLineup ("[", "]") +vList = vCommaSepWrapped ("[", "]") -- | Runs printers to construct a promoted list in a line. hPromotedList :: [Printer ()] -> Printer () hPromotedList = promotedListBrackets . hCommaSep --- | Prints elements in vertical with the given prefix and suffix. -vLineup :: (String, String) -> [Printer ()] -> Printer () -vLineup (prefix, suffix) ps = - string prefix >> - space |=> do - vCommaSep ps - newline - indentedWithSpace (-(fromIntegral (length prefix) + 1)) $ string suffix - --- | Similar to 'vLineup' but the suffix is in the same line as the last --- element. -vLineup' :: (String, String) -> [Printer ()] -> Printer () -vLineup' (prefix, suffix) ps = - string prefix >> - space |=> do - vCommaSep ps - string suffix - -- | Runs printers in a line with a space as the separator. spaced :: [Printer ()] -> Printer () spaced = inter space @@ -157,6 +177,16 @@ hCommaSep = inter (string ", ") vCommaSep :: [Printer ()] -> Printer () vCommaSep = prefixedLined ", " +-- | Prints elements separated by comma in vertical with the given prefix +-- and suffix. +vCommaSepWrapped :: (String, String) -> [Printer ()] -> Printer () +vCommaSepWrapped = vWrappedLineup ',' + +-- | Similar to 'vCommaSepWrapped' but the suffix is in the same line as the last +-- element. +vCommaSepWrapped' :: (String, String) -> [Printer ()] -> Printer () +vCommaSepWrapped' = vWrappedLineup' ',' + -- | Runs printers with a dot as the separator. hDotSep :: [Printer ()] -> Printer () hDotSep = inter (string ".") @@ -178,6 +208,25 @@ prefixedLined pref (x:xs) = do newline prefixed pref p +-- | Prints elements in vertical with the given prefix, suffix, and +-- separator. +vWrappedLineup :: Char -> (String, String) -> [Printer ()] -> Printer () +vWrappedLineup sep (prefix, suffix) ps = + string prefix >> + space |=> do + prefixedLined [sep, ' '] ps + newline + indentedWithSpace (-(fromIntegral (length prefix) + 1)) $ string suffix + +-- | Similar to 'vWrappedLineup' but the suffix is in the same line as the +-- last element. +vWrappedLineup' :: Char -> (String, String) -> [Printer ()] -> Printer () +vWrappedLineup' sep (prefix, suffix) ps = + string prefix >> + space |=> do + prefixedLined [sep, ' '] ps + string suffix + -- Inserts the first printer between each element of the list passed as the -- second argument and runs them. inter :: Printer () -> [Printer ()] -> Printer () diff --git a/src/HIndent/Pretty/Combinators/Wrap.hs b/src/HIndent/Pretty/Combinators/Wrap.hs index 908dac47e..c01948f46 100644 --- a/src/HIndent/Pretty/Combinators/Wrap.hs +++ b/src/HIndent/Pretty/Combinators/Wrap.hs @@ -12,7 +12,7 @@ module HIndent.Pretty.Combinators.Wrap , wrapWithBars , promotedListBrackets , promotedTupleParens - , unboxedSums + , unboxedParens ) where import GHC.Types.Name @@ -77,8 +77,8 @@ promotedTupleParens :: Printer a -> Printer a promotedTupleParens = wrap "'( " ")" -- | Wraps with @(# @ and @ #)@. -unboxedSums :: Printer a -> Printer a -unboxedSums = wrap "(# " " #)" +unboxedParens :: Printer a -> Printer a +unboxedParens = wrap "(# " " #)" -- | This function wraps the printer with the prefix and the suffix. wrap :: String -> String -> Printer a -> Printer a