Support QuasiQuotation-splices

src-literatetests/14-extensions.blt

@@ -95,3 +95,38 @@ spanKey = case foo of
 spanKey :: (# Int#, Int# #) -> (# Int#, Int# #)
 spanKey = case foo of
   (# bar#, baz# #) -> (# baz# +# bar#, bar# #)
+
+
+###############################################################################
+## QuasiQuotes
+#test quasi-quotes simple 1
+{-# LANGUAGE QuasiQuotes #-}
+func = [blub|
+  asd
+  qwe
+  |]
+
+#test quasi-quotes simple 2
+{-# LANGUAGE QuasiQuotes #-}
+func = [blub|
+        asd
+  qwe|]
+
+#test quasi-quotes ignoring layouting
+{-# LANGUAGE QuasiQuotes #-}
+func = do
+  let body = [json|
+  hello
+  |]
+  pure True
+
+#test quasi-quotes ignoring layouting, strict mode
+-- brittany { lconfig_allowHangingQuasiQuotes: False }
+{-# LANGUAGE QuasiQuotes #-}
+func = do
+  let
+    body =
+      [json|
+  hello
+  |]
+  pure True

src-literatetests/Main.hs

@@ -178,6 +178,7 @@ defaultTestConfig = Config
     , _lconfig_hangingTypeSignature      = coerce False
     , _lconfig_reformatModulePreamble    = coerce True
     , _lconfig_allowSingleLineExportList = coerce True
+    , _lconfig_allowHangingQuasiQuotes   = coerce True
     }
   , _conf_errorHandling             = (_conf_errorHandling staticDefaultConfig)
     { _econf_omit_output_valid_check = coerce True

src-unittests/TestUtils.hs

@@ -59,6 +59,7 @@ defaultTestConfig = Config
     , _lconfig_hangingTypeSignature      = coerce False
     , _lconfig_reformatModulePreamble    = coerce True
     , _lconfig_allowSingleLineExportList = coerce True
+    , _lconfig_allowHangingQuasiQuotes   = coerce True
     }
   , _conf_errorHandling             = (_conf_errorHandling staticDefaultConfig)
     { _econf_ExactPrintFallback = coerce ExactPrintFallbackModeNever

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

@@ -151,6 +151,8 @@ layoutBriDocM = \case
       mSet $ state
         { _lstate_comments = Map.filterWithKey filterF $ _lstate_comments state
         }
+  BDPlain t -> do
+    layoutWriteAppend t
   BDAnnotationPrior annKey bd -> do
     state <- mGet
     let m = _lstate_comments state
@@ -310,6 +312,7 @@ briDocLineLength briDoc = flip StateS.evalState False $ rec briDoc
     BDForceSingleline bd    -> rec bd
     BDForwardLineMode bd    -> rec bd
     BDExternal _ _ _ t      -> return $ Text.length t
+    BDPlain t               -> return $ Text.length t
     BDAnnotationPrior _ bd  -> rec bd
     BDAnnotationKW _ _ bd   -> rec bd
     BDAnnotationRest _ bd   -> rec bd
@@ -346,6 +349,8 @@ briDocIsMultiLine briDoc = rec briDoc
     BDForwardLineMode bd                     -> rec bd
     BDExternal _ _ _ t | [_] <- Text.lines t -> False
     BDExternal _ _ _ _                       -> True
+    BDPlain t | [_] <- Text.lines t          -> False
+    BDPlain _                                -> True
     BDAnnotationPrior _ bd                   -> rec bd
     BDAnnotationKW _ _ bd                    -> rec bd
     BDAnnotationRest _ bd                    -> rec bd

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

@@ -75,6 +75,7 @@ staticDefaultConfig = Config
     , _lconfig_hangingTypeSignature      = coerce False
     , _lconfig_reformatModulePreamble    = coerce True
     , _lconfig_allowSingleLineExportList = coerce False
+    , _lconfig_allowHangingQuasiQuotes   = coerce True
     }
   , _conf_errorHandling = ErrorHandlingConfig
     { _econf_produceOutputOnErrors   = coerce False
@@ -177,6 +178,7 @@ cmdlineConfigParser = do
       , _lconfig_hangingTypeSignature      = mempty
       , _lconfig_reformatModulePreamble    = mempty
       , _lconfig_allowSingleLineExportList = mempty
+      , _lconfig_allowHangingQuasiQuotes   = mempty
       }
     , _conf_errorHandling = ErrorHandlingConfig
       { _econf_produceOutputOnErrors   = wrapLast $ falseToNothing outputOnErrors

src/Language/Haskell/Brittany/Internal/Config/Types.hs

@@ -109,6 +109,24 @@ data CLayoutConfig f = LayoutConfig
     -- >   , def
     -- >   )
     -- > where
+  , _lconfig_allowHangingQuasiQuotes :: f (Last Bool)
+    -- if false, the layouter sees any splices as infinitely big and places
+    -- them accordingly (in newlines, most likely); This also influences
+    -- parent nodes.
+    -- if true, the layouter is free to start a quasi-quotation at the end
+    -- of a line.
+    --
+    -- false:
+    -- > let
+    -- >   body =
+    -- >     [json|
+    -- >     hello
+    -- >     |]
+    --
+    -- true:
+    -- > let body = [json|
+    -- >     hello
+    -- >     |]
   }
   deriving (Generic)
 

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

@@ -15,6 +15,8 @@ import           Language.Haskell.Brittany.Internal.Types
 import           Language.Haskell.Brittany.Internal.LayouterBasics
 import           Language.Haskell.Brittany.Internal.Config.Types
 
+import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint.Types
+
 import           GHC ( runGhc, GenLocated(L), SrcSpan, moduleNameString, AnnKeywordId(..), RdrName(..) )
 import           HsSyn
 import           Name
@@ -1109,6 +1111,18 @@ layoutExpr lexpr@(L _ expr) = do
     HsTcBracketOut{} -> do
       -- TODO
       briDocByExactInlineOnly "HsTcBracketOut{}" lexpr
+#if MIN_VERSION_ghc(8,6,0)   /* ghc-8.6 */
+    HsSpliceE _ (HsQuasiQuote _ _ quoter _loc content) -> do
+#else
+    HsSpliceE (HsQuasiQuote _ quoter _loc content) -> do
+#endif
+      allocateNode $ BDFPlain
+        (Text.pack
+          $  "["
+          ++ showOutputable quoter
+          ++ "|"
+          ++ showOutputable content
+          ++ "|]")
     HsSpliceE{} -> do
       -- TODO
       briDocByExactInlineOnly "HsSpliceE{}" lexpr

src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs

@@ -288,6 +288,7 @@ transformAlts =
           mSet $ acp' { _acp_forceMLFlag = _acp_forceMLFlag acp }
           return $ x
         BDFExternal{} -> processSpacingSimple bdX $> bdX
+        BDFPlain{}    -> processSpacingSimple bdX $> bdX
         BDFAnnotationPrior annKey bd -> do
           acp <- mGet
           mSet $ acp { _acp_forceMLFlag = altLineModeDecay $ _acp_forceMLFlag acp }
@@ -337,9 +338,13 @@ transformAlts =
           acp :: AltCurPos <- mGet
           tellDebugMess $ "transformAlts: BDFDEBUG " ++ s ++ " (node-id=" ++ show brDcId ++ "): acp=" ++ show acp
           reWrap . BDFDebug s <$> rec bd
-    processSpacingSimple :: (MonadMultiReader
+    processSpacingSimple
-                                                     Config m,
+      :: ( MonadMultiReader Config m
-                                                   MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m ()
+         , MonadMultiState AltCurPos m
+         , MonadMultiWriter (Seq String) m
+         )
+      => BriDocNumbered
+      -> m ()
     processSpacingSimple bd = getSpacing bd >>= \case
       LineModeInvalid                           -> error "processSpacingSimple inv"
       LineModeValid (VerticalSpacing i VerticalSpacingParNone _) -> do
@@ -455,6 +460,9 @@ getSpacing !bridoc = rec bridoc
       BDFExternal _ _ _ txt -> return $ LineModeValid $ case Text.lines txt of
         [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
         _   -> VerticalSpacing 999 VerticalSpacingParNone False
+      BDFPlain txt -> return $ LineModeValid $ case Text.lines txt of
+        [t] -> VerticalSpacing (Text.length t) VerticalSpacingParNone False
+        _   -> VerticalSpacing 999 VerticalSpacingParNone False
       BDFAnnotationPrior _annKey bd -> rec bd
       BDFAnnotationKW _annKey _kw bd -> rec bd
       BDFAnnotationRest  _annKey bd -> rec bd
@@ -584,6 +592,11 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
                   if i1 < i2 then Smaller else Bigger
                 (p1, p2) -> if p1 == p2 then Smaller else Unequal
               else Unequal
+      let allowHangingQuasiQuotes =
+            config
+              & _conf_layout
+              & _lconfig_allowHangingQuasiQuotes
+              & confUnpack
       let -- this is like List.nub, with one difference: if two elements
           -- are unequal only in _vs_paragraph, with both ParAlways, we
           -- treat them like equals and replace the first occurence with the
@@ -729,6 +742,19 @@ getSpacings limit bridoc = preFilterLimit <$> rec bridoc
         BDFExternal{} ->
           return $ [] -- yes, we just assume that we cannot properly layout
                       -- this.
+        BDFPlain t -> return
+          [ case Text.lines t of
+              []       -> VerticalSpacing 0 VerticalSpacingParNone False
+              [t1    ] -> VerticalSpacing
+                (Text.length t1)
+                VerticalSpacingParNone
+                False
+              (t1 : _) -> VerticalSpacing
+                (Text.length t1)
+                (VerticalSpacingParAlways 0)
+                True
+          | allowHangingQuasiQuotes
+          ]
         BDFAnnotationPrior _annKey bd -> rec bd
         BDFAnnotationKW _annKey _kw bd -> rec bd
         BDFAnnotationRest  _annKey bd -> rec bd

src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs

@@ -125,6 +125,7 @@ transformSimplifyColumns = Uniplate.rewrite $ \case
   BDForceSingleline{} -> Nothing
   BDForwardLineMode{} -> Nothing
   BDExternal{}        -> Nothing
+  BDPlain{}           -> Nothing
   BDLines{}           -> Nothing
   BDAnnotationPrior{} -> Nothing
   BDAnnotationKW{}    -> Nothing

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

@@ -243,6 +243,8 @@ data BriDoc
                             -- to be printed via exactprint
                Bool -- should print extra comment ?
                Text
+  | BDPlain !Text -- used for QuasiQuotes, content can be multi-line
+                  -- (contrast to BDLit)
   | BDAnnotationPrior AnnKey BriDoc
   | BDAnnotationKW AnnKey (Maybe AnnKeywordId) BriDoc
   | BDAnnotationRest  AnnKey BriDoc
@@ -289,6 +291,8 @@ data BriDocF f
                             -- to be printed via exactprint
                Bool -- should print extra comment ?
                Text
+  | BDFPlain !Text -- used for QuasiQuotes, content can be multi-line
+                   -- (contrast to BDLit)
   | BDFAnnotationPrior AnnKey (f (BriDocF f))
   | BDFAnnotationKW AnnKey (Maybe AnnKeywordId) (f (BriDocF f))
   | BDFAnnotationRest  AnnKey (f (BriDocF f))
@@ -323,6 +327,7 @@ instance Uniplate.Uniplate BriDoc where
   uniplate (BDAlt             alts)      = plate BDAlt ||* alts
   uniplate (BDForwardLineMode bd  )      = plate BDForwardLineMode |* bd
   uniplate x@BDExternal{}                = plate x
+  uniplate x@BDPlain{}                = plate x
   uniplate (BDAnnotationPrior annKey bd) = plate BDAnnotationPrior |- annKey |* bd
   uniplate (BDAnnotationKW annKey kw bd) = plate BDAnnotationKW |- annKey |- kw |* bd
   uniplate (BDAnnotationRest annKey bd)  = plate BDAnnotationRest |- annKey |* bd
@@ -355,6 +360,7 @@ unwrapBriDocNumbered tpl = case snd tpl of
   BDFAlt             alts      -> BDAlt $ rec <$> alts -- not that this will happen
   BDFForwardLineMode bd        -> BDForwardLineMode $ rec bd
   BDFExternal k ks c t         -> BDExternal k ks c t
+  BDFPlain t                   -> BDPlain t
   BDFAnnotationPrior annKey bd -> BDAnnotationPrior annKey $ rec bd
   BDFAnnotationKW annKey kw bd -> BDAnnotationKW annKey kw $ rec bd
   BDFAnnotationRest annKey bd  -> BDAnnotationRest annKey $ rec bd
@@ -391,6 +397,7 @@ briDocSeqSpine = \case
   BDAlt             alts         -> foldl' (\(!()) -> briDocSeqSpine) () alts
   BDForwardLineMode bd           -> briDocSeqSpine bd
   BDExternal{}                   -> ()
+  BDPlain{}                      -> ()
   BDAnnotationPrior _annKey bd   -> briDocSeqSpine bd
   BDAnnotationKW _annKey _kw bd  -> briDocSeqSpine bd
   BDAnnotationRest _annKey bd    -> briDocSeqSpine bd

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

@@ -24,6 +24,7 @@ module Language.Haskell.Brittany.Internal.Utils
   , FirstLastView(..)
   , splitFirstLast
   , lines'
+  , showOutputable
   )
 where
 
@@ -69,8 +70,8 @@ parDocW = PP.fsep . fmap PP.text . List.words . List.unwords
 showSDoc_ :: GHC.SDoc -> String
 showSDoc_ = GHC.showSDoc GHC.unsafeGlobalDynFlags
 
-showGhc :: (GHC.Outputable a) => a -> String
+showOutputable :: (GHC.Outputable a) => a -> String
-showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
+showOutputable = GHC.showPpr GHC.unsafeGlobalDynFlags
 
 fromMaybeIdentity :: Identity a -> Maybe a -> Identity a
 fromMaybeIdentity x y = Data.Coerce.coerce $ fromMaybe (Data.Coerce.coerce x) y
@@ -124,7 +125,7 @@ customLayouterF anns layoutF =
   srcSpan :: GHC.SrcSpan -> NodeLayouter
   srcSpan ss = simpleLayouter
              -- - $ "{"++ showSDoc_ (GHC.ppr ss)++"}"
-                              $ "{" ++ showGhc ss ++ "}"
+                              $ "{" ++ showOutputable ss ++ "}"
   located :: (Data b, Data loc) => GHC.GenLocated loc b -> NodeLayouter
   located (GHC.L ss a) = runDataToLayouter layoutF $ A annStr a
    where