Work-in-progress commit (deriving clause..)

src-literatetests/30-tests-context-free.blt

@@ -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)

src/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs

@@ -39,19 +39,89 @@ 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
+        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
+          ]
+    _ -> briDocByExact ld
+
+  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)
-        tyVarLine   <-
+    docSeq
-          fmap return
-            $   docSeq
       $   List.intersperse docSeparator
       $   tyVarDocs
       <&> \(vname, mKind) -> case mKind of
@@ -60,15 +130,33 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
               [ docLit (Text.pack "(")
               , docLit vname
               , docSeparator
+              , docLit (Text.pack "::")
+              , docSeparator
               , kind
               , docLit (Text.pack ")")
               ]
-        headDoc     <- fmap return $ docSeq
+  createDerivingPar
-          [ appSep $ docLit (Text.pack "newtype")
+    :: HsDeriving RdrName
-          , appSep $ docLit nameStr
+    -> ToBriDocM BriDocNumbered
-          , appSep tyVarLine
+    -> 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 ")"
           ]
-        rhsDoc      <- fmap return $ case details of
+  createDetailsDoc
+    :: Text -> HsConDeclDetails RdrName -> (ToBriDocM BriDocNumbered)
+  createDetailsDoc consNameStr details = case details of
     PrefixCon args         -> docSeq
       [ docLit consNameStr
       , docSeparator
@@ -100,35 +188,14 @@ layoutDataDecl ld name (HsQTvs _ bndrs _) defn = case defn of
       , docSeparator
       , layoutType arg2
       ]
-        let
+  createForallDoc :: Maybe (LHsQTyVars RdrName) -> ToBriDocM BriDocNumbered
-          mainDoc =
+  createForallDoc Nothing                   = docEmpty
+  createForallDoc (Just (HsQTvs _ bs _)) = do
+    tDoc <- fmap return $ createBndrDoc bs
     docSeq
-              [ headDoc
+      [ docLit (Text.pack "forall ")
+      , tDoc
+      , docLit (Text.pack " .")
       , 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
-
-  -- HsDataDefn DataType _ctxt _ctype Nothing _conss _derivs -> do
-  --   -- _ name vars ctxt ctype mKindSig conss derivs
-  --   nameStr <- lrdrNameToTextAnn name
-  --   docLit nameStr
-
-  _ -> briDocByExactNoComment ld