Merge pull request #23 from mlabs-haskell/common/proto-types-validated

Create Common Proto Types conversion

Author: bladyjoker

flake.nix

@@ -66,23 +66,37 @@
             inherit (pre-commit-check) shellHook;
           };
 
-          # Compiler build
           index-state = "2022-12-01T00:00:00Z";
           compiler-nix-name = "ghc924";
 
-          compilerBuild = import ./lambda-buffers-compiler/build.nix {
-            inherit pkgs compiler-nix-name index-state haskell-nix mlabs-tooling commonTools;
-            inherit (protosBuild) compilerHsPb;
-            inherit (pre-commit-check) shellHook;
+          # Common build abstraction for the components.
+          buildAbstraction = { import-location, additional ? { } }:
+            import import-location ({
+              inherit pkgs compiler-nix-name index-state haskell-nix mlabs-tooling commonTools;
+              inherit (protosBuild) compilerHsPb;
+              inherit (pre-commit-check) shellHook;
+            } // additional);
+
+          # Common Flake abstraction for the components.
+          flakeAbstraction = component-name: component-name.hsNixProj.flake { };
+
+          # Compiler Build
+          compilerBuild = buildAbstraction { import-location = ./lambda-buffers-compiler/build.nix; };
+          compilerFlake = flakeAbstraction compilerBuild;
+
+          # Extras Build
+          extrasBuild = buildAbstraction {
+            import-location = ./lambda-buffers-extras/build.nix;
+            additional = { lambda-buffers-compiler = ./lambda-buffers-compiler; };
           };
-          compilerFlake = compilerBuild.hsNixProj.flake { };
+          extrasFlake = flakeAbstraction extrasBuild;
 
-          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;
+          # Frontend Build
+          frontendBuild = buildAbstraction {
+            import-location = ./lambda-buffers-frontend/build.nix;
+            additional = { lambda-buffers-compiler = ./lambda-buffers-compiler; };
           };
-          frontendFlake = frontendBuild.hsNixProj.flake { };
+          frontendFlake = flakeAbstraction frontendBuild;
 
           # Utilities
           renameAttrs = rnFn: pkgs.lib.attrsets.mapAttrs' (n: value: { name = rnFn n; inherit value; });
@@ -92,7 +106,7 @@
           inherit pkgs;
 
           # Standard flake attributes
-          packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages // frontendFlake.packages;
+          packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages // frontendFlake.packages // extrasFlake.packages;
 
           devShells = rec {
             dev-pre-commit = preCommitDevShell;
@@ -101,11 +115,12 @@
             dev-protos = protosBuild.devShell;
             dev-compiler = compilerFlake.devShell;
             dev-frontend = frontendFlake.devShell;
+            dev-common = extrasFlake.devShell;
             default = preCommitDevShell;
           };
 
           # nix flake check --impure --keep-going --allow-import-from-derivation
-          checks = { inherit pre-commit-check; } // devShells // packages // renameAttrs (n: "check-${n}") (frontendFlake.checks // compilerFlake.checks);
+          checks = { inherit pre-commit-check; } // devShells // packages // renameAttrs (n: "check-${n}") (frontendFlake.checks // compilerFlake.checks // extrasFlake.checks);
 
         }
       ) // {

lambda-buffers-compiler/app/LambdaBuffers/Compiler/Cli/Compile.hs

@@ -0,0 +1,56 @@
+module LambdaBuffers.Compiler.Cli.Compile (CompileOpts (..), compile) where
+
+import Control.Lens (makeLenses)
+import Control.Lens.Getter ((^.))
+import Data.ByteString qualified as BS
+import Data.ProtoLens qualified as Pb
+import Data.ProtoLens.TextFormat qualified as PbText
+import Data.Text.Lazy qualified as Text
+import Data.Text.Lazy.IO qualified as Text
+import LambdaBuffers.Compiler.ProtoCompat (FromProtoErr (NamingError, ProtoError), IsMessage (fromProto, toProto))
+import LambdaBuffers.Compiler.ProtoCompat.Types qualified as ProtoCompat
+import Proto.Compiler (CompilerInput)
+import System.FilePath.Lens (extension)
+
+data CompileOpts = CompileOpts
+  { _input :: FilePath
+  , _output :: FilePath
+  }
+  deriving stock (Eq, Show)
+
+makeLenses ''CompileOpts
+
+-- | Compile LambdaBuffers modules
+compile :: CompileOpts -> IO ()
+compile opts = do
+  compIn <- readCompilerInput (opts ^. input)
+  case fromProto @CompilerInput @ProtoCompat.CompilerInput compIn of
+    Left err -> case err of
+      NamingError ne -> print $ "Encountered a naming error " <> show ne
+      ProtoError pe -> print $ "Encountered a proto error " <> show pe
+    Right compIn' -> do
+      print @String "Successfully processed the CompilerInput"
+      writeCompilerOutput (opts ^. output) (toProto compIn')
+
+  return ()
+
+readCompilerInput :: FilePath -> IO CompilerInput
+readCompilerInput fp = do
+  let ext = fp ^. extension
+  case ext of
+    ".pb" -> do
+      content <- BS.readFile fp
+      return $ Pb.decodeMessageOrDie content
+    ".textproto" -> do
+      content <- Text.readFile fp
+      return $ PbText.readMessageOrDie content
+    _ -> error $ "Unknown CompilerInput format " <> ext
+
+-- FIXME(bladyjoker): Do this properly when you figure out what the CompilerOutput is.
+writeCompilerOutput :: FilePath -> CompilerInput -> IO ()
+writeCompilerOutput fp co = do
+  let ext = fp ^. extension
+  case ext of
+    ".pb" -> BS.writeFile fp (Pb.encodeMessage co)
+    ".textproto" -> Text.writeFile fp (Text.pack . show $ PbText.pprintMessage co)
+    _ -> error $ "Unknown CompilerOutput format " <> ext

lambda-buffers-compiler/app/Main.hs

@@ -1,11 +1,64 @@
 module Main (main) where
 
-import Control.Lens ((&), (.~))
-import Data.ProtoLens.Default (def)
-import Proto.Compiler (CompilerInput)
-import Proto.Compiler_Fields (modules)
+import Control.Applicative ((<**>))
+
+import LambdaBuffers.Compiler.Cli.Compile (CompileOpts (CompileOpts), compile)
+import Options.Applicative (
+  Parser,
+  ParserInfo,
+  command,
+  customExecParser,
+  fullDesc,
+  help,
+  helper,
+  info,
+  long,
+  metavar,
+  prefs,
+  progDesc,
+  short,
+  showHelpOnEmpty,
+  showHelpOnError,
+  strOption,
+  subparser,
+ )
+
+newtype Command
+  = Compile CompileOpts
+
+inputPathP :: Parser FilePath
+inputPathP =
+  strOption
+    ( long "input-file"
+        <> short 'i'
+        <> metavar "FILEPATH"
+        <> help "File to compile (lambdabuffers.compiler.CompilerInput in .textproto format)"
+    )
+
+outputPathP :: Parser FilePath
+outputPathP =
+  strOption
+    ( long "output-file"
+        <> short 'o'
+        <> metavar "FILEPATH"
+        <> help "File to write the output to (lambdabuffers.compiler.CompilerOutput in .textproto format)"
+    )
+
+compileOptsP :: Parser CompileOpts
+compileOptsP = CompileOpts <$> inputPathP <*> outputPathP
+
+optionsP :: Parser Command
+optionsP =
+  subparser $
+    command
+      "compile"
+      (info (Compile <$> compileOptsP <* helper) (progDesc "Compile LambdaBuffers"))
+
+parserInfo :: ParserInfo Command
+parserInfo = info (optionsP <**> helper) (fullDesc <> progDesc "LambdaBuffers Compiler command-line interface tool")
 
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
-  print $ (def :: CompilerInput) & modules .~ []
+  cmd <- customExecParser (prefs (showHelpOnEmpty <> showHelpOnError)) parserInfo
+  case cmd of
+    Compile opts -> compile opts

lambda-buffers-compiler/build.nix

@@ -17,7 +17,7 @@ let
     inherit compiler-nix-name index-state;
 
     extraHackage = [
-      (builtins.toString compilerHsPb)
+      "${compilerHsPb}"
     ];
 
     modules = [

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

@@ -84,14 +84,21 @@ library
   build-depends:
     , base                        >=4.16
     , freer-simple                >=1.2
+    , generic-lens                >=2.2
     , lambda-buffers-compiler-pb  >=0.1.0.0
     , lens                        >=5.2
+    , mtl                         >=2.2
+    , parsec                      >=3.1
     , prettyprinter               >=1.7
+    , proto-lens                  >=0.7
     , text                        >=1.2
 
   exposed-modules:
     LambdaBuffers.Compiler.KindCheck
     LambdaBuffers.Compiler.KindCheck.Inference
+    LambdaBuffers.Compiler.NamingCheck
+    LambdaBuffers.Compiler.ProtoCompat
+    LambdaBuffers.Compiler.ProtoCompat.Types
 
   hs-source-dirs:  src
 
@@ -100,11 +107,16 @@ executable lambda-buffers-compiler-cli
   main-is:        Main.hs
   build-depends:
     , base                        >=4.16
+    , bytestring                  >=0.11
+    , lambda-buffers-compiler
     , lambda-buffers-compiler-pb  >=0.1.0.0
     , lens                        >=5.2
+    , optparse-applicative        >=0.17
     , proto-lens                  >=0.7
+    , text                        >=1.2
 
   hs-source-dirs: app
+  other-modules:  LambdaBuffers.Compiler.Cli.Compile
 
 test-suite tests
   import:         common-language

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

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
-{- | Note: At the moment the Kind Checker disregards multiple Modules for
-simplicity of testing and developing. This will be changed ASAP. :fixme:
+{- | FIXME(cstml): At the moment the Kind Checker disregards multiple Modules for
+simplicity of testing and developing. This will be changed ASAP.
 -}
 module LambdaBuffers.Compiler.KindCheck (
   KindCheckFailure (..),
@@ -44,6 +44,7 @@ import Proto.Compiler (
   TyRef'TyRef (TyRef'ForeignTyRef, TyRef'LocalTyRef),
  )
 import Proto.Compiler_Fields as PF (
+  argName,
   constrName,
   constructors,
   fieldTy,
@@ -61,7 +62,6 @@ import Proto.Compiler_Fields as PF (
   tyBody,
   tyFunc,
   tyName,
-  tyVars,
   varName,
  )
 
@@ -142,7 +142,7 @@ interpretKindCheck = interpret $
 
 validateTyDef :: TyDef -> Eff KindCheckFailEff TypeDefinition
 validateTyDef tD = do
-  let vars = tD ^.. tyAbs . tyVars . folded . varName . name . to unpack
+  let vars = tD ^.. tyAbs . tyArgs . folded . argName . name . to unpack
   sop <- go (tD ^. tyAbs . tyBody . maybe'tyBody)
   pure $
     TypeDefinition

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

@@ -0,0 +1,82 @@
+module LambdaBuffers.Compiler.NamingCheck (pModuleNamePart, pVarName, pTyName, pConstrName, pFieldName, pClassName, checkModuleName, checkTyName, checkVarName, checkConstrName, checkClassName, checkFieldName) where
+
+import Control.Lens ((.~), (^.))
+import Control.Monad.Except (MonadError (throwError))
+import Data.Foldable (for_)
+import Data.Function ((&))
+import Data.Kind (Type)
+import Data.ProtoLens (Message (defMessage))
+import Data.ProtoLens.Field (HasField)
+import Data.String (IsString (fromString))
+import Data.Text (Text)
+import Proto.Compiler (ClassName, ConstrName, FieldName, Module, NamingError, NamingError'NameType (NamingError'NAME_TYPE_CLASS, NamingError'NAME_TYPE_CONSTR, NamingError'NAME_TYPE_FIELD, NamingError'NAME_TYPE_MODULE, NamingError'NAME_TYPE_TYPE, NamingError'NAME_TYPE_VAR), SourceInfo, TyName, VarName)
+import Proto.Compiler_Fields (moduleName, name, nameType, parts, sourceInfo)
+import Text.Parsec (ParsecT, Stream, alphaNum, label, lower, many, many1, runParserT)
+import Text.Parsec.Char (upper)
+
+type Parser :: Type -> (Type -> Type) -> Type -> Type
+type Parser s m a = ParsecT s () m a
+
+pUpperCamelCase :: Stream s m Char => Parser s m Text
+pUpperCamelCase = label' "UpperCamelCase" $ fromString <$> ((:) <$> upper <*> many alphaNum)
+
+pLowerCamelCase :: Stream s m Char => Parser s m Text
+pLowerCamelCase = label' "lowerCamelCase" $ fromString <$> ((:) <$> lower <*> many alphaNum)
+
+pModuleNamePart :: Stream s m Char => Parser s m Text
+pModuleNamePart = label' "module part name" pUpperCamelCase
+
+pVarName :: Stream s m Char => Parser s m Text
+pVarName = label' "type variable name" $ fromString <$> many1 lower
+
+pTyName :: Stream s m Char => Parser s m Text
+pTyName = label' "type name" pUpperCamelCase
+
+pConstrName :: Stream s m Char => Parser s m Text
+pConstrName = label' "sum body constructor name" pUpperCamelCase
+
+pFieldName :: Stream s m Char => Parser s m Text
+pFieldName = label' "record body field name" pLowerCamelCase
+
+pClassName :: Stream s m Char => Parser s m Text
+pClassName = label' "type class name" pUpperCamelCase
+
+label' :: String -> Parser s m a -> Parser s m a
+label' l m = label m l
+
+validateP ::
+  ( MonadError NamingError m
+  , HasField a "sourceInfo" SourceInfo
+  , HasField a "name" Text
+  ) =>
+  Parser Text m Text ->
+  NamingError'NameType ->
+  a ->
+  m ()
+validateP p nt i = do
+  resOrErr <- runParserT p () "" (i ^. name)
+  case resOrErr of
+    Left _ ->
+      throwError $
+        defMessage
+          & nameType .~ nt
+          & sourceInfo .~ (i ^. sourceInfo)
+    Right _ -> return ()
+
+checkModuleName :: MonadError NamingError m => Module -> m ()
+checkModuleName m = for_ (m ^. (moduleName . parts)) (validateP pModuleNamePart NamingError'NAME_TYPE_MODULE)
+
+checkTyName :: MonadError NamingError m => TyName -> m ()
+checkTyName = validateP pTyName NamingError'NAME_TYPE_TYPE
+
+checkVarName :: MonadError NamingError m => VarName -> m ()
+checkVarName = validateP pVarName NamingError'NAME_TYPE_VAR
+
+checkConstrName :: MonadError NamingError m => ConstrName -> m ()
+checkConstrName = validateP pConstrName NamingError'NAME_TYPE_CONSTR
+
+checkFieldName :: MonadError NamingError m => FieldName -> m ()
+checkFieldName = validateP pFieldName NamingError'NAME_TYPE_FIELD
+
+checkClassName :: MonadError NamingError m => ClassName -> m ()
+checkClassName = validateP pClassName NamingError'NAME_TYPE_CLASS