diff --git a/sol-core.cabal b/sol-core.cabal index 93113804d..4d2989050 100644 --- a/sol-core.cabal +++ b/sol-core.cabal @@ -31,6 +31,8 @@ common common-opts , optparse-applicative , parser-combinators >= 1.3 , pretty + , prettyprinter + , prettyprinter-ansi-terminal , pretty-simple , split , syb @@ -72,6 +74,7 @@ library Solcore.Desugarer.ContractDispatch Solcore.Desugarer.ReplaceFunTypeArgs Solcore.Desugarer.UniqueTypeGen + Solcore.Diagnostics Solcore.Frontend.Lexer.SolcoreLexer Solcore.Frontend.Module.Identity Solcore.Frontend.Module.Loader @@ -83,6 +86,7 @@ library Solcore.Frontend.Syntax Solcore.Frontend.Syntax.Ty Solcore.Frontend.Syntax.Contract + Solcore.Frontend.Syntax.Location Solcore.Frontend.Syntax.Name Solcore.Frontend.Syntax.NameResolution Solcore.Frontend.Syntax.Stmt @@ -166,7 +170,10 @@ test-suite sol-core-tests -- cabal-fmt: expand test -Main other-modules: Cases + DiagnosticCliTests + DiagnosticTests HullCases + LocationTests MatchCompilerTests ModuleTypeCheckTests @@ -177,6 +184,7 @@ test-suite sol-core-tests , tasty-expected-failure , tasty-hunit , HUnit + , process build-tool-depends: sol-core:sol-core, sol-core:yule diff --git a/src/Language/Yul/Parser.hs b/src/Language/Yul/Parser.hs index 546c26cb6..fa59528d9 100644 --- a/src/Language/Yul/Parser.hs +++ b/src/Language/Yul/Parser.hs @@ -2,7 +2,7 @@ module Language.Yul.Parser (parseYul, yulBlock, yulStmt, yulExp) where import Common.LightYear import Language.Yul -import Solcore.Frontend.Syntax.Name (Name (..)) +import Solcore.Frontend.Syntax.Name (Name, pattern Name) import Text.Megaparsec.Char.Lexer qualified as L parseYul :: String -> Yul diff --git a/src/Solcore/Backend/Mast.hs b/src/Solcore/Backend/Mast.hs index 515bd38f1..e02b092ba 100644 --- a/src/Solcore/Backend/Mast.hs +++ b/src/Solcore/Backend/Mast.hs @@ -14,7 +14,7 @@ import Solcore.Frontend.Pretty.SolcorePretty () import Solcore.Frontend.Syntax.Contract (DataTy (..), Import (..)) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.Stmt (Literal (..)) -import Solcore.Frontend.Syntax.Ty (Ty (..), Tyvar (..)) +import Solcore.Frontend.Syntax.Ty (Ty (..), Tyvar (..), pattern TyCon) import Solcore.Primitives.Primitives (word) deployerName :: Name diff --git a/src/Solcore/Backend/Specialise.hs b/src/Solcore/Backend/Specialise.hs index d7e5a69ed..62529f7ce 100644 --- a/src/Solcore/Backend/Specialise.hs +++ b/src/Solcore/Backend/Specialise.hs @@ -21,7 +21,6 @@ import Solcore.Frontend.Syntax hiding (decls, name) import Solcore.Frontend.TypeInference.Id (Id (..)) import Solcore.Frontend.TypeInference.NameSupply import Solcore.Frontend.TypeInference.TcEnv (TcEnv (typeTable), TypeInfo (..)) -import Solcore.Frontend.TypeInference.TcUnify (typesDoNotUnify) import Solcore.Primitives.Primitives -- ** Specialisation state and monad @@ -655,7 +654,7 @@ specmgu (TyCon n ts) (TyCon n' ts') specsolve (zip ts ts') mempty specmgu (TyVar v) t = varBind v t specmgu t (TyVar v) = varBind v t -specmgu t1 t2 = typesDoNotUnify t1 t2 +specmgu t1 t2 = Left $ "types do not unify: " ++ pretty t1 ++ " and " ++ pretty t2 varBind :: (MonadError String m) => Tyvar -> Ty -> m TVSubst varBind v t diff --git a/src/Solcore/Desugarer/DecisionTreeCompiler.hs b/src/Solcore/Desugarer/DecisionTreeCompiler.hs index 7756ad3de..f7b9b9559 100644 --- a/src/Solcore/Desugarer/DecisionTreeCompiler.hs +++ b/src/Solcore/Desugarer/DecisionTreeCompiler.hs @@ -1,5 +1,6 @@ module Solcore.Desugarer.DecisionTreeCompiler where +import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Except import Control.Monad.Reader @@ -12,6 +13,7 @@ import Data.Map qualified as Map import Data.Maybe import Data.Ord (comparing) import Language.Yul (YulExp (..)) +import Solcore.Diagnostics qualified as Diag import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax import Solcore.Frontend.TypeInference.Id @@ -30,7 +32,7 @@ matchCompiler cunit = if null nonExaustive then pure $ Right (unit', redundant) - else pure $ Left $ unlines $ map showWarning nonExaustive + else pure $ Left $ unlines $ map (Diag.encodeDiagnostic . warningAsErrorDiagnostic) nonExaustive -- type class for the defining the pattern matching compilation -- over the syntax tree @@ -63,7 +65,7 @@ instance Compile (TopDecl Id) where instance Compile (Contract Id) where compile (Contract n vs ds) = Contract n vs - <$> local (\(te, ctx) -> (Map.union env' te, ctx ++ ["contract " ++ pretty n])) (compile ds) + <$> local (\(te, ctx, warnSpan) -> (Map.union env' te, ctx ++ ["contract " ++ pretty n], warnSpan)) (compile ds) where ds' = [d | (CDataDecl d) <- ds] env' = foldr addDataTyInfo Map.empty ds' @@ -102,7 +104,7 @@ instance Compile (Stmt Id) where For <$> compile initStmt <*> compile cond <*> compile postStmt <*> compile body compile s@(Asm _) = pure s - compile (Match es eqns) = do + compile matchStmt@(Match es eqns) = withWarnSpan (sourceSpanOf matchStmt) $ do es' <- compile es eqns' <- mapM compileEqn eqns scrutTys <- mapM scrutineeType es' @@ -143,7 +145,9 @@ compileMatrix :: compileMatrix tys _ [] _ = do pats <- mapM freshPat tys ctx <- askWarnCtx - unless (null pats) $ tell [NonExhaustive ctx pats] + unless (null pats) $ do + warnSpan <- askWarnSpan + tell [NonExhaustive ctx warnSpan pats] pure Fail compileMatrix _tys occs (firstRow : _restRows) ((firstBinds, firstAct) : _restBacts) | all isVarPat firstRow = do @@ -233,7 +237,8 @@ buildConSwitch testOcc restOccs _testTy restTys matrix bacts headCons = do pure (PCon k fieldPats : restWit) [] -> mapM freshPat restTys ctx <- askWarnCtx - tell [NonExhaustive ctx witPats] + warnSpan <- askWarnSpan + tell [NonExhaustive ctx warnSpan witPats] pure (Just Fail) else Just <$> compileMatrix restTys restOccs defMat defBacts @@ -256,7 +261,8 @@ buildLitSwitch testOcc restOccs testTy restTys matrix bacts headLits = do litWit <- freshPat testTy restWit <- mapM freshPat restTys ctx <- askWarnCtx - tell [NonExhaustive ctx (litWit : restWit)] + warnSpan <- askWarnSpan + tell [NonExhaustive ctx warnSpan (litWit : restWit)] pure (Just Fail) else Just <$> compileMatrix restTys restOccs defMat defBacts pure (LitSwitch testOcc branches mDefault) @@ -377,24 +383,31 @@ litBranchToEqn occMap (lit, tree) = do type WarnCtx = [String] type CompilerM a = - ReaderT (TypeEnv, WarnCtx) (ExceptT String (WriterT [Warning] (StateT Int IO))) a + ReaderT (TypeEnv, WarnCtx, Maybe Diag.SourceSpan) (ExceptT String (WriterT [Warning] (StateT Int IO))) a runCompilerM :: TypeEnv -> CompilerM a -> IO (Either String (a, [Warning])) runCompilerM env m = do - ((r, ws), _) <- runStateT (runWriterT (runExceptT (runReaderT m (env, [])))) 0 + ((r, ws), _) <- runStateT (runWriterT (runExceptT (runReaderT m (env, [], Nothing)))) 0 case r of Left err -> pure $ Left err Right t -> pure $ Right (t, ws) askTypeEnv :: CompilerM TypeEnv -askTypeEnv = asks fst +askTypeEnv = asks (\(typeEnv, _, _) -> typeEnv) askWarnCtx :: CompilerM WarnCtx -askWarnCtx = asks snd +askWarnCtx = asks (\(_, warnCtx, _) -> warnCtx) + +askWarnSpan :: CompilerM (Maybe Diag.SourceSpan) +askWarnSpan = asks (\(_, _, warnSpan) -> warnSpan) pushCtx :: String -> CompilerM a -> CompilerM a -pushCtx s = local (\(te, ctx) -> (te, ctx ++ [s])) +pushCtx s = local (\(te, ctx, warnSpan) -> (te, ctx ++ [s], warnSpan)) + +withWarnSpan :: Maybe Diag.SourceSpan -> CompilerM a -> CompilerM a +withWarnSpan sourceSpan = + local (\(te, ctx, currentSpan) -> (te, ctx, sourceSpan <|> currentSpan)) lookupConInfo :: Name -> CompilerM ConInfo lookupConInfo k = do @@ -699,7 +712,7 @@ checkRedundancy ctx tys matrix bacts = go [] (zip matrix bacts) go _ [] = pure () go prefix ((row, (_, act)) : rest) = do useful <- isUseful tys prefix row - unless useful $ tell [RedundantClause ctx row act] + unless useful $ tell [RedundantClause ctx (sourceSpanOf row) row act] go (prefix ++ [row]) rest -- Maranget's U(P, q): returns True iff row q adds new coverage that no @@ -799,20 +812,20 @@ inhabitsLitCol matrix ty restTys = do -- warnings data Warning - = RedundantClause WarnCtx PatternRow Action - | NonExhaustive WarnCtx [Pattern] + = RedundantClause WarnCtx (Maybe Diag.SourceSpan) PatternRow Action + | NonExhaustive WarnCtx (Maybe Diag.SourceSpan) [Pattern] deriving (Eq, Show) isNonExaustive :: Warning -> Bool -isNonExaustive (NonExhaustive _ _) = True +isNonExaustive (NonExhaustive _ _ _) = True isNonExaustive _ = False -- Pretty-print a warning showWarning :: Warning -> String -showWarning (RedundantClause ctx row blk) = +showWarning (RedundantClause ctx _ row blk) = unwords ["Warning: Clause ", "(", pretty (row, blk), ") is redundant.", showWarnCtx ctx] -showWarning (NonExhaustive ctx pats) = +showWarning (NonExhaustive ctx _ pats) = unwords ["Non-exhaustive pattern match. Missing case:", showRow $ nub pats, showWarnCtx ctx] showWarnCtx :: WarnCtx -> String @@ -822,6 +835,51 @@ showWarnCtx ctx = "\n in " ++ intercalate "\n in " (reverse ctx) showRow :: [Pattern] -> String showRow = intercalate ", " . map pretty +warningDiagnostic :: Warning -> Diag.Diagnostic +warningDiagnostic (RedundantClause ctx sourceSpan row blk) = + Diag.Diagnostic + { Diag.diagnosticSeverity = Diag.Warning, + Diag.diagnosticCode = Just (Diag.DiagnosticCode "SC0301"), + Diag.diagnosticMessage = "redundant pattern clause", + Diag.diagnosticLabels = warningLabels "redundant clause" sourceSpan, + Diag.diagnosticNotes = + [ "clause: " ++ pretty (row, blk) + ] + ++ warningContextNotes ctx, + Diag.diagnosticHelp = ["remove this clause or make an earlier pattern more specific"] + } +warningDiagnostic (NonExhaustive ctx sourceSpan pats) = + Diag.Diagnostic + { Diag.diagnosticSeverity = Diag.Warning, + Diag.diagnosticCode = Just (Diag.DiagnosticCode "SC0302"), + Diag.diagnosticMessage = "non-exhaustive pattern match", + Diag.diagnosticLabels = warningLabels "non-exhaustive match" sourceSpan, + Diag.diagnosticNotes = + ["missing case: " ++ showRow (nub pats)] + ++ warningContextNotes ctx, + Diag.diagnosticHelp = ["add a clause that covers the missing case"] + } + +warningLabels :: String -> Maybe Diag.SourceSpan -> [Diag.Label] +warningLabels _ Nothing = [] +warningLabels message (Just sourceSpan) = + [ Diag.Label + { Diag.labelSpan = sourceSpan, + Diag.labelStyle = Diag.Primary, + Diag.labelMessage = Just message + } + ] + +warningAsErrorDiagnostic :: Warning -> Diag.Diagnostic +warningAsErrorDiagnostic warning = + (warningDiagnostic warning) + { Diag.diagnosticSeverity = Diag.Error + } + +warningContextNotes :: WarnCtx -> [String] +warningContextNotes = + map ("in: " ++) . reverse + -- error messages undefinedConstructorError :: Name -> CompilerM a diff --git a/src/Solcore/Diagnostics.hs b/src/Solcore/Diagnostics.hs new file mode 100644 index 000000000..7c8341bc0 --- /dev/null +++ b/src/Solcore/Diagnostics.hs @@ -0,0 +1,731 @@ +module Solcore.Diagnostics + ( Severity (..), + DiagnosticCode (..), + SourceSpan (..), + LabelStyle (..), + Label (..), + Diagnostic (..), + CompilerError (..), + SourceId (..), + SourceToken (..), + SourceFile (..), + SourceMap, + DiagnosticFormat (..), + ColorChoice (..), + UnicodeChoice (..), + DiagnosticRenderOptions (..), + defaultDiagnosticRenderOptions, + resolveDiagnosticRenderOptions, + makeSourceFile, + sourceMapFromFiles, + emptySourceMap, + insertSourceFile, + lookupSourceFile, + sourceMapFiles, + sourceMapNull, + findTokenSpansInSource, + findTextSpansInSource, + combineSourceSpans, + legacyDiagnostic, + addDiagnosticNote, + addDiagnosticHelp, + diagnosticCompilerError, + diagnosticsCompilerError, + legacyCompilerError, + compilerErrorDiagnostics, + compilerErrorText, + compilerErrorFromString, + mapCompilerErrorDiagnostics, + encodeDiagnostic, + decodeDiagnostic, + diagnosticPrimarySpan, + renderDiagnostic, + renderDiagnostics, + ) +where + +import Data.Char (isAlpha, isAlphaNum) +import Data.Generics (Data, Typeable) +import Data.List (foldl', isPrefixOf, sortOn, stripPrefix, tails) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Prettyprinter (Doc, LayoutOptions (..), PageWidth (..), layoutPretty, pretty, vsep) +import Prettyprinter.Render.String (renderString) +import System.Environment (lookupEnv) +import System.IO (hIsTerminalDevice, stdout) +import Text.Read (readMaybe) + +data Severity + = Error + | Warning + deriving (Eq, Ord, Read, Show) + +newtype DiagnosticCode = DiagnosticCode String + deriving (Eq, Ord, Read, Show) + +data SourceSpan + = SourceSpan + { spanFile :: FilePath, + spanStartByte :: Int, + spanEndByte :: Int, + spanStartLine :: Int, + spanStartColumn :: Int, + spanEndLine :: Int, + spanEndColumn :: Int + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +data LabelStyle + = Primary + | Secondary + deriving (Eq, Ord, Read, Show) + +data Label + = Label + { labelSpan :: SourceSpan, + labelStyle :: LabelStyle, + labelMessage :: Maybe String + } + deriving (Eq, Ord, Read, Show) + +data Diagnostic + = Diagnostic + { diagnosticSeverity :: Severity, + diagnosticCode :: Maybe DiagnosticCode, + diagnosticMessage :: String, + diagnosticLabels :: [Label], + diagnosticNotes :: [String], + diagnosticHelp :: [String] + } + deriving (Eq, Ord, Read, Show) + +data CompilerError + = CompilerDiagnostics [Diagnostic] + | CompilerLegacyError String + deriving (Eq, Ord, Show) + +newtype SourceId = SourceId FilePath + deriving (Eq, Ord, Show) + +data SourceFile + = SourceFile + { sourceId :: SourceId, + sourcePath :: FilePath, + sourceText :: String, + sourceLineStarts :: [Int], + sourceTokens :: [SourceToken] + } + deriving (Eq, Ord, Show) + +data SourceToken + = SourceToken + { sourceTokenText :: String, + sourceTokenSpan :: SourceSpan + } + deriving (Eq, Ord, Show) + +newtype SourceMap = SourceMap (Map FilePath SourceFile) + deriving (Eq, Ord, Show) + +data DiagnosticFormat + = DiagnosticHuman + | DiagnosticShort + deriving (Eq, Ord, Show) + +data ColorChoice + = ColorAuto + | ColorAlways + | ColorNever + deriving (Eq, Ord, Show) + +data UnicodeChoice + = UnicodeAuto + | UnicodeAlways + | UnicodeNever + deriving (Eq, Ord, Show) + +data DiagnosticRenderOptions + = DiagnosticRenderOptions + { diagnosticColor :: ColorChoice, + diagnosticUnicode :: UnicodeChoice, + diagnosticWidth :: Int, + diagnosticFormat :: DiagnosticFormat + } + deriving (Eq, Ord, Show) + +defaultDiagnosticRenderOptions :: DiagnosticRenderOptions +defaultDiagnosticRenderOptions = + DiagnosticRenderOptions + { diagnosticColor = ColorAuto, + diagnosticUnicode = UnicodeAuto, + diagnosticWidth = 100, + diagnosticFormat = DiagnosticHuman + } + +resolveDiagnosticRenderOptions :: DiagnosticRenderOptions -> IO DiagnosticRenderOptions +resolveDiagnosticRenderOptions opts = do + isTerminal <- hIsTerminalDevice stdout + columns <- lookupEnv "COLUMNS" + pure + opts + { diagnosticColor = resolveColor isTerminal (diagnosticColor opts), + diagnosticUnicode = resolveUnicode isTerminal (diagnosticUnicode opts), + diagnosticWidth = resolveWidth columns (diagnosticWidth opts) + } + +resolveColor :: Bool -> ColorChoice -> ColorChoice +resolveColor isTerminal ColorAuto + | isTerminal = ColorAlways + | otherwise = ColorNever +resolveColor _ choice = choice + +resolveUnicode :: Bool -> UnicodeChoice -> UnicodeChoice +resolveUnicode isTerminal UnicodeAuto + | isTerminal = UnicodeAlways + | otherwise = UnicodeNever +resolveUnicode _ choice = choice + +resolveWidth :: Maybe String -> Int -> Int +resolveWidth columns width + | width == diagnosticWidth defaultDiagnosticRenderOptions = + maybe width (max 20) (columns >>= readMaybe) + | otherwise = width + +makeSourceFile :: FilePath -> String -> SourceFile +makeSourceFile path content = + SourceFile + { sourceId = SourceId path, + sourcePath = path, + sourceText = content, + sourceLineStarts = computeLineStarts content, + sourceTokens = computeSourceTokens path content + } + +sourceMapFromFiles :: [SourceFile] -> SourceMap +sourceMapFromFiles = + foldl' (\sourceMap source -> insertSourceFile source sourceMap) emptySourceMap + +emptySourceMap :: SourceMap +emptySourceMap = SourceMap Map.empty + +insertSourceFile :: SourceFile -> SourceMap -> SourceMap +insertSourceFile source (SourceMap sources) = + SourceMap (Map.insert (sourcePath source) source sources) + +lookupSourceFile :: FilePath -> SourceMap -> Maybe SourceFile +lookupSourceFile path (SourceMap sources) = + Map.lookup path sources + +sourceMapFiles :: SourceMap -> [SourceFile] +sourceMapFiles (SourceMap sources) = + Map.elems sources + +sourceMapNull :: SourceMap -> Bool +sourceMapNull (SourceMap sources) = + Map.null sources + +findTokenSpansInSource :: SourceFile -> String -> [SourceSpan] +findTokenSpansInSource source needle + | null needle = [] + | otherwise = + [ sourceTokenSpan sourceToken + | sourceToken <- sourceTokens source, + sourceTokenText sourceToken == needle + ] + +findTextSpansInSource :: SourceFile -> String -> [SourceSpan] +findTextSpansInSource source needle + | null needle = [] + | otherwise = + [ lineSpan lineNo lineStart column + | (lineNo, lineStart, lineText) <- sourceLinesWithOffsets source, + column <- findColumns needle lineText + ] + where + needleLen = length needle + lineSpan lineNo lineStart column = + SourceSpan + { spanFile = sourcePath source, + spanStartByte = lineStart + column - 1, + spanEndByte = lineStart + column - 1 + needleLen, + spanStartLine = lineNo, + spanStartColumn = column, + spanEndLine = lineNo, + spanEndColumn = column + needleLen + } + +combineSourceSpans :: SourceSpan -> SourceSpan -> SourceSpan +combineSourceSpans left right + | spanFile left /= spanFile right = left + | otherwise = + SourceSpan + { spanFile = spanFile left, + spanStartByte = spanStartByte start, + spanEndByte = spanEndByte end, + spanStartLine = spanStartLine start, + spanStartColumn = spanStartColumn start, + spanEndLine = spanEndLine end, + spanEndColumn = spanEndColumn end + } + where + start + | spanStartByte left <= spanStartByte right = left + | otherwise = right + end + | spanEndByte left >= spanEndByte right = left + | otherwise = right + +sourceLinesWithOffsets :: SourceFile -> [(Int, Int, String)] +sourceLinesWithOffsets source = + zipWith3 + (\lineNo lineStart lineText -> (lineNo, lineStart, lineText)) + [1 ..] + (sourceLineStarts source) + (sourceLines source) + +findColumns :: String -> String -> [Int] +findColumns needle haystack = + [column | (column, suffix) <- zip [1 ..] (tails haystack), needle `isPrefixOf` suffix] + +legacyDiagnostic :: String -> Diagnostic +legacyDiagnostic msg = + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Nothing, + diagnosticMessage = message, + diagnosticLabels = [], + diagnosticNotes = notes, + diagnosticHelp = [] + } + where + (message, notes) = + case lines msg of + [] -> ("", []) + firstLine : restLines -> (firstLine, restLines) + +addDiagnosticNote :: String -> Diagnostic -> Diagnostic +addDiagnosticNote note diagnostic = + diagnostic {diagnosticNotes = appendUnique note (diagnosticNotes diagnostic)} + +addDiagnosticHelp :: String -> Diagnostic -> Diagnostic +addDiagnosticHelp help diagnostic = + diagnostic {diagnosticHelp = appendUnique help (diagnosticHelp diagnostic)} + +diagnosticCompilerError :: Diagnostic -> CompilerError +diagnosticCompilerError diagnostic = + CompilerDiagnostics [diagnostic] + +diagnosticsCompilerError :: [Diagnostic] -> CompilerError +diagnosticsCompilerError diagnostics = + CompilerDiagnostics diagnostics + +legacyCompilerError :: String -> CompilerError +legacyCompilerError = + CompilerLegacyError + +compilerErrorDiagnostics :: CompilerError -> [Diagnostic] +compilerErrorDiagnostics (CompilerDiagnostics diagnostics) = diagnostics +compilerErrorDiagnostics (CompilerLegacyError message) = [legacyDiagnostic message] + +compilerErrorText :: CompilerError -> String +compilerErrorText (CompilerDiagnostics diagnostics) = + unlines (map encodeDiagnostic diagnostics) +compilerErrorText (CompilerLegacyError message) = message + +compilerErrorFromString :: String -> CompilerError +compilerErrorFromString err = + case mapM decodeDiagnostic (filter (not . null) (lines err)) of + Just diagnostics + | not (null diagnostics) -> CompilerDiagnostics diagnostics + _ -> + case decodeDiagnostic err of + Just diagnostic -> CompilerDiagnostics [diagnostic] + Nothing -> CompilerLegacyError err + +mapCompilerErrorDiagnostics :: ([Diagnostic] -> [Diagnostic]) -> CompilerError -> CompilerError +mapCompilerErrorDiagnostics f (CompilerDiagnostics diagnostics) = + CompilerDiagnostics (f diagnostics) +mapCompilerErrorDiagnostics f (CompilerLegacyError message) = + CompilerDiagnostics (f [legacyDiagnostic message]) + +appendUnique :: String -> [String] -> [String] +appendUnique item items + | null item = items + | item `elem` items = items + | otherwise = items ++ [item] + +encodeDiagnostic :: Diagnostic -> String +encodeDiagnostic diagnostic = + diagnosticEnvelopePrefix ++ show diagnostic + +decodeDiagnostic :: String -> Maybe Diagnostic +decodeDiagnostic raw = do + encoded <- stripPrefix diagnosticEnvelopePrefix raw + readMaybe encoded + +diagnosticEnvelopePrefix :: String +diagnosticEnvelopePrefix = "\STXsolcore-diagnostic\ETX" + +diagnosticPrimarySpan :: Diagnostic -> Maybe SourceSpan +diagnosticPrimarySpan diagnostic = + case filter ((== Primary) . labelStyle) (diagnosticLabels diagnostic) of + label : _ -> Just (labelSpan label) + [] -> + case diagnosticLabels diagnostic of + label : _ -> Just (labelSpan label) + [] -> Nothing + +renderDiagnostics :: DiagnosticRenderOptions -> SourceMap -> [Diagnostic] -> String +renderDiagnostics opts sources diagnostics = + joinWithBlankLines (map (renderDiagnostic opts sources) diagnostics) + +renderDiagnostic :: DiagnosticRenderOptions -> SourceMap -> Diagnostic -> String +renderDiagnostic opts sources diagnostic = + case diagnosticFormat opts of + DiagnosticShort -> renderShortDiagnostic opts diagnostic + DiagnosticHuman -> renderDoc opts (vsep (map pretty (humanDiagnosticLines opts sources diagnostic))) + +renderDoc :: DiagnosticRenderOptions -> Doc ann -> String +renderDoc opts = + renderString . layoutPretty layoutOptions + where + layoutOptions = + LayoutOptions + { layoutPageWidth = AvailablePerLine (max 20 (diagnosticWidth opts)) 1.0 + } + +renderShortDiagnostic :: DiagnosticRenderOptions -> Diagnostic -> String +renderShortDiagnostic opts diagnostic = + case diagnosticPrimarySpan diagnostic of + Just sourceSpan -> + spanFile sourceSpan + ++ ":" + ++ show (spanStartLine sourceSpan) + ++ ":" + ++ show (spanStartColumn sourceSpan) + ++ ": " + ++ diagnosticHeader opts diagnostic + Nothing -> diagnosticHeader opts diagnostic + +humanDiagnosticLines :: DiagnosticRenderOptions -> SourceMap -> Diagnostic -> [String] +humanDiagnosticLines opts sources diagnostic = + [diagnosticHeader opts diagnostic] + ++ locationLines opts diagnostic + ++ labelSnippetLines opts (diagnosticSeverity diagnostic) sources (diagnosticLabels diagnostic) + ++ concatMap (prefixedWrappedLines opts "note: ") (diagnosticNotes diagnostic) + ++ concatMap (prefixedWrappedLines opts "help: ") (diagnosticHelp diagnostic) + +diagnosticHeader :: DiagnosticRenderOptions -> Diagnostic -> String +diagnosticHeader opts diagnostic = + colorize opts (severityAnsi (diagnosticSeverity diagnostic)) header + ++ ": " + ++ diagnosticMessage diagnostic + where + header = severityName (diagnosticSeverity diagnostic) ++ codeText (diagnosticCode diagnostic) + +severityName :: Severity -> String +severityName Error = "error" +severityName Warning = "warning" + +codeText :: Maybe DiagnosticCode -> String +codeText Nothing = "" +codeText (Just (DiagnosticCode code)) = "[" ++ code ++ "]" + +locationLines :: DiagnosticRenderOptions -> Diagnostic -> [String] +locationLines opts diagnostic = + case diagnosticPrimarySpan diagnostic of + Nothing -> [] + Just sourceSpan -> + [ colorize + opts + locationAnsi + ( locationArrow opts + ++ spanFile sourceSpan + ++ ":" + ++ show (spanStartLine sourceSpan) + ++ ":" + ++ show (spanStartColumn sourceSpan) + ) + ] + +labelSnippetLines :: DiagnosticRenderOptions -> Severity -> SourceMap -> [Label] -> [String] +labelSnippetLines opts severity (SourceMap sources) labels = + concatMap renderGroup (groupNearbyLabels labels) + where + renderGroup [] = [] + renderGroup group@(label : _) = + case Map.lookup (spanFile (labelSpan label)) sources of + Nothing -> [] + Just source -> sourceLabelsSnippet opts severity source group + +groupNearbyLabels :: [Label] -> [[Label]] +groupNearbyLabels = + foldr insertLabel [] . sortOn labelSortKey + where + insertLabel label [] = [[label]] + insertLabel label (group : groups) + | labelBelongsWith label group = (label : group) : groups + | otherwise = [label] : group : groups + +labelBelongsWith :: Label -> [Label] -> Bool +labelBelongsWith _ [] = False +labelBelongsWith label group@(firstLabel : _) = + spanFile nextSpan == spanFile firstSpan + && spanStartLine nextSpan <= groupEndLine group + 2 + where + nextSpan = labelSpan label + firstSpan = labelSpan firstLabel + +groupEndLine :: [Label] -> Int +groupEndLine = + maximum . map (spanEndLine . labelSpan) + +labelSortKey :: Label -> (FilePath, Int, Int, Int) +labelSortKey label = + (spanFile sourceSpan, spanStartLine sourceSpan, spanStartColumn sourceSpan, labelStyleRank (labelStyle label)) + where + sourceSpan = labelSpan label + +labelStyleRank :: LabelStyle -> Int +labelStyleRank Primary = 0 +labelStyleRank Secondary = 1 + +sourceLabelsSnippet :: DiagnosticRenderOptions -> Severity -> SourceFile -> [Label] -> [String] +sourceLabelsSnippet opts severity source labels = + [gutter] + ++ concatMap renderLine [firstLine .. lastLine] + where + firstLine = minimum (map (spanStartLine . labelSpan) labels) + lastLine = maximum (map (spanEndLine . labelSpan) labels) + lineNoWidth = length (show lastLine) + gutter = gutterLine opts lineNoWidth + + renderLine lineNo = + let lineText = sourceLine source lineNo + displayLine = expandTabs tabWidth lineText + lineLabels = filter (labelTouchesLine lineNo) labels + in [ colorize opts lineNumberAnsi (padLeft lineNoWidth (show lineNo)) + ++ gutterSeparator opts + ++ " " + ++ displayLine + ] + ++ map (renderLabelMarker lineNo lineText) lineLabels + + renderLabelMarker lineNo lineText label = + let marker = case labelStyle label of + Primary -> '^' + Secondary -> '-' + markerAnsi = case labelStyle label of + Primary -> severityAnsi severity + Secondary -> secondaryAnsi + underline = underlineForLine (labelSpan label) lineNo lineText marker + message = if lineNo == spanStartLine (labelSpan label) then maybe "" (" " ++) (labelMessage label) else "" + in gutterLine opts lineNoWidth + ++ " " + ++ colorize opts markerAnsi underline + ++ message + +labelTouchesLine :: Int -> Label -> Bool +labelTouchesLine lineNo label = + lineNo >= spanStartLine sourceSpan && lineNo <= spanEndLine sourceSpan + where + sourceSpan = labelSpan label + +underlineForLine :: SourceSpan -> Int -> String -> Char -> String +underlineForLine sourceSpan lineNo lineText marker = + replicate (startCol - 1) ' ' ++ replicate markerWidth marker + where + startCol + | lineNo == spanStartLine sourceSpan = sourceColumnToVisual lineText (max 1 (spanStartColumn sourceSpan)) + | otherwise = 1 + endCol + | lineNo == spanEndLine sourceSpan = max startCol (sourceColumnToVisual lineText (max 1 (spanEndColumn sourceSpan))) + | otherwise = max startCol (visualLength lineText + 1) + markerWidth = max 1 (endCol - startCol) + +sourceLine :: SourceFile -> Int -> String +sourceLine source lineNo = + case drop (lineNo - 1) (sourceLines source) of + lineText : _ -> lineText + [] -> "" + +sourceLines :: SourceFile -> [String] +sourceLines source = + case lines (sourceText source) of + [] -> [""] + xs -> xs + +computeLineStarts :: String -> [Int] +computeLineStarts = + (0 :) . reverse . fst . foldl' step ([], 0) + where + step (starts, offset) '\n' = (offset + 1 : starts, offset + 1) + step (starts, offset) _ = (starts, offset + 1) + +computeSourceTokens :: FilePath -> String -> [SourceToken] +computeSourceTokens path content = + concat + [ lineTokens path lineNo lineStart lineText + | (lineNo, lineStart, lineText) <- zip3 [1 ..] (computeLineStarts content) (sourceLinesFromText content) + ] + +sourceLinesFromText :: String -> [String] +sourceLinesFromText content = + case lines content of + [] -> [""] + xs -> xs + +lineTokens :: FilePath -> Int -> Int -> String -> [SourceToken] +lineTokens path lineNo lineStart lineText = + go 1 lineText + where + go _ [] = [] + go column chars@(c : rest) + | isIdentifierStart c = + let (tokenText, suffix) = spanQualifiedIdentifier chars + endColumn = column + length tokenText + in SourceToken + { sourceTokenText = tokenText, + sourceTokenSpan = + SourceSpan + { spanFile = path, + spanStartByte = lineStart + column - 1, + spanEndByte = lineStart + endColumn - 1, + spanStartLine = lineNo, + spanStartColumn = column, + spanEndLine = lineNo, + spanEndColumn = endColumn + } + } + : go endColumn suffix + | otherwise = go (column + 1) rest + +spanQualifiedIdentifier :: String -> (String, String) +spanQualifiedIdentifier chars = + let (segment, rest) = span isIdentifierContinue chars + in case rest of + '.' : next : suffix + | isIdentifierStart next -> + let (tailText, finalRest) = spanQualifiedIdentifier (next : suffix) + in (segment ++ "." ++ tailText, finalRest) + _ -> (segment, rest) + +isIdentifierStart :: Char -> Bool +isIdentifierStart c = + isAlpha c || c == '_' + +isIdentifierContinue :: Char -> Bool +isIdentifierContinue c = + isAlphaNum c || c == '_' || c == '\'' + +padLeft :: Int -> String -> String +padLeft width str = + replicate (max 0 (width - length str)) ' ' ++ str + +prefixedWrappedLines :: DiagnosticRenderOptions -> String -> String -> [String] +prefixedWrappedLines opts prefix body = + case linesOrBlank body of + [] -> [prefix] + firstLine : restLines -> + wrapPhysicalLine prefix firstLine + ++ concatMap (wrapPhysicalLine continuationPrefix) restLines + where + continuationPrefix = replicate (length prefix) ' ' + wrapPhysicalLine linePrefix line = + case wrapWords (max 20 (diagnosticWidth opts)) linePrefix line of + [] -> [linePrefix] + wrapped -> wrapped + +wrapWords :: Int -> String -> String -> [String] +wrapWords width prefix raw = + case words raw of + [] -> [prefix] + word : rest -> go [prefix ++ word] rest + where + continuationPrefix = replicate (length prefix) ' ' + go acc [] = reverse acc + go [] _ = [] + go (line : acc) (word : rest) + | length line + 1 + length word <= width = + go ((line ++ " " ++ word) : acc) rest + | length word + length continuationPrefix <= width = + go ((continuationPrefix ++ word) : line : acc) rest + | otherwise = + go ((continuationPrefix ++ word) : line : acc) rest + +linesOrBlank :: String -> [String] +linesOrBlank "" = [""] +linesOrBlank body = lines body + +gutterLine :: DiagnosticRenderOptions -> Int -> String +gutterLine opts lineNoWidth = + replicate lineNoWidth ' ' ++ gutterSeparator opts + +gutterSeparator :: DiagnosticRenderOptions -> String +gutterSeparator opts + | useUnicode opts = " │" + | otherwise = " |" + +locationArrow :: DiagnosticRenderOptions -> String +locationArrow opts + | useUnicode opts = " ──> " + | otherwise = " --> " + +useUnicode :: DiagnosticRenderOptions -> Bool +useUnicode opts = + case diagnosticUnicode opts of + UnicodeAlways -> True + UnicodeAuto -> False + UnicodeNever -> False + +useColor :: DiagnosticRenderOptions -> Bool +useColor opts = + case diagnosticColor opts of + ColorAlways -> True + ColorAuto -> False + ColorNever -> False + +colorize :: DiagnosticRenderOptions -> String -> String -> String +colorize opts ansi body + | useColor opts = "\ESC[" ++ ansi ++ "m" ++ body ++ "\ESC[0m" + | otherwise = body + +severityAnsi :: Severity -> String +severityAnsi Error = "1;31" +severityAnsi Warning = "1;33" + +locationAnsi :: String +locationAnsi = "1;36" + +lineNumberAnsi :: String +lineNumberAnsi = "1;34" + +secondaryAnsi :: String +secondaryAnsi = "1;34" + +tabWidth :: Int +tabWidth = 4 + +expandTabs :: Int -> String -> String +expandTabs width = + go 1 + where + go _ [] = [] + go column ('\t' : rest) = + let spaces = width - ((column - 1) `mod` width) + in replicate spaces ' ' ++ go (column + spaces) rest + go column (c : rest) = + c : go (column + 1) rest + +visualLength :: String -> Int +visualLength = + length . expandTabs tabWidth + +sourceColumnToVisual :: String -> Int -> Int +sourceColumnToVisual lineText sourceColumn = + visualLength (take (sourceColumn - 1) lineText) + 1 + +joinWithBlankLines :: [String] -> String +joinWithBlankLines [] = "" +joinWithBlankLines [x] = x +joinWithBlankLines (x : xs) = x ++ "\n\n" ++ joinWithBlankLines xs diff --git a/src/Solcore/Frontend/Lexer/SolcoreLexer.x b/src/Solcore/Frontend/Lexer/SolcoreLexer.x index f20f6c4f6..91a1a5f00 100644 --- a/src/Solcore/Frontend/Lexer/SolcoreLexer.x +++ b/src/Solcore/Frontend/Lexer/SolcoreLexer.x @@ -4,6 +4,7 @@ module Solcore.Frontend.Lexer.SolcoreLexer where import Control.Monad import Numeric (readHex) +import Solcore.Diagnostics } @@ -30,7 +31,7 @@ tokens :- <0> $white+ ; <0> "//" .* ; <0> "/*" {nestComment `andBegin` state_comment} - <0> "*/" {\ _ _ -> alexError "Error: unexpected close comment!"} + <0> "*/" {unexpectedCloseComment} "/*" {nestComment} "*/" {unnestComment} . ; @@ -123,11 +124,12 @@ data AlexUserState nestLevel :: Int , strStart :: AlexPosn , strBuffer :: String + , sourceName :: FilePath } alexInitUserState :: AlexUserState alexInitUserState - = AlexUserState 0 (AlexPn 0 0 0) [] + = AlexUserState 0 (AlexPn 0 0 0) [] "" get :: Alex AlexUserState get = Alex $ \s -> Right (s, alex_ust s) @@ -139,33 +141,130 @@ modify :: (AlexUserState -> AlexUserState) -> Alex () modify f = Alex $ \s -> Right (s{alex_ust = f (alex_ust s)}, ()) +setSourceName :: FilePath -> Alex () +setSourceName name = + modify $ \s -> s{sourceName = name} + alexEOF :: Alex Token alexEOF = do (pos, _, _, _) <- alexGetInput startCode <- alexGetStartCode + state <- get when (startCode == state_comment) $ - alexError "Error: unclosed comment" + lexerErrorAt pos 1 "unclosed comment" "comment is not closed" when (startCode == state_string) $ - alexError "Error: unclosed string" - pure $ Token (position pos) TEOF - --- FIXME: Use AlexPosn in the token type to represent the location. + lexerErrorWithSpan + (sourceSpanBetween (sourceName state) (strStart state) pos 0) + "unclosed string" + "string literal is not closed" + pure $ mkToken (sourceName state) pos 0 TEOF position :: AlexPosn -> (Int, Int) position (AlexPn _ x y) = (x,y) +sourceSpan :: FilePath -> AlexPosn -> Int -> SourceSpan +sourceSpan file (AlexPn offset line column) len = + SourceSpan + { spanFile = file, + spanStartByte = offset, + spanEndByte = offset + len, + spanStartLine = line, + spanStartColumn = column, + spanEndLine = line, + spanEndColumn = column + max 1 len + } + +sourceSpanBetween :: FilePath -> AlexPosn -> AlexPosn -> Int -> SourceSpan +sourceSpanBetween file (AlexPn startOffset startLine startColumn) (AlexPn endOffset endLine endColumn) endLen = + SourceSpan + { spanFile = file, + spanStartByte = startOffset, + spanEndByte = endOffset + endLen, + spanStartLine = startLine, + spanStartColumn = startColumn, + spanEndLine = endLine, + spanEndColumn = endColumn + max 1 endLen + } + +mkToken :: FilePath -> AlexPosn -> Int -> Lexeme -> Token +mkToken file st len lx = + TokenWithSpan (sourceSpan file st len) (position st) lx + +mkTokenWithSpan :: SourceSpan -> Lexeme -> Token +mkTokenWithSpan span lx = + TokenWithSpan span (spanStartLine span, spanStartColumn span) lx + +lexerErrorAt :: AlexPosn -> Int -> String -> String -> Alex a +lexerErrorAt pos len message label = + do + file <- sourceName <$> get + lexerErrorWithSpan (sourceSpan file pos len) message label + +lexerErrorWithSpan :: SourceSpan -> String -> String -> Alex a +lexerErrorWithSpan span message label = + alexError $ + encodeDiagnostic + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0000"), + diagnosticMessage = message, + diagnosticLabels = + [ Label + { labelSpan = span, + labelStyle = Primary, + labelMessage = Just label + } + ], + diagnosticNotes = [], + diagnosticHelp = [] + } + -- token definition data Token - = Token { - pos :: (Int, Int) + = TokenWithSpan { + tokenSpan :: SourceSpan + , pos :: (Int, Int) , lexeme :: Lexeme } deriving (Eq, Ord, Show) +pattern Token :: (Int, Int) -> Lexeme -> Token +pattern Token p lx <- TokenWithSpan _ p lx + where + Token p lx = TokenWithSpan (uncurriedSourceSpan p) p lx + +{-# COMPLETE Token #-} + +uncurriedSourceSpan :: (Int, Int) -> SourceSpan +uncurriedSourceSpan (line, column) = + SourceSpan + { spanFile = "", + spanStartByte = 0, + spanEndByte = 0, + spanStartLine = line, + spanStartColumn = column, + spanEndLine = line, + spanEndColumn = column + 1 + } + +data LocatedText + = LocatedText + { locatedTextSpan :: SourceSpan, + locatedTextText :: String + } + deriving (Eq, Ord, Show) + +data LocatedValue a + = LocatedValue + { locatedValueSpan :: SourceSpan, + locatedValue :: a + } + deriving (Eq, Ord, Show) + data Lexeme - = TIdent { unIdent :: String } - | TNumber { unNum :: Integer } - | TString { unStr :: String } + = TIdent { unIdent :: LocatedText } + | TNumber { unNum :: LocatedValue Integer } + | TString { unStr :: LocatedValue String } | TContract | TImport | TExport @@ -240,44 +339,53 @@ data Lexeme mkIdent :: AlexAction Token mkIdent (st, _, _, str) len - = case take len str of - "match" -> return $ Token (position st) TMatch - "data" -> return $ Token (position st) TData - "import" -> return $ Token (position st) TImport - "export" -> return $ Token (position st) TExport - "hiding" -> return $ Token (position st) THiding - "as" -> return $ Token (position st) TAs - "contract" -> return $ Token (position st) TContract - "function" -> return $ Token (position st) TFunction - "constructor" -> return $ Token (position st) TConstructor - "return" -> return $ Token (position st) TReturn - "continue" -> return $ Token (position st) TContinue - "break" -> return $ Token (position st) TBreak - "let" -> return $ Token (position st) TLet - "assembly" -> return $ Token (position st) TAssembly - "if" -> return $ Token (position st) TIf - "else" -> return $ Token (position st) TElse - "switch" -> return $ Token (position st) TSwitch - "for" -> return $ Token (position st) TFor - "default" -> return $ Token (position st) TDefault - "type" -> return $ Token (position st) TType - "forall" -> return $ Token (position st) TForall - "pragma" -> return $ Token (position st) TPragma - "no-coverage-condition" -> - return $ Token (position st) TNoCoverageCondition - "no-patterson-condition" -> - return $ Token (position st) TNoPattersonCondition - "no-bounded-variable-condition" -> - return $ Token (position st) TNoBoundVariableCondition - _ -> return $ Token (position st) (TIdent $ take len str) + = do + file <- sourceName <$> get + let identSpan = sourceSpan file st len + pure $ mkTokenWithSpan identSpan (lexemeFor identSpan (take len str)) + where + lexemeFor identSpan str = + case str of + "match" -> TMatch + "data" -> TData + "import" -> TImport + "export" -> TExport + "hiding" -> THiding + "as" -> TAs + "contract" -> TContract + "function" -> TFunction + "constructor" -> TConstructor + "return" -> TReturn + "continue" -> TContinue + "break" -> TBreak + "let" -> TLet + "assembly" -> TAssembly + "if" -> TIf + "else" -> TElse + "switch" -> TSwitch + "for" -> TFor + "default" -> TDefault + "type" -> TType + "forall" -> TForall + "pragma" -> TPragma + "no-coverage-condition" -> TNoCoverageCondition + "no-patterson-condition" -> TNoPattersonCondition + "no-bounded-variable-condition" -> TNoBoundVariableCondition + _ -> TIdent (LocatedText identSpan str) mkNumber :: AlexAction Token mkNumber (st, _, _, str) len - = pure $ Token (position st) (TNumber $ read $ take len str) + = do + file <- sourceName <$> get + let numberSpan = sourceSpan file st len + pure $ mkTokenWithSpan numberSpan (TNumber $ LocatedValue numberSpan $ read $ take len str) mkHexlit :: AlexAction Token mkHexlit (st, _, _, str) len - = pure $ Token (position st) (TNumber $ parseHex $ take len str) + = do + file <- sourceName <$> get + let numberSpan = sourceSpan file st len + pure $ mkTokenWithSpan numberSpan (TNumber $ LocatedValue numberSpan $ parseHex $ take len str) parseHex :: String -> Integer parseHex str = case readHex (drop 2 str) of @@ -285,8 +393,14 @@ parseHex str = case readHex (drop 2 str) of _ -> error "impossible :)" simpleToken :: Lexeme -> AlexAction Token -simpleToken lx (st, _, _, _) _ - = return $ Token (position st) lx +simpleToken lx (st, _, _, _) len + = do + file <- sourceName <$> get + return $ mkToken file st len lx + +unexpectedCloseComment :: AlexAction Token +unexpectedCloseComment (st, _, _, _) len = + lexerErrorAt st len "unexpected close comment" "this close comment has no matching open comment" -- string literals @@ -299,12 +413,13 @@ enterString inp@(pos, _, _, _) len skip inp len exitString :: AlexAction Token -exitString (pos, _, _, _) _ +exitString (pos, _, _, _) len = do s <- get put s{strStart = AlexPn 0 0 0, strBuffer = []} - let tk = TString $ reverse $ '"' : strBuffer s - return $ Token (position pos) tk + let stringSpan = sourceSpanBetween (sourceName s) (strStart s) pos len + tk = TString $ LocatedValue stringSpan $ reverse $ '"' : strBuffer s + return $ mkTokenWithSpan stringSpan tk emit :: Char -> AlexAction Token emit c inp@(_, _, _, _) len = do diff --git a/src/Solcore/Frontend/Module/Loader.hs b/src/Solcore/Frontend/Module/Loader.hs index 408a59fd0..f9e8f7df0 100644 --- a/src/Solcore/Frontend/Module/Loader.hs +++ b/src/Solcore/Frontend/Module/Loader.hs @@ -3,6 +3,7 @@ module Solcore.Frontend.Module.Loader LoadedModule (..), ModuleTypeCheckSurface (..), loadModuleGraph, + moduleSourceMap, moduleValidationTopDeclSegments, moduleSourcePath, moduleLocalTypeCheckSurface, @@ -19,8 +20,9 @@ import Data.Map qualified as Map import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set (Set) import Data.Set qualified as Set +import Solcore.Diagnostics (Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceFile, SourceMap, SourceSpan, combineSourceSpans, encodeDiagnostic, makeSourceFile, sourceMapFromFiles) import Solcore.Frontend.Module.Identity qualified as Mod -import Solcore.Frontend.Parser.SolcoreParser (parseCompUnit) +import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithPath) import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree import System.Directory (doesFileExist, makeAbsolute) @@ -29,6 +31,7 @@ import System.FilePath data LoadedModule = LoadedModule { loadedSourcePath :: FilePath, + loadedSource :: SourceFile, loadedCompUnit :: CompUnit, loadedModuleRefs :: Map ModulePath Mod.ModuleId } @@ -124,11 +127,12 @@ visit cfg moduleId sourcePath = do unless (alreadyLoaded || loading) do modify (\st -> st {loadingModules = Set.insert moduleId (loadingModules st)}) content <- liftIO (readFile sourcePath) - parsed <- liftIO (parseCompUnit content) + let source = makeSourceFile sourcePath content + parsed <- liftIO (parseCompUnitWithPath sourcePath content) cunit <- either throwError pure parsed - importedModules <- mapM (resolveImportPath cfg moduleId) (imports cunit) + importedModules <- mapM (resolveImportPath cfg moduleId sourcePath) (imports cunit) exportedModules <- - mapM (resolveModuleReference cfg moduleId "export") (exportModulePaths cunit) + mapM (resolveModuleReference cfg moduleId sourcePath "export") (exportModulePaths cunit) let moduleRefs = Map.fromList $ [(importModule imp, importId) | (imp, (importId, _)) <- zip (imports cunit) importedModules] @@ -142,7 +146,7 @@ visit cfg moduleId sourcePath = do modify ( \st -> st - { loadedModules = Map.insert moduleId (LoadedModule sourcePath cunit moduleRefs) (loadedModules st), + { loadedModules = Map.insert moduleId (LoadedModule sourcePath source cunit moduleRefs) (loadedModules st), moduleDeps = Map.insert moduleId (map fst importedModules) (moduleDeps st), moduleRefDeps = Map.insert moduleId (map fst referencedModules) (moduleRefDeps st), loadingModules = Set.delete moduleId (loadingModules st), @@ -153,29 +157,60 @@ visit cfg moduleId sourcePath = do resolveImportPath :: LoaderConfig -> Mod.ModuleId -> + FilePath -> Import -> StateT LoadState (ExceptT String IO) (Mod.ModuleId, FilePath) -resolveImportPath cfg currentModule imp = +resolveImportPath cfg currentModule currentSourcePath imp = fmap (\(_, targetId, targetPath) -> (targetId, targetPath)) $ - resolveModuleReference cfg currentModule "import" (importModule imp) + resolveModuleReference cfg currentModule currentSourcePath "import" (importModule imp) resolveModuleReference :: LoaderConfig -> Mod.ModuleId -> + FilePath -> String -> ModulePath -> StateT LoadState (ExceptT String IO) (ModulePath, Mod.ModuleId, FilePath) -resolveModuleReference cfg currentModule refKind modulePath = do - candidates <- either throwError pure (resolveModuleImportCandidates cfg currentModule modulePath) +resolveModuleReference cfg currentModule currentSourcePath refKind modulePath = do + candidates <- + either + (throwError . moduleReferenceDiagnostic "SC0118" currentSourcePath refKind modulePath) + pure + (resolveModuleImportCandidates cfg currentModule modulePath) resolved <- liftIO $ firstExisting candidates case resolved of Just (targetId, targetPath) -> pure (modulePath, targetId, targetPath) Nothing -> throwError $ - refKind - ++ " " - ++ Mod.modulePathDisplay modulePath - ++ ": file not found" + moduleReferenceDiagnostic + "SC0109" + currentSourcePath + refKind + modulePath + ( refKind + ++ " " + ++ Mod.modulePathDisplay modulePath + ++ ": file not found" + ) + +moduleReferenceDiagnostic :: String -> FilePath -> String -> ModulePath -> String -> String +moduleReferenceDiagnostic code sourcePath refKind modulePath message = + loaderDiagnosticWithLabels + code + message + (maybe [] pure (primaryModulePathLabel (moduleReferenceLabelMessage code refKind) modulePath)) + [sourcePath, refKind ++ " " ++ Mod.modulePathDisplay modulePath] + (moduleReferenceHelp code) + +moduleReferenceLabelMessage :: String -> String -> String +moduleReferenceLabelMessage "SC0118" _ = "external library import" +moduleReferenceLabelMessage "SC0109" _ = "module reference" +moduleReferenceLabelMessage _ refKind = refKind ++ " path" + +moduleReferenceHelp :: String -> [String] +moduleReferenceHelp "SC0118" = ["pass --external-lib NAME=PATH for external imports"] +moduleReferenceHelp "SC0109" = ["check the module path or add the missing source file"] +moduleReferenceHelp _ = [] toFilePath :: FilePath -> Name -> FilePath toFilePath base = (base ) . Mod.moduleFilePath @@ -238,17 +273,23 @@ rootForLibrary cfg (Mod.ExternalLibrary libName) = case Map.lookup libName (externalRoots cfg) of Just root -> Right root Nothing -> - Left ("external library root is not configured: @" ++ show libName) + Left $ + loaderDiagnostic + "SC0118" + ("external library root is not configured: @" ++ show libName) + [] + ["pass --external-lib " ++ show libName ++ "=PATH"] moduleIdForPath :: Mod.LibraryId -> FilePath -> FilePath -> ExceptT String IO Mod.ModuleId moduleIdForPath libId root filePath = case makeRelativeToRoot root filePath of Nothing -> throwError $ - "source file is outside library root:\n " - ++ filePath - ++ "\n root: " - ++ root + loaderDiagnostic + "SC0119" + "source file is outside library root" + [filePath, "root: " ++ root] + ["choose --root so it contains the source file"] Just relPath -> case splitDirectories (dropExtension relPath) of [] -> @@ -342,6 +383,10 @@ moduleSourcePath graph modulePath = (Right . loadedSourcePath) (Map.lookup modulePath (modules graph)) +moduleSourceMap :: ModuleGraph -> SourceMap +moduleSourceMap graph = + sourceMapFromFiles (map loadedSource (Map.elems (modules graph))) + moduleImportPairsFor :: ModuleGraph -> Mod.ModuleId -> CompUnit -> [(Import, Mod.ModuleId)] moduleImportPairsFor graph modulePath unit = zip (imports unit) (Map.findWithDefault [] modulePath (dependencies graph)) @@ -507,18 +552,24 @@ ensureImportItemsExist graph importPairs = do ([], []) -> Right () (selectedXs, hiddenXs) -> Left $ - unlines - ( (if null selectedXs then [] else ["Unknown selected imports:", unlines selectedXs]) - ++ (if null hiddenXs then [] else ["Unknown hidden imports:", unlines hiddenXs]) + loaderDiagnosticWithLabels + "SC0110" + "unknown import item" + ( primaryNameLabels "unknown import item" (map snd selectedXs) + ++ primaryNameLabels "unknown import item" (map snd hiddenXs) ) + ( (if null selectedXs then [] else "unknown selected imports:" : map (uncurry formatMissing) selectedXs) + ++ (if null hiddenXs then [] else "unknown hidden imports:" : map (uncurry formatMissing) hiddenXs) + ) + ["check the imported module's exported names"] where unknowns (ImportOnly importPath items, modulePath) = do available <- importableNamesForModule graph modulePath let missingSelected = filter (`notElem` available) (explicitSelectorNames items) missingHidden = filter (`notElem` available) (explicitHiddenNames items) pure - ( [formatMissing importPath n | n <- missingSelected], - [formatMissing importPath n | n <- missingHidden] + ( [(importPath, n) | n <- missingSelected], + [(importPath, n) | n <- missingHidden] ) unknowns _ = pure ([], []) @@ -823,25 +874,28 @@ selectRemoteExportRefs sourcePath exportPath (SelectExportItems items) available Nothing | shouldValidate -> Left $ - unlines - [ "Unknown re-exported constructors:", - " " ++ sourcePath, - " " ++ Mod.modulePathDisplay exportPath ++ "." ++ show typeName - ] + loaderDiagnosticWithLabels + "SC0115" + "unknown re-exported constructor" + (maybe [] pure (primaryNameLabel "unknown re-exported constructor" typeName)) + [sourcePath, " " ++ Mod.modulePathDisplay exportPath ++ "." ++ show typeName] + ["re-export constructors provided by the target module"] | otherwise -> pure [] Just ref | shouldValidate, missingVisibleConstructors constructorSelector ref /= [] -> Left $ - unlines - [ "Unknown re-exported constructors:", - " " ++ sourcePath, - unlines - [ " " ++ Mod.modulePathDisplay exportPath ++ "." ++ show typeName ++ "." ++ show constructorName - | constructorName <- missingVisibleConstructors constructorSelector ref - ] - ] + loaderDiagnosticWithLabels + "SC0115" + "unknown re-exported constructor" + (primaryNameLabels "unknown re-exported constructor" (missingVisibleConstructors constructorSelector ref)) + ( sourcePath + : [ " " ++ Mod.modulePathDisplay exportPath ++ "." ++ show typeName ++ "." ++ show constructorName + | constructorName <- missingVisibleConstructors constructorSelector ref + ] + ) + ["re-export constructors provided by the target module"] | otherwise -> pure [ref] @@ -926,11 +980,11 @@ ensureNoDuplicateExportedItems modulePath itemRefs = [] -> Right () xs -> Left $ - unlines - [ "Duplicate exported item names:", - " " ++ modulePath, - unlines (map (\n -> " " ++ show n) xs) - ] + loaderDiagnostic + "SC0111" + "duplicate exported item names" + (("module: " ++ modulePath) : map (\n -> " " ++ show n) xs) + ["export each item name from only one origin"] where conflicts = [ itemName @@ -945,11 +999,11 @@ ensureNoDuplicateExportedModules modulePath moduleBindings = [] -> Right () xs -> Left $ - unlines - [ "Duplicate exported module names:", - " " ++ modulePath, - unlines (map (\n -> " " ++ show n) xs) - ] + loaderDiagnostic + "SC0112" + "duplicate exported module names" + (("module: " ++ modulePath) : map (\n -> " " ++ show n) xs) + ["export each module name from only one origin"] where conflicts = [ bindingName @@ -963,22 +1017,24 @@ ensureLocalExportExists sourcePath ds itemName | itemName `elem` availableExportNames ds = Right () | otherwise = Left $ - unlines - [ "Unknown export:", - " " ++ sourcePath, - " " ++ show itemName - ] + loaderDiagnosticWithLabels + "SC0113" + "unknown export" + (maybe [] pure (primaryNameLabel "unknown export" itemName)) + [sourcePath, show itemName] + ["export a name defined in this module or re-export it from another module"] ensureLocalConstructorExportExists :: FilePath -> [TopDecl] -> Name -> ConstructorSelector -> Either String () ensureLocalConstructorExportExists sourcePath topLevelDecls typeName constructorSelector = case findLocalDataType typeName topLevelDecls of Nothing -> Left $ - unlines - [ "Unknown export:", - " " ++ sourcePath, - " " ++ show typeName - ] + loaderDiagnosticWithLabels + "SC0113" + "unknown export" + (maybe [] pure (primaryNameLabel "unknown export" typeName)) + [sourcePath, show typeName] + ["export a type defined in this module or re-export it from another module"] Just (DataTy _ _ constrs) -> ensureConstructorSelectorExists sourcePath typeName constructorSelector constrs @@ -1000,11 +1056,12 @@ ensureConstructorSelectorExists sourcePath typeName (SelectConstructors construc [] -> Right () xs -> Left $ - unlines - [ "Unknown exported constructors:", - " " ++ sourcePath, - unlines [" " ++ show typeName ++ "." ++ show constructorName | constructorName <- xs] - ] + loaderDiagnosticWithLabels + "SC0114" + "unknown exported constructor" + (primaryNameLabels "unknown exported constructor" xs) + (sourcePath : [" " ++ show typeName ++ "." ++ show constructorName | constructorName <- xs]) + ["select constructors defined by the exported type"] where availableNames = uniqueNames (map (constructorLeafName . constrName) constrs) missing = filter (`notElem` availableNames) constructorNames @@ -1027,11 +1084,12 @@ ensureRemoteExportsExist sourcePath exportPath names availableNames = [] -> Right () xs -> Left $ - unlines - [ "Unknown re-exported names:", - " " ++ sourcePath, - unlines [formatMissing exportPath missingName | missingName <- xs] - ] + loaderDiagnosticWithLabels + "SC0115" + "unknown re-exported name" + (primaryNameLabels "unknown re-exported name" xs) + (sourcePath : [formatMissing exportPath missingName | missingName <- xs]) + ["re-export a name provided by the target module"] where missing = filter (`notElem` availableNames) names @@ -1040,8 +1098,8 @@ defaultModuleBindingName = moduleLeafName . Mod.modulePathName moduleLeafName :: Name -> Name -moduleLeafName (Name n) = Name n -moduleLeafName (QualName _ n) = Name n +moduleLeafName n@(Name _) = n +moduleLeafName q@(QualName _ n) = copyNameSourceSpan q (Name n) importModuleQualifiers :: ModulePath -> [Name] importModuleQualifiers importPath = @@ -1095,17 +1153,17 @@ qualifiedImportStubDecls graph (imp, modulePath) = ++ nestedDecls stubNestedModule qualifier (ExportedModuleBinding bindingName targetModule) = - stubDecls (QualName qualifier (show bindingName)) targetModule + stubDecls (qualifyName qualifier bindingName) targetModule qualifyFunctionSignature :: Name -> FunDef -> FunDef qualifyFunctionSignature qualifier (FunDef sig body) = FunDef - (sig {sigName = QualName qualifier (show (sigName sig))}) + (sig {sigName = qualifyName qualifier (sigName sig)}) body qualifiedFunctionStubDecls :: Name -> CompUnit -> [TopDecl] qualifiedFunctionStubDecls qualifier cunit = - [ TFunDef (stubFunction (QualName qualifier (show (sigName (funSignature fd))))) + [ TFunDef (stubFunction (qualifyName qualifier (sigName (funSignature fd)))) | TFunDef fd <- topDeclsFrom cunit ] @@ -1114,7 +1172,7 @@ qualifierFromExpVarChain (ExpVar Nothing n) = Just n qualifierFromExpVarChain (ExpVar (Just e) n) = do q <- qualifierFromExpVarChain e - pure (QualName q (show n)) + pure (qualifyName q n) qualifierFromExpVarChain _ = Nothing @@ -1202,11 +1260,11 @@ renamePatTypeRefs _ p@(PWildcard) = p renamePatTypeRefs _ p@(PLit _) = p renamePatNameTypeRefs :: Map Name Name -> Name -> Name -renamePatNameTypeRefs renameMap (QualName q n) = - QualName (renameTypeName renameMap q) n +renamePatNameTypeRefs renameMap qn@(QualName q n) = + copyNameSourceSpan qn (QualName (renameTypeName renameMap q) n) renamePatNameTypeRefs renameMap n = case Map.lookup n renameMap of - Just qn -> QualName qn (show n) + Just qn -> qualifyName qn n Nothing -> n renameExpTypeRefs :: Map Name Name -> Exp -> Exp @@ -1351,8 +1409,8 @@ renameConstrTypeRefs renameMap (Constr n tys) = Constr (renameConstrNameTypeRefs renameMap n) (map (renameTyTypeRefs renameMap) tys) renameConstrNameTypeRefs :: Map Name Name -> Name -> Name -renameConstrNameTypeRefs renameMap (QualName q n) = - QualName (renameTypeName renameMap q) n +renameConstrNameTypeRefs renameMap qn@(QualName q n) = + copyNameSourceSpan qn (QualName (renameTypeName renameMap q) n) renameConstrNameTypeRefs _ n = n renameTySymTypeRefs :: Map Name Name -> TySym -> TySym @@ -1379,7 +1437,7 @@ renameTypeName renameMap n = Just n' -> n' Nothing -> case n of - QualName q x -> QualName (renameTypeName renameMap q) x + qn@(QualName q x) -> copyNameSourceSpan qn (QualName (renameTypeName renameMap q) x) _ -> n qualifiedTypeAliasDecls :: Map Name Name -> Name -> CompUnit -> [TopDecl] @@ -1404,25 +1462,25 @@ qualifiedTypeStubDecls qualifier cunit = dataAliases = [ TDataDef ( DataTy - (QualName qualifier (show n)) + (qualifyName qualifier n) [] [Constr (constructorLeafName (constrName c)) [] | c <- cs] ) | TDataDef (DataTy n _ cs) <- topDeclsFrom cunit ] symAliases = - [ TSym (stubType (QualName qualifier (show n))) + [ TSym (stubType (qualifyName qualifier n)) | TSym (TySym n _ _) <- topDeclsFrom cunit ] constructorLeafName :: Name -> Name -constructorLeafName (QualName _ n) = Name n +constructorLeafName q@(QualName _ n) = copyNameSourceSpan q (Name n) constructorLeafName n = n qualifyTyCon :: Name -> Name -> [Ty] -> TySym qualifyTyCon qualifier unqualName tyVars = TySym - { symName = QualName qualifier (show unqualName), + { symName = qualifyName qualifier unqualName, symVars = tyVars, symType = TyCon unqualName tyVars } @@ -1489,7 +1547,7 @@ typeCheckQualifiedImportDecls collidingTypeNames graph (imp, modulePath) = ++ nestedDecls qualifyNestedModule qualifier (ExportedModuleBinding bindingName targetModule) = - qualifyDecls (QualName qualifier (show bindingName)) targetModule + qualifyDecls (qualifyName qualifier bindingName) targetModule qualifiedFunctionSignatureDecls :: Map Name Name -> Name -> CompUnit -> [TopDecl] qualifiedFunctionSignatureDecls typeRenameMap qualifier cunit = @@ -1537,7 +1595,7 @@ typeCheckImportedDecls collidingTypeNames graph (imp, modulePath) = pure (localSupportDecls ++ shadowImportedDecls localSupportDecls nestedSupportDecls) nestedModuleImportDecls qualifier (ExportedModuleBinding bindingName targetModule) = - moduleImportDecls (QualName qualifier (show bindingName)) targetModule + moduleImportDecls (qualifyName qualifier bindingName) targetModule typeCheckSupportNonFunctionDecls :: ModuleGraph -> Mod.ModuleId -> Either String [TopDecl] typeCheckSupportNonFunctionDecls graph = @@ -1640,7 +1698,7 @@ fullConstructorNamesForRef graph itemRef = do importedTypeRenameMap :: Set Name -> Name -> [TopDecl] -> Map Name Name importedTypeRenameMap collidingTypeNames qualifier ds = Map.fromList - [ (n, QualName qualifier (show n)) + [ (n, qualifyName qualifier n) | d <- ds, n <- topDeclImportedTypeNames d, n `Set.member` collidingTypeNames @@ -1845,10 +1903,12 @@ ensureNoAmbiguousSelectedImports graph importPairs = do [] -> Right () xs -> Left $ - unlines - [ "Ambiguous selected imports:", - unlines (map formatAmbiguous xs) - ] + loaderDiagnosticWithLabels + "SC0120" + "ambiguous selected imports" + (primaryNameLabels "ambiguous selected import" (map fst xs)) + (map formatAmbiguous xs) + ["use an explicit module qualifier or narrow the selected imports"] where selectedFromImport (ImportOnly modName selector, modulePath) = do names <- resolveSelectedImportItems graph modName modulePath selector @@ -1877,10 +1937,12 @@ ensureNoModuleLookupConflicts graph unit importPairs = [] -> Right () xs -> Left $ - unlines - [ "Conflicting unqualified names:", - unlines (map (\n -> " " ++ show n) xs) - ] + loaderDiagnosticWithLabels + "SC0121" + "conflicting unqualified names" + (primaryNameLabels "conflicting unqualified name" xs) + (map (\n -> " " ++ show n) xs) + ["rename the local binding or use an import alias"] where localTermNames = uniqueNames (concatMap topDeclTermNames (topDeclsFrom unit)) @@ -1949,10 +2011,12 @@ ensureNoDuplicateModuleQualifiers (CompUnit imps _) = [] -> Right () qs -> Left $ - unlines - [ "Duplicate import qualifiers:", - unlines (map (\q -> " " ++ show q) qs) - ] + loaderDiagnosticWithLabels + "SC0116" + "duplicate import qualifier" + (primaryNameLabels "duplicate import qualifier" qs) + (map (\q -> " " ++ show q) qs) + ["use an explicit alias to disambiguate one of the imports"] where duplicates = duplicateNames (mapMaybe moduleQualifier imps) @@ -1983,20 +2047,72 @@ ensureNoDuplicateSelectedItems (CompUnit imps _) = [] -> Right () xs -> Left $ - unlines - [ "Duplicate names in selective import:", - unlines xs - ] + loaderDiagnosticWithLabels + "SC0117" + "duplicate name in selective import" + (primaryNameLabels "duplicate selected import" (map snd xs)) + (map ((" " ++) . fst) xs) + ["list each selected or hidden name only once"] where duplicateItems (ImportOnly moduleName selector) = - [ " " ++ Mod.modulePathDisplay moduleName ++ "." ++ show item + [ (Mod.modulePathDisplay moduleName ++ "." ++ show item, item) | item <- duplicateNames (explicitSelectorNames selector) ] - ++ [ " " ++ Mod.modulePathDisplay moduleName ++ " hiding " ++ show item + ++ [ (Mod.modulePathDisplay moduleName ++ " hiding " ++ show item, item) | item <- duplicateNames (explicitHiddenNames selector) ] duplicateItems _ = [] +loaderDiagnostic :: String -> String -> [String] -> [String] -> String +loaderDiagnostic code message notes help = + loaderDiagnosticWithLabels code message [] notes help + +loaderDiagnosticWithLabels :: String -> String -> [Label] -> [String] -> [String] -> String +loaderDiagnosticWithLabels code message labels notes help = + encodeDiagnostic + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode code), + diagnosticMessage = message, + diagnosticLabels = labels, + diagnosticNotes = notes, + diagnosticHelp = help + } + +primaryNameLabel :: String -> Name -> Maybe Label +primaryNameLabel message identName = do + sourceSpan <- nameSourceSpan identName + pure + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just message + } + +primaryNameLabels :: String -> [Name] -> [Label] +primaryNameLabels message = + mapMaybe (primaryNameLabel message) + +primaryModulePathLabel :: String -> ModulePath -> Maybe Label +primaryModulePathLabel message modulePath = do + sourceSpan <- modulePathSourceSpan modulePath + pure + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just message + } + +modulePathSourceSpan :: ModulePath -> Maybe SourceSpan +modulePathSourceSpan (ExternalPath libName pathName) = + case (nameSourceSpan libName, nameSourceSpan pathName) of + (Just left, Just right) -> Just (combineSourceSpans left right) + (Just left, Nothing) -> Just left + (Nothing, Just right) -> Just right + (Nothing, Nothing) -> Nothing +modulePathSourceSpan modulePath = + nameSourceSpan (Mod.modulePathName modulePath) + explicitSelectorNames :: ItemSelector -> [Name] explicitSelectorNames (SelectItems items _) = [itemName | SelectItem itemName <- items] diff --git a/src/Solcore/Frontend/Parser/SolcoreParser.y b/src/Solcore/Frontend/Parser/SolcoreParser.y index 4058cfaab..b1cb994ca 100644 --- a/src/Solcore/Frontend/Parser/SolcoreParser.y +++ b/src/Solcore/Frontend/Parser/SolcoreParser.y @@ -4,10 +4,12 @@ module Solcore.Frontend.Parser.SolcoreParser where import Data.List.NonEmpty (NonEmpty, cons, singleton) import Solcore.Frontend.Lexer.SolcoreLexer hiding (lexer) +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.SyntaxTree import Solcore.Primitives.Primitives hiding (pairTy) import Language.Yul +import Solcore.Diagnostics } @@ -42,7 +44,7 @@ import Language.Yul 'leave' {Token _ TLeave} 'continue' {Token _ TContinue} 'break' {Token _ TBreak} - 'assembly' {Token _ TAssembly} + 'assembly' {TokenWithSpan $$ _ TAssembly} 'data' {Token _ TData} 'match' {Token _ TMatch} 'function' {Token _ TFunction} @@ -59,7 +61,7 @@ import Language.Yul ':' {Token _ TColon} ',' {Token _ TComma} '->' {Token _ TArrow} - '_' {Token _ TWildCard} + '_' {TokenWithSpan $$ _ TWildCard} '=>' {Token _ TDArrow} '(' {Token _ TLParen} ')' {Token _ TRParen} @@ -120,10 +122,10 @@ Import : 'import' ModName ';' { ImportModule (classifyImpor | 'import' ModName 'as' Name ';' { ImportAlias (classifyImportPath $2) $4 } | 'import' ModName '.' '{' ImportItems '}' ImportHiding ';' { ImportOnly (classifyImportPath $2) (SelectItems $5 $7) } - | 'import' '@' identifier '.' ModName ';' { ImportModule (ExternalPath (Name $3) $5) } - | 'import' '@' identifier '.' ModName 'as' Name ';' { ImportAlias (ExternalPath (Name $3) $5) $7 } + | 'import' '@' identifier '.' ModName ';' { ImportModule (ExternalPath (nameFromIdent $3) $5) } + | 'import' '@' identifier '.' ModName 'as' Name ';' { ImportAlias (ExternalPath (nameFromIdent $3) $5) $7 } | 'import' '@' identifier '.' ModName '.' '{' ImportItems '}' ImportHiding ';' - { ImportOnly (ExternalPath (Name $3) $5) (SelectItems $8 $10) } + { ImportOnly (ExternalPath (nameFromIdent $3) $5) (SelectItems $8 $10) } ImportItems :: { [ItemSelectorEntry] } ImportItems : ImportItemList { $1 } @@ -145,11 +147,11 @@ HidingItemList : ItemName ',' HidingItemList { $1 : $3 } | ItemName { [$1] } ModName :: { Name } -ModName : identifier { Name $1 } - | ModName '.' identifier { QualName $1 $3 } +ModName : identifier { nameFromIdent $1 } + | ModName '.' identifier { qualNameFromIdent $1 $3 } ItemName :: { Name } -ItemName : identifier { Name $1 } +ItemName : identifier { nameFromIdent $1 } TopDeclList :: { [TopDecl] } TopDeclList : TopDecl TopDeclList { $1 : $2 } @@ -172,7 +174,7 @@ ExportDecl :: { Export } ExportDecl : 'export' '{' ExportItems '}' ';' { ExportList $3 } | 'export' ModName ExportTail { $3 (classifyImportPath $2) } | 'export' '@' identifier '.' ModName ExportTail - { $6 (ExternalPath (Name $3) $5) } + { $6 (ExternalPath (nameFromIdent $3) $5) } ExportTail :: { ModulePath -> Export } ExportTail : ';' { ExportModule } @@ -193,7 +195,7 @@ ExportListItem : '*' { ExportAll } | ItemName { ExportName $1 } | ItemName '(' ExportConstructorItems ')' { ExportNameWithConstructors $1 $3 } | ModName '.' '*' { ExportModuleAll (classifyImportPath $1) } - | '@' identifier '.' ModName '.' '*' { ExportModuleAll (ExternalPath (Name $2) $4) } + | '@' identifier '.' ModName '.' '*' { ExportModuleAll (ExternalPath (nameFromIdent $2) $4) } ExportFromItems :: { [ExportSelectorEntry] } ExportFromItems : ExportFromItemList { $1 } @@ -356,7 +358,7 @@ InstBody : '{' Functions '}' {$2} Function :: { FunDef } Function : Signature Body {FunDef $1 $2} -- Proposed Rust-style short return, e.g `function d(x) { 2*x }` - | Signature '{' Expr '}' {FunDef $1 [Return $3]} + | Signature '{' Expr '}' {FunDef $1 [locatedFrom $3 locatedStmt (Return $3)]} OptRetTy :: { Maybe Ty } OptRetTy : '->' Type {Just $2} @@ -379,32 +381,32 @@ StmtList : Stmt StmtList {$1 : $2} -- Statements Stmt :: { Stmt } -Stmt : Expr '=' Expr ';' {Assign $1 $3} - | Expr '+=' Expr ';' {StmtPlusEq $1 $3} - | Expr '-=' Expr ';' {StmtMinusEq $1 $3} - | 'let' Name ':' Type InitOpt ';' {Let $2 (Just $4) $5} - | 'let' Name InitOpt ';' {Let $2 Nothing $3} - | Expr ';' {StmtExp $1} - | 'return' Expr ';' {Return $2} - | 'match' MatchArgList '{' Equations '}' {Match $2 $4} - | AsmBlock {Asm $1} - | 'if' '(' Expr ')' Body %shift {If $3 $5 []} - | 'if' '(' Expr ')' Body 'else' Body {If $3 $5 $7} - | 'for' '(' ForInitStmt ';' Expr ';' ForPostStmt ')' Body {For $3 $5 $7 $9} +Stmt : Expr '=' Expr ';' {locatedBetween $1 $3 locatedStmt (Assign $1 $3)} + | Expr '+=' Expr ';' {locatedBetween $1 $3 locatedStmt (StmtPlusEq $1 $3)} + | Expr '-=' Expr ';' {locatedBetween $1 $3 locatedStmt (StmtMinusEq $1 $3)} + | 'let' Name ':' Type InitOpt ';' {locatedBetween $2 (Just $4, $5) locatedStmt (Let $2 (Just $4) $5)} + | 'let' Name InitOpt ';' {locatedBetween $2 $3 locatedStmt (Let $2 Nothing $3)} + | Expr ';' {locatedFrom $1 locatedStmt (StmtExp $1)} + | 'return' Expr ';' {locatedFrom $2 locatedStmt (Return $2)} + | 'match' MatchArgList '{' Equations '}' {locatedBetween $2 $4 locatedStmt (Match $2 $4)} + | AsmBlock {locatedValueWith locatedStmt $1 Asm} + | 'if' '(' Expr ')' Body %shift {locatedBetween $3 $5 locatedStmt (If $3 $5 [])} + | 'if' '(' Expr ')' Body 'else' Body {locatedBetween $3 ($5, $7) locatedStmt (If $3 $5 $7)} + | 'for' '(' ForInitStmt ';' Expr ';' ForPostStmt ')' Body {locatedBetween $3 ($5, $7, $9) locatedStmt (For $3 $5 $7 $9)} ForInitStmt :: { Stmt } -ForInitStmt : Expr '=' Expr {Assign $1 $3} - | Expr '+=' Expr {StmtPlusEq $1 $3} - | Expr '-=' Expr {StmtMinusEq $1 $3} - | 'let' Name ':' Type InitOpt {Let $2 (Just $4) $5} - | 'let' Name InitOpt {Let $2 Nothing $3} - | Expr {StmtExp $1} +ForInitStmt : Expr '=' Expr {locatedBetween $1 $3 locatedStmt (Assign $1 $3)} + | Expr '+=' Expr {locatedBetween $1 $3 locatedStmt (StmtPlusEq $1 $3)} + | Expr '-=' Expr {locatedBetween $1 $3 locatedStmt (StmtMinusEq $1 $3)} + | 'let' Name ':' Type InitOpt {locatedBetween $2 (Just $4, $5) locatedStmt (Let $2 (Just $4) $5)} + | 'let' Name InitOpt {locatedBetween $2 $3 locatedStmt (Let $2 Nothing $3)} + | Expr {locatedFrom $1 locatedStmt (StmtExp $1)} ForPostStmt :: { Stmt } -ForPostStmt : Expr '=' Expr {Assign $1 $3} - | Expr '+=' Expr {StmtPlusEq $1 $3} - | Expr '-=' Expr {StmtMinusEq $1 $3} - | Expr {StmtExp $1} +ForPostStmt : Expr '=' Expr {locatedBetween $1 $3 locatedStmt (Assign $1 $3)} + | Expr '+=' Expr {locatedBetween $1 $3 locatedStmt (StmtPlusEq $1 $3)} + | Expr '-=' Expr {locatedBetween $1 $3 locatedStmt (StmtMinusEq $1 $3)} + | Expr {locatedFrom $1 locatedStmt (StmtExp $1)} MatchArgList :: {[Exp]} @@ -418,37 +420,37 @@ InitOpt : {- empty -} {Nothing} -- Expressions Expr :: { Exp } -Expr : Name FunArgs {ExpName Nothing $1 $2} - | Literal {Lit $1} +Expr : Name FunArgs {locatedBetween $1 $2 locatedExp (ExpName Nothing $1 $2)} + | Literal {locatedValueWith locatedExp $1 Lit} | '(' Expr ')' {$2} - | '.' Name FunArgs {ExpDotName $2 $3} - | Expr '.' Name FunArgs {ExpName (Just $1) $3 $4} - | Name {ExpVar Nothing $1} - | '.' Name {ExpDotName $2 []} - | Expr '.' Name {ExpVar (Just $1) $3} - | 'lam' '(' ParamList ')' OptRetTy Body {Lam $3 $6 $5} - | Expr ':' Type {TyExp $1 $3} - | '(' TupleArgs ')' {tupleExp $2} - | Expr '[' Expr ']' {ExpIndexed $1 $3 } - | Expr '+' Expr {ExpPlus $1 $3 } - | Expr '-' Expr {ExpMinus $1 $3 } - | Expr '*' Expr {ExpTimes $1 $3 } - | Expr '/' Expr {ExpDivide $1 $3 } - | Expr '%' Expr {ExpModulo $1 $3 } - | Expr '<' Expr {ExpLT $1 $3 } - | Expr '>' Expr {ExpGT $1 $3 } - | Expr '<=' Expr {ExpLE $1 $3 } - | Expr '>=' Expr {ExpGE $1 $3 } - | Expr '==' Expr {ExpEE $1 $3 } - | Expr '!=' Expr {ExpNE $1 $3 } - | Expr '&&' Expr {ExpLAnd $1 $3 } - | Expr '||' Expr {ExpLOr $1 $3 } - | '!' Expr {ExpLNot $2 } + | '.' Name FunArgs {locatedBetween $2 $3 locatedExp (ExpDotName $2 $3)} + | Expr '.' Name FunArgs {locatedBetween $1 ($3, $4) locatedExp (ExpName (Just $1) $3 $4)} + | Name {locatedFrom $1 locatedExp (ExpVar Nothing $1)} + | '.' Name {locatedFrom $2 locatedExp (ExpDotName $2 [])} + | Expr '.' Name {locatedBetween $1 $3 locatedExp (ExpVar (Just $1) $3)} + | 'lam' '(' ParamList ')' OptRetTy Body {locatedBetween $3 ($5, $6) locatedExp (Lam $3 $6 $5)} + | Expr ':' Type {locatedBetween $1 $3 locatedExp (TyExp $1 $3)} + | '(' TupleArgs ')' {locatedFrom $2 locatedExp (tupleExp $2)} + | Expr '[' Expr ']' {locatedBetween $1 $3 locatedExp (ExpIndexed $1 $3)} + | Expr '+' Expr {locatedBetween $1 $3 locatedExp (ExpPlus $1 $3)} + | Expr '-' Expr {locatedBetween $1 $3 locatedExp (ExpMinus $1 $3)} + | Expr '*' Expr {locatedBetween $1 $3 locatedExp (ExpTimes $1 $3)} + | Expr '/' Expr {locatedBetween $1 $3 locatedExp (ExpDivide $1 $3)} + | Expr '%' Expr {locatedBetween $1 $3 locatedExp (ExpModulo $1 $3)} + | Expr '<' Expr {locatedBetween $1 $3 locatedExp (ExpLT $1 $3)} + | Expr '>' Expr {locatedBetween $1 $3 locatedExp (ExpGT $1 $3)} + | Expr '<=' Expr {locatedBetween $1 $3 locatedExp (ExpLE $1 $3)} + | Expr '>=' Expr {locatedBetween $1 $3 locatedExp (ExpGE $1 $3)} + | Expr '==' Expr {locatedBetween $1 $3 locatedExp (ExpEE $1 $3)} + | Expr '!=' Expr {locatedBetween $1 $3 locatedExp (ExpNE $1 $3)} + | Expr '&&' Expr {locatedBetween $1 $3 locatedExp (ExpLAnd $1 $3)} + | Expr '||' Expr {locatedBetween $1 $3 locatedExp (ExpLOr $1 $3)} + | '!' Expr {locatedFrom $2 locatedExp (ExpLNot $2)} | Conditional {$1} - | '@' Type {ExpAt $2} + | '@' Type {locatedFrom $2 locatedExp (ExpAt $2)} Conditional :: { Exp } -Conditional : 'if' Expr 'then' Expr 'else' Expr {ExpCond $2 $4 $6} +Conditional : 'if' Expr 'then' Expr 'else' Expr {locatedBetween $2 $6 locatedExp (ExpCond $2 $4 $6)} TupleArgs :: { [Exp] } TupleArgs : Expr ',' Expr {[$1, $3]} @@ -477,12 +479,12 @@ PatCommaList : Pattern {[$1]} | Pattern ',' PatCommaList {$1 : $3} Pattern :: { Pat } -Pattern : TypeName PatternList {Pat $1 $2} - | '.' Name PatternList {PatDot $2 $3} - | '_' {PWildcard} - | Literal {PLit $1} +Pattern : TypeName PatternList {locatedBetween $1 $2 locatedPat (Pat $1 $2)} + | '.' Name PatternList {locatedBetween $2 $3 locatedPat (PatDot $2 $3)} + | '_' {locatedPat $1 PWildcard} + | Literal {locatedValueWith locatedPat $1 PLit} | '(' Pattern ')' {$2} - | PatternList {Pat (Name "pair") $1} + | PatternList {locatedFrom $1 locatedPat (Pat (Name "pair") $1)} PatternList :: {[Pat]} PatternList : '(' PatList ')' {$2} @@ -494,17 +496,17 @@ PatList : Pattern %shift {[$1]} -- literals -Literal :: { Literal } -Literal : number {IntLit $ toInteger $1} - | stringlit {StrLit $ rmquotes $1} +Literal :: { LocatedValue Literal } +Literal : number {LocatedValue (locatedValueSpan $1) (IntLit (toInteger (locatedValue $1)))} + | stringlit {LocatedValue (locatedValueSpan $1) (StrLit (rmquotes (locatedValue $1)))} -- basic type definitions Type :: { Ty } -Type : TypeName OptTypeParam {TyCon $1 $2} - | LamType {uncurry funtype $1} +Type : TypeName OptTypeParam {locatedBetween $1 $2 locatedTy (TyCon $1 $2)} + | LamType {locatedFrom $1 locatedTy (uncurry funtype $1)} | TupleTy {$1} - | '@' Type {TyCon (Name "Proxy") [$2]} + | '@' Type {locatedFrom $2 locatedTy (TyCon (Name "Proxy") [$2])} TupleTy :: { Ty } TupleTy : '(' TypeCommaList ')' {mkTupleTy $2} @@ -513,19 +515,19 @@ LamType :: {([Ty], Ty)} LamType : '(' TypeCommaList ')' '->' Type {($2, $5)} Var :: { Ty } -Var : Name {TyCon $1 []} +Var : Name {locatedFrom $1 locatedTy (TyCon $1 [])} Name :: { Name } -Name : identifier { Name $1 } +Name : identifier { nameFromIdent $1 } TypeName :: { Name } -TypeName : identifier { Name $1 } - | TypeName '.' identifier { QualName $1 $3 } +TypeName : identifier { nameFromIdent $1 } + | TypeName '.' identifier { qualNameFromIdent $1 $3 } -- Yul statments and blocks -AsmBlock :: {YulBlock} -AsmBlock : 'assembly' YulBlock {$2} +AsmBlock :: {LocatedValue YulBlock} +AsmBlock : 'assembly' YulBlock {LocatedValue $1 $2} YulBlock :: {YulBlock} YulBlock : '{' YulStmts '}' {$2} @@ -597,8 +599,8 @@ YulExpCommaList : YulExp {[$1]} | YulExp ',' YulExpCommaList {$1 : $3} YulLiteral :: { YLiteral } -YulLiteral : number {YulNumber $ toInteger $1} - | stringlit {YulString (rmquotes $1)} +YulLiteral : number {YulNumber (toInteger (locatedValue $1))} + | stringlit {YulString (rmquotes (locatedValue $1))} OptSemi :: { () } OptSemi : ';' { () } @@ -607,9 +609,12 @@ OptSemi : ';' { () } { moduleParser :: [String] -> String -> IO (Either String CompUnit) -moduleParser _dirs content +moduleParser _dirs = parseCompUnitWithPath "" + +parseCompUnitWithPath :: FilePath -> String -> IO (Either String CompUnit) +parseCompUnitWithPath sourcePath content = do - let r = runAlex content parser + let r = runAlex content (setSourceName sourcePath >> parser) case r of Left err -> pure $ Left err Right cunit -> pure (Right cunit) @@ -617,6 +622,14 @@ moduleParser _dirs content parseCompUnit :: String -> IO (Either String CompUnit) parseCompUnit = moduleParser [] +nameFromIdent :: LocatedText -> Name +nameFromIdent ident = + locatedName (locatedTextSpan ident) (Name (locatedTextText ident)) + +qualNameFromIdent :: Name -> LocatedText -> Name +qualNameFromIdent qualifier ident = + locatedQualName qualifier (locatedTextSpan ident) (locatedTextText ident) + classifyImportPath :: Name -> ModulePath classifyImportPath modName = case splitName modName of @@ -647,12 +660,46 @@ tupleExp [t1] = t1 tupleExp [t1, t2] = pairExp t1 t2 tupleExp (t1 : ts) = pairExp t1 (tupleExp ts) +locatedFrom :: (HasSourceSpan anchor) => anchor -> (SourceSpan -> node -> node) -> node -> node +locatedFrom anchor locate node = + maybe node (`locate` node) (sourceSpanOf anchor) + +locatedBetween :: (HasSourceSpan left, HasSourceSpan right) => left -> right -> (SourceSpan -> node -> node) -> node -> node +locatedBetween left right locate node = + maybe node (`locate` node) (combineMaybeSourceSpans (sourceSpanOf left) (sourceSpanOf right)) + +locatedValueWith :: (SourceSpan -> node -> node) -> LocatedValue value -> (value -> node) -> node +locatedValueWith locate located build = + locate (locatedValueSpan located) (build (locatedValue located)) + rmquotes :: String -> String rmquotes = read -parseError (Token (line, col) lexeme) - = alexError $ "Parse error while processing lexeme: " ++ show lexeme - ++ "\n at line " ++ show line ++ ", column " ++ show col +parseError token@(Token _ lexeme) + = alexError $ + encodeDiagnostic + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0001"), + diagnosticMessage = "parse error: unexpected " ++ lexemeDescription lexeme, + diagnosticLabels = + [ Label + { labelSpan = tokenSpan token, + labelStyle = Primary, + labelMessage = Just (labelDescription lexeme) + } + ], + diagnosticNotes = [], + diagnosticHelp = [] + } + +lexemeDescription :: Lexeme -> String +lexemeDescription TEOF = "end of file" +lexemeDescription lexeme = show lexeme + +labelDescription :: Lexeme -> String +labelDescription TEOF = "expected more input" +labelDescription _ = "unexpected token" lexer :: (Token -> Alex a) -> Alex a lexer = (=<< alexMonadScan) diff --git a/src/Solcore/Frontend/Syntax.hs b/src/Solcore/Frontend/Syntax.hs index ce3cc43f6..4ac40813b 100644 --- a/src/Solcore/Frontend/Syntax.hs +++ b/src/Solcore/Frontend/Syntax.hs @@ -1,5 +1,6 @@ module Solcore.Frontend.Syntax ( module Solcore.Frontend.Syntax.Contract, + module Solcore.Frontend.Syntax.Location, module Solcore.Frontend.Syntax.Name, module Solcore.Frontend.Syntax.Stmt, module Solcore.Frontend.Syntax.Ty, @@ -7,6 +8,7 @@ module Solcore.Frontend.Syntax where import Solcore.Frontend.Syntax.Contract +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.Stmt import Solcore.Frontend.Syntax.Ty diff --git a/src/Solcore/Frontend/Syntax/Contract.hs b/src/Solcore/Frontend/Syntax/Contract.hs index 2694c09f3..d5ad59416 100644 --- a/src/Solcore/Frontend/Syntax/Contract.hs +++ b/src/Solcore/Frontend/Syntax/Contract.hs @@ -2,6 +2,7 @@ module Solcore.Frontend.Syntax.Contract where import Data.Generics (Data, Typeable) import Data.List.NonEmpty +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.Stmt import Solcore.Frontend.Syntax.Ty @@ -229,3 +230,122 @@ data ContractDecl a | CMutualDecl [ContractDecl a] -- used only after SCC analysis | CConstrDecl (Constructor a) deriving (Eq, Ord, Show, Data, Typeable) + +instance (HasSourceSpan a) => HasSourceSpan (CompUnit a) where + sourceSpanOf (CompUnit imps ds) = + firstSourceSpan [sourceSpanOf imps, sourceSpanOf ds] + +instance (HasSourceSpan a) => HasSourceSpan (TopDecl a) where + sourceSpanOf (TContr contractDef) = sourceSpanOf contractDef + sourceSpanOf (TFunDef funDef) = sourceSpanOf funDef + sourceSpanOf (TClassDef cls) = sourceSpanOf cls + sourceSpanOf (TInstDef inst) = sourceSpanOf inst + sourceSpanOf (TMutualDef mutualDecls) = sourceSpanOf mutualDecls + sourceSpanOf (TDataDef dataTy) = sourceSpanOf dataTy + sourceSpanOf (TSym tySym) = sourceSpanOf tySym + sourceSpanOf (TExportDecl exportDecl) = sourceSpanOf exportDecl + sourceSpanOf (TPragmaDecl pragma) = sourceSpanOf pragma + +instance HasSourceSpan Pragma where + sourceSpanOf (Pragma _ status) = sourceSpanOf status + +instance HasSourceSpan PragmaStatus where + sourceSpanOf Enabled = Nothing + sourceSpanOf DisableAll = Nothing + sourceSpanOf (DisableFor names) = sourceSpanOf (toList names) + +instance HasSourceSpan ModulePath where + sourceSpanOf (RelativePath n) = sourceSpanOf n + sourceSpanOf (LibraryPath n) = sourceSpanOf n + sourceSpanOf (ExternalPath libName modName) = + combineMaybeSourceSpans (sourceSpanOf libName) (sourceSpanOf modName) + +instance HasSourceSpan Export where + sourceSpanOf (ExportList specs) = sourceSpanOf specs + sourceSpanOf (ExportModule modulePath) = sourceSpanOf modulePath + sourceSpanOf (ExportModuleAs modulePath aliasName) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf aliasName] + sourceSpanOf (ExportItemsFrom modulePath selector) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf selector] + +instance HasSourceSpan ExportSpec where + sourceSpanOf (ExportName n) = sourceSpanOf n + sourceSpanOf (ExportNameWithConstructors typeName selector) = + firstSourceSpan [sourceSpanOf typeName, sourceSpanOf selector] + sourceSpanOf ExportAll = Nothing + sourceSpanOf (ExportModuleAll modulePath) = sourceSpanOf modulePath + +instance HasSourceSpan ConstructorSelector where + sourceSpanOf (SelectConstructors names) = sourceSpanOf names + sourceSpanOf SelectAllConstructors = Nothing + +instance HasSourceSpan ExportSelector where + sourceSpanOf (SelectExportItems items) = sourceSpanOf items + +instance HasSourceSpan ExportSelectorEntry where + sourceSpanOf SelectExportAllItems = Nothing + sourceSpanOf (SelectExportItem n) = sourceSpanOf n + sourceSpanOf (SelectExportConstructors typeName selector) = + firstSourceSpan [sourceSpanOf typeName, sourceSpanOf selector] + +instance HasSourceSpan Import where + sourceSpanOf (ImportModule modulePath) = sourceSpanOf modulePath + sourceSpanOf (ImportAlias modulePath aliasName) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf aliasName] + sourceSpanOf (ImportOnly modulePath items) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf items] + +instance HasSourceSpan ItemSelector where + sourceSpanOf (SelectItems items hidden) = + firstSourceSpan [sourceSpanOf items, sourceSpanOf hidden] + +instance HasSourceSpan ItemSelectorEntry where + sourceSpanOf SelectAllItems = Nothing + sourceSpanOf (SelectItem n) = sourceSpanOf n + +instance (HasSourceSpan a) => HasSourceSpan (Contract a) where + sourceSpanOf (Contract n tyVars contractDecls) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyVars, sourceSpanOf contractDecls] + +instance HasSourceSpan DataTy where + sourceSpanOf (DataTy n tyVars constrs) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyVars, sourceSpanOf constrs] + +instance HasSourceSpan Constr where + sourceSpanOf (Constr n tys) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tys] + +instance HasSourceSpan TySym where + sourceSpanOf (TySym n tyVars ty) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyVars, sourceSpanOf ty] + +instance (HasSourceSpan a) => HasSourceSpan (Constructor a) where + sourceSpanOf (Constructor params body) = + firstSourceSpan [sourceSpanOf params, sourceSpanOf body] + +instance (HasSourceSpan a) => HasSourceSpan (Class a) where + sourceSpanOf (Class boundVars context clsName params main signatures') = + firstSourceSpan [sourceSpanOf boundVars, sourceSpanOf context, sourceSpanOf clsName, sourceSpanOf params, sourceSpanOf main, sourceSpanOf signatures'] + +instance (HasSourceSpan a) => HasSourceSpan (Signature a) where + sourceSpanOf (Signature vars context sig params returnTy) = + firstSourceSpan [sourceSpanOf vars, sourceSpanOf context, sourceSpanOf sig, sourceSpanOf params, sourceSpanOf returnTy] + +instance (HasSourceSpan a) => HasSourceSpan (Instance a) where + sourceSpanOf (Instance _ vars context clsName params main funs) = + firstSourceSpan [sourceSpanOf vars, sourceSpanOf context, sourceSpanOf clsName, sourceSpanOf params, sourceSpanOf main, sourceSpanOf funs] + +instance (HasSourceSpan a) => HasSourceSpan (Field a) where + sourceSpanOf (Field n ty initExp) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf ty, sourceSpanOf initExp] + +instance (HasSourceSpan a) => HasSourceSpan (FunDef a) where + sourceSpanOf (FunDef sig body) = + firstSourceSpan [sourceSpanOf sig, sourceSpanOf body] + +instance (HasSourceSpan a) => HasSourceSpan (ContractDecl a) where + sourceSpanOf (CDataDecl dataTy) = sourceSpanOf dataTy + sourceSpanOf (CFieldDecl field) = sourceSpanOf field + sourceSpanOf (CFunDecl funDef) = sourceSpanOf funDef + sourceSpanOf (CMutualDecl decls') = sourceSpanOf decls' + sourceSpanOf (CConstrDecl constructor) = sourceSpanOf constructor diff --git a/src/Solcore/Frontend/Syntax/Location.hs b/src/Solcore/Frontend/Syntax/Location.hs new file mode 100644 index 000000000..25fabda7b --- /dev/null +++ b/src/Solcore/Frontend/Syntax/Location.hs @@ -0,0 +1,78 @@ +module Solcore.Frontend.Syntax.Location where + +import Control.Applicative ((<|>)) +import Data.Generics (Data, Typeable, everything, mkQ) +import Solcore.Diagnostics (SourceSpan, combineSourceSpans) + +data NodeOrigin + = SourceNode SourceSpan + | GeneratedNode + deriving (Show, Data, Typeable) + +newtype NodeLocation + = NodeLocation {nodeLocationOrigin :: NodeOrigin} + deriving (Show, Data, Typeable) + +instance Eq NodeLocation where + _ == _ = True + +instance Ord NodeLocation where + compare _ _ = EQ + +unlocatedNode :: NodeLocation +unlocatedNode = generatedNode + +generatedNode :: NodeLocation +generatedNode = NodeLocation GeneratedNode + +locatedNode :: SourceSpan -> NodeLocation +locatedNode = NodeLocation . SourceNode + +withNodeSourceSpan :: Maybe SourceSpan -> NodeLocation +withNodeSourceSpan Nothing = generatedNode +withNodeSourceSpan (Just sourceSpan) = locatedNode sourceSpan + +nodeLocationSpan :: NodeLocation -> Maybe SourceSpan +nodeLocationSpan (NodeLocation (SourceNode sourceSpan)) = Just sourceSpan +nodeLocationSpan (NodeLocation GeneratedNode) = Nothing + +isSourceNodeLocation :: NodeLocation -> Bool +isSourceNodeLocation (NodeLocation (SourceNode _)) = True +isSourceNodeLocation (NodeLocation GeneratedNode) = False + +isGeneratedNodeLocation :: NodeLocation -> Bool +isGeneratedNodeLocation = not . isSourceNodeLocation + +nodeLocationsOf :: (Data a) => a -> [NodeLocation] +nodeLocationsOf = + everything (++) (mkQ [] nodeLocationList) + where + nodeLocationList :: NodeLocation -> [NodeLocation] + nodeLocationList location = [location] + +combineMaybeSourceSpans :: Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan +combineMaybeSourceSpans Nothing right = right +combineMaybeSourceSpans left Nothing = left +combineMaybeSourceSpans (Just left) (Just right) = Just (combineSourceSpans left right) + +firstSourceSpan :: [Maybe SourceSpan] -> Maybe SourceSpan +firstSourceSpan = foldr (<|>) Nothing + +class HasSourceSpan a where + sourceSpanOf :: a -> Maybe SourceSpan + +instance HasSourceSpan NodeLocation where + sourceSpanOf = nodeLocationSpan + +instance (HasSourceSpan a) => HasSourceSpan (Maybe a) where + sourceSpanOf = (>>= sourceSpanOf) + +instance (HasSourceSpan a) => HasSourceSpan [a] where + sourceSpanOf = firstSourceSpan . map sourceSpanOf + +instance (HasSourceSpan a, HasSourceSpan b) => HasSourceSpan (a, b) where + sourceSpanOf (left, right) = firstSourceSpan [sourceSpanOf left, sourceSpanOf right] + +instance (HasSourceSpan a, HasSourceSpan b, HasSourceSpan c) => HasSourceSpan (a, b, c) where + sourceSpanOf (left, middle, right) = + firstSourceSpan [sourceSpanOf left, sourceSpanOf middle, sourceSpanOf right] diff --git a/src/Solcore/Frontend/Syntax/Name.hs b/src/Solcore/Frontend/Syntax/Name.hs index 56c111d01..d9f750a11 100644 --- a/src/Solcore/Frontend/Syntax/Name.hs +++ b/src/Solcore/Frontend/Syntax/Name.hs @@ -1,15 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Solcore.Frontend.Syntax.Name where import Common.Pretty +import Control.Applicative ((<|>)) import Data.Generics (Data, Typeable) import Data.String +import Solcore.Diagnostics (SourceSpan, combineSourceSpans) +import Solcore.Frontend.Syntax.Location data Name - = Name String - | QualName Name String - deriving (Eq, Ord, Data, Typeable) + = NameWithSpan (Maybe SourceSpan) String + | QualNameWithSpan (Maybe SourceSpan) Name String + deriving (Data, Typeable) + +pattern Name :: String -> Name +pattern Name s <- NameWithSpan _ s + where + Name s = NameWithSpan Nothing s + +pattern QualName :: Name -> String -> Name +pattern QualName n s <- QualNameWithSpan _ n s + where + QualName n s = QualNameWithSpan Nothing n s + +{-# COMPLETE Name, QualName #-} + +instance Eq Name where + left == right = nameSegments left == nameSegments right + +instance Ord Name where + compare left right = compare (nameSegments left) (nameSegments right) instance Show Name where show (Name s) = s @@ -22,3 +44,40 @@ instance IsString Name where instance Pretty Name where ppr (QualName n s) = ppr n <> text "." <> text s ppr (Name s) = text s + +nameSourceSpan :: Name -> Maybe SourceSpan +nameSourceSpan (NameWithSpan sourceSpan _) = sourceSpan +nameSourceSpan (QualNameWithSpan sourceSpan qualifier _) = sourceSpan <|> nameSourceSpan qualifier + +instance HasSourceSpan Name where + sourceSpanOf = nameSourceSpan + +locatedName :: SourceSpan -> Name -> Name +locatedName sourceSpan (Name s) = NameWithSpan (Just sourceSpan) s +locatedName sourceSpan (QualName qualifier s) = QualNameWithSpan (Just sourceSpan) qualifier s + +withNameSourceSpan :: Maybe SourceSpan -> Name -> Name +withNameSourceSpan Nothing name = name +withNameSourceSpan (Just sourceSpan) name = locatedName sourceSpan name + +copyNameSourceSpan :: Name -> Name -> Name +copyNameSourceSpan source target = + withNameSourceSpan (nameSourceSpan source) target + +qualifyName :: Name -> Name -> Name +qualifyName qualifier leaf = + copyNameSourceSpan leaf (QualName qualifier (show leaf)) + +locatedQualName :: Name -> SourceSpan -> String -> Name +locatedQualName qualifier leafSpan leaf = + QualNameWithSpan (Just sourceSpan) qualifier leaf + where + sourceSpan = maybe leafSpan (`combineSourceSpans` leafSpan) (nameSourceSpan qualifier) + +stripNameSourceSpan :: Name -> Name +stripNameSourceSpan (Name s) = Name s +stripNameSourceSpan (QualName qualifier s) = QualName (stripNameSourceSpan qualifier) s + +nameSegments :: Name -> [String] +nameSegments (Name s) = [s] +nameSegments (QualName n s) = nameSegments n ++ [s] diff --git a/src/Solcore/Frontend/Syntax/NameResolution.hs b/src/Solcore/Frontend/Syntax/NameResolution.hs index 471daff0a..033461f72 100644 --- a/src/Solcore/Frontend/Syntax/NameResolution.hs +++ b/src/Solcore/Frontend/Syntax/NameResolution.hs @@ -5,11 +5,16 @@ import Control.Applicative import Control.Monad import Control.Monad.Except import Control.Monad.State +import Data.Generics (Data, everything, extQ, mkQ) import Data.List ((\\)) import Data.Map (Map) import Data.Map qualified as Map +import Data.Maybe (mapMaybe) +import Data.Monoid (First (..)) +import Solcore.Diagnostics (CompilerError (..), Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceSpan, addDiagnosticNote, diagnosticCompilerError) import Solcore.Frontend.Pretty.TreePretty import Solcore.Frontend.Syntax.Contract hiding (contracts, decls) +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name import Solcore.Frontend.Syntax.Stmt import Solcore.Frontend.Syntax.SyntaxTree qualified as S @@ -17,14 +22,14 @@ import Solcore.Frontend.Syntax.Ty -- name resolution -nameResolution :: S.CompUnit -> IO (Either String (CompUnit Name)) +nameResolution :: S.CompUnit -> IO (Either CompilerError (CompUnit Name)) nameResolution (S.CompUnit imps ds) = fmap fst <$> nameResolutionTopDeclSegments imps [ds] nameResolutionTopDeclSegments :: [S.Import] -> [[S.TopDecl]] -> - IO (Either String (CompUnit Name, [[TopDecl Name]])) + IO (Either CompilerError (CompUnit Name, [[TopDecl Name]])) nameResolutionTopDeclSegments imps segments = do let ds = concat segments @@ -79,23 +84,23 @@ resolveExportSpec (S.ExportNameWithConstructors typeName ctorSelector) = ExportNameWithConstructors typeName (resolveConstructorSelector ctorSelector) resolveExportSpec (S.ExportModuleAll path) = ExportModuleAll (resolveModulePath path) -validateDuplicateNamespacesInCompUnit :: S.CompUnit -> Either String () +validateDuplicateNamespacesInCompUnit :: S.CompUnit -> Either CompilerError () validateDuplicateNamespacesInCompUnit (S.CompUnit _ ds) = validateDuplicateNamespaces ds -validateDuplicateNamespacesInTopDeclSegments :: [[S.TopDecl]] -> Either String () +validateDuplicateNamespacesInTopDeclSegments :: [[S.TopDecl]] -> Either CompilerError () validateDuplicateNamespacesInTopDeclSegments segments = do ensureNoDuplicateNames "type namespace" (concatMap topLevelTypeNames segments) ensureNoDuplicateNames "term namespace" (concatMap topLevelTermNames segments) mapM_ validateContractDuplicates [c | segment <- segments, S.TContr c <- segment] -validateDuplicateNamespaces :: [S.TopDecl] -> Either String () +validateDuplicateNamespaces :: [S.TopDecl] -> Either CompilerError () validateDuplicateNamespaces ds = do ensureNoDuplicateNames "type namespace" (topLevelTypeNames ds) ensureNoDuplicateNames "term namespace" (topLevelTermNames ds) mapM_ validateContractDuplicates [c | S.TContr c <- ds] -validateContractDuplicates :: S.Contract -> Either String () +validateContractDuplicates :: S.Contract -> Either CompilerError () validateContractDuplicates (S.Contract cname _ decls) = do let typeNames = [n | S.CDataDecl (S.DataTy n _ _) <- decls] termNames = contractTermNames decls @@ -130,22 +135,24 @@ contractTermNames = concatMap collect qualifiedConstructorName :: Name -> Name -> Name qualifiedConstructorName tyCon conName = - QualName tyCon (pretty (constructorLeafName conName)) + qualifyName tyCon (constructorLeafName conName) -ensureNoDuplicateNames :: String -> [Name] -> Either String () +ensureNoDuplicateNames :: String -> [Name] -> Either CompilerError () ensureNoDuplicateNames ns = ensureNoDuplicateNamesIn "module" ns -ensureNoDuplicateNamesIn :: String -> String -> [Name] -> Either String () +ensureNoDuplicateNamesIn :: String -> String -> [Name] -> Either CompilerError () ensureNoDuplicateNamesIn ctx ns names = case duplicates of [] -> pure () xs -> Left $ - unlines - [ "Duplicate declarations in " ++ ns ++ ":", - " " ++ ctx, - unlines (map (\n -> " " ++ pretty n) xs) - ] + diagnosticCompilerError $ + diagnosticValue + "SC0108" + ("duplicate declarations in " ++ ns) + [] + (("context: " ++ ctx) : map (\n -> " " ++ pretty n) xs) + ["rename or remove the duplicate declaration"] where counts :: Map Name Int counts = Map.fromListWith (+) [(n, 1) | n <- names] @@ -172,6 +179,10 @@ instance (Resolve a) => Resolve (Maybe a) where resolve Nothing = pure Nothing resolve (Just x) = Just <$> resolve x +locatedLike :: (HasSourceSpan source) => source -> (SourceSpan -> target -> target) -> target -> target +locatedLike source locate target = + maybe target (`locate` target) (sourceSpanOf source) + instance Resolve S.TopDecl where type Result S.TopDecl = TopDecl Name @@ -356,34 +367,34 @@ instance Resolve S.Stmt where type Result S.Stmt = Stmt Name resolve s@(S.Assign lhs rhs) = - do + locatedLike s locatedStmt <$> do lhs' <- resolve lhs `wrapError` s rhs' <- resolve rhs `wrapError` s pure (lhs' := rhs') - resolve (S.StmtPlusEq lhs rhs) = - (:=) <$> resolve lhs <*> resolve (S.ExpPlus lhs rhs) - resolve (S.StmtMinusEq lhs rhs) = - (:=) <$> resolve lhs <*> resolve (S.ExpMinus lhs rhs) + resolve s@(S.StmtPlusEq lhs rhs) = + locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpPlus lhs rhs)) + resolve s@(S.StmtMinusEq lhs rhs) = + locatedLike s locatedStmt <$> ((:=) <$> resolve lhs <*> resolve (S.ExpMinus lhs rhs)) resolve s@(S.Let n mt me) = - do + locatedLike s locatedStmt <$> do mt' <- resolve mt `wrapError` s me' <- resolve me `wrapError` s addLocalVar n pure (Let n mt' me') - resolve (S.Block blk) = - withLocalCtx (Block <$> resolve blk) + resolve s@(S.Block blk) = + locatedLike s locatedStmt <$> withLocalCtx (Block <$> resolve blk) resolve s@(S.StmtExp e) = - StmtExp <$> resolve e `wrapError` s + locatedLike s locatedStmt <$> (StmtExp <$> resolve e `wrapError` s) resolve s@(S.Return e) = - Return <$> resolve e `wrapError` s - resolve (S.Match es eqns) = - Match <$> resolve es <*> resolve eqns - resolve (S.Asm blk) = - pure (Asm blk) - resolve (S.If e blk1 blk2) = - If <$> resolve e <*> resolve blk1 <*> resolve blk2 - resolve (S.For initStmt cond postStmt body) = - For <$> resolve initStmt <*> resolve cond <*> resolve postStmt <*> resolve body + locatedLike s locatedStmt <$> (Return <$> resolve e `wrapError` s) + resolve s@(S.Match es eqns) = + locatedLike s locatedStmt <$> (Match <$> resolve es <*> resolve eqns) + resolve s@(S.Asm blk) = + pure (locatedLike s locatedStmt (Asm blk)) + resolve s@(S.If e blk1 blk2) = + locatedLike s locatedStmt <$> (If <$> resolve e <*> resolve blk1 <*> resolve blk2) + resolve s@(S.For initStmt cond postStmt body) = + locatedLike s locatedStmt <$> (For <$> resolve initStmt <*> resolve cond <*> resolve postStmt <*> resolve body) instance Resolve S.Equation where type Result S.Equation = Equation Name @@ -395,13 +406,13 @@ instance Resolve S.Equation where instance Resolve S.Pat where type Result S.Pat = Pat Name - resolve S.PWildcard = pure PWildcard - resolve (S.PLit l) = PLit <$> resolve l + resolve p@S.PWildcard = pure (locatedLike p locatedPat PWildcard) + resolve p@(S.PLit l) = locatedLike p locatedPat <$> (PLit <$> resolve l) resolve p@(S.PatDot n ps) = do ps' <- resolve ps `wrapError` p - pure (PCon (dotConstructorMarker n) ps') + pure (locatedLike p locatedPat (PCon (dotConstructorMarker n) ps')) resolve p@(S.Pat n ps) = - do + locatedLike p locatedPat <$> do ps' <- resolve ps `wrapError` p mdt <- lookupName n case mdt of @@ -454,11 +465,11 @@ pairPat :: Pat Name -> Pat Name -> Pat Name pairPat p1 p2 = PCon (Name "pair") [p1, p2] constructorLeafName :: Name -> Name -constructorLeafName (QualName _ n) = Name n +constructorLeafName q@(QualName _ n) = copyNameSourceSpan q (Name n) constructorLeafName n = n dotConstructorMarker :: Name -> Name -dotConstructorMarker n = Name ('.' : pretty (constructorLeafName n)) +dotConstructorMarker n = copyNameSourceSpan n (Name ('.' : pretty (constructorLeafName n))) isPrimitiveConstructor :: Name -> Bool isPrimitiveConstructor n = @@ -474,8 +485,8 @@ isPrimitiveConstructor n = ] splitQualifiedName :: Name -> Maybe (Name, Name) -splitQualifiedName (QualName qualifier conName) = - Just (qualifier, Name conName) +splitQualifiedName q@(QualName qualifier conName) = + Just (qualifier, copyNameSourceSpan q (Name conName)) splitQualifiedName _ = Nothing hasQualifiedConstructorLeaf :: Name -> ResolveM Bool @@ -512,254 +523,257 @@ resolveSameNameConstructorName n = instance Resolve S.Exp where type Result S.Exp = Exp Name - resolve (S.Lit l) = Lit <$> resolve l - resolve e@(S.ExpDotName n es) = - Con (dotConstructorMarker n) <$> resolve es `wrapError` e - resolve e@(S.Lam ps bd mt) = - withLocalCtx $ do - ps' <- resolve ps `wrapError` e - mt' <- resolve mt `wrapError` e - let args = map paramName ps' - mapM_ addParameter args - bd' <- resolve bd `wrapError` e - pure (Lam ps' bd' mt') - resolve (S.TyExp e t) = - TyExp <$> resolve e <*> resolve t - resolve c@(S.ExpVar me n) = - do - me' <- resolve me `wrapError` c - dt <- lookupName n - case (me', dt) of - -- local variables - (_, Just TLocalVar) -> pure (Var n) - -- function parameters - (_, Just TParameter) -> pure (Var n) - -- field access - (Nothing, Just TField) -> - pure (FieldAccess Nothing n) - -- function reference - (_, Just TFunction) -> do - dt1 <- gets (Map.lookup n . fieldEnv) - case dt1 of - Just TField -> pure (FieldAccess Nothing n) - _ -> pure (Var n) - -- data constructor - (Nothing, Just TDataCon) -> do - if isPrimitiveConstructor n - then pure (Con n []) - else case splitQualifiedName n of - Just (qualifier, conName) -> - Con <$> resolveQualifiedConstructorName qualifier conName <*> pure [] - Nothing -> unqualifiedConstructorError n - (Just (Var d), Just TDataCon) -> - Con <$> resolveQualifiedConstructorName d n <*> pure [] - (Just (Var d), Just TTyCon) -> do - let qn = QualName d (pretty n) - qdt <- lookupName qn - case qdt of - Just TFunction -> pure (Var qn) - Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] - Just TTyCon -> pure (Var qn) - Just TModule -> pure (Var qn) - _ -> undefinedName n - -- class name - (_, Just TClass) -> pure (Var n) - -- type constructor used as a constructor qualifier - (Nothing, Just TTyCon) -> do - sameName <- isSameNameConstructor n - if sameName - then Con <$> resolveSameNameConstructorName n <*> pure [] - else pure (Var n) - -- imported module qualifier name - (_, Just TModule) -> pure (Var n) - -- module-qualified function or constructor reference - (Just (Var d), Nothing) -> do - let qn = QualName d (pretty n) - qdt <- lookupName qn - case qdt of - Just TFunction -> pure (Var qn) - Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] - Just TTyCon -> pure (Var qn) - Just TModule -> pure (Var qn) - _ -> do - let fallback = QualName (constructorLeafName d) (pretty n) - fdt <- lookupName fallback - case fdt of - Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] - _ -> undefinedName n - _ -> do - sameName <- isSameNameConstructor n - if sameName - then Con <$> resolveSameNameConstructorName n <*> pure [] - else do - hasQualified <- hasQualifiedConstructorLeaf n - if hasQualified - then unqualifiedConstructorError n - else undefinedName n - resolve x@(S.ExpName me n es) = - do - me' <- resolve me `wrapError` x - es' <- resolve es `wrapError` x - dt <- lookupName n - case (me', dt) of - -- normal function call - (Nothing, Just TFunction) -> - pure (Call Nothing n es') - (Nothing, Just TTyCon) -> do - sameName <- isSameNameConstructor n - if sameName - then Con <$> resolveSameNameConstructorName n <*> pure es' - else undefinedName n - -- data constructors - (Nothing, Just TDataCon) -> do - if isPrimitiveConstructor n - then pure (Con n es') - else case splitQualifiedName n of - Just (qualifier, conName) -> - Con <$> resolveQualifiedConstructorName qualifier conName <*> pure es' - Nothing -> unqualifiedConstructorError n - (Just (Var d), Just TDataCon) -> - Con <$> resolveQualifiedConstructorName d n <*> pure es' - (Just (Var c), Just TTyCon) -> do - let qn = QualName c (pretty n) - qdt <- lookupName qn - case qdt of - Just TFunction -> pure (Call Nothing qn es') - Just TDataCon -> Con <$> resolveQualifiedConstructorName c n <*> pure es' - _ -> undefinedName n - -- class functions - (Just (Var c), Just TFunction) -> do - ct <- lookupName c - let qn = QualName c (pretty n) - case ct of - Just TClass -> - pure (Call Nothing qn es') - Just TModule -> do - cf <- lookupName qn - case cf of - Just TFunction -> pure (Call Nothing qn es') - Just TDataCon -> Con <$> resolveQualifiedConstructorName c n <*> pure es' - _ -> undefinedName n - _ -> undefinedName c - (Just (Var c), Nothing) -> do - ct <- lookupName c - let qn = QualName c (pretty n) - cf <- lookupName qn - case (ct, cf) of - (Just TClass, Just TFunction) -> - pure (Call Nothing qn es') - (_, Just TFunction) -> - pure (Call Nothing qn es') - (_, Just TDataCon) -> - Con <$> resolveQualifiedConstructorName c n <*> pure es' - _ -> do - let fallback = QualName (constructorLeafName c) (pretty n) - fdt <- lookupName fallback - case fdt of - Just TDataCon -> - Con <$> resolveQualifiedConstructorName c n <*> pure es' - _ -> undefinedName n - (Just (Var c), Just TTyVar) -> do - let qn = QualName c (pretty n) - cf <- gets (Map.lookup qn . scopeEnv) - case cf of - Just TFunction -> pure (Call Nothing qn es') - _ -> undefinedName n - -- variables - (_, Just TLocalVar) -> - pure (Call Nothing n es') - (_, Just TParameter) -> - pure (Call Nothing n es') - -- error - _ -> do - sameName <- isSameNameConstructor n - if sameName - then Con <$> resolveSameNameConstructorName n <*> pure es' - else do - hasQualified <- hasQualifiedConstructorLeaf n - if hasQualified - then unqualifiedConstructorError n - else undefinedName n - resolve c@(S.ExpPlus e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Add") "add" - pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpMinus e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Sub") "sub" - pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpTimes e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Mul") "mul" - pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpDivide e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Div") "div" - pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpModulo e1 e2) = - do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Mod") "mod" - pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpIndexed array idx) = do - arr' <- resolve array `wrapError` c - idx' <- resolve idx `wrapError` c - pure $ Indexed arr' idx' - resolve c@(S.ExpLT e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "lt") [e1', e2'] - resolve c@(S.ExpGT e1 e2) = do + resolve e = locatedLike e locatedExp <$> resolveExp e + +resolveExp :: S.Exp -> ResolveM (Exp Name) +resolveExp (S.Lit l) = Lit <$> resolve l +resolveExp e@(S.ExpDotName n es) = + Con (dotConstructorMarker n) <$> resolve es `wrapError` e +resolveExp e@(S.Lam ps bd mt) = + withLocalCtx $ do + ps' <- resolve ps `wrapError` e + mt' <- resolve mt `wrapError` e + let args = map paramName ps' + mapM_ addParameter args + bd' <- resolve bd `wrapError` e + pure (Lam ps' bd' mt') +resolveExp (S.TyExp e t) = + TyExp <$> resolve e <*> resolve t +resolveExp c@(S.ExpVar me n) = + do + me' <- resolve me `wrapError` c + dt <- lookupName n + case (me', dt) of + -- local variables + (_, Just TLocalVar) -> pure (Var n) + -- function parameters + (_, Just TParameter) -> pure (Var n) + -- field access + (Nothing, Just TField) -> + pure (FieldAccess Nothing n) + -- function reference + (_, Just TFunction) -> do + dt1 <- gets (Map.lookup n . fieldEnv) + case dt1 of + Just TField -> pure (FieldAccess Nothing n) + _ -> pure (Var n) + -- data constructor + (Nothing, Just TDataCon) -> do + if isPrimitiveConstructor n + then pure (Con n []) + else case splitQualifiedName n of + Just (qualifier, conName) -> + Con <$> resolveQualifiedConstructorName qualifier conName <*> pure [] + Nothing -> unqualifiedConstructorError n + (Just (Var d), Just TDataCon) -> + Con <$> resolveQualifiedConstructorName d n <*> pure [] + (Just (Var d), Just TTyCon) -> do + let qn = qualifyName d n + qdt <- lookupName qn + case qdt of + Just TFunction -> pure (Var qn) + Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] + Just TTyCon -> pure (Var qn) + Just TModule -> pure (Var qn) + _ -> undefinedName n + -- class name + (_, Just TClass) -> pure (Var n) + -- type constructor used as a constructor qualifier + (Nothing, Just TTyCon) -> do + sameName <- isSameNameConstructor n + if sameName + then Con <$> resolveSameNameConstructorName n <*> pure [] + else pure (Var n) + -- imported module qualifier name + (_, Just TModule) -> pure (Var n) + -- module-qualified function or constructor reference + (Just (Var d), Nothing) -> do + let qn = qualifyName d n + qdt <- lookupName qn + case qdt of + Just TFunction -> pure (Var qn) + Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] + Just TTyCon -> pure (Var qn) + Just TModule -> pure (Var qn) + _ -> do + let fallback = qualifyName (constructorLeafName d) n + fdt <- lookupName fallback + case fdt of + Just TDataCon -> Con <$> resolveQualifiedConstructorName d n <*> pure [] + _ -> undefinedName n + _ -> do + sameName <- isSameNameConstructor n + if sameName + then Con <$> resolveSameNameConstructorName n <*> pure [] + else do + hasQualified <- hasQualifiedConstructorLeaf n + if hasQualified + then unqualifiedConstructorError n + else undefinedName n +resolveExp x@(S.ExpName me n es) = + do + me' <- resolve me `wrapError` x + es' <- resolve es `wrapError` x + dt <- lookupName n + case (me', dt) of + -- normal function call + (Nothing, Just TFunction) -> + pure (Call Nothing n es') + (Nothing, Just TTyCon) -> do + sameName <- isSameNameConstructor n + if sameName + then Con <$> resolveSameNameConstructorName n <*> pure es' + else undefinedName n + -- data constructors + (Nothing, Just TDataCon) -> do + if isPrimitiveConstructor n + then pure (Con n es') + else case splitQualifiedName n of + Just (qualifier, conName) -> + Con <$> resolveQualifiedConstructorName qualifier conName <*> pure es' + Nothing -> unqualifiedConstructorError n + (Just (Var d), Just TDataCon) -> + Con <$> resolveQualifiedConstructorName d n <*> pure es' + (Just (Var c), Just TTyCon) -> do + let qn = qualifyName c n + qdt <- lookupName qn + case qdt of + Just TFunction -> pure (Call Nothing qn es') + Just TDataCon -> Con <$> resolveQualifiedConstructorName c n <*> pure es' + _ -> undefinedName n + -- class functions + (Just (Var c), Just TFunction) -> do + ct <- lookupName c + let qn = qualifyName c n + case ct of + Just TClass -> + pure (Call Nothing qn es') + Just TModule -> do + cf <- lookupName qn + case cf of + Just TFunction -> pure (Call Nothing qn es') + Just TDataCon -> Con <$> resolveQualifiedConstructorName c n <*> pure es' + _ -> undefinedName n + _ -> undefinedName c + (Just (Var c), Nothing) -> do + ct <- lookupName c + let qn = qualifyName c n + cf <- lookupName qn + case (ct, cf) of + (Just TClass, Just TFunction) -> + pure (Call Nothing qn es') + (_, Just TFunction) -> + pure (Call Nothing qn es') + (_, Just TDataCon) -> + Con <$> resolveQualifiedConstructorName c n <*> pure es' + _ -> do + let fallback = qualifyName (constructorLeafName c) n + fdt <- lookupName fallback + case fdt of + Just TDataCon -> + Con <$> resolveQualifiedConstructorName c n <*> pure es' + _ -> undefinedName n + (Just (Var c), Just TTyVar) -> do + let qn = qualifyName c n + cf <- gets (Map.lookup qn . scopeEnv) + case cf of + Just TFunction -> pure (Call Nothing qn es') + _ -> undefinedName n + -- variables + (_, Just TLocalVar) -> + pure (Call Nothing n es') + (_, Just TParameter) -> + pure (Call Nothing n es') + -- error + _ -> do + sameName <- isSameNameConstructor n + if sameName + then Con <$> resolveSameNameConstructorName n <*> pure es' + else do + hasQualified <- hasQualifiedConstructorLeaf n + if hasQualified + then unqualifiedConstructorError n + else undefinedName n +resolveExp c@(S.ExpPlus e1 e2) = + do e1' <- resolve e1 `wrapError` c e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Ord") "gt" + let fun = QualName (Name "Add") "add" pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpLE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "le") [e1', e2'] - resolve c@(S.ExpGE e1 e2) = do - e1' <- resolve e1 `wrapError` c - e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "ge") [e1', e2'] - resolve c@(S.ExpEE e1 e2) = do +resolveExp c@(S.ExpMinus e1 e2) = + do e1' <- resolve e1 `wrapError` c e2' <- resolve e2 `wrapError` c - let fun = QualName (Name "Eq") "eq" + let fun = QualName (Name "Sub") "sub" pure $ Call Nothing fun [e1', e2'] - resolve c@(S.ExpNE e1 e2) = do +resolveExp c@(S.ExpTimes e1 e2) = + do e1' <- resolve e1 `wrapError` c e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "ne") [e1', e2'] - resolve c@(S.ExpLAnd e1 e2) = do + let fun = QualName (Name "Mul") "mul" + pure $ Call Nothing fun [e1', e2'] +resolveExp c@(S.ExpDivide e1 e2) = + do e1' <- resolve e1 `wrapError` c e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "and") [e1', e2'] - resolve c@(S.ExpLOr e1 e2) = do + let fun = QualName (Name "Div") "div" + pure $ Call Nothing fun [e1', e2'] +resolveExp c@(S.ExpModulo e1 e2) = + do e1' <- resolve e1 `wrapError` c e2' <- resolve e2 `wrapError` c - pure $ Call Nothing (Name "or") [e1', e2'] - resolve c@(S.ExpLNot e) = do - e' <- resolve e `wrapError` c - pure $ Call Nothing (Name "not") [e'] - resolve (S.ExpCond e1 e2 e3) = - Cond <$> resolve e1 <*> resolve e2 <*> resolve e3 - resolve (S.ExpAt t) = do - t' <- resolve t - pure - ( TyExp - (Con (Name "Proxy") []) - (TyCon (Name "Proxy") [t']) - ) + let fun = QualName (Name "Mod") "mod" + pure $ Call Nothing fun [e1', e2'] +resolveExp c@(S.ExpIndexed array idx) = do + arr' <- resolve array `wrapError` c + idx' <- resolve idx `wrapError` c + pure $ Indexed arr' idx' +resolveExp c@(S.ExpLT e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "lt") [e1', e2'] +resolveExp c@(S.ExpGT e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + let fun = QualName (Name "Ord") "gt" + pure $ Call Nothing fun [e1', e2'] +resolveExp c@(S.ExpLE e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "le") [e1', e2'] +resolveExp c@(S.ExpGE e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "ge") [e1', e2'] +resolveExp c@(S.ExpEE e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + let fun = QualName (Name "Eq") "eq" + pure $ Call Nothing fun [e1', e2'] +resolveExp c@(S.ExpNE e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "ne") [e1', e2'] +resolveExp c@(S.ExpLAnd e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "and") [e1', e2'] +resolveExp c@(S.ExpLOr e1 e2) = do + e1' <- resolve e1 `wrapError` c + e2' <- resolve e2 `wrapError` c + pure $ Call Nothing (Name "or") [e1', e2'] +resolveExp c@(S.ExpLNot e) = do + e' <- resolve e `wrapError` c + pure $ Call Nothing (Name "not") [e'] +resolveExp (S.ExpCond e1 e2 e3) = + Cond <$> resolve e1 <*> resolve e2 <*> resolve e3 +resolveExp (S.ExpAt t) = do + t' <- resolve t + pure + ( TyExp + (Con (Name "Proxy") []) + (TyCon (Name "Proxy") [t']) + ) instance Resolve S.Literal where type Result S.Literal = Literal @@ -818,7 +832,7 @@ instance Resolve S.Ty where type Result S.Ty = Ty resolve tc@(S.TyCon n ts) = - do + locatedLike tc locatedTy <$> do ndt <- lookupType n case ndt of Just TTyCon -> TyCon n <$> resolve ts `wrapError` tc @@ -923,7 +937,7 @@ addTopDecl (S.TClassDef (S.Class _ _ n _ _ sigs)) env = let env' = foldr ( \s ac -> - let qn = QualName n (pretty (S.sigName s)) + let qn = qualifyName n (S.sigName s) in Map.insert qn TFunction ac ) (scopeEnv env) @@ -962,9 +976,9 @@ addQualifiedModules _ env = env -- definition of a monad for name resolution -type ResolveM a = StateT Env (ExceptT String IO) a +type ResolveM a = StateT Env (ExceptT CompilerError IO) a -runResolveM :: ResolveM a -> Env -> IO (Either String a) +runResolveM :: ResolveM a -> Env -> IO (Either CompilerError a) runResolveM m env = do r <- runExceptT (runStateT m env) @@ -1004,12 +1018,57 @@ lookupName n = fdt = Map.lookup n (fieldEnv env) pure (ldt <|> gdt <|> cdt <|> fdt) -wrapError :: (Pretty b) => ResolveM a -> b -> ResolveM a +wrapError :: (Pretty b, Data b) => ResolveM a -> b -> ResolveM a wrapError m e = catchError m handler where handler msg = throwError (decorate msg) - decorate msg = msg ++ "\n - in:" ++ pretty e + decorate (CompilerDiagnostics diagnostics) = + CompilerDiagnostics $ + map + (addDiagnosticNote ("in: " ++ pretty e) . addContextLabel e) + diagnostics + decorate (CompilerLegacyError msg) = + CompilerLegacyError (msg ++ "\n - in:" ++ pretty e) + +addContextLabel :: (Data b) => b -> Diagnostic -> Diagnostic +addContextLabel context diagnostic + | any ((== Primary) . labelStyle) (diagnosticLabels diagnostic) = diagnostic + | otherwise = + case contextSourceSpan context of + Just sourceSpan -> + diagnostic + { diagnosticLabels = + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just (contextLabelMessage diagnostic) + } + : diagnosticLabels diagnostic + } + Nothing -> diagnostic + +contextLabelMessage :: Diagnostic -> String +contextLabelMessage diagnostic = + case diagnosticCode diagnostic of + Just (DiagnosticCode "SC0101") -> "unknown name" + Just (DiagnosticCode "SC0102") -> "undefined type variable" + Just (DiagnosticCode "SC0103") -> "undefined type constructor" + Just (DiagnosticCode "SC0104") -> "invalid type synonym" + Just (DiagnosticCode "SC0105") -> "undefined class" + Just (DiagnosticCode "SC0106") -> "unqualified constructor" + Just (DiagnosticCode "SC0107") -> "invalid pattern" + _ -> "diagnostic reported here" + +contextSourceSpan :: (Data a) => a -> Maybe SourceSpan +contextSourceSpan value = + getFirst $ everything (<>) (mkQ (First Nothing) locationSpan `extQ` nameSpan) value + where + locationSpan :: NodeLocation -> First SourceSpan + locationSpan = First . nodeLocationSpan + + nameSpan :: Name -> First SourceSpan + nameSpan = First . nameSourceSpan addContractName :: Name -> ResolveM () addContractName n = @@ -1056,12 +1115,12 @@ addTyVar n = resolveQualifiedConstructorName :: Name -> Name -> ResolveM Name resolveQualifiedConstructorName qualifier conName = do - let qn = QualName qualifier (pretty conName) + let qn = qualifyName qualifier conName dt <- lookupName qn case dt of Just TDataCon -> pure qn _ -> - let fallback = QualName (constructorLeafName qualifier) (pretty conName) + let fallback = qualifyName (constructorLeafName qualifier) conName in do fdt <- lookupName fallback case fdt of @@ -1072,33 +1131,101 @@ resolveQualifiedConstructorName qualifier conName = undefinedTypeVariables :: [Name] -> ResolveM a undefinedTypeVariables ns = - throwError $ unlines ["Undefined type variables:", unwords (map pretty ns)] + diagnosticErrorWithLabels + "SC0102" + ("undefined type variables: " ++ unwords (map pretty ns)) + (mapMaybe (primaryNameLabel "undefined type variable") ns) + [] + [] undefinedTypeConstructor :: S.Ty -> ResolveM a undefinedTypeConstructor t = - throwError $ unlines ["Undefined type constructor:", pretty t] + diagnosticErrorAtName + "SC0103" + ("undefined type constructor: " ++ pretty t) + (S.tyName t) + "undefined type constructor" + [] + [] invalidTypeSynonymError :: S.TySym -> ResolveM a invalidTypeSynonymError t = - throwError $ unlines ["Invalid type synonym:", pretty t] + diagnosticErrorAtName + "SC0104" + ("invalid type synonym: " ++ pretty t) + (S.symName t) + "invalid type synonym" + [] + [] undefinedClassError :: Name -> ResolveM a undefinedClassError n = - throwError $ unlines ["Undefined class:", pretty n] + diagnosticErrorAtName + "SC0105" + ("undefined class: " ++ pretty n) + n + "undefined class" + [] + [] undefinedName :: Name -> ResolveM a undefinedName n = - throwError $ unwords ["Undefined name:", pretty n] + diagnosticErrorAtName + "SC0101" + ("undefined name: " ++ pretty n) + n + "unknown name" + [] + [] unqualifiedConstructorError :: Name -> ResolveM a unqualifiedConstructorError n = - throwError $ - unlines - [ "Unqualified constructor:", - pretty n, - "Use Type.Constructor form." - ] + diagnosticErrorAtName + "SC0106" + ("unqualified constructor: " ++ pretty n) + n + "constructor must be qualified" + [] + ["use Type.Constructor form"] invalidPatternSyntax :: S.Pat -> ResolveM a invalidPatternSyntax p = - throwError $ unwords ["Invalid pattern syntax:", pretty p] + diagnosticError + "SC0107" + ("invalid pattern syntax: " ++ pretty p) + [] + [] + +diagnosticError :: String -> String -> [String] -> [String] -> ResolveM a +diagnosticError code message notes help = + diagnosticErrorWithLabels code message [] notes help + +diagnosticErrorAtName :: String -> String -> Name -> String -> [String] -> [String] -> ResolveM a +diagnosticErrorAtName code message identName label notes help = + diagnosticErrorWithLabels code message (maybe [] pure (primaryNameLabel label identName)) notes help + +diagnosticErrorWithLabels :: String -> String -> [Label] -> [String] -> [String] -> ResolveM a +diagnosticErrorWithLabels code message labels notes help = + throwError $ diagnosticCompilerError $ diagnosticValue code message labels notes help + +diagnosticValue :: String -> String -> [Label] -> [String] -> [String] -> Diagnostic +diagnosticValue code message labels notes help = + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode code), + diagnosticMessage = message, + diagnosticLabels = labels, + diagnosticNotes = notes, + diagnosticHelp = help + } + +primaryNameLabel :: String -> Name -> Maybe Label +primaryNameLabel message identName = + do + sourceSpan <- nameSourceSpan identName + pure + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just message + } diff --git a/src/Solcore/Frontend/Syntax/Stmt.hs b/src/Solcore/Frontend/Syntax/Stmt.hs index d5a5c1911..eda3d48ee 100644 --- a/src/Solcore/Frontend/Syntax/Stmt.hs +++ b/src/Solcore/Frontend/Syntax/Stmt.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} + module Solcore.Frontend.Syntax.Stmt where import Data.Generics (Data, Typeable) import Language.Yul +import Solcore.Diagnostics (SourceSpan) +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Ty +import Prelude hiding (exp) -- definition of statements @@ -11,19 +16,99 @@ type Equation a = ([Pat a], [Stmt a]) type Equations a = [Equation a] data Stmt a - = (Exp a) := (Exp a) -- assignment - | Let a (Maybe Ty) (Maybe (Exp a)) -- local variable - | Block (Body a) -- lexical block - | StmtExp (Exp a) -- expression level statements - | Return (Exp a) -- return statements - | Match [Exp a] (Equations a) -- pattern matching - | Asm YulBlock -- Yul block - | If (Exp a) (Body a) (Body a) -- If statement - | For (Stmt a) (Exp a) (Stmt a) (Body a) -- for(init; cond; post) { body } + = AssignWithLocation NodeLocation (Exp a) (Exp a) -- assignment + | LetWithLocation NodeLocation a (Maybe Ty) (Maybe (Exp a)) -- local variable + | BlockWithLocation NodeLocation (Body a) -- lexical block + | StmtExpWithLocation NodeLocation (Exp a) -- expression level statements + | ReturnWithLocation NodeLocation (Exp a) -- return statements + | MatchWithLocation NodeLocation [Exp a] (Equations a) -- pattern matching + | AsmWithLocation NodeLocation YulBlock -- Yul block + | IfWithLocation NodeLocation (Exp a) (Body a) (Body a) -- If statement + | ForWithLocation NodeLocation (Stmt a) (Exp a) (Stmt a) (Body a) -- for(init; cond; post) { body } deriving (Eq, Ord, Show, Data, Typeable) +infix 4 := + +pattern (:=) :: Exp a -> Exp a -> Stmt a +pattern lhs := rhs <- AssignWithLocation _ lhs rhs + where + lhs := rhs = AssignWithLocation unlocatedNode lhs rhs + +pattern Let :: a -> Maybe Ty -> Maybe (Exp a) -> Stmt a +pattern Let n ty value <- LetWithLocation _ n ty value + where + Let n ty value = LetWithLocation unlocatedNode n ty value + +pattern Block :: Body a -> Stmt a +pattern Block body <- BlockWithLocation _ body + where + Block body = BlockWithLocation unlocatedNode body + +pattern StmtExp :: Exp a -> Stmt a +pattern StmtExp exp <- StmtExpWithLocation _ exp + where + StmtExp exp = StmtExpWithLocation unlocatedNode exp + +pattern Return :: Exp a -> Stmt a +pattern Return exp <- ReturnWithLocation _ exp + where + Return exp = ReturnWithLocation unlocatedNode exp + +pattern Match :: [Exp a] -> Equations a -> Stmt a +pattern Match exps equations <- MatchWithLocation _ exps equations + where + Match exps equations = MatchWithLocation unlocatedNode exps equations + +pattern Asm :: YulBlock -> Stmt a +pattern Asm block <- AsmWithLocation _ block + where + Asm block = AsmWithLocation unlocatedNode block + +pattern If :: Exp a -> Body a -> Body a -> Stmt a +pattern If cond thenBody elseBody <- IfWithLocation _ cond thenBody elseBody + where + If cond thenBody elseBody = IfWithLocation unlocatedNode cond thenBody elseBody + +pattern For :: Stmt a -> Exp a -> Stmt a -> Body a -> Stmt a +pattern For initStmt cond postStmt body <- ForWithLocation _ initStmt cond postStmt body + where + For initStmt cond postStmt body = ForWithLocation unlocatedNode initStmt cond postStmt body + +{-# COMPLETE (:=), Let, Block, StmtExp, Return, Match, Asm, If, For #-} + type Body a = [Stmt a] +locatedStmt :: SourceSpan -> Stmt a -> Stmt a +locatedStmt sourceSpan (lhs := rhs) = AssignWithLocation (locatedNode sourceSpan) lhs rhs +locatedStmt sourceSpan (Let n ty value) = LetWithLocation (locatedNode sourceSpan) n ty value +locatedStmt sourceSpan (Block body) = BlockWithLocation (locatedNode sourceSpan) body +locatedStmt sourceSpan (StmtExp exp) = StmtExpWithLocation (locatedNode sourceSpan) exp +locatedStmt sourceSpan (Return exp) = ReturnWithLocation (locatedNode sourceSpan) exp +locatedStmt sourceSpan (Match exps equations) = MatchWithLocation (locatedNode sourceSpan) exps equations +locatedStmt sourceSpan (Asm block) = AsmWithLocation (locatedNode sourceSpan) block +locatedStmt sourceSpan (If cond thenBody elseBody) = IfWithLocation (locatedNode sourceSpan) cond thenBody elseBody +locatedStmt sourceSpan (For initStmt cond postStmt body) = ForWithLocation (locatedNode sourceSpan) initStmt cond postStmt body + +instance (HasSourceSpan a) => HasSourceSpan (Stmt a) where + sourceSpanOf (AssignWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (LetWithLocation location n ty value) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ty, sourceSpanOf value] + sourceSpanOf (BlockWithLocation location body) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf body] + sourceSpanOf (StmtExpWithLocation location exp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] + sourceSpanOf (ReturnWithLocation location exp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] + sourceSpanOf (MatchWithLocation location exps equations) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exps, sourceSpanOf equations] + sourceSpanOf (AsmWithLocation location _) = + sourceSpanOf location + sourceSpanOf (IfWithLocation location cond thenBody elseBody) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf cond, sourceSpanOf thenBody, sourceSpanOf elseBody] + sourceSpanOf (ForWithLocation location initStmt cond postStmt body) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf initStmt, sourceSpanOf cond, sourceSpanOf postStmt, sourceSpanOf body] + data Param a = Typed a Ty | Untyped a @@ -33,29 +118,151 @@ paramName :: Param a -> a paramName (Typed n _) = n paramName (Untyped n) = n +instance (HasSourceSpan a) => HasSourceSpan (Param a) where + sourceSpanOf (Typed n ty) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf ty] + sourceSpanOf (Untyped n) = + sourceSpanOf n + -- definition of the expression syntax data Exp a - = Var a -- variable - | Con a [Exp a] -- data type constructor - | FieldAccess (Maybe (Exp a)) a -- field access - | Lit Literal -- literal - | Call (Maybe (Exp a)) a [Exp a] -- function call - | Lam [Param a] (Body a) (Maybe Ty) -- lambda-abstraction - | TyExp (Exp a) Ty -- type annotated expression - | Cond (Exp a) (Exp a) (Exp a) -- conditional expression - | Indexed (Exp a) (Exp a) -- e1[e2] + = VarWithLocation NodeLocation a -- variable + | ConWithLocation NodeLocation a [Exp a] -- data type constructor + | FieldAccessWithLocation NodeLocation (Maybe (Exp a)) a -- field access + | LitWithLocation NodeLocation Literal -- literal + | CallWithLocation NodeLocation (Maybe (Exp a)) a [Exp a] -- function call + | LamWithLocation NodeLocation [Param a] (Body a) (Maybe Ty) -- lambda-abstraction + | TyExpWithLocation NodeLocation (Exp a) Ty -- type annotated expression + | CondWithLocation NodeLocation (Exp a) (Exp a) (Exp a) -- conditional expression + | IndexedWithLocation NodeLocation (Exp a) (Exp a) -- e1[e2] deriving (Eq, Ord, Show, Data, Typeable) +pattern Var :: a -> Exp a +pattern Var n <- VarWithLocation _ n + where + Var n = VarWithLocation unlocatedNode n + +pattern Con :: a -> [Exp a] -> Exp a +pattern Con n es <- ConWithLocation _ n es + where + Con n es = ConWithLocation unlocatedNode n es + +pattern FieldAccess :: Maybe (Exp a) -> a -> Exp a +pattern FieldAccess me n <- FieldAccessWithLocation _ me n + where + FieldAccess me n = FieldAccessWithLocation unlocatedNode me n + +pattern Lit :: Literal -> Exp a +pattern Lit lit <- LitWithLocation _ lit + where + Lit lit = LitWithLocation unlocatedNode lit + +pattern Call :: Maybe (Exp a) -> a -> [Exp a] -> Exp a +pattern Call me n es <- CallWithLocation _ me n es + where + Call me n es = CallWithLocation unlocatedNode me n es + +pattern Lam :: [Param a] -> Body a -> Maybe Ty -> Exp a +pattern Lam ps body ty <- LamWithLocation _ ps body ty + where + Lam ps body ty = LamWithLocation unlocatedNode ps body ty + +pattern TyExp :: Exp a -> Ty -> Exp a +pattern TyExp exp ty <- TyExpWithLocation _ exp ty + where + TyExp exp ty = TyExpWithLocation unlocatedNode exp ty + +pattern Cond :: Exp a -> Exp a -> Exp a -> Exp a +pattern Cond cond thenExp elseExp <- CondWithLocation _ cond thenExp elseExp + where + Cond cond thenExp elseExp = CondWithLocation unlocatedNode cond thenExp elseExp + +pattern Indexed :: Exp a -> Exp a -> Exp a +pattern Indexed lhs rhs <- IndexedWithLocation _ lhs rhs + where + Indexed lhs rhs = IndexedWithLocation unlocatedNode lhs rhs + +{-# COMPLETE Var, Con, FieldAccess, Lit, Call, Lam, TyExp, Cond, Indexed #-} + +locatedExp :: SourceSpan -> Exp a -> Exp a +locatedExp sourceSpan (Var n) = VarWithLocation (locatedNode sourceSpan) n +locatedExp sourceSpan (Con n es) = ConWithLocation (locatedNode sourceSpan) n es +locatedExp sourceSpan (FieldAccess me n) = FieldAccessWithLocation (locatedNode sourceSpan) me n +locatedExp sourceSpan (Lit lit) = LitWithLocation (locatedNode sourceSpan) lit +locatedExp sourceSpan (Call me n es) = CallWithLocation (locatedNode sourceSpan) me n es +locatedExp sourceSpan (Lam ps body ty) = LamWithLocation (locatedNode sourceSpan) ps body ty +locatedExp sourceSpan (TyExp exp ty) = TyExpWithLocation (locatedNode sourceSpan) exp ty +locatedExp sourceSpan (Cond cond thenExp elseExp) = CondWithLocation (locatedNode sourceSpan) cond thenExp elseExp +locatedExp sourceSpan (Indexed lhs rhs) = IndexedWithLocation (locatedNode sourceSpan) lhs rhs + +instance (HasSourceSpan a) => HasSourceSpan (Exp a) where + sourceSpanOf (VarWithLocation location n) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n] + sourceSpanOf (ConWithLocation location n es) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf es] + sourceSpanOf (FieldAccessWithLocation location me n) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf me, sourceSpanOf n] + sourceSpanOf (LitWithLocation location _) = + sourceSpanOf location + sourceSpanOf (CallWithLocation location me n es) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf me, sourceSpanOf n, sourceSpanOf es] + sourceSpanOf (LamWithLocation location ps body ty) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf ps, sourceSpanOf body, sourceSpanOf ty] + sourceSpanOf (TyExpWithLocation location exp ty) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp, sourceSpanOf ty] + sourceSpanOf (CondWithLocation location cond thenExp elseExp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf cond, sourceSpanOf thenExp, sourceSpanOf elseExp] + sourceSpanOf (IndexedWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + -- pattern matching equations data Pat a - = PVar a - | PCon a [Pat a] - | PWildcard - | PLit Literal + = PVarWithLocation NodeLocation a + | PConWithLocation NodeLocation a [Pat a] + | PWildcardWithLocation NodeLocation + | PLitWithLocation NodeLocation Literal deriving (Eq, Ord, Show, Data, Typeable) +pattern PVar :: a -> Pat a +pattern PVar n <- PVarWithLocation _ n + where + PVar n = PVarWithLocation unlocatedNode n + +pattern PCon :: a -> [Pat a] -> Pat a +pattern PCon n ps <- PConWithLocation _ n ps + where + PCon n ps = PConWithLocation unlocatedNode n ps + +pattern PWildcard :: Pat a +pattern PWildcard <- PWildcardWithLocation _ + where + PWildcard = PWildcardWithLocation unlocatedNode + +pattern PLit :: Literal -> Pat a +pattern PLit lit <- PLitWithLocation _ lit + where + PLit lit = PLitWithLocation unlocatedNode lit + +{-# COMPLETE PVar, PCon, PWildcard, PLit #-} + +locatedPat :: SourceSpan -> Pat a -> Pat a +locatedPat sourceSpan (PVar n) = PVarWithLocation (locatedNode sourceSpan) n +locatedPat sourceSpan (PCon n ps) = PConWithLocation (locatedNode sourceSpan) n ps +locatedPat sourceSpan PWildcard = PWildcardWithLocation (locatedNode sourceSpan) +locatedPat sourceSpan (PLit lit) = PLitWithLocation (locatedNode sourceSpan) lit + +instance (HasSourceSpan a) => HasSourceSpan (Pat a) where + sourceSpanOf (PVarWithLocation location n) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n] + sourceSpanOf (PConWithLocation location n ps) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ps] + sourceSpanOf (PWildcardWithLocation location) = + sourceSpanOf location + sourceSpanOf (PLitWithLocation location _) = + sourceSpanOf location + -- definition of literals data Literal diff --git a/src/Solcore/Frontend/Syntax/SyntaxTree.hs b/src/Solcore/Frontend/Syntax/SyntaxTree.hs index 3104d6dce..8d0d7923b 100644 --- a/src/Solcore/Frontend/Syntax/SyntaxTree.hs +++ b/src/Solcore/Frontend/Syntax/SyntaxTree.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE PatternSynonyms #-} + module Solcore.Frontend.Syntax.SyntaxTree where import Data.Generics (Data, Typeable) import Data.List (union) import Data.List.NonEmpty import Language.Yul +import Solcore.Diagnostics (SourceSpan) +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name +import Prelude hiding (exp) -- compilation unit @@ -127,15 +132,30 @@ data Constr -- type definition data Ty - = TyCon Name [Ty] -- type constructor + = TyConWithLocation NodeLocation Name [Ty] -- type constructor deriving (Eq, Ord, Show, Data, Typeable) +pattern TyCon :: Name -> [Ty] -> Ty +pattern TyCon n ts <- TyConWithLocation _ n ts + where + TyCon n ts = TyConWithLocation unlocatedNode n ts + +{-# COMPLETE TyCon #-} + pattern (:->) :: Ty -> Ty -> Ty pattern (:->) t1 t2 = TyCon (Name "->") [t1, t2] tyName :: Ty -> Name tyName (TyCon n _) = n +locatedTy :: SourceSpan -> Ty -> Ty +locatedTy sourceSpan (TyCon n ts) = + TyConWithLocation (locatedNode sourceSpan) n ts + +instance HasSourceSpan Ty where + sourceSpanOf (TyConWithLocation location n ts) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ts] + data Pred = InCls { predName :: Name, predMain :: Ty, @@ -143,6 +163,10 @@ data Pred = InCls } deriving (Eq, Ord, Show, Data, Typeable) +instance HasSourceSpan Pred where + sourceSpanOf (InCls n t ts) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf t, sourceSpanOf ts] + tysFrom :: [Pred] -> [Ty] tysFrom = foldr go [] where @@ -228,6 +252,123 @@ data ContractDecl | CConstrDecl Constructor deriving (Eq, Ord, Show, Data, Typeable) +instance HasSourceSpan CompUnit where + sourceSpanOf (CompUnit imps ds) = + firstSourceSpan [sourceSpanOf imps, sourceSpanOf ds] + +instance HasSourceSpan TopDecl where + sourceSpanOf (TContr contractDef) = sourceSpanOf contractDef + sourceSpanOf (TFunDef funDef) = sourceSpanOf funDef + sourceSpanOf (TClassDef cls) = sourceSpanOf cls + sourceSpanOf (TInstDef inst) = sourceSpanOf inst + sourceSpanOf (TDataDef dataTy) = sourceSpanOf dataTy + sourceSpanOf (TSym tySym) = sourceSpanOf tySym + sourceSpanOf (TExportDecl exportDecl) = sourceSpanOf exportDecl + sourceSpanOf (TPragmaDecl pragma) = sourceSpanOf pragma + +instance HasSourceSpan Pragma where + sourceSpanOf (Pragma _ status) = sourceSpanOf status + +instance HasSourceSpan PragmaStatus where + sourceSpanOf Enabled = Nothing + sourceSpanOf DisableAll = Nothing + sourceSpanOf (DisableFor names) = sourceSpanOf (toList names) + +instance HasSourceSpan ModulePath where + sourceSpanOf (RelativePath n) = sourceSpanOf n + sourceSpanOf (LibraryPath n) = sourceSpanOf n + sourceSpanOf (ExternalPath libName modName) = + combineMaybeSourceSpans (sourceSpanOf libName) (sourceSpanOf modName) + +instance HasSourceSpan Export where + sourceSpanOf (ExportList specs) = sourceSpanOf specs + sourceSpanOf (ExportModule modulePath) = sourceSpanOf modulePath + sourceSpanOf (ExportModuleAs modulePath aliasName) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf aliasName] + sourceSpanOf (ExportItemsFrom modulePath selector) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf selector] + +instance HasSourceSpan ExportSpec where + sourceSpanOf (ExportName n) = sourceSpanOf n + sourceSpanOf (ExportNameWithConstructors typeName selector) = + firstSourceSpan [sourceSpanOf typeName, sourceSpanOf selector] + sourceSpanOf ExportAll = Nothing + sourceSpanOf (ExportModuleAll modulePath) = sourceSpanOf modulePath + +instance HasSourceSpan ConstructorSelector where + sourceSpanOf (SelectConstructors names) = sourceSpanOf names + sourceSpanOf SelectAllConstructors = Nothing + +instance HasSourceSpan ExportSelector where + sourceSpanOf (SelectExportItems items) = sourceSpanOf items + +instance HasSourceSpan ExportSelectorEntry where + sourceSpanOf SelectExportAllItems = Nothing + sourceSpanOf (SelectExportItem n) = sourceSpanOf n + sourceSpanOf (SelectExportConstructors typeName selector) = + firstSourceSpan [sourceSpanOf typeName, sourceSpanOf selector] + +instance HasSourceSpan Import where + sourceSpanOf (ImportModule modulePath) = sourceSpanOf modulePath + sourceSpanOf (ImportAlias modulePath aliasName) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf aliasName] + sourceSpanOf (ImportOnly modulePath items) = + firstSourceSpan [sourceSpanOf modulePath, sourceSpanOf items] + +instance HasSourceSpan ItemSelector where + sourceSpanOf (SelectItems items hidden) = + firstSourceSpan [sourceSpanOf items, sourceSpanOf hidden] + +instance HasSourceSpan ItemSelectorEntry where + sourceSpanOf SelectAllItems = Nothing + sourceSpanOf (SelectItem n) = sourceSpanOf n + +instance HasSourceSpan Contract where + sourceSpanOf (Contract n tyParams' contractDecls) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyParams', sourceSpanOf contractDecls] + +instance HasSourceSpan DataTy where + sourceSpanOf (DataTy n tyParams' constrs) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyParams', sourceSpanOf constrs] + +instance HasSourceSpan Constr where + sourceSpanOf (Constr n tys) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tys] + +instance HasSourceSpan TySym where + sourceSpanOf (TySym n tyParams' ty) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf tyParams', sourceSpanOf ty] + +instance HasSourceSpan Constructor where + sourceSpanOf (Constructor params body) = + firstSourceSpan [sourceSpanOf params, sourceSpanOf body] + +instance HasSourceSpan Class where + sourceSpanOf (Class boundVars context clsName params main signatures') = + firstSourceSpan [sourceSpanOf boundVars, sourceSpanOf context, sourceSpanOf clsName, sourceSpanOf params, sourceSpanOf main, sourceSpanOf signatures'] + +instance HasSourceSpan Signature where + sourceSpanOf (Signature vars context sig params retTy) = + firstSourceSpan [sourceSpanOf vars, sourceSpanOf context, sourceSpanOf sig, sourceSpanOf params, sourceSpanOf retTy] + +instance HasSourceSpan Instance where + sourceSpanOf (Instance _ vars context clsName params main funs) = + firstSourceSpan [sourceSpanOf vars, sourceSpanOf context, sourceSpanOf clsName, sourceSpanOf params, sourceSpanOf main, sourceSpanOf funs] + +instance HasSourceSpan Field where + sourceSpanOf (Field n ty initExp) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf ty, sourceSpanOf initExp] + +instance HasSourceSpan FunDef where + sourceSpanOf (FunDef sig body) = + firstSourceSpan [sourceSpanOf sig, sourceSpanOf body] + +instance HasSourceSpan ContractDecl where + sourceSpanOf (CDataDecl dataTy) = sourceSpanOf dataTy + sourceSpanOf (CFieldDecl field) = sourceSpanOf field + sourceSpanOf (CFunDecl funDef) = sourceSpanOf funDef + sourceSpanOf (CConstrDecl constructor) = sourceSpanOf constructor + -- definition of statements type Equation = ([Pat], [Stmt]) @@ -235,63 +376,398 @@ type Equation = ([Pat], [Stmt]) type Equations = [Equation] data Stmt - = Assign Exp Exp -- assignment - | StmtPlusEq Exp Exp -- e1 += e2 - | StmtMinusEq Exp Exp -- e1 -= e2 - | Let Name (Maybe Ty) (Maybe Exp) -- local variable - | Block Body -- lexical block - | StmtExp Exp -- expression level statements - | Return Exp -- return statements - | Match [Exp] Equations -- pattern matching - | Asm YulBlock -- Yul block - | If Exp Body Body -- If statement - | For Stmt Exp Stmt Body -- for(init; cond; post) { body } - deriving (Eq, Ord, Show, Data, Typeable) + = AssignWithLocation NodeLocation Exp Exp -- assignment + | StmtPlusEqWithLocation NodeLocation Exp Exp -- e1 += e2 + | StmtMinusEqWithLocation NodeLocation Exp Exp -- e1 -= e2 + | LetWithLocation NodeLocation Name (Maybe Ty) (Maybe Exp) -- local variable + | BlockWithLocation NodeLocation Body -- lexical block + | StmtExpWithLocation NodeLocation Exp -- expression level statements + | ReturnWithLocation NodeLocation Exp -- return statements + | MatchWithLocation NodeLocation [Exp] Equations -- pattern matching + | AsmWithLocation NodeLocation YulBlock -- Yul block + | IfWithLocation NodeLocation Exp Body Body -- If statement + | ForWithLocation NodeLocation Stmt Exp Stmt Body -- for(init; cond; post) { body } + deriving (Eq, Ord, Show, Data, Typeable) + +pattern Assign :: Exp -> Exp -> Stmt +pattern Assign lhs rhs <- AssignWithLocation _ lhs rhs + where + Assign lhs rhs = AssignWithLocation unlocatedNode lhs rhs + +pattern StmtPlusEq :: Exp -> Exp -> Stmt +pattern StmtPlusEq lhs rhs <- StmtPlusEqWithLocation _ lhs rhs + where + StmtPlusEq lhs rhs = StmtPlusEqWithLocation unlocatedNode lhs rhs + +pattern StmtMinusEq :: Exp -> Exp -> Stmt +pattern StmtMinusEq lhs rhs <- StmtMinusEqWithLocation _ lhs rhs + where + StmtMinusEq lhs rhs = StmtMinusEqWithLocation unlocatedNode lhs rhs + +pattern Let :: Name -> Maybe Ty -> Maybe Exp -> Stmt +pattern Let n ty value <- LetWithLocation _ n ty value + where + Let n ty value = LetWithLocation unlocatedNode n ty value + +pattern Block :: Body -> Stmt +pattern Block body <- BlockWithLocation _ body + where + Block body = BlockWithLocation unlocatedNode body + +pattern StmtExp :: Exp -> Stmt +pattern StmtExp exp <- StmtExpWithLocation _ exp + where + StmtExp exp = StmtExpWithLocation unlocatedNode exp + +pattern Return :: Exp -> Stmt +pattern Return exp <- ReturnWithLocation _ exp + where + Return exp = ReturnWithLocation unlocatedNode exp + +pattern Match :: [Exp] -> Equations -> Stmt +pattern Match exps equations <- MatchWithLocation _ exps equations + where + Match exps equations = MatchWithLocation unlocatedNode exps equations + +pattern Asm :: YulBlock -> Stmt +pattern Asm block <- AsmWithLocation _ block + where + Asm block = AsmWithLocation unlocatedNode block + +pattern If :: Exp -> Body -> Body -> Stmt +pattern If cond thenBody elseBody <- IfWithLocation _ cond thenBody elseBody + where + If cond thenBody elseBody = IfWithLocation unlocatedNode cond thenBody elseBody + +pattern For :: Stmt -> Exp -> Stmt -> Body -> Stmt +pattern For initStmt cond postStmt body <- ForWithLocation _ initStmt cond postStmt body + where + For initStmt cond postStmt body = ForWithLocation unlocatedNode initStmt cond postStmt body + +{-# COMPLETE Assign, StmtPlusEq, StmtMinusEq, Let, Block, StmtExp, Return, Match, Asm, If, For #-} type Body = [Stmt] +locatedStmt :: SourceSpan -> Stmt -> Stmt +locatedStmt sourceSpan (Assign lhs rhs) = AssignWithLocation location lhs rhs + where + location = locatedNode sourceSpan +locatedStmt sourceSpan (StmtPlusEq lhs rhs) = StmtPlusEqWithLocation location lhs rhs + where + location = locatedNode sourceSpan +locatedStmt sourceSpan (StmtMinusEq lhs rhs) = StmtMinusEqWithLocation location lhs rhs + where + location = locatedNode sourceSpan +locatedStmt sourceSpan (Let n ty value) = LetWithLocation location n ty value + where + location = locatedNode sourceSpan +locatedStmt sourceSpan (Block body) = BlockWithLocation (locatedNode sourceSpan) body +locatedStmt sourceSpan (StmtExp exp) = StmtExpWithLocation (locatedNode sourceSpan) exp +locatedStmt sourceSpan (Return exp) = ReturnWithLocation (locatedNode sourceSpan) exp +locatedStmt sourceSpan (Match exps equations) = MatchWithLocation (locatedNode sourceSpan) exps equations +locatedStmt sourceSpan (Asm block) = AsmWithLocation (locatedNode sourceSpan) block +locatedStmt sourceSpan (If cond thenBody elseBody) = IfWithLocation (locatedNode sourceSpan) cond thenBody elseBody +locatedStmt sourceSpan (For initStmt cond postStmt body) = ForWithLocation (locatedNode sourceSpan) initStmt cond postStmt body + +instance HasSourceSpan Stmt where + sourceSpanOf (AssignWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (StmtPlusEqWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (StmtMinusEqWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (LetWithLocation location n ty value) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ty, sourceSpanOf value] + sourceSpanOf (BlockWithLocation location body) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf body] + sourceSpanOf (StmtExpWithLocation location exp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] + sourceSpanOf (ReturnWithLocation location exp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] + sourceSpanOf (MatchWithLocation location exps equations) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exps, sourceSpanOf equations] + sourceSpanOf (AsmWithLocation location _) = + sourceSpanOf location + sourceSpanOf (IfWithLocation location cond thenBody elseBody) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf cond, sourceSpanOf thenBody, sourceSpanOf elseBody] + sourceSpanOf (ForWithLocation location initStmt cond postStmt body) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf initStmt, sourceSpanOf cond, sourceSpanOf postStmt, sourceSpanOf body] + data Param = Typed Name Ty | Untyped Name deriving (Eq, Ord, Show, Data, Typeable) +instance HasSourceSpan Param where + sourceSpanOf (Typed n ty) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf ty] + sourceSpanOf (Untyped n) = + sourceSpanOf n + -- expression syntax data Exp - = Lit Literal -- literal - | ExpName (Maybe Exp) Name [Exp] -- function call or constructor - | ExpVar (Maybe Exp) Name -- variables or field access - | ExpDotName Name [Exp] -- contextual constructor shorthand, e.g. .Some(1), .None - | Lam [Param] Body (Maybe Ty) -- lambda-abstraction - | TyExp Exp Ty -- type annotation expression - | ExpIndexed Exp Exp -- e1[e2] - | ExpPlus Exp Exp -- e1 + e2 - | ExpMinus Exp Exp -- e1 - e2 - | ExpTimes Exp Exp -- e1 * e2 - | ExpDivide Exp Exp -- e1 / e2 - | ExpModulo Exp Exp -- e1 % e2 - | ExpLT Exp Exp -- e1 < e2 - | ExpGT Exp Exp -- e1 > e2 - | ExpLE Exp Exp -- e1 <= e2 - | ExpGE Exp Exp -- e1 >= e2 - | ExpEE Exp Exp -- e1 == e2 - | ExpNE Exp Exp -- e1 != e2 - | ExpLAnd Exp Exp -- e1 && e2 - | ExpLOr Exp Exp -- e1 || e2 - | ExpLNot Exp -- ! e - | ExpCond Exp Exp Exp -- if e1 then e2 else e3 - | ExpAt Ty -- proxy sugar - deriving (Eq, Ord, Show, Data, Typeable) + = LitWithLocation NodeLocation Literal -- literal + | ExpNameWithLocation NodeLocation (Maybe Exp) Name [Exp] -- function call or constructor + | ExpVarWithLocation NodeLocation (Maybe Exp) Name -- variables or field access + | ExpDotNameWithLocation NodeLocation Name [Exp] -- contextual constructor shorthand, e.g. .Some(1), .None + | LamWithLocation NodeLocation [Param] Body (Maybe Ty) -- lambda-abstraction + | TyExpWithLocation NodeLocation Exp Ty -- type annotation expression + | ExpIndexedWithLocation NodeLocation Exp Exp -- e1[e2] + | ExpPlusWithLocation NodeLocation Exp Exp -- e1 + e2 + | ExpMinusWithLocation NodeLocation Exp Exp -- e1 - e2 + | ExpTimesWithLocation NodeLocation Exp Exp -- e1 * e2 + | ExpDivideWithLocation NodeLocation Exp Exp -- e1 / e2 + | ExpModuloWithLocation NodeLocation Exp Exp -- e1 % e2 + | ExpLTWithLocation NodeLocation Exp Exp -- e1 < e2 + | ExpGTWithLocation NodeLocation Exp Exp -- e1 > e2 + | ExpLEWithLocation NodeLocation Exp Exp -- e1 <= e2 + | ExpGEWithLocation NodeLocation Exp Exp -- e1 >= e2 + | ExpEEWithLocation NodeLocation Exp Exp -- e1 == e2 + | ExpNEWithLocation NodeLocation Exp Exp -- e1 != e2 + | ExpLAndWithLocation NodeLocation Exp Exp -- e1 && e2 + | ExpLOrWithLocation NodeLocation Exp Exp -- e1 || e2 + | ExpLNotWithLocation NodeLocation Exp -- ! e + | ExpCondWithLocation NodeLocation Exp Exp Exp -- if e1 then e2 else e3 + | ExpAtWithLocation NodeLocation Ty -- proxy sugar + deriving (Eq, Ord, Show, Data, Typeable) + +pattern Lit :: Literal -> Exp +pattern Lit lit <- LitWithLocation _ lit + where + Lit lit = LitWithLocation unlocatedNode lit + +pattern ExpName :: Maybe Exp -> Name -> [Exp] -> Exp +pattern ExpName me n es <- ExpNameWithLocation _ me n es + where + ExpName me n es = ExpNameWithLocation unlocatedNode me n es + +pattern ExpVar :: Maybe Exp -> Name -> Exp +pattern ExpVar me n <- ExpVarWithLocation _ me n + where + ExpVar me n = ExpVarWithLocation unlocatedNode me n + +pattern ExpDotName :: Name -> [Exp] -> Exp +pattern ExpDotName n es <- ExpDotNameWithLocation _ n es + where + ExpDotName n es = ExpDotNameWithLocation unlocatedNode n es + +pattern Lam :: [Param] -> Body -> Maybe Ty -> Exp +pattern Lam ps body ty <- LamWithLocation _ ps body ty + where + Lam ps body ty = LamWithLocation unlocatedNode ps body ty + +pattern TyExp :: Exp -> Ty -> Exp +pattern TyExp exp ty <- TyExpWithLocation _ exp ty + where + TyExp exp ty = TyExpWithLocation unlocatedNode exp ty + +pattern ExpIndexed :: Exp -> Exp -> Exp +pattern ExpIndexed lhs rhs <- ExpIndexedWithLocation _ lhs rhs + where + ExpIndexed lhs rhs = ExpIndexedWithLocation unlocatedNode lhs rhs + +pattern ExpPlus :: Exp -> Exp -> Exp +pattern ExpPlus lhs rhs <- ExpPlusWithLocation _ lhs rhs + where + ExpPlus lhs rhs = ExpPlusWithLocation unlocatedNode lhs rhs + +pattern ExpMinus :: Exp -> Exp -> Exp +pattern ExpMinus lhs rhs <- ExpMinusWithLocation _ lhs rhs + where + ExpMinus lhs rhs = ExpMinusWithLocation unlocatedNode lhs rhs + +pattern ExpTimes :: Exp -> Exp -> Exp +pattern ExpTimes lhs rhs <- ExpTimesWithLocation _ lhs rhs + where + ExpTimes lhs rhs = ExpTimesWithLocation unlocatedNode lhs rhs + +pattern ExpDivide :: Exp -> Exp -> Exp +pattern ExpDivide lhs rhs <- ExpDivideWithLocation _ lhs rhs + where + ExpDivide lhs rhs = ExpDivideWithLocation unlocatedNode lhs rhs + +pattern ExpModulo :: Exp -> Exp -> Exp +pattern ExpModulo lhs rhs <- ExpModuloWithLocation _ lhs rhs + where + ExpModulo lhs rhs = ExpModuloWithLocation unlocatedNode lhs rhs + +pattern ExpLT :: Exp -> Exp -> Exp +pattern ExpLT lhs rhs <- ExpLTWithLocation _ lhs rhs + where + ExpLT lhs rhs = ExpLTWithLocation unlocatedNode lhs rhs + +pattern ExpGT :: Exp -> Exp -> Exp +pattern ExpGT lhs rhs <- ExpGTWithLocation _ lhs rhs + where + ExpGT lhs rhs = ExpGTWithLocation unlocatedNode lhs rhs + +pattern ExpLE :: Exp -> Exp -> Exp +pattern ExpLE lhs rhs <- ExpLEWithLocation _ lhs rhs + where + ExpLE lhs rhs = ExpLEWithLocation unlocatedNode lhs rhs + +pattern ExpGE :: Exp -> Exp -> Exp +pattern ExpGE lhs rhs <- ExpGEWithLocation _ lhs rhs + where + ExpGE lhs rhs = ExpGEWithLocation unlocatedNode lhs rhs + +pattern ExpEE :: Exp -> Exp -> Exp +pattern ExpEE lhs rhs <- ExpEEWithLocation _ lhs rhs + where + ExpEE lhs rhs = ExpEEWithLocation unlocatedNode lhs rhs + +pattern ExpNE :: Exp -> Exp -> Exp +pattern ExpNE lhs rhs <- ExpNEWithLocation _ lhs rhs + where + ExpNE lhs rhs = ExpNEWithLocation unlocatedNode lhs rhs + +pattern ExpLAnd :: Exp -> Exp -> Exp +pattern ExpLAnd lhs rhs <- ExpLAndWithLocation _ lhs rhs + where + ExpLAnd lhs rhs = ExpLAndWithLocation unlocatedNode lhs rhs + +pattern ExpLOr :: Exp -> Exp -> Exp +pattern ExpLOr lhs rhs <- ExpLOrWithLocation _ lhs rhs + where + ExpLOr lhs rhs = ExpLOrWithLocation unlocatedNode lhs rhs + +pattern ExpLNot :: Exp -> Exp +pattern ExpLNot exp <- ExpLNotWithLocation _ exp + where + ExpLNot exp = ExpLNotWithLocation unlocatedNode exp + +pattern ExpCond :: Exp -> Exp -> Exp -> Exp +pattern ExpCond cond thenExp elseExp <- ExpCondWithLocation _ cond thenExp elseExp + where + ExpCond cond thenExp elseExp = ExpCondWithLocation unlocatedNode cond thenExp elseExp + +pattern ExpAt :: Ty -> Exp +pattern ExpAt ty <- ExpAtWithLocation _ ty + where + ExpAt ty = ExpAtWithLocation unlocatedNode ty + +{-# COMPLETE Lit, ExpName, ExpVar, ExpDotName, Lam, TyExp, ExpIndexed, ExpPlus, ExpMinus, ExpTimes, ExpDivide, ExpModulo, ExpLT, ExpGT, ExpLE, ExpGE, ExpEE, ExpNE, ExpLAnd, ExpLOr, ExpLNot, ExpCond, ExpAt #-} + +locatedExp :: SourceSpan -> Exp -> Exp +locatedExp sourceSpan (Lit lit) = LitWithLocation location lit + where + location = locatedNode sourceSpan +locatedExp sourceSpan (ExpName me n es) = ExpNameWithLocation (locatedNode sourceSpan) me n es +locatedExp sourceSpan (ExpVar me n) = ExpVarWithLocation (locatedNode sourceSpan) me n +locatedExp sourceSpan (ExpDotName n es) = ExpDotNameWithLocation (locatedNode sourceSpan) n es +locatedExp sourceSpan (Lam ps body ty) = LamWithLocation (locatedNode sourceSpan) ps body ty +locatedExp sourceSpan (TyExp exp ty) = TyExpWithLocation (locatedNode sourceSpan) exp ty +locatedExp sourceSpan (ExpIndexed lhs rhs) = ExpIndexedWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpPlus lhs rhs) = ExpPlusWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpMinus lhs rhs) = ExpMinusWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpTimes lhs rhs) = ExpTimesWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpDivide lhs rhs) = ExpDivideWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpModulo lhs rhs) = ExpModuloWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpLT lhs rhs) = ExpLTWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpGT lhs rhs) = ExpGTWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpLE lhs rhs) = ExpLEWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpGE lhs rhs) = ExpGEWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpEE lhs rhs) = ExpEEWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpNE lhs rhs) = ExpNEWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpLAnd lhs rhs) = ExpLAndWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpLOr lhs rhs) = ExpLOrWithLocation (locatedNode sourceSpan) lhs rhs +locatedExp sourceSpan (ExpLNot exp) = ExpLNotWithLocation (locatedNode sourceSpan) exp +locatedExp sourceSpan (ExpCond cond thenExp elseExp) = ExpCondWithLocation (locatedNode sourceSpan) cond thenExp elseExp +locatedExp sourceSpan (ExpAt ty) = ExpAtWithLocation (locatedNode sourceSpan) ty + +instance HasSourceSpan Exp where + sourceSpanOf (LitWithLocation location _) = sourceSpanOf location + sourceSpanOf (ExpNameWithLocation location me n es) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf me, sourceSpanOf n, sourceSpanOf es] + sourceSpanOf (ExpVarWithLocation location me n) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf me, sourceSpanOf n] + sourceSpanOf (ExpDotNameWithLocation location n es) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf es] + sourceSpanOf (LamWithLocation location ps body ty) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf ps, sourceSpanOf body, sourceSpanOf ty] + sourceSpanOf (TyExpWithLocation location exp ty) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp, sourceSpanOf ty] + sourceSpanOf (ExpIndexedWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpPlusWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpMinusWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpTimesWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpDivideWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpModuloWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpLTWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpGTWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpLEWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpGEWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpEEWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpNEWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpLAndWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpLOrWithLocation location lhs rhs) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf lhs, sourceSpanOf rhs] + sourceSpanOf (ExpLNotWithLocation location exp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf exp] + sourceSpanOf (ExpCondWithLocation location cond thenExp elseExp) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf cond, sourceSpanOf thenExp, sourceSpanOf elseExp] + sourceSpanOf (ExpAtWithLocation location ty) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf ty] -- pattern matching equations data Pat - = Pat Name [Pat] - | PatDot Name [Pat] - | PWildcard - | PLit Literal + = PatWithLocation NodeLocation Name [Pat] + | PatDotWithLocation NodeLocation Name [Pat] + | PWildcardWithLocation NodeLocation + | PLitWithLocation NodeLocation Literal deriving (Eq, Ord, Show, Data, Typeable) +pattern Pat :: Name -> [Pat] -> Pat +pattern Pat n ps <- PatWithLocation _ n ps + where + Pat n ps = PatWithLocation unlocatedNode n ps + +pattern PatDot :: Name -> [Pat] -> Pat +pattern PatDot n ps <- PatDotWithLocation _ n ps + where + PatDot n ps = PatDotWithLocation unlocatedNode n ps + +pattern PWildcard :: Pat +pattern PWildcard <- PWildcardWithLocation _ + where + PWildcard = PWildcardWithLocation unlocatedNode + +pattern PLit :: Literal -> Pat +pattern PLit lit <- PLitWithLocation _ lit + where + PLit lit = PLitWithLocation unlocatedNode lit + +{-# COMPLETE Pat, PatDot, PWildcard, PLit #-} + +locatedPat :: SourceSpan -> Pat -> Pat +locatedPat sourceSpan (Pat n ps) = PatWithLocation (locatedNode sourceSpan) n ps +locatedPat sourceSpan (PatDot n ps) = PatDotWithLocation (locatedNode sourceSpan) n ps +locatedPat sourceSpan PWildcard = PWildcardWithLocation (locatedNode sourceSpan) +locatedPat sourceSpan (PLit lit) = PLitWithLocation (locatedNode sourceSpan) lit + +instance HasSourceSpan Pat where + sourceSpanOf (PatWithLocation location n ps) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ps] + sourceSpanOf (PatDotWithLocation location n ps) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ps] + sourceSpanOf (PWildcardWithLocation location) = sourceSpanOf location + sourceSpanOf (PLitWithLocation location _) = sourceSpanOf location + -- definition of literals data Literal diff --git a/src/Solcore/Frontend/Syntax/Ty.hs b/src/Solcore/Frontend/Syntax/Ty.hs index c1ccbd088..a8b2beb57 100644 --- a/src/Solcore/Frontend/Syntax/Ty.hs +++ b/src/Solcore/Frontend/Syntax/Ty.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} + module Solcore.Frontend.Syntax.Ty where import Data.Generics (Data, Typeable) import Data.List +import Solcore.Diagnostics (SourceSpan) +import Solcore.Frontend.Syntax.Location import Solcore.Frontend.Syntax.Name -- basic typing infrastructure @@ -21,14 +25,37 @@ isBound _ = False data Ty = TyVar Tyvar -- type variable - | TyCon Name [Ty] -- type constructor + | TyConWithLocation NodeLocation Name [Ty] -- type constructor | Meta MetaTv -- meta type variable deriving (Eq, Ord, Show, Data, Typeable) +pattern TyCon :: Name -> [Ty] -> Ty +pattern TyCon n ts <- TyConWithLocation _ n ts + where + TyCon n ts = TyConWithLocation unlocatedNode n ts + +{-# COMPLETE TyVar, TyCon, Meta #-} + newtype MetaTv = MetaTv {metaName :: Name} deriving (Eq, Ord, Show, Data, Typeable) +locatedTy :: SourceSpan -> Ty -> Ty +locatedTy sourceSpan (TyCon n ts) = TyConWithLocation (locatedNode sourceSpan) n ts +locatedTy _ ty = ty + +instance HasSourceSpan Tyvar where + sourceSpanOf = sourceSpanOf . tyvarName + +instance HasSourceSpan MetaTv where + sourceSpanOf = sourceSpanOf . metaName + +instance HasSourceSpan Ty where + sourceSpanOf (TyVar tyvar) = sourceSpanOf tyvar + sourceSpanOf (TyConWithLocation location n ts) = + firstSourceSpan [sourceSpanOf location, sourceSpanOf n, sourceSpanOf ts] + sourceSpanOf (Meta metaTv) = sourceSpanOf metaTv + tyconNames :: Ty -> [Name] tyconNames (TyCon n ts) = nub (n : concatMap tyconNames ts) @@ -110,12 +137,22 @@ data Pred | Ty :~: Ty deriving (Eq, Ord, Show, Data, Typeable) +instance HasSourceSpan Pred where + sourceSpanOf (InCls n t ts) = + firstSourceSpan [sourceSpanOf n, sourceSpanOf t, sourceSpanOf ts] + sourceSpanOf (left :~: right) = + firstSourceSpan [sourceSpanOf left, sourceSpanOf right] + -- qualified types data Qual t = [Pred] :=> t deriving (Eq, Ord, Show, Data, Typeable) +instance (HasSourceSpan t) => HasSourceSpan (Qual t) where + sourceSpanOf (preds :=> t) = + firstSourceSpan [sourceSpanOf preds, sourceSpanOf t] + infix 2 :=> -- type schemes @@ -124,6 +161,10 @@ data Scheme = Forall [Tyvar] (Qual Ty) deriving (Eq, Ord, Show, Data, Typeable) +instance HasSourceSpan Scheme where + sourceSpanOf (Forall tyvars qualTy) = + firstSourceSpan [sourceSpanOf tyvars, sourceSpanOf qualTy] + monotype :: Ty -> Scheme monotype t = Forall [] ([] :=> t) diff --git a/src/Solcore/Frontend/TypeInference/Id.hs b/src/Solcore/Frontend/TypeInference/Id.hs index 380477092..4fdb64a60 100644 --- a/src/Solcore/Frontend/TypeInference/Id.hs +++ b/src/Solcore/Frontend/TypeInference/Id.hs @@ -18,3 +18,6 @@ instance HasType Id where fv (Id _ t) = fv t mv (Id _ t) = mv t bv (Id _ t) = bv t + +instance HasSourceSpan Id where + sourceSpanOf = sourceSpanOf . idName diff --git a/src/Solcore/Frontend/TypeInference/TcContract.hs b/src/Solcore/Frontend/TypeInference/TcContract.hs index 990cc2706..10c4a1fb6 100644 --- a/src/Solcore/Frontend/TypeInference/TcContract.hs +++ b/src/Solcore/Frontend/TypeInference/TcContract.hs @@ -1,7 +1,6 @@ module Solcore.Frontend.TypeInference.TcContract where import Control.Monad -import Control.Monad.Except import Control.Monad.State import Data.Generics hiding (Constr) import Data.List @@ -9,6 +8,7 @@ import Data.List.NonEmpty qualified as N import Data.Map qualified as Map import Data.Maybe import Data.Set qualified as Set +import Solcore.Diagnostics (CompilerError) import Solcore.Frontend.Pretty.ShortName import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax @@ -40,7 +40,7 @@ typeInferTopDeclChecks :: [InstanceHead] -> [(Name, [Name])] -> [TopDeclCheck Name] -> - IO (Either String (CompUnit Id, TcEnv)) + IO (Either CompilerError (CompUnit Id, TcEnv)) typeInferTopDeclChecks opts imps trustedInstances partialTypes topDeclChecks = do r <- @@ -77,7 +77,7 @@ expandTyM st (TyCon n ts) = do | length params == length ts' -> expandTyM st (insts (zip params ts') body) | otherwise -> - throwError $ + tcmError $ unlines [ "Type synonym arity mismatch for '" ++ pretty n ++ "':", " expected " ++ show (length params) ++ " argument(s)", @@ -162,7 +162,7 @@ findCycle deps = go [] (map fst deps) recursiveSynonymError :: [Name] -> TcM a recursiveSynonymError cyclePath = - throwError $ + tcmError $ unlines [ "Recursive type synonym detected:", " " ++ intercalate " -> " (map pretty cyclePath) @@ -202,7 +202,7 @@ tcTopDecl (TFunDef fd) = fd' <- tcBindGroup [fd] case fd' of (fd1 : _) -> pure (TFunDef fd1) - _ -> throwError "Impossible! Empty binding group!" + _ -> tcmError "Impossible! Empty binding group!" tcTopDecl (TClassDef c) = TClassDef <$> tcClass c tcTopDecl (TInstDef is) = @@ -306,7 +306,7 @@ tcDecl (CFunDecl d) = requireAnnotations d d' <- tcBindGroup [d] case d' of - [] -> throwError "Impossible! Empty function binding!" + [] -> tcmError "Impossible! Empty function binding!" (x : _) -> pure (CFunDecl x) tcDecl (CMutualDecl ds) = do @@ -484,7 +484,7 @@ addClassMethod p@(InCls c _ _) sig@(Signature _ methodCtx f ps t) = extEnv qn sch pure () addClassMethod p@(_ :~: _) (Signature _ _ n _ _) = - throwError $ + tcmError $ unlines [ "Invalid constraint:", pretty p, @@ -497,7 +497,7 @@ addClassMethod p@(_ :~: _) (Signature _ _ n _ _) = signatureError :: Name -> Tyvar -> Signature Name -> Ty -> TcM () signatureError n v (Signature _ methodCtx f _ _) t | null methodCtx = - throwError $ + tcmError $ unlines [ "Impossible! Class context is empty in function:", pretty f, @@ -505,7 +505,7 @@ signatureError n v (Signature _ methodCtx f _ _) t pretty n ] | v `notElem` fv t = - throwError $ + tcmError $ unlines [ "Main class type variable", pretty v, @@ -520,12 +520,24 @@ signatureError n v (Signature _ methodCtx f _ _) t duplicatedClassDecl :: Name -> TcM () duplicatedClassDecl n = - throwError $ "Duplicated class definition:" ++ pretty n + tcDiagnosticErrorAtName + "SC0227" + ("duplicate class definition: " ++ pretty n) + n + "duplicate class" + [] + ["rename or remove the duplicate class definition"] duplicatedClassMethod :: Name -> TcM () duplicatedClassMethod n = - throwError $ "Duplicated class method definition:" ++ pretty n + tcDiagnosticErrorAtName + "SC0228" + ("duplicate class method definition: " ++ pretty n) + n + "duplicate class method" + [] + ["rename or remove the duplicate class method"] invalidPragmaDecl :: [Pragma] -> TcM () invalidPragmaDecl ps = - throwError $ unlines $ ["Invalid pragma definitions:"] ++ map pretty ps + tcmError $ unlines $ ["Invalid pragma definitions:"] ++ map pretty ps diff --git a/src/Solcore/Frontend/TypeInference/TcModule.hs b/src/Solcore/Frontend/TypeInference/TcModule.hs index f58d2a9e7..59e3cf500 100644 --- a/src/Solcore/Frontend/TypeInference/TcModule.hs +++ b/src/Solcore/Frontend/TypeInference/TcModule.hs @@ -32,6 +32,7 @@ import Data.List (foldl') import Data.Map (Map) import Data.Map qualified as Map import Data.Set qualified as Set +import Solcore.Diagnostics (CompilerError, compilerErrorFromString, legacyCompilerError) import Solcore.Frontend.Module.Identity qualified as Mod import Solcore.Frontend.Module.Loader import Solcore.Frontend.Syntax @@ -91,17 +92,17 @@ data CheckedAssembly loadModuleLocalTypeCheckInput :: ModuleGraph -> Mod.ModuleId -> - IO (Either String ModuleResolvedTypeCheckInput) + IO (Either CompilerError ModuleResolvedTypeCheckInput) loadModuleLocalTypeCheckInput graph moduleId = loadResolvedModuleTypeCheckInput (moduleLocalTypeCheckSurface graph moduleId) loadResolvedModuleTypeCheckInput :: Either String ModuleTypeCheckSurface -> - IO (Either String ModuleResolvedTypeCheckInput) + IO (Either CompilerError ModuleResolvedTypeCheckInput) loadResolvedModuleTypeCheckInput input = case input of Left err -> - pure (Left err) + pure (Left (compilerErrorFromString err)) Right surface -> do resolved <- nameResolutionTopDeclSegments @@ -115,7 +116,7 @@ loadResolvedModuleTypeCheckInput input = mkModuleResolvedTypeCheckInput :: ModuleTypeCheckSurface -> (CompUnit Name, [[TopDecl Name]]) -> - Either String ModuleResolvedTypeCheckInput + Either CompilerError ModuleResolvedTypeCheckInput mkModuleResolvedTypeCheckInput surface (resolved, resolvedSegments) = case resolvedSegments of [resolvedQualifiedDecls, resolvedLocalDecls, resolvedImportedDecls] -> @@ -133,13 +134,14 @@ mkModuleResolvedTypeCheckInput surface (resolved, resolvedSegments) = } _ -> Left $ - "Internal error: expected 3 resolved module typecheck surface segments, got " - ++ show (length resolvedSegments) + legacyCompilerError $ + "Internal error: expected 3 resolved module typecheck surface segments, got " + ++ show (length resolvedSegments) typeInferModuleLocals :: Option -> ModuleTypeCheckInput -> - IO (Either String (CompUnit Id, TcEnv)) + IO (Either CompilerError (CompUnit Id, TcEnv)) typeInferModuleLocals opts input = typeInferTopDeclChecks opts @@ -401,8 +403,8 @@ defaultImportQualifiers importPath = leafName = importedModuleLeafName fullName importedModuleLeafName :: Name -> Name -importedModuleLeafName (Name n) = Name n -importedModuleLeafName (QualName _ n) = Name n +importedModuleLeafName n@(Name _) = n +importedModuleLeafName q@(QualName _ n) = copyNameSourceSpan q (Name n) typedForwardingWrapper :: Name -> FunDef Id -> FunDef Id typedForwardingWrapper qualifier (FunDef sig body) @@ -416,7 +418,7 @@ typedForwardingWrapper qualifier (FunDef sig body) [Return (Call Nothing targetId args)] where originalName = sigName sig - qualifiedName = QualName qualifier (show originalName) + qualifiedName = qualifyName qualifier originalName targetId = Id originalName (typedSignatureType sig) args = map (Var . paramName) (sigParams sig) diff --git a/src/Solcore/Frontend/TypeInference/TcMonad.hs b/src/Solcore/Frontend/TypeInference/TcMonad.hs index e44176cbe..a473f4261 100644 --- a/src/Solcore/Frontend/TypeInference/TcMonad.hs +++ b/src/Solcore/Frontend/TypeInference/TcMonad.hs @@ -3,11 +3,14 @@ module Solcore.Frontend.TypeInference.TcMonad where import Control.Monad import Control.Monad.Except import Control.Monad.State +import Data.Generics (Data, everything, extQ, mkQ) import Data.List import Data.List.NonEmpty qualified as N import Data.Map qualified as Map import Data.Maybe +import Data.Monoid (First (..)) import Data.Set qualified as Set +import Solcore.Diagnostics (CompilerError (..), Diagnostic (..), DiagnosticCode (..), Label (..), LabelStyle (..), Severity (..), SourceSpan, addDiagnosticNote, diagnosticCompilerError) import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax import Solcore.Frontend.TypeInference.Id @@ -20,9 +23,9 @@ import Text.Printf -- definition of type inference monad infrastructure -type TcM a = (StateT TcEnv (ExceptT String IO)) a +type TcM a = (StateT TcEnv (ExceptT CompilerError IO)) a -runTcM :: TcM a -> TcEnv -> IO (Either String (a, TcEnv)) +runTcM :: TcM a -> TcEnv -> IO (Either CompilerError (a, TcEnv)) runTcM m env = runExceptT (runStateT m env) defaultM :: TcM a -> TcM (Maybe a) @@ -163,7 +166,7 @@ matchTy t t' = extSubst s tcmMatch :: Ty -> Ty -> TcM Subst -tcmMatch t u = catchError (match t u) throwError +tcmMatch = match addFunctionName :: Name -> TcM () addFunctionName n = @@ -203,7 +206,7 @@ kindCheck t@(TyCon n ts) = do ti <- askTypeInfo n `wrapError` t unless (n == Name "pair" || arity ti == length ts) $ - throwError $ + tcmError $ unlines [ "Invalid number of type arguments!", "Type " @@ -353,7 +356,7 @@ askCurrentContract = do n <- gets contract maybe - (throwError "Impossible! Lacking current contract name!") + (tcmError "Impossible! Lacking current contract name!") pure n @@ -499,7 +502,13 @@ checkSynonym (TySym n vs t) = duplicatedSynonymDecl :: Name -> TcM a duplicatedSynonymDecl n = - throwError $ unwords ["Duplicated type synonym definition:", pretty n] + tcDiagnosticErrorAtName + "SC0226" + ("duplicate type synonym definition: " ++ pretty n) + n + "duplicate type synonym" + [] + ["rename or remove the duplicate type synonym"] -- manipulating the instance environment @@ -550,7 +559,7 @@ addDefaultInstance n inst = ) maybeToTcM :: String -> Maybe a -> TcM a -maybeToTcM s Nothing = throwError s +maybeToTcM s Nothing = tcmError s maybeToTcM _ (Just x) = pure x -- checking coverage pragma @@ -652,15 +661,72 @@ dumpLogs = do -- wrapping error messages -wrapError :: (Pretty b) => TcM a -> b -> TcM a +wrapError :: (Pretty b, Data b) => TcM a -> b -> TcM a wrapError m e = catchError m handler where handler msg = throwError (decorate msg) - decorate msg = msg ++ "\n - in:" ++ pretty e + decorate (CompilerDiagnostics diagnostics) = + CompilerDiagnostics $ + map + (addDiagnosticNote ("in: " ++ pretty e) . addContextLabel e) + diagnostics + decorate (CompilerLegacyError msg) = + CompilerLegacyError (msg ++ "\n - in:" ++ pretty e) + +addContextLabel :: (Data b) => b -> Diagnostic -> Diagnostic +addContextLabel context diagnostic + | any ((== Primary) . labelStyle) (diagnosticLabels diagnostic) = diagnostic + | otherwise = + case contextSourceSpan context of + Just sourceSpan -> + diagnostic + { diagnosticLabels = + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just (contextLabelMessage diagnostic) + } + : diagnosticLabels diagnostic + } + Nothing -> diagnostic + +contextLabelMessage :: Diagnostic -> String +contextLabelMessage diagnostic = + case diagnosticCode diagnostic of + Just (DiagnosticCode "SC0201") -> "expression has mismatched type" + Just (DiagnosticCode "SC0202") -> "unknown name" + Just (DiagnosticCode "SC0203") -> "undefined type" + Just (DiagnosticCode "SC0204") -> "undefined field" + Just (DiagnosticCode "SC0205") -> "undefined constructor" + Just (DiagnosticCode "SC0206") -> "undefined function" + Just (DiagnosticCode "SC0207") -> "undefined class" + Just (DiagnosticCode "SC0208") -> "undefined type synonym" + Just (DiagnosticCode "SC0209") -> "type is not polymorphic enough" + Just (DiagnosticCode "SC0220") -> "incomplete signature" + Just (DiagnosticCode "SC0221") -> "incomplete method signature" + Just (DiagnosticCode "SC0222") -> "return before end of block" + Just (DiagnosticCode "SC0223") -> "unsolved constraint" + Just (DiagnosticCode "SC0224") -> "shorthand constructor" + Just (DiagnosticCode "SC0225") -> "duplicate function" + Just (DiagnosticCode "SC0226") -> "duplicate type synonym" + Just (DiagnosticCode "SC0227") -> "duplicate class" + Just (DiagnosticCode "SC0228") -> "duplicate class method" + Just (DiagnosticCode "SC0229") -> "duplicate type" + _ -> "diagnostic reported here" + +contextSourceSpan :: (Data a) => a -> Maybe SourceSpan +contextSourceSpan value = + getFirst $ everything (<>) (mkQ (First Nothing) locationSpan `extQ` nameSpan) value + where + locationSpan :: NodeLocation -> First SourceSpan + locationSpan = First . nodeLocationSpan + + nameSpan :: Name -> First SourceSpan + nameSpan = First . nameSourceSpan tcmMgu :: Ty -> Ty -> TcM Subst -tcmMgu t u = catchError (mgu t u) tcmError +tcmMgu = mgu -- error messages @@ -668,67 +734,205 @@ tcmError :: String -> TcM a tcmError s = do verbose <- isVerbose when verbose dumpLogs - throwError s + throwError (genericTypecheckError s) + +genericTypecheckError :: String -> CompilerError +genericTypecheckError rawMessage = + diagnosticCompilerError $ + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0299"), + diagnosticMessage = message, + diagnosticLabels = [], + diagnosticNotes = notes, + diagnosticHelp = [] + } + where + rawLines = dropWhile null (lines rawMessage) + (message, notes) = + case rawLines of + [] -> ("typecheck error", []) + firstLine : rest -> (firstLine, filter (not . null) rest) undefinedName :: Name -> TcM a undefinedName n = - throwError $ unwords ["Undefined name:", pretty n] + tcDiagnosticErrorAtName + "SC0202" + ("undefined name: " ++ pretty n) + n + "unknown name" + [] + [] undefinedType :: Name -> TcM a undefinedType n = do s <- (unlines . reverse) <$> gets logs - throwError $ unwords ["Undefined type:", pretty n, "\n", s] + tcDiagnosticErrorAtName + "SC0203" + ("undefined type: " ++ pretty n) + n + "undefined type" + (if null s then [] else [s]) + [] undefinedField :: Name -> Name -> TcM a undefinedField n n' = - throwError $ - unlines - [ "Undefined field:", - pretty n, - "in type:", - pretty n' - ] + tcDiagnosticErrorAtName + "SC0204" + ("undefined field: " ++ pretty n) + n + "undefined field" + ["in type: " ++ pretty n'] + [] undefinedConstr :: Name -> Name -> TcM a undefinedConstr tn cn = - throwError $ - unlines - [ "Undefined constructor:", - pretty cn, - "in type:", - pretty tn - ] + tcDiagnosticErrorAtName + "SC0205" + ("undefined constructor: " ++ pretty cn) + cn + "undefined constructor" + ["in type: " ++ pretty tn] + [] undefinedFunction :: Name -> Name -> TcM a undefinedFunction t n = - throwError $ - unlines - [ "The type:", - pretty t, - "does not define function:", - pretty n - ] + tcDiagnosticErrorAtName + "SC0206" + ("undefined function: " ++ pretty n) + n + "undefined function" + ["type " ++ pretty t ++ " does not define this function"] + [] typeNotPolymorphicEnough :: Signature Name -> Scheme -> Scheme -> TcM a typeNotPolymorphicEnough sig sch1 sch2 = - tcmError $ - unlines - [ "Type not polymorphic enough! The annotated type is:", - pretty sch2, - "but the infered type is:", - pretty sch1, - "in:", - pretty sig - ] + tcDiagnosticErrorAtName + "SC0209" + "type is not polymorphic enough" + (sigName sig) + "annotated type is not polymorphic enough" + [ "annotated type: " ++ pretty sch2, + "inferred type: " ++ pretty sch1, + "in: " ++ pretty sig + ] + [] undefinedClass :: Name -> TcM a undefinedClass n = - throwError $ unlines ["Undefined class:", pretty n] + tcDiagnosticErrorAtName + "SC0207" + ("undefined class: " ++ pretty n) + n + "undefined class" + [] + [] undefinedSynonym :: Name -> TcM a undefinedSynonym n = - throwError $ unwords ["Undefined type synonym:", pretty n] + tcDiagnosticErrorAtName + "SC0208" + ("undefined type synonym: " ++ pretty n) + n + "undefined type synonym" + [] + [] + +tcDiagnosticError :: String -> String -> [String] -> [String] -> TcM a +tcDiagnosticError code message notes help = + tcDiagnosticErrorWithLabels code message [] notes help + +tcDiagnosticErrorAtName :: String -> String -> Name -> String -> [String] -> [String] -> TcM a +tcDiagnosticErrorAtName code message identName label notes help = + tcDiagnosticErrorWithLabels code message (maybe [] pure (primaryNameLabel label identName)) notes help + +tcDiagnosticErrorAtSource :: (HasSourceSpan source) => String -> String -> source -> String -> [String] -> [String] -> TcM a +tcDiagnosticErrorAtSource code message source label notes help = + tcDiagnosticErrorWithLabels code message (maybe [] pure (primarySourceLabel label source)) notes help + +tcDiagnosticErrorWithLabels :: String -> String -> [Label] -> [String] -> [String] -> TcM a +tcDiagnosticErrorWithLabels code message labels notes help = + throwError $ + diagnosticCompilerError $ + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode code), + diagnosticMessage = message, + diagnosticLabels = labels, + diagnosticNotes = notes, + diagnosticHelp = help + } + +primaryNameLabel :: String -> Name -> Maybe Label +primaryNameLabel message identName = + do + sourceSpan <- nameSourceSpan identName + pure + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just message + } + +primarySourceLabel :: (HasSourceSpan source) => String -> source -> Maybe Label +primarySourceLabel message source = + do + sourceSpan <- sourceSpanOf source + pure + Label + { labelSpan = sourceSpan, + labelStyle = Primary, + labelMessage = Just message + } + +topLevelFunctionAnnotationError :: Signature Name -> TcM a +topLevelFunctionAnnotationError sig = + tcDiagnosticErrorAtName + "SC0220" + "top-level function must have complete type annotations" + (sigName sig) + "incomplete signature" + ["signature: " ++ pretty sig] + ["annotate every parameter (name : Type) and provide a return type (-> Type)"] + +methodAnnotationError :: Signature Name -> TcM a +methodAnnotationError sig = + tcDiagnosticErrorAtName + "SC0221" + "class and instance methods must have complete type signatures" + (sigName sig) + "incomplete method signature" + ["signature: " ++ pretty sig] + ["annotate every method parameter and provide a return type"] + +illegalReturnStatement :: Stmt Name -> TcM a +illegalReturnStatement stmt = + tcDiagnosticErrorAtSource + "SC0222" + "illegal return statement" + stmt + "return before end of block" + ["return statements must be the final statement in a block"] + [] + +cannotEntail :: Pred -> [String] -> TcM a +cannotEntail predValue notes = + tcDiagnosticError + "SC0223" + ("cannot entail: " ++ pretty predValue) + notes + ["add a matching instance or strengthen the surrounding type context"] + +shorthandConstructorError :: String -> Name -> [String] -> TcM a +shorthandConstructorError message constructorName notes = + tcDiagnosticErrorAtName + "SC0224" + message + constructorName + "shorthand constructor" + notes + ["use a constructor that is visible for the expected type"] typeAlreadyDefinedError :: DataTy -> Name -> TcM a typeAlreadyDefinedError d n = @@ -736,13 +940,13 @@ typeAlreadyDefinedError d n = -- get type info di <- askTypeInfo n d' <- dataTyFromInfo n di `wrapError` d - throwError $ - unlines - [ "Duplicated type definition for " ++ pretty n ++ ":", - pretty d, - "and", - pretty d' - ] + tcDiagnosticErrorAtName + "SC0229" + ("duplicate type definition: " ++ pretty n) + n + "duplicate type" + ["new definition: " ++ pretty d, "existing definition: " ++ pretty d'] + ["rename or remove the duplicate type definition"] dataTyFromInfo :: Name -> TypeInfo -> TcM DataTy dataTyFromInfo n (TypeInfo _ cs _) = diff --git a/src/Solcore/Frontend/TypeInference/TcSat.hs b/src/Solcore/Frontend/TypeInference/TcSat.hs index e303da807..214477958 100644 --- a/src/Solcore/Frontend/TypeInference/TcSat.hs +++ b/src/Solcore/Frontend/TypeInference/TcSat.hs @@ -1,7 +1,6 @@ module Solcore.Frontend.TypeInference.TcSat where import Control.Monad -import Control.Monad.Except import Data.Maybe import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax hiding (gen) @@ -18,7 +17,7 @@ sat ps = satI :: Int -> [Pred] -> TcM [Subst] satI 0 p = - throwError $ + tcmError $ unwords [ "Could not deduce:", pretty p, @@ -40,13 +39,13 @@ satOne n p = do -- rule Inst delta <- sats p when (null delta) $ - throwError $ + tcmError $ unwords ["There is no instance to satisfy:", pretty p] foldM (step n p) [mempty] delta step :: Int -> Pred -> [Subst] -> (Subst, [Pred]) -> TcM [Subst] step 0 p _ _ = - throwError $ + tcmError $ unwords [ "Could not deduce:", pretty p, diff --git a/src/Solcore/Frontend/TypeInference/TcSimplify.hs b/src/Solcore/Frontend/TypeInference/TcSimplify.hs index 768f78faa..6839bf653 100644 --- a/src/Solcore/Frontend/TypeInference/TcSimplify.hs +++ b/src/Solcore/Frontend/TypeInference/TcSimplify.hs @@ -342,16 +342,8 @@ undefinedInstance p@(InCls n _ _) = do insts <- askInstEnv n insts' <- mapM fromANF insts - tcmError $ - unlines $ - [ "Cannot entail:", - f (pretty p), - "currently defined instances:" - ] - ++ map (f . pretty) insts' - where - f s = " " ++ s -undefinedInstance p = tcmError $ unwords ["Cannot entail: ", pretty p] + cannotEntail p ("currently defined instances:" : map pretty insts') +undefinedInstance p = cannotEntail p [] unsolvedError :: [Pred] -> TcM () unsolvedError = mapM_ unsolvedPredError @@ -361,12 +353,5 @@ unsolvedPredError p@(InCls n _ _) = do insts <- askInstEnv n insts' <- mapM fromANF insts - let s = unlines (map pretty insts') - tcmError $ - unlines - [ "Cannot entail:", - pretty p, - "using defined instances:", - s - ] -unsolvedPredError p = tcmError $ unwords ["Cannot entail:", pretty p] + cannotEntail p ("using defined instances:" : map pretty insts') +unsolvedPredError p = cannotEntail p [] diff --git a/src/Solcore/Frontend/TypeInference/TcStmt.hs b/src/Solcore/Frontend/TypeInference/TcStmt.hs index 92bfffbd2..20fcd8394 100644 --- a/src/Solcore/Frontend/TypeInference/TcStmt.hs +++ b/src/Solcore/Frontend/TypeInference/TcStmt.hs @@ -11,6 +11,7 @@ import Data.Maybe import Data.Set qualified as Set import GHC.Stack import Language.Yul +import Solcore.Diagnostics (SourceSpan) import Solcore.Frontend.Pretty.ShortName import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax @@ -28,11 +29,35 @@ import Solcore.Primitives.Primitives type Infer f = f Name -> TcM (f Id, [Pred], Ty) +locatedLike :: (HasSourceSpan source) => source -> (SourceSpan -> target -> target) -> target -> target +locatedLike source locate target = + maybe target (`locate` target) (sourceSpanOf source) + +locatedInferResult :: + (HasSourceSpan source) => + (SourceSpan -> node -> node) -> + source -> + (node, [Pred], Ty) -> + (node, [Pred], Ty) +locatedInferResult locate source (node, preds, ty) = + (locatedLike source locate node, preds, ty) + +locatedPatResult :: + Pat Name -> + (Pat Id, Ty, [(Name, Scheme)]) -> + (Pat Id, Ty, [(Name, Scheme)]) +locatedPatResult source (pat, ty, context) = + (locatedLike source locatedPat pat, ty, context) + tcStmt :: Infer Stmt tcStmt = tcStmtWithExpectedReturn Nothing tcStmtWithExpectedReturn :: Maybe Ty -> Infer Stmt -tcStmtWithExpectedReturn _ e@(lhs := rhs) = +tcStmtWithExpectedReturn mExpectedReturn stmt = + locatedInferResult locatedStmt stmt <$> tcStmtWithExpectedReturn' mExpectedReturn stmt + +tcStmtWithExpectedReturn' :: Maybe Ty -> Infer Stmt +tcStmtWithExpectedReturn' _ e@(lhs := rhs) = do (lhs1, ps1, t1) <- tcExp lhs s0 <- getSubst @@ -41,7 +66,7 @@ tcStmtWithExpectedReturn _ e@(lhs := rhs) = s <- unify t1 t2 `wrapError` e _ <- extSubst s pure (lhs1 := rhs1, apply s $ ps1 ++ ps2, unit) -tcStmtWithExpectedReturn _ e@(Let n mt me) = +tcStmtWithExpectedReturn' _ e@(Let n mt me) = do (me', psf, tf) <- case (mt, me) of (Just t, Just e1) -> do @@ -63,31 +88,31 @@ tcStmtWithExpectedReturn _ e@(Let n mt me) = extEnv n (monotype tf) let e' = Let (Id n tf) (Just tf) me' withCurrentSubst (e', psf, unit) -tcStmtWithExpectedReturn mExpectedReturn (Block body) = +tcStmtWithExpectedReturn' mExpectedReturn (Block body) = withLocalCtx [] $ do (body', ps, t) <- tcBodyWithExpectedReturn mExpectedReturn body pure (Block body', ps, t) -tcStmtWithExpectedReturn _ (StmtExp e) = +tcStmtWithExpectedReturn' _ (StmtExp e) = do (e', ps', _) <- tcExp e pure (StmtExp e', ps', unit) -tcStmtWithExpectedReturn mExpectedReturn (Return e) = +tcStmtWithExpectedReturn' mExpectedReturn (Return e) = do (e', ps, t) <- tcExpWithExpected mExpectedReturn e pure (Return e', ps, t) -tcStmtWithExpectedReturn mExpectedReturn (Match es eqns) = +tcStmtWithExpectedReturn' mExpectedReturn (Match es eqns) = do (es', pss', ts') <- unzip3 <$> mapM tcExp es ensureVisiblePatternCoverage ts' eqns (eqns', pss1, resTy) <- tcEquationsWithExpectedReturn mExpectedReturn ts' eqns withCurrentSubst (Match es' eqns', concat (pss1 : pss'), resTy) -tcStmtWithExpectedReturn _ (Asm yblk) = +tcStmtWithExpectedReturn' _ (Asm yblk) = withLocalCtx yulPrimOps $ do (newBinds, t) <- tcYulBlock yblk let word' = monotype word mapM_ (flip extEnv word') newBinds pure (Asm yblk, [], t) -tcStmtWithExpectedReturn mExpectedReturn s@(If e blk1 blk2) = +tcStmtWithExpectedReturn' mExpectedReturn s@(If e blk1 blk2) = do (e', ps, t) <- tcExp e -- condition should have the boolean type @@ -128,7 +153,7 @@ tcStmtWithExpectedReturn mExpectedReturn s@(If e blk1 blk2) = ) `wrapError` s withCurrentSubst (If e' blk1' blk2', ps3, t1) -tcStmtWithExpectedReturn mExpectedReturn s@(For initStmt cond postStmt body) = +tcStmtWithExpectedReturn' mExpectedReturn s@(For initStmt cond postStmt body) = withLocalEnv $ do (initStmt', psInit, _) <- tcStmtWithExpectedReturn Nothing initStmt (cond', psCond, condTy) <- tcExp cond @@ -181,7 +206,7 @@ ensureVisiblePatternCoverage scrutineeTys eqns = TyCon scrutineeTypeName _ -> do isPartial <- isPartialDataType scrutineeTypeName when (isPartial && not (hasCatchAllAt index eqns)) $ - throwError $ + tcmError $ unlines [ "Pattern match on type with hidden constructors requires a wildcard arm:", pretty scrutineeTypeName @@ -213,11 +238,15 @@ tcPats ts ps pure (ps', ts', concat ctxs) tcPat :: Ty -> Pat Name -> TcM (Pat Id, Ty, [(Name, Scheme)]) -tcPat t (PVar n) = +tcPat t pat = + locatedPatResult pat <$> tcPat' t pat + +tcPat' :: Ty -> Pat Name -> TcM (Pat Id, Ty, [(Name, Scheme)]) +tcPat' t (PVar n) = do let v = PVar (Id n t) pure (v, t, [(n, monotype t)]) -tcPat t p@(PCon n ps) = +tcPat' t p@(PCon n ps) = do n' <- resolvePatternConstructor n t `wrapError` p -- asking type from environment @@ -225,7 +254,7 @@ tcPat t p@(PCon n ps) = (_ :=> tc) <- freshInst st let (argTys, resultTy) = splitTy tc when (length argTys /= length ps) $ - throwError $ + tcmError $ unlines [ "Wrong number of pattern arguments for constructor:", pretty n', @@ -248,9 +277,9 @@ tcPat t p@(PCon n ps) = -- building typing assumptions for introduced names let lctx' = map (\(boundName, t1) -> (boundName, apply s t1)) (concat lctxs) pure (PCon (Id n' tc) ps1, t', apply s lctx') -tcPat t PWildcard = +tcPat' t PWildcard = pure (PWildcard, t, []) -tcPat t' (PLit l) = +tcPat' t' (PLit l) = do t <- tcLit l s <- unify t t' @@ -274,13 +303,17 @@ tcExp :: (HasCallStack) => Infer Exp tcExp = tcExpWithExpected Nothing tcExpWithExpected :: (HasCallStack) => Maybe Ty -> Exp Name -> TcM (Exp Id, [Pred], Ty) -tcExpWithExpected _ (Lit l) = +tcExpWithExpected mExpected expr = + locatedInferResult locatedExp expr <$> tcExpWithExpected' mExpected expr + +tcExpWithExpected' :: (HasCallStack) => Maybe Ty -> Exp Name -> TcM (Exp Id, [Pred], Ty) +tcExpWithExpected' _ (Lit l) = do t <- tcLit l pure (Lit l, [], t) -tcExpWithExpected _ (Var n) = +tcExpWithExpected' _ e@(Var n) = do - s <- askEnv n `wrapError` (Var n) + s <- askEnv n `wrapError` e (ps :=> t) <- freshInst s noDesugarCalls <- getNoDesugarCalls if noDesugarCalls @@ -291,7 +324,7 @@ tcExpWithExpected _ (Var n) = r <- lookupUniqueTy n p <- maybe (pure $ (Var (Id n t), t)) mkCon r withCurrentSubst (fst p, ps, snd p) -tcExpWithExpected mExpected e@(Con n es) = +tcExpWithExpected' mExpected e@(Con n es) = do expectedArgTys <- mapM (const freshTyVar) es n' <- resolveExpressionConstructor n expectedArgTys mExpected `wrapError` e @@ -328,10 +361,10 @@ tcExpWithExpected mExpected e@(Con n es) = let ps' = concat (ps : pss) e1 = Con (Id n' t) es' withCurrentSubst (e1, ps', t') -tcExpWithExpected _ e@(FieldAccess Nothing _) = +tcExpWithExpected' _ e@(FieldAccess Nothing _) = -- = notImplementedS "tcExp" e - throwError ("tcExp not implemented for: " ++ pretty e ++ "\n" ++ show e) -tcExpWithExpected _ (FieldAccess (Just e) n) = + tcmError ("tcExp not implemented for: " ++ pretty e ++ "\n" ++ show e) +tcExpWithExpected' _ (FieldAccess (Just e) n) = do -- inferring expression type (e', ps, t) <- tcExpWithExpected Nothing e @@ -342,9 +375,9 @@ tcExpWithExpected _ (FieldAccess (Just e) n) = s <- askField tn n (ps' :=> t') <- freshInst s withCurrentSubst (FieldAccess (Just e') (Id n t'), ps ++ ps', t') -tcExpWithExpected _ ex@(Call me n args) = +tcExpWithExpected' _ ex@(Call me n args) = tcCall me n args `wrapError` ex -tcExpWithExpected _ (Lam args bd _) = +tcExpWithExpected' _ (Lam args bd _) = do (args', schs, ts') <- tcArgs args (bd', ps, t') <- withLocalCtx schs (tcBody bd) @@ -361,14 +394,14 @@ tcExpWithExpected _ (Lam args bd _) = else do (exp1, t) <- closureConversion vs (apply s args') (apply s bd') ps1 ty withCurrentSubst (exp1, ps1, t) -tcExpWithExpected _ e1@(TyExp e ty) = +tcExpWithExpected' _ e1@(TyExp e ty) = do ty1 <- kindCheck ty `wrapError` e1 (e', ps, ty') <- tcExpWithExpected (Just ty1) e s <- tcmMatch ty' ty1 _ <- extSubst s withCurrentSubst (TyExp e' ty1, ps, ty1) -tcExpWithExpected _ e@(Cond e1 e2 e3) = +tcExpWithExpected' _ e@(Cond e1 e2 e3) = do (e1', ps1, t1) <- tcExpWithExpected Nothing e1 `wrapError` e (e2', ps2, t2) <- tcExpWithExpected Nothing e2 `wrapError` e @@ -406,7 +439,7 @@ tcExpWithExpected _ e@(Cond e1 e2 e3) = ) `wrapError` e withCurrentSubst (Cond e1' e2' e3', ps1 ++ ps2 ++ ps3, t2) -tcExpWithExpected _ e@(Indexed arrExp idx) = +tcExpWithExpected' _ e@(Indexed arrExp idx) = do (arr', psArr, tArr) <- tcExp arrExp `wrapError` e (idx', psIdx, tIdx) <- tcExp idx `wrapError` e @@ -776,7 +809,7 @@ checkPhantomMetaVars checkReturn n body rs ty = do let allPhantomMVs = nub (phantomMVs ++ escapedReturnMVs) unless (null allPhantomMVs) $ do let mvNames = intercalate ", " $ map (pretty . metaName) allPhantomMVs - throwError $ + tcmError $ unlines [ "Ambiguous type variable(s) " ++ mvNames ++ " in definition of " ++ pretty n ++ ".", "This typically occurs when a constructor has phantom type parameters.", @@ -860,12 +893,12 @@ annotateParam t (Untyped n) = Typed n t correctName :: Name -> TcM Name correctName n@(QualName _ _) = pure n -correctName (Name s) = +correctName n@(Name s) = do c <- gets contract if isJust c - then pure (QualName (fromJust c) s) - else pure (Name s) + then pure (copyNameSourceSpan n (QualName (fromJust c) s)) + else pure n extSignature :: Signature Name -> TcM () extSignature sig@(Signature _ _ n _ _) = @@ -942,7 +975,7 @@ verifySignatures instd@(Instance _ _ ps n ts t funs) = s <- match classc' ih `wrapError` instd -- getting method types let qnames = map qual (methods cinfo) - qual v = if v == invoke then v else QualName n (pretty v) + qual v = if v == invoke then v else qualifyName n v -- getting most general types and instantiate them aqts <- mapM @@ -987,7 +1020,7 @@ hasClosureType = any isClosureName . tyconNames invalidMemberType :: Name -> Ty -> Ty -> TcM a invalidMemberType n cls ins = - throwError $ + tcmError $ unlines [ "The instance method:", pretty n, @@ -1001,7 +1034,7 @@ schemeFromSignature :: Signature Id -> TcM Scheme schemeFromSignature sig@(Signature vs ps _ args (Just rt)) = do unless (all isTyped args) $ - throwError $ + tcmError $ unwords ["Invalid instance member signature:", pretty sig] pure $ Forall vs (ps :=> (funtype ts rt)) where @@ -1014,12 +1047,12 @@ schemeFromSignature sig@(Signature vs ps _ args (Just rt)) = ts = map extractType args schemeFromSignature sig = - throwError $ + tcmError $ unwords ["Invalid instance member signature (missing return type):", pretty sig] updateSignature :: [Tyvar] -> Name -> FunDef Id -> FunDef Id updateSignature vs' c (FunDef (Signature vs ps n args rt) bd) = - FunDef (Signature (vs \\ vs') ps (QualName c (pretty n)) args rt) bd + FunDef (Signature (vs \\ vs') ps (qualifyName c n) args rt) bd checkDeferedConstraints :: [(FunDef Id, [Pred])] -> TcM () checkDeferedConstraints = mapM_ checkDeferedConstraint @@ -1048,7 +1081,7 @@ checkCompleteInstDef n ns = mths' = map unqual mths remaining = mths' \\ ns when (not $ null remaining) do - throwError $ + tcmError $ unlines $ [ "Incomplete definition for class:", pretty n, @@ -1118,7 +1151,7 @@ maybeExpandSynonym (TyCon n ts) = do | ar == length ts' -> maybeExpandSynonym (insts (zip params ts') body) | otherwise -> - throwError $ + tcmError $ unlines [ "Type synonym arity mismatch for '" ++ pretty n ++ "':", " expected " ++ show ar ++ " argument(s)", @@ -1152,7 +1185,7 @@ isTyVar _ = False checkBoundVariable :: [Pred] -> [Tyvar] -> TcM () checkBoundVariable ps vs = unless (all (`elem` vs) (bv ps)) $ do - throwError "Bounded variable condition fails!" + tcmError "Bounded variable condition fails!" checkOverlap :: Pred -> [Inst] -> TcM () checkOverlap _ [] = pure () @@ -1163,7 +1196,7 @@ checkOverlap p@(InCls _ t _) (i : is) = (_ :=> (InCls _ t' _)) -> case mgu t t' of Right _ -> - throwError + tcmError ( unlines [ "Overlapping instances are not supported", "instance:", @@ -1186,7 +1219,7 @@ checkCoverage cn ts t = weakTvs = bv ts undetermined = weakTvs \\ strongTvs unless (null undetermined) $ - throwError + tcmError ( unlines [ "Coverage condition fails for class:", pretty cn, @@ -1203,7 +1236,7 @@ checkMethod ih@(InCls n _ _) d@(FunDef sig _) = -- checking if the signature is fully annotated fullSignature sig -- getting current method signature in class - let qn = QualName n (show (sigName sig)) + let qn = qualifyName n (sigName sig) sch <- askEnv qn `wrapError` d (qs :=> _) <- freshInst sch p <- @@ -1225,17 +1258,11 @@ fullSignature :: Signature Name -> TcM () fullSignature sig = unless (isFullyAnnotated sig) - (throwError $ unlines ["Class and instance methods must have complete type signatures:", pretty sig]) + (methodAnnotationError sig) requireAnnotations :: FunDef Name -> TcM () requireAnnotations (FunDef sig _) = - unless (isFullyAnnotated sig) $ - tcmError $ - unlines - [ "Top-level function must have complete type annotations:", - " " ++ pretty sig, - "Annotate every parameter (name : Type) and provide a return type (-> Type)." - ] + unless (isFullyAnnotated sig) (topLevelFunctionAnnotationError sig) isFullyAnnotated :: Signature Name -> Bool isFullyAnnotated (Signature _ _ _ ps rt) = @@ -1258,7 +1285,7 @@ checkMeasure ps c = if all smaller ps then return () else - throwError $ + tcmError $ unlines [ "Instance ", pretty c, @@ -1326,8 +1353,8 @@ tcBodyWithExpectedReturn mExpectedReturn [s] = do (s', ps', t') <- tcStmtWithExpectedReturn mExpectedReturn s pure ([s'], ps', t') -tcBodyWithExpectedReturn _ (Return _ : _) = - throwError "Illegal return statement" +tcBodyWithExpectedReturn _ (returnStmt@(Return _) : _) = + illegalReturnStatement returnStmt tcBodyWithExpectedReturn mExpectedReturn (s : ss) = do (s', ps', _) <- tcStmtWithExpectedReturn mExpectedReturn s @@ -1393,7 +1420,7 @@ canonicalizeConstructorName n = case mUnqual of Just _ -> pure n Nothing -> do - let qn = QualName n (pretty n) + let qn = qualifyName n n mQual <- maybeAskEnv qn pure (if isJust mQual then qn else n) @@ -1403,28 +1430,25 @@ resolveDotExpressionConstructor dotName argTys mExpected = do candidates <- case mcandidates of Just xs -> pure xs Nothing -> - throwError $ - unlines - [ "Cannot resolve shorthand constructor expression without expected constructor type:", - pretty dotName - ] + shorthandConstructorError + "cannot resolve shorthand constructor expression without expected constructor type" + dotName + ["constructor: " ++ pretty dotName] valid <- filterM (\n -> constructorAcceptsArguments n argTys mExpected) (nub candidates) case valid of [] -> - throwError $ - unlines - [ "No matching constructor for shorthand expression:", - pretty dotName - ] + shorthandConstructorError + "no matching constructor for shorthand expression" + dotName + ["constructor: " ++ pretty dotName] [n] -> pure n xs -> - throwError $ - unlines - [ "Ambiguous shorthand constructor expression:", - pretty dotName, - "Candidates:", - unwords (map pretty xs) - ] + shorthandConstructorError + "ambiguous shorthand constructor expression" + dotName + [ "constructor: " ++ pretty dotName, + "candidates: " ++ unwords (map pretty xs) + ] constructorAcceptsArguments :: Name -> [Ty] -> Maybe Ty -> TcM Bool constructorAcceptsArguments n argTys mExpected = do @@ -1465,27 +1489,24 @@ resolveDotPatternConstructor dotName expectedTy = do candidates <- case mcandidates of Just xs -> pure xs Nothing -> - throwError $ - unlines - [ "Cannot resolve shorthand constructor pattern without expected constructor type:", - pretty dotName - ] + shorthandConstructorError + "cannot resolve shorthand constructor pattern without expected constructor type" + dotName + ["constructor: " ++ pretty dotName] case nub candidates of [] -> - throwError $ - unlines - [ "No matching constructor for shorthand pattern:", - pretty dotName - ] + shorthandConstructorError + "no matching constructor for shorthand pattern" + dotName + ["constructor: " ++ pretty dotName] [n] -> pure n xs -> - throwError $ - unlines - [ "Ambiguous shorthand constructor pattern:", - pretty dotName, - "Candidates:", - unwords (map pretty xs) - ] + shorthandConstructorError + "ambiguous shorthand constructor pattern" + dotName + [ "constructor: " ++ pretty dotName, + "candidates: " ++ unwords (map pretty xs) + ] candidatesForDotPattern :: Name -> Ty -> TcM (Maybe [Name]) candidatesForDotPattern dotName expectedTy = do @@ -1517,17 +1538,17 @@ isDotConstructorMarker (Name ('.' : _)) = True isDotConstructorMarker _ = False dotMarkerLeafName :: Name -> Name -dotMarkerLeafName (Name ('.' : xs)) = Name xs +dotMarkerLeafName n@(Name ('.' : xs)) = copyNameSourceSpan n (Name xs) dotMarkerLeafName n = constructorLeafName n constructorLeafName :: Name -> Name -constructorLeafName (QualName _ n) = Name n +constructorLeafName q@(QualName _ n) = copyNameSourceSpan q (Name n) constructorLeafName n = n typeName :: Ty -> TcM Name typeName (TyCon n _) = pure n typeName t = - throwError $ + tcmError $ unlines [ "Expected type, but found:", pretty t @@ -1716,7 +1737,7 @@ rename t = classArityError :: (Pretty a) => Name -> ClassInfo -> a -> TcM () classArityError n cinfo v = - throwError $ + tcmError $ unlines [ "Type class " ++ pretty n, "requires " ++ show (classArity cinfo) ++ " weak parameter(s)", @@ -1726,14 +1747,14 @@ classArityError n cinfo v = unboundTypeVars :: (Pretty a) => a -> [Tyvar] -> TcM b unboundTypeVars sig vs = - throwError $ unlines ["Type variables:", vs', "are unbound in:", pretty sig] + tcmError $ unlines ["Type variables:", vs', "are unbound in:", pretty sig] where vs' = unwords $ map pretty vs typeMatch :: Scheme -> Scheme -> TcM () typeMatch t1 t2 = unless (t1 == t2) $ - throwError $ + tcmError $ unwords [ "Types", pretty t1, @@ -1744,13 +1765,13 @@ typeMatch t1 t2 = invalidYulType :: Name -> Ty -> TcM a invalidYulType (Name n) ty = - throwError $ unlines ["Yul values can only be of word type:", unwords [n, ":", pretty ty]] + tcmError $ unlines ["Yul values can only be of word type:", unwords [n, ":", pretty ty]] invalidYulType qn ty = - throwError $ unlines ["Yul values can only be of word type:", unwords [pretty qn, ":", pretty ty]] + tcmError $ unlines ["Yul values can only be of word type:", unwords [pretty qn, ":", pretty ty]] invalidMethodPred :: Pred -> FunDef Name -> TcM a invalidMethodPred p d = - throwError $ + tcmError $ unlines [ "Expected class predicate in instance head for method check:", pretty p, @@ -1760,7 +1781,7 @@ invalidMethodPred p d = expectedFunction :: Ty -> TcM a expectedFunction t = - throwError $ + tcmError $ unlines [ "Expected function type. Found:", pretty t @@ -1768,7 +1789,7 @@ expectedFunction t = wrongPatternNumber :: [Ty] -> [Pat Name] -> TcM a wrongPatternNumber qts ps = - throwError $ + tcmError $ unlines [ "Wrong number of patterns in:", unwords (map pretty ps), @@ -1779,7 +1800,13 @@ wrongPatternNumber qts ps = duplicatedFunDef :: Name -> TcM () duplicatedFunDef n = - throwError $ "Duplicated function definition:" ++ pretty n + tcDiagnosticErrorAtName + "SC0225" + ("duplicate function definition: " ++ pretty n) + n + "duplicate function" + [] + ["rename or remove the duplicate function definition"] entailmentError :: [Pred] -> [Pred] -> TcM () entailmentError base nonentail = diff --git a/src/Solcore/Frontend/TypeInference/TcUnify.hs b/src/Solcore/Frontend/TypeInference/TcUnify.hs index ca134453c..ce1733842 100644 --- a/src/Solcore/Frontend/TypeInference/TcUnify.hs +++ b/src/Solcore/Frontend/TypeInference/TcUnify.hs @@ -3,6 +3,7 @@ module Solcore.Frontend.TypeInference.TcUnify where import Common.Pretty import Control.Monad.Except import Data.List +import Solcore.Diagnostics import Solcore.Frontend.Pretty.ShortName import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax @@ -10,7 +11,7 @@ import Solcore.Frontend.TypeInference.TcSubst -- standard unification machinery -varBind :: (MonadError String m) => MetaTv -> Ty -> m Subst +varBind :: (MonadError CompilerError m) => MetaTv -> Ty -> m Subst varBind v t | t == Meta v = return mempty | v `elem` mv t = infiniteTyErr v t @@ -24,7 +25,7 @@ isTyCon _ = False -- type matching class Match a where - match :: (MonadError String m) => a -> a -> m Subst + match :: (MonadError CompilerError m) => a -> a -> m Subst instance Match Ty where match (TyCon n ts) (TyCon n' ts') @@ -51,15 +52,18 @@ instance (Pretty a, Match a) => Match [a] where instance Match Pred where match (InCls n t ts) (InCls n' t' ts') | n == n' = match (t : ts) (t' : ts') - | otherwise = throwError "Classes differ!" + | otherwise = + structuredUnifyError + "SC0210" + "classes do not match" + ["left class: " ++ pretty n, "right class: " ++ pretty n'] + [] match p1 p2 = - throwError $ - unlines - [ "Cannot match predicates:", - pretty p1, - "with", - pretty p2 - ] + structuredUnifyError + "SC0211" + "predicates do not match" + ["left predicate: " ++ pretty p1, "right predicate: " ++ pretty p2] + [] instance (HasType a, Match a) => Match (Qual a) where match (ps :=> t) (ps' :=> t') = @@ -71,7 +75,7 @@ instance (HasType a, Match a) => Match (Qual a) where -- most general unifier class MGU a where - mgu :: (MonadError String m) => a -> a -> m Subst + mgu :: (MonadError CompilerError m) => a -> a -> m Subst instance (HasType a, MGU a, Pretty a) => MGU [a] where mgu ts1 ts2 @@ -98,23 +102,19 @@ instance MGU Pred where mgu p1@(InCls n t ts) p2@(InCls n' t' ts') | n == n' = mgu (t : ts) (t' : ts') | otherwise = - throwError $ - unlines - [ "Cannot unify predicates:", - pretty p1, - "with", - pretty p2 - ] + structuredUnifyError + "SC0212" + "predicates do not unify" + ["left predicate: " ++ pretty p1, "right predicate: " ++ pretty p2] + [] mgu (t1 :~: t2) (t1' :~: t2') = mgu [t1, t2] [t1', t2'] mgu p1 p2 = - throwError $ - unlines - [ "Cannot unify predicates:", - pretty p1, - "with", - pretty p2 - ] + structuredUnifyError + "SC0212" + "predicates do not unify" + ["left predicate: " ++ pretty p1, "right predicate: " ++ pretty p2] + [] instance (HasType a, MGU a) => MGU (Qual a) where mgu (ps :=> t) (ps' :=> t') = @@ -122,7 +122,7 @@ instance (HasType a, MGU a) => MGU (Qual a) where s <- mgu (sort ps) (sort ps') mgu (apply s t) (apply s t') -solve :: (MonadError String m, MGU a, HasType a) => [(a, a)] -> Subst -> m Subst +solve :: (MonadError CompilerError m, MGU a, HasType a) => [(a, a)] -> Subst -> m Subst solve [] s = pure s solve ((t1, t2) : ts) s = do @@ -130,10 +130,10 @@ solve ((t1, t2) : ts) s = s2 <- solve ts s1 pure (s2 <> s1) -unifyTypes :: (MonadError String m) => [Ty] -> [Ty] -> m Subst +unifyTypes :: (MonadError CompilerError m) => [Ty] -> [Ty] -> m Subst unifyTypes ts ts' = solve (zip ts ts') mempty -unifyAllTypes :: (MonadError String m) => [Ty] -> m Subst +unifyAllTypes :: (MonadError CompilerError m) => [Ty] -> m Subst unifyAllTypes [] = pure mempty unifyAllTypes (t : ts) = do @@ -143,7 +143,7 @@ unifyAllTypes (t : ts) = -- composition operator for matching -merge :: (MonadError String m) => Subst -> Subst -> m Subst +merge :: (MonadError CompilerError m) => Subst -> Subst -> m Subst merge s1@(Subst p1) s2@(Subst p2) = if agree then pure (Subst $ nub (p1 ++ p2)) @@ -159,75 +159,84 @@ merge s1@(Subst p1) s2@(Subst p2) = (dom p1 `intersect` dom p2) dom s = map fst s -mergeError :: (MonadError String m) => [(Ty, Ty)] -> m a -mergeError ts = throwError $ unlines $ "Cannot match types:" : ss +mergeError :: (MonadError CompilerError m) => [(Ty, Ty)] -> m a +mergeError ts = + structuredUnifyError + "SC0213" + "substitutions assign incompatible types" + ss + [] where - ss = map go ts + ss = map (("conflict: " ++) . go) ts go (x, y) = pretty x ++ " with " ++ pretty y -- basic error messages -infiniteTyErr :: (MonadError String m) => MetaTv -> Ty -> m a +infiniteTyErr :: (MonadError CompilerError m) => MetaTv -> Ty -> m a infiniteTyErr v t = - throwError $ - unwords - [ "Cannot construct the infinite type:", - pretty (metaName v), - "~", - pretty t - ] - -typesNotMatch :: (MonadError String m) => Ty -> Ty -> m a + structuredUnifyError + "SC0214" + "cannot construct infinite type" + ["meta variable: " ++ pretty (metaName v), "type: " ++ pretty t] + [] + +typesNotMatch :: (MonadError CompilerError m) => Ty -> Ty -> m a typesNotMatch t1 t2 = - throwError $ - unwords - [ "Types do not match:", - pretty t1, - "and", - pretty t2 - ] - -typesMatchListErr :: (MonadError String m) => [String] -> [String] -> m a + typeMismatchDiagnostic "types do not match" t1 t2 + +typesMatchListErr :: (MonadError CompilerError m) => [String] -> [String] -> m a typesMatchListErr ts ts' = - throwError (errMsg ts ts') - where - errMsg lhs rhs = - unwords - [ "Type lists do not match: (typesMatchListErr)\n", - prettys lhs, - "and", - prettys rhs - ] - -typesMguListErr :: (MonadError String m, Pretty t) => [t] -> [t] -> m a + structuredUnifyError + "SC0215" + "type lists do not match" + ["left types: " ++ prettys ts, "right types: " ++ prettys ts'] + [] + +typesMguListErr :: (MonadError CompilerError m, Pretty t) => [t] -> [t] -> m a typesMguListErr ts ts' = - throwError (errMsg ts ts') - where - errMsg lhs rhs = - unwords - [ "Type lists do not unify: (typesMguListErr)\n", - prettys lhs, - "and", - prettys rhs - ] - -typesDoNotUnify :: (MonadError String m) => Ty -> Ty -> m a + structuredUnifyError + "SC0216" + "type lists do not unify" + ["left types: " ++ prettys ts, "right types: " ++ prettys ts'] + [] + +typesDoNotUnify :: (MonadError CompilerError m) => Ty -> Ty -> m a typesDoNotUnify t1 t2 = + typeMismatchDiagnostic "types do not unify" t1 t2 + +typeMismatchDiagnostic :: (MonadError CompilerError m) => String -> Ty -> Ty -> m a +typeMismatchDiagnostic message t1 t2 = throwError $ - unwords - [ "Types:", - pretty t1, - "and", - pretty t2, - "do not unify" - ] - -boundVariablesErr :: (MonadError String m) => [Tyvar] -> m a + diagnosticCompilerError $ + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0201"), + diagnosticMessage = message ++ ": " ++ pretty t1 ++ " and " ++ pretty t2, + diagnosticLabels = [], + diagnosticNotes = + [ "left type: " ++ pretty t1, + "right type: " ++ pretty t2 + ], + diagnosticHelp = [] + } + +boundVariablesErr :: (MonadError CompilerError m) => [Tyvar] -> m a boundVariablesErr ts = + structuredUnifyError + "SC0217" + "bound variable escaped unification" + ["bound variables: " ++ prettys ts] + ["report this as a compiler bug if it is reachable from source code"] + +structuredUnifyError :: (MonadError CompilerError m) => String -> String -> [String] -> [String] -> m a +structuredUnifyError code message notes help = throwError $ - unwords $ - [ "Panic!", - "The following bound variables where", - "found in unification / matching:" - ] - ++ map pretty ts + diagnosticCompilerError $ + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode code), + diagnosticMessage = message, + diagnosticLabels = [], + diagnosticNotes = notes, + diagnosticHelp = help + } diff --git a/src/Solcore/Pipeline/Options.hs b/src/Solcore/Pipeline/Options.hs index 35efef7ca..e4d269d92 100644 --- a/src/Solcore/Pipeline/Options.hs +++ b/src/Solcore/Pipeline/Options.hs @@ -1,6 +1,7 @@ module Solcore.Pipeline.Options where import Options.Applicative +import Solcore.Diagnostics data Option = Option @@ -25,11 +26,23 @@ data Option optDebugSpec :: !Bool, optDebugHull :: !Bool, optTiming :: !Bool, + optDiagnosticColor :: !ColorChoice, + optDiagnosticUnicode :: !UnicodeChoice, + optDiagnosticWidth :: !Int, + optDiagnosticFormat :: !DiagnosticFormat, + optWarningPolicy :: !WarningPolicy, -- Partial evaluation options optPEFuel :: !(Maybe Int) } deriving (Eq, Show) +data WarningPolicy + = WarningsDefault + | WarningsAlways + | WarningsNever + | WarningsDeny + deriving (Eq, Ord, Show) + emptyOption :: FilePath -> Option emptyOption path = Option @@ -54,6 +67,11 @@ emptyOption path = optDebugSpec = False, optDebugHull = False, optTiming = False, + optDiagnosticColor = diagnosticColor defaultDiagnosticRenderOptions, + optDiagnosticUnicode = diagnosticUnicode defaultDiagnosticRenderOptions, + optDiagnosticWidth = diagnosticWidth defaultDiagnosticRenderOptions, + optDiagnosticFormat = diagnosticFormat defaultDiagnosticRenderOptions, + optWarningPolicy = WarningsDefault, -- Partial evaluation options optPEFuel = Nothing } @@ -168,6 +186,46 @@ options = ( long "timing" <> help "Measure time of some phases" ) + <*> option + colorChoiceReader + ( long "color" + <> metavar "auto|always|never" + <> value (optDiagnosticColor stdOpt) + <> showDefaultWith showColorChoice + <> help "Configure diagnostic colors" + ) + <*> option + unicodeChoiceReader + ( long "unicode" + <> metavar "auto|always|never" + <> value (optDiagnosticUnicode stdOpt) + <> showDefaultWith showUnicodeChoice + <> help "Configure diagnostic Unicode output" + ) + <*> option + auto + ( long "diagnostic-width" + <> metavar "N" + <> value (optDiagnosticWidth stdOpt) + <> showDefault + <> help "Set diagnostic output width" + ) + <*> option + diagnosticFormatReader + ( long "diagnostic-format" + <> metavar "human|short" + <> value (optDiagnosticFormat stdOpt) + <> showDefaultWith showDiagnosticFormat + <> help "Configure diagnostic output format" + ) + <*> option + warningPolicyReader + ( long "warnings" + <> metavar "default|always|never|deny" + <> value (optWarningPolicy stdOpt) + <> showDefaultWith showWarningPolicy + <> help "Configure compiler warning diagnostics" + ) -- Partial evaluation options <*> optional ( option @@ -188,3 +246,68 @@ argumentsParser = do <> header "Solcore - solidity core language" ) execParser opts + +diagnosticRenderOptions :: Option -> DiagnosticRenderOptions +diagnosticRenderOptions opts = + DiagnosticRenderOptions + { diagnosticColor = optDiagnosticColor opts, + diagnosticUnicode = optDiagnosticUnicode opts, + diagnosticWidth = optDiagnosticWidth opts, + diagnosticFormat = optDiagnosticFormat opts + } + +colorChoiceReader :: ReadM ColorChoice +colorChoiceReader = + eitherReader $ \raw -> + case raw of + "auto" -> Right ColorAuto + "always" -> Right ColorAlways + "never" -> Right ColorNever + _ -> Left "expected one of: auto, always, never" + +unicodeChoiceReader :: ReadM UnicodeChoice +unicodeChoiceReader = + eitherReader $ \raw -> + case raw of + "auto" -> Right UnicodeAuto + "always" -> Right UnicodeAlways + "never" -> Right UnicodeNever + _ -> Left "expected one of: auto, always, never" + +diagnosticFormatReader :: ReadM DiagnosticFormat +diagnosticFormatReader = + eitherReader $ \raw -> + case raw of + "human" -> Right DiagnosticHuman + "short" -> Right DiagnosticShort + _ -> Left "expected one of: human, short" + +warningPolicyReader :: ReadM WarningPolicy +warningPolicyReader = + eitherReader $ \raw -> + case raw of + "default" -> Right WarningsDefault + "always" -> Right WarningsAlways + "never" -> Right WarningsNever + "deny" -> Right WarningsDeny + _ -> Left "expected one of: default, always, never, deny" + +showColorChoice :: ColorChoice -> String +showColorChoice ColorAuto = "auto" +showColorChoice ColorAlways = "always" +showColorChoice ColorNever = "never" + +showUnicodeChoice :: UnicodeChoice -> String +showUnicodeChoice UnicodeAuto = "auto" +showUnicodeChoice UnicodeAlways = "always" +showUnicodeChoice UnicodeNever = "never" + +showDiagnosticFormat :: DiagnosticFormat -> String +showDiagnosticFormat DiagnosticHuman = "human" +showDiagnosticFormat DiagnosticShort = "short" + +showWarningPolicy :: WarningPolicy -> String +showWarningPolicy WarningsDefault = "default" +showWarningPolicy WarningsAlways = "always" +showWarningPolicy WarningsNever = "never" +showWarningPolicy WarningsDeny = "deny" diff --git a/src/Solcore/Pipeline/SolcorePipeline.hs b/src/Solcore/Pipeline/SolcorePipeline.hs index 8650a5bc8..bb335d4a0 100644 --- a/src/Solcore/Pipeline/SolcorePipeline.hs +++ b/src/Solcore/Pipeline/SolcorePipeline.hs @@ -1,12 +1,15 @@ module Solcore.Pipeline.SolcorePipeline where +import Control.Applicative ((<|>)) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class (liftIO) import Data.Bifunctor (first) -import Data.Char (isAlpha, isAlphaNum) +import Data.Char (isAlpha, isAlphaNum, isSpace) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf, nub, stripPrefix) import Data.Map (Map) import Data.Map qualified as Map +import Data.Maybe (mapMaybe, maybeToList) import Data.Time qualified as Time import Language.Hull qualified as Hull -- Pretty instances for MastCompUnit @@ -16,14 +19,43 @@ import Solcore.Backend.Mast () import Solcore.Backend.MastEval (defaultFuel, eliminateDeadCode, evalCompUnit) import Solcore.Backend.Specialise (specialiseCompUnit) import Solcore.Desugarer.ContractDispatch (contractDispatchTopDecls) -import Solcore.Desugarer.DecisionTreeCompiler (matchCompiler, showWarning) +import Solcore.Desugarer.DecisionTreeCompiler (matchCompiler, warningDiagnostic) import Solcore.Desugarer.FieldAccess (fieldDesugarTopDecls) import Solcore.Desugarer.IfDesugarer (ifDesugarer) import Solcore.Desugarer.IndirectCall (indirectCallTopDecls) import Solcore.Desugarer.ReplaceFunTypeArgs import Solcore.Desugarer.ReplaceWildcard (replaceWildcardTopDecls) +import Solcore.Diagnostics + ( CompilerError (..), + Diagnostic (..), + DiagnosticCode (..), + Label (..), + LabelStyle (..), + Severity (..), + SourceFile, + SourceMap, + SourceSpan (..), + addDiagnosticHelp, + addDiagnosticNote, + compilerErrorDiagnostics, + compilerErrorFromString, + compilerErrorText, + defaultDiagnosticRenderOptions, + diagnosticMessage, + diagnosticPrimarySpan, + emptySourceMap, + findTextSpansInSource, + findTokenSpansInSource, + insertSourceFile, + lookupSourceFile, + makeSourceFile, + renderDiagnostics, + resolveDiagnosticRenderOptions, + sourceMapFiles, + ) +import Solcore.Diagnostics qualified as Diag import Solcore.Frontend.Module.Identity qualified as Mod -import Solcore.Frontend.Module.Loader (ModuleGraph (..), loadModuleGraph, moduleSourcePath, moduleValidationTopDeclSegments) +import Solcore.Frontend.Module.Loader (ModuleGraph (..), loadModuleGraph, moduleSourceMap, moduleSourcePath, moduleValidationTopDeclSegments) import Solcore.Frontend.Pretty.SolcorePretty import Solcore.Frontend.Syntax hiding (contracts) import Solcore.Frontend.Syntax.NameResolution @@ -31,8 +63,8 @@ import Solcore.Frontend.TypeInference.Id import Solcore.Frontend.TypeInference.SccAnalysis import Solcore.Frontend.TypeInference.TcEnv import Solcore.Frontend.TypeInference.TcModule -import Solcore.Pipeline.Options (Option (..), argumentsParser, noDesugarOpt) -import System.Directory (makeAbsolute) +import Solcore.Pipeline.Options (Option (..), WarningPolicy (..), argumentsParser, diagnosticRenderOptions, noDesugarOpt) +import System.Directory (doesFileExist, makeAbsolute) import System.Exit (ExitCode (..), exitWith) import System.TimeIt qualified as TimeIt @@ -41,10 +73,11 @@ pipeline :: IO () pipeline = do _startTime <- Time.getCurrentTime opts <- argumentsParser - result <- compile opts + result <- compileWithDiagnostics opts case result of Left err -> do - putStrLn err + rendered <- renderCompileDiagnosticsIO opts err + putStrLn rendered exitWith (ExitFailure 1) Right contracts -> do forM_ (zip [(1 :: Int) ..] contracts) $ \(i, c) -> do @@ -52,9 +85,20 @@ pipeline = do putStrLn ("Writing to " ++ filename) writeFile filename (show c) +data CompileDiagnostics + = CompileDiagnostics + { compileDiagnosticSources :: SourceMap, + compileDiagnosticMessages :: [Diagnostic] + } + deriving (Eq, Show) + -- Version that returns Either for testing compile :: Option -> IO (Either String [Hull.Object]) -compile opts = runExceptT $ do +compile opts = + first compileDiagnosticsText <$> compileWithDiagnostics opts + +compileWithDiagnostics :: Option -> IO (Either CompileDiagnostics [Hull.Object]) +compileWithDiagnostics opts = runExceptT $ do let verbose = optVerbose opts noMatchCompiler = optNoMatchCompiler opts noIfDesugar = optNoIfDesugar opts @@ -62,34 +106,39 @@ compile opts = runExceptT $ do timeItNamed = optTimeItNamed opts file = fileName opts mainRoot <- liftIO $ makeAbsolute (optRootDir opts) - stdRoot <- ExceptT $ pure (parseStdRoot (optImportDirs opts)) - externalLibs <- ExceptT $ pure (parseExternalLibSpecs (optExternalLibs opts)) + stdRoot <- liftEitherDiagnostic emptySourceMap (parseStdRoot (optImportDirs opts)) + externalLibs <- liftEitherDiagnostic emptySourceMap (parseExternalLibSpecs (optExternalLibs opts)) -- Parsing and import loading - graph <- ExceptT $ loadModuleGraph mainRoot stdRoot externalLibs file + graph <- liftEitherDiagnosticIO emptySourceMap (loadModuleGraph mainRoot stdRoot externalLibs file) + let sources = moduleSourceMap graph -- Validate each module against only its own direct imports. forM_ (moduleOrder graph) $ \moduleId -> do - sourcePath <- ExceptT $ pure (moduleSourcePath graph moduleId) + sourcePath <- liftEitherDiagnostic sources (moduleSourcePath graph moduleId) (validationImports, validationSegments) <- - ExceptT $ - pure (moduleValidationTopDeclSegments graph moduleId) + liftEitherDiagnostic sources (moduleValidationTopDeclSegments graph moduleId) _ <- - ExceptT $ - pure $ - first (\e -> "Module validation failed for " ++ sourcePath ++ ":\n" ++ e) $ + liftCompilerDiagnostic + sources + ( first (decorateCompilerDiagnosticContext ("module validation failed for " ++ sourcePath)) $ validateDuplicateNamespacesInTopDeclSegments validationSegments + ) _ <- - ExceptT $ - first (\e -> "Module validation failed for " ++ sourcePath ++ ":\n" ++ e) - <$> nameResolutionTopDeclSegments validationImports validationSegments + liftCompilerDiagnosticIO + sources + ( first (decorateCompilerDiagnosticContext ("module validation failed for " ++ sourcePath)) + <$> nameResolutionTopDeclSegments validationImports validationSegments + ) pure () checkedModules <- - ExceptT $ - timeItNamed "Typecheck modules" $ - runExceptT (typeCheckLoadedModules opts graph) - checkedAssembly <- ExceptT $ pure (assembleCheckedModules graph checkedModules) + liftCompilerDiagnosticIO + sources + ( timeItNamed "Typecheck modules" $ + runExceptT (typeCheckLoadedModules opts graph) + ) + checkedAssembly <- liftEitherDiagnostic sources (assembleCheckedModules graph checkedModules) let typed = checkedAssemblyCompUnit checkedAssembly tcEnv = checkedAssemblyEnv checkedAssembly @@ -109,8 +158,9 @@ compile opts = runExceptT $ do if noMatchCompiler then pure desugared else do - (ast, warns) <- ExceptT $ timeItNamed "Match compiler" $ matchCompiler desugared - when (verbose && not (null warns)) $ liftIO $ mapM_ (putStrLn . showWarning) warns + (ast, warns) <- liftEitherDiagnosticIO sources (timeItNamed "Match compiler" $ matchCompiler desugared) + let warningDiagnostics = map (enrichDiagnostic sources . warningDiagnostic) warns + handleWarningDiagnostics opts sources warningDiagnostics pure ast let printMatch = not noMatchCompiler && (verbose || optDumpDS opts) @@ -160,7 +210,493 @@ compile opts = runExceptT $ do pure hull -typeCheckLoadedModules :: Option -> ModuleGraph -> ExceptT String IO (Map Mod.ModuleId CheckedModule) +renderCompileDiagnostics :: Option -> CompileDiagnostics -> String +renderCompileDiagnostics opts diagnostics = + renderDiagnostics + (diagnosticRenderOptions opts) + (compileDiagnosticSources diagnostics) + (compileDiagnosticMessages diagnostics) + +renderCompileDiagnosticsIO :: Option -> CompileDiagnostics -> IO String +renderCompileDiagnosticsIO opts diagnostics = do + renderOptions <- resolveDiagnosticRenderOptions (diagnosticRenderOptions opts) + pure $ + renderDiagnostics + renderOptions + (compileDiagnosticSources diagnostics) + (compileDiagnosticMessages diagnostics) + +compileDiagnosticsText :: CompileDiagnostics -> String +compileDiagnosticsText diagnostics = + renderDiagnostics + defaultDiagnosticRenderOptions + (compileDiagnosticSources diagnostics) + (compileDiagnosticMessages diagnostics) + +handleWarningDiagnostics :: Option -> SourceMap -> [Diagnostic] -> ExceptT CompileDiagnostics IO () +handleWarningDiagnostics _ _ [] = + pure () +handleWarningDiagnostics opts sources diagnostics = + case optWarningPolicy opts of + WarningsNever -> pure () + WarningsDefault + | optVerbose opts -> printWarnings + | otherwise -> pure () + WarningsAlways -> printWarnings + WarningsDeny -> + throwError + CompileDiagnostics + { compileDiagnosticSources = sources, + compileDiagnosticMessages = map denyWarning diagnostics + } + where + printWarnings = + liftIO $ do + renderOptions <- resolveDiagnosticRenderOptions (diagnosticRenderOptions opts) + putStrLn (renderDiagnostics renderOptions sources diagnostics) + +denyWarning :: Diagnostic -> Diagnostic +denyWarning diagnostic = + addDiagnosticHelp + "pass --warnings=default, --warnings=always, or --warnings=never to allow this warning" + diagnostic {diagnosticSeverity = Error} + +liftEitherDiagnostic :: SourceMap -> Either String a -> ExceptT CompileDiagnostics IO a +liftEitherDiagnostic sources = + ExceptT . pure . first (compileDiagnosticError sources) + +liftEitherDiagnosticIO :: SourceMap -> IO (Either String a) -> ExceptT CompileDiagnostics IO a +liftEitherDiagnosticIO sources action = + ExceptT $ do + result <- action + case result of + Left err -> Left <$> compileDiagnosticErrorIO sources err + Right value -> pure (Right value) + +liftCompilerDiagnostic :: SourceMap -> Either CompilerError a -> ExceptT CompileDiagnostics IO a +liftCompilerDiagnostic sources = + ExceptT . pure . first (compileCompilerError sources) + +liftCompilerDiagnosticIO :: SourceMap -> IO (Either CompilerError a) -> ExceptT CompileDiagnostics IO a +liftCompilerDiagnosticIO sources action = + ExceptT $ do + result <- action + case result of + Left err -> Left <$> compileCompilerErrorIO sources err + Right value -> pure (Right value) + +compileDiagnosticError :: SourceMap -> String -> CompileDiagnostics +compileDiagnosticError sources err = + compileCompilerError sources (compilerErrorFromString err) + +compileDiagnosticErrorIO :: SourceMap -> String -> IO CompileDiagnostics +compileDiagnosticErrorIO sources err = + compileCompilerErrorIO sources (compilerErrorFromString err) + +compileCompilerError :: SourceMap -> CompilerError -> CompileDiagnostics +compileCompilerError sources err = + let diagnostics = compilerErrorDiagnostics err + in CompileDiagnostics + { compileDiagnosticSources = sources, + compileDiagnosticMessages = map (enrichDiagnostic sources) diagnostics + } + +compileCompilerErrorIO :: SourceMap -> CompilerError -> IO CompileDiagnostics +compileCompilerErrorIO sources err = do + let diagnostics = compilerErrorDiagnostics err + sources' <- ensureDiagnosticSources sources diagnostics + pure + CompileDiagnostics + { compileDiagnosticSources = sources', + compileDiagnosticMessages = map (enrichDiagnostic sources') diagnostics + } + +diagnosticsFromError :: String -> [Diagnostic] +diagnosticsFromError = + compilerErrorDiagnostics . compilerErrorFromString + +enrichDiagnostic :: SourceMap -> Diagnostic -> Diagnostic +enrichDiagnostic sources diagnostic + | not (null (diagnosticLabels diagnostic)) = diagnostic + | isDuplicateDiagnostic diagnostic, + Just labels <- inferDuplicateLabels sources diagnostic = + diagnostic {diagnosticLabels = labels} + | Just label <- inferPrimaryLabel sources diagnostic = + diagnostic {diagnosticLabels = [label]} + | Just label <- inferFallbackLabel sources diagnostic = + diagnostic {diagnosticLabels = [label]} + | otherwise = diagnostic + +inferPrimaryLabel :: SourceMap -> Diagnostic -> Maybe Label +inferPrimaryLabel sources diagnostic = do + term <- firstMatchTerm sources diagnostic (diagnosticSearchTerms diagnostic) + foundSpan <- firstSpanForTerm sources diagnostic term + pure + Label + { labelSpan = foundSpan, + labelStyle = Primary, + labelMessage = Just (primaryLabelMessage diagnostic) + } + +inferDuplicateLabels :: SourceMap -> Diagnostic -> Maybe [Label] +inferDuplicateLabels sources diagnostic = + case firstTwoSpans of + [previous, duplicate] -> + Just + [ Label previous Secondary (Just "previous definition"), + Label duplicate Primary (Just "duplicate definition") + ] + _ -> Nothing + where + firstTwoSpans = + take 2 $ + concat + [ spansForTerm sources diagnostic term + | term <- duplicateSearchTerms diagnostic + ] + +firstMatchTerm :: SourceMap -> Diagnostic -> [String] -> Maybe String +firstMatchTerm sources diagnostic = + go . filter (not . null) + where + go [] = Nothing + go (term : terms) + | null (spansForTerm sources diagnostic term) = go terms + | otherwise = Just term + +firstSpanForTerm :: SourceMap -> Diagnostic -> String -> Maybe SourceSpan +firstSpanForTerm sources diagnostic term = + case spansForTerm sources diagnostic term of + foundSpan : _ -> Just foundSpan + [] -> Nothing + +spansForTerm :: SourceMap -> Diagnostic -> String -> [SourceSpan] +spansForTerm sources diagnostic term = + concatMap (`spansInSource` term) (candidateSources sources diagnostic) + +spansInSource :: SourceFile -> String -> [SourceSpan] +spansInSource source term = + case findTokenSpansInSource source term of + [] -> findTextSpansInSource source term + tokenSpans -> tokenSpans + +candidateSources :: SourceMap -> Diagnostic -> [SourceFile] +candidateSources sources diagnostic = + case mapMaybe (`lookupSourceFile` sources) (diagnosticSourcePaths diagnostic) of + [] -> sourceMapFiles sources + matched -> matched + +diagnosticSearchTerms :: Diagnostic -> [String] +diagnosticSearchTerms diagnostic = + uniqueStrings $ + concat + [ prefixedTerms + [ "undefined name: ", + "undefined type constructor: ", + "undefined type: ", + "undefined field: ", + "undefined constructor: ", + "undefined class: ", + "invalid pattern syntax: " + ] + (diagnosticMessage diagnostic), + typeMismatchTerms diagnostic, + unknownImportTerms diagnostic, + moduleReferenceTerms diagnostic, + duplicateSearchTerms diagnostic, + declarationSearchTerms diagnostic, + inContextSearchTerms diagnostic + ] + +inferFallbackLabel :: SourceMap -> Diagnostic -> Maybe Label +inferFallbackLabel sources diagnostic = do + source <- firstSource (candidateSources sources diagnostic) + pure + Label + { labelSpan = sourceFallbackSpan source, + labelStyle = Primary, + labelMessage = Just (fallbackLabelMessage diagnostic) + } + +firstSource :: [SourceFile] -> Maybe SourceFile +firstSource [] = Nothing +firstSource (source : _) = Just source + +sourceFallbackSpan :: SourceFile -> SourceSpan +sourceFallbackSpan source = + case Diag.sourceTokens source of + token : _ -> Diag.sourceTokenSpan token + [] -> + SourceSpan + { spanFile = Diag.sourcePath source, + spanStartByte = 0, + spanEndByte = 1, + spanStartLine = 1, + spanStartColumn = 1, + spanEndLine = 1, + spanEndColumn = 2 + } + +fallbackLabelMessage :: Diagnostic -> String +fallbackLabelMessage diagnostic = + case diagnosticCode diagnostic of + Nothing -> "diagnostic reported here" + Just _ -> primaryLabelMessage diagnostic + +duplicateSearchTerms :: Diagnostic -> [String] +duplicateSearchTerms diagnostic = + uniqueStrings $ + concatMap indentedTerms (allDiagnosticText diagnostic) + ++ prefixedTerms + [ "Duplicated function definition:", + "Duplicated class definition:", + "Duplicated class method definition:", + "Duplicated type synonym definition:" + ] + (diagnosticMessage diagnostic) + +typeMismatchTerms :: Diagnostic -> [String] +typeMismatchTerms diagnostic = + case diagnosticCode diagnostic of + Just (DiagnosticCode "SC0201") -> + [trim (drop (length inPrefix) note) | note <- diagnosticNotes diagnostic, inPrefix `isPrefixOf` note, isSmallNote note] + _ -> [] + where + inPrefix = "in: " + isSmallNote note = length note <= 80 && '\n' `notElem` note + +unknownImportTerms :: Diagnostic -> [String] +unknownImportTerms diagnostic = + concatMap itemTerms (allDiagnosticText diagnostic) + where + itemTerms line = + case words (trim line) of + [word] + | "." `isInfixOf` word -> + [word, lastSegment word] + _ -> [] + +moduleReferenceTerms :: Diagnostic -> [String] +moduleReferenceTerms diagnostic = + concatMap referenceTerms (allDiagnosticText diagnostic) + where + referenceTerms line = + case words (trim line) of + ("import" : path : _) -> modulePathTerms path + ("export" : path : _) -> modulePathTerms path + _ -> [] + +modulePathTerms :: String -> [String] +modulePathTerms raw = + uniqueStrings + [ dropAt cleanPath, + cleanPath, + lastSegment cleanPath + ] + where + cleanPath = + trimModulePath raw + +trimModulePath :: String -> String +trimModulePath = + takeWhile (\c -> c /= ';' && c /= ',' && c /= '{' && c /= '}') + +declarationSearchTerms :: Diagnostic -> [String] +declarationSearchTerms diagnostic = + concatMap declarationTerms (allDiagnosticText diagnostic) + where + declarationTerms raw = + case words (stripContextPrefix (trim raw)) of + "function" : declName : _ -> [stripTrailingParens declName] + "contract" : declName : _ -> [stripTrailingParens declName] + "class" : _vars : ":" : declName : _ -> [stripTrailingParens declName] + "class" : declName : _ -> [stripTrailingParens declName] + "data" : declName : _ -> [stripTrailingParens declName] + "type" : declName : _ -> [stripTrailingParens declName] + "constructor" : _ -> ["constructor"] + "instance" : _mainTy : ":" : instanceClassName : _ -> [stripTrailingParens instanceClassName, "instance"] + "instance" : instanceClassName : _ -> [stripTrailingParens instanceClassName, "instance"] + _ -> [] + +inContextSearchTerms :: Diagnostic -> [String] +inContextSearchTerms diagnostic = + concatMap contextTerms (allDiagnosticText diagnostic) + where + contextTerms raw = + case stripPrefix "in: " (trim raw) <|> stripPrefix "- in:" (trim raw) of + Nothing -> [] + Just context -> + take 1 (declarationSearchTerms (diagnostic {diagnosticMessage = context, diagnosticNotes = []})) + +stripContextPrefix :: String -> String +stripContextPrefix raw = + case stripPrefix "- in:" raw of + Just rest -> trim rest + Nothing -> + case stripPrefix "in: " raw of + Just rest -> trim rest + Nothing -> raw + +stripTrailingParens :: String -> String +stripTrailingParens = + takeWhile (\c -> c /= '(' && c /= ',' && c /= ';' && c /= '{') + +prefixedTerms :: [String] -> String -> [String] +prefixedTerms prefixes body = + [trim rest | prefix <- prefixes, Just rest <- [stripPrefix prefix body]] + +primaryLabelMessage :: Diagnostic -> String +primaryLabelMessage diagnostic = + case diagnosticCode diagnostic of + Just (DiagnosticCode "SC0101") -> "unknown name" + Just (DiagnosticCode "SC0102") -> "undefined type variable" + Just (DiagnosticCode "SC0103") -> "undefined type constructor" + Just (DiagnosticCode "SC0104") -> "invalid type synonym" + Just (DiagnosticCode "SC0105") -> "undefined class" + Just (DiagnosticCode "SC0106") -> "unqualified constructor" + Just (DiagnosticCode "SC0107") -> "invalid pattern" + Just (DiagnosticCode "SC0110") -> "unknown import item" + Just (DiagnosticCode "SC0201") -> "expression has mismatched type" + Just (DiagnosticCode "SC0202") -> "unknown name" + Just (DiagnosticCode "SC0203") -> "undefined type" + Just (DiagnosticCode "SC0204") -> "undefined field" + Just (DiagnosticCode "SC0205") -> "undefined constructor" + Just (DiagnosticCode "SC0206") -> "undefined function" + Just (DiagnosticCode "SC0207") -> "undefined class" + Just (DiagnosticCode "SC0208") -> "undefined type synonym" + Just (DiagnosticCode "SC0209") -> "type is not polymorphic enough" + Just (DiagnosticCode "SC0220") -> "incomplete signature" + Just (DiagnosticCode "SC0221") -> "incomplete method signature" + Just (DiagnosticCode "SC0222") -> "return before end of block" + Just (DiagnosticCode "SC0223") -> "unsolved constraint" + Just (DiagnosticCode "SC0224") -> "shorthand constructor" + Just (DiagnosticCode "SC0225") -> "duplicate function" + Just (DiagnosticCode "SC0226") -> "duplicate type synonym" + Just (DiagnosticCode "SC0227") -> "duplicate class" + Just (DiagnosticCode "SC0228") -> "duplicate class method" + Just (DiagnosticCode "SC0229") -> "duplicate type" + Just (DiagnosticCode "SC0299") -> "diagnostic reported here" + Just (DiagnosticCode "SC0301") -> "redundant clause" + Just (DiagnosticCode "SC0302") -> "non-exhaustive match" + Just (DiagnosticCode "SC0109") -> "module reference" + Just (DiagnosticCode "SC0118") -> "external library import" + Just (DiagnosticCode "SC0119") -> "source file" + Nothing -> "diagnostic reported here" + _ -> defaultPrimaryLabelMessage diagnostic + +defaultPrimaryLabelMessage :: Diagnostic -> String +defaultPrimaryLabelMessage diagnostic + | diagnosticMessageLooksLikeHeader diagnostic = "diagnostic reported here" + | otherwise = diagnosticMessage diagnostic + +diagnosticMessageLooksLikeHeader :: Diagnostic -> Bool +diagnosticMessageLooksLikeHeader diagnostic = + '\n' `elem` message || length message > 80 + where + message = diagnosticMessage diagnostic + +isDuplicateDiagnostic :: Diagnostic -> Bool +isDuplicateDiagnostic diagnostic = + any + (`isInfixOf` diagnosticMessage diagnostic) + [ "Duplicate declarations", + "duplicate declarations", + "Duplicated ", + "duplicate ", + "Duplicate exported", + "duplicate exported", + "Duplicate import", + "duplicate import", + "Duplicate names", + "duplicate name" + ] + || any ("Duplicate declarations" `isInfixOf`) (diagnosticNotes diagnostic) + || any ("duplicate declarations" `isInfixOf`) (diagnosticNotes diagnostic) + +diagnosticSourcePaths :: Diagnostic -> [FilePath] +diagnosticSourcePaths diagnostic = + uniqueStrings (concatMap sourcePathsFromLine (allDiagnosticText diagnostic)) + +sourcePathsFromLine :: String -> [FilePath] +sourcePathsFromLine line = + mapMaybe (`sourcePathAfterPrefix` line) prefixes ++ standaloneSourcePaths line + where + prefixes = + [ "module validation failed for ", + "module typecheck failed for ", + "source file is outside library root:" + ] + +standaloneSourcePaths :: String -> [FilePath] +standaloneSourcePaths line = + [path | let path = trim line, ".solc" `isSuffixOf` path] + +sourcePathAfterPrefix :: String -> String -> Maybe FilePath +sourcePathAfterPrefix prefix line = do + rest <- stripPrefix prefix (trim line) + let path = trim (takeWhile (\c -> c /= ':' && c /= '(') rest) + if null path then Nothing else Just path + +allDiagnosticText :: Diagnostic -> [String] +allDiagnosticText diagnostic = + concatMap lines (diagnosticMessage diagnostic : diagnosticNotes diagnostic ++ diagnosticHelp diagnostic) + +indentedTerms :: String -> [String] +indentedTerms line + | " " `isPrefixOf` line = + case words (trim line) of + [term] + | term /= "module" -> [term, lastSegment term] + _ -> [] + | otherwise = [] + +lastSegment :: String -> String +lastSegment = + reverse . takeWhile (/= '.') . reverse + +dropAt :: String -> String +dropAt ('@' : rest) = rest +dropAt path = path + +uniqueStrings :: [String] -> [String] +uniqueStrings = + nub . filter (not . null) . map trim + +trim :: String -> String +trim = + dropWhileEnd isSpace . dropWhile isSpace + +dropWhileEnd :: (a -> Bool) -> [a] -> [a] +dropWhileEnd p = + reverse . dropWhile p . reverse + +ensureDiagnosticSources :: SourceMap -> [Diagnostic] -> IO SourceMap +ensureDiagnosticSources = + foldM ensureDiagnosticSource + +ensureDiagnosticSource :: SourceMap -> Diagnostic -> IO SourceMap +ensureDiagnosticSource sources diagnostic = + foldM ensureSourcePath sources (diagnosticReferencedSourcePaths diagnostic) + +diagnosticReferencedSourcePaths :: Diagnostic -> [FilePath] +diagnosticReferencedSourcePaths diagnostic = + uniqueStrings $ + maybeToList (spanFile <$> diagnosticPrimarySpan diagnostic) + ++ diagnosticSourcePaths diagnostic + +ensureSourcePath :: SourceMap -> FilePath -> IO SourceMap +ensureSourcePath sources path + | null path = pure sources + | Just _ <- lookupSourceFile path sources = pure sources + | otherwise = do + exists <- doesFileExist path + if exists + then do + content <- readFile path + pure (insertSourceFile (makeSourceFile path content) sources) + else pure sources + +typeCheckLoadedModules :: Option -> ModuleGraph -> ExceptT CompilerError IO (Map Mod.ModuleId CheckedModule) typeCheckLoadedModules opts graph = Map.fromList <$> mapM (typeCheckModuleFromGraph opts graph) (moduleOrder graph) @@ -168,9 +704,9 @@ typeCheckModuleFromGraph :: Option -> ModuleGraph -> Mod.ModuleId -> - ExceptT String IO (Mod.ModuleId, CheckedModule) + ExceptT CompilerError IO (Mod.ModuleId, CheckedModule) typeCheckModuleFromGraph opts graph moduleId = do - sourcePath <- ExceptT $ pure (moduleSourcePath graph moduleId) + sourcePath <- ExceptT $ pure (first compilerErrorFromString (moduleSourcePath graph moduleId)) resolvedInput <- ExceptT $ first (moduleTypeCheckError sourcePath "input") <$> loadModuleLocalTypeCheckInput graph moduleId @@ -200,7 +736,7 @@ typeCheckModuleFromGraph opts graph moduleId = do prepareModuleTypeCheckInput :: Option -> ModuleResolvedTypeCheckInput -> - ExceptT String IO ModuleTypeCheckInput + ExceptT CompilerError IO ModuleTypeCheckInput prepareModuleTypeCheckInput opts resolvedInput = do inferenceDecls <- prepareModuleInferenceDeclsForTypeInference opts resolvedInput pure (withPreparedModuleInferenceDecls resolvedInput inferenceDecls) @@ -208,7 +744,7 @@ prepareModuleTypeCheckInput opts resolvedInput = do prepareModuleInferenceDeclsForTypeInference :: Option -> ModuleResolvedTypeCheckInput -> - ExceptT String IO [ModuleInferenceDecl] + ExceptT CompilerError IO [ModuleInferenceDecl] prepareModuleInferenceDeclsForTypeInference opts input = prepareInferenceDeclsForTypeInference opts @@ -246,21 +782,28 @@ dumpModuleTypeInference opts sourcePath typed tcEnv = putStrLn ("> Elaborated tree for " ++ sourcePath ++ ":") putStrLn $ pretty typed -moduleTypeCheckError :: FilePath -> String -> String -> String +moduleTypeCheckError :: FilePath -> String -> CompilerError -> CompilerError moduleTypeCheckError sourcePath phase err = - "Module typecheck failed for " - ++ sourcePath - ++ " (" - ++ phase - ++ "):\n" - ++ err + decorateCompilerDiagnosticContext + ("module typecheck failed for " ++ sourcePath ++ " (" ++ phase ++ ")") + err + +decorateDiagnosticContext :: String -> String -> String +decorateDiagnosticContext context err = + compilerErrorText (decorateCompilerDiagnosticContext context (compilerErrorFromString err)) + +decorateCompilerDiagnosticContext :: String -> CompilerError -> CompilerError +decorateCompilerDiagnosticContext context (CompilerDiagnostics diagnostics) = + CompilerDiagnostics (map (addDiagnosticNote context) diagnostics) +decorateCompilerDiagnosticContext context (CompilerLegacyError err) = + CompilerLegacyError (context ++ ":\n" ++ err) prepareInferenceDeclsForTypeInference :: Option -> Bool -> [Import] -> [ModuleInferenceDecl] -> - ExceptT String IO [ModuleInferenceDecl] + ExceptT CompilerError IO [ModuleInferenceDecl] prepareInferenceDeclsForTypeInference opts emitOutput imps inferenceDecls = do let verbose = emitOutput && optVerbose opts noDesugarCalls = optNoDesugarCalls opts @@ -292,9 +835,10 @@ prepareInferenceDeclsForTypeInference opts emitOutput imps inferenceDecls = do -- SCC analysis connected <- ExceptT $ - timeItNamed "SCC " $ - runExceptT $ - traverseModuleInferenceTopDecls (ExceptT . sccAnalysisTopDecls) dispatched + fmap (first compilerErrorFromString) $ + timeItNamed "SCC " $ + runExceptT $ + traverseModuleInferenceTopDecls (ExceptT . sccAnalysisTopDecls) dispatched liftIO $ when verbose $ do putStrLn "> SCC Analysis:" diff --git a/test/DiagnosticCliTests.hs b/test/DiagnosticCliTests.hs new file mode 100644 index 000000000..faaed2adf --- /dev/null +++ b/test/DiagnosticCliTests.hs @@ -0,0 +1,311 @@ +module DiagnosticCliTests where + +import Data.List (isSuffixOf, stripPrefix) +import System.Directory (doesFileExist, findExecutable, getCurrentDirectory) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.Process (readProcessWithExitCode) +import Test.Tasty +import Test.Tasty.HUnit + +diagnosticCliTests :: TestTree +diagnosticCliTests = + testGroup + "Diagnostic CLI snapshots" + [ testCase "parser error" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/parse-error.solc", "--no-specialise"] + [ "error[SC0001]: parse error: unexpected TArrow", + " --> /test/diagnostics/parse-error.solc:1:16", + " |", + "1 | function main( -> word { return 0; }", + " | ^^ unexpected token" + ], + testCase "undefined name" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/undefined-name.solc", "--no-specialise"] + [ "error[SC0101]: undefined name: missing", + " --> /test/diagnostics/undefined-name.solc:1:34", + " |", + "1 | function main() -> word { return missing; }", + " | ^^^^^^^ unknown name", + "note: in: return missing ;", + "note: in: function main () -> word {", + " return missing ;", + " }", + "note: module validation failed for /test/diagnostics/undefined-name.solc" + ], + testCase "duplicate definition" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/duplicate-definition.solc", "--no-specialise"] + [ "error[SC0108]: duplicate declarations in term namespace", + " --> /test/diagnostics/duplicate-definition.solc:2:10", + " |", + "1 | function foo() -> word { return 1; }", + " | --- previous definition", + "2 | function foo() -> word { return 2; }", + " | ^^^ duplicate definition", + "note: context: module", + "note: foo", + "note: module validation failed for /test/diagnostics/duplicate-definition.solc", + "help: rename or remove the duplicate declaration" + ], + testCase "type mismatch" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/type-mismatch.solc", "--no-specialise"] + [ "error[SC0201]: types do not unify: bool and word", + " --> /test/diagnostics/type-mismatch.solc:1:34", + " |", + "1 | function main() -> word { return true; }", + " | ^^^^ expression has mismatched type", + "note: left type: bool", + "note: right type: word", + "note: in: true", + "note: in: function main () -> word {", + " return true;", + " }", + "note: module typecheck failed for /test/diagnostics/type-mismatch.solc (no desugaring)" + ], + testCase "missing signature uses signature span" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/missing-signature.solc", "--no-specialise"] + [ "error[SC0220]: top-level function must have complete type annotations", + " --> /test/diagnostics/missing-signature.solc:1:10", + " |", + "1 | function foo() {", + " | ^^^ incomplete signature", + "note: signature: function foo ()", + "note: module typecheck failed for /test/diagnostics/missing-signature.solc (no desugaring)", + "help: annotate every parameter (name : Type) and provide a return type (-> Type)" + ], + testCase "polymorphic type error uses signature span" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/not-polymorphic-enough.solc", "--no-specialise"] + [ "error[SC0209]: type is not polymorphic enough", + " --> /test/diagnostics/not-polymorphic-enough.solc:1:21", + " |", + "1 | forall a . function fromWord(x : word) -> a {", + " | ^^^^^^^^ annotated type is not polymorphic enough", + "note: annotated type: forall a . word -> a", + "note: inferred type: word -> word", + "note: in: forall a . function fromWord (x : word) -> a", + "note: in: forall a . function fromWord (x : word) -> a {", + " let result ;", + " assembly {", + " result := x", + " }", + " return result;", + " }", + "note: module typecheck failed for /test/diagnostics/not-polymorphic-enough.solc (no desugaring)" + ], + testCase "missing instance" $ + expectFailure + ["--root", "test/examples/cases", "--file", "test/examples/cases/missing-instance.solc", "--no-specialise"] + [ "error[SC0223]: cannot entail: word : Typedef (word)", + " --> /test/examples/cases/missing-instance.solc:12:14", + " |", + "12 | function load(ptr:word) -> word {", + " | ^^^^ unsolved constraint", + "note: using defined instances:", + "note: in: function load (ptr : word) -> word {", + " return Typedef.abs(MemoryType.load(ptr) : word);", + " }", + "note: in: instance word : MemoryType {", + " function load (ptr : word) -> word {", + " return Typedef.abs(MemoryType.load(ptr) : word);", + " }", + " }", + "note: module typecheck failed for /test/examples/cases/missing-instance.solc (no desugaring)", + "help: add a matching instance or strengthen the surrounding type context" + ], + testCase "dot shorthand constructor error" $ + expectFailure + ["--root", "test/examples/cases", "--file", "test/examples/cases/dot-expression-unknown-fail.solc", "--no-specialise"] + [ "error[SC0224]: no matching constructor for shorthand expression", + " --> /test/examples/cases/dot-expression-unknown-fail.solc:4:11", + " |", + "4 | return .Nope(1);", + " | ^^^^ shorthand constructor", + "note: constructor: .Nope", + "note: in: .Nope(1)", + "note: in: function bad () -> Option {", + " return .Nope(1);", + " }", + "note: module typecheck failed for /test/examples/cases/dot-expression-unknown-fail.solc (no desugaring)", + "help: use a constructor that is visible for the expected type" + ], + testCase "import error" $ + expectFailure + ["--root", "test/imports", "--file", "test/imports/select_unknown.solc", "--no-specialise"] + [ "error[SC0110]: unknown import item", + " --> /test/imports/select_unknown.solc:1:19", + " |", + "1 | import selectlib.{missing};", + " | ^^^^^^^ unknown import item", + "note: unknown selected imports:", + "note: selectlib.missing", + "help: check the imported module's exported names" + ], + testCase "loader error before graph keeps source span" $ + expectFailure + ["--root", "test/imports", "--file", "test/imports/external_lib_missing_fail.solc", "--no-specialise"] + [ "error[SC0118]: external library root is not configured: @missing", + " --> /test/imports/external_lib_missing_fail.solc:1:9", + " |", + "1 | import @missing.math.api;", + " | ^^^^^^^^^^^^^^^^ external library import", + "note: /test/imports/external_lib_missing_fail.solc", + "note: import @missing.math.api", + "help: pass --external-lib NAME=PATH for external imports" + ], + testCase "ambiguous selected import" $ + expectFailure + ["--root", "test/imports", "--file", "test/imports/amb_main.solc", "--no-specialise"] + [ "error[SC0120]: ambiguous selected imports", + " --> /test/imports/amb_main.solc:2:14", + " |", + "2 | import ambB.{pick};", + " | ^^^^ ambiguous selected import", + "note: pick imported from ambB, ambA", + "help: use an explicit module qualifier or narrow the selected imports" + ], + testCase "hidden constructor import" $ + expectFailure + ["--root", "test/imports", "--file", "test/imports/hidden_ctor_expr_fail.solc", "--no-specialise"] + [ "error[SC0101]: undefined name: Err", + " --> /test/imports/hidden_ctor_expr_fail.solc:4:16", + " |", + "4 | return Token.Err(0);", + " | ^^^ unknown name", + "note: in: return Token.Err(0) ;", + "note: in: function main () -> Token {", + " return Token.Err(0) ;", + " }", + "note: module validation failed for /test/imports/hidden_ctor_expr_fail.solc" + ], + testCase "short output" $ + expectFailure + ["--root", "test/diagnostics", "--file", "test/diagnostics/undefined-name.solc", "--no-specialise", "--diagnostic-format", "short"] + ["/test/diagnostics/undefined-name.solc:1:34: error[SC0101]: undefined name: missing"], + testCase "warnings always" $ + expectSuccess + ["--root", "test/examples/cases", "--file", "test/examples/cases/redundant-match.solc", "--no-specialise", "--warnings", "always"] + redundantWarningsSnapshot, + testCase "warnings never" $ + expectSuccess + ["--root", "test/examples/cases", "--file", "test/examples/cases/redundant-match.solc", "--no-specialise", "--warnings", "never"] + [], + testCase "warnings deny" $ + expectFailure + ["--root", "test/examples/cases", "--file", "test/examples/cases/redundant-match.solc", "--no-specialise", "--warnings", "deny"] + (map denyWarningLine redundantWarningsSnapshot) + ] + +expectSuccess :: [String] -> [String] -> Assertion +expectSuccess args expectedLines = do + exe <- solCoreExecutable + (exitCode, stdout, stderr) <- readProcessWithExitCode exe (stableDiagnosticArgs args) "" + assertEqual "exit code" ExitSuccess exitCode + assertEqual "stderr" "" stderr + cwd <- normalizePath <$> getCurrentDirectory + assertEqual "stdout" (unlinesNoTrailing expectedLines) (stripFinalNewline (normalizeOutput cwd stdout)) + +expectFailure :: [String] -> [String] -> Assertion +expectFailure args expectedLines = do + exe <- solCoreExecutable + (exitCode, stdout, stderr) <- readProcessWithExitCode exe (stableDiagnosticArgs args) "" + assertEqual "exit code" (ExitFailure 1) exitCode + assertEqual "stderr" "" stderr + cwd <- normalizePath <$> getCurrentDirectory + assertEqual "stdout" (unlinesNoTrailing expectedLines) (stripFinalNewline (normalizeOutput cwd stdout)) + +solCoreExecutable :: IO FilePath +solCoreExecutable = do + envExe <- lookupEnv "SOL_CORE_EXE" + pathExe <- findExecutable "sol-core" + cwd <- getCurrentDirectory + found <- + firstExisting + ( maybeToList envExe + ++ maybeToList pathExe + ++ [cwd "dist" "build" "sol-core" "sol-core"] + ) + case found of + Just exe -> pure exe + Nothing -> assertFailure "could not find sol-core executable" + +stableDiagnosticArgs :: [String] -> [String] +stableDiagnosticArgs args = + args ++ ["--diagnostic-width", "240"] + +firstExisting :: [FilePath] -> IO (Maybe FilePath) +firstExisting [] = pure Nothing +firstExisting (path : paths) = do + exists <- doesFileExist path + if exists then pure (Just path) else firstExisting paths + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just value) = [value] + +redundantWarningsSnapshot :: [String] +redundantWarningsSnapshot = + [ "warning[SC0301]: redundant pattern clause", + " --> /test/examples/cases/redundant-match.solc:6:7", + " |", + "6 | | Bool.True => return Bool.True;", + " | ^^^^^^^^^ redundant clause", + "note: clause: | Bool.True =>", + " return Bool.True;", + "note: in: match (x)", + "note: in: function f", + "help: remove this clause or make an earlier pattern more specific", + "", + "warning[SC0301]: redundant pattern clause", + " --> /test/examples/cases/redundant-match.solc:7:7", + " |", + "7 | | Bool.False => return Bool.False;", + " | ^^^^^^^^^^ redundant clause", + "note: clause: | Bool.False =>", + " return Bool.False;", + "note: in: match (x)", + "note: in: function f", + "help: remove this clause or make an earlier pattern more specific" + ] + +denyWarningLine :: String -> String +denyWarningLine "warning[SC0301]: redundant pattern clause" = + "error[SC0301]: redundant pattern clause" +denyWarningLine "help: remove this clause or make an earlier pattern more specific" = + "help: remove this clause or make an earlier pattern more specific\nhelp: pass --warnings=default, --warnings=always, or --warnings=never to allow this warning" +denyWarningLine line = line + +normalizeOutput :: FilePath -> String -> String +normalizeOutput cwd = + replace cwd "" . normalizePath + +normalizePath :: FilePath -> FilePath +normalizePath = + map (\c -> if c == '\\' then '/' else c) + +replace :: String -> String -> String -> String +replace needle replacement haystack + | null needle = haystack + | otherwise = + case stripPrefix needle haystack of + Just rest -> replacement ++ replace needle replacement rest + Nothing -> + case haystack of + [] -> [] + c : rest -> c : replace needle replacement rest + +stripFinalNewline :: String -> String +stripFinalNewline text + | "\n" `isSuffixOf` text = take (length text - 1) text + | otherwise = text + +unlinesNoTrailing :: [String] -> String +unlinesNoTrailing [] = "" +unlinesNoTrailing [line] = line +unlinesNoTrailing (line : rest) = line ++ "\n" ++ unlinesNoTrailing rest diff --git a/test/DiagnosticTests.hs b/test/DiagnosticTests.hs new file mode 100644 index 000000000..e7dbb1327 --- /dev/null +++ b/test/DiagnosticTests.hs @@ -0,0 +1,201 @@ +module DiagnosticTests where + +import Solcore.Diagnostics +import Test.Tasty +import Test.Tasty.HUnit + +diagnosticTests :: TestTree +diagnosticTests = + testGroup + "Diagnostics" + [ testCase "human diagnostic snapshot" test_humanDiagnosticSnapshot, + testCase "short diagnostic snapshot" test_shortDiagnosticSnapshot, + testCase "unicode diagnostic snapshot" test_unicodeDiagnosticSnapshot, + testCase "diagnostic notes wrap to configured width" test_diagnosticWidthWrapsNotes, + testCase "color always emits ANSI styles" test_colorAlwaysEmitsAnsi, + testCase "nearby labels share one snippet" test_nearbyLabelsShareOneSnippet, + testCase "diagnostic notes are deduplicated" test_diagnosticNotesAreDeduplicated, + testCase "source token spans are exact" test_sourceTokenSpansAreExact + ] + +test_humanDiagnosticSnapshot :: Assertion +test_humanDiagnosticSnapshot = + renderDiagnostic defaultDiagnosticRenderOptions sourceMap undefinedNameDiagnostic + @?= unlinesNoTrailing + [ "error[SC0101]: undefined name `missing`", + " --> main.solc:2:10", + " |", + "2 | return missing;", + " | ^^^^^^^ unknown name", + "note: names must be in scope", + "help: import it explicitly" + ] + +test_shortDiagnosticSnapshot :: Assertion +test_shortDiagnosticSnapshot = + renderDiagnostic + defaultDiagnosticRenderOptions {diagnosticFormat = DiagnosticShort} + sourceMap + undefinedNameDiagnostic + @?= "main.solc:2:10: error[SC0101]: undefined name `missing`" + +test_unicodeDiagnosticSnapshot :: Assertion +test_unicodeDiagnosticSnapshot = + renderDiagnostic + defaultDiagnosticRenderOptions {diagnosticUnicode = UnicodeAlways} + sourceMap + undefinedNameDiagnostic + @?= unlinesNoTrailing + [ "error[SC0101]: undefined name `missing`", + " ──> main.solc:2:10", + " │", + "2 │ return missing;", + " │ ^^^^^^^ unknown name", + "note: names must be in scope", + "help: import it explicitly" + ] + +test_diagnosticWidthWrapsNotes :: Assertion +test_diagnosticWidthWrapsNotes = + renderDiagnostic + defaultDiagnosticRenderOptions {diagnosticWidth = 24} + sourceMap + ( undefinedNameDiagnostic + { diagnosticNotes = ["alpha beta gamma delta epsilon"], + diagnosticHelp = [] + } + ) + @?= unlinesNoTrailing + [ "error[SC0101]: undefined name `missing`", + " --> main.solc:2:10", + " |", + "2 | return missing;", + " | ^^^^^^^ unknown name", + "note: alpha beta gamma", + " delta epsilon" + ] + +test_colorAlwaysEmitsAnsi :: Assertion +test_colorAlwaysEmitsAnsi = + renderDiagnostic + defaultDiagnosticRenderOptions {diagnosticColor = ColorAlways, diagnosticFormat = DiagnosticShort} + sourceMap + undefinedNameDiagnostic + @?= "main.solc:2:10: \ESC[1;31merror[SC0101]\ESC[0m: undefined name `missing`" + +test_nearbyLabelsShareOneSnippet :: Assertion +test_nearbyLabelsShareOneSnippet = + renderDiagnostic defaultDiagnosticRenderOptions duplicateSourceMap duplicateDiagnostic + @?= unlinesNoTrailing + [ "error[SC0108]: duplicate declarations", + " --> dup.solc:2:10", + " |", + "1 | function foo() -> word { return 1; }", + " | --- previous definition", + "2 | function foo() -> word { return 2; }", + " | ^^^ duplicate definition" + ] + +test_diagnosticNotesAreDeduplicated :: Assertion +test_diagnosticNotesAreDeduplicated = + diagnosticNotes + ( addDiagnosticNote + "in: main" + (addDiagnosticNote "in: main" undefinedNameDiagnostic) + ) + @?= ["names must be in scope", "in: main"] + +test_sourceTokenSpansAreExact :: Assertion +test_sourceTokenSpansAreExact = + map spanStartColumn (findTokenSpansInSource tokenSourceFile "missing") + @?= [20] + where + tokenSourceFile = + makeSourceFile "tokens.solc" "let missingValue = missing;" + +sourceMap :: SourceMap +sourceMap = + sourceMapFromFiles [sourceFile] + +sourceFile :: SourceFile +sourceFile = + makeSourceFile "main.solc" (unlines ["function main() -> word {", " return missing;", "}"]) + +duplicateSourceMap :: SourceMap +duplicateSourceMap = + sourceMapFromFiles [duplicateSourceFile] + +duplicateSourceFile :: SourceFile +duplicateSourceFile = + makeSourceFile "dup.solc" (unlines ["function foo() -> word { return 1; }", "function foo() -> word { return 2; }"]) + +undefinedNameDiagnostic :: Diagnostic +undefinedNameDiagnostic = + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0101"), + diagnosticMessage = "undefined name `missing`", + diagnosticLabels = + [ Label + { labelSpan = + SourceSpan + { spanFile = "main.solc", + spanStartByte = 34, + spanEndByte = 41, + spanStartLine = 2, + spanStartColumn = 10, + spanEndLine = 2, + spanEndColumn = 17 + }, + labelStyle = Primary, + labelMessage = Just "unknown name" + } + ], + diagnosticNotes = ["names must be in scope"], + diagnosticHelp = ["import it explicitly"] + } + +duplicateDiagnostic :: Diagnostic +duplicateDiagnostic = + Diagnostic + { diagnosticSeverity = Error, + diagnosticCode = Just (DiagnosticCode "SC0108"), + diagnosticMessage = "duplicate declarations", + diagnosticLabels = + [ Label + { labelSpan = + SourceSpan + { spanFile = "dup.solc", + spanStartByte = 9, + spanEndByte = 12, + spanStartLine = 1, + spanStartColumn = 10, + spanEndLine = 1, + spanEndColumn = 13 + }, + labelStyle = Secondary, + labelMessage = Just "previous definition" + }, + Label + { labelSpan = + SourceSpan + { spanFile = "dup.solc", + spanStartByte = 47, + spanEndByte = 50, + spanStartLine = 2, + spanStartColumn = 10, + spanEndLine = 2, + spanEndColumn = 13 + }, + labelStyle = Primary, + labelMessage = Just "duplicate definition" + } + ], + diagnosticNotes = [], + diagnosticHelp = [] + } + +unlinesNoTrailing :: [String] -> String +unlinesNoTrailing [] = "" +unlinesNoTrailing [line] = line +unlinesNoTrailing (line : rest) = line ++ "\n" ++ unlinesNoTrailing rest diff --git a/test/LocationTests.hs b/test/LocationTests.hs new file mode 100644 index 000000000..3691b9b50 --- /dev/null +++ b/test/LocationTests.hs @@ -0,0 +1,185 @@ +module LocationTests + ( locationTests, + ) +where + +import Data.Generics (Data, everything, mkQ) +import Data.Maybe (mapMaybe) +import Data.Set qualified as Set +import Solcore.Diagnostics (CompilerError, SourceSpan (..), compilerErrorText) +import Solcore.Frontend.Parser.SolcoreParser (parseCompUnitWithPath) +import Solcore.Frontend.Syntax qualified as Typed +import Solcore.Frontend.Syntax.Location +import Solcore.Frontend.Syntax.NameResolution (nameResolution) +import Solcore.Frontend.Syntax.SyntaxTree qualified as Parsed +import Solcore.Frontend.TypeInference.SccAnalysis (sccAnalysis) +import Solcore.Frontend.TypeInference.TcModule +import Solcore.Pipeline.Options (noDesugarOpt) +import Test.Tasty +import Test.Tasty.HUnit + +locationTests :: TestTree +locationTests = + testGroup + "Syntax locations" + [ testCase "parsed nodes carry source locations" test_parsedNodesCarrySourceLocations, + testCase "generated nodes are explicit" test_generatedNodesAreExplicit, + testCase "name resolution preserves source locations" test_nameResolutionPreservesSourceLocations, + testCase "SCC analysis preserves source locations" test_sccAnalysisPreservesSourceLocations, + testCase "type inference preserves source locations" test_typeInferencePreservesSourceLocations + ] + +test_parsedNodesCarrySourceLocations :: Assertion +test_parsedNodesCarrySourceLocations = do + parsed <- parseCompUnitWithPath "location-invariant.solc" locatedSource + unit <- + case parsed of + Left err -> assertFailure err + Right cunit -> pure cunit + assertBool "compilation unit should have a source span" (hasSourceSpan unit) + assertBool "parser sample should exercise located AST nodes" (length (nodeLocationsOf unit) > 8) + assertEqual "generated node locations in parser output" [] (filter isGeneratedNodeLocation (nodeLocationsOf unit)) + +test_generatedNodesAreExplicit :: Assertion +test_generatedNodesAreExplicit = do + assertBool "unlocatedNode is generated" (isGeneratedNodeLocation unlocatedNode) + assertEqual "generated source span" Nothing (nodeLocationSpan unlocatedNode) + assertEqual "source node span" (Just sampleSpan) (nodeLocationSpan (locatedNode sampleSpan)) + +test_nameResolutionPreservesSourceLocations :: Assertion +test_nameResolutionPreservesSourceLocations = do + parsed <- parseUnit "location-name-resolution.solc" transformSource + resolved <- assertCompilerRight "name resolution" (nameResolution parsed) + assertSpansPreserved "name resolution" parsed resolved + assertNoGeneratedNodeLocations "name resolution" resolved + +test_sccAnalysisPreservesSourceLocations :: Assertion +test_sccAnalysisPreservesSourceLocations = do + parsed <- parseUnit "location-scc.solc" mutualSource + resolved <- assertCompilerRight "name resolution" (nameResolution parsed) + grouped <- assertEitherRight "SCC analysis" =<< sccAnalysis resolved + assertBool "SCC analysis should create a mutual group" (any isMutualDecl (Typed.contracts grouped)) + assertSpansPreserved "SCC analysis" resolved grouped + assertNoGeneratedNodeLocations "SCC analysis" grouped + +test_typeInferencePreservesSourceLocations :: Assertion +test_typeInferencePreservesSourceLocations = do + parsed <- parseUnit "location-type-inference.solc" transformSource + resolved <- assertCompilerRight "name resolution" (nameResolution parsed) + (typedUnit, _) <- + assertCompilerRight + "type inference" + (typeInferModuleLocals noDesugarOpt (moduleInputFromUnit resolved)) + assertSpansPreserved "type inference" resolved typedUnit + +hasSourceSpan :: (HasSourceSpan a) => a -> Bool +hasSourceSpan = + maybe False (const True) . sourceSpanOf + +parseUnit :: FilePath -> String -> IO Parsed.CompUnit +parseUnit path source = do + parsed <- parseCompUnitWithPath path source + case parsed of + Left err -> assertFailure err + Right cunit -> pure cunit + +assertCompilerRight :: String -> IO (Either CompilerError a) -> IO a +assertCompilerRight label action = do + result <- action + case result of + Left err -> assertFailure (label ++ " failed:\n" ++ compilerErrorText err) + Right value -> pure value + +assertEitherRight :: String -> Either String a -> IO a +assertEitherRight label result = + case result of + Left err -> assertFailure (label ++ " failed:\n" ++ err) + Right value -> pure value + +assertSpansPreserved :: (Data source, Data target) => String -> source -> target -> Assertion +assertSpansPreserved label source target = do + let sourceSpans = Set.fromList (sourceSpansOf source) + targetSpans = Set.fromList (sourceSpansOf target) + introduced = Set.toList (targetSpans `Set.difference` sourceSpans) + assertBool (label ++ " should keep source spans") (not (Set.null targetSpans)) + assertEqual (label ++ " introduced non-input source spans") [] introduced + +assertNoGeneratedNodeLocations :: (Data a) => String -> a -> Assertion +assertNoGeneratedNodeLocations label value = + assertEqual + (label ++ " generated node locations") + [] + (filter isGeneratedNodeLocation (nodeLocationsOf value)) + +sourceSpansOf :: (Data a) => a -> [SourceSpan] +sourceSpansOf value = + mapMaybe nodeLocationSpan (nodeLocationsOf value) + ++ everything (++) (mkQ [] nameSpan) value + where + nameSpan :: Typed.Name -> [SourceSpan] + nameSpan name = maybe [] pure (sourceSpanOf name) + +moduleInputFromUnit :: Typed.CompUnit Typed.Name -> ModuleTypeCheckInput +moduleInputFromUnit unit = + withPreparedModuleInferenceDecls resolvedInput (moduleInitialInferenceDecls resolvedInput) + where + resolvedInput = + ModuleResolvedTypeCheckInput + { moduleResolvedInputImports = Typed.imports unit, + moduleResolvedInputQualifiedDecls = [], + moduleResolvedInputLocalDecls = Typed.contracts unit, + moduleResolvedInputImportedDecls = [], + moduleResolvedInputTrustedInstanceHeads = [], + moduleResolvedInputPartialImportedTypes = [] + } + +isMutualDecl :: Typed.TopDecl a -> Bool +isMutualDecl (Typed.TMutualDef _) = True +isMutualDecl _ = False + +sampleSpan :: SourceSpan +sampleSpan = + SourceSpan + { spanFile = "generated.solc", + spanStartByte = 0, + spanEndByte = 1, + spanStartLine = 1, + spanStartColumn = 1, + spanEndLine = 1, + spanEndColumn = 2 + } + +locatedSource :: String +locatedSource = + unlines + [ "data Bool = True | False;", + "function main(x : word) -> word {", + " let y : word = x + 1;", + " match Bool.True {", + " | Bool.True => return y;", + " | _ => return 0;", + " }", + "}" + ] + +transformSource :: String +transformSource = + unlines + [ "function id(x : word) -> word {", + " return x;", + "}", + "function passthrough(y : word) -> word {", + " return id(y);", + "}" + ] + +mutualSource :: String +mutualSource = + unlines + [ "function first(x : word) -> word {", + " return second(x);", + "}", + "function second(x : word) -> word {", + " return first(x);", + "}" + ] diff --git a/test/Main.hs b/test/Main.hs index 77ba788ae..71520fd7b 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,10 @@ module Main where import Cases +import DiagnosticCliTests +import DiagnosticTests import HullCases +import LocationTests import MatchCompilerTests import ModuleTypeCheckTests import Test.Tasty @@ -18,6 +21,9 @@ tests = pragmas, spec, std, + diagnosticCliTests, + diagnosticTests, + locationTests, imports, moduleTypeCheckTests, dispatches, diff --git a/test/MatchCompilerTests.hs b/test/MatchCompilerTests.hs index 0f61b005b..fb8863296 100644 --- a/test/MatchCompilerTests.hs +++ b/test/MatchCompilerTests.hs @@ -133,11 +133,11 @@ assertLeft label act = do assertFailure (label ++ ": expected error but got tree: " ++ show tree) isNonExh :: Warning -> Bool -isNonExh (NonExhaustive _ _) = True +isNonExh (NonExhaustive _ _ _) = True isNonExh _ = False isRedundant :: Warning -> Bool -isRedundant (RedundantClause _ _ _) = True +isRedundant (RedundantClause _ _ _ _) = True isRedundant _ = False branchNames :: [(Id, [Pattern], DecisionTree)] -> [String] @@ -298,7 +298,7 @@ test_redundantVarRow_emitsRedundantClause = case tree of Leaf _ _ -> pure () _ -> assertFailure ("expected Leaf for all-var first row, got: " ++ show tree) - let redundantActs = [act | RedundantClause _ _ act <- warns] + let redundantActs = [act | RedundantClause _ _ _ act <- warns] assertBool "True clause must be warned as unreachable" (actionB `elem` redundantActs) assertBool "False clause must be warned as unreachable" (actionC `elem` redundantActs) assertBool "first all-var row must not be warned as redundant" (actionA `notElem` redundantActs) @@ -583,7 +583,7 @@ test_allVar_first_shadows_nonexhaustive_rest = case tree of Leaf _ _ -> pure () _ -> assertFailure ("expected Leaf, got: " ++ show tree) - let redundantActs = [act | RedundantClause _ _ act <- warns] + let redundantActs = [act | RedundantClause _ _ _ act <- warns] assertBool "True clause must be warned as unreachable" (actionB `elem` redundantActs) assertBool "first all-var row must not be warned" (actionA `notElem` redundantActs) @@ -607,7 +607,7 @@ test_twoCol_noFalsePositive_partialOverlap = [actionA, actionB, actionC] ) $ \_ warns -> do - let redundantActs = [act | RedundantClause _ _ act <- warns] + let redundantActs = [act | RedundantClause _ _ _ act <- warns] assertBool "row 1 (w,True) must NOT be warned as redundant" (actionB `notElem` redundantActs) assertBool "row 2 (a,b) must NOT be warned as redundant" (actionC `notElem` redundantActs) assertBool "no RedundantClause warnings at all" (null redundantActs) @@ -631,7 +631,7 @@ test_twoCol_genuinelyRedundant_thirdRow = [actionA, actionB, actionC] ) $ \_ warns -> do - let redundantActs = [act | RedundantClause _ _ act <- warns] + let redundantActs = [act | RedundantClause _ _ _ act <- warns] assertBool "row 2 (z,True) must be warned as redundant" (actionC `elem` redundantActs) assertBool "row 0 must not be warned" (actionA `notElem` redundantActs) assertBool "row 1 must not be warned" (actionB `notElem` redundantActs) @@ -650,7 +650,7 @@ test_singleCol_duplicateRow_warned = [actionA, actionB, actionC] ) $ \_ warns -> do - let redundantActs = [act | RedundantClause _ _ act <- warns] + let redundantActs = [act | RedundantClause _ _ _ act <- warns] assertBool "second True must be warned as redundant" (actionB `elem` redundantActs) assertBool "False must not be warned as redundant" (actionC `notElem` redundantActs) assertBool "first True must not be warned" (actionA `notElem` redundantActs) @@ -674,7 +674,7 @@ test_twoCol_con_nonExh_witness_has_both_columns = [actionA] ) $ \_ warns -> do - let nonExhPats = [pats | NonExhaustive _ pats <- warns] + let nonExhPats = [pats | NonExhaustive _ _ pats <- warns] case nonExhPats of [] -> assertFailure "expected a NonExhaustive warning" (pats : _) -> do @@ -707,7 +707,7 @@ test_twoCol_lit_nonExh_witness_has_both_columns = [actionA] ) $ \_ warns -> do - let nonExhPats = [pats | NonExhaustive _ pats <- warns] + let nonExhPats = [pats | NonExhaustive _ _ pats <- warns] case nonExhPats of [] -> assertFailure "expected a NonExhaustive warning" (pats : _) -> @@ -817,7 +817,7 @@ test_nonExh_polyEnv_missingNil_witness_is_Nil = [actionA] ) $ \_ warns -> do - let nonExhPats = [pats | NonExhaustive _ pats <- warns] + let nonExhPats = [pats | NonExhaustive _ _ pats <- warns] case nonExhPats of [] -> assertFailure "expected a NonExhaustive warning" (pats : _) -> case pats of @@ -848,7 +848,7 @@ test_nonExh_polyEnv_missingCons_witness_is_Cons = [actionA] ) $ \_ warns -> do - let nonExhPats = [pats | NonExhaustive _ pats <- warns] + let nonExhPats = [pats | NonExhaustive _ _ pats <- warns] case nonExhPats of [] -> assertFailure "expected a NonExhaustive warning" (pats : _) -> case pats of diff --git a/test/ModuleTypeCheckTests.hs b/test/ModuleTypeCheckTests.hs index 5b20d45f3..3c9f9ad1e 100644 --- a/test/ModuleTypeCheckTests.hs +++ b/test/ModuleTypeCheckTests.hs @@ -3,6 +3,7 @@ module ModuleTypeCheckTests ) where +import Solcore.Diagnostics (CompilerError, compilerErrorText) import Solcore.Frontend.Syntax import Solcore.Frontend.TypeInference.TcModule import Solcore.Pipeline.Options (noDesugarOpt) @@ -57,12 +58,12 @@ moduleTypeCheckTests = assertLeft "local body should be checked" result ] -assertRight :: String -> Either String a -> Assertion +assertRight :: String -> Either CompilerError a -> Assertion assertRight _ (Right _) = pure () assertRight label (Left err) = - assertFailure (label ++ ": unexpected failure:\n" ++ err) + assertFailure (label ++ ": unexpected failure:\n" ++ compilerErrorText err) -assertLeft :: String -> Either String a -> Assertion +assertLeft :: String -> Either CompilerError a -> Assertion assertLeft _ (Left _) = pure () assertLeft label (Right _) = assertFailure (label ++ ": expected failure") diff --git a/test/diagnostics/duplicate-definition.solc b/test/diagnostics/duplicate-definition.solc new file mode 100644 index 000000000..11e1185e3 --- /dev/null +++ b/test/diagnostics/duplicate-definition.solc @@ -0,0 +1,3 @@ +function foo() -> word { return 1; } +function foo() -> word { return 2; } +function main() -> word { return foo(); } diff --git a/test/diagnostics/missing-signature.solc b/test/diagnostics/missing-signature.solc new file mode 100644 index 000000000..059ca49d1 --- /dev/null +++ b/test/diagnostics/missing-signature.solc @@ -0,0 +1,3 @@ +function foo() { + return 1; +} diff --git a/test/diagnostics/not-polymorphic-enough.solc b/test/diagnostics/not-polymorphic-enough.solc new file mode 100644 index 000000000..7400c26ce --- /dev/null +++ b/test/diagnostics/not-polymorphic-enough.solc @@ -0,0 +1,5 @@ +forall a . function fromWord(x : word) -> a { + let result; + assembly { result := x } + return result; +} diff --git a/test/diagnostics/parse-error.solc b/test/diagnostics/parse-error.solc new file mode 100644 index 000000000..88b553a77 --- /dev/null +++ b/test/diagnostics/parse-error.solc @@ -0,0 +1 @@ +function main( -> word { return 0; } diff --git a/test/diagnostics/type-mismatch.solc b/test/diagnostics/type-mismatch.solc new file mode 100644 index 000000000..64d7ed2c4 --- /dev/null +++ b/test/diagnostics/type-mismatch.solc @@ -0,0 +1 @@ +function main() -> word { return true; } diff --git a/test/diagnostics/undefined-name.solc b/test/diagnostics/undefined-name.solc new file mode 100644 index 000000000..6aae2ad1e --- /dev/null +++ b/test/diagnostics/undefined-name.solc @@ -0,0 +1 @@ +function main() -> word { return missing; }