Support typed and untyped splices

data/examples/declaration/splice/bracket-out.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+foo =
+  [e|
+  foo bar
+  |]
+
+foo =
+  [e|
+  foo bar
+  |]
+
+foo = [t|Char|]
+
+foo =
+  [d|
+  foo :: Int -> Char
+
+  bar = 42
+
+  |]
+
+foo =
+  [||
+  foo bar
+  ||]

data/examples/declaration/splice/bracket.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+foo   = [|      foo bar
+  |]
+
+foo = [e| foo bar
+  |]
+
+foo = [t|       Char |]
+
+foo = [d|
+           foo:: Int       -> Char
+           bar = 42
+  |]
+
+foo = [|| foo bar
+  ||]

data/examples/declaration/splice/quasiquote-out.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE QuasiQuotes #-}
+x = [foo|    foo bar   |]
+
+x =
+  [e|    foo
+ bar  {- -}
+  |]
+
+[d|    foo bar
+
+|]

data/examples/declaration/splice/quasiquote.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+x = [foo|    foo bar   |]
+
+x = [e|    foo
+ bar  {- -}
+  |]
+
+[d|    foo bar
+
+|]

data/examples/declaration/splice/splice-decl-out.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+$(foo bar)
+
+$foo
+
+$$(foo bar)
+
+$$foo
+
+foo bar
+
+[e|booya|]
+
+-- TemplateHaskell allows Q () at the top level
+do
+  pure []

data/examples/declaration/splice/splice-decl.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+$(  foo       bar)
+
+$foo
+
+$$(  foo       bar)
+
+$$foo
+
+foo bar
+
+[|booya|]
+
+-- TemplateHaskell allows Q () at the top level
+do
+  pure []

data/examples/declaration/splice/typed-splice-out.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+x =
+  $$( foo bar
+    )
+
+x = $$foo

data/examples/declaration/splice/typed-splice.hs

@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+x      =    $$(   foo  bar 
+  )
+
+x     =     $$foo

data/examples/declaration/splice/untyped-splice-out.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+x = $(foo bar)
+
+x =
+  $( foo
+       bar
+   )
+
+x = $foo

data/examples/declaration/splice/untyped-splice.hs

@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+x      =    $(      foo bar     )
+
+x = $(   
+  foo  
+      bar      )
+
+x = $foo

data/examples/declaration/value/function/pattern/quasi-quotes-pattern-out.hs

@@ -4,7 +4,6 @@ singleline [yamlQQ|something|] = ()
 
 multiline :: ()
 multiline = case y of
-  [yamlQQ|
-    name: John Doe
-    age: 23
-  |] -> ()
+  [yamlQQ| name: John Doe
+age: 23
+|] -> ()

data/examples/declaration/value/function/pattern/splice-pattern-out.hs

@@ -5,8 +5,8 @@ singleLine = case () of
 
 multiline = case () of
   $( x +
-     y
+       y
    ) -> ()
   $( y
-     "something"
+       "something"
    ) -> ()

data/examples/declaration/value/function/quasi-quotes-out.hs

@@ -4,9 +4,8 @@ singleline = [yamlQQ|something|]
 
 multiline :: Value
 multiline =
-  [yamlQQ|
-    name: John Doe
-    age: 23
+  [yamlQQ| name: John Doe
+age: 23
 
-    something: foo
-  |]
+something: foo
+|]

ormolu.cabal

@@ -68,6 +68,7 @@ library
                     , Ormolu.Printer.Meat.Declaration.Instance
                     , Ormolu.Printer.Meat.Declaration.RoleAnnotation
                     , Ormolu.Printer.Meat.Declaration.Signature
+                    , Ormolu.Printer.Meat.Declaration.Splice
                     , Ormolu.Printer.Meat.Declaration.Type
                     , Ormolu.Printer.Meat.Declaration.TypeFamily
                     , Ormolu.Printer.Meat.Declaration.Value

src/Ormolu/Printer/Combinators.hs

@@ -22,6 +22,7 @@ module Ormolu.Printer.Combinators
   , switchLayout
   , vlayout
   , breakpoint
+  , breakpoint'
     -- ** Formatting lists
   , velt
   , velt'
@@ -143,6 +144,14 @@ switchLayout spn = enterLayout
 breakpoint :: R ()
 breakpoint = vlayout space newline
 
+-- | Similar to 'breakpoint' but outputs nothing in case of single-line
+-- layout.
+--
+-- > breakpoint' = vlayout (return ()) newline
+
+breakpoint' :: R ()
+breakpoint' = vlayout (return ()) newline
+
 ----------------------------------------------------------------------------
 -- Formatting lists
 
@@ -155,9 +164,7 @@ breakpoint = vlayout space newline
 -- when layout is single line.
 
 velt :: [R ()] -> R ()
-velt xs = sequence_ (intersperse sep (sitcc <$> xs))
-  where
-    sep = vlayout (pure ()) newline
+velt xs = sequence_ (intersperse breakpoint' (sitcc <$> xs))
 
 -- | Like 'velt', but all sub-elements start at the same indentation level
 -- as first element, additionally spaces are inserted when layout is single

src/Ormolu/Printer/Meat/Declaration.hs

@@ -1,13 +1,16 @@
 {-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
 
 -- | Rendering of declarations.
 
 module Ormolu.Printer.Meat.Declaration
-  ( p_hsDecl
+  ( p_hsDecls
+  , p_hsDecl
   )
 where
 
+import Control.Monad (forM_)
 import GHC
 import Ormolu.Printer.Combinators
 import Ormolu.Printer.Meat.Common
@@ -15,16 +18,28 @@ import Ormolu.Printer.Meat.Declaration.Annotation
 import Ormolu.Printer.Meat.Declaration.Class
 import Ormolu.Printer.Meat.Declaration.Data
 import Ormolu.Printer.Meat.Declaration.Default
-import Ormolu.Printer.Meat.Declaration.Instance
 import Ormolu.Printer.Meat.Declaration.Foreign
+import Ormolu.Printer.Meat.Declaration.Instance
 import Ormolu.Printer.Meat.Declaration.RoleAnnotation
 import Ormolu.Printer.Meat.Declaration.Signature
+import Ormolu.Printer.Meat.Declaration.Splice
 import Ormolu.Printer.Meat.Declaration.Type
 import Ormolu.Printer.Meat.Declaration.TypeFamily
 import Ormolu.Printer.Meat.Declaration.Value
 import Ormolu.Printer.Meat.Type
 import Ormolu.Utils
 
+p_hsDecls :: [LHsDecl GhcPs] -> R ()
+p_hsDecls decls =
+  forM_ (zip decls ((Just <$> drop 1 decls) ++ [Nothing])) $
+    \(d, md) -> do
+      case md of
+        Nothing -> located d p_hsDecl
+        Just d' ->
+          if separatedDecls (unLoc d) (unLoc d')
+            then line (located d p_hsDecl)
+            else located d p_hsDecl
+
 p_hsDecl :: HsDecl GhcPs -> R ()
 p_hsDecl = \case
   TyClD NoExt x -> p_tyClDecl x
@@ -37,7 +52,7 @@ p_hsDecl = \case
   WarningD _ _ -> notImplemented "WarningD"
   AnnD NoExt x -> p_annDecl x
   RuleD _ _ -> notImplemented "RuleD"
-  SpliceD _ _ -> notImplemented "SpliceD"
+  SpliceD NoExt x -> p_spliceDecl x
   DocD _ _ -> notImplemented "DocD"
   RoleAnnotD NoExt x -> p_roleAnnot x
   XHsDecl _ -> notImplemented "XHsDecl"
@@ -72,3 +87,26 @@ p_derivDecl :: DerivDecl GhcPs -> R ()
 p_derivDecl = \case
   d@DerivDecl {..} -> p_standaloneDerivDecl d
   XDerivDecl _ -> notImplemented "XDerivDecl standalone deriving"
+
+-- | Determine if these declarations should be separated by a blank line.
+
+separatedDecls
+  :: HsDecl GhcPs
+  -> HsDecl GhcPs
+  -> Bool
+separatedDecls (TypeSignature n) (FunctionBody n') = n /= n'
+separatedDecls (FunctionBody n) (InlinePragma n') = n /= n'
+separatedDecls (InlinePragma n) (TypeSignature n') = n /= n'
+separatedDecls (FunctionBody n) (SpecializePragma n') = n /= n'
+separatedDecls (SpecializePragma n) (TypeSignature n') = n /= n'
+separatedDecls (SpecializePragma n) (SpecializePragma n') = n /= n'
+separatedDecls _ _ = True
+
+pattern TypeSignature
+      , FunctionBody
+      , InlinePragma
+      , SpecializePragma :: RdrName -> HsDecl GhcPs
+pattern TypeSignature n <- SigD NoExt (TypeSig NoExt ((L _ n):_) _)
+pattern FunctionBody n <- ValD NoExt (FunBind NoExt (L _ n) _ _ _)
+pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
+pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)

src/Ormolu/Printer/Meat/Declaration.hs-boot

@@ -0,0 +1,12 @@
+module Ormolu.Printer.Meat.Declaration
+  ( p_hsDecls
+  , p_hsDecl
+  )
+where
+
+import GHC
+import Ormolu.Printer.Combinators
+
+p_hsDecls :: [LHsDecl GhcPs] -> R ()
+
+p_hsDecl :: HsDecl GhcPs -> R ()

src/Ormolu/Printer/Meat/Declaration/Splice.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Ormolu.Printer.Meat.Declaration.Splice
+  ( p_spliceDecl
+  )
+where
+
+import GHC
+import Ormolu.Printer.Combinators
+import Ormolu.Printer.Meat.Declaration.Value (p_hsSplice)
+import Ormolu.Utils
+
+p_spliceDecl :: SpliceDecl GhcPs -> R ()
+p_spliceDecl = \case
+  SpliceDecl NoExt splice _explicit -> line $ located splice p_hsSplice
+  XSpliceDecl {} -> notImplemented "XSpliceDecl"

src/Ormolu/Printer/Meat/Declaration/Value.hs

@@ -6,6 +6,7 @@ module Ormolu.Printer.Meat.Declaration.Value
   ( p_valDecl
   , p_pat
   , p_hsExpr
+  , p_hsSplice
   )
 where
 
@@ -14,8 +15,7 @@ import BasicTypes
 import Control.Monad
 import Data.Data
 import Data.List (sortOn)
-import Data.String (fromString)
-import FastString as GHC
+import Data.Text (Text)
 import GHC
 import Ormolu.Printer.Combinators
 import Ormolu.Printer.Meat.Common
@@ -25,7 +25,7 @@ import Ormolu.Utils
 import Outputable (Outputable (..))
 import SrcLoc (combineSrcSpans, isOneLineSpan)
 import qualified Data.List.NonEmpty as NE
-import qualified Data.Text as T
+import {-# SOURCE #-} Ormolu.Printer.Meat.Declaration
 
 data MatchGroupStyle
   = Function (Located RdrName)
@@ -381,7 +381,6 @@ p_hsExpr = \case
           HsIB {..} = hswc_body
       located hsib_body p_hsType
   ArithSeq NoExt _ x -> do
-    let breakpoint' = vlayout (return ()) newline
     case x of
       From from -> brackets $ do
         located from p_hsExpr
@@ -413,7 +412,7 @@ p_hsExpr = \case
     txt " #-}"
     breakpoint
     located x p_hsExpr
-  HsBracket {} -> notImplemented "HsBracket"
+  HsBracket NoExt x -> p_hsBracket x
   HsRnBracketOut {} -> notImplemented "HsRnBracketOut"
   HsTcBracketOut {} -> notImplemented "HsTcBracketOut"
   HsSpliceE NoExt splice -> p_hsSplice splice
@@ -557,10 +556,13 @@ p_hsSplice = \case
   HsTypedSplice NoExt deco _ expr -> p_hsSpliceTH True expr deco
   HsUntypedSplice NoExt deco _ expr -> p_hsSpliceTH False expr deco
   HsQuasiQuote NoExt _ quoterName srcSpan str -> do
-    let locatedQuoterName = L srcSpan quoterName
-    p_quasiQuote locatedQuoterName $ do
-      let p x = unless (T.null x) (txt x)
-      newlineSep (p . T.strip) (T.lines . T.strip . fromString . GHC.unpackFS $ str)
+    txt "["
+    p_rdrName (L srcSpan quoterName)
+    txt "|"
+    -- NOTE QuasiQuoters often rely on precise custom strings. We cannot do
+    -- any formatting here without potentially breaking someone's code.
+    atom str
+    txt "|]"
   HsSpliced {} -> notImplemented "HsSpliced"
   XSplice {} -> notImplemented "XSplice"
 
@@ -572,25 +574,40 @@ p_hsSpliceTH
 p_hsSpliceTH isTyped expr = \case
   HasParens -> do
     txt decoSymbol
-    parens (located expr p_hsExpr)
+    parens (located expr (sitcc . p_hsExpr))
   HasDollar -> do
     txt decoSymbol
-    located expr p_hsExpr
+    located expr (sitcc . p_hsExpr)
   NoParens -> do
-    located expr p_hsExpr
+    located expr (sitcc . p_hsExpr)
   where
     decoSymbol = if isTyped then "$$" else "$"
 
-p_quasiQuote :: Located RdrName -> R () -> R ()
-p_quasiQuote quoter m = do
-  txt "["
-  p_rdrName quoter
-  txt "|"
-  let breakpoint' = vlayout (return ()) newline
-  breakpoint'
-  inci m
-  breakpoint'
-  txt "|]"
+p_hsBracket :: HsBracket GhcPs -> R ()
+p_hsBracket = \case
+  ExpBr NoExt expr -> quote "e" (located expr p_hsExpr)
+  PatBr NoExt pat -> quote "p" (located pat p_pat)
+  DecBrL NoExt decls -> quote "d" (p_hsDecls decls)
+  DecBrG NoExt _ -> notImplemented "DecBrG" -- result of renamer
+  TypBr NoExt ty -> quote "t" (located ty p_hsType)
+  VarBr NoExt _ _ -> notImplemented "VarBr"
+  TExpBr NoExt expr -> do
+    txt "[||"
+    breakpoint'
+    located expr p_hsExpr
+    breakpoint'
+    txt "||]"
+  XBracket {} -> notImplemented "XBracket"
+  where
+    quote :: Text -> R () -> R ()
+    quote name body = do
+      txt "["
+      txt name
+      txt "|"
+      breakpoint'
+      body
+      breakpoint'
+      txt "|]"
 
 ----------------------------------------------------------------------------
 -- Helpers

src/Ormolu/Printer/Meat/Module.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms   #-}
 {-# LANGUAGE RecordWildCards   #-}
 
 -- | Rendering of modules.
@@ -50,16 +49,7 @@ p_hsModule loc@(L moduleSpan hsModule) = do
         when (not (null hsmodImports) || not (null hsmodDecls)) newline
     forM_ (sortImports hsmodImports) (located' p_hsmodImport)
     when (not (null hsmodImports) && not (null hsmodDecls)) newline
-
-    forM_ (zip hsmodDecls ((Just <$> drop 1 hsmodDecls) ++ [Nothing])) $
-      \(d, md) -> do
-        case md of
-          Nothing -> located d p_hsDecl
-          Just d' ->
-            if separatedDecls (unLoc d) (unLoc d')
-              then line (located d p_hsDecl)
-              else located d p_hsDecl
-
+    p_hsDecls hsmodDecls
     trailingComments <- hasMoreComments
     when (trailingComments && isJust hsmodName) newline
     spitRemainingComments
@@ -83,26 +73,3 @@ p_warningTxt = \case
     p_lits = \case
       [l] -> atom l
       ls -> brackets . velt $ withSep comma atom ls
-
--- | Determine if these declarations should be separated by a blank line.
-
-separatedDecls
-  :: HsDecl GhcPs
-  -> HsDecl GhcPs
-  -> Bool
-separatedDecls (TypeSignature n) (FunctionBody n') = n /= n'
-separatedDecls (FunctionBody n) (InlinePragma n') = n /= n'
-separatedDecls (InlinePragma n) (TypeSignature n') = n /= n'
-separatedDecls (FunctionBody n) (SpecializePragma n') = n /= n'
-separatedDecls (SpecializePragma n) (TypeSignature n') = n /= n'
-separatedDecls (SpecializePragma n) (SpecializePragma n') = n /= n'
-separatedDecls _ _ = True
-
-pattern TypeSignature
-      , FunctionBody
-      , InlinePragma
-      , SpecializePragma :: RdrName -> HsDecl GhcPs
-pattern TypeSignature n <- SigD NoExt (TypeSig NoExt ((L _ n):_) _)
-pattern FunctionBody n <- ValD NoExt (FunBind NoExt (L _ n) _ _ _)
-pattern InlinePragma n <- SigD NoExt (InlineSig NoExt (L _ n) _)
-pattern SpecializePragma n <- SigD NoExt (SpecSig NoExt (L _ n) _ _)