Do semantic analysis as part of typechecking step

This is a temporary workaround until the main compiler pipeline requires
the analysis results. We need to do this to avoid running into undefined
situations further down in the pipeline!

lib/Eclair.hs

@@ -43,7 +43,7 @@ type EIR = EIR.EIR
 data EclairError
   = ParseErr ParseError
   | TypeErr [TS.TypeError]
-  | SemanticErr SA.SemanticError
+  | SemanticErr SA.SemanticErrors
   deriving (Show, Exception)
 
 
@@ -99,13 +99,15 @@ rules = \case
     liftIO $ either (throwIO . ParseErr) pure =<< parseFile path
   RunSemanticAnalysis path -> do
     ast <- fst <$> Rock.fetch (Parse path)
-    liftIO $ SA.runAnalysis ast
-    -- TODO: throwing the exception causes some tests fail:
-    -- result <- liftIO $ SA.runAnalysis ast
-    -- liftIO $ forM_ (SA.maybeToSemanticError result) (throwIO . SemanticErr)
-    -- pure result
+    result <- liftIO $ SA.runAnalysis ast
+    let errors = SA.semanticErrors result
+    when (SA.hasSemanticErrors result) $ do
+      liftIO $ (throwIO . SemanticErr) errors
+    pure result
   Typecheck path -> do
     ast <- fst <$> Rock.fetch (Parse path)
+    -- TODO: find better place to do semantic analysis
+    _ <- Rock.fetch (RunSemanticAnalysis path)
     liftIO . either (throwIO . TypeErr) pure $ TS.typeCheck ast
   CompileRA path -> do
     ast <- fst <$> Rock.fetch (Parse path)

lib/Eclair/AST/Analysis.hs

@@ -2,9 +2,9 @@
 
 module Eclair.AST.Analysis
   ( Result(..)
-  , SemanticError(..)
+  , SemanticErrors(..)
+  , hasSemanticErrors
   , runAnalysis
-  , maybeToSemanticError
   , UngroundedVar(..)
   , MissingTypedef(..)
   , EmptyModule(..)
@@ -134,37 +134,34 @@ data SemanticAnalysis
 -- TODO: change to Vector when finished for performance
 type Container = []
 
+type SemanticInfo = ()  -- TODO: not used atm
+
 data Result
   = Result
-  { emptyModules :: Container EmptyModule
-  , ungroundedVars :: Container UngroundedVar
-  , missingTypedefs :: Container MissingTypedef
-  , ruleClausesWithSameVar :: Container RuleClauseSameVar -- TODO remove once support is added for this!
-  } deriving (Eq, Show)
-
-data SemanticError
-  = SemanticError (Container EmptyModule)
-                  (Container UngroundedVar)
-                  (Container MissingTypedef)
+  { semanticInfo :: SemanticInfo
+  , semanticErrors :: SemanticErrors
+  }
+  deriving (Eq, Show)
+
+data SemanticErrors
+  = SemanticErrors
+    { emptyModules :: Container EmptyModule
+    , ungroundedVars :: Container UngroundedVar
+    , missingTypedefs :: Container MissingTypedef
+    , ruleClausesWithSameVar :: Container RuleClauseSameVar  -- TODO remove once support is added for this!
+    }
   deriving (Eq, Show, Exception)
 
 hasSemanticErrors :: Result -> Bool
 hasSemanticErrors result =
-  not $ isNull emptyModules &&
-        isNull ungroundedVars &&
-        isNull missingTypedefs
+  isNotNull emptyModules ||
+  isNotNull ungroundedVars ||
+  isNotNull missingTypedefs ||
+  isNotNull ruleClausesWithSameVar
   where
-    isNull :: (Result -> Container a) -> Bool
-    isNull f = null (f result)
-
-maybeToSemanticError :: Result -> Maybe SemanticError
-maybeToSemanticError result
-  | hasSemanticErrors result
-  = Just $ SemanticError (emptyModules result)
-                         (ungroundedVars result)
-                         (missingTypedefs result)
-  | otherwise
-  = Nothing
+    errs = semanticErrors result
+    isNotNull :: (SemanticErrors -> [a]) -> Bool
+    isNotNull f = not . null $ f errs
 
 analysis :: S.Handle SemanticAnalysis -> S.Analysis S.SouffleM IR.AST Result
 analysis prog = S.mkAnalysis addFacts run getFacts
@@ -201,11 +198,12 @@ analysis prog = S.mkAnalysis addFacts run getFacts
       S.run prog
 
     getFacts :: S.SouffleM Result
-    getFacts =
-      Result <$> S.getFacts prog
-             <*> S.getFacts prog
-             <*> S.getFacts prog
-             <*> S.getFacts prog
+    getFacts = do
+      errs <- SemanticErrors <$> S.getFacts prog
+                             <*> S.getFacts prog
+                             <*> S.getFacts prog
+                             <*> S.getFacts prog
+      pure $ Result () errs
 
     getNodeId :: IR.ASTF NodeId -> NodeId
     getNodeId = \case

src/Main.hs

@@ -3,19 +3,11 @@ module Main (main) where
 import qualified Data.Text.Lazy.IO as T
 import Control.Exception
 import LLVM.Pretty
-import qualified Eclair.AST.Analysis as SA
 import Eclair.ArgParser
 import Eclair
 import GHC.IO.Encoding
 
 
--- TODO: remove this hack, should be integrated into main compiler line.
--- this is only needed atm since main compiler pipeline doesn't use the actual semantic analysis results yet.
-manualSemanticAnalysis :: FilePath -> IO ()
-manualSemanticAnalysis file = do
-  result <- semanticAnalysis file
-  liftIO $ forM_ (SA.maybeToSemanticError result) (throwIO . SemanticErr)
-
 main :: IO ()
 main = do
   setLocaleEncoding utf8
@@ -27,6 +19,4 @@ main = do
             EmitRA -> emitRA
             EmitEIR -> emitEIR
             EmitLLVM -> emitLLVM
-      handle handleErrors $ do
-        manualSemanticAnalysis file
-        fn file
+      fn file `catch` handleErrors

tests/Test/Eclair/AST/AnalysisSpec.hs

@@ -4,16 +4,24 @@ module Test.Eclair.AST.AnalysisSpec
 
 import Test.Hspec
 import System.FilePath
+import Control.Exception
 import Eclair.AST.Analysis
 import Eclair.Id
 import Eclair
 
 
-check :: (Eq a, Show a) => (Result -> a) -> FilePath -> a -> IO ()
+check :: (Eq a, Show a) => (SemanticErrors -> [a]) -> FilePath -> [a] -> IO ()
 check f path expected = do
   let file = "tests/fixtures" </> path <.> "dl"
-  result <- semanticAnalysis file
-  f result `shouldBe` expected
+  result <- try $ semanticAnalysis file
+  case result of
+    Left (SemanticErr errs) ->
+      f errs `shouldBe` expected
+    Left e ->
+      panic $ "Received unexpected exception: " <> show e
+    Right _ ->
+      unless (null expected) $
+        panic "Expected SA errors, but found none!"
 
 checkUngroundedVars :: FilePath -> [Text] -> IO ()
 checkUngroundedVars path expectedVars =
@@ -35,9 +43,9 @@ checkEmptyModules =
 
 checkRuleClauseSameVar :: FilePath -> [Text] -> IO ()
 checkRuleClauseSameVar path expectedVars =
-  check getMissingTypedefs path (map Id expectedVars)
+  check getRuleClausesSameVar path (map Id expectedVars)
   where
-    getMissingTypedefs =
+    getRuleClausesSameVar =
       map (\(RuleClauseSameVar _ v) -> v) . ruleClausesWithSameVar
 
 spec :: Spec

tests/Test/Eclair/EIR/LowerSpec.hs

@@ -10,10 +10,12 @@ import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import Eclair
 import Eclair.Pretty
+import Eclair.AST.Analysis
 import System.FilePath
 import Test.Hspec
 import NeatInterpolation
 import LLVM.Codegen
+import Control.Exception
 
 -- Tip: compare LLVM IR with EIR from tests that generate pretty-printed EIR
 
@@ -24,6 +26,14 @@ cg path = do
   llvm <- compileLLVM file
   pure $ ppllvm llvm
 
+shouldFailWithCause :: (Eq a, Show a) => IO T.Text -> (SemanticErrors -> [a]) -> IO ()
+shouldFailWithCause m f =
+  try m >>= \case
+    Left (SemanticErr errs) ->
+      f errs `shouldNotBe` []
+    result ->
+      panic $ "Expected a failure, but got: " <> show result
+
 extractDeclTypeSnippet :: Text -> Text
 extractDeclTypeSnippet result =
   fromJust $ find (T.isPrefixOf "%program =") $ lines result
@@ -39,32 +49,7 @@ extractFnSnippet result fnSignature = do
 spec :: Spec
 spec = describe "LLVM Code Generation" $ parallel $ do
   it "generates almost no code for an empty program" $ do
-    llvmIR <- cg "empty"
-    extractDeclTypeSnippet llvmIR `shouldBe` "%program = type {}"
-    -- TODO: should not malloc 0 bytes, atleast 1 => semantic analysis should give a warning instead
-    extractFnSnippet llvmIR "eclair_program_init" `shouldBe` Just [text|
-      define external ccc %program* @eclair_program_init() {
-      start:
-        %memory_0 = call ccc i8* @malloc(i32 0)
-        %program_0 = bitcast i8* %memory_0 to %program*
-        ret %program* %program_0
-      }
-      |]
-    extractFnSnippet llvmIR "eclair_program_destroy" `shouldBe` Just [text|
-      define external ccc void @eclair_program_destroy(%program* %arg_0) {
-      start:
-        %memory_0 = bitcast %program* %arg_0 to i8*
-        call ccc void @free(i8* %memory_0)
-        ret void
-      }
-      |]
-    -- It generates an empty function (forward decl?), but apparently LLVM is fine with it, huh.
-    extractFnSnippet llvmIR "eclair_program_run" `shouldBe` Just [text|
-      define external ccc void @eclair_program_run(%program* %arg_0) {
-      start:
-        ret void
-      }
-      |]
+    cg "empty" `shouldFailWithCause` emptyModules
 
   it "generates code for a single fact" $ do
     llvmIR <- cg "single_fact"
@@ -1125,32 +1110,6 @@ spec = describe "LLVM Code Generation" $ parallel $ do
       |]
 
   describe "fact IO" $ parallel $ do
-    it "generates valid code for empty programs" $ do
-      llvmIR <- cg "empty"
-      extractFnSnippet llvmIR "eclair_add_fact" `shouldBe` Just [text|
-        define external ccc void @eclair_add_fact(%program* %eclair_program_0, i16 %fact_type_0, i32* %memory_0) {
-        start:
-          call ccc void @eclair_add_facts(%program* %eclair_program_0, i16 %fact_type_0, i32* %memory_0, i32 1)
-          ret void
-        }
-        |]
-      extractFnSnippet llvmIR "eclair_add_facts" `shouldBe` Just [text|
-        define external ccc void @eclair_add_facts(%program* %eclair_program_0, i16 %fact_type_0, i32* %memory_0, i32 %fact_count_0) {
-        start:
-          switch i16 %fact_type_0, label %switch.default_0 []
-        switch.default_0:
-          ret void
-        }
-        |]
-      extractFnSnippet llvmIR "eclair_get_facts" `shouldBe` Just [text|
-        define external ccc i32* @eclair_get_facts(%program* %eclair_program_0, i16 %fact_type_0) {
-        start:
-          switch i16 %fact_type_0, label %switch.default_0 []
-        switch.default_0:
-          ret i32* zeroinitializer
-        }
-        |]
-
     it "only generates IO code for relations visible to the user" $ do
       llvmIR <- cg "no_top_level_facts"
       extractFnSnippet llvmIR "eclair_add_facts" `shouldBe` Just [text|

tests/Test/Eclair/RA/LowerSpec.hs

@@ -5,12 +5,14 @@ module Test.Eclair.RA.LowerSpec
   ) where
 
 import qualified Data.Text as T
-import Eclair
 import qualified Eclair.EIR.IR as EIR
+import Eclair.AST.Analysis
 import Eclair.Pretty
+import Eclair
 import System.FilePath
 import Test.Hspec
 import NeatInterpolation
+import Control.Exception
 
 
 cg :: FilePath -> IO T.Text
@@ -61,28 +63,13 @@ extractFnSnippet result fnSignature =
 spec :: Spec
 spec = describe "EIR Code Generation" $ parallel $ do
   it "generates empty run function for empty program" $ do
-    eir <- cg "empty"
-    eir `shouldBe` [text|
-      {
-        declare_type Program
-        {
-
-        }
-        fn eclair_program_init() -> *Program
-        {
-          program = heap_allocate_program
-          return program
-        }
-        fn eclair_program_destroy(*Program) -> Void
-        {
-          free_program(FN_ARG[0])
-        }
-        fn eclair_program_run(*Program) -> Void
-        {
-
-        }
-      }
-      |]
+    let shouldFailWithCause m f = do
+          try m >>= \case
+            Left (SemanticErr errs) ->
+              f errs `shouldNotBe` []
+            result ->
+              panic $ "Expected a failure, but got: " <> show result
+    cg "empty" `shouldFailWithCause` emptyModules
 
   it "generates code for a single fact" $ do
     eir <- cg "single_fact"