Add support for pattern synonyms
Raoul Hidalgo Charman
parent
4b673d1d9d
commit
dfa3fef56c
|
|
@ -82,6 +82,60 @@ import Test ( type (++)
|
|||
, pattern (:.)
|
||||
)
|
||||
|
||||
###############################################################################
|
||||
## PatternSynonyms
|
||||
#test bidirectional pattern
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern J x = Just x
|
||||
|
||||
#test unidirection pattern
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern F x <- (x, _)
|
||||
|
||||
#test explicitly bidirectional pattern
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern HeadC x <- x : xs where
|
||||
HeadC x = [x]
|
||||
|
||||
#test Multiple arguments
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern Head2 x y <- x : y : xs where
|
||||
Head2 x y = [x, y]
|
||||
|
||||
#test Infix argument
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern x :> y = [x, y]
|
||||
|
||||
#test Record argument
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern MyData { a, b, c } = [a, b, c]
|
||||
|
||||
#test long pattern match
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern myLongLeftVariableName `MyLongInfixPatternMatcher` myLongRightVariableName =
|
||||
[myLongLeftVariableName, myLongRightVariableName]
|
||||
|
||||
#test long explicitly bidirectional match
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern myLeftVariableName `MyInfixPatternMatcher` myRightVariableName <-
|
||||
[myLongLeftVariableName, myLongRightVariableName] where
|
||||
MyInfixPatternMatcher x y = [x, x, y]
|
||||
|
||||
#test Pattern synonym types
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern J :: a -> Maybe a
|
||||
pattern J x = Just x
|
||||
|
||||
#test Pattern synonym type sig wrapped
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
pattern LongMatcher
|
||||
:: longlongtypevar
|
||||
-> longlongtypevar
|
||||
-> longlongtypevar
|
||||
-> Maybe [longlongtypevar]
|
||||
pattern LongMatcher x y z = Just [x, y, z]
|
||||
|
||||
|
||||
###############################################################################
|
||||
## UnboxedTuples + MagicHash
|
||||
#test unboxed-tuple and vanilla names
|
||||
|
|
|
|||
|
|
@ -93,11 +93,11 @@ layoutDecl d@(L loc decl) = case decl of
|
|||
layoutSig :: ToBriDoc Sig
|
||||
layoutSig lsig@(L _loc sig) = case sig of
|
||||
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
||||
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType names typ
|
||||
TypeSig _ names (HsWC _ (HsIB _ typ)) -> layoutNamesAndType Nothing names typ
|
||||
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
|
||||
TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ
|
||||
TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType Nothing names typ
|
||||
#else /* ghc-8.0 */
|
||||
TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ
|
||||
TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType Nothing names typ
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
||||
InlineSig _ name (InlinePragma _ spec _arity phaseAct conlike) ->
|
||||
|
|
@ -121,15 +121,25 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
<> nameStr
|
||||
<> Text.pack " #-}"
|
||||
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
||||
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType names typ
|
||||
ClassOpSig _ False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
|
||||
#elif MIN_VERSION_ghc(8,2,0) /* ghc-8.2 8.4 */
|
||||
ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ
|
||||
ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType Nothing names typ
|
||||
#else /* ghc-8.0 */
|
||||
ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ
|
||||
ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType Nothing names typ
|
||||
#endif
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
PatSynSig _ names (HsIB _ typ) -> layoutNamesAndType (Just "pattern") names typ
|
||||
#elif MIN_VERSION_ghc(8,2,0)
|
||||
PatSynSig names (HsIB _ typ _) -> layoutNamesAndType (Just "pattern") names typ
|
||||
#else
|
||||
PatSynSig name (HsIB _ typ) -> layoutNamesAndType (Just "pattern") [name] typ
|
||||
#endif
|
||||
_ -> briDocByExactNoComment lsig -- TODO
|
||||
where
|
||||
layoutNamesAndType names typ = docWrapNode lsig $ do
|
||||
layoutNamesAndType mKeyword names typ = docWrapNode lsig $ do
|
||||
let keyDoc = case mKeyword of
|
||||
Just key -> [appSep . docLit $ Text.pack key]
|
||||
Nothing -> []
|
||||
nameStrs <- names `forM` lrdrNameToTextAnn
|
||||
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
|
||||
typeDoc <- docSharedWrapper layoutType typ
|
||||
|
|
@ -139,8 +149,8 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
.> _lconfig_hangingTypeSignature
|
||||
.> confUnpack
|
||||
if shouldBeHanging
|
||||
then docSeq
|
||||
[ appSep $ docWrapNodeRest lsig $ docLit nameStr
|
||||
then docSeq $
|
||||
[ appSep $ docWrapNodeRest lsig $ docSeq $ keyDoc <> [docLit nameStr]
|
||||
, docSetBaseY $ docLines
|
||||
[ docCols
|
||||
ColTyOpPrefix
|
||||
|
|
@ -151,7 +161,7 @@ layoutSig lsig@(L _loc sig) = case sig of
|
|||
]
|
||||
else layoutLhsAndType
|
||||
hasComments
|
||||
(appSep . docWrapNodeRest lsig $ docLit nameStr)
|
||||
(appSep . docWrapNodeRest lsig . docSeq $ keyDoc <> [docLit nameStr])
|
||||
"::"
|
||||
typeDoc
|
||||
|
||||
|
|
@ -231,8 +241,18 @@ layoutBind lbind@(L _ bind) = case bind of
|
|||
clauseDocs
|
||||
mWhereArg
|
||||
hasComments
|
||||
#if MIN_VERSION_ghc(8,8,0)
|
||||
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
|
||||
#elif MIN_VERSION_ghc(8,6,0)
|
||||
PatSynBind _ (PSB _ patID lpat rpat dir) -> do
|
||||
#else
|
||||
PatSynBind (PSB patID _ lpat rpat dir) -> do
|
||||
#endif
|
||||
fmap Right $ docWrapNode lbind $ layoutPatSynBind patID
|
||||
lpat
|
||||
dir
|
||||
rpat
|
||||
_ -> Right <$> unknownNodeError "" lbind
|
||||
|
||||
layoutIPBind :: ToBriDoc IPBind
|
||||
layoutIPBind lipbind@(L _ bind) = case bind of
|
||||
#if MIN_VERSION_ghc(8,6,0) /* ghc-8.6 */
|
||||
|
|
@ -709,6 +729,92 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
|||
]
|
||||
++ wherePartMultiLine
|
||||
|
||||
-- | Layout a pattern synonym binding
|
||||
layoutPatSynBind
|
||||
:: Located (IdP GhcPs)
|
||||
-> HsPatSynDetails (Located (IdP GhcPs))
|
||||
-> HsPatSynDir GhcPs
|
||||
-> LPat GhcPs
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutPatSynBind name patSynDetails patDir rpat = do
|
||||
let patDoc = docLit $ Text.pack "pattern"
|
||||
binderDoc = case patDir of
|
||||
ImplicitBidirectional -> docLit $ Text.pack "="
|
||||
_ -> docLit $ Text.pack "<-"
|
||||
body = colsWrapPat =<< layoutPat rpat
|
||||
whereDoc = docLit $ Text.pack "where"
|
||||
mWhereDocs <- layoutPatSynWhere patDir
|
||||
runFilteredAlternative $ do
|
||||
addAlternative $
|
||||
docLines $
|
||||
[ docSeq $ fmap appSep
|
||||
[ patDoc
|
||||
, layoutLPatSyn name patSynDetails
|
||||
, binderDoc, body]
|
||||
<> case mWhereDocs of
|
||||
Just _ -> [whereDoc]
|
||||
Nothing -> []
|
||||
] <> case mWhereDocs of
|
||||
Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x]
|
||||
Nothing -> []
|
||||
|
||||
addAlternative $
|
||||
docLines $
|
||||
[ docSeq $ appSep <$> [ patDoc, layoutLPatSyn name patSynDetails, binderDoc]
|
||||
, docEnsureIndent BrIndentRegular . docSeq
|
||||
$ appSep body : case mWhereDocs of
|
||||
Just _ -> [whereDoc]
|
||||
Nothing -> []
|
||||
] <> case mWhereDocs of
|
||||
Just x -> [docEnsureIndent BrIndentRegular . docSeq $ fmap pure x]
|
||||
Nothing -> []
|
||||
|
||||
-- | Helper method for the left hand side of a pattern synonym
|
||||
layoutLPatSyn
|
||||
:: Located (IdP GhcPs)
|
||||
-> HsPatSynDetails (Located (IdP GhcPs))
|
||||
-> ToBriDocM BriDocNumbered
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
layoutLPatSyn name (PrefixCon vars) = do
|
||||
#else
|
||||
layoutLPatSyn name (PrefixPatSyn vars) = do
|
||||
#endif
|
||||
docName <- lrdrNameToTextAnn name
|
||||
names <- mapM lrdrNameToTextAnn vars
|
||||
docSeq . fmap appSep $ docLit docName : (docLit <$> names)
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
layoutLPatSyn name (InfixCon left right) = do
|
||||
#else
|
||||
layoutLPatSyn name (InfixPatSyn left right) = do
|
||||
#endif
|
||||
leftDoc <- lrdrNameToTextAnn left
|
||||
docName <- lrdrNameToTextAnn name
|
||||
rightDoc <- lrdrNameToTextAnn right
|
||||
docSeq . fmap (appSep . docLit) $ [leftDoc, docName, rightDoc]
|
||||
#if MIN_VERSION_ghc(8,4,0)
|
||||
layoutLPatSyn name (RecCon recArgs) = do
|
||||
#else
|
||||
layoutLPatSyn name (RecordPatSyn recArgs) = do
|
||||
#endif
|
||||
docName <- lrdrNameToTextAnn name
|
||||
args <- mapM (lrdrNameToTextAnn . recordPatSynSelectorId) recArgs
|
||||
docSeq . fmap docLit
|
||||
$ [docName, Text.pack " { " ]
|
||||
<> intersperse (Text.pack ", ") args
|
||||
<> [Text.pack " }"]
|
||||
|
||||
-- | Helper method to get the where clause from of explicitly bidirectional
|
||||
-- pattern synonyms
|
||||
layoutPatSynWhere :: HsPatSynDir GhcPs -> ToBriDocM (Maybe [BriDocNumbered])
|
||||
layoutPatSynWhere hs = case hs of
|
||||
#if MIN_VERSION_ghc(8,6,0)
|
||||
ExplicitBidirectional (MG _ (L _ lbinds) _) -> do
|
||||
#else
|
||||
ExplicitBidirectional (MG (L _ lbinds) _ _ _) -> do
|
||||
#endif
|
||||
binderDoc <- docLit $ Text.pack "="
|
||||
Just <$> mapM (layoutPatternBind Nothing binderDoc) lbinds
|
||||
_ -> pure Nothing
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- TyClDecl
|
||||
|
|
|
|||
Loading…
Reference in New Issue