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
|
{-# LANGUAGE QuasiQuotes #-}
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 Label
import Netencode qualified
import PossehlAnalyticsPrelude
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])
)
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
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
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)
|
