cd40585ea4
A simple categorical parser that does not implement Monad, and does not contain an `m` and some rudementary error message handling. In the future I’d probably want to wrap everything in an additional `m`, so that subparsers can somehow use `Selective` to throw errors from within `m` that contain the parsing context if at all possible. Hard to do without Monad, I have to say. Not even stuff like `StateT` works without the inner `m` implementing `Monad`. Change-Id: I1366eda606ddfb019637b09c82d8b0e30bd4e318 Reviewed-on: https://cl.tvl.fyi/c/depot/+/7797 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
112 lines
3.5 KiB
Haskell
112 lines
3.5 KiB
Haskell
{-# LANGUAGE ApplicativeDo #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DerivingVia #-}
|
|
{-# LANGUAGE GHC2021 #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedRecordDot #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoFieldSelectors #-}
|
|
{-# OPTIONS_GHC -Wall #-}
|
|
|
|
module Netencode.Parse where
|
|
|
|
import Control.Category qualified
|
|
import Control.Selective (Selective)
|
|
import Data.Error.Tree
|
|
import Data.Fix (Fix (..))
|
|
import Data.Functor.Compose
|
|
import Data.List qualified as List
|
|
import Data.Map.NonEmpty (NEMap)
|
|
import Data.Map.NonEmpty qualified as NEMap
|
|
import Data.Semigroupoid qualified as Semigroupiod
|
|
import Data.Semigroupoid qualified as Semigroupoid
|
|
import Data.Text qualified as Text
|
|
import MyPrelude
|
|
import Netencode qualified
|
|
import Prelude hiding (log)
|
|
|
|
newtype Parse from to
|
|
= -- TODO: the way @Context = [Text]@ has to be forwarded to everything is kinda shitty.
|
|
-- This is essentially just a difference list, and can probably be treated as a function in the output?
|
|
Parse (([Text], from) -> Validation (NonEmpty ErrorTree) ([Text], to))
|
|
deriving
|
|
(Functor, Applicative, Selective)
|
|
via ( Compose
|
|
( Compose
|
|
((->) ([Text], from))
|
|
(Validation (NonEmpty ErrorTree))
|
|
)
|
|
((,) [Text])
|
|
)
|
|
|
|
runParse :: Error -> Parse from to -> from -> Either ErrorTree to
|
|
runParse errMsg parser t =
|
|
(["$"], t)
|
|
& runParse' parser
|
|
<&> snd
|
|
& first (nestedMultiError errMsg)
|
|
& validationToEither
|
|
|
|
runParse' :: Parse from to -> ([Text], from) -> Validation (NonEmpty ErrorTree) ([Text], to)
|
|
runParse' (Parse f) from = f from
|
|
|
|
instance Semigroupoid Parse where
|
|
o p2 p1 = Parse $ \from -> case runParse' p1 from of
|
|
Failure err -> Failure err
|
|
Success to1 -> runParse' p2 to1
|
|
|
|
instance Category Parse where
|
|
(.) = Semigroupoid.o
|
|
id = Parse $ \t -> Success t
|
|
|
|
parseEither :: (([Text], from) -> Either ErrorTree ([Text], to)) -> Parse from to
|
|
parseEither f = Parse $ \from -> f from & eitherToListValidation
|
|
|
|
tAs :: (Netencode.TF (Fix Netencode.TF) -> Either ([Text] -> ErrorTree) to) -> Parse Netencode.T to
|
|
tAs f = parseEither ((\(context, Netencode.T (Fix tf)) -> f tf & bimap ($ context) (context,)))
|
|
|
|
key :: Text -> Parse (NEMap Text to) to
|
|
key name = parseEither $ \(context, rec) ->
|
|
rec
|
|
& NEMap.lookup name
|
|
& annotate (errorTreeContext (showContext context) [fmt|Key "{name}" does not exist|])
|
|
<&> (addContext name context,)
|
|
|
|
showContext :: [Text] -> Text
|
|
showContext context = context & List.reverse & Text.intercalate "."
|
|
|
|
addContext :: a -> [a] -> [a]
|
|
addContext = (:)
|
|
|
|
asText :: Parse Netencode.T Text
|
|
asText = tAs $ \case
|
|
Netencode.Text t -> pure t
|
|
other -> typeError "of text" other
|
|
|
|
asBytes :: Parse Netencode.T ByteString
|
|
asBytes = tAs $ \case
|
|
Netencode.Bytes b -> pure b
|
|
other -> typeError "of bytes" other
|
|
|
|
asRecord :: Parse Netencode.T (NEMap Text (Netencode.T))
|
|
asRecord = tAs $ \case
|
|
Netencode.Record rec -> pure (rec <&> Netencode.T)
|
|
other -> typeError "a record" other
|
|
|
|
typeError :: Text -> Netencode.TF ignored -> (Either ([Text] -> ErrorTree) b)
|
|
typeError should is = do
|
|
let otherS = is <&> (\_ -> ("…" :: String)) & show
|
|
Left $ \context -> errorTreeContext (showContext context) [fmt|Value is not {should}, but a {otherS}|]
|
|
|
|
orThrowParseError ::
|
|
Parse (Either Error to) to
|
|
orThrowParseError = Parse $ \case
|
|
(context, Left err) ->
|
|
err
|
|
& singleError
|
|
& errorTreeContext (showContext context)
|
|
& singleton
|
|
& Failure
|
|
(context, Right to) -> Success (context, to)
|