Add type synonym formatting
parent
9de3564e00
commit
e1b43531a8
|
@ -906,6 +906,100 @@ import qualified Data.List as L
|
||||||
-- Test
|
-- Test
|
||||||
import Test ( test )
|
import Test ( test )
|
||||||
|
|
||||||
|
|
||||||
|
###############################################################################
|
||||||
|
###############################################################################
|
||||||
|
###############################################################################
|
||||||
|
#group type synonyms
|
||||||
|
###############################################################################
|
||||||
|
###############################################################################
|
||||||
|
###############################################################################
|
||||||
|
|
||||||
|
#test simple-synonym
|
||||||
|
|
||||||
|
type MySynonym = String
|
||||||
|
|
||||||
|
#test parameterised-synonym
|
||||||
|
|
||||||
|
type MySynonym a = [a]
|
||||||
|
|
||||||
|
#test long-function-synonym
|
||||||
|
|
||||||
|
-- | Important comment thrown in
|
||||||
|
type MySynonym b a
|
||||||
|
= MySynonym a b -> MySynonym a b -> MyParamType a b -> MyParamType a b
|
||||||
|
|
||||||
|
#test overflowing-function-synonym
|
||||||
|
|
||||||
|
type MySynonym3 b a
|
||||||
|
= MySynonym a b
|
||||||
|
-> MySynonym a b
|
||||||
|
-- ^ RandomComment
|
||||||
|
-> MyParamType a b
|
||||||
|
-> MyParamType a b
|
||||||
|
-> MySynonym2 b a
|
||||||
|
|
||||||
|
#test synonym-with-kind-sig
|
||||||
|
|
||||||
|
type MySynonym (a :: * -> *)
|
||||||
|
= MySynonym a b
|
||||||
|
-> MySynonym a b
|
||||||
|
-> MyParamType a b
|
||||||
|
-> MyParamType a b
|
||||||
|
-> MySynonym2 b a
|
||||||
|
|
||||||
|
#test synonym-with-constraint
|
||||||
|
|
||||||
|
type MySynonym a = Num a => a -> Int
|
||||||
|
|
||||||
|
#test synonym-overflowing-with-constraint
|
||||||
|
|
||||||
|
type MySynonym a
|
||||||
|
= Num a
|
||||||
|
=> AReallyLongTypeName
|
||||||
|
-> AnotherReallyLongTypeName
|
||||||
|
-> AThirdTypeNameToOverflow
|
||||||
|
|
||||||
|
#test synonym-forall
|
||||||
|
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
|
||||||
|
type MySynonym = forall a . [a]
|
||||||
|
|
||||||
|
#test synonym-operator
|
||||||
|
|
||||||
|
type (:+:) a b = (a, b)
|
||||||
|
|
||||||
|
#test synonym-infix
|
||||||
|
|
||||||
|
type a `MySynonym` b = a -> b
|
||||||
|
|
||||||
|
#test synonym-infix-operator
|
||||||
|
|
||||||
|
type a :+: b = (a, b)
|
||||||
|
|
||||||
|
#test synonym-infix-parens
|
||||||
|
|
||||||
|
type (a `Foo` b) c = (a, b, c)
|
||||||
|
|
||||||
|
#test synonym-comments
|
||||||
|
#pending
|
||||||
|
|
||||||
|
type Foo a -- fancy type comment
|
||||||
|
= -- strange comment
|
||||||
|
Int
|
||||||
|
|
||||||
|
#test synonym-type-operators
|
||||||
|
#pending
|
||||||
|
|
||||||
|
type (a :+: b) = (a, b)
|
||||||
|
|
||||||
|
#test synonym-multi-parens
|
||||||
|
#pending
|
||||||
|
|
||||||
|
type ((a :+: b) c) = (a, c)
|
||||||
|
|
||||||
|
|
||||||
###############################################################################
|
###############################################################################
|
||||||
###############################################################################
|
###############################################################################
|
||||||
###############################################################################
|
###############################################################################
|
||||||
|
|
|
@ -26,7 +26,11 @@ import qualified Language.Haskell.GHC.ExactPrint.Types as ExactPrint
|
||||||
import Language.Haskell.Brittany.Internal.ExactPrintUtils
|
import Language.Haskell.Brittany.Internal.ExactPrintUtils
|
||||||
import Language.Haskell.Brittany.Internal.Utils
|
import Language.Haskell.Brittany.Internal.Utils
|
||||||
|
|
||||||
import GHC ( runGhc, GenLocated(L), moduleNameString )
|
import GHC ( runGhc
|
||||||
|
, GenLocated(L)
|
||||||
|
, moduleNameString
|
||||||
|
, AnnKeywordId (..)
|
||||||
|
)
|
||||||
import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
|
import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
|
||||||
import HsSyn
|
import HsSyn
|
||||||
import Name
|
import Name
|
||||||
|
@ -34,6 +38,9 @@ import BasicTypes ( InlinePragma(..)
|
||||||
, Activation(..)
|
, Activation(..)
|
||||||
, InlineSpec(..)
|
, InlineSpec(..)
|
||||||
, RuleMatchInfo(..)
|
, RuleMatchInfo(..)
|
||||||
|
#if MIN_VERSION_ghc(8,2,0)
|
||||||
|
, LexicalFixity(..)
|
||||||
|
#endif
|
||||||
)
|
)
|
||||||
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
|
import Language.Haskell.GHC.ExactPrint.Types ( mkAnnKey )
|
||||||
|
|
||||||
|
@ -43,6 +50,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
|
||||||
import Language.Haskell.Brittany.Internal.Layouters.Pattern
|
import Language.Haskell.Brittany.Internal.Layouters.Pattern
|
||||||
|
|
||||||
import Bag ( mapBagM, bagToList, emptyBag )
|
import Bag ( mapBagM, bagToList, emptyBag )
|
||||||
|
import Data.Char (isUpper)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -52,6 +60,7 @@ layoutDecl d@(L loc decl) = case decl of
|
||||||
ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
|
ValD bind -> withTransformedAnns d $ layoutBind (L loc bind) >>= \case
|
||||||
Left ns -> docLines $ return <$> ns
|
Left ns -> docLines $ return <$> ns
|
||||||
Right n -> return n
|
Right n -> return n
|
||||||
|
TyClD tycl -> withTransformedAnns d $ layoutTyCl (L loc tycl)
|
||||||
InstD (TyFamInstD{}) -> do
|
InstD (TyFamInstD{}) -> do
|
||||||
-- this is a (temporary (..)) workaround for "type instance" decls
|
-- this is a (temporary (..)) workaround for "type instance" decls
|
||||||
-- that do not round-trip through exactprint properly.
|
-- that do not round-trip through exactprint properly.
|
||||||
|
@ -69,6 +78,10 @@ layoutDecl d@(L loc decl) = case decl of
|
||||||
_ -> briDocByExactNoComment d
|
_ -> briDocByExactNoComment d
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Sig
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
layoutSig :: ToBriDoc Sig
|
layoutSig :: ToBriDoc Sig
|
||||||
layoutSig lsig@(L _loc sig) = case sig of
|
layoutSig lsig@(L _loc sig) = case sig of
|
||||||
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
|
||||||
|
@ -168,6 +181,11 @@ layoutGuardLStmt lgstmt@(L _ stmtLR) = docWrapNode lgstmt $ case stmtLR of
|
||||||
]
|
]
|
||||||
_ -> unknownNodeError "" lgstmt -- TODO
|
_ -> unknownNodeError "" lgstmt -- TODO
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- HsBind
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
layoutBind
|
layoutBind
|
||||||
:: ToBriDocC
|
:: ToBriDocC
|
||||||
(HsBindLR GhcPs GhcPs)
|
(HsBindLR GhcPs GhcPs)
|
||||||
|
@ -595,6 +613,91 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
|
||||||
]
|
]
|
||||||
++ wherePartMultiLine
|
++ wherePartMultiLine
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- TyClDecl
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
layoutTyCl :: ToBriDoc TyClDecl
|
||||||
|
layoutTyCl ltycl@(L _loc tycl) = case tycl of
|
||||||
|
#if MIN_VERSION_ghc(8,2,0)
|
||||||
|
SynDecl name vars fixity typ _ -> do
|
||||||
|
let isInfix = case fixity of
|
||||||
|
Prefix -> False
|
||||||
|
Infix -> True
|
||||||
|
#else
|
||||||
|
SynDecl name vars typ _ -> do
|
||||||
|
nameStr <- lrdrNameToTextAnn name
|
||||||
|
let isInfixTypeOp = case Text.uncons nameStr of
|
||||||
|
Nothing -> False
|
||||||
|
Just (c, _) -> not (c == '(' || isUpper c)
|
||||||
|
isInfix <- (isInfixTypeOp ||) <$> hasAnnKeyword name AnnBackquote
|
||||||
|
#endif
|
||||||
|
docWrapNode ltycl $ layoutSynDecl isInfix name (hsq_explicit vars) typ
|
||||||
|
_ -> briDocByExactNoComment ltycl
|
||||||
|
|
||||||
|
layoutSynDecl
|
||||||
|
:: Bool
|
||||||
|
-> Located (IdP GhcPs)
|
||||||
|
-> [LHsTyVarBndr GhcPs]
|
||||||
|
-> LHsType GhcPs
|
||||||
|
-> ToBriDocM BriDocNumbered
|
||||||
|
layoutSynDecl isInfix name vars typ = do
|
||||||
|
nameStr <- lrdrNameToTextAnn name
|
||||||
|
let
|
||||||
|
lhs = if isInfix
|
||||||
|
then do
|
||||||
|
let
|
||||||
|
(a : b : rest) = vars
|
||||||
|
-- This isn't quite right, but does give syntactically valid results
|
||||||
|
hasParens = not $ null rest
|
||||||
|
docSeq
|
||||||
|
$ [ appSep $ docLit $ Text.pack "type"
|
||||||
|
, appSep
|
||||||
|
. docSeq
|
||||||
|
$ [ docParenL | hasParens ]
|
||||||
|
++ [ appSep $ layoutTyVarBndr a
|
||||||
|
, appSep $ docLit nameStr
|
||||||
|
, layoutTyVarBndr b
|
||||||
|
]
|
||||||
|
++ [ docParenR | hasParens ]
|
||||||
|
]
|
||||||
|
++ fmap (appSep . layoutTyVarBndr) rest
|
||||||
|
else
|
||||||
|
docSeq
|
||||||
|
$ [appSep $ docLit $ Text.pack "type", appSep $ docLit nameStr]
|
||||||
|
++ fmap (appSep . layoutTyVarBndr) vars
|
||||||
|
typeDoc <- docSharedWrapper layoutType typ
|
||||||
|
docAlt
|
||||||
|
[ docSeq [lhs, appSep $ docLit $ Text.pack "=", docForceSingleline typeDoc]
|
||||||
|
, docAddBaseY BrIndentRegular $ docPar
|
||||||
|
lhs
|
||||||
|
(docCols
|
||||||
|
ColTyOpPrefix
|
||||||
|
[docLit $ Text.pack "= ", docAddBaseY (BrIndentSpecial 2) typeDoc]
|
||||||
|
)
|
||||||
|
]
|
||||||
|
|
||||||
|
layoutTyVarBndr :: ToBriDoc HsTyVarBndr
|
||||||
|
layoutTyVarBndr (L _ bndr) = case bndr of
|
||||||
|
UserTyVar name -> do
|
||||||
|
nameStr <- lrdrNameToTextAnn name
|
||||||
|
docLit nameStr
|
||||||
|
KindedTyVar name kind -> do
|
||||||
|
nameStr <- lrdrNameToTextAnn name
|
||||||
|
docSeq
|
||||||
|
[ docLit $ Text.pack "("
|
||||||
|
, appSep $ docLit nameStr
|
||||||
|
, appSep . docLit $ Text.pack "::"
|
||||||
|
, docForceSingleline $ layoutType kind
|
||||||
|
, docLit $ Text.pack ")"
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- ClsInstDecl
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Layout an @instance@ declaration
|
-- | Layout an @instance@ declaration
|
||||||
--
|
--
|
||||||
-- Layout signatures and bindings using the corresponding layouters from the
|
-- Layout signatures and bindings using the corresponding layouters from the
|
||||||
|
|
|
@ -1,3 +1,8 @@
|
||||||
|
#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
module Language.Haskell.Brittany.Internal.Prelude
|
module Language.Haskell.Brittany.Internal.Prelude
|
||||||
( module E
|
( module E
|
||||||
, module Language.Haskell.Brittany.Internal.Prelude
|
, module Language.Haskell.Brittany.Internal.Prelude
|
||||||
|
@ -400,5 +405,8 @@ todo = error "todo"
|
||||||
|
|
||||||
|
|
||||||
#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */
|
#if !MIN_VERSION_ghc(8,4,0) /* ghc-8.0, ghc-8.2 */
|
||||||
|
type family IdP p
|
||||||
|
type instance IdP GhcPs = RdrName
|
||||||
|
|
||||||
type GhcPs = RdrName
|
type GhcPs = RdrName
|
||||||
#endif
|
#endif
|
||||||
|
|
Loading…
Reference in New Issue