diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs new file mode 100644 index 00000000..520a813a --- /dev/null +++ b/.git-blame-ignore-revs @@ -0,0 +1,12 @@ +# This file lists commits that can be helpful to ignore when running git-blame. +# See: https://git-scm.com/docs/git-blame#Documentation/git-blame.txt---ignore-revs-fileltfilegt +# +# You can tell blame to always use this file with: +# +# git config blame.ignoreRevsFile .git-blame-ignore-revs +# +# GitHub also picks it up automatically: +# https://docs.github.com/en/repositories/working-with-files/using-files/viewing-and-understanding-files#ignore-commits-in-the-blame-view + +# Format with fourmolu +c06b1b1b68d039ab853e8fd18b5d0f24bd911d1b diff --git a/hoff.cabal b/hoff.cabal index 549d477f..b5bad9bb 100644 --- a/hoff.cabal +++ b/hoff.cabal @@ -33,6 +33,7 @@ library Metrics.Server MonadLoggerEffect Parser + Parser2 Project Server Time @@ -50,6 +51,7 @@ library , containers , cryptonite , directory + , Earley , effectful , extra , file-embed @@ -60,6 +62,7 @@ library , megaparsec , memory , monad-logger + , parser-combinators , process , process-extras , prometheus-client diff --git a/hoff.nix b/hoff.nix index 37a094df..c0bb6f4f 100644 --- a/hoff.nix +++ b/hoff.nix @@ -8,10 +8,10 @@ pkgs, mkDerivation # Haskell packages , QuickCheck, aeson, aeson-pretty, blaze-html, blaze-markup, bytestring -, containers, cryptonite, directory, effectful, extra, file-embed, filepath +, containers, cryptonite, directory, Earley, effectful, extra, file-embed, filepath , generic-arbitrary, github, hspec, hspec-core, http-client, http-conduit -, http-types, megaparsec, memory, monad-logger, optparse-applicative, process -, process-extras, prometheus, prometheus-metrics-ghc, quickcheck-instances +, http-types, megaparsec, memory, monad-logger, optparse-applicative, parser-combinators +, process, process-extras, prometheus, prometheus-metrics-ghc, quickcheck-instances , scotty, stm, text, text-format, time, uuid, vector, wai , wai-middleware-prometheus, warp, warp-tls }: mkDerivation { @@ -69,6 +69,7 @@ mkDerivation { containers cryptonite directory + Earley effectful extra file-embed @@ -84,6 +85,7 @@ mkDerivation { memory monad-logger optparse-applicative + parser-combinators process process-extras prometheus diff --git a/src/Parser2.hs b/src/Parser2.hs new file mode 100644 index 00000000..a4d892b4 --- /dev/null +++ b/src/Parser2.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecursiveDo #-} + +module Parser2 ( + parseComment, + Comment(..), + Command(..), +) where + +import Data.Functor (($>)) +import Data.Text (Text) +import Text.Earley (Grammar, list, rule, terminal, fullParses, (), namedToken, satisfy) +import Text.Earley qualified as Earley +import qualified Data.Text as Text +import qualified Data.List as List +import Control.Applicative.Combinators ((<|>)) + +import Project (ApprovedFor (..), DeployEnvironment (..), DeploySubprojects (..), MergeCommand (..), MergeWindow (..), Priority (..)) + +data Comment + = Skippable + | HasCommand Command + deriving Show + +data Command + = Command MergeCommand MergeWindow Priority + deriving Show + +parseComment :: Text -> Either (Earley.Report Token [Token]) Comment +parseComment = parse commentGrammar + +parse :: (forall r. Grammar r (Prod r a)) -> Text -> Either (Earley.Report Token [Token]) a +parse grammar input = + let + parser = Earley.parser grammar + tokens = tokenize input + in case fullParses parser tokens of + ([], report) -> Left report + (c : _, _) -> Right c + +tokenize :: Text -> [Token] +tokenize = + -- WIP(daan): deal with commas + Text.words + +type Token = Text + +type Prod r a = Earley.Prod r Token Token a + +commentGrammar :: Grammar r (Prod r Comment) +commentGrammar = + -- WIP(daan): parse skippable + -- WIP(daan): parse prefix, trigger word, and suffix + fmap HasCommand <$> commandGrammar + +commandGrammar :: Grammar r (Prod r Command) +commandGrammar = do + mergeCommand <- mergeCommandGrammar + + pure $ Command + <$> mergeCommand + <*> mergeWindow + <*> priority + +mergeCommandGrammar :: Grammar r (Prod r MergeCommand) +mergeCommandGrammar = do + approvedFor <- approvedForGrammar + + pure $ + Approve <$> approvedFor <|> "retry" $> Retry + +approvedForGrammar :: Grammar r (Prod r ApprovedFor) +approvedForGrammar = do + deploySubprojects <- deploySubprojectsGrammar + + let mergeAndDeploy = + MergeAndDeploy <$> deploySubprojects <*> deployEnvironment + + pure $ + "merge" + *> ( pure Merge + <|> "and" *> ( "deploy" *> mergeAndDeploy <|> "tag" $> MergeAndTag ) + ) + +deploySubprojectsGrammar :: Grammar r (Prod r DeploySubprojects) +deploySubprojectsGrammar = do + onlySubprojects <- sepBy1 (namedToken ",") subprojectName + + pure $ + pure EntireProject + <|> OnlySubprojects <$> onlySubprojects + +subprojectName :: Prod r Text +subprojectName = identifier "subproject name" + +deployEnvironment :: Prod r DeployEnvironment +deployEnvironment = + pure (DeployEnvironment "") + <|> "to" + *> (DeployEnvironment <$> identifier "environment name") + +identifier :: Prod r Token +identifier = + satisfy $ \tok -> + not (Text.null tok) && not (Text.any (== ',') tok) + +mergeWindow :: Prod r MergeWindow +mergeWindow = + pure AnyDay + <|> list ["on", "friday"] $> OnFriday + <|> list ["as", "hotfix"] $> DuringFeatureFreeze + +priority :: Prod r Priority +priority = + pure Normal + <|> list ["with", "priority"] $> High + +sepBy1 :: Earley.Prod r e t sep -> Earley.Prod r e t a -> Grammar r (Earley.Prod r e t [a]) +sepBy1 sep item = do + rec + prod <- rule $ + (List.singleton <$> item) + <|> ((:) <$> item <*> (sep *> prod)) + + pure prod