From 42f566b94ab24f41d191ae8e91d8fa2f4aba95e7 Mon Sep 17 00:00:00 2001 From: Lennart Spitzner Date: Wed, 12 Jun 2019 09:17:21 +0200 Subject: [PATCH] Support QuasiQuotation-splices --- src-literatetests/14-extensions.blt | 35 +++++++++++ src-literatetests/Main.hs | 1 + src-unittests/TestUtils.hs | 1 + .../Haskell/Brittany/Internal/Backend.hs | 61 ++++++++++--------- .../Haskell/Brittany/Internal/Config.hs | 2 + .../Haskell/Brittany/Internal/Config/Types.hs | 18 ++++++ .../Brittany/Internal/Layouters/Expr.hs | 14 +++++ .../Brittany/Internal/Transformations/Alt.hs | 32 +++++++++- .../Internal/Transformations/Columns.hs | 1 + .../Haskell/Brittany/Internal/Types.hs | 7 +++ .../Haskell/Brittany/Internal/Utils.hs | 7 ++- 11 files changed, 145 insertions(+), 34 deletions(-) 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