{-# LANGUAGE DataKinds #-}
module Language.Haskell.Brittany.Internal.Layouters.Type
( layoutType
)
where
#include "prelude.inc"
import Language.Haskell.Brittany.Internal.Config.Types
import Language.Haskell.Brittany.Internal.Types
import Language.Haskell.Brittany.Internal.LayouterBasics
import GHC ( runGhc
, GenLocated(L)
, moduleNameString
, AnnKeywordId (..)
)
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
import HsSyn
import Name
import Outputable ( ftext, showSDocUnsafe )
import BasicTypes
import qualified SrcLoc
import DataTreePrint
layoutType :: ToBriDoc HsType
layoutType ltype@(L _ typ) = docWrapNode ltype $ case typ of
#if MIN_VERSION_ghc(8,6,0)
HsTyVar _ promoted name -> do
t <- lrdrNameToTextAnn name
case promoted of
Promoted -> docSeq
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsTyVar promoted name -> do
t <- lrdrNameToTextAnn name
case promoted of
Promoted -> docSeq
[ docSeparator
, docTick
, docWrapNode name $ docLit t
]
NotPromoted -> docWrapNode name $ docLit t
#else /* ghc-8.0 */
HsTyVar name -> do
t <- lrdrNameToTextAnn name
docWrapNode name $ docLit t
#endif
#if MIN_VERSION_ghc(8,6,0)
HsForAllTy _ bndrs (L _ (HsQualTy _ (L _ cntxts) typ2)) -> do
#else
HsForAllTy bndrs (L _ (HsQualTy (L _ cntxts) typ2)) -> do
#endif
typeDoc <- docSharedWrapper layoutType typ2
tyVarDocs <- bndrs `forM` \case
#if MIN_VERSION_ghc(8,6,0)
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"
#else
(L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar lrdrName kind)) -> do
d <- docSharedWrapper layoutType kind
return $ (lrdrNameToText lrdrName, Just $ d)
#endif
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = tyVarDocs >>= \case
(tname, Nothing) -> [docLit $ Text.pack " " <> tname]
(tname, Just doc) -> [ docLit $ Text.pack " ("
<> tname
<> Text.pack " :: "
, docForceSingleline $ doc
, docLit $ Text.pack ")"
]
forallDoc = docAlt
[ let
open = docLit $ Text.pack "forall"
in docSeq ([open]++tyVarDocLineList)
, docPar
(docLit (Text.pack "forall"))
(docLines
$ tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
])
]
contextDoc = case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
, let
open = docCols ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2) cntxtDoc
]
in docPar open $ docLines $ list ++ [close]
]
docAlt
[ docSeq
[ if null bndrs
then docEmpty
else let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close])
, docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
]
, docPar
forallDoc
( docLines
[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, docAddBaseY (BrIndentSpecial 3)
$ contextDoc
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML $ typeDoc
]
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsForAllTy _ bndrs typ2 -> do
#else
HsForAllTy bndrs typ2 -> do
#endif
typeDoc <- layoutType typ2
tyVarDocs <- bndrs `forM` \case
#if MIN_VERSION_ghc(8,6,0)
(L _ (UserTyVar _ name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar _ lrdrName kind)) -> do
d <- layoutType kind
return $ (lrdrNameToText lrdrName, Just $ return d)
(L _ (XTyVarBndr{})) -> error "brittany internal error: XTyVarBndr"
#else
(L _ (UserTyVar name)) -> return $ (lrdrNameToText name, Nothing)
(L _ (KindedTyVar lrdrName kind)) -> do
d <- layoutType kind
return $ (lrdrNameToText lrdrName, Just $ return d)
#endif
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
let
tyVarDocLineList = tyVarDocs >>= \case
(tname, Nothing) -> [docLit $ Text.pack " " <> tname]
(tname, Just doc) -> [ docLit $ Text.pack " ("
<> tname
<> Text.pack " :: "
, docForceSingleline doc
, docLit $ Text.pack ")"
]
docAlt
[ docSeq
[ if null bndrs
then docEmpty
else let
open = docLit $ Text.pack "forall"
close = docLit $ Text.pack " . "
in docSeq ([open]++tyVarDocLineList++[close])
, docForceSingleline $ return $ typeDoc
]
, docPar
(docSeq $ docLit (Text.pack "forall") : tyVarDocLineList)
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
)
, docPar
(docLit (Text.pack "forall"))
(docLines
$ (tyVarDocs <&> \case
(tname, Nothing) -> docEnsureIndent BrIndentRegular $ docLit tname
(tname, Just doc) -> docEnsureIndent BrIndentRegular
$ docLines
[ docCols ColTyOpPrefix
[ docParenLSep
, docLit tname
]
, docCols ColTyOpPrefix
[ docLit $ Text.pack ":: "
, doc
]
, docLit $ Text.pack ")"
]
)
++[ docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack " . "
, maybeForceML $ return typeDoc
]
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsQualTy _ lcntxts@(L _ cntxts) typ1 -> do
#else
HsQualTy lcntxts@(L _ cntxts) typ1 -> do
#endif
typeDoc <- docSharedWrapper layoutType typ1
cntxtDocs <- cntxts `forM` docSharedWrapper layoutType
let
contextDoc = docWrapNode lcntxts $ case cntxtDocs of
[] -> docLit $ Text.pack "()"
[x] -> x
_ -> docAlt
[ let
open = docLit $ Text.pack "("
close = docLit $ Text.pack ")"
list = List.intersperse docCommaSep
$ docForceSingleline <$> cntxtDocs
in docSeq ([open]++list++[close])
, let
open = docCols ColTyOpPrefix
[ docParenLSep
, docAddBaseY (BrIndentSpecial 2)
$ head cntxtDocs
]
close = docLit $ Text.pack ")"
list = List.tail cntxtDocs <&> \cntxtDoc ->
docCols ColTyOpPrefix
[ docCommaSep
, docAddBaseY (BrIndentSpecial 2)
$ cntxtDoc
]
in docPar open $ docLines $ list ++ [close]
]
let maybeForceML = case typ1 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
docAlt
[ docSeq
[ docForceSingleline contextDoc
, docLit $ Text.pack " => "
, docForceSingleline typeDoc
]
, docPar
(docForceSingleline contextDoc)
( docCols ColTyOpPrefix
[ docLit $ Text.pack "=> "
, docAddBaseY (BrIndentSpecial 3) $ maybeForceML typeDoc
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsFunTy _ typ1 typ2 -> do
#else
HsFunTy typ1 typ2 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
let maybeForceML = case typ2 of
(L _ HsFunTy{}) -> docForceMultiline
_ -> id
hasComments <- hasAnyCommentsBelow ltype
docAlt $
[ docSeq
[ appSep $ docForceSingleline typeDoc1
, appSep $ docLit $ Text.pack "->"
, docForceSingleline typeDoc2
]
| not hasComments
] ++
[ docPar
(docNodeAnnKW ltype Nothing typeDoc1)
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ appSep $ docLit $ Text.pack "->"
, docAddBaseY (BrIndentSpecial 3)
$ maybeForceML typeDoc2
]
)
]
#if MIN_VERSION_ghc(8,6,0)
HsParTy _ typ1 -> do
#else
HsParTy typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack "("
, docForceSingleline typeDoc1
, docLit $ Text.pack ")"
]
, docPar
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
(docLit $ Text.pack ")")
]
#if MIN_VERSION_ghc(8,6,0)
HsAppTy _ typ1@(L _ HsAppTy{}) typ2 -> do
let gather :: [LHsType GhcPs] -> LHsType GhcPs -> (LHsType GhcPs, [LHsType GhcPs])
gather list = \case
L _ (HsAppTy _ ty1 ty2) -> gather (ty2:list) ty1
final -> (final, list)
let (typHead, typRest) = gather [typ2] typ1
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppTy _ typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
]
#else
HsAppTy typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
(docEnsureIndent BrIndentRegular typeDoc2)
]
HsAppsTy [] -> error "HsAppsTy []"
HsAppsTy [L _ (HsAppPrefix typ1)] -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc1
HsAppsTy [lname@(L _ (HsAppInfix name))] -> do
typeDoc1 <-
lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lname name
docLit typeDoc1
HsAppsTy (L _ (HsAppPrefix typHead):typRestA)
| Just typRest <- mapM (\case L _ (HsAppPrefix t) -> Just t
_ -> Nothing) typRestA -> do
docHead <- docSharedWrapper layoutType typHead
docRest <- docSharedWrapper layoutType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
HsAppsTy (typHead:typRest) -> do
docHead <- docSharedWrapper layoutAppType typHead
docRest <- docSharedWrapper layoutAppType `mapM` typRest
docAlt
[ docSeq
$ docForceSingleline docHead : (docRest >>= \d ->
[ docSeparator, docForceSingleline d ])
, docPar docHead (docLines $ docEnsureIndent BrIndentRegular <$> docRest)
]
where
layoutAppType (L _ (HsAppPrefix t)) = layoutType t
layoutAppType lt@(L _ (HsAppInfix t)) =
docLit =<< lrdrNameToTextAnnTypeEqualityIsSpecialAndRespectTick lt t
#endif
#if MIN_VERSION_ghc(8,6,0)
HsListTy _ typ1 -> do
#else
HsListTy typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack "["
, docForceSingleline typeDoc1
, docLit $ Text.pack "]"
]
, docPar
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[ "
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
(docLit $ Text.pack "]")
]
#if MIN_VERSION_ghc(8,6,0)
#else
HsPArrTy typ1 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
, docForceSingleline typeDoc1
, docLit $ Text.pack ":]"
]
, docPar
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack "[:"
, docAddBaseY (BrIndentSpecial 2) $ typeDoc1
])
(docLit $ Text.pack ":]")
]
#endif
#if MIN_VERSION_ghc(8,6,0)
HsTupleTy _ tupleSort typs -> case tupleSort of
#else
HsTupleTy tupleSort typs -> case tupleSort of
#endif
HsUnboxedTuple -> unboxed
HsBoxedTuple -> simple
HsConstraintTuple -> simple
HsBoxedOrConstraintTuple -> simple
where
unboxed = if null typs then error "brittany internal error: unboxed unit"
else unboxedL
simple = if null typs then unitL else simpleL
unitL = docLit $ Text.pack "()"
simpleL = do
docs <- docSharedWrapper layoutType `mapM` typs
let end = docLit $ Text.pack ")"
lines = List.tail docs <&> \d ->
docCols ColTyOpPrefix [docCommaSep, d]
docAlt
[ docSeq $ [docLit $ Text.pack "("]
++ List.intersperse docCommaSep (docForceSingleline <$> docs)
++ [end]
, let line1 = docCols ColTyOpPrefix [docParenLSep, head docs]
in docPar
(docAddBaseY (BrIndentSpecial 2) $ line1)
(docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
]
unboxedL = do
docs <- docSharedWrapper layoutType `mapM` typs
let start = docParenHashLSep
end = docParenHashRSep
docAlt
[ docSeq $ [start]
++ List.intersperse docCommaSep docs
++ [end]
, let
line1 = docCols ColTyOpPrefix [start, head docs]
lines = List.tail docs <&> \d ->
docCols ColTyOpPrefix [docCommaSep, d]
in docPar
(docAddBaseY (BrIndentSpecial 2) line1)
(docLines $ (docAddBaseY (BrIndentSpecial 2) <$> lines) ++ [end])
]
HsOpTy{} ->
briDocByExactInlineOnly "HsOpTy{}" ltype
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
HsIParamTy _ (L _ (HsIPName ipName)) typ1 -> do
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
HsIParamTy (L _ (HsIPName ipName)) typ1 -> do
#else /* ghc-8.0 */
HsIParamTy (HsIPName ipName) typ1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
docAlt
[ docSeq
[ docWrapNodeRest ltype
$ docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName) ++ "::")
, docForceSingleline typeDoc1
]
, docPar
( docLit
$ Text.pack ("?" ++ showSDocUnsafe (ftext ipName))
)
(docCols ColTyOpPrefix
[ docWrapNodeRest ltype
$ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 2) typeDoc1
])
]
#if MIN_VERSION_ghc(8,6,0)
#else
HsEqTy typ1 typ2 -> do
typeDoc1 <- docSharedWrapper layoutType typ1
typeDoc2 <- docSharedWrapper layoutType typ2
docAlt
[ docSeq
[ docForceSingleline typeDoc1
, docWrapNodeRest ltype
$ docLit $ Text.pack " ~ "
, docForceSingleline typeDoc2
]
, docPar
typeDoc1
( docCols ColTyOpPrefix
[ docWrapNodeRest ltype
$ docLit $ Text.pack "~ "
, docAddBaseY (BrIndentSpecial 2) typeDoc2
])
]
#endif
#if MIN_VERSION_ghc(8,6,0)
HsKindSig _ typ1 kind1 -> do
#else
HsKindSig typ1 kind1 -> do
#endif
typeDoc1 <- docSharedWrapper layoutType typ1
kindDoc1 <- docSharedWrapper layoutType kind1
hasParens <- hasAnnKeyword ltype AnnOpenP
docAlt
[ if hasParens
then docSeq
[ docLit $ Text.pack "("
, docForceSingleline typeDoc1
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, docForceSingleline kindDoc1
, docLit $ Text.pack ")"
]
else docSeq
[ docForceSingleline typeDoc1
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, docForceSingleline kindDoc1
]
, if hasParens
then docLines
[ docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docParenLSep
, docAddBaseY (BrIndentSpecial 3) $ typeDoc1
]
, docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
]
, (docLit $ Text.pack ")")
]
else docPar
typeDoc1
( docCols
ColTyOpPrefix
[ docWrapNodeRest ltype $ docLit $ Text.pack ":: "
, docAddBaseY (BrIndentSpecial 3) kindDoc1
]
)
]
HsBangTy{} ->
briDocByExactInlineOnly "HsBangTy{}" ltype
HsSpliceTy{} ->
briDocByExactInlineOnly "HsSpliceTy{}" ltype
HsDocTy{} ->
briDocByExactInlineOnly "HsDocTy{}" ltype
HsRecTy{} ->
briDocByExactInlineOnly "HsRecTy{}" ltype
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsExplicitListTy _ _ typs -> do
#else /* ghc-8.0 */
HsExplicitListTy _ typs -> do
#endif
typDocs <- docSharedWrapper layoutType `mapM` typs
docAlt
[ docSeq
$ [docLit $ Text.pack "'["]
++ List.intersperse docCommaSep typDocs
++ [docLit $ Text.pack "]"]
]
HsExplicitTupleTy{} ->
briDocByExactInlineOnly "HsExplicitTupleTy{}" ltype
#if MIN_VERSION_ghc(8,6,0)
HsTyLit _ lit -> case lit of
#else
HsTyLit lit -> case lit of
#endif
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsNumTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsNumTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
HsStrTy (SourceText srctext) _ -> docLit $ Text.pack srctext
HsStrTy NoSourceText _ ->
error "overLitValBriDoc: literal with no SourceText"
#else /* ghc-8.0 */
HsNumTy srctext _ -> docLit $ Text.pack srctext
HsStrTy srctext _ -> docLit $ Text.pack srctext
#endif
#if !MIN_VERSION_ghc(8,6,0)
HsCoreTy{} ->
briDocByExactInlineOnly "HsCoreTy{}" ltype
#endif
HsWildCardTy _ ->
docLit $ Text.pack "_"
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
HsSumTy{} ->
briDocByExactInlineOnly "HsSumTy{}" ltype
#endif
#if MIN_VERSION_ghc(8,6,0)
HsStarTy _ isUnicode -> do
if isUnicode
then docLit $ Text.pack "\x2605"
else docLit $ Text.pack "*"
XHsType{} -> error "brittany internal error: XHsType"
#endif