diff --git a/lib/Eclair.hs b/lib/Eclair.hs index cce54d91..a4e1ef45 100644 --- a/lib/Eclair.hs +++ b/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) diff --git a/lib/Eclair/AST/Analysis.hs b/lib/Eclair/AST/Analysis.hs index cd27f29a..0df9602e 100644 --- a/lib/Eclair/AST/Analysis.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index cb5150dc..ec1b0d31 100644 --- a/src/Main.hs +++ b/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 diff --git a/tests/Test/Eclair/AST/AnalysisSpec.hs b/tests/Test/Eclair/AST/AnalysisSpec.hs index 4a0dd864..4b78c2c2 100644 --- a/tests/Test/Eclair/AST/AnalysisSpec.hs +++ b/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 diff --git a/tests/Test/Eclair/EIR/LowerSpec.hs b/tests/Test/Eclair/EIR/LowerSpec.hs index 84fca619..cad447c5 100644 --- a/tests/Test/Eclair/EIR/LowerSpec.hs +++ b/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| diff --git a/tests/Test/Eclair/RA/LowerSpec.hs b/tests/Test/Eclair/RA/LowerSpec.hs index e8166cfc..48c09b74 100644 --- a/tests/Test/Eclair/RA/LowerSpec.hs +++ b/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"