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

Hack on Layouters.Type

mxxun/ghc-9.2
mrkun 2022-02-12 16:11:22 +03:00
parent 03ba1f3a3d
commit 800500f7ce
1 changed files with 11 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
module Language.Haskell.Brittany.Internal.Layouters.Type where module Language.Haskell.Brittany.Internal.Layouters.Type where
import qualified Data.Text as Text import qualified Data.Text as Text
import GHC (AnnKeywordId(..), GenLocated(L)) import GHC (GenLocated(L))
import GHC.Hs import GHC.Hs
import qualified GHC.OldList as List import qualified GHC.OldList as List
import GHC.Types.Basic import GHC.Types.Basic
@ -18,8 +19,8 @@ import Language.Haskell.Brittany.Internal.Utils
(FirstLastView(..), splitFirstLast) (FirstLastView(..), splitFirstLast)
--- XXX: maybe push `Anno (sym GhcPs)` into ToBriDoc definition in place of a typevar
layoutType :: ToBriDoc ann HsType layoutType :: ToBriDoc AnnListItem HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
-- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible" -- _ | traceShow (ExactPrint.Types.mkAnnKey ltype) False -> error "impossible"
HsTyVar _ promoted name -> do HsTyVar _ promoted name -> do
@ -27,7 +28,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
case promoted of case promoted of
IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t] IsPromoted -> docSeq [docSeparator, docTick, docWrapNode name $ docLit t]
NotPromoted -> docWrapNode name $ docLit t NotPromoted -> docWrapNode name $ docLit t
HsForAllTy _ hsf (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do HsForAllTy _ hsf (L _ (HsQualTy _ (fromMaybeContext -> cntxts) typ2)) -> do
let bndrs = getBinders hsf let bndrs = getBinders hsf
typeDoc <- docSharedWrapper layoutType typ2 typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- layoutTyVarBndrs bndrs tyVarDocs <- layoutTyVarBndrs bndrs
@ -160,7 +161,7 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
] ]
) )
] ]
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do HsQualTy _ (fromMaybe (noLocA []) -> lcntxts@(L _ cntxts)) typ1 -> do
typeDoc <- docSharedWrapper layoutType typ1 typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let let
@ -578,6 +579,9 @@ layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext HsStrTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy GHC.Types.SourceText.NoSourceText _ -> HsStrTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText" error "overLitValBriDoc: literal with no SourceText"
HsCharTy (GHC.Types.SourceText.SourceText srctext) _ -> docLit $ Text.pack srctext
HsCharTy GHC.Types.SourceText.NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsWildCardTy _ -> docLit $ Text.pack "_" HsWildCardTy _ -> docLit $ Text.pack "_"
HsSumTy{} -> -- TODO HsSumTy{} -> -- TODO
briDocByExactInlineOnly "HsSumTy{}" ltype briDocByExactInlineOnly "HsSumTy{}" ltype
@ -621,14 +625,12 @@ processTyVarBndrsSingleline bndrDocs = bndrDocs >>= \case
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
getBinders :: HsForAllTelescope pass -> [LHsTyVarBndr () pass] getBinders :: HsForAllTelescope (GhcPass pass) -> [LHsTyVarBndr () (GhcPass pass)]
getBinders x = case x of getBinders x = case x of
HsForAllVis _ b -> b HsForAllVis _ b -> b
HsForAllInvis _ b -> fmap withoutSpecificity b HsForAllInvis _ b -> fmap withoutSpecificity b
XHsForAllTelescope _ -> []
withoutSpecificity :: LHsTyVarBndr flag pass -> LHsTyVarBndr () pass withoutSpecificity :: LHsTyVarBndr flag (GhcPass pass) -> LHsTyVarBndr () (GhcPass pass)
withoutSpecificity = fmap $ \case withoutSpecificity = fmap $ \case
UserTyVar a _ c -> UserTyVar a () c UserTyVar a _ c -> UserTyVar a () c
KindedTyVar a _ c d -> KindedTyVar a () c d KindedTyVar a _ c d -> KindedTyVar a () c d
XTyVarBndr a -> XTyVarBndr a