hexagoxel
/
brittany
1
0
Fork 0
Code Issues 117 Pull Requests 5 Packages Projects Releases 5 Wiki Activity

Support QuasiQuotation-splices

pull/247/head
Lennart Spitzner 2019-06-12 09:17:21 +02:00
parent 305f98fad7
commit 42f566b94a
11 changed files with 145 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
src-literatetests/14-extensions.blt
View File

@ -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

1
src-literatetests/Main.hs
View File

@ -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

1
src-unittests/TestUtils.hs
View File

@ -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

61
src/Language/Haskell/Brittany/Internal/Backend.hs
View File

@ -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
-- =========

2
src/Language/Haskell/Brittany/Internal/Config.hs
View File

@ -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

18
src/Language/Haskell/Brittany/Internal/Config/Types.hs
View File

@ -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)

14
src/Language/Haskell/Brittany/Internal/Layouters/Expr.hs
View File

@ -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

32
src/Language/Haskell/Brittany/Internal/Transformations/Alt.hs
View File

@ -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

1
src/Language/Haskell/Brittany/Internal/Transformations/Columns.hs
View File

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

7
src/Language/Haskell/Brittany/Internal/Types.hs
View File

@ -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

7
src/Language/Haskell/Brittany/Internal/Utils.hs
View File

@ -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