From 393f907a51300381f8168d6f9f68b2dbca8bb657 Mon Sep 17 00:00:00 2001
From: Jan Mas Rovira <janmasrovira@gmail.com>
Date: Thu, 17 Feb 2022 22:00:58 +0100
Subject: [PATCH] [scoper] add error for unused operator syntax definitions

---
 src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs       |  2 ++
 .../Syntax/Concrete/Scoped/Error/Pretty/Base.hs     |  5 +++++
 src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs |  5 +++++
 src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs      | 13 ++++++++++---
 test/Scope/Negative.hs                              |  8 ++++++++
 tests/negative/UnusedOperatorDef.mjuvix             |  3 +++
 6 files changed, 33 insertions(+), 3 deletions(-)
 create mode 100644 tests/negative/UnusedOperatorDef.mjuvix

diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs
index d8a7a55f3..7834fc58a 100644
--- a/src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs
+++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Error.hs
@@ -28,6 +28,7 @@ data ScopeError
   | ErrMultipleExport MultipleExportConflict
   | ErrAmbiguousSym [SymbolEntry]
   | ErrAmbiguousModuleSym [SymbolEntry]
+  | ErrUnusedOperatorDef UnusedOperatorDef
   -- | Eventually this needs to go away
   | ErrGeneric Text
   deriving stock (Show)
@@ -49,6 +50,7 @@ ppScopeError s = case s of
   ErrMultipleExport e -> ppError e
   ErrAmbiguousSym {} -> undefined
   ErrAmbiguousModuleSym {} -> undefined
+  ErrUnusedOperatorDef e -> ppError e
 
 docStream :: ScopeError -> SimpleDocStream Eann
 docStream = layoutPretty defaultLayoutOptions . ppScopeError
diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Pretty/Base.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Pretty/Base.hs
index c07afdaae..0deb5d52d 100644
--- a/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Pretty/Base.hs
+++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Pretty/Base.hs
@@ -119,3 +119,8 @@ instance PrettyError ModuleNotInScope where
 
 instance PrettyError MegaParsecError where
   ppError MegaParsecError {..} = pretty _megaParsecError
+
+instance PrettyError UnusedOperatorDef where
+  ppError UnusedOperatorDef {..} =
+    "Unused operator syntax definition:" <> line
+    <> ppCode _unusedOperatorDef
diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs
index 0c4ba3324..789635035 100644
--- a/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs
+++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Error/Types.hs
@@ -74,3 +74,8 @@ newtype MegaParsecError = MegaParsecError {
   _megaParsecError :: Text
   }
  deriving stock (Show)
+
+newtype UnusedOperatorDef = UnusedOperatorDef {
+  _unusedOperatorDef :: OperatorSyntaxDef
+  }
+ deriving stock (Show)
diff --git a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs
index b011493ef..54fbe19a5 100644
--- a/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs
+++ b/src/MiniJuvix/Syntax/Concrete/Scoped/Scoper.hs
@@ -527,9 +527,16 @@ checkLocalModule Module {..} = do
     inheritEntry :: SymbolEntry -> SymbolEntry
     inheritEntry = over S.nameWhyInScope S.BecauseInherited
 
--- | TODO checks if there is an infix declaration without a binding.
-checkOrphanFixities :: Members '[Error ScopeError, State Scope] r => Sem r ()
-checkOrphanFixities = return ()
+checkOrphanFixities :: forall r .Members '[Error ScopeError, State Scope] r => Sem r ()
+checkOrphanFixities = do
+  path <- gets _scopePath
+  declared <- gets _scopeFixities
+  used <- gets (HashMap.keys . fmap (filter (== path) . HashMap.keys . _symbolInfo) . _scopeSymbols)
+  let unused = toList $ foldr HashMap.delete declared used
+  case unused of
+    [] -> return ()
+    (x : _) -> throw (ErrUnusedOperatorDef (UnusedOperatorDef x))
+
 
 symbolInfoSingle :: SymbolEntry -> SymbolInfo
 symbolInfoSingle p = SymbolInfo $ HashMap.singleton (S._nameDefinedIn p) p
diff --git a/test/Scope/Negative.hs b/test/Scope/Negative.hs
index 463be3318..22d7e86e8 100644
--- a/test/Scope/Negative.hs
+++ b/test/Scope/Negative.hs
@@ -103,4 +103,12 @@ tests = [
       case er of
         ErrModuleNotInScope {} -> Nothing
         _ -> wrongError
+
+  ,  NegTest "Unused operator syntax definition"
+    "."
+   "UnusedOperatorDef.mjuvix" $ \er ->
+      case er of
+        ErrUnusedOperatorDef {} -> Nothing
+        _ -> wrongError
+
   ]
diff --git a/tests/negative/UnusedOperatorDef.mjuvix b/tests/negative/UnusedOperatorDef.mjuvix
new file mode 100644
index 000000000..80f178e38
--- /dev/null
+++ b/tests/negative/UnusedOperatorDef.mjuvix
@@ -0,0 +1,3 @@
+module UnusedOperatorDef;
+  infixl 12 + ;
+end ;
\ No newline at end of file