diff --git a/_typos.toml b/_typos.toml index d34cfe96..4a1f2e9e 100644 --- a/_typos.toml +++ b/_typos.toml @@ -1,5 +1,6 @@ [default.extend-words] substituters = "substituters" +hask= "hask" [type.pdf] extend-glob = ["*.pdf"] diff --git a/experimental/prolog/class_check.pl b/experimental/prolog/class_check.pl index 023a4d49..41013b58 100644 --- a/experimental/prolog/class_check.pl +++ b/experimental/prolog/class_check.pl @@ -38,30 +38,47 @@ %% Structural rules for types of kind `*` struct_rule(class(ClassName, class_arg(_, kind(*)), _), Rule) :- member(Rule, [ - (rule(ClassName, opaque(_, kind(*), _)) :- true), - (rule(ClassName, ty_ref(unit)) :- true), - (rule(ClassName, ty_ref(void)) :- true), - (rule(ClassName, ty_app(ty_app(ty_ref(prod), A), B)) :- + (goal(ClassName, opaque(_, kind(*), _)) :- true), + (goal(ClassName, ty_ref(unit)) :- true), + (goal(ClassName, ty_ref(void)) :- true), + (goal(ClassName, ty_app(ty_app(ty_ref(prod), A), B)) :- ( - rule(ClassName, A), - rule(ClassName, B) + goal(ClassName, A), + goal(ClassName, B) )), - (rule(ClassName, ty_app(ty_app(ty_ref(either), A), B)) :- + (goal(ClassName, ty_app(ty_app(ty_ref(either), A), B)) :- ( - rule(ClassName, A), - rule(ClassName, B) + goal(ClassName, A), + goal(ClassName, B) )) ]). +conj(Goal, (Goal, Conj), Conj). + +superclass_goal(Ty, Cl_, Conj) :- + copy_term(Cl_, Cl), + class(_ClassName, class_arg(Ty, _K), ClassSups) = Cl, + findall(R, ( + member(Sup_, ClassSups), + copy_term(Sup_, Sup), + Sup =.. [SupName, Ty], + R = goal(SupName, Ty) + ), + Rules), + foldl(conj, Rules, Conj, true). + + %% User specifiable `derive` rules (the same for any kind?) %% NOTE(bladyjoker): TyAbs can't be derived for non `*` kinds. -derive_rule(ty_ref(RefName), class(ClassName, _, _), Rule) :- +derive_rule(ty_ref(RefName), class(ClassName, ClassArgs, ClassSups), Rule) :- ty_def(RefName, Ty), - Rule = (rule(ClassName, ty_ref(RefName)) :- rule(ClassName, Ty)). + superclass_goal(ty_ref(RefName), class(ClassName, ClassArgs, ClassSups), SupGoals), + Rule = (goal(ClassName, ty_ref(RefName)) :- goal(ClassName, Ty), SupGoals). -derive_rule(ty_app(F, A), class(ClassName, _, _), Rule) :- +derive_rule(ty_app(F, A), class(ClassName, ClassArgs, ClassSups), Rule) :- apply(F, A, Res), - Rule = (rule(ClassName, ty_app(F, A)) :- rule(ClassName, Res)). + superclass_goal(ty_app(F, A), class(ClassName, ClassArgs, ClassSups), SupGoals), + Rule = (goal(ClassName, ty_app(F, A)) :- goal(ClassName, Res), SupGoals). %% Experimental structural rules for types of kind * -> * % Haskell: Functor Deriving https://mail.haskell.org/pipermail/haskell-prime/2007-March/002137.html @@ -82,10 +99,10 @@ -class_def(eq, class_arg(a, kind(*)), []). -class_def(ord, class_arg(a, kind(*)), [eq(a)]). -class_def(json, class_arg(a, kind(*)), []). -class_def(functor, class_arg(a, kind(arr(*, *))), []). +class_def(eq, class_arg(_A, kind(*)), []). +class_def(ord, class_arg(A, kind(*)), [eq(A)]). +class_def(json, class_arg(_A, kind(*)), []). +class_def(functor, class_arg(_A, kind(arr(*, *))), []). derive(Tys, CName, StructRules, UserRules) :- @@ -114,47 +131,118 @@ solve(StructRules, UserRules, Goal) :- Goal =.. [ClassName, Ty], append(StructRules, UserRules, Rules), - eval_rule(Rules, [], rule(ClassName, Ty)) -> true; - ( - print_message(error, rule_failed(Goal)), - fail - ). + solve_goal(Rules, [], goal(ClassName, Ty)) ->( true; + print_message(error, goal_failed(goal(ClassName, Ty))), + fail + ). -eval_rule(_, _, true) :- - print_message(informational, rule_true). +solve_goal(_, Trace, true) :- + print_message(informational, goal_true(Trace)). -eval_rule(Rules, Trace, (RL,RR)) :- - eval_rule(Rules, Trace, RL), - eval_rule(Rules, Trace, RR). +solve_goal(Rules, Trace, (GL,GR)) :- + solve_goal(Rules, Trace, GL), + solve_goal(Rules, Trace, GR). -eval_rule(Rules, Trace, rule(ClassName, Ty)) :- - var(Ty) -> print_message(informational, rule_ok(rule(ClassName, Ty))), true; - first(rule(ClassName, Ty), Trace) -> print_message(informational, rule_ok_cycle(rule(ClassName, Ty))), true; +solve_goal(Rules, Trace, goal(ClassName, Ty)) :- + var(Ty) -> print_message(informational, goal_ok(goal(ClassName, Ty), Trace)), true; + check_cycle(Trace, goal(ClassName, Ty)) -> true; ( - print_message(informational, lookup(rule(ClassName, Ty))), + print_message(informational, + lookup(goal(ClassName, Ty), Trace) + ), copy_term(Rules, Rules_), %% WARN(bladyjoker): Without this, Rules get unified and instantiated leading to a cycle and just wrong. - first((rule(ClassName, Ty) :- RuleBody), Rules_) -> ( - print_message(informational, trying(rule(ClassName, Ty))), - eval_rule(Rules, [rule(ClassName, Ty)|Trace], RuleBody), - print_message(informational, rule_ok(rule(ClassName, Ty))) + first((goal(ClassName, Ty) :- RuleBody), Rules_) -> ( + print_message(informational, + running(goal(ClassName, Ty), Trace) + ), + solve_goal(Rules, [goal(ClassName, Ty)|Trace], RuleBody), + print_message(informational, + goal_ok(goal(ClassName, Ty), Trace) + ) ); ( - print_message(error, missing_rule(rule(ClassName, Ty), Trace)), + print_message(error, missing_rule(goal(ClassName, Ty), Trace)), fail ) ). +check_cycle(Trace, Goal) :- + copy_term(Trace, Trace_), %% WARN(bladyjoker): Without this, Trace gets unified and instantiated. + print_message(informational, checking_cycle(Goal, Trace)), + (member(TracedGoal, Trace_), TracedGoal =@= Goal) -> print_message(informational, goal_ok_cycle(Goal, Trace)); fail. + + :- multifile prolog:message//1. -prolog:message(wrong_kind(Ty, got(Got), wanted(Want))) --> [ '~w is of kind ~w but wanted kind ~w'-[Ty, Got, Want]]. -prolog:message(normalization_failed(_, Ty)) --> [ 'Normalizing ~w failed'-[Ty]]. -prolog:message(lookup(rule(ClassName, Ty))) --> [ 'Looking up rule ~w ~w'-[ClassName, Ty]]. -prolog:message(trying(rule(ClassName, Ty))) --> [ 'Trying rule ~w ~w'-[ClassName, Ty]]. -prolog:message(rule_ok(rule(ClassName, Ty))) --> [ 'Done with rule ~w ~w'-[ClassName, Ty]]. -prolog:message(rule_ok_cycle(rule(ClassName, Ty))) --> [ 'Done with rule because cycle ~w ~w'-[ClassName, Ty]]. -prolog:message(rule_true) --> [ 'Done because bottom']. -prolog:message(missing_rule(rule(ClassName, Ty), _)) --> [ 'Missing rule ~w ~w'-[ClassName, Ty]]. -prolog:message(rule_failed(rule(ClassName, Ty))) --> [ 'Failed rule ~w ~w'-[ClassName, Ty]]. +trace_to_indentation([], ""). +trace_to_indentation([_|Xs], I) :- + trace_to_indentation(Xs, Is), + string_concat(".", Is, I). + +prolog:message(checking_cycle(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG) + }, [ + '~w ~w Checking cycle for for goal'-[I, PG] + ]. + +prolog:message(lookup(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG) + }, [ + '~w ~w Looking up rule for goal'-[I, PG] + ]. +prolog:message(running(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG) + }, [ + '~w ~w Running goal'-[I, PG] + ]. +prolog:message(goal_ok(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG) + }, [ + '~w ~w Done with goal'-[I, PG] + ]. +prolog:message(goal_ok_cycle(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG), + pretty_trace(Trace, PTrace) + }, [ + '~w ~w Done with goal because cycle ~w '-[I, PG, PTrace] + ]. +prolog:message(goal_true(Trace)) --> { trace_to_indentation(Trace, I) }, [ '~w Done because bottom'-[I]]. +prolog:message(missing_rule(G, Trace)) --> { + trace_to_indentation(Trace, I), + pretty_goal(G, PG) + }, [ + '~w ~w Missing rule for goal'-[I, PG] + ]. +prolog:message(goal_failed(G)) --> {pretty_goal(G, PG)}, ['~w Failed goal'-[PG]]. + +%% Pretty represenationts +%% ?- pretty_ty(ty_app(ty_app(ty_ref(either), ty_ref(int)), B), P). +%% P = either(int, B). +pretty_ty(TyVar, TyVar) :- + var(TyVar). +pretty_ty(opaque(N, _, _), P) :- + atom_concat('_', N, OpaqueN), + P =.. [OpaqueN]. +pretty_ty(ty_ref(RefName), P) :- + P =.. [RefName]. +pretty_ty(ty_app(TyF, TyA), P) :- + (var(TyF) -> PTyF = TyF; pretty_ty(TyF, PTyF)), + (var(TyA) -> PTyA = TyA; pretty_ty(TyA, PTyA)), + PTyF =.. [N|Args], + append(Args, [PTyA], PArgs), + P =.. [N|PArgs]. + +pretty_goal(goal(ClassName, Ty), P) :- + pretty_ty(Ty, PTy), + P =.. [ClassName, PTy]. + +pretty_trace(Trace, PTrace) :- + findall(P, (member(R, Trace), pretty_goal(R, P)), PTrace). :- begin_tests(class_check). @@ -203,18 +291,67 @@ ], eq, S, U), solve(S, U, eq(ty_ref(recfoo))). -test("should_succeed: derive Maybe (Maybe Int8))", [ ]) :- +test("should_succeed: derive Eq Maybe (Maybe Int8))", [ ]) :- derive([ ty_ref(int8), ty_app(ty_ref(maybe), _A) ], eq, S, U), solve(S, U, eq(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), ty_ref(int8))))). -test("should_succeed: derive Maybe (Maybe a)", [ ]) :- +test("should_succeed: derive Eq Maybe (Maybe a)", [ ]) :- derive([ ty_ref(int8), ty_app(ty_ref(maybe), _A) ], eq, S, U), solve(S, U, eq(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), _B)))). +test("should_fail: derive Ord (Maybe Int)", [ fail ]) :- + derive([ + ty_app(ty_ref(maybe), _A) + ], ord, S, U), + solve(S, U, ord(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), ty_ref(int8))))). + +test("should_fail: derive Ord (Maybe Int)", [ fail ]) :- + derive([ + ty_ref(int8), + ty_app(ty_ref(maybe), _A) + ], ord, S, U), + solve(S, U, ord(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), ty_ref(int8))))). + +test("should_succeed: derive Ord (Maybe a)", [ fail ]) :- + derive([ + ty_ref(int8) + ], eq, EqS, EqU), + derive([ + ty_ref(int8), + ty_app(ty_ref(maybe), __A) + ], ord, OrdS, OrdU), + append(EqS, OrdS, S), + append(EqU, OrdU, U), + solve(S, U, ord(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), ty_ref(int8))))). + +test("should_succeed: derive Ord (Maybe a)", [ ]) :- + derive([ + ty_ref(int8), + ty_app(ty_ref(maybe), _A) + ], eq, EqS, EqU), + derive([ + ty_ref(int8), + ty_app(ty_ref(maybe), __A) + ], ord, OrdS, OrdU), + append(EqS, OrdS, S), + append(EqU, OrdU, U), + solve(S, U, ord(ty_app(ty_ref(maybe), ty_app(ty_ref(maybe), ty_ref(int8))))). + +test("should_fails: Eq List a => Eq List a", [ ]) :- + solve([ + ( + goal(eq, ty_app(ty_ref(list), A)) :- + (goal(eq, ty_app(ty_ref(list), A)),true) + ) + ], + [], + eq(ty_app(ty_ref(list), _B)) + ). + :- end_tests(class_check). diff --git a/flake.nix b/flake.nix index a78a0b4c..154ed2d6 100644 --- a/flake.nix +++ b/flake.nix @@ -101,6 +101,15 @@ }; frontendFlake = flakeAbstraction frontendBuild; + # Codegen Build + codegenBuild = buildAbstraction { + import-location = ./lambda-buffers-codegen/build.nix; + additional = { + lambda-buffers-compiler = ./lambda-buffers-compiler; + }; + }; + codegenFlake = flakeAbstraction codegenBuild; + # Utilities renameAttrs = rnFn: pkgs.lib.attrsets.mapAttrs' (n: value: { name = rnFn n; inherit value; }); in @@ -109,7 +118,7 @@ inherit pkgs; # Standard flake attributes - packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages // frontendFlake.packages // extrasFlake.packages; + packages = { inherit (protosBuild) compilerHsPb; } // compilerFlake.packages // frontendFlake.packages // codegenFlake.packages // extrasFlake.packages; devShells = rec { dev-pre-commit = preCommitDevShell; @@ -118,12 +127,13 @@ dev-protos = protosBuild.devShell; dev-compiler = compilerFlake.devShell; dev-frontend = frontendFlake.devShell; + dev-codegen = codegenFlake.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 // extrasFlake.checks); + checks = { inherit pre-commit-check; } // devShells // packages // renameAttrs (n: "check-${n}") (compilerFlake.checks // frontendFlake.checks // codegenFlake.checks // extrasFlake.checks); } ) // { diff --git a/lambda-buffers-codegen/.envrc b/lambda-buffers-codegen/.envrc new file mode 100644 index 00000000..d45b862b --- /dev/null +++ b/lambda-buffers-codegen/.envrc @@ -0,0 +1 @@ +use flake ..#dev-codegen diff --git a/lambda-buffers-codegen/app/LambdaBuffers/Codegen/Cli/Gen.hs b/lambda-buffers-codegen/app/LambdaBuffers/Codegen/Cli/Gen.hs new file mode 100644 index 00000000..55c0c64c --- /dev/null +++ b/lambda-buffers-codegen/app/LambdaBuffers/Codegen/Cli/Gen.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module LambdaBuffers.Codegen.Cli.Gen (GenOpts (..), gen) where + +import Control.Lens (makeLenses) + +data GenOpts = GenOpts + { _compiled :: FilePath + , _debug :: Bool + , _workingDir :: Maybe FilePath + } + deriving stock (Eq, Show) + +makeLenses ''GenOpts + +-- | Generate code given some options. +gen :: GenOpts -> IO () +gen _opts = error "not implemented" diff --git a/lambda-buffers-codegen/app/Main.hs b/lambda-buffers-codegen/app/Main.hs new file mode 100644 index 00000000..344babd3 --- /dev/null +++ b/lambda-buffers-codegen/app/Main.hs @@ -0,0 +1,71 @@ +module Main (main) where + +import Control.Applicative (optional, (<**>)) +import LambdaBuffers.Codegen.Cli.Gen (GenOpts (GenOpts), gen) +import Options.Applicative ( + Parser, + ParserInfo, + command, + customExecParser, + flag, + fullDesc, + help, + helper, + info, + long, + metavar, + prefs, + progDesc, + short, + showDefault, + showHelpOnEmpty, + showHelpOnError, + strOption, + subparser, + ) + +newtype Command + = Gen GenOpts + +genOptsP :: Parser GenOpts +genOptsP = + GenOpts + <$> strOption + ( long "file" + <> short 'f' + <> metavar "FILEPATH" + <> help "Compiled LambdaBuffers schema to compile" + ) + <*> flag + False + True + ( long "debug" + <> short 'd' + <> help "Run in debug mode" + <> showDefault + ) + <*> optional + ( strOption + ( long "work-dir" + <> short 'w' + <> metavar "FILEPATH" + <> help "Working directory used to communicate with the Codegen" + <> showDefault + ) + ) + +optionsP :: Parser Command +optionsP = + subparser $ + command + "gen" + (info (Gen <$> genOptsP <* helper) (progDesc "Generate code from a compiled LambdaBuffers schema")) + +parserInfo :: ParserInfo Command +parserInfo = info (optionsP <**> helper) (fullDesc <> progDesc "LambdaBuffers Codegen command-line interface tool") + +main :: IO () +main = do + cmd <- customExecParser (prefs (showHelpOnEmpty <> showHelpOnError)) parserInfo + case cmd of + Gen opts -> gen opts diff --git a/lambda-buffers-codegen/build.nix b/lambda-buffers-codegen/build.nix new file mode 100644 index 00000000..5d1bfcae --- /dev/null +++ b/lambda-buffers-codegen/build.nix @@ -0,0 +1,64 @@ +{ pkgs +, haskell-nix +, mlabs-tooling +, compiler-nix-name +, index-state +, compilerHsPb +, lambda-buffers-compiler +, commonTools +, shellHook +}: +let + inherit pkgs; + project = { + src = ./.; + + name = "lambda-buffers-codegen"; + + inherit compiler-nix-name index-state; + + extraHackage = [ + "${compilerHsPb}" + "${lambda-buffers-compiler}" + ]; + + modules = [ + (_: { + packages = { + allComponent.doHoogle = true; + allComponent.doHaddock = true; + + # Enable strict compilation + lambda-buffers-codegen.configureFlags = [ "-f-dev" ]; + }; + }) + ]; + + shell = { + + withHoogle = true; + + exactDeps = true; + + nativeBuildInputs = builtins.attrValues commonTools; + + tools = { + cabal = { }; + haskell-language-server = { }; + }; + + shellHook = '' + export LC_CTYPE=C.UTF-8 + export LC_ALL=C.UTF-8 + export LANG=C.UTF-8 + ${shellHook} + ''; + }; + }; +in +{ + hsNixProj = haskell-nix.cabalProject' [ + mlabs-tooling.lib.mkHackageMod + project + ]; +} diff --git a/lambda-buffers-codegen/cabal.project b/lambda-buffers-codegen/cabal.project new file mode 100644 index 00000000..6b0c1f6a --- /dev/null +++ b/lambda-buffers-codegen/cabal.project @@ -0,0 +1,3 @@ +packages: ./. + +tests: true \ No newline at end of file diff --git a/lambda-buffers-codegen/hie.yaml b/lambda-buffers-codegen/hie.yaml new file mode 100644 index 00000000..04cd2439 --- /dev/null +++ b/lambda-buffers-codegen/hie.yaml @@ -0,0 +1,2 @@ +cradle: + cabal: diff --git a/lambda-buffers-codegen/lambda-buffers-codegen.cabal b/lambda-buffers-codegen/lambda-buffers-codegen.cabal new file mode 100644 index 00000000..109861ea --- /dev/null +++ b/lambda-buffers-codegen/lambda-buffers-codegen.cabal @@ -0,0 +1,146 @@ +cabal-version: 3.0 +name: lambda-buffers-codegen +version: 0.1.0.0 +synopsis: Lambda Buffers Codegen + +-- license: + +author: MLabs LTD +maintainer: info@mlabs.city + +-- A copyright notice. +-- copyright: +-- category: + +flag dev + description: Enable non-strict compilation for development + manual: True + +common common-language + ghc-options: + -Wall -Wcompat -fprint-explicit-foralls -fprint-explicit-kinds + -fwarn-missing-import-lists -Weverything -Wno-unsafe + -Wno-missing-safe-haskell-mode -Wno-implicit-prelude + -Wno-missing-kind-signatures -Wno-all-missed-specializations + + if !flag(dev) + ghc-options: -Werror + + default-extensions: + NoStarIsType + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DataKinds + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + EmptyCase + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + ForeignFunctionInterface + GADTSyntax + GeneralizedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MonomorphismRestriction + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + OverloadedLabels + OverloadedStrings + PartialTypeSignatures + PatternGuards + PolyKinds + PostfixOperators + RankNTypes + RecordWildCards + RelaxedPolyRec + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TemplateHaskell + TraditionalRecordSyntax + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + ViewPatterns + + default-language: Haskell2010 + +library + import: common-language + build-depends: + , base >=4.16 + , containers >=0.6 + , lambda-buffers-compiler >=0.1 + , lambda-buffers-compiler-pb >=0.1 + , lens >=5.2 + , mtl >=2.2 + , ordered-containers >=0.2 + , prettyprinter >=1.7 + , proto-lens >=0.7 + , text >=1.2 + + hs-source-dirs: src + exposed-modules: + LambdaBuffers.Codegen + LambdaBuffers.Codegen.Haskell + LambdaBuffers.Codegen.Haskell.Config + LambdaBuffers.Codegen.Haskell.Print + LambdaBuffers.Codegen.Haskell.PrintM + LambdaBuffers.Codegen.Haskell.Syntax + +executable lbg + import: common-language + build-depends: + , base >=4.16 + , lens >=5.2 + , optparse-applicative >=0.17 + + hs-source-dirs: app + main-is: Main.hs + other-modules: LambdaBuffers.Codegen.Cli.Gen + +test-suite tests + import: common-language + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + build-depends: + , base >=4.16 + , containers >=0.6 + , data-default >=0.7 + , lambda-buffers-codegen + , lambda-buffers-compiler >=0.1 + , lambda-buffers-compiler-pb >=0.1 + , lens >=5.2 + , prettyprinter >=1.7 + , proto-lens >=0.7 + , tasty >=1.4 + , tasty-hunit >=0.10 + , text >=1.2 + + other-modules: + Test.LambdaBuffers.Codegen + Test.LambdaBuffers.Codegen.Haskell diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen.hs new file mode 100644 index 00000000..34ef0465 --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen.hs @@ -0,0 +1,4 @@ +module LambdaBuffers.Codegen (runCodegen) where + +runCodegen :: forall {a}. a +runCodegen = error "not implemented" diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell.hs new file mode 100644 index 00000000..0276978f --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell.hs @@ -0,0 +1,5 @@ +module LambdaBuffers.Codegen.Haskell ( + runPrint, +) where + +import LambdaBuffers.Codegen.Haskell.PrintM (runPrint) diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Config.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Config.hs new file mode 100644 index 00000000..18f651a5 --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Config.hs @@ -0,0 +1,18 @@ +module LambdaBuffers.Codegen.Haskell.Config (QTyName, QClassName, Config (..), opaques, classes) where + +import Control.Lens (makeLenses) +import Data.Map (Map) +import LambdaBuffers.Codegen.Haskell.Syntax qualified as H +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC +import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC + +type QTyName = (PC.InfoLess PC.ModuleName, PC.InfoLess PC.TyName) +type QClassName = (PC.InfoLess PC.ModuleName, PC.InfoLess PC.ClassName) + +data Config = MkConfig + { _opaques :: Map QTyName H.QTyName + , _classes :: Map QClassName (H.QClassName, [H.FunctionName]) + } + deriving stock (Eq, Ord, Show) + +makeLenses 'MkConfig diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print.hs new file mode 100644 index 00000000..16f95817 --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Print.hs @@ -0,0 +1,145 @@ +module LambdaBuffers.Codegen.Haskell.Print (printTyDefOpaque, printTyDefNonOpaque, NonOpaqueTyBody (..), printModule) where + +import Control.Lens ((^.)) +import Data.Char qualified as Char +import Data.Foldable (Foldable (toList)) +import Data.Map.Ordered (OMap) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import LambdaBuffers.Codegen.Haskell.Syntax qualified as H +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC +import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC +import Prettyprinter (Doc, Pretty (pretty), align, colon, comma, concatWith, dot, encloseSep, equals, group, lbrace, line, lparen, parens, pipe, rbrace, rparen, sep, space, squote, surround, vsep, (<+>)) + +printModuleHeader :: H.ModuleName -> Set H.TyName -> Doc a +printModuleHeader (H.MkModuleName mn) exports = + let typeExportsDoc = align $ group $ encloseSep lparen rparen comma ((\(H.MkTyName tn) -> pretty tn) <$> toList exports) + in "module" <+> pretty mn <+> typeExportsDoc <+> "where" + +printImports :: Set H.QTyName -> Doc a +printImports imports = + let grouped = Set.fromList [(c, mn) | (c, mn, _tn) <- toList imports] + typeImportsDocs = (\(_, H.MkModuleName mn) -> "import qualified" <+> pretty mn) <$> toList grouped + typeImportsDoc = vsep typeImportsDocs + in typeImportsDoc + +printTyDefs :: [Doc a] -> Doc a +printTyDefs = vsep + +printModule :: H.ModuleName -> Set H.TyName -> Set H.QTyName -> [Doc a] -> Doc a +printModule modName tyExports tyImports tyDefDocs = + vsep + [ printModuleHeader modName tyExports + , line + , printImports tyImports + , line + , printTyDefs tyDefDocs + , line + ] + +printTyVar :: PC.TyVar -> Doc a +printTyVar (PC.TyVar vn) = printVarName vn + +printVarName :: PC.VarName -> Doc a +printVarName (PC.VarName n _) = pretty n + +printTyName :: PC.TyName -> Doc a +printTyName (PC.TyName n _) = pretty n + +printModName :: PC.ModuleName -> Doc a +printModName (PC.ModuleName parts _) = group $ concatWith (surround dot) [pretty p | PC.ModuleNamePart p _ <- parts] + +{- | Creates an alias to the specified 'native' type. + +opaque Maybe a + +translates to + +type Maybe = Prelude.Maybe +-} +printTyDefOpaque :: PC.TyName -> (H.CabalPackageName, H.ModuleName, H.TyName) -> Doc a +printTyDefOpaque tyN hsTyRef = "type" <+> printTyName tyN <+> equals <+> printHsTyRef hsTyRef + +printHsTyRef :: H.QTyName -> Doc a +printHsTyRef (_, H.MkModuleName hsModName, H.MkTyName hsTyName) = pretty hsModName <> dot <> pretty hsTyName + +-- | Used to distinguish from Opaques. +newtype NonOpaqueTyBody = Sum PC.Sum + +printTyDefNonOpaque :: PC.TyName -> OMap (PC.InfoLess PC.VarName) PC.TyArg -> NonOpaqueTyBody -> Doc a +printTyDefNonOpaque tyN args body = + let argsDoc = sep (printTyArg <$> toList args) + (keyword, bodyDoc) = printTyBody tyN body + in group $ keyword <+> printTyName tyN <+> argsDoc <+> equals <+> bodyDoc + +-- TODO(bladyjoker): Add Record/Tuple. +printTyBody :: PC.TyName -> NonOpaqueTyBody -> (Doc a, Doc a) +printTyBody tyN (Sum s) = ("data", printTyBodySum tyN s) + +printTyArg :: forall {a}. PC.TyArg -> Doc a +printTyArg (PC.TyArg vn _ _) = printVarName vn + +printTyBodySum :: PC.TyName -> PC.Sum -> Doc a +printTyBodySum tyN (PC.Sum ctors _) = + let ctorDocs = printCtor tyN <$> toList ctors + in group $ + if null ctors + then mempty + else align $ encloseSep mempty mempty (space <> pipe <> space) ctorDocs + +printCtor :: PC.TyName -> PC.Constructor -> Doc a +printCtor tyN (PC.Constructor ctorName prod) = + let ctorNDoc = printCtorName tyN ctorName + prodDoc = printProd tyN prod + in align $ group (ctorNDoc <+> prodDoc) + +{- | Translate LambdaBuffer sum constructor names into Haskell sum constructor names. + sum Sum = Foo Int | Bar String + translates to + data Sum = Sum'Foo Int | Sum'Bar String +-} +printCtorName :: PC.TyName -> PC.ConstrName -> Doc a +printCtorName tyN (PC.ConstrName n _) = group $ printTyName tyN <> squote <> pretty n + +printProd :: PC.TyName -> PC.Product -> Doc a +printProd tyN (PC.RecordI rc) = printRec tyN rc +printProd _ (PC.TupleI tup) = printTup tup + +printRec :: PC.TyName -> PC.Record -> Doc a +printRec tyN (PC.Record fields _) = + let fieldDocs = printField tyN <$> toList fields + in group $ encloseSep lbrace rbrace (space <> comma <> space) fieldDocs + +printTup :: PC.Tuple -> Doc a +printTup (PC.Tuple fields _) = group $ sep (printTy <$> fields) + +printField :: PC.TyName -> PC.Field -> Doc a +printField tyN (PC.Field fn ty) = printFieldName tyN fn <+> colon <> colon <+> printTy ty + +{- | Translate LambdaBuffer record field names into Haskell record field names + rec Rec = { foo :: Int, bar :: String } + translates to + data Rec = MkRec { rec'foo :: Int, rec'bar :: String } +-} +printFieldName :: PC.TyName -> PC.FieldName -> Doc a +printFieldName tyN (PC.FieldName n _) = + let prefix = case Text.uncons (tyN ^. #name) of + Nothing -> "" -- NOTE(bladyjoker): Should not happen :shrug:. + Just (h, t) -> Text.cons (Char.toLower h) t + in pretty prefix <> squote <> pretty n + +printTy :: PC.Ty -> Doc a +printTy (PC.TyVarI v) = printTyVar v +printTy (PC.TyRefI r) = printTyRef r +printTy (PC.TyAppI a) = printTyApp a + +printTyApp :: PC.TyApp -> Doc a +printTyApp (PC.TyApp f args _) = + let fDoc = printTy f + argsDoc = printTy <$> args + in group $ parens $ fDoc <+> align (sep argsDoc) + +printTyRef :: PC.TyRef -> Doc a +printTyRef (PC.LocalI (PC.LocalRef tn _)) = group $ printTyName tn +printTyRef (PC.ForeignI (PC.ForeignRef tn mn _)) = group $ printModName mn <> dot <> printTyName tn diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/PrintM.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/PrintM.hs new file mode 100644 index 00000000..d4e07ae2 --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/PrintM.hs @@ -0,0 +1,131 @@ +module LambdaBuffers.Codegen.Haskell.PrintM ( + runPrint, +) where + +import Control.Lens ((&), (.~), (^.)) +import Control.Monad.Error.Class (MonadError (throwError)) +import Control.Monad.Except (runExcept) +import Control.Monad.RWS (RWST (runRWST)) +import Control.Monad.RWS.Class (MonadRWS, asks) +import Control.Monad.Reader.Class (MonadReader (local)) +import Control.Monad.State.Class (modify) +import Control.Monad.Writer.Class (MonadWriter (tell)) +import Data.Foldable (for_) +import Data.Map qualified as Map +import Data.ProtoLens (Message (defMessage)) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text qualified as Text +import LambdaBuffers.Codegen.Haskell.Config (Config, opaques) +import LambdaBuffers.Codegen.Haskell.Print qualified as Print +import LambdaBuffers.Codegen.Haskell.Syntax qualified as H +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC +import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC +import Prettyprinter (Doc) +import Proto.Compiler qualified as P +import Proto.Compiler_Fields qualified as P + +data PrintCtx + = ModuleCtx PC.ModuleName + | TyDefCtx PC.ModuleName PC.TyDef + | InstanceClauseCtx PC.ModuleName + deriving stock (Eq, Ord, Show) + +type PrintRead = (Config, PrintCtx) + +type PrintWrite = [PrintCommand] +data PrintCommand + = AddTyDef (Doc ()) + | AddInstanceDef (Doc ()) + deriving stock (Show) + +type PrintErr = String + +data PrintState = MkPrintState + { moduleTyImports :: Set H.QTyName + , moduleTyExports :: Set H.TyName + , moduleClassImports :: Set (H.QClassName, [H.FunctionName]) + } + deriving stock (Eq, Ord, Show) + +type MonadPrint m = (MonadRWS PrintRead PrintWrite PrintState m, MonadError PrintErr m) + +runPrint :: Config -> PC.Module -> Either P.CompilerError (Doc ()) +runPrint cfg m = + let p = runRWST (goModule m) (cfg, ModuleCtx $ m ^. #moduleName) (MkPrintState mempty mempty mempty) + p' = runExcept p + in go p' + where + go :: Either PrintErr (H.ModuleName, PrintState, [PrintCommand]) -> Either P.CompilerError (Doc ()) + go (Right (mn, MkPrintState ti te _, pw)) = Right $ Print.printModule mn te ti [tdDoc | AddTyDef tdDoc <- pw] + go (Left printErr) = Left $ defMessage & P.internalErrors .~ [defMessage & P.msg .~ Text.pack printErr] + +askConfig :: MonadPrint m => m Config +askConfig = asks fst + +askCtx :: MonadPrint m => m PrintCtx +askCtx = asks snd + +askTyDefCtx :: MonadPrint m => m (PC.ModuleName, PC.TyDef) +askTyDefCtx = do + ctx <- askCtx + case ctx of + TyDefCtx mn td -> return (mn, td) + other -> throwError $ "Internal error, wanted TyDefCtx got " <> show other + +_askInstCtx :: MonadPrint m => m PC.ModuleName +_askInstCtx = do + ctx <- askCtx + case ctx of + InstanceClauseCtx mn -> return mn + other -> throwError $ "Internal error, wanted InstanceClauseCtx got " <> show other + +exportTy :: MonadPrint m => H.TyName -> m () +exportTy htyN = modify (\s -> s {moduleTyExports = Set.union (moduleTyExports s) (Set.singleton htyN)}) + +importTy :: MonadPrint m => (H.CabalPackageName, H.ModuleName, H.TyName) -> m () +importTy qhTyRef = modify (\s -> s {moduleTyImports = Set.union (moduleTyImports s) (Set.singleton qhTyRef)}) + +_importClass :: MonadPrint m => (H.QClassName, [H.FunctionName]) -> m () +_importClass qhClassRef = modify (\s -> s {moduleClassImports = Set.union (moduleClassImports s) (Set.singleton qhClassRef)}) + +-- | Traverse the module and collect imports, exports and type definition documents. +goModule :: MonadPrint m => PC.Module -> m H.ModuleName +goModule m = do + for_ (m ^. #typeDefs) (\td -> local (\(cfg, _) -> (cfg, TyDefCtx (m ^. #moduleName) td)) (goTyDef td)) + return $ H.fromLbModuleName (m ^. #moduleName) + +goTyDef :: MonadPrint m => PC.TyDef -> m () +goTyDef td = goTyAbs $ td ^. #tyAbs + +goTyAbs :: MonadPrint m => PC.TyAbs -> m () +goTyAbs (PC.TyAbs _ (PC.OpaqueI _) _) = do + cfg <- askConfig + (currentModuleName, currentTyDef) <- askTyDefCtx + qhTyRef <- case Map.lookup (PC.mkInfoLess currentModuleName, PC.mkInfoLess $ currentTyDef ^. #tyName) (cfg ^. opaques) of + Nothing -> throwError $ "TODO(bladyjoker): Opaque not configured" <> show (currentTyDef ^. #tyName) + Just qhsTyRef -> return qhsTyRef + exportTy (H.fromLbTyName (currentTyDef ^. #tyName)) + importTy qhTyRef + tell + [ AddTyDef $ Print.printTyDefOpaque (currentTyDef ^. #tyName) qhTyRef + ] +goTyAbs (PC.TyAbs args (PC.SumI s) _) = do + goSum s + currentTyDef <- snd <$> askTyDefCtx + exportTy (H.fromLbTyName (currentTyDef ^. #tyName)) + tell + [ AddTyDef $ Print.printTyDefNonOpaque (currentTyDef ^. #tyName) args (Print.Sum s) + ] + +goSum :: MonadPrint m => PC.Sum -> m () +goSum s = for_ (s ^. #constructors) (\c -> goProduct (c ^. #product)) + +goProduct :: MonadPrint m => PC.Product -> m () +goProduct (PC.TupleI t) = for_ (t ^. #fields) goTy +goProduct (PC.RecordI r) = for_ (r ^. #fields) (\f -> goTy $ f ^. #fieldTy) + +goTy :: MonadPrint m => PC.Ty -> m () +goTy (PC.TyRefI (PC.ForeignI fr)) = importTy (H.fromLbForeignRef fr) +goTy (PC.TyAppI ta) = goTy (ta ^. #tyFunc) >> for_ (ta ^. #tyArgs) goTy +goTy _ = return () diff --git a/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Syntax.hs b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Syntax.hs new file mode 100644 index 00000000..6c87f898 --- /dev/null +++ b/lambda-buffers-codegen/src/LambdaBuffers/Codegen/Haskell/Syntax.hs @@ -0,0 +1,32 @@ +module LambdaBuffers.Codegen.Haskell.Syntax (QTyName, QClassName, CabalPackageName (..), ModuleName (..), TyName (..), ClassName (..), FunctionName (..), fromLbModuleName, cabalFromLbModuleName, fromLbTyName, fromLbForeignRef) where + +import Control.Lens ((^.)) +import Data.Text (Text) +import Data.Text qualified as Text +import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC + +type QTyName = (CabalPackageName, ModuleName, TyName) +type QClassName = (CabalPackageName, ModuleName, ClassName) + +newtype CabalPackageName = MkCabalPackageName Text deriving stock (Eq, Ord, Show) +newtype ModuleName = MkModuleName Text deriving stock (Eq, Ord, Show) +newtype TyName = MkTyName Text deriving stock (Eq, Ord, Show) +newtype ClassName = MkClassName Text deriving stock (Eq, Ord, Show) +newtype FunctionName = MkFunctionName Text deriving stock (Eq, Ord, Show) + +fromLbTyName :: PC.TyName -> TyName +fromLbTyName tn = MkTyName $ tn ^. #name + +fromLbModuleName :: PC.ModuleName -> ModuleName +fromLbModuleName mn = MkModuleName $ Text.intercalate "." ("LambdaBuffers" : [p ^. #name | p <- mn ^. #parts]) + +-- TODO(bladyjoker): Figure out the Cabal package name syntax. +cabalFromLbModuleName :: PC.ModuleName -> CabalPackageName +cabalFromLbModuleName mn = MkCabalPackageName $ Text.intercalate "-" ([Text.toLower $ p ^. #name | p <- mn ^. #parts] <> ["-lb"]) + +fromLbForeignRef :: PC.ForeignRef -> QTyName +fromLbForeignRef fr = + ( cabalFromLbModuleName $ fr ^. #moduleName + , fromLbModuleName $ fr ^. #moduleName + , fromLbTyName $ fr ^. #tyName + ) diff --git a/lambda-buffers-codegen/test/Test.hs b/lambda-buffers-codegen/test/Test.hs new file mode 100644 index 00000000..0e40daf9 --- /dev/null +++ b/lambda-buffers-codegen/test/Test.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.LambdaBuffers.Codegen (tests) +import Test.Tasty (defaultMain, testGroup) + +main :: IO () +main = defaultMain $ testGroup "Codegen tests" [tests] diff --git a/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen.hs b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen.hs new file mode 100644 index 00000000..68425555 --- /dev/null +++ b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen.hs @@ -0,0 +1,10 @@ +module Test.LambdaBuffers.Codegen (tests) where + +import Test.LambdaBuffers.Codegen.Haskell qualified as H +import Test.Tasty (TestTree, testGroup) + +tests :: TestTree +tests = + testGroup + "LambdaBuffers.Codegen" + [H.tests] diff --git a/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Haskell.hs b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Haskell.hs new file mode 100644 index 00000000..0750c4ae --- /dev/null +++ b/lambda-buffers-codegen/test/Test/LambdaBuffers/Codegen/Haskell.hs @@ -0,0 +1,189 @@ +module Test.LambdaBuffers.Codegen.Haskell (tests) where + +import Control.Lens ((&), (.~), (^.)) +import Data.Foldable (Foldable (toList)) +import Data.Map qualified as Map +import Data.ProtoLens (Message (defMessage)) +import Data.Text (Text) +import Data.Traversable (for) +import LambdaBuffers.Codegen.Haskell.Config (Config (MkConfig)) +import LambdaBuffers.Codegen.Haskell.Syntax qualified as H +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC +import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC +import Proto.Compiler qualified as P +import Proto.Compiler_Fields qualified as P + +import Data.Default (Default (def)) +import LambdaBuffers.Codegen.Haskell.Config qualified as H +import LambdaBuffers.Codegen.Haskell.PrintM qualified as H +import LambdaBuffers.Compiler.ProtoCompat.FromProto qualified as PC +import Prettyprinter (vsep) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "LambdaBuffers.Codegen.Haskell" + [testCase "should succeed" $ testPrint testCompInp testConfig "module LambdaBuffers.TestMod (Either,I8,Maybe,Set) where\n\n\nimport qualified Data.Int\nimport qualified Data.Set\n\n\ndata Either a b = Either'Left a | Either'Right b\ntype I8 = Data.Int.Int8\ndata Maybe a = Maybe'Just a | Maybe'Nothing \ntype Set = Data.Set.Set\n\n\nmodule LambdaBuffers.TestMod2 (Foo,I16) where\n\n\nimport qualified Data.Int\nimport qualified LambdaBuffers.TestMod\n\n\ndata Foo a = Foo'MkFoo a I16 TestMod.I8\ntype I16 = Data.Int.Int16\n\n"] + +testPrint :: P.CompilerInput -> H.Config -> String -> Assertion +testPrint compInp cfg want = do + compInp' <- case PC.runFromProto compInp of + Left err -> assertFailure (show err) + Right res -> return res + modDocs <- + for + (compInp' ^. #modules) + ( \m -> case H.runPrint cfg m of + Left err -> assertFailure (show err) + Right res -> return res + ) + print @String "" + print $ vsep (toList modDocs) + assertEqual "" want (show $ vsep (toList modDocs)) + +testCompInp :: P.CompilerInput +testCompInp = + defMessage + & P.modules + .~ [testModule1, testModule2] + +testConfig :: H.Config +testConfig = + MkConfig + ( Map.fromList + [ + ( + ( PC.mkInfoLess $ PC.ModuleName [PC.ModuleNamePart "TestMod" def] def + , PC.mkInfoLess $ PC.TyName "I8" def + ) + , (H.MkCabalPackageName "base", H.MkModuleName "Data.Int", H.MkTyName "Int8") + ) + , + ( + ( PC.mkInfoLess $ PC.ModuleName [PC.ModuleNamePart "TestMod2" def] def + , PC.mkInfoLess $ PC.TyName "I16" def + ) + , (H.MkCabalPackageName "base", H.MkModuleName "Data.Int", H.MkTyName "Int16") + ) + , + ( + ( PC.mkInfoLess $ PC.ModuleName [PC.ModuleNamePart "TestMod" def] def + , PC.mkInfoLess $ PC.TyName "Set" def + ) + , (H.MkCabalPackageName "containers", H.MkModuleName "Data.Set", H.MkTyName "Set") + ) + ] + ) + mempty + +testModule1 :: P.Module +testModule1 = + defMessage + & P.moduleName .~ mkModuleName ["TestMod"] + & P.typeDefs + .~ [ mkTyDefOpq "I8" [] + , mkTyDefOpq "Set" ["a"] + , mkTyDefSum + "Maybe" + ["a"] + ( mkSum + [ ("Just", mkTuple [mkTyVar "a"]) + , ("Nothing", mkTuple []) + ] + ) + , mkTyDefSum + "Either" + ["a", "b"] + ( mkSum + [ ("Left", mkTuple [mkTyVar "a"]) + , ("Right", mkTuple [mkTyVar "b"]) + ] + ) + ] + & P.classDefs + .~ [ defMessage + & P.className . P.name .~ "Eq" + & P.classArgs .~ [mkArg "a"] + , defMessage + & P.className . P.name .~ "Ord" + & P.classArgs .~ [mkArg "a"] + ] + & P.instances + .~ [ defMessage + & P.classRef . P.localClassRef . P.className . P.name .~ "Eq" + & P.args + .~ [ defMessage + & P.tyApp . P.tyFunc . P.tyRef . P.localTyRef . P.tyName . P.name .~ "Maybe" + & P.tyApp . P.tyArgs .~ [mkTyVar "a"] + ] + ] + +testModule2 :: P.Module +testModule2 = + defMessage + & P.moduleName .~ mkModuleName ["TestMod2"] + & P.typeDefs + .~ [ mkTyDefOpq "I16" [] + , mkTyDefSum + "Foo" + ["a"] + ( mkSum + [ ("MkFoo", mkTuple [mkTyVar "a", mkLRef "I16", mkFRef ["TestMod"] "I8"]) + ] + ) + ] + +mkArg :: Text -> P.TyArg +mkArg vn = + defMessage + & P.argName . P.name .~ vn + & P.argKind . P.kindRef .~ P.Kind'KIND_REF_TYPE + +mkTyVar :: Text -> P.Ty +mkTyVar vn = defMessage & P.tyVar . P.varName . P.name .~ vn + +mkFRef :: [Text] -> Text -> P.Ty +mkFRef mn tn = + defMessage + & P.tyRef . P.foreignTyRef . P.moduleName .~ mkModuleName mn + & P.tyRef . P.foreignTyRef . P.tyName .~ mkTyName tn + +mkLRef :: Text -> P.Ty +mkLRef tn = + defMessage + & P.tyRef . P.localTyRef . P.tyName .~ mkTyName tn + +mkModuleName :: [Text] -> P.ModuleName +mkModuleName parts = defMessage & P.parts .~ [defMessage & P.name .~ p | p <- parts] + +mkTyName :: Text -> P.TyName +mkTyName tn = defMessage & P.name .~ tn + +mkTyDefOpq :: Text -> [Text] -> P.TyDef +mkTyDefOpq tn args = + defMessage + & P.tyName . P.name .~ tn + & P.tyAbs . P.tyArgs .~ (mkArg <$> args) + & P.tyAbs . P.tyBody . P.opaque .~ defMessage + +mkTyDefSum :: Text -> [Text] -> P.Sum -> P.TyDef +mkTyDefSum tn args s = + defMessage + & P.tyName . P.name .~ tn + & P.tyAbs . P.tyArgs .~ (mkArg <$> args) + & P.tyAbs . P.tyBody . P.sum .~ s + +mkSum :: [(Text, P.Product)] -> P.Sum +mkSum ctors = + defMessage + & P.constructors + .~ [ defMessage + & P.constrName . P.name .~ ctorN + & P.product .~ p + | (ctorN, p) <- ctors + ] + +mkTuple :: [P.Ty] -> P.Product +mkTuple tys = defMessage & P.ntuple . P.fields .~ tys diff --git a/lambda-buffers-compiler/lambda-buffers-compiler.cabal b/lambda-buffers-compiler/lambda-buffers-compiler.cabal index b987a2f4..2d5a6f40 100644 --- a/lambda-buffers-compiler/lambda-buffers-compiler.cabal +++ b/lambda-buffers-compiler/lambda-buffers-compiler.cabal @@ -96,16 +96,14 @@ library , containers >=0.6.5.1 , data-default >=0.7 , freer-simple >=1.2 - , generic-arbitrary , generic-lens >=2.2 , generics-sop >=0.5 , lambda-buffers-compiler-pb >=0.1.0.0 , mtl >=2.2 + , ordered-containers >=0.2 , parsec >=3.1 , prettyprinter >=1.7 , proto-lens >=0.7 - , QuickCheck >=2.14 - , quickcheck-instances >=0.3 , text >=1.2 exposed-modules: @@ -160,12 +158,11 @@ test-suite tests , lambda-buffers-compiler , lambda-buffers-compiler-pb >=0.1 , nonempty-containers >=0.3 + , ordered-containers >=0.2 , proto-lens >=0.7 - , QuickCheck >=2.14 , tasty >=1.4 , tasty-hedgehog >=1.4 , tasty-hunit >=0.10 - , tasty-quickcheck >=0.10 , text >=1.2 other-modules: diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs index 99e99237..1e4763a5 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Inference.hs @@ -25,6 +25,7 @@ import Control.Monad.Freer.Writer (Writer, runWriter, tell) import Data.Bifunctor (Bifunctor (second)) import Data.Foldable (foldrM) import Data.Map qualified as M +import Data.Map.Ordered qualified as OMap import Data.Text qualified as T import LambdaBuffers.Compiler.KindCheck.Derivation ( Context (Context), @@ -139,16 +140,15 @@ derive x = deriveTyAbs x deriveTyAbs :: PC.TyAbs -> Derive Derivation deriveTyAbs tyabs = do - case M.toList (tyabs ^. #tyArgs) of + case OMap.assocs (tyabs ^. #tyArgs) of [] -> deriveTyBody (x ^. #tyBody) - a@(n, ar) : as -> do + a@(_, ar) : as -> do let argK = protoKind2Kind (ar ^. #argKind) bodyK <- KVar <$> fresh ctx <- ask - - let newContext = ctx & addContext %~ (<> M.singleton (mkInfoLess (TyVar n)) argK) - let newAbs = tyabs & #tyArgs .~ uncurry M.singleton a - let restAbs = tyabs & #tyArgs .~ M.fromList as + let newContext = ctx & addContext %~ (<> M.singleton (mkInfoLess (TyVar (ar ^. #argName))) argK) + newAbs = tyabs & #tyArgs .~ OMap.singleton a + restAbs = tyabs & #tyArgs .~ OMap.fromList as restF <- local (const newContext) $ deriveTyAbs restAbs @@ -165,11 +165,11 @@ derive x = deriveTyAbs x deriveSum :: PC.Sum -> Derive Derivation deriveSum s = do - case M.toList (s ^. #constructors) of + case OMap.assocs (s ^. #constructors) of [] -> voidDerivation c : cs -> do dc <- deriveConstructor $ snd c - restDc <- deriveSum $ s & #constructors .~ M.fromList cs + restDc <- deriveSum $ s & #constructors .~ OMap.fromList cs sumDerivation dc restDc deriveConstructor :: PC.Constructor -> Derive Derivation @@ -186,11 +186,11 @@ derive x = deriveTyAbs x deriveRecord :: PC.Record -> Derive Derivation deriveRecord r = do - case M.toList (r ^. #fields) of + case OMap.assocs (r ^. #fields) of [] -> unitDerivation f : fs -> do d1 <- deriveField $ snd f - d2 <- deriveRecord $ r & #fields .~ M.fromList fs + d2 <- deriveRecord $ r & #fields .~ OMap.fromList fs productDerivation d1 d2 deriveField :: PC.Field -> Derive Derivation diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs index 8e1558a5..87243e3a 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Kind.hs @@ -3,7 +3,6 @@ module LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, (:->:), KVar), kind2P import GHC.Generics (Generic) import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC import Prettyprinter (Pretty (pretty), parens, (<+>)) -import Test.QuickCheck.Arbitrary.Generic (Arbitrary, GenericArbitrary (GenericArbitrary)) infixr 8 :->: @@ -14,7 +13,6 @@ data Kind | Kind :->: Kind | KVar Atom deriving stock (Eq, Show, Generic) - deriving (Arbitrary) via GenericArbitrary Kind instance Pretty Kind where pretty = \case diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Type.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Type.hs index 709ffac6..75b9a635 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Type.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/KindCheck/Type.hs @@ -12,8 +12,6 @@ import Generics.SOP qualified as SOP import LambdaBuffers.Compiler.ProtoCompat.InfoLess (InfoLess, InfoLessC, withInfoLess) import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC import Prettyprinter (Pretty (pretty), viaShow) -import Test.QuickCheck (Arbitrary) -import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary (GenericArbitrary)) -- NOTE(cstml): Let's remove the Arbitrary instances and replaces them with -- Gens. @@ -24,7 +22,6 @@ data Variable QualifiedTyRef PC.ForeignRef | TyVar PC.VarName deriving stock (Eq, Ord, Show, Generic) - deriving (Arbitrary) via GenericArbitrary Variable deriving anyclass (SOP.Generic) instance Pretty Variable where diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs index fba02d7a..f14ffecb 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/FromProto.hs @@ -7,18 +7,18 @@ import Control.Lens ((&), (.~), (^.)) import Control.Monad.Except (Except, MonadError (throwError), runExcept) import Control.Monad.Reader (MonadReader (ask, local), ReaderT (runReaderT)) import Data.Foldable (foldlM, toList) -import Data.Generics.Labels () -import Data.Generics.Product (HasField) import Data.Kind (Type) import Data.Map (Map) import Data.Map qualified as Map +import Data.Map.Ordered (OMap) +import Data.Map.Ordered qualified as OMap import Data.ProtoLens (Message (messageName), MessageEnum (showEnum), defMessage) import Data.Proxy (Proxy (Proxy)) -import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics (Generic) import LambdaBuffers.Compiler.NamingCheck (checkClassName, checkConstrName, checkFieldName, checkModuleNamePart, checkTyName, checkVarName) +import LambdaBuffers.Compiler.ProtoCompat.InfoLess (mkInfoLess) import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC import Proto.Compiler (NamingError) import Proto.Compiler qualified as P @@ -88,11 +88,17 @@ parseAndIndex key = ) (mempty, mempty) --- WARN(bladyjoker): This function is used to 'strip' the SourceInfo from types that end up as Map keys. --- This can cause confusion and errors and we should rather parametrize types with `info` and --- maintain `Map (TyName ()) (TyDef SourceInfo)` -stripSourceInfo :: HasField "sourceInfo" s t a PC.SourceInfo => s -> t -stripSourceInfo x = x & #sourceInfo .~ PC.defSourceInfo +parseAndIndex' :: forall {t :: Type -> Type} {proto} {a} {k}. (Foldable t, IsMessage proto a, Ord k) => (a -> k) -> t proto -> FromProto (OMap k a, Map k [proto]) +parseAndIndex' key = + foldlM + ( \(indexed, multiples) px -> do + x <- fromProto px + let k = key x + if OMap.member k indexed + then return (indexed, Map.insertWith (++) k [px] multiples) + else return (OMap.alter (const (Just x)) k indexed, multiples) + ) + (OMap.empty, mempty) {- SourceInfo @@ -300,7 +306,7 @@ instance IsMessage P.TyDef PC.TyDef where instance IsMessage P.TyAbs PC.TyAbs where fromProto ta = do - (tyargs, mulTyArgs) <- parseAndIndex (\a -> stripSourceInfo $ a ^. #argName) (ta ^. P.tyArgs) + (tyargs, mulTyArgs) <- parseAndIndex' (\a -> mkInfoLess $ a ^. #argName) (ta ^. P.tyArgs) tybody <- fromProto $ ta ^. P.tyBody si <- fromProto $ ta ^. P.sourceInfo ctx <- ask @@ -389,7 +395,7 @@ instance IsMessage P.TyBody PC.TyBody where instance IsMessage P.Sum PC.Sum where fromProto s = do - (ctors, mulCtors) <- parseAndIndex (\c -> stripSourceInfo $ c ^. #constrName) (s ^. P.constructors) + (ctors, mulCtors) <- parseAndIndex' (\c -> mkInfoLess $ c ^. #constrName) (s ^. P.constructors) si <- fromProto $ s ^. P.sourceInfo ctx <- ask (ctxMn, ctxTyd) <- case ctx of @@ -425,7 +431,7 @@ instance IsMessage P.Sum'Constructor PC.Constructor where instance IsMessage P.Product'Record PC.Record where fromProto r = do - (fields, mulFields) <- parseAndIndex (\f -> stripSourceInfo $ f ^. #fieldName) (r ^. P.fields) + (fields, mulFields) <- parseAndIndex' (\f -> mkInfoLess $ f ^. #fieldName) (r ^. P.fields) si <- fromProto $ r ^. P.sourceInfo ctx <- ask (ctxMn, ctxTyd) <- case ctx of @@ -599,9 +605,9 @@ instance IsMessage P.Module PC.Module where _ -> throwInternalError "Expected to be in CompilerInput Context" local (const $ CtxModule (m ^. P.moduleName)) $ do mnm <- fromProto $ m ^. P.moduleName - (tydefs, mulTyDefs) <- parseAndIndex (\tyDef -> stripSourceInfo $ tyDef ^. #tyName) (m ^. P.typeDefs) - (cldefs, mulClDefs) <- parseAndIndex (\cldef -> stripSourceInfo $ cldef ^. #className) (m ^. P.classDefs) - (impts, mulImpts) <- parseAndIndex stripSourceInfo (m ^. P.imports) + (tydefs, mulTyDefs) <- parseAndIndex (\tyDef -> mkInfoLess $ tyDef ^. #tyName) (m ^. P.typeDefs) + (cldefs, mulClDefs) <- parseAndIndex (\cldef -> mkInfoLess $ cldef ^. #className) (m ^. P.classDefs) + (impts, mulImpts) <- parseAndIndex mkInfoLess (m ^. P.imports) insts <- traverse fromProto $ m ^. P.instances si <- fromProto $ m ^. P.sourceInfo let mulTyDefsErrs = @@ -627,7 +633,7 @@ instance IsMessage P.Module PC.Module where ] protoParseErrs = mulTyDefsErrs ++ mulClassDefsErrs ++ mulImptsErrs if null protoParseErrs - then pure $ PC.Module mnm tydefs cldefs insts (Map.keysSet impts) si + then pure $ PC.Module mnm tydefs cldefs insts impts si else throwError protoParseErrs toProto (PC.Module mnm tdefs cdefs insts impts si) = @@ -636,13 +642,13 @@ instance IsMessage P.Module PC.Module where & P.typeDefs .~ (toProto <$> toList tdefs) & P.classDefs .~ (toProto <$> toList cdefs) & P.instances .~ (toProto <$> insts) - & P.imports .~ (toProto <$> Set.toList impts) + & P.imports .~ (toProto <$> toList impts) & P.sourceInfo .~ toProto si instance IsMessage P.CompilerInput PC.CompilerInput where fromProto ci = do local (const CtxCompilerInput) $ do - (mods, mulModules) <- parseAndIndex (\m -> stripSourceInfo $ m ^. #moduleName) (ci ^. P.modules) + (mods, mulModules) <- parseAndIndex (\m -> mkInfoLess $ m ^. #moduleName) (ci ^. P.modules) let mulModulesErrs = [ FPProtoParseError $ defMessage & P.multipleModuleError . P.modules .~ ms diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs index f5f5cb03..d2014ec2 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/InfoLess.hs @@ -1,66 +1,20 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} module LambdaBuffers.Compiler.ProtoCompat.InfoLess ( InfoLess, withInfoLess, withInfoLessF, mkInfoLess, - InfoLessC, + InfoLessC (infoLessId), ) where -import Data.Bifunctor (Bifunctor (bimap)) -import Data.Default (Default (def)) -import Data.Map qualified as M +import Data.Map (Map) +import Data.Map.Ordered (OMap) +import Data.Set (Set) import Data.Set qualified as S import Data.Text (Text) import Generics.SOP (All2, Generic (Code, from, to), Proxy (Proxy), hcmap, mapII) -import LambdaBuffers.Compiler.ProtoCompat.Types ( - ClassDef, - ClassName, - CompilerError, - CompilerInput, - CompilerResult, - ConstrName, - Constraint, - Constructor, - Field, - FieldName, - ForeignClassRef, - ForeignRef, - InferenceErr, - InstanceClause, - Kind, - KindCheckErr, - KindCheckError, - KindRefType, - KindType, - LBName, - LocalClassRef, - LocalRef, - Module, - ModuleName, - ModuleNamePart, - Product, - Record, - SourceInfo, - SourcePosition, - Sum, - Tuple, - Ty, - TyAbs, - TyApp, - TyArg, - TyBody, - TyClassRef, - TyDef, - TyName, - TyRef, - TyVar, - VarName, - defSourceInfo, - ) -- | InfoLess newtype. Constructor is not exported to not allow the construction of types with the Info. InfoLess a can only be constructed via its class instance and deconstructed using the exported function. newtype InfoLess a = InfoLess {unsafeInfoLess :: a} @@ -99,56 +53,11 @@ instance InfoLessC Int where instance InfoLessC Text where infoLessId = id -instance (Ord k, InfoLessC k, InfoLessC v) => InfoLessC (M.Map k v) where - infoLessId = M.fromList . fmap (bimap infoLessId infoLessId) . M.toList +instance (Ord k, InfoLessC v) => InfoLessC (Map k v) where + infoLessId m = infoLessId <$> m -instance (Ord a, InfoLessC a) => InfoLessC (S.Set a) where +instance (Ord a, InfoLessC a) => InfoLessC (Set a) where infoLessId = S.fromList . fmap infoLessId . S.toList -instance InfoLessC SourceInfo where - infoLessId = const def - -instance Default SourceInfo where - def = defSourceInfo - -instance InfoLessC SourcePosition -instance InfoLessC LBName -instance InfoLessC TyName -instance InfoLessC ConstrName -instance InfoLessC ModuleName -instance InfoLessC ModuleNamePart -instance InfoLessC VarName -instance InfoLessC FieldName -instance InfoLessC ClassName -instance InfoLessC Kind -instance InfoLessC KindType -instance InfoLessC KindRefType -instance InfoLessC TyVar -instance InfoLessC Ty -instance InfoLessC TyApp -instance InfoLessC ForeignRef -instance InfoLessC LocalRef -instance InfoLessC TyRef -instance InfoLessC TyDef -instance InfoLessC TyAbs -instance InfoLessC TyArg -instance InfoLessC TyBody -instance InfoLessC Constructor -instance InfoLessC Sum -instance InfoLessC Field -instance InfoLessC Record -instance InfoLessC Tuple -instance InfoLessC Product -instance InfoLessC ForeignClassRef -instance InfoLessC LocalClassRef -instance InfoLessC TyClassRef -instance InfoLessC ClassDef -instance InfoLessC InstanceClause -instance InfoLessC Constraint -instance InfoLessC Module -instance InfoLessC InferenceErr -instance InfoLessC KindCheckErr -instance InfoLessC CompilerInput -instance InfoLessC KindCheckError -instance InfoLessC CompilerError -instance InfoLessC CompilerResult +instance (Ord k, InfoLessC v) => InfoLessC (OMap k v) where + infoLessId om = infoLessId <$> om diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/Types.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/Types.hs index 88a2d757..b8454544 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/Types.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/ProtoCompat/Types.hs @@ -1,9 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} --- this is needed so the deriving via can generate Arbitrary instances for data --- definitions with more than 4 constructors -{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-} module LambdaBuffers.Compiler.ProtoCompat.Types ( localRef2ForeignRef, @@ -48,137 +44,97 @@ module LambdaBuffers.Compiler.ProtoCompat.Types ( TyRef (..), TyVar (..), VarName (..), - defSourceInfo, InferenceErr, KindCheckErr, ) where import Control.Exception (Exception) import Control.Lens (Getter, to, (^.)) +import Data.Default (Default (def)) import Data.Generics.Labels () import Data.Map (Map) -import Data.Set (Set) +import Data.Map.Ordered (OMap) import Data.Text (Text) import GHC.Generics (Generic) import Generics.SOP qualified as SOP -import Test.QuickCheck (Gen, oneof, resize, sized) -import Test.QuickCheck.Arbitrary.Generic (Arbitrary (arbitrary), GenericArbitrary (GenericArbitrary)) -import Test.QuickCheck.Instances.Semigroup () -import Test.QuickCheck.Instances.Text () +import LambdaBuffers.Compiler.ProtoCompat.InfoLess (InfoLess, InfoLessC (infoLessId)) data SourceInfo = SourceInfo {file :: Text, posFrom :: SourcePosition, posTo :: SourcePosition} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary SourceInfo deriving anyclass (SOP.Generic) data SourcePosition = SourcePosition {column :: Int, row :: Int} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary SourcePosition deriving anyclass (SOP.Generic) -defSourceInfo :: SourceInfo -defSourceInfo = SourceInfo "" (SourcePosition 0 0) (SourcePosition 0 0) +instance Default SourceInfo where + def = SourceInfo "" (SourcePosition 0 0) (SourcePosition 0 0) {- | NOTE(gnumonik): I need a "generic name" type for my template haskell, this shouldn't be used anywhere outside of that -} data LBName = LBName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary LBName deriving anyclass (SOP.Generic) data TyName = TyName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyName deriving anyclass (SOP.Generic) data ConstrName = ConstrName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ConstrName deriving anyclass (SOP.Generic) data ModuleName = ModuleName {parts :: [ModuleNamePart], sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ModuleName deriving anyclass (SOP.Generic) data ModuleNamePart = ModuleNamePart {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ModuleNamePart deriving anyclass (SOP.Generic) data VarName = VarName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary VarName deriving anyclass (SOP.Generic) data FieldName = FieldName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary FieldName deriving anyclass (SOP.Generic) data ClassName = ClassName {name :: Text, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ClassName deriving anyclass (SOP.Generic) newtype Kind = Kind {kind :: KindType} deriving stock (Show, Eq, Ord, Generic) deriving anyclass (SOP.Generic) -instance Arbitrary Kind where - arbitrary = sized fn - where - fn n = Kind <$> resize n arbitrary data KindType = KindRef KindRefType | KindArrow Kind Kind deriving stock (Show, Eq, Ord, Generic) deriving anyclass (SOP.Generic) -instance Arbitrary KindType where - arbitrary = sized fn - where - fn n - | n <= 0 = KindRef <$> arbitrary - | otherwise = KindArrow <$> resize (n `div` 2) arbitrary <*> resize (n `div` 2) arbitrary data KindRefType = KUnspecified | KType deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary KindRefType deriving anyclass (SOP.Generic) newtype TyVar = TyVar {varName :: VarName} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyVar deriving anyclass (SOP.Generic) data Ty = TyVarI TyVar | TyAppI TyApp | TyRefI TyRef deriving stock (Show, Eq, Ord, Generic) deriving anyclass (SOP.Generic) -instance Arbitrary Ty where - arbitrary = sized fn - where - fn :: (Num a, Ord a) => a -> Gen Ty - fn n - | n <= 0 = TyRefI <$> arbitrary - | otherwise = - oneof - [ TyVarI <$> arbitrary - , TyAppI <$> arbitrary - , TyRefI <$> arbitrary - ] data TyApp = TyApp {tyFunc :: Ty, tyArgs :: [Ty], sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyApp deriving anyclass (SOP.Generic) data ForeignRef = ForeignRef {tyName :: TyName, moduleName :: ModuleName, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ForeignRef deriving anyclass (SOP.Generic) data LocalRef = LocalRef {tyName :: TyName, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary LocalRef deriving anyclass (SOP.Generic) localRef2ForeignRef :: ModuleName -> Getter LocalRef ForeignRef @@ -194,57 +150,46 @@ localRef2ForeignRef modName = data TyRef = LocalI LocalRef | ForeignI ForeignRef deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyRef deriving anyclass (SOP.Generic) data TyDef = TyDef {tyName :: TyName, tyAbs :: TyAbs, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyDef deriving anyclass (SOP.Generic) -data TyAbs = TyAbs {tyArgs :: Map VarName TyArg, tyBody :: TyBody, sourceInfo :: SourceInfo} +data TyAbs = TyAbs {tyArgs :: OMap (InfoLess VarName) TyArg, tyBody :: TyBody, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyAbs deriving anyclass (SOP.Generic) data TyArg = TyArg {argName :: VarName, argKind :: Kind, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyArg deriving anyclass (SOP.Generic) data TyBody = OpaqueI SourceInfo | SumI Sum deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyBody deriving anyclass (SOP.Generic) data Constructor = Constructor {constrName :: ConstrName, product :: Product} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Constructor deriving anyclass (SOP.Generic) -data Sum = Sum {constructors :: Map ConstrName Constructor, sourceInfo :: SourceInfo} +data Sum = Sum {constructors :: OMap (InfoLess ConstrName) Constructor, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Sum deriving anyclass (SOP.Generic) data Field = Field {fieldName :: FieldName, fieldTy :: Ty} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Field deriving anyclass (SOP.Generic) -data Record = Record {fields :: Map FieldName Field, sourceInfo :: SourceInfo} +data Record = Record {fields :: OMap (InfoLess FieldName) Field, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Record deriving anyclass (SOP.Generic) data Tuple = Tuple {fields :: [Ty], sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Tuple deriving anyclass (SOP.Generic) data Product = RecordI Record | TupleI Tuple deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Product deriving anyclass (SOP.Generic) data ForeignClassRef = ForeignClassRef @@ -253,19 +198,16 @@ data ForeignClassRef = ForeignClassRef , sourceInfo :: SourceInfo } deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ForeignClassRef deriving anyclass (SOP.Generic) data LocalClassRef = LocalClassRef {className :: ClassName, sourceInfo :: SourceInfo} deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary LocalClassRef deriving anyclass (SOP.Generic) data TyClassRef = LocalCI LocalClassRef | ForeignCI ForeignClassRef deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary TyClassRef deriving anyclass (SOP.Generic) data ClassDef = ClassDef @@ -276,7 +218,6 @@ data ClassDef = ClassDef , sourceInfo :: SourceInfo } deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary ClassDef deriving anyclass (SOP.Generic) data InstanceClause = InstanceClause @@ -288,55 +229,31 @@ data InstanceClause = InstanceClause deriving stock (Show, Eq, Ord, Generic) deriving anyclass (SOP.Generic) -instance Arbitrary InstanceClause where - arbitrary = sized fn - where - fn n = - InstanceClause - <$> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - data Constraint = Constraint { classRef :: TyClassRef , argument :: Ty , sourceInfo :: SourceInfo } deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary Constraint deriving anyclass (SOP.Generic) data Module = Module { moduleName :: ModuleName - , typeDefs :: Map TyName TyDef - , classDefs :: Map ClassName ClassDef + , typeDefs :: Map (InfoLess TyName) TyDef + , classDefs :: Map (InfoLess ClassName) ClassDef , instances :: [InstanceClause] - , imports :: Set ModuleName + , imports :: Map (InfoLess ModuleName) ModuleName , sourceInfo :: SourceInfo } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (SOP.Generic) -instance Arbitrary Module where - arbitrary = sized fn - where - fn n = - Module - <$> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - <*> resize n arbitrary - data InferenceErr = UnboundTermErr Text | ImpossibleErr Text | UnificationErr Text | RecursiveSubstitutionErr Text deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary InferenceErr deriving anyclass (SOP.Generic) instance Exception InferenceErr @@ -345,21 +262,15 @@ data KindCheckErr = InconsistentTypeErr TyDef | InferenceFailure TyDef InferenceErr deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary KindCheckErr deriving anyclass (SOP.Generic) instance Exception KindCheckErr -newtype CompilerInput = CompilerInput {modules :: Map ModuleName Module} +newtype CompilerInput = CompilerInput {modules :: Map (InfoLess ModuleName) Module} deriving stock (Show, Eq, Ord, Generic) deriving newtype (Monoid, Semigroup) deriving anyclass (SOP.Generic) -instance Arbitrary CompilerInput where - arbitrary = sized fn - where - fn n = CompilerInput <$> resize n arbitrary - data KindCheckError = UnboundTyVarError TyDef TyVar ModuleName | UnboundTyRefError TyDef TyRef ModuleName @@ -367,8 +278,8 @@ data KindCheckError | RecursiveKindError TyDef ModuleName | InconsistentTypeError TyDef Kind Kind ModuleName deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary KindCheckError deriving anyclass (SOP.Generic) + instance Exception KindCheckError -- | All the compiler errors. @@ -376,12 +287,56 @@ data CompilerError = CompKindCheckError KindCheckError | InternalError Text deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary CompilerError deriving anyclass (SOP.Generic) data CompilerResult = CompilerResult deriving stock (Show, Eq, Ord, Generic) - deriving (Arbitrary) via GenericArbitrary CompilerResult deriving anyclass (SOP.Generic) type CompilerOutput = Either CompilerError CompilerResult + +-- | InfoLess instances +instance InfoLessC SourceInfo where + infoLessId = const def + +instance InfoLessC SourcePosition +instance InfoLessC LBName +instance InfoLessC TyName +instance InfoLessC ConstrName +instance InfoLessC ModuleName +instance InfoLessC ModuleNamePart +instance InfoLessC VarName +instance InfoLessC FieldName +instance InfoLessC ClassName +instance InfoLessC Kind +instance InfoLessC KindType +instance InfoLessC KindRefType +instance InfoLessC TyVar +instance InfoLessC Ty +instance InfoLessC TyApp +instance InfoLessC ForeignRef +instance InfoLessC LocalRef +instance InfoLessC TyRef +instance InfoLessC TyDef +instance InfoLessC TyAbs +instance InfoLessC TyArg +instance InfoLessC TyBody +instance InfoLessC Constructor +instance InfoLessC Sum +instance InfoLessC Field +instance InfoLessC Record +instance InfoLessC Tuple +instance InfoLessC Product +instance InfoLessC ForeignClassRef +instance InfoLessC LocalClassRef +instance InfoLessC TyClassRef +instance InfoLessC ClassDef +instance InfoLessC InstanceClause +instance InfoLessC Constraint +instance InfoLessC Module +instance InfoLessC InferenceErr +instance InfoLessC KindCheckErr +instance InfoLessC CompilerInput +instance InfoLessC KindCheckError +instance InfoLessC CompilerError +instance InfoLessC CompilerResult diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck.hs index 567483d6..d0ab2223 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck.hs @@ -6,7 +6,6 @@ module LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles, detectSupe 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 @@ -80,7 +79,7 @@ detectSuperclassCycles cds = case detectSuperclassCycles' cds of format :: [Text] -> Doc a format = hcat . punctuate " => " . map pretty -runDeriveCheck :: P.ModuleName -> ModuleBuilder -> Either TypeClassError () +runDeriveCheck :: P.InfoLess P.ModuleName -> ModuleBuilder -> Either TypeClassError () runDeriveCheck mn mb = mconcat <$> traverse go (S.toList $ mbInstances mb) where go :: Instance -> Either TypeClassError () @@ -94,7 +93,7 @@ runDeriveCheck mn mb = mconcat <$> traverse go (S.toList $ mbInstances mb) -- 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' :: P.CompilerInput -> Either TypeClassError (M.Map (P.InfoLess P.ModuleName) ModuleBuilder) validateTypeClasses' ci = do -- detectSuperclassCycles ci moduleBuilders <- mkBuilders ci @@ -102,16 +101,16 @@ validateTypeClasses' ci = do 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 :: P.CompilerInput -> IO (M.Map (P.InfoLess 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 :: forall a. M.Map (P.InfoLess P.ModuleName) ModuleBuilder -> Doc a prettyBuilders = spaced . vcat . punctuate line . map (uncurry go) . M.toList where - go :: P.ModuleName -> ModuleBuilder -> Doc a + go :: P.InfoLess P.ModuleName -> ModuleBuilder -> Doc a go mn mb = "MODULE" - <+> pretty mn + <+> P.withInfoLess mn pretty indent 2 (pretty mb) diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Compat.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Compat.hs index 5b1f6e81..0e99df2e 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Compat.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Compat.hs @@ -14,7 +14,7 @@ import Control.Lens ((^.)) import Control.Lens.Combinators (view) import Data.Bifunctor (second) import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M +import Data.Map.Ordered qualified as OMap import Data.Text qualified as T import LambdaBuffers.Compiler.ProtoCompat qualified as P import LambdaBuffers.Compiler.TypeClassCheck.Pat ( @@ -49,20 +49,20 @@ making the resulting Pat suitable for substitution into Rules. -} defToExp :: P.TyDef -> Exp defToExp (P.TyDef tName (P.TyAbs tArgs tBody _) _) = DecE (LitE . Name $ tName ^. #name) vars $ case tBody of - P.SumI constrs -> toSumE . fmap (uncurry goConstr . second (view #product)) . M.toList $ (constrs ^. #constructors) + P.SumI constrs -> toSumE . fmap (uncurry goConstr . second (view #product)) . OMap.assocs $ (constrs ^. #constructors) P.OpaqueI _ -> LitE Opaque where - collectFreeTyVars :: [P.VarName] -> Exp - collectFreeTyVars = foldr (\x acc -> LitE (TyVar (x ^. #name)) *: acc) nil + collectFreeTyVars :: [P.InfoLess P.VarName] -> Exp + collectFreeTyVars = foldr (\x' acc -> P.withInfoLess x' (\x -> LitE (TyVar (x ^. #name)) *: acc)) nil - vars = collectFreeTyVars (M.keys tArgs) + vars = collectFreeTyVars (fst <$> OMap.assocs tArgs) - goConstr :: P.ConstrName -> P.Product -> Exp - goConstr (P.ConstrName n _) p = LitE (Name n) *= goProduct p + goConstr :: P.InfoLess P.ConstrName -> P.Product -> Exp + goConstr cn' p = P.withInfoLess cn' (\cn -> LitE (Name $ cn ^. #name) *= goProduct p) goProduct :: P.Product -> Exp goProduct = \case - P.RecordI (P.Record rMap _) -> toRecE . fmap goField . M.elems $ rMap + P.RecordI (P.Record rMap _) -> toRecE . fmap goField $ (snd <$> OMap.assocs rMap) P.TupleI (P.Tuple pList _) -> toProdE $ fmap tyToExp pList goField :: P.Field -> Exp @@ -89,20 +89,20 @@ appToExp fun (p : ps) = case NE.nonEmpty ps of defToPat :: P.TyDef -> Pat defToPat (P.TyDef tName (P.TyAbs tArgs tBody _) _) = DecP (LitP . Name $ tName ^. #name) vars $ case tBody of - P.SumI constrs -> toSumP . fmap (uncurry goConstr . second (view #product)) . M.toList $ (constrs ^. #constructors) + P.SumI constrs -> toSumP . fmap (uncurry goConstr . second (view #product)) . OMap.assocs $ (constrs ^. #constructors) P.OpaqueI _ -> LitP Opaque where - collectFreeTyVars :: [P.VarName] -> Pat - collectFreeTyVars = foldr (\x acc -> LitP (TyVar (x ^. #name)) *: acc) nil + collectFreeTyVars :: [P.InfoLess P.VarName] -> Pat + collectFreeTyVars = foldr (\x' acc -> P.withInfoLess x' (\x -> LitP (TyVar (x ^. #name)) *: acc)) nil - vars = collectFreeTyVars (M.keys tArgs) + vars = collectFreeTyVars (fst <$> OMap.assocs tArgs) - goConstr :: P.ConstrName -> P.Product -> Pat - goConstr (P.ConstrName n _) p = LitP (Name n) *= goProduct p + goConstr :: P.InfoLess P.ConstrName -> P.Product -> Pat + goConstr cn' p = P.withInfoLess cn' (\cn -> LitP (Name $ cn ^. #name) *= goProduct p) goProduct :: P.Product -> Pat goProduct = \case - P.RecordI (P.Record rMap _) -> toRecP . fmap goField . M.elems $ rMap + P.RecordI (P.Record rMap _) -> toRecP . fmap goField $ (snd <$> OMap.assocs rMap) P.TupleI (P.Tuple pList _) -> toProdP $ fmap tyToPat pList goField :: P.Field -> Pat diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Pretty.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Pretty.hs index 2f8b0093..1c4ecf72 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Pretty.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Pretty.hs @@ -10,7 +10,6 @@ module LambdaBuffers.Compiler.TypeClassCheck.Pretty ( ) where import Control.Lens.Operators ((^.)) -import Data.Generics.Labels () import Data.Text qualified as T import LambdaBuffers.Compiler.ProtoCompat qualified as P import LambdaBuffers.Compiler.TypeClassCheck.Pat ( diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Utils.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Utils.hs index 90a467e4..d2e7a501 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Utils.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Utils.hs @@ -20,7 +20,6 @@ import Control.Lens.Combinators (Ixed (ix)) import Control.Monad.Except (MonadError (throwError)) import Control.Monad.State (foldM) import Data.List (foldl') -import Data.Map.Internal (traverseWithKey) import GHC.Generics (Generic) import Data.Map qualified as M @@ -52,6 +51,8 @@ import LambdaBuffers.Compiler.ProtoCompat.Types qualified as P ( ) import LambdaBuffers.Compiler.TypeClassCheck.Pat (Exp, Literal (ModuleName), Pat (AppP, ConsP, DecP, LabelP, LitP, NilP, ProdP, RecP, RefP, SumP, VarP)) +import Data.Foldable (Foldable (toList)) +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as P import LambdaBuffers.Compiler.TypeClassCheck.Pretty (pointies, ()) import LambdaBuffers.Compiler.TypeClassCheck.Solve (Overlap (Overlap)) import Prettyprinter ( @@ -77,10 +78,10 @@ data TypeClassError | MissingModuleInstances P.ModuleName | MissingModuleScope P.ModuleName | ClassNotFoundInModule Text [Text] - | LocalTyRefNotFound T.Text P.ModuleName + | LocalTyRefNotFound T.Text (P.InfoLess P.ModuleName) | SuperclassCycleDetected [[FQClassName]] - | FailedToSolveConstraints P.ModuleName [Constraint Exp] Instance - | MalformedTyDef P.ModuleName Exp + | FailedToSolveConstraints (P.InfoLess P.ModuleName) [Constraint Exp] Instance + | MalformedTyDef (P.InfoLess P.ModuleName) Exp | BadInstance BasicConditionViolation deriving stock (Show, Eq, Generic) @@ -104,7 +105,7 @@ instance Pretty TypeClassError where "Error: Expected to find a type definition for a type named" <+> pretty txt <+> "in module" - <+> pretty mn + <+> P.withInfoLess mn pretty <+> "but it isn't there!" SuperclassCycleDetected crs -> "Error: Superclass cycles detected in compiler input:" @@ -120,7 +121,7 @@ instance Pretty TypeClassError where <> line <> line <> indent 2 "in module" - <+> pretty mn + <+> P.withInfoLess mn pretty <> line <> line <> indent 2 "because the following constraint(s) were not satisfied:" @@ -132,7 +133,7 @@ instance Pretty TypeClassError where <> line <> indent 2 (pretty xp) <> line - <> indent 2 ("in module" <+> pretty mn) + <> indent 2 ("in module" <+> P.withInfoLess mn pretty) BadInstance bcv -> pretty bcv data BasicConditionViolation @@ -230,8 +231,8 @@ data ClassInfo = ClassInfo {ciName :: FQClassName, ciSupers :: [FQClassName]} type Classes = S.Set Class -mkClassInfos :: [P.Module] -> M.Map P.ModuleName [ClassInfo] -mkClassInfos = foldl' (\acc mdl -> M.insert (mdl ^. #moduleName) (go mdl) acc) M.empty +mkClassInfos :: [P.Module] -> M.Map (P.InfoLess P.ModuleName) [ClassInfo] +mkClassInfos = foldl' (\acc mdl -> M.insert (P.mkInfoLess $ mdl ^. #moduleName) (go mdl) acc) M.empty where go :: P.Module -> [ClassInfo] go m = map (defToClassInfo $ m ^. #moduleName) (M.elems $ m ^. #classDefs) @@ -255,7 +256,7 @@ toClassMap = foldl' (\acc (ClassInfo nm sups) -> M.insert nm sups acc) M.empty This constructs a Map where the keys are fully qualified class names and the values are values of the Class data type from TypeClass.Rules -} -buildClasses :: M.Map P.ModuleName [ClassInfo] -> Either TypeClassError (M.Map FQClassName Class) +buildClasses :: M.Map (P.InfoLess P.ModuleName) [ClassInfo] -> Either TypeClassError (M.Map FQClassName Class) buildClasses cis = foldM go M.empty (concat $ M.elems cis) where superclasses = foldl' M.union M.empty $ M.elems (toClassMap <$> cis) @@ -300,7 +301,7 @@ getInstances ctable mn = foldM go S.empty where cref = tyRefToFQClassName (modulename mn) cn -mkModuleClasses :: P.CompilerInput -> M.Map P.ModuleName [ClassInfo] +mkModuleClasses :: P.CompilerInput -> M.Map (P.InfoLess P.ModuleName) [ClassInfo] mkModuleClasses (P.CompilerInput ms) = mkClassInfos (M.elems ms) {- | @@ -309,39 +310,36 @@ This constructs the instances defined in each module (NOT the instances in scope mkModuleInstances :: P.CompilerInput -> M.Map FQClassName Class -> - Either TypeClassError (M.Map P.ModuleName Instances) + Either TypeClassError (M.Map (P.InfoLess P.ModuleName) Instances) mkModuleInstances (P.CompilerInput ms) ctable = foldM go M.empty ms where - go :: M.Map P.ModuleName Instances -> P.Module -> Either TypeClassError (M.Map P.ModuleName Instances) + go :: M.Map (P.InfoLess P.ModuleName) Instances -> P.Module -> Either TypeClassError (M.Map (P.InfoLess P.ModuleName) Instances) go acc modl = case getInstances ctable (modl ^. #moduleName) (modl ^. #instances) of Left e -> Left e - Right is -> Right $ M.insert (modl ^. #moduleName) is acc - -moduleMap :: P.CompilerInput -> M.Map P.ModuleName P.Module -moduleMap (P.CompilerInput ms) = foldl' (\acc m -> M.insert (m ^. #moduleName) m acc) M.empty ms + Right is -> Right $ M.insert (P.mkInfoLess $ modl ^. #moduleName) is acc {- | This fetches the *Rules* used as the scope for constraint solving for a given module. -} moduleScope :: - M.Map P.ModuleName P.Module -> - M.Map P.ModuleName Instances -> + M.Map (P.InfoLess P.ModuleName) P.Module -> + M.Map (P.InfoLess P.ModuleName) Instances -> P.ModuleName -> Either TypeClassError (S.Set (Rule Pat)) moduleScope modls is = go where go :: P.ModuleName -> Either TypeClassError Instances - go mn = case modls ^? (ix mn . #imports) of + go mn = case modls ^? (ix (P.mkInfoLess mn) . #imports) of Nothing -> Left $ UnknownModule mn - Just impts -> mconcat <$> traverse goImport (S.toList impts) + Just impts -> mconcat <$> traverse goImport (toList impts) -- NOTE: This doesn't do recursive scope fetching anymore. -- If a user wants an instance rule in scope, they -- have to import the module (or something from it) -- (this is how it works in haskell/ps/rust) goImport :: P.ModuleName -> Either TypeClassError Instances - goImport mn = case is ^? ix mn of + goImport mn = case is ^? ix (P.mkInfoLess mn) of Nothing -> Left $ UnknownModule mn Just insts -> Right $ contextualize mn insts @@ -368,31 +366,28 @@ lookupOr k m e = case M.lookup k m of Nothing -> Left e Just v -> Right v -mkBuilders :: P.CompilerInput -> Either TypeClassError (M.Map P.ModuleName ModuleBuilder) +mkBuilders :: P.CompilerInput -> Either TypeClassError (M.Map (P.InfoLess P.ModuleName) ModuleBuilder) mkBuilders ci = do classTable <- buildClasses classInfos insts <- mkModuleInstances ci classTable - scope <- traverseWithKey (\k _ -> moduleScope modTable insts k) modTable - foldM (go classTable insts scope) M.empty (M.keys modTable) + scope <- traverse (\m -> moduleScope (ci ^. #modules) insts (m ^. #moduleName)) (ci ^. #modules) + foldM (go classTable insts scope) M.empty (ci ^. #modules) where - modTable :: M.Map P.ModuleName P.Module - modTable = moduleMap ci - - classInfos :: M.Map P.ModuleName [ClassInfo] + classInfos :: M.Map (P.InfoLess P.ModuleName) [ClassInfo] classInfos = mkModuleClasses ci go :: M.Map FQClassName Class -> - M.Map P.ModuleName Instances -> - M.Map P.ModuleName Instances -> - M.Map P.ModuleName ModuleBuilder -> - P.ModuleName -> - Either TypeClassError (M.Map P.ModuleName ModuleBuilder) - go classTable insts scope acc mn = do - mbinsts <- lookupOr mn insts $ MissingModuleInstances mn - mbscope <- lookupOr mn scope $ MissingModuleScope mn - mdule <- lookupOr mn modTable $ UnknownModule mn - mbclasses <- resolveClasses classTable mn . M.elems $ mdule ^. #classDefs + M.Map (P.InfoLess P.ModuleName) Instances -> + M.Map (P.InfoLess P.ModuleName) Instances -> + M.Map (P.InfoLess P.ModuleName) ModuleBuilder -> + P.Module -> + Either TypeClassError (M.Map (P.InfoLess P.ModuleName) ModuleBuilder) + go classTable insts scope acc m = do + mbinsts <- lookupOr (P.mkInfoLess $ m ^. #moduleName) insts $ MissingModuleInstances $ m ^. #moduleName + mbscope <- lookupOr (P.mkInfoLess $ m ^. #moduleName) scope $ MissingModuleScope $ m ^. #moduleName + mdule <- lookupOr (P.mkInfoLess $ m ^. #moduleName) (ci ^. #modules) $ UnknownModule $ m ^. #moduleName + mbclasses <- resolveClasses classTable (m ^. #moduleName) . M.elems $ mdule ^. #classDefs let mbtydefs = foldl' ( \accM t -> @@ -410,7 +405,7 @@ mkBuilders ci = do , mbClasses = mbclasses , mbScope = mbscope } - pure $ M.insert mn mb acc + pure $ M.insert (P.mkInfoLess $ m ^. #moduleName) mb acc resolveClasses :: M.Map FQClassName Class -> diff --git a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Validate.hs b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Validate.hs index 98c0a1e9..539c3fb5 100644 --- a/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Validate.hs +++ b/lambda-buffers-compiler/src/LambdaBuffers/Compiler/TypeClassCheck/Validate.hs @@ -15,6 +15,7 @@ module LambdaBuffers.Compiler.TypeClassCheck.Validate ( import Data.Set qualified as S import Control.Monad.Except (throwError) +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as P import LambdaBuffers.Compiler.ProtoCompat.Types qualified as P ( ModuleName, ) @@ -63,7 +64,7 @@ constraintClass (C c _) = c -- NOTE: Practically this enforces the "must define instances where types are defined" -- half of Haskell's orphan instances rule. We could relax that in various ways -- but it would require reworking a lot of the utilities above. -checkDerive :: P.ModuleName -> ModuleBuilder -> Rule Pat -> Either TypeClassError [Constraint Exp] +checkDerive :: P.InfoLess P.ModuleName -> ModuleBuilder -> Rule Pat -> Either TypeClassError [Constraint Exp] checkDerive mn mb i = concat <$> secondPass where secondPass :: Either TypeClassError [[Constraint Exp]] diff --git a/lambda-buffers-compiler/test/Test/DeriveCheck.hs b/lambda-buffers-compiler/test/Test/DeriveCheck.hs index c54a29b0..41b1d4d5 100644 --- a/lambda-buffers-compiler/test/Test/DeriveCheck.hs +++ b/lambda-buffers-compiler/test/Test/DeriveCheck.hs @@ -5,11 +5,12 @@ module Test.DeriveCheck (test) where import Control.Lens (Prism, _Left, _Right) import Control.Lens.Extras (is) -import Data.Generics.Labels () +import Data.Default (Default (def)) import Data.Generics.Sum.Constructors (AsConstructor (_Ctor)) import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text) +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC import LambdaBuffers.Compiler.ProtoCompat.Types qualified as PC import LambdaBuffers.Compiler.TypeClassCheck (runDeriveCheck) import LambdaBuffers.Compiler.TypeClassCheck.Pat ( @@ -168,12 +169,10 @@ tyVarP :: Text -> Pat tyVarP t = LitP (TyVar t) runTest :: ModuleBuilder -> Either TypeClassError () -runTest = runDeriveCheck (moduleName1 "") +runTest = runDeriveCheck (PC.mkInfoLess $ moduleName1 "") where moduleName1 :: Text -> PC.ModuleName - moduleName1 nm = PC.ModuleName [PC.ModuleNamePart nm si] si - si = PC.SourceInfo "" pos pos - pos = PC.SourcePosition 0 0 + moduleName1 nm = PC.ModuleName [PC.ModuleNamePart nm def] def {- Test 1: Basic test. Should pass module A where diff --git a/lambda-buffers-compiler/test/Test/KindCheck.hs b/lambda-buffers-compiler/test/Test/KindCheck.hs index effd90d5..3fe7e10e 100644 --- a/lambda-buffers-compiler/test/Test/KindCheck.hs +++ b/lambda-buffers-compiler/test/Test/KindCheck.hs @@ -5,12 +5,14 @@ import LambdaBuffers.Compiler.KindCheck ( foldWithArrowToType, ) -import LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, (:->:))) +import Hedgehog (Gen, forAll, property, (===)) +import Hedgehog.Gen (choice, int, list) +import Hedgehog.Range qualified as R +import LambdaBuffers.Compiler.KindCheck.Kind (Kind (KType, KVar, (:->:))) import Test.KindCheck.Errors (testGKindCheckErrors) -import Test.QuickCheck (Arbitrary (arbitrary), forAll, (===)) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.HUnit (HasCallStack, assertBool, testCase, (@?=)) +import Test.Tasty.Hedgehog (testProperty) import Test.Utils.CompilerInput ( compilerInput'either, compilerInput'incoherent, @@ -138,8 +140,22 @@ testArrowFoldHHK = foldWithArrowToType [ty, (ty :->: ty) :->: ty, ty] @?= (ty :->: (((ty :->: ty) :->: ty) :->: (ty :->: ty))) -testFoldWithArrowToTypeTotal :: TestTree +testFoldWithArrowToTypeTotal :: HasCallStack => TestTree testFoldWithArrowToTypeTotal = - testProperty "foldWithArrowToType is total" $ - forAll arbitrary $ - \ts -> foldWithArrowToType ts === foldWithArrowToType ts + testProperty + "foldWithArrowToType is total" + ( property $ do + ts <- forAll genKinds + foldWithArrowToType ts === foldWithArrowToType ts + ) + where + genKind :: Gen Kind + genKind = + choice + [ return KType + , KVar . toInteger <$> int (R.constant 0 100) + , (:->:) <$> genKind <*> genKind + ] + + genKinds :: Gen [Kind] + genKinds = list (R.constant 0 10) genKind diff --git a/lambda-buffers-compiler/test/Test/TypeClassCheck.hs b/lambda-buffers-compiler/test/Test/TypeClassCheck.hs index a001e1c9..a0164351 100644 --- a/lambda-buffers-compiler/test/Test/TypeClassCheck.hs +++ b/lambda-buffers-compiler/test/Test/TypeClassCheck.hs @@ -9,6 +9,7 @@ import Data.Map qualified as Map import Data.ProtoLens (Message (defMessage)) import Data.Text (Text) import LambdaBuffers.Compiler.ProtoCompat (runFromProto) +import LambdaBuffers.Compiler.ProtoCompat.InfoLess qualified as PC import LambdaBuffers.Compiler.ProtoCompat.Types qualified as ProtoCompat import LambdaBuffers.Compiler.TypeClassCheck (detectSuperclassCycles') import LambdaBuffers.Compiler.TypeClassCheck.Pat ( @@ -56,7 +57,7 @@ noCycleDetected :: TestTree noCycleDetected = testCase "No cycle detected" $ do nocycles' <- fromProto' nocycles - case Map.lookup (_ModuleName ["ModuleWithNoClassCycles"]) (nocycles' ^. #modules) of + case Map.lookup (PC.mkInfoLess $ _ModuleName ["ModuleWithNoClassCycles"]) (nocycles' ^. #modules) of Nothing -> assertFailure "Failed lookup to ModuleWithClassNoClassCycles" Just m -> detectSuperclassCycles' (toList $ m ^. #classDefs) @?= [] @@ -64,7 +65,7 @@ cycleDetected :: TestTree cycleDetected = testCase "Cycle detected" $ do cycles' <- fromProto' cycles - case Map.lookup (_ModuleName ["ModuleWithClassCycles"]) (cycles' ^. #modules) of + case Map.lookup (PC.mkInfoLess $ _ModuleName ["ModuleWithClassCycles"]) (cycles' ^. #modules) of Nothing -> assertFailure "Failed lookup to ModuleWithClassCycles" Just m -> detectSuperclassCycles' (toList $ m ^. #classDefs) @?= [["Bar", "Foo", "Bop", "Bar"], ["Bop", "Bar", "Foo", "Bop"], ["Foo", "Bop", "Bar", "Foo"]] diff --git a/lambda-buffers-compiler/test/Test/Utils/Constructors.hs b/lambda-buffers-compiler/test/Test/Utils/Constructors.hs index 41f0c44c..f5ebf341 100644 --- a/lambda-buffers-compiler/test/Test/Utils/Constructors.hs +++ b/lambda-buffers-compiler/test/Test/Utils/Constructors.hs @@ -33,39 +33,40 @@ import LambdaBuffers.Compiler.ProtoCompat.Types (SourceInfo) import Proto.Compiler_Fields () import Data.Default (def) +import Data.Map.Ordered qualified as OMap _CompilerInput :: [PC.Module] -> PC.CompilerInput _CompilerInput ms = PC.CompilerInput - { PC.modules = Map.fromList [(m ^. #moduleName, m) | m <- ms] + { PC.modules = Map.fromList [(PC.mkInfoLess $ m ^. #moduleName, m) | m <- ms] } _Module :: PC.ModuleName -> [PC.TyDef] -> [PC.ClassDef] -> [PC.InstanceClause] -> PC.Module _Module mn tds cds ins = PC.Module { PC.moduleName = mn - , PC.typeDefs = Map.fromList [(td ^. #tyName, td) | td <- tds] - , PC.classDefs = Map.fromList [(cd ^. #className, cd) | cd <- cds] + , PC.typeDefs = Map.fromList [(PC.mkInfoLess $ td ^. #tyName, td) | td <- tds] + , PC.classDefs = Map.fromList [(PC.mkInfoLess $ cd ^. #className, cd) | cd <- cds] , PC.instances = ins , PC.imports = mempty - , PC.sourceInfo = PC.defSourceInfo + , PC.sourceInfo = def } _ModuleName :: [Text] -> PC.ModuleName _ModuleName ps = PC.ModuleName { PC.parts = _ModuleNamePart <$> ps - , PC.sourceInfo = PC.defSourceInfo + , PC.sourceInfo = def } _ModuleNamePart :: Text -> PC.ModuleNamePart -_ModuleNamePart n = PC.ModuleNamePart n PC.defSourceInfo +_ModuleNamePart n = PC.ModuleNamePart n def _TyName :: Text -> PC.TyName -_TyName x = PC.TyName x PC.defSourceInfo +_TyName x = PC.TyName x def _VarName :: Text -> PC.VarName -_VarName = flip _VarName' PC.defSourceInfo +_VarName = flip _VarName' def _VarName' :: Text -> PC.SourceInfo -> PC.VarName _VarName' x s = PC.VarName {PC.name = x, PC.sourceInfo = s} @@ -95,7 +96,7 @@ _TupleI x = PC.TupleI $ PC.Tuple { PC.fields = x - , PC.sourceInfo = PC.defSourceInfo + , PC.sourceInfo = def } _Constructor :: Text -> PC.Product -> PC.Constructor @@ -109,15 +110,15 @@ _ConstrName :: Text -> PC.ConstrName _ConstrName x = PC.ConstrName { PC.name = x - , PC.sourceInfo = PC.defSourceInfo + , PC.sourceInfo = def } _Sum :: [(Text, PC.Product)] -> PC.TyBody _Sum cs = PC.SumI $ PC.Sum - { constructors = Map.fromList [(ctor ^. #constrName, ctor) | (cn, cp) <- cs, ctor <- [_Constructor cn cp]] - , sourceInfo = PC.defSourceInfo + { constructors = OMap.fromList [(PC.mkInfoLess $ ctor ^. #constrName, ctor) | (cn, cp) <- cs, ctor <- [_Constructor cn cp]] + , sourceInfo = def } _TyApp :: PC.Ty -> PC.Ty -> PC.Ty @@ -132,30 +133,30 @@ _TyApp ty1 ty2 = _TyAbs :: [(Text, PC.KindType)] -> [(Text, PC.Product)] -> PC.TyAbs _TyAbs args body = PC.TyAbs - { PC.tyArgs = Map.fromList [(ta ^. #argName, ta) | ta <- _TyArg <$> args] + { PC.tyArgs = OMap.fromList [(PC.mkInfoLess $ ta ^. #argName, ta) | ta <- _TyArg <$> args] , PC.tyBody = _Sum body - , sourceInfo = PC.defSourceInfo + , sourceInfo = def } _TyArg :: (Text, PC.KindType) -> PC.TyArg _TyArg (a, k) = PC.TyArg - { PC.argName = PC.VarName a PC.defSourceInfo + { PC.argName = PC.VarName a def , PC.argKind = PC.Kind {PC.kind = k} - , PC.sourceInfo = PC.defSourceInfo + , PC.sourceInfo = def } _Type :: PC.KindType _Type = PC.KindRef PC.KType _TyDef :: PC.TyName -> PC.TyAbs -> PC.TyDef -_TyDef name ab = PC.TyDef {PC.tyName = name, PC.tyAbs = ab, sourceInfo = PC.defSourceInfo} +_TyDef name ab = PC.TyDef {PC.tyName = name, PC.tyAbs = ab, sourceInfo = def} _TyRefILocal :: Text -> PC.Ty _TyRefILocal x = PC.TyRefI $ PC.LocalI $ _LocalRef x _LocalRef :: Text -> PC.LocalRef -_LocalRef = flip _LocalRef' PC.defSourceInfo +_LocalRef = flip _LocalRef' def -- | LocalRef with Source Info - for error precision testing. _LocalRef' :: Text -> PC.SourceInfo -> PC.LocalRef @@ -166,7 +167,7 @@ _LocalRef' x s = } _ForeignRef :: Text -> [Text] -> PC.ForeignRef -_ForeignRef n m = _ForeignRef' n (_ModuleName m) PC.defSourceInfo +_ForeignRef n m = _ForeignRef' n (_ModuleName m) def _ForeignRef' :: Text -> PC.ModuleName -> PC.SourceInfo -> PC.ForeignRef _ForeignRef' x m s = diff --git a/lambda-buffers-extras/lambda-buffers-extras.cabal b/lambda-buffers-extras/lambda-buffers-extras.cabal index cd4b1cc0..0b128681 100644 --- a/lambda-buffers-extras/lambda-buffers-extras.cabal +++ b/lambda-buffers-extras/lambda-buffers-extras.cabal @@ -86,7 +86,6 @@ library hs-source-dirs: src build-depends: , base >=4.16 - , generic-lens >=2.2.1.0 , lambda-buffers-compiler >=0.1 , lens >=5.2 , template-haskell >=2.18 diff --git a/lambda-buffers-extras/src/LambdaBuffers/Extras/TH.hs b/lambda-buffers-extras/src/LambdaBuffers/Extras/TH.hs index 2a07b609..4f590752 100644 --- a/lambda-buffers-extras/src/LambdaBuffers/Extras/TH.hs +++ b/lambda-buffers-extras/src/LambdaBuffers/Extras/TH.hs @@ -14,7 +14,6 @@ module LambdaBuffers.Extras.TH ( ) where import Control.Lens ((^.)) -import Data.Generics.Labels () import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text qualified as T import LambdaBuffers.Compiler.ProtoCompat.Types (