Merge pull request #44 from mlabs-haskell/compiler/typeclass-utils

Compiler/typeclass utils

Author: gnumonik

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

@@ -120,11 +120,14 @@ library
     LambdaBuffers.Compiler.ProtoCompat
     LambdaBuffers.Compiler.ProtoCompat.FromProto
     LambdaBuffers.Compiler.ProtoCompat.Types
-    LambdaBuffers.Compiler.TypeClass.Pat
-    LambdaBuffers.Compiler.TypeClass.Pretty
-    LambdaBuffers.Compiler.TypeClass.Rules
-    LambdaBuffers.Compiler.TypeClass.Solve
     LambdaBuffers.Compiler.TypeClassCheck
+    LambdaBuffers.Compiler.TypeClassCheck.Compat
+    LambdaBuffers.Compiler.TypeClassCheck.Pat
+    LambdaBuffers.Compiler.TypeClassCheck.Pretty
+    LambdaBuffers.Compiler.TypeClassCheck.Rules
+    LambdaBuffers.Compiler.TypeClassCheck.Solve
+    LambdaBuffers.Compiler.TypeClassCheck.Utils
+    LambdaBuffers.Compiler.TypeClassCheck.Validate
 
   hs-source-dirs:  src
 
@@ -150,7 +153,8 @@ test-suite tests
   hs-source-dirs: test
   main-is:        Test.hs
   build-depends:
-    , containers                  >=0.6
+    , containers
+    , generic-lens
     , lambda-buffers-compiler
     , lambda-buffers-compiler-pb  >=0.1
     , proto-lens                  >=0.7
@@ -161,6 +165,7 @@ test-suite tests
     , text                        >=1.2
 
   other-modules:
+    Test.DeriveCheck
     Test.KindCheck
     Test.KindCheck.Errors
     Test.LambdaBuffers.Compiler

lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClass/Pretty.hs

@@ -1,20 +1,33 @@
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles, detectSuperclassCycles') where
+module LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles, detectSuperclassCycles', runDeriveCheck, validateTypeClasses) where
 
 import Control.Lens.Combinators (view)
 import Control.Lens.Operators ((^.))
+import Control.Monad (void)
 import Data.Generics.Labels ()
 import Data.List (foldl')
+import Data.Map (traverseWithKey)
 import Data.Map qualified as M
+import Data.Set qualified as S
 import Data.Text (Text)
+import LambdaBuffers.Compiler.ProtoCompat qualified as P
 import LambdaBuffers.Compiler.ProtoCompat.Types (
   ClassDef (),
   ForeignClassRef (ForeignClassRef),
   LocalClassRef (LocalClassRef),
   TyClassRef (ForeignCI, LocalCI),
  )
+import LambdaBuffers.Compiler.TypeClassCheck.Pretty (spaced, (<//>))
+import LambdaBuffers.Compiler.TypeClassCheck.Utils (
+  Instance,
+  ModuleBuilder (mbInstances),
+  TypeClassError (FailedToSolveConstraints),
+  checkInstance,
+  mkBuilders,
+ )
+import LambdaBuffers.Compiler.TypeClassCheck.Validate (checkDerive)
 import Prettyprinter (
   Doc,
   Pretty (pretty),
@@ -23,6 +36,7 @@ import Prettyprinter (
   line,
   punctuate,
   vcat,
+  (<+>),
  )
 
 data ClassInfo = ClassInfo {ciName :: Text, ciSupers :: [Text]}
@@ -65,3 +79,39 @@ detectSuperclassCycles cds = case detectSuperclassCycles' cds of
   where
     format :: [Text] -> Doc a
     format = hcat . punctuate " => " . map pretty
+
+runDeriveCheck :: P.ModuleName -> ModuleBuilder -> Either TypeClassError ()
+runDeriveCheck mn mb = mconcat <$> traverse go (S.toList $ mbInstances mb)
+  where
+    go :: Instance -> Either TypeClassError ()
+    go i =
+      checkInstance i
+        >> checkDerive mn mb i
+        >>= \case
+          [] -> pure ()
+          xs -> Left $ FailedToSolveConstraints mn xs i
+
+-- ModuleBuilder is suitable codegen input,
+-- and is (relatively) computationally expensive to
+-- construct, so we return it here if successful.
+validateTypeClasses' :: P.CompilerInput -> Either TypeClassError (M.Map P.ModuleName ModuleBuilder)
+validateTypeClasses' ci = do
+  -- detectSuperclassCycles ci
+  moduleBuilders <- mkBuilders ci
+  void $ traverseWithKey runDeriveCheck moduleBuilders
+  pure moduleBuilders
+
+-- maybe use Control.Exception? Tho if we're not gonna catch it i guess this is fine
+validateTypeClasses :: P.CompilerInput -> IO (M.Map P.ModuleName ModuleBuilder)
+validateTypeClasses ci = case validateTypeClasses' ci of
+  Left err -> print (spaced $ pretty err) >> error "\nCompilation aborted due to TypeClass Error"
+  Right mbs -> print (prettyBuilders mbs) >> pure mbs
+
+prettyBuilders :: forall a. M.Map P.ModuleName ModuleBuilder -> Doc a
+prettyBuilders = spaced . vcat . punctuate line . map (uncurry go) . M.toList
+  where
+    go :: P.ModuleName -> ModuleBuilder -> Doc a
+    go mn mb =
+      "MODULE"
+        <+> pretty mn
+        <//> indent 2 (pretty mb)