diff --git a/src-literatetests/14-extensions.blt b/src-literatetests/14-extensions.blt
index 9dc0378..e403568 100644
--- a/src-literatetests/14-extensions.blt
+++ b/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
diff --git a/src-literatetests/Main.hs b/src-literatetests/Main.hs
index 284c696..ef70e44 100644
--- a/src-literatetests/Main.hs
+++ b/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
diff --git a/src-unittests/TestUtils.hs b/src-unittests/TestUtils.hs
index 3394dc9..bf7a1a3 100644
--- a/src-unittests/TestUtils.hs
+++ b/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
diff --git a/src/Language/Haskell/Brittany/Internal/Backend.hs b/src/Language/Haskell/Brittany/Internal/Backend.hs
index d5a2434..8f97171 100644
--- a/src/Language/Haskell/Brittany/Internal/Backend.hs
+++ b/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
@@ -329,35 +332,37 @@ briDocIsMultiLine briDoc = rec briDoc
where
rec :: BriDoc -> Bool
rec = \case
- BDEmpty -> False
- BDLit _ -> False
- BDSeq bds -> any rec bds
- BDCols _ bds -> any rec bds
- BDSeparator -> False
- BDAddBaseY _ bd -> rec bd
- BDBaseYPushCur bd -> rec bd
- BDBaseYPop bd -> rec bd
- BDIndentLevelPushCur bd -> rec bd
- BDIndentLevelPop bd -> rec bd
- BDPar _ _ _ -> True
- BDAlt{} -> error "briDocIsMultiLine BDAlt"
- BDForceMultiline _ -> True
- BDForceSingleline bd -> rec bd
- BDForwardLineMode bd -> rec bd
+ BDEmpty -> False
+ BDLit _ -> False
+ BDSeq bds -> any rec bds
+ BDCols _ bds -> any rec bds
+ BDSeparator -> False
+ BDAddBaseY _ bd -> rec bd
+ BDBaseYPushCur bd -> rec bd
+ BDBaseYPop bd -> rec bd
+ BDIndentLevelPushCur bd -> rec bd
+ BDIndentLevelPop bd -> rec bd
+ BDPar _ _ _ -> True
+ BDAlt{} -> error "briDocIsMultiLine BDAlt"
+ BDForceMultiline _ -> True
+ BDForceSingleline bd -> rec bd
+ BDForwardLineMode bd -> rec bd
BDExternal _ _ _ t | [_] <- Text.lines t -> False
- BDExternal _ _ _ _ -> True
- BDAnnotationPrior _ bd -> rec bd
- BDAnnotationKW _ _ bd -> rec bd
- BDAnnotationRest _ bd -> rec bd
- BDMoveToKWDP _ _ _ bd -> rec bd
- BDLines (_:_:_) -> True
- BDLines [_ ] -> False
- BDLines [] -> error "briDocIsMultiLine BDLines []"
- BDEnsureIndent _ bd -> rec bd
- BDSetParSpacing bd -> rec bd
- BDForceParSpacing bd -> rec bd
- BDNonBottomSpacing bd -> rec bd
- BDDebug _ bd -> rec bd
+ BDExternal _ _ _ _ -> True
+ BDPlain t | [_] <- Text.lines t -> False
+ BDPlain _ -> True
+ BDAnnotationPrior _ bd -> rec bd
+ BDAnnotationKW _ _ bd -> rec bd
+ BDAnnotationRest _ bd -> rec bd
+ BDMoveToKWDP _ _ _ bd -> rec bd
+ BDLines (_ : _ : _) -> True
+ BDLines [_ ] -> False
+ BDLines [] -> error "briDocIsMultiLine BDLines []"
+ BDEnsureIndent _ bd -> rec bd
+ BDSetParSpacing bd -> rec bd
+ BDForceParSpacing bd -> rec bd
+ BDNonBottomSpacing bd -> rec bd
+ BDDebug _ bd -> rec bd
-- In theory
-- =========
diff --git a/src/Language/Haskell/Brittany/Internal/Config.hs b/src/Language/Haskell/Brittany/Internal/Config.hs
index 464bd3c..89d125e 100644
--- a/src/Language/Haskell/Brittany/Internal/Config.hs
+++ b/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
diff --git a/src/Language/Haskell/Brittany/Internal/Config/Types.hs b/src/Language/Haskell/Brittany/Internal/Config/Types.hs
index e157c77..a415a08 100644
--- a/src/Language/Haskell/Brittany/Internal/Config/Types.hs
+++ b/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)
diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
index 3f1cfb7..74a87af 100644
--- a/src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
+++ b/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
diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
index b9458fb..22d0555 100644
--- a/src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
+++ b/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
- Config m,
- MonadMultiState AltCurPos m, MonadMultiWriter (Seq String) m) => BriDocNumbered -> m ()
+ processSpacingSimple
+ :: ( MonadMultiReader Config 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
diff --git a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs b/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
index 471ac67..31ec86a 100644
--- a/src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
+++ b/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
diff --git a/src/Language/Haskell/Brittany/Internal/Types.hs b/src/Language/Haskell/Brittany/Internal/Types.hs
index e54d35e..8aad965 100644
--- a/src/Language/Haskell/Brittany/Internal/Types.hs
+++ b/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
diff --git a/src/Language/Haskell/Brittany/Internal/Utils.hs b/src/Language/Haskell/Brittany/Internal/Utils.hs
index b454890..dfd28c3 100644
--- a/src/Language/Haskell/Brittany/Internal/Utils.hs
+++ b/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
-showGhc = GHC.showPpr GHC.unsafeGlobalDynFlags
+showOutputable :: (GHC.Outputable a) => a -> String
+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