Merge pull request #29 from mlabs-haskell/bladyjoker/compiler-typeclass-check

Compiler: TypeClass checks

Author: gnumonik

lambda-buffers-compiler/lambda-buffers-compiler.cabal

@@ -83,6 +83,7 @@ library
   import:          common-language
   build-depends:
     , base                        >=4.16
+    , containers                  >=0.6
     , freer-simple                >=1.2
     , generic-lens                >=2.2
     , lambda-buffers-compiler-pb  >=0.1.0.0
@@ -99,6 +100,7 @@ library
     LambdaBuffers.Compiler.NamingCheck
     LambdaBuffers.Compiler.ProtoCompat
     LambdaBuffers.Compiler.ProtoCompat.Types
+    LambdaBuffers.Compiler.TypeClassCheck
 
   hs-source-dirs:  src
 
@@ -124,9 +126,15 @@ test-suite tests
   hs-source-dirs: test
   main-is:        Test.hs
   build-depends:
-    , base                     >=4.16
+    , base                        >=4.16
     , lambda-buffers-compiler
-    , tasty                    >=1.4
-    , tasty-hunit              >=0.10
+    , lambda-buffers-compiler-pb  >=0.1
+    , lens                        >=5.2
+    , proto-lens                  >=0.7
+    , tasty                       >=1.4
+    , tasty-hunit                 >=0.10
+    , text                        >=1.2
 
-  other-modules:  Test.KindCheck
+  other-modules:
+    Test.KindCheck
+    Test.TypeClassCheck

lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles, detectSuperclassCycles') where
+
+import Control.Lens.Operators ((^.))
+import Data.Generics.Labels ()
+import Data.List (foldl')
+import Data.Map qualified as M
+import Data.Text (Text)
+import LambdaBuffers.Compiler.ProtoCompat.Types (
+  ClassDef (),
+ )
+import Prettyprinter (
+  Doc,
+  Pretty (pretty),
+  hcat,
+  indent,
+  line,
+  punctuate,
+  vcat,
+ )
+
+data ClassInfo = ClassInfo {ciName :: Text, ciSupers :: [Text]}
+  deriving stock (Show, Eq, Ord)
+
+detectSuperclassCycles' :: [ClassDef] -> [[Text]]
+detectSuperclassCycles' = detectCycles . mkClassGraph . map defToClassInfo
+  where
+    defToClassInfo :: ClassDef -> ClassInfo
+    defToClassInfo cd =
+      ClassInfo (cd ^. #className . #name) $
+        map (\x -> x ^. #className . #name) (cd ^. #supers)
+
+    mkClassGraph :: [ClassInfo] -> M.Map Text [Text]
+    mkClassGraph = foldl' (\acc (ClassInfo nm sups) -> M.insert nm sups acc) M.empty
+
+    detectCycles :: forall k. Ord k => M.Map k [k] -> [[k]]
+    detectCycles m = concatMap (detect []) (M.keys m)
+      where
+        detect :: [k] -> k -> [[k]]
+        detect visited x = case M.lookup x m of
+          Nothing -> []
+          Just xs ->
+            if x `elem` visited
+              then [x : visited]
+              else concatMap (detect (x : visited)) xs
+
+detectSuperclassCycles :: forall a. [ClassDef] -> Maybe (Doc a)
+detectSuperclassCycles cds = case detectSuperclassCycles' cds of
+  [] -> Nothing
+  xs ->
+    Just $
+      "Error: Superclass cycle(s) detected"
+        <> line
+        <> indent 2 (vcat $ map format xs)
+  where
+    format :: [Text] -> Doc a
+    format = hcat . punctuate " => " . map pretty

lambda-buffers-compiler/test/Test.hs

@@ -2,6 +2,13 @@ module Main (main) where
 
 import Test.KindCheck qualified as KC
 import Test.Tasty (defaultMain, testGroup)
+import Test.TypeClassCheck qualified as TC
 
 main :: IO ()
-main = defaultMain $ testGroup "Compiler tests" [KC.test]
+main =
+  defaultMain $
+    testGroup
+      "Compiler tests"
+      [ KC.test
+      , TC.test
+      ]

lambda-buffers-compiler/test/Test/TypeClassCheck.hs

@@ -0,0 +1,72 @@
+module Test.TypeClassCheck (test) where
+
+import Control.Lens ((.~))
+import Data.Function ((&))
+import Data.ProtoLens (Message (defMessage))
+import Data.Text (Text)
+import Data.Traversable (for)
+import LambdaBuffers.Compiler.ProtoCompat (IsMessage (fromProto))
+import LambdaBuffers.Compiler.ProtoCompat.Types qualified as ProtoCompat
+import LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles')
+import Proto.Compiler (ClassDef, Constraint, Kind, Kind'KindRef (Kind'KIND_REF_TYPE))
+import Proto.Compiler_Fields (argKind, argName, arguments, classArgs, className, kindRef, name, supers, tyVar, varName)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))
+
+test :: TestTree
+test =
+  testGroup
+    "TypeClassCheck tests"
+    [ noCycleDetected
+    , cycleDetected
+    ]
+
+noCycleDetected :: TestTree
+noCycleDetected =
+  testCase "No cycle detected" $ do
+    nocycles' <- classDefsFromProto nocycles
+    detectSuperclassCycles' nocycles' @?= []
+
+cycleDetected :: TestTree
+cycleDetected =
+  testCase "Cycle detected" $ do
+    cycles' <- classDefsFromProto cycles
+    detectSuperclassCycles' cycles' @?= [["Bar", "Foo", "Bop", "Bar"], ["Bop", "Bar", "Foo", "Bop"], ["Foo", "Bop", "Bar", "Foo"]]
+
+classDefsFromProto :: [ClassDef] -> IO [ProtoCompat.ClassDef]
+classDefsFromProto cds = for cds (either (\err -> assertFailure $ "FromProto failed with " <> show err) return . fromProto @ClassDef @ProtoCompat.ClassDef)
+
+star :: Kind
+star = defMessage & kindRef .~ Kind'KIND_REF_TYPE
+
+mkclass :: Text -> [Text] -> ClassDef
+mkclass nm sups =
+  defMessage
+    & className . name .~ nm
+    & classArgs
+      .~ [ defMessage
+            & argName . name .~ "a"
+            & argKind .~ star
+         ]
+    & supers .~ map constraint sups
+
+constraint :: Text -> Constraint
+constraint nm =
+  defMessage
+    & className . name .~ nm
+    & arguments .~ [defMessage & tyVar . varName . name .~ "a"]
+
+cycles :: [ClassDef]
+cycles =
+  [ mkclass "Foo" ["Bar", "Baz", "Beep"]
+  , mkclass "Bar" ["Bip", "Bop"]
+  , mkclass "Bop" ["Foo"]
+  ]
+
+nocycles :: [ClassDef]
+nocycles =
+  [ mkclass "Functor" []
+  , mkclass "Applicative" ["Functor"]
+  , mkclass "Monad" ["Applicative"]
+  , mkclass "Traversable" ["Foldable", "Functor"]
+  ]