125 lines
3.9 KiB
Haskell
125 lines
3.9 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
|
|
module Language.Haskell.Brittany.Layouters.Pattern
|
|
( layoutPat
|
|
)
|
|
where
|
|
|
|
|
|
|
|
#include "prelude.inc"
|
|
|
|
import Language.Haskell.Brittany.Types
|
|
import Language.Haskell.Brittany.LayoutBasics
|
|
|
|
import RdrName ( RdrName(..) )
|
|
import GHC ( runGhc, GenLocated(L), moduleNameString )
|
|
import SrcLoc ( SrcSpan )
|
|
import HsSyn
|
|
import Name
|
|
import BasicTypes
|
|
|
|
import {-# SOURCE #-} Language.Haskell.Brittany.Layouters.Expr
|
|
import Language.Haskell.Brittany.Layouters.Type
|
|
|
|
|
|
|
|
layoutPat :: ToBriDoc Pat
|
|
layoutPat lpat@(L _ pat) = docWrapNode lpat $ case pat of
|
|
WildPat _ -> docLit $ Text.pack "_"
|
|
VarPat n -> docLit $ lrdrNameToText n
|
|
LitPat lit -> allocateNode $ litBriDoc lit
|
|
ParPat inner -> do
|
|
innerDoc <- docSharedWrapper layoutPat inner
|
|
docSeq
|
|
[ docLit $ Text.pack "("
|
|
, innerDoc
|
|
, docLit $ Text.pack ")"
|
|
]
|
|
ConPatIn lname (PrefixCon args) -> do
|
|
let nameDoc = lrdrNameToText lname
|
|
argDocs <- docSharedWrapper layoutPat `mapM` args
|
|
if null argDocs
|
|
then docLit nameDoc
|
|
else docSeq
|
|
$ appSep (docLit nameDoc) : spacifyDocs argDocs
|
|
ConPatIn lname (InfixCon left right) -> do
|
|
let nameDoc = lrdrNameToText lname
|
|
leftDoc <- docSharedWrapper layoutPat left
|
|
rightDoc <- docSharedWrapper layoutPat right
|
|
docSeq [leftDoc, docLit nameDoc, rightDoc]
|
|
ConPatIn lname (RecCon (HsRecFields [] Nothing)) -> do
|
|
let t = lrdrNameToText lname
|
|
docLit $ t <> Text.pack "{}"
|
|
ConPatIn lname (RecCon (HsRecFields fs@(_:_) Nothing)) -> do
|
|
let t = lrdrNameToText lname
|
|
fds <- fs `forM` \(L _ (HsRecField (L _ (FieldOcc lnameF _)) fPat _)) -> do
|
|
-- special casing for some record special thingy..
|
|
fExpDoc <- case fPat of
|
|
(L _ (VarPat (L _ (Unqual x)))) | occNameString x == "pun-right-hand-side" -> return Nothing
|
|
_ -> Just <$> docSharedWrapper layoutPat fPat
|
|
return $ (lrdrNameToText lnameF, fExpDoc)
|
|
docSeq
|
|
[ appSep $ docLit t
|
|
, appSep $ docLit $ Text.pack "{"
|
|
, docSeq $ List.intersperse docCommaSep
|
|
$ fds <&> \case
|
|
(fieldName, Just fieldDoc) -> docSeq
|
|
[ appSep $ docLit $ fieldName
|
|
, appSep $ docLit $ Text.pack "="
|
|
, fieldDoc
|
|
]
|
|
(fieldName, Nothing) -> docLit fieldName
|
|
, docSeparator
|
|
, docLit $ Text.pack "}"
|
|
]
|
|
TuplePat args boxity _ -> do
|
|
argDocs <- docSharedWrapper layoutPat `mapM` args
|
|
case boxity of
|
|
Boxed -> docAlt
|
|
[ docSeq
|
|
$ [ docLit $ Text.pack "(" ]
|
|
++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
|
|
++ [ docLit $ Text.pack ")"]
|
|
-- TODO
|
|
]
|
|
Unboxed -> docAlt
|
|
[ docSeq
|
|
$ [ docLit $ Text.pack "(#" ]
|
|
++ List.intersperse (appSep $ docLit $ Text.pack ",") argDocs
|
|
++ [ docLit $ Text.pack "#)"]
|
|
-- TODO
|
|
]
|
|
AsPat asName asPat -> do
|
|
patDoc <- docSharedWrapper layoutPat asPat
|
|
docSeq
|
|
[ docLit $ lrdrNameToText asName <> Text.pack "@"
|
|
, patDoc
|
|
]
|
|
SigPatIn pat1 (HsIB _ (HsWC _ _ ty1)) -> do
|
|
patDoc <- docSharedWrapper layoutPat pat1
|
|
tyDoc <- docSharedWrapper layoutType ty1
|
|
docSeq
|
|
[ appSep $ patDoc
|
|
, appSep $ docLit $ Text.pack "::"
|
|
, tyDoc
|
|
]
|
|
ListPat elems _ _ -> do
|
|
elemDocs <- docSharedWrapper layoutPat `mapM` elems
|
|
docSeq
|
|
$ [docLit $ Text.pack "["]
|
|
++ List.intersperse docCommaSep (elemDocs)
|
|
++ [docLit $ Text.pack "]"]
|
|
BangPat pat1 -> do
|
|
patDoc <- docSharedWrapper layoutPat pat1
|
|
docSeq [docLit $ Text.pack "!", patDoc]
|
|
NPat llit@(L _ (OverLit olit _ _ _)) _ _ _ -> do
|
|
docWrapNode llit $ allocateNode $ overLitValBriDoc olit
|
|
|
|
-- #if MIN_VERSION_ghc(8,0,0)
|
|
-- VarPat n -> return $ stringLayouter lpat $ lrdrNameToText n
|
|
-- #else
|
|
-- VarPat n -> return $ stringLayouter lpat $ rdrNameToText n
|
|
-- #endif
|
|
_ -> briDocByExact lpat
|