Merge pull request #11 from mlabs-haskell/bladyjoker/frontend

Frontend

Author: bladyjoker

flake.nix

@@ -75,7 +75,14 @@
             inherit (protosBuild) compilerHsPb;
             inherit (pre-commit-check) shellHook;
           };
-          compilerFlake = compilerBuild.compilerHsNixProj.flake { };
+          compilerFlake = compilerBuild.hsNixProj.flake { };
+
+          frontendBuild = import ./lambda-buffers-frontend/build.nix {
+            inherit pkgs compiler-nix-name index-state haskell-nix mlabs-tooling commonTools;
+            inherit (protosBuild) compilerHsPb;
+            inherit (pre-commit-check) shellHook;
+          };
+          frontendFlake = frontendBuild.hsNixProj.flake { };
 
           # Utilities
           # INFO: Will need this; renameAttrs = rnFn: pkgs.lib.attrsets.mapAttrs' (n: value: { name = rnFn n; inherit value; });
@@ -85,14 +92,15 @@
           inherit pkgs;
 
           # Standard flake attributes
-          packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages;
+          packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages // frontendFlake.packages;
 
           devShells = rec {
             dev-pre-commit = preCommitDevShell;
             dev-experimental = experimentalDevShell;
             dev-docs = docsDevShell;
             dev-protos = protosBuild.devShell;
             dev-compiler = compilerFlake.devShell;
+            dev-frontend = frontendFlake.devShell;
             default = preCommitDevShell;
           };
 

lambda-buffers-compiler/build.nix

@@ -27,7 +27,7 @@ let
           allComponent.doHaddock = true;
 
           # Enable strict compilation
-          allComponent.configureFlags = [ "-f-dev" ];
+          lambda-buffers-compiler.configureFlags = [ "-f-dev" ];
         };
       })
     ];
@@ -40,10 +40,6 @@ let
 
       nativeBuildInputs = builtins.attrValues commonTools;
 
-      additional = ps: [
-        ps.lambda-buffers-compiler-pb
-      ];
-
       tools = {
         cabal = { };
         haskell-language-server = { };
@@ -59,7 +55,7 @@ let
   };
 in
 {
-  compilerHsNixProj = haskell-nix.cabalProject' [
+  hsNixProj = haskell-nix.cabalProject' [
     mlabs-tooling.lib.mkHackageMod
     project
   ];

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

@@ -79,34 +79,24 @@ common common-language
 
   default-language:   Haskell2010
 
-common common-dependencies
-  build-depends:
-    , base          >=4.16
-    , containers    >=0.6
-    , lens          >=5.2
-    , proto-lens    >=0.7
-    , text          >=1.2
-    , transformers  >=0.5
-
 library
   import:          common-language
-  import:          common-dependencies
   build-depends:
-    , containers                  >=0.6
+    , base                        >=4.16
     , freer-simple                >=1.2
     , lambda-buffers-compiler-pb  >=0.1.0.0
-    , mtl                         >=2.2
+    , lens                        >=5.2
     , prettyprinter               >=1.7
+    , text                        >=1.2
 
   exposed-modules:
     LambdaBuffers.Compiler.KindCheck
     LambdaBuffers.Compiler.KindCheck.Inference
 
   hs-source-dirs:  src
 
-executable lambda-buffers-compiler
+executable lambda-buffers-compiler-cli
   import:         common-language
-  import:         common-dependencies
   main-is:        Main.hs
   build-depends:
     , base                        >=4.16
@@ -118,18 +108,13 @@ executable lambda-buffers-compiler
 
 test-suite tests
   import:         common-language
-  import:         common-dependencies
   type:           exitcode-stdio-1.0
   hs-source-dirs: test
   main-is:        Test.hs
   build-depends:
-    , hedgehog                 >=1
+    , base                     >=4.16
     , lambda-buffers-compiler
-    , QuickCheck               >=2
     , tasty                    >=1.4
-    , tasty-expected-failure   >=0.12
-    , tasty-hedgehog           >=1.4
     , tasty-hunit              >=0.10
-    , tasty-quickcheck         >=0.10
 
   other-modules:  Test.KindCheck

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

@@ -18,7 +18,7 @@ import Control.Lens (folded, makeLenses, to, (&), (.~), (^.), (^..))
 import Control.Monad.Freer (Eff, interpret, run)
 import Control.Monad.Freer.Error (Error, runError, throwError)
 import Control.Monad.Freer.TH (makeEffect)
-import Data.Text (Text, unpack)
+import Data.Text (Text, intercalate, unpack)
 import LambdaBuffers.Compiler.KindCheck.Inference (
   Context,
   InferErr,
@@ -32,7 +32,7 @@ import Control.Monad (void)
 import Data.Traversable (for)
 import Proto.Compiler (
   Product'NTuple,
-  Product'Product (Product'Empty', Product'Ntuple, Product'Record'),
+  Product'Product (Product'Ntuple, Product'Record'),
   Product'Record,
   Sum,
   Ty,
@@ -54,6 +54,7 @@ import Proto.Compiler_Fields as PF (
   maybe'tyRef,
   moduleName,
   name,
+  parts,
   product,
   tyAbs,
   tyArgs,
@@ -171,7 +172,6 @@ sumToType sumT = do
     for
       products
       $ \case
-        Just (Product'Empty' _) -> pure $ Var "()"
         Just (Product'Ntuple nt) -> nTupleToType nt
         Just (Product'Record' re) -> recordToType re
         Nothing -> throwError $ InvalidProto "Every constructor should have a product defining it"
@@ -236,5 +236,5 @@ tyRefToType :: TyRef -> Eff KindCheckFailEff Type
 tyRefToType tR = do
   case tR ^. maybe'tyRef of
     Just (TyRef'LocalTyRef t) -> pure $ Var $ t ^. tyName . name . to unpack
-    Just (TyRef'ForeignTyRef t) -> pure $ Var $ (t ^. moduleName . name . to unpack) <> "." <> (t ^. tyName . name . to unpack)
+    Just (TyRef'ForeignTyRef t) -> pure $ Var $ (t ^. moduleName . parts . to (\ps -> unpack $ intercalate "." [p ^. name | p <- ps])) <> "." <> (t ^. tyName . name . to unpack)
     Nothing -> throwError $ InvalidProto "TyRef Cannot be empty"

lambda-buffers-compiler/test/Test.hs

@@ -1,9 +1,7 @@
-{-# LANGUAGE ImportQualifiedPost #-}
-
 module Main (main) where
 
 import Test.KindCheck qualified as KC
-import Test.Tasty
+import Test.Tasty (defaultMain, testGroup)
 
 main :: IO ()
-main = defaultMain $ testGroup "All Tests" [KC.test]
+main = defaultMain $ testGroup "Compiler tests" [KC.test]

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

@@ -1,36 +1,48 @@
-{-# OPTIONS_GHC -Wno-missing-signatures #-}
-
 module Test.KindCheck (test) where
 
-import LambdaBuffers.Compiler.KindCheck
-import LambdaBuffers.Compiler.KindCheck.Inference
-import Test.Tasty
-import Test.Tasty.HUnit
+import LambdaBuffers.Compiler.KindCheck (
+  KindCheckFailure (InferenceFailed),
+  TypeDefinition (TypeDefinition, _td'name, _td'sop, _td'variables),
+  kindCheckType,
+  runKindCheckEff,
+ )
+import LambdaBuffers.Compiler.KindCheck.Inference (
+  InferErr (ImpossibleUnificationErr),
+  Kind (Type, (:->:)),
+  Type (Abs, App, Var),
+ )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, (@?=))
 
 test :: TestTree
-test = testGroup "KindChecker Tests" [t1, t2, t3, t4, t5]
+test = testGroup "KindChecker tests" [t1, t2, t3, t4, t5]
 
 runKC :: [TypeDefinition] -> Either KindCheckFailure [Kind]
 runKC = runKindCheckEff . kindCheckType
 
+t1 :: TestTree
 t1 =
-  testCase "No Definition, No Kinds." $
+  testCase "No Definition, No Kinds" $
     runKC [] @?= Right []
 
+t2 :: TestTree
 t2 =
-  testCase "Maybe has the correct Kind." $
+  testCase "Maybe has the correct Kind" $
     runKC [tdMaybe] @?= Right [Type :->: Type]
 
+t3 :: TestTree
 t3 =
-  testCase "Maybe works correctly when used as a type." $
+  testCase "Maybe works correctly when used as a type" $
     runKC [tdT1, tdMaybe] @?= Right [Type :->: Type, Type :->: Type]
 
+t4 :: TestTree
 t4 =
-  testCase "Maybe and a term containing a maybe work correctly." $
+  testCase "Maybe and a term containing a maybe work correctly" $
     runKC [tdT1, tdMaybe, tdT2] @?= Right [Type :->: Type, Type :->: Type, Type :->: Type]
 
+t5 :: TestTree
 t5 =
-  testCase "Bad Type is caught and reported." $
+  testCase "Bad Type is caught and reported" $
     runKC [tdMaybe, tdBT0]
       @?= Left
         ( InferenceFailed
@@ -46,6 +58,7 @@ t5 =
 --------------------------------------------------------------------------------
 -- Manual type definitions.
 
+tdMaybe :: TypeDefinition
 tdMaybe =
   TypeDefinition
     { _td'name = "Maybe"
@@ -58,6 +71,7 @@ tdMaybe =
     }
 
 -- T1 ~ T a = T Maybe (Maybe a)
+tdT1 :: TypeDefinition
 tdT1 =
   TypeDefinition
     { _td'name = "T"
@@ -66,6 +80,7 @@ tdT1 =
     }
 
 -- T2 ~ T a = T Maybe (Maybe a)
+tdT2 :: TypeDefinition
 tdT2 =
   TypeDefinition
     { _td'name = "T2"
@@ -74,6 +89,7 @@ tdT2 =
     }
 
 -- T2 ~ T = T Maybe Maybe
+tdBT0 :: TypeDefinition
 tdBT0 =
   TypeDefinition
     { _td'name = "T"

lambda-buffers-frontend/.envrc

@@ -0,0 +1 @@
+use flake ..#dev-frontend

lambda-buffers-frontend/app/LambdaBuffers/Frontend/Cli/Compile.hs

@@ -0,0 +1,26 @@
+module LambdaBuffers.Frontend.Cli.Compile (CompileOpts (..), compile) where
+
+import Control.Lens (makeLenses, (^.))
+import Data.Map qualified as Map
+import LambdaBuffers.Frontend (runFrontend)
+import LambdaBuffers.Frontend.PPrint ()
+import Prettyprinter (Pretty (pretty))
+import Proto.Compiler ()
+
+data CompileOpts = CompileOpts
+  { _importPaths :: [FilePath]
+  , _moduleFilepath :: FilePath
+  }
+  deriving stock (Eq, Show)
+
+makeLenses ''CompileOpts
+
+-- | Compile a filepath containing a LambdaBuffers module
+compile :: CompileOpts -> IO ()
+compile opts = do
+  errOrMod <- runFrontend (opts ^. importPaths) (opts ^. moduleFilepath)
+  case errOrMod of
+    Left err -> print err
+    Right mods -> do
+      putStrLn "OK"
+      putStrLn $ "Compiler closure contains the following modules: " <> (show . pretty . Map.elems $ mods)

lambda-buffers-frontend/app/LambdaBuffers/Frontend/Cli/Format.hs

@@ -0,0 +1,29 @@
+module LambdaBuffers.Frontend.Cli.Format (FormatOpts (..), format) where
+
+import Control.Lens (makeLenses, (^.))
+import Data.Text.IO qualified as Text
+import LambdaBuffers.Frontend.PPrint ()
+import LambdaBuffers.Frontend.Parsec qualified as Parsec
+import Prettyprinter (Pretty (pretty))
+import Proto.Compiler ()
+
+data FormatOpts = FormatOpts
+  { _moduleFilepath :: FilePath
+  , _inPlace :: Bool
+  }
+  deriving stock (Eq, Show)
+
+makeLenses ''FormatOpts
+
+-- | Format a LambdaBuffers file
+format :: FormatOpts -> IO ()
+format opts = do
+  modContent <- Text.readFile (opts ^. moduleFilepath)
+  modOrErr <- Parsec.runParser Parsec.parseModule (opts ^. moduleFilepath) modContent
+  case modOrErr of
+    Left err -> print err
+    Right m -> do
+      let formatted = show . pretty $ m
+      if opts ^. inPlace
+        then Prelude.writeFile (opts ^. moduleFilepath) formatted
+        else Prelude.putStrLn formatted