Work-in-progress commit (deriving clause..)
Lennart Spitzner
Evan Rutledge Borden
parent
172866755c
commit
4f827491da
|
|
@ -1163,6 +1163,12 @@ foo = Reflex.runSpiderHost $ ReflexHost.hostApp $ do
|
|||
liftIO . forkIO . forever $ getLine >>= inputFire
|
||||
ReflexHost.performEvent_ $ fmap (liftIO . putStrLn) inputEvent
|
||||
|
||||
#test issue 15
|
||||
-- Test.hs
|
||||
module Test where
|
||||
|
||||
data X = X
|
||||
|
||||
#test issue 16
|
||||
foldrDesc f z = unSwitchQueue $ \q ->
|
||||
switch (Min.foldrDesc (f unTaggedF) z q) (Min.foldrAsc (f unTaggedF) z q)
|
||||
|
|
|
|||
|
|
@ -39,96 +39,163 @@ layoutDataDecl
|
|||
-> HsDataDefn RdrName
|
||||
-> ToBriDocM BriDocNumbered
|
||||
layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
|
||||
|
||||
HsDataDefn NewType (L _ []) _ctype Nothing [cons] mDerivs -> case cons of
|
||||
(L _ (ConDeclH98 consName Nothing (Just (L _ [])) details _)) ->
|
||||
docWrapNode ld $ do
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
tyVarDocs <- bndrs `forM` \case
|
||||
(L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)
|
||||
(L _ (KindedTyVar lrdrName kind)) -> do
|
||||
d <- docSharedWrapper layoutType kind
|
||||
return $ (lrdrNameToText lrdrName, Just $ d)
|
||||
tyVarLine <-
|
||||
fmap return
|
||||
$ docSeq
|
||||
$ List.intersperse docSeparator
|
||||
$ tyVarDocs
|
||||
<&> \(vname, mKind) -> case mKind of
|
||||
Nothing -> docLit vname
|
||||
Just kind -> docSeq
|
||||
[ docLit (Text.pack "(")
|
||||
, docLit vname
|
||||
, docSeparator
|
||||
, kind
|
||||
, docLit (Text.pack ")")
|
||||
]
|
||||
headDoc <- fmap return $ docSeq
|
||||
tyVarLine <- fmap return $ createBndrDoc bndrs
|
||||
-- headDoc <- fmap return $ docSeq
|
||||
-- [ appSep $ docLit (Text.pack "newtype")
|
||||
-- , appSep $ docLit nameStr
|
||||
-- , appSep tyVarLine
|
||||
-- ]
|
||||
rhsDoc <- fmap return $ createDetailsDoc consNameStr details
|
||||
createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLit (Text.pack "newtype")
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeparator
|
||||
, docLit (Text.pack "=")
|
||||
, docSeparator
|
||||
, rhsDoc
|
||||
]
|
||||
rhsDoc <- fmap return $ 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
|
||||
]
|
||||
let
|
||||
mainDoc =
|
||||
docSeq
|
||||
[ headDoc
|
||||
, docSeparator
|
||||
, docLit (Text.pack "=")
|
||||
, docSeparator
|
||||
, rhsDoc
|
||||
]
|
||||
case mDerivs of
|
||||
Nothing -> mainDoc
|
||||
Just (L _ [(HsIB _ t)]) -> do
|
||||
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
|
||||
[docLit $ Text.pack "deriving", docSeparator, layoutType t]
|
||||
Just (L _ ts ) -> do
|
||||
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
|
||||
[ docLit $ Text.pack "deriving"
|
||||
, docSeparator
|
||||
, docLit $ Text.pack "("
|
||||
, docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) ->
|
||||
layoutType t
|
||||
, docLit $ Text.pack ")"
|
||||
]
|
||||
_ -> briDocByExactNoComment ld
|
||||
_ -> briDocByExact ld
|
||||
|
||||
-- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do
|
||||
-- -- _ name vars ctxt ctype mKindSig conss derivs
|
||||
-- nameStr <- lrdrNameToTextAnn name
|
||||
-- docLit nameStr
|
||||
HsDataDefn DataType (L _ lhsContext) _ctype Nothing [] mDerivs ->
|
||||
docWrapNode ld $ do
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
tyVarLine <- fmap return $ createBndrDoc bndrs
|
||||
createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLit (Text.pack "data")
|
||||
, lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
]
|
||||
|
||||
HsDataDefn DataType (L _ lhsContext) _ctype Nothing [cons] mDerivs ->
|
||||
case cons of
|
||||
(L _ (ConDeclH98 consName mForall mRhsContext details _)) ->
|
||||
docWrapNode ld $ do
|
||||
lhsContextDoc <- docSharedWrapper createContextDoc lhsContext
|
||||
nameStr <- lrdrNameToTextAnn name
|
||||
consNameStr <- lrdrNameToTextAnn consName
|
||||
tyVarLine <- fmap return $ createBndrDoc bndrs
|
||||
forallDoc <- docSharedWrapper createForallDoc mForall
|
||||
rhsContextDoc <- case mRhsContext of
|
||||
Nothing -> return docEmpty
|
||||
Just (L _ ctxt) -> docSharedWrapper createContextDoc ctxt
|
||||
rhsDoc <- fmap return $ createDetailsDoc consNameStr details
|
||||
createDerivingPar mDerivs $ docSeq
|
||||
[ appSep $ docLit (Text.pack "data")
|
||||
, lhsContextDoc
|
||||
, appSep $ docLit nameStr
|
||||
, appSep tyVarLine
|
||||
, docSeparator
|
||||
, docLit (Text.pack "=")
|
||||
, docSeparator
|
||||
, forallDoc
|
||||
, rhsContextDoc
|
||||
, rhsDoc
|
||||
]
|
||||
_ -> briDocByExact ld
|
||||
|
||||
_ -> briDocByExactNoComment ld
|
||||
where
|
||||
createContextDoc :: HsContext RdrName -> ToBriDocM BriDocNumbered
|
||||
createContextDoc [] = docEmpty
|
||||
createContextDoc [t] =
|
||||
docSeq [layoutType t, docSeparator, docLit (Text.pack "=>"), docSeparator]
|
||||
createContextDoc ts = docSeq
|
||||
[ docLit (Text.pack "(")
|
||||
, docSeq $ List.intersperse docCommaSep (layoutType <$> ts)
|
||||
, docLit (Text.pack ") =>")
|
||||
, docSeparator
|
||||
]
|
||||
createBndrDoc :: [LHsTyVarBndr RdrName] -> ToBriDocM BriDocNumbered
|
||||
createBndrDoc bs = do
|
||||
tyVarDocs <- bs `forM` \case
|
||||
(L _ (UserTyVar vname)) -> return $ (lrdrNameToText vname, Nothing)
|
||||
(L _ (KindedTyVar lrdrName kind)) -> do
|
||||
d <- docSharedWrapper layoutType kind
|
||||
return $ (lrdrNameToText lrdrName, Just $ d)
|
||||
docSeq
|
||||
$ List.intersperse docSeparator
|
||||
$ tyVarDocs
|
||||
<&> \(vname, mKind) -> case mKind of
|
||||
Nothing -> docLit vname
|
||||
Just kind -> docSeq
|
||||
[ docLit (Text.pack "(")
|
||||
, docLit vname
|
||||
, docSeparator
|
||||
, docLit (Text.pack "::")
|
||||
, docSeparator
|
||||
, kind
|
||||
, docLit (Text.pack ")")
|
||||
]
|
||||
createDerivingPar
|
||||
:: HsDeriving RdrName
|
||||
-> ToBriDocM BriDocNumbered
|
||||
-> ToBriDocM BriDocNumbered
|
||||
createDerivingPar mDerivs mainDoc = do
|
||||
case mDerivs of
|
||||
Nothing -> docLines [mainDoc]
|
||||
Just (L _ [(HsIB _ t)]) -> do
|
||||
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
|
||||
[docLit $ Text.pack "deriving", docSeparator, layoutType t]
|
||||
Just (L _ ts ) -> do
|
||||
docAddBaseY BrIndentRegular $ docPar mainDoc $ docSeq
|
||||
[ docLit $ Text.pack "deriving"
|
||||
, docSeparator
|
||||
, docLit $ Text.pack "("
|
||||
, docSeq $ List.intersperse docCommaSep $ ts <&> \(HsIB _ t) ->
|
||||
layoutType t
|
||||
, 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
|
||||
]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue