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

Work in progress, add record formatting tests.

pull/95/head
Evan Rutledge Borden 2017-12-30 21:28:01 -05:00
parent 2dad7f82fe
commit 011b108558
2 changed files with 160 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
src-literatetests/tests-context-free.blt
View File

@ -312,6 +312,47 @@ func = f
f = id f = id
###############################################################################
###############################################################################
###############################################################################
#group data type declarations
###############################################################################
###############################################################################
###############################################################################
#test single record
data Foo = Bar { foo :: Baz }
#test record multiple names
data Foo = Bar { foo, bar :: Baz }
#test record multiple types
data Foo = Bar
{ foo :: Baz
, bar :: Bizzz
}
#test record multiple types and names
data Foo = Bar
{ foo, biz :: Baz
, bar :: Bizzz
}
#test record multiple types deriving
data Foo = Bar
{ foo :: Baz
, bar :: Bizzz
}
deriving Show
#test record multiple types deriving
data Foo = Bar
{ foo :: Baz
, bar :: Bizzz
}
deriving (Show, Eq, Monad, Functor, Traversable, Foldable)
############################################################################### ###############################################################################
############################################################################### ###############################################################################
############################################################################### ###############################################################################

208
src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs
View File

@ -103,99 +103,129 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
_ -> briDocByExact ld _ -> briDocByExact ld
_ -> briDocByExactNoComment ld _ -> briDocByExactNoComment ld
where
createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered
createContextDoc [] = docEmpty createContextDoc [] = docEmpty
createContextDoc [t] = createContextDoc [t] =
docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator] docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator]
createContextDoc ts = docSeq createContextDoc ts = docSeq
[ docLit (Text.pack "(") [ docLit (Text.pack "(")
, docSeq $ List.intersperse docCommaSep (layoutType <$> ts) , docSeq $ List.intersperse docCommaSep (layoutType <$> ts)
, docLit (Text.pack ") =>") , docLit (Text.pack ") =>")
, docSeparator , docSeparator
] ]
createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered
createBndrDoc bs = do createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered
tyVarDocs <- bs `forM` \case createBndrDoc bs = do
(L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing) tyVarDocs <- bs `forM` \case
(L _ (KindedTyVar lrdrName kind)) -> do (L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)
d <- docSharedWrapper layoutType kind (L _ (KindedTyVar lrdrName kind)) -> do
return $ (lrdrNameToText lrdrName, Just $ d) d <- docSharedWrapper layoutType kind
docSeq return $ (lrdrNameToText lrdrName, Just $ d)
$ List.intersperse docSeparator docSeq
$ tyVarDocs $ List.intersperse docSeparator
<&> \(vname, mKind) -> case mKind of $ tyVarDocs
Nothing -> docLit vname <&> \(vname, mKind) -> case mKind of
Just kind -> docSeq Nothing -> docLit vname
[ docLit (Text.pack "(") Just kind -> docSeq
, docLit vname [ docLit (Text.pack "(")
, docSeparator , docLit vname
, docLit (Text.pack "::") , docSeparator
, docSeparator , docLit (Text.pack "::")
, kind , docSeparator
, docLit (Text.pack ")") , kind
] , docLit (Text.pack ")")
createDerivingPar ]
:: HsDeriving RdrName
-> ToBriDocM BriDocNumbered createDerivingPar
-> ToBriDocM BriDocNumbered :: HsDeriving RdrName
createDerivingPar mDerivs mainDoc = do -> ToBriDocM BriDocNumbered
case mDerivs of -> ToBriDocM BriDocNumbered
Nothing -> docLines [mainDoc] createDerivingPar mDerivs mainDoc = do
Just (L _ [(HsIB _ t)]) -> do case mDerivs of
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq Nothing -> docLines [mainDoc]
[docLit $ Text.pack "deriving", docSeparator, layoutType t] Just (L _ [(HsIB _ t)]) -> do
Just (L _ ts ) -> do docAlt
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq [ docPar mainDoc $ docEnsureIndent BrIndentRegular $ docSeq
[ docLit $ Text.pack "deriving" [docDeriving, docSeparator, layoutType t]
]
Just (L _ ts ) -> do
docAlt
[ docPar mainDoc $ docEnsureIndent BrIndentRegular $ docSeq
[ docDeriving
, docSeparator , docSeparator
, docLit $ Text.pack "(" , docLit $ Text.pack "("
, docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) -> , docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) ->
layoutType t layoutType t
, docLit $ Text.pack ")" , docLit $ Text.pack ")"
] ]
createDetailsDoc ]
:: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of
PrefixCon args -> docSeq
[ docLit consNameStr
, docSeparator
, docSeq $ List.intersperse docSeparator $ args <&> layoutType
]
RecCon (L _ fields) -> docSeq
[ appSep $ docLit $ Text.pack "{"
, docSeq
$ List.intersperse docSeparator
$ fields
<&> \(L _ (ConDeclField names t _)) -> do
docSeq
[ docSeq
$ List.intersperse docCommaSep
$ names
<&> \(L _ (FieldOcc fieldName _)) ->
docLit =<< lrdrNameToTextAnn fieldName
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, layoutType t
]
, docLit $ Text.pack "}"
]
InfixCon arg1 arg2 -> docSeq
[ layoutType arg1
, docSeparator
, docLit consNameStr
, docSeparator
, layoutType arg2
]
createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered
createForallDoc Nothing = docEmpty
createForallDoc (Just (HsQTvs _ bs _)) = do
tDoc <- fmap return $ createBndrDoc bs
docSeq
[ docLit (Text.pack "forall ")
, tDoc
, docLit (Text.pack " .")
, docSeparator
]
docDeriving :: ToBriDocM BriDocNumbered
docDeriving = docLit $ Text.pack "deriving"
createDetailsDoc
:: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered)
createDetailsDoc consNameStr details = case details of
PrefixCon args -> docSeq
[ docLit consNameStr
, docSeparator
, docSeq $ List.intersperse docSeparator $ args <&> layoutType
]
RecCon (L _ []) -> docEmpty
RecCon (L _ [L _ (ConDeclField names t _)]) -> docSeq
[ docLit consNameStr
, docSeparator
, appSep $ docLit $ Text.pack "{"
, createNamesAndTypeDoc names t
, docSeparator
, docLit $ Text.pack "}"
]
RecCon (L _ (fstField:fields)) ->
docAddBaseY BrIndentRegular $ docPar
(docLit consNameStr)
(docLines
[ docSeq
[ docLit $ Text.pack "{ "
, let L _ (ConDeclField names t _) = fstField
in createNamesAndTypeDoc names t
]
, docLines
$ (\(L _ (ConDeclField names t _)) ->
docSeq [docCommaSep, createNamesAndTypeDoc names t])
<$> fields
, docLit $ Text.pack "}"
]
)
InfixCon arg1 arg2 -> docSeq
[ layoutType arg1
, docSeparator
, docLit consNameStr
, docSeparator
, layoutType arg2
]
createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered
createForallDoc Nothing = docEmpty
createForallDoc (Just (HsQTvs _ bs _)) = do
tDoc <- fmap return $ createBndrDoc bs
docSeq
[ docLit (Text.pack "forall ")
, tDoc
, docLit (Text.pack " .")
, docSeparator
]
createNamesAndTypeDoc
:: [GenLocated t (FieldOcc u)] -> Located (HsType RdrName) -> ToBriDocM BriDocNumbered
createNamesAndTypeDoc names t = docSeq
[ docSeq
$ List.intersperse docCommaSep
$ names
<&> \(L _ (FieldOcc fieldName _)) ->
docLit =<< lrdrNameToTextAnn fieldName
, docSeparator
, docLit $ Text.pack "::"
, docSeparator
, layoutType t
]