1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
|
{-# 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)
|
