Boilerplate and minimal syntax for Haskell assignment

semantic.cabal

@@ -114,6 +114,9 @@ library
                      , Language.Go.Assignment
                      , Language.Go.Syntax
                      , Language.Go.Type
+                     , Language.Haskell.Grammar
+                     , Language.Haskell.Assignment
+                     , Language.Haskell.Syntax
                      , Language.JSON.Grammar
                      , Language.JSON.Assignment
                      , Language.Ruby.Grammar
@@ -206,6 +209,7 @@ library
                      , unordered-containers
                      , haskell-tree-sitter
                      , tree-sitter-go
+                     , tree-sitter-haskell
                      , tree-sitter-json
                      , tree-sitter-php
                      , tree-sitter-python

src/Data/Language.hs

@@ -7,6 +7,7 @@ import Data.Aeson
 -- | A programming language.
 data Language
     = Go
+    | Haskell
     | JavaScript
     | JSON
     | JSX
@@ -21,6 +22,7 @@ data Language
 languageForType :: String -> Maybe Language
 languageForType mediaType = case mediaType of
     ".json" -> Just JSON
+    ".hs" -> Just Haskell
     ".md" -> Just Markdown
     ".rb" -> Just Ruby
     ".go" -> Just Go
@@ -36,6 +38,7 @@ languageForType mediaType = case mediaType of
 extensionsForLanguage :: Language -> [String]
 extensionsForLanguage language = case language of
   Go -> [".go"]
+  Haskell -> [".hs"]
   JavaScript -> [".js"]
   PHP -> [".php"]
   Python -> [".py"]

src/Language/Haskell/Assignment.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE DataKinds, RankNTypes, TypeOperators #-}
+module Language.Haskell.Assignment
+( assignment
+, Syntax
+, Grammar
+, Term
+) where
+
+import Assigning.Assignment hiding (Assignment, Error)
+import Data.Record
+import Data.Sum
+import Data.Syntax (handleError, parseError, makeTerm, contextualize, postContextualize)
+import Language.Haskell.Grammar as Grammar
+import qualified Assigning.Assignment as Assignment
+import qualified Data.Abstract.FreeVariables as FV
+import qualified Data.Syntax as Syntax
+import qualified Data.Syntax.Comment as Comment
+import qualified Data.Term as Term
+import qualified Language.Haskell.Syntax as Syntax
+import Prologue
+
+type Syntax = '[
+    Comment.Comment
+  , Syntax.Context
+  , Syntax.Empty
+  , Syntax.Error
+  , Syntax.Identifier
+  , Syntax.Module
+  , Syntax.Program
+  , []
+  ]
+
+type Term = Term.Term (Sum Syntax) (Record Location)
+type Assignment' a = HasCallStack => Assignment.Assignment [] Grammar a
+type Assignment = Assignment' Term
+
+assignment :: Assignment
+assignment = handleError $ module' <|> parseError
+
+module' :: Assignment
+module' = makeTerm <$> symbol Module <*> children (Syntax.Module <$> moduleIdentifier <*> pure [] <*> (where' <|> pure []))
+
+expression :: Assignment
+expression = term (handleError (choice expressionChoices))
+
+expressionChoices :: [Assignment.Assignment [] Grammar Term]
+expressionChoices = [
+                      constructorIdentifier
+                    , moduleIdentifier
+                    , comment
+                    ]
+
+term :: Assignment -> Assignment
+term term = contextualize comment (postContextualize comment term)
+
+comment :: Assignment
+comment = makeTerm <$> symbol Comment <*> (Comment.Comment <$> source)
+
+constructorIdentifier :: Assignment
+constructorIdentifier = makeTerm <$> symbol ConstructorIdentifier <*> (Syntax.Identifier . FV.name <$> source)
+
+moduleIdentifier :: Assignment
+moduleIdentifier = makeTerm <$> symbol ModuleIdentifier <*> (Syntax.Identifier . FV.name <$> source)
+
+where' :: Assignment' [Term]
+where' = (symbol Where <|> symbol Where') *> children (many expression)

src/Language/Haskell/Grammar.hs

@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Language.Haskell.Grammar where
+
+import Language.Haskell.TH
+import TreeSitter.Language
+import TreeSitter.Haskell
+
+-- Regenerate template haskell code when these files change:
+addDependentFileRelative "../../../vendor/haskell-tree-sitter/languages/haskell/vendor/tree-sitter-haskell/src/parser.c"
+
+-- | Statically-known rules corresponding to symbols in the grammar.
+-- v2 - bump this to regenerate
+mkSymbolDatatype (mkName "Grammar") tree_sitter_haskell

src/Language/Haskell/Syntax.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveAnyClass #-}
+module Language.Haskell.Syntax where
+
+import           Data.Abstract.Evaluatable
+import           Data.JSON.Fields
+import           Diffing.Algorithm
+import           Prelude
+import           Prologue
+
+data Module a = Module { moduleIdentifier :: !a
+                       , moduleExports    :: ![a]
+                       , moduleStatements :: ![a]
+                       }
+  deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+
+instance Eq1 Module where liftEq = genericLiftEq
+instance Ord1 Module where liftCompare = genericLiftCompare
+instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
+
+instance ToJSONFields1 Module
+
+instance Evaluatable Module where
+  -- eval (Module identifier exports statements) = eval statements

src/Parsing/Parser.hs

@@ -18,6 +18,7 @@ module Parsing.Parser
 , rubyParser
 , typescriptParser
 , phpParser
+, haskellParser
 ) where
 
 import           Assigning.Assignment
@@ -33,6 +34,7 @@ import           Data.Project
 import           Foreign.Ptr
 import qualified GHC.TypeLits as TypeLevel
 import qualified Language.Go.Assignment as Go
+import qualified Language.Haskell.Assignment as Haskell
 import qualified Language.JSON.Assignment as JSON
 import qualified Language.Markdown.Assignment as Markdown
 import qualified Language.PHP.Assignment as PHP
@@ -48,6 +50,7 @@ import           TreeSitter.PHP
 import           TreeSitter.Python
 import           TreeSitter.Ruby
 import           TreeSitter.TypeScript
+import           TreeSitter.Haskell
 
 
 type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where
@@ -68,12 +71,14 @@ someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax
                       , ApplyAll' typeclasses Python.Syntax
                       , ApplyAll' typeclasses Ruby.Syntax
                       , ApplyAll' typeclasses TypeScript.Syntax
+                      , ApplyAll' typeclasses Haskell.Syntax
                       )
                    => proxy typeclasses                                -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@.
                    -> Language                                         -- ^ The 'Language' to select.
                    -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced.
 someAnalysisParser _ Go         = SomeAnalysisParser goParser Nothing
 someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath TypeScript.Term))) (Just JavaScript))
+someAnalysisParser _ Haskell    = SomeAnalysisParser haskellParser Nothing
 someAnalysisParser _ PHP        = SomeAnalysisParser phpParser Nothing
 someAnalysisParser _ Python     = SomeAnalysisParser pythonParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Python.Term))) (Just Python))
 someAnalysisParser _ Ruby       = SomeAnalysisParser rubyParser $ Just (File (TypeLevel.symbolVal (Proxy :: Proxy (PreludePath Ruby.Term))) (Just Ruby))
@@ -106,6 +111,7 @@ type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *
 --
 --   > runTask (parse (someParser @'[Show1] language) blob) >>= putStrLn . withSomeTerm show
 someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
+              , ApplyAll typeclasses (Sum Haskell.Syntax)
               , ApplyAll typeclasses (Sum JSON.Syntax)
               , ApplyAll typeclasses (Sum Markdown.Syntax)
               , ApplyAll typeclasses (Sum Python.Syntax)
@@ -118,6 +124,7 @@ someParser :: ( ApplyAll typeclasses (Sum Go.Syntax)
 someParser Go         = SomeParser goParser
 someParser JavaScript = SomeParser typescriptParser
 someParser JSON       = SomeParser jsonParser
+someParser Haskell    = SomeParser haskellParser
 someParser JSX        = SomeParser typescriptParser
 someParser Markdown   = SomeParser markdownParser
 someParser Python     = SomeParser pythonParser
@@ -144,6 +151,9 @@ jsonParser = AssignmentParser (ASTParser tree_sitter_json) JSON.assignment
 typescriptParser :: Parser TypeScript.Term
 typescriptParser = AssignmentParser (ASTParser tree_sitter_typescript) TypeScript.assignment
 
+haskellParser :: Parser Haskell.Term
+haskellParser = AssignmentParser (ASTParser tree_sitter_haskell) Haskell.assignment
+
 markdownParser :: Parser Markdown.Term
 markdownParser = AssignmentParser MarkdownParser Markdown.assignment
 
@@ -163,6 +173,7 @@ data SomeASTParser where
 
 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))