diff --git a/src-literatetests/15-regressions.blt b/src-literatetests/15-regressions.blt index 5e4f52ca..0eec0be1 100644 --- a/src-literatetests/15-regressions.blt +++ b/src-literatetests/15-regressions.blt @@ -524,3 +524,6 @@ spanKey p q = case minViewWithKey q of Just ((k, _), q') | p k -> let (kas, q'') = spanKey p q' in ((k, a) : kas, q'') _ -> ([], q) + +#test issue 125 +a :: () ':- () diff --git a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs index 52c9e08d..a013270c 100644 --- a/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs +++ b/src/Language/Haskell/Brittany/Internal/LayouterBasics.hs @@ -4,6 +4,7 @@ module Language.Haskell.Brittany.Internal.LayouterBasics , lrdrNameToText , lrdrNameToTextAnn , lrdrNameToTextAnnTypeEqualityIsSpecial + , lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick , askIndent , extractAllComments , filterAnns @@ -216,6 +217,27 @@ lrdrNameToTextAnnTypeEqualityIsSpecial ast = do then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh else x +-- | Same as lrdrNameToTextAnnTypeEqualityIsSpecial, but also inspects +-- the annotations for a (parent) node for a tick to be added to the +-- literal. +-- Excessively long name to reflect on us having to work around such +-- excessively obscure special cases in the exactprint API. +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick + :: ( Data ast + , MonadMultiReader Config m + , MonadMultiReader (Map AnnKey Annotation) m + ) + => Located ast + -> Located RdrName + -> m Text +lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick ast1 ast2 = do + hasQuote <- hasAnnKeyword ast1 AnnSimpleQuote + x <- lrdrNameToTextAnn ast2 + let lit = if x == Text.pack "Data.Type.Equality~" + then Text.pack "~" -- rraaaahhh special casing rraaahhhhhh + else x + return $ if hasQuote then Text.cons '\'' lit else lit + askIndent :: (MonadMultiReader Config m) => m Int askIndent = confUnpack . _lconfig_indentAmount . _conf_layout <$> mAsk diff --git a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs index bd4d7283..11e0eed2 100644 --- a/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs +++ b/src/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -317,7 +317,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of HsAppsTy [L _ (HsAppPrefix typ1)] -> do typeDoc1 <- docSharedWrapper layoutType typ1 typeDoc1 - HsAppsTy [_lname@(L _ (HsAppInfix name))] -> do + HsAppsTy [lname@(L _ (HsAppInfix name))] -> do -- this redirection is somewhat hacky, but whatever. -- TODO: a general problem when doing deep inspections on -- the type (and this is not the only instance) @@ -326,7 +326,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of -- circumstances exactly important annotations (comments) -- would be assigned to such constructors. typeDoc1 <- -- docSharedWrapper layoutType $ (L l $ HsTyVar name) - lrdrNameToTextAnnTypeEqualityIsSpecial name + lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name docLit typeDoc1 HsAppsTy (L _ (HsAppPrefix typHead):typRestA) | Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t @@ -350,7 +350,8 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of ] where layoutAppType (L _ (HsAppPrefix t)) = layoutType t - layoutAppType (L _ (HsAppInfix t)) = docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecial t + layoutAppType lt@(L _ (HsAppInfix t)) = + docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t HsListTy typ1 -> do typeDoc1 <- docSharedWrapper layoutType typ1 docAlt