From 6abb7b9a2a2754d0ee574cf07611f9baf4f65a3f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 4 Jun 2018 18:17:02 -0400 Subject: [PATCH] tighten up some Maybes now that Unknown is a thing --- src/Parsing/Parser.hs | 48 +++++++++++++++++++++---------------------- src/Semantic/AST.hs | 3 +-- src/Semantic/Diff.hs | 4 ++-- src/Semantic/Parse.hs | 2 +- 4 files changed, 28 insertions(+), 29 deletions(-) diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 35d678bfe..c5c3c47b6 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -126,19 +126,19 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax) , ApplyAll typeclasses (Sum PHP.Syntax) ) => Language   -- ^ The 'Language' to select. - -> Parser (SomeTerm typeclasses (Record Location)) -- ^ A 'SomeParser' abstracting the syntax type to be produced. -someParser Go = SomeParser goParser -someParser Java = SomeParser javaParser -someParser JavaScript = SomeParser typescriptParser -someParser JSON = SomeParser jsonParser -someParser Haskell = SomeParser haskellParser -someParser JSX = SomeParser typescriptParser -someParser Markdown = SomeParser markdownParser -someParser Python = SomeParser pythonParser -someParser Ruby = SomeParser rubyParser -someParser TypeScript = SomeParser typescriptParser -someParser PHP = SomeParser phpParser -someParser Unknown = error "No parser suitable for an unknown language." + -> Maybe (Parser (SomeTerm typeclasses (Record Location))) -- ^ A 'SomeParser' abstracting the syntax type to be produced. +someParser Go = Just (SomeParser goParser) +someParser Java = Just (SomeParser javaParser) +someParser JavaScript = Just (SomeParser typescriptParser) +someParser JSON = Just (SomeParser jsonParser) +someParser Haskell = Just (SomeParser haskellParser) +someParser JSX = Just (SomeParser typescriptParser) +someParser Markdown = Just (SomeParser markdownParser) +someParser Python = Just (SomeParser pythonParser) +someParser Ruby = Just (SomeParser rubyParser) +someParser TypeScript = Just (SomeParser typescriptParser) +someParser PHP = Just (SomeParser phpParser) +someParser Unknown = Nothing goParser :: Parser Go.Term @@ -182,14 +182,14 @@ data SomeASTParser where => Parser (AST [] grammar) -> SomeASTParser -someASTParser :: Language -> SomeASTParser -someASTParser Go = SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar)) -someASTParser Haskell = SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar)) -someASTParser JavaScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser JSON = SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar)) -someASTParser JSX = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser Python = SomeASTParser (ASTParser tree_sitter_python :: Parser (AST [] Python.Grammar)) -someASTParser Ruby = SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar)) -someASTParser TypeScript = SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar)) -someASTParser PHP = SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar)) -someASTParser l = error $ "Tree-Sitter AST parsing not supported for: " <> show l +someASTParser :: Language -> Maybe SomeASTParser +someASTParser Go = Just (SomeASTParser (ASTParser tree_sitter_go :: Parser (AST [] Go.Grammar))) +someASTParser Haskell = Just (SomeASTParser (ASTParser tree_sitter_haskell :: Parser (AST [] Haskell.Grammar))) +someASTParser JavaScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser JSON = Just (SomeASTParser (ASTParser tree_sitter_json :: Parser (AST [] JSON.Grammar))) +someASTParser JSX = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser Python = Just (SomeASTParser (ASTParser tree_sitter_python :: Parser (AST [] Python.Grammar))) +someASTParser Ruby = Just (SomeASTParser (ASTParser tree_sitter_ruby :: Parser (AST [] Ruby.Grammar))) +someASTParser TypeScript = Just (SomeASTParser (ASTParser tree_sitter_typescript :: Parser (AST [] TypeScript.Grammar))) +someASTParser PHP = Just (SomeASTParser (ASTParser tree_sitter_php :: Parser (AST [] PHP.Grammar))) +someASTParser l = Nothing diff --git a/src/Semantic/AST.hs b/src/Semantic/AST.hs index a7b382732..292029172 100644 --- a/src/Semantic/AST.hs +++ b/src/Semantic/AST.hs @@ -18,8 +18,7 @@ withSomeAST f (SomeAST ast) = f ast astParseBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs SomeAST astParseBlob blob@Blob{..} - | Just (SomeASTParser parser) <- someASTParser <$> (Just blobLanguage) - = SomeAST <$> parse parser blob + | Just (SomeASTParser parser) <- someASTParser blobLanguage = SomeAST <$> parse parser blob | otherwise = noLanguageForBlob blobPath diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 9225a5cc1..d100e7e57 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -54,6 +54,6 @@ withParsedBlobPair :: (Member (Distribute WrappedTask) effs, Member (Exc SomeExc -> BlobPair -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields)) withParsedBlobPair decorate blobs - | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] <$> (Just (languageForBlobPair blobs)) - = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) + | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs) + = SomeTermPair <$> distributeFor blobs (\ blob -> WrapTask (parse parser blob >>= decorate blob)) | otherwise = noLanguageForBlob (pathForBlobPair blobs) diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index d8f84589b..42ff4b81a 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -31,4 +31,4 @@ withParsedBlobs :: (Member (Distribute WrappedTask) effs, Monoid output) => (for withParsedBlobs render = distributeFoldMap (\ blob -> WrapTask (parseSomeBlob blob >>= withSomeTerm (render blob))) parseSomeBlob :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs (SomeTerm '[ConstructorName, Foldable, Functor, HasDeclaration, HasPackageDef, Show1, ToJSONFields1] (Record Location)) -parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob . someParser) (ensureLanguage blobLanguage) +parseSomeBlob blob@Blob{..} = maybe (noLanguageForBlob blobPath) (flip parse blob) (someParser blobLanguage)