Implement "how it behaves when there is a list of constraints"

haskell · Apr 9, 2021 · 41ca2df · 41ca2df
1 parent 63e3bbf
commit 41ca2df
Show file tree

Hide file tree

Showing 2 changed files with 48 additions and 6 deletions.
diff --git a/lib/Language/Haskell/Stylish/Step/Signature.hs b/lib/Language/Haskell/Stylish/Step/Signature.hs
@@ -45,17 +45,25 @@ changes cfg m = fmap (formatSignatureDecl cfg m) (topLevelFunctionSignatures m)
 topLevelFunctionSignatures :: Module -> [Located SignatureDecl]
 topLevelFunctionSignatures = queryModule @(Located (HsDecl GhcPs)) \case
   L pos (SigD _ (TypeSig _ [name] (HsWC _ (HsIB _ (L _ funTy@(HsFunTy _ _ _ )))))) ->
-    [L pos $ MkSignatureDecl name (listParameters funTy)]
+    [L pos $ MkSignatureDecl name (listParameters funTy) []]
+  L pos (SigD _ (TypeSig _ [name] (HsWC _ (HsIB _ (L _ (HsQualTy _ (L _ contexts) (L _ funTy))))))) ->
+    [L pos $ MkSignatureDecl name (listParameters funTy) (contexts >>= listContexts)]
   _ -> []
 
 listParameters :: HsType GhcPs -> [Located RdrName]
 listParameters (HsFunTy _ (L _ arg2) (L _ arg3)) = listParameters arg2 <> listParameters arg3
 listParameters (HsTyVar _ _promotionFlag name) = [name]
 listParameters _ = []
 
+listContexts :: Located (HsType GhcPs) -> [Located RdrName]
+listContexts (L _ (HsTyVar _ _ name)) = [name]
+listContexts (L _ (HsAppTy _ arg1 arg2)) = listContexts arg1 <> listContexts arg2
+listContexts _ = []
+
 data SignatureDecl = MkSignatureDecl
   { sigName :: Located RdrName
   , sigParameters :: [Located RdrName]
+  , sigConstraints :: [Located RdrName]
   }
 
 formatSignatureDecl :: Config -> Module -> Located SignatureDecl -> ChangeLine
@@ -74,20 +82,54 @@ printDecl Config{..} m MkSignatureDecl{..} = runPrinter_ printerConfig [] m do
   printRemainingLines
   where
 
+    ----------------------------------------------------------------------------------------
+
     printFirstLine =
       putRdrName sigName >> space >> putText "::" >> newline
 
+    ----------------------------------------------------------------------------------------
+
     printSecondLine =
-      spaces 5 >> (putRdrName $ head sigParameters) >> newline
+      if hasConstraints then printConstraints
+      else printFirstParameter
+
+    printConstraints =
+        spaces 5 >> putText "("
+        >> (traverse (\ctr -> printConstraint ctr >> putText ", ") (init groupConstraints))
+        >> (printConstraint $ last groupConstraints)
+        >> putText ")" >> newline
+
+    groupConstraints = zip (dropEvery sigConstraints 2) (dropEvery (tail sigConstraints) 2)
+
+    printConstraint (tc, tp) = putRdrName tc >> space >> putRdrName tp
+
+    printFirstParameter =
+        spaces 5 >> (putRdrName $ head sigParameters) >> newline
+
+    ----------------------------------------------------------------------------------------
 
     printRemainingLines =
-      traverse printRemainingLine (tail sigParameters)
+      if hasConstraints then
+        printRemainingLine "=>" (head sigParameters)
+        >> traverse (printRemainingLine "->") (tail sigParameters)
+      else
+        traverse (printRemainingLine "->") (tail sigParameters)
+
+    printRemainingLine prefix parameter =
+      spaces 2 >> putText prefix >> space >> (putRdrName parameter) >> newline
 
-    printRemainingLine parameter =
-      spaces 2 >> putText "->" >> space >> (putRdrName parameter) >> newline
+    ----------------------------------------------------------------------------------------
 
     printerConfig = PrinterConfig
       { columns = case cMaxColumns of
           NoMaxColumns -> Nothing
           MaxColumns n -> Just n
       }
+
+    hasConstraints = not $ null sigConstraints
+
+-- 99 problems :)
+dropEvery :: [a] -> Int -> [a]
+dropEvery xs n
+  | length xs < n = xs
+  | otherwise     = take (n-1) xs ++ dropEvery (drop n xs) n
diff --git a/tests/Language/Haskell/Stylish/Step/Signature/Tests.hs b/tests/Language/Haskell/Stylish/Step/Signature/Tests.hs
@@ -14,7 +14,7 @@ tests :: Test
 tests = testGroup "Language.Haskell.Stylish.Step.Signature.Tests"
     [ testCase "do not wrap signature if it fits max column length" case00
     , testCase "wrap signature if it does not fit max column length" case01
-    -- , testCase "how it behaves when there is a list of constraints" case02
+    , testCase "how it behaves when there is a list of constraints" case02
     -- , testCase "how it behaves when there is a explicit forall" case03
     -- , testCase "how it behaves when there is a explicit forall" case04
     -- , testCase "how it behaves when there is a large function in the argument" case05