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

Merge pull request #187 from ruhatch/master 

Add instance formatting, defaulting to ExactPrint in places
pull/189/head
Lennart Spitzner 2018-10-14 00:46:53 +02:00 committed by GitHub
parent 11dc30fbe1 38216cdc02
commit 818768cd4b
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 267 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
src-literatetests/10-tests.blt
View File

@ -905,3 +905,111 @@ import qualified Data.List as L
-- Test
import Test ( test )
###############################################################################
###############################################################################
###############################################################################
#group class.instance
###############################################################################
###############################################################################
###############################################################################
#test simple-instance
instance MyClass Int where
myMethod x = x + 1
#test simple-method-signature
instance MyClass Int where
myMethod :: Int -> Int
myMethod x = x + 1
#test simple-long-method-signature
instance MyClass Int where
myMethod
:: Int
-> Int
-> AReallyLongType
-> AReallyLongType
-> AReallyLongType
-> Int
myMethod x = x + 1
#test simple-two-methods
instance MyClass Int where
myMethod x = x + 1
myMethod2 x = x + 1
#test simple-two-signatures
instance MyClass Int where
myMethod
:: Int
-> Int
-> AReallyLongType
-> AReallyLongType
-> AReallyLongType
-> Int
myMethod x = x + 1
myMethod2 :: Int -> Int
myMethod2 x = x + 1
#test simple-instance-comment
-- | This instance should be commented on
instance MyClass Int where
-- | This method is also comment-worthy
myMethod x = x + 1
#test instance-with-type-family
instance MyClass Int where
type MyType = Int
myMethod :: MyType -> Int
myMethod x = x + 1
#test instance-with-type-family-below-method
instance MyClass Int where
type MyType = String
myMethod :: MyType -> Int
myMethod x = x + 1
type MyType = Int
#test instance-with-data-family
instance MyClass Int where
-- | This data is very important
data MyData = IntData
{ intData :: String
, intData2 :: Int
}
myMethod :: MyData -> Int
myMethod = intData2
#test instance-with-data-family-below-method
instance MyClass Int where
-- | This data is important
data MyData = Test Int Int
myMethod :: MyData -> Int
myMethod = intData2
-- | This data is also important
data MyData2 = IntData
{ intData :: String
-- ^ Interesting field
, intData2 :: Int
}

177
src/Language/Haskell/Brittany/Internal/Layouters/Decl.hs
View File

@ -27,7 +27,7 @@ import Language.Haskell.Brittany.Internal.ExactPrintUtils
import Language.Haskell.Brittany.Internal.Utils
import GHC ( runGhc, GenLocated(L), moduleNameString )
import SrcLoc ( SrcSpan, noSrcSpan )
import SrcLoc ( SrcSpan, noSrcSpan, Located , getLoc, unLoc )
import HsSyn
import Name
import BasicTypes ( InlinePragma(..)
@ -42,7 +42,7 @@ import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Expr
import {-# SOURCE #-} Language.Haskell.Brittany.Internal.Layouters.Stmt
import Language.Haskell.Brittany.Internal.Layouters.Pattern
import Bag ( mapBagM )
import Bag ( mapBagM, bagToList, emptyBag )
@ -65,16 +65,42 @@ layoutDecl d@(L loc decl) = case decl of
(foldedAnnKeys d)
False
(Text.pack str)
InstD (ClsInstD inst) -> withTransformedAnns d $ layoutClsInst (L loc inst)
_ -> briDocByExactNoComment d
layoutSig :: ToBriDoc Sig
layoutSig lsig@(L _loc sig) = case sig of
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
TypeSig names (HsWC _ (HsIB _ typ _)) -> docWrapNode lsig $ do
TypeSig names (HsWC _ (HsIB _ typ _)) -> layoutNamesAndType names typ
#else /* ghc-8.0 */
TypeSig names (HsIB _ (HsWC _ _ typ)) -> docWrapNode lsig $ do
TypeSig names (HsIB _ (HsWC _ _ typ)) -> layoutNamesAndType names typ
#endif
InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec
let phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default
AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] "
let conlikeStr = case conlike of
FunLike -> ""
ConLike -> "CONLIKE "
docLit
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
#if MIN_VERSION_ghc(8,2,0) /* ghc-8.2 */
ClassOpSig False names (HsIB _ typ _) -> layoutNamesAndType names typ
#else /* ghc-8.0 */
ClassOpSig False names (HsIB _ typ) -> layoutNamesAndType names typ
#endif
_ -> briDocByExactNoComment lsig -- TODO
where
layoutNamesAndType names typ = docWrapNode lsig $ do
nameStrs <- names `forM` lrdrNameToTextAnn
let nameStr = Text.intercalate (Text.pack ", ") $ nameStrs
typeDoc <- docSharedWrapper layoutType typ
@ -112,24 +138,7 @@ layoutSig lsig@(L _loc sig) = case sig of
]
)
]
InlineSig name (InlinePragma _ spec _arity phaseAct conlike) ->
docWrapNode lsig $ do
nameStr <- lrdrNameToTextAnn name
specStr <- specStringCompat lsig spec
let phaseStr = case phaseAct of
NeverActive -> "" -- not [] - for NOINLINE NeverActive is
-- in fact the default
AlwaysActive -> ""
ActiveBefore _ i -> "[~" ++ show i ++ "] "
ActiveAfter _ i -> "[" ++ show i ++ "] "
let conlikeStr = case conlike of
FunLike -> ""
ConLike -> "CONLIKE "
docLit
$ Text.pack ("{-# " ++ specStr ++ conlikeStr ++ phaseStr)
<> nameStr
<> Text.pack " #-}"
_ -> briDocByExactNoComment lsig -- TODO
specStringCompat
:: MonadMultiWriter [BrittanyError] m => LSig GhcPs -> InlineSpec -> m String
@ -585,3 +594,127 @@ layoutPatternBindFinal alignmentToken binderDoc mPatDoc clauseDocs mWhereDocs ha
]
]
++ wherePartMultiLine
-- | Layout an @instance@ declaration
--
-- Layout signatures and bindings using the corresponding layouters from the
-- top-level. Layout the instance head, type family instances, and data family
-- instances using ExactPrint.
layoutClsInst :: ToBriDoc ClsInstDecl
layoutClsInst lcid@(L _ cid) = docLines
[ layoutInstanceHead
, docEnsureIndent BrIndentRegular
$ docSortedLines
$ fmap layoutAndLocateSig (cid_sigs cid)
++ fmap layoutAndLocateBind (bagToList $ cid_binds cid)
++ fmap layoutAndLocateTyFamInsts (cid_tyfam_insts cid)
++ fmap layoutAndLocateDataFamInsts (cid_datafam_insts cid)
]
where
layoutInstanceHead :: ToBriDocM BriDocNumbered
layoutInstanceHead =
briDocByExactNoComment $ InstD . ClsInstD . removeChildren <$> lcid
removeChildren :: ClsInstDecl p -> ClsInstDecl p
removeChildren c = c
{ cid_binds = emptyBag
, cid_sigs = []
, cid_tyfam_insts = []
, cid_datafam_insts = []
}
-- | Like 'docLines', but sorts the lines based on location
docSortedLines
:: [ToBriDocM (Located BriDocNumbered)] -> ToBriDocM BriDocNumbered
docSortedLines l =
allocateNode . BDFLines . fmap unLoc . List.sortOn getLoc =<< sequence l
layoutAndLocateSig :: ToBriDocC (Sig GhcPs) (Located BriDocNumbered)
layoutAndLocateSig lsig@(L loc _) = L loc <$> layoutSig lsig
layoutAndLocateBind :: ToBriDocC (HsBind GhcPs) (Located BriDocNumbered)
layoutAndLocateBind lbind@(L loc _) =
L loc <$> (joinBinds =<< layoutBind lbind)
joinBinds
:: Either [BriDocNumbered] BriDocNumbered -> ToBriDocM BriDocNumbered
joinBinds = \case
Left ns -> docLines $ return <$> ns
Right n -> return n
layoutAndLocateTyFamInsts
:: ToBriDocC (TyFamInstDecl GhcPs) (Located BriDocNumbered)
layoutAndLocateTyFamInsts ltfid@(L loc _) =
L loc <$> layoutTyFamInstDecl ltfid
-- | Send to ExactPrint then remove unecessary whitespace
layoutTyFamInstDecl :: ToBriDoc TyFamInstDecl
layoutTyFamInstDecl ltfid =
fmap stripWhitespace <$> briDocByExactNoComment ltfid
layoutAndLocateDataFamInsts
:: ToBriDocC (DataFamInstDecl GhcPs) (Located BriDocNumbered)
layoutAndLocateDataFamInsts ldfid@(L loc _) =
L loc <$> layoutDataFamInstDecl ldfid
-- | Send to ExactPrint then remove unecessary whitespace
layoutDataFamInstDecl :: ToBriDoc DataFamInstDecl
layoutDataFamInstDecl ldfid =
fmap stripWhitespace <$> briDocByExactNoComment ldfid
-- | ExactPrint adds indentation/newlines to @data@/@type@ declarations
stripWhitespace :: BriDocF f -> BriDocF f
stripWhitespace (BDFExternal ann anns b t) =
BDFExternal ann anns b $ stripWhitespace' t
stripWhitespace b = b
-- | This fixes two issues of output coming from Exactprinting
-- associated (data) type decls. Firstly we place the output into docLines,
-- so one newline coming from Exactprint is superfluous, so we drop the
-- first (empty) line. The second issue is Exactprint indents the first
-- member in a strange fashion:
--
-- input:
--
-- > instance MyClass Int where
-- > -- | This data is very important
-- > data MyData = IntData
-- > { intData :: String
-- > , intData2 :: Int
-- > }
--
-- output of just exactprinting the associated data type syntax node
--
-- >
-- > -- | This data is very important
-- > data MyData = IntData
-- > { intData :: String
-- > , intData2 :: Int
-- > }
--
-- To fix this, we strip whitespace from the start of the comments and the
-- first line of the declaration, stopping when we see "data" or "type" at
-- the start of a line. I.e., this function yields
--
-- > -- | This data is very important
-- > data MyData = IntData
-- > { intData :: String
-- > , intData2 :: Int
-- > }
--
-- Downside apart from being a hacky and brittle fix is that this removes
-- possible additional indentation from comments before the first member.
--
-- But the whole thing is just a temporary measure until brittany learns
-- to layout data/type decls.
stripWhitespace' :: Text -> Text
stripWhitespace' t =
Text.intercalate (Text.pack "\n") $ go $ List.drop 1 $ Text.lines t
where
go [] = []
go (line1 : lineR) = case Text.stripStart line1 of
st | isTypeOrData st -> st : lineR
| otherwise -> st : go lineR
isTypeOrData t' =
(Text.pack "type" `Text.isPrefixOf` t')
|| (Text.pack "data" `Text.isPrefixOf` t')

4
stack-8.4.3.yaml Normal file
View File

@ -0,0 +1,4 @@
resolver: lts-12.12
extra-deps:
- ghc-exactprint-0.5.8.1