diff options
Diffstat (limited to 'users/Profpatsch/netencode')
| -rw-r--r-- | users/Profpatsch/netencode/Netencode.hs | 87 | ||||
| -rw-r--r-- | users/Profpatsch/netencode/Netencode/Parse.hs | 102 | ||||
| -rw-r--r-- | users/Profpatsch/netencode/README.md | 2 | ||||
| -rw-r--r-- | users/Profpatsch/netencode/default.nix | 5 | ||||
| -rw-r--r-- | users/Profpatsch/netencode/netencode.cabal | 66 |
5 files changed, 206 insertions, 56 deletions
diff --git a/users/Profpatsch/netencode/Netencode.hs b/users/Profpatsch/netencode/Netencode.hs index dfc57ce8dc..ca93ab2fef 100644 --- a/users/Profpatsch/netencode/Netencode.hs +++ b/users/Profpatsch/netencode/Netencode.hs @@ -1,69 +1,57 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} module Netencode where import Control.Applicative (many) -import qualified Data.Attoparsec.ByteString as Atto -import qualified Data.Attoparsec.ByteString.Char8 as Atto.Char -import qualified Data.ByteString as ByteString +import Data.Attoparsec.ByteString qualified as Atto +import Data.Attoparsec.ByteString.Char8 qualified as Atto.Char +import Data.ByteString qualified as ByteString import Data.ByteString.Builder (Builder) -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Lazy as ByteString.Lazy -import Data.Coerce (coerce) +import Data.ByteString.Builder qualified as Builder +import Data.ByteString.Lazy qualified as ByteString.Lazy import Data.Fix (Fix (Fix)) -import qualified Data.Fix as Fix +import Data.Fix qualified as Fix import Data.Functor.Classes (Eq1 (liftEq)) import Data.Int (Int16, Int32, Int64, Int8) -import Data.List.NonEmpty (nonEmpty) import Data.Map.NonEmpty (NEMap) -import qualified Data.Map.NonEmpty as NEMap -import qualified Data.Semigroup as Semi +import Data.Map.NonEmpty qualified as NEMap +import Data.Semigroup qualified as Semi import Data.String (IsString) import Data.Word (Word16, Word32, Word64) import GHC.Exts (fromString) -import qualified Hedgehog as Hedge -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import MyPrelude +import Hedgehog qualified as Hedge +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PossehlAnalyticsPrelude import Text.Show.Deriving import Prelude hiding (sum) -import Data.Maybe (fromMaybe) - -- | Netencode type base functor. -- -- Recursive elements have a @rec@. data TF rec - = Unit - -- ^ Unit value - | N1 Bool - -- ^ Boolean (2^1) - | N3 Word8 - -- ^ Byte (2^3) - | N6 Word64 - -- ^ 64-bit Natural (2^6) - | I6 Int64 - -- ^ 64-bit Integer (2^6) - | Text Text - -- ^ Unicode Text - | Bytes ByteString - -- ^ Arbitrary Bytestring - | Sum (Tag Text rec) - -- ^ A constructor of a(n open) Sum - | Record (NEMap Text rec) - -- ^ Record - | List [rec] - -- ^ List + = -- | Unit value + Unit + | -- | Boolean (2^1) + N1 Bool + | -- | Byte (2^3) + N3 Word8 + | -- | 64-bit Natural (2^6) + N6 Word64 + | -- | 64-bit Integer (2^6) + I6 Int64 + | -- | Unicode Text + Text Text + | -- | Arbitrary Bytestring + Bytes ByteString + | -- | A constructor of a(n open) Sum + Sum (Tag Text rec) + | -- | Record + Record (NEMap Text rec) + | -- | List + List [rec] deriving stock (Show, Eq, Functor) instance Eq1 TF where @@ -74,7 +62,7 @@ instance Eq1 TF where liftEq _ (I6 i64) (I6 i64') = i64 == i64' liftEq _ (Text t) (Text t') = t == t' liftEq _ (Bytes b) (Bytes b') = b == b' - liftEq eq (Sum t) (Sum t') = eq (t & tagVal) (t' & tagVal) + liftEq eq (Sum t) (Sum t') = eq (t.tagVal) (t'.tagVal) liftEq eq (Record m) (Record m') = liftEq eq m m' liftEq eq (List xs) (List xs') = liftEq eq xs xs' liftEq _ _ _ = False @@ -90,7 +78,7 @@ $(Text.Show.Deriving.deriveShow1 ''Tag) $(Text.Show.Deriving.deriveShow1 ''TF) -- | The Netencode type -newtype T = T (Fix TF) +newtype T = T {unT :: Fix TF} deriving stock (Eq, Show) -- | Create a unit @@ -291,7 +279,8 @@ netencodeParserF inner = do Nothing -> fail "record is not allowed to have 0 elements" Just tags -> pure $ - tags <&> (\t -> (t & tagTag, t & tagVal)) + tags + <&> (\t -> (t.tagTag, t.tagVal)) -- later keys are preferred if they are duplicates, according to the standard & NEMap.fromList _ <- Atto.Char.char '}' Atto.<?> "record did not end with }" @@ -421,7 +410,9 @@ genNetencode = record <$> ( let k = Gen.text (Range.linear 3 10) Gen.lower v = genNetencode - in NEMap.insertMap <$> k <*> v + in NEMap.insertMap + <$> k + <*> v <*> ( (Gen.map (Range.linear 0 3)) $ (,) <$> k <*> v ) diff --git a/users/Profpatsch/netencode/Netencode/Parse.hs b/users/Profpatsch/netencode/Netencode/Parse.hs new file mode 100644 index 0000000000..184fb5f912 --- /dev/null +++ b/users/Profpatsch/netencode/Netencode/Parse.hs @@ -0,0 +1,102 @@ +{-# 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 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) diff --git a/users/Profpatsch/netencode/README.md b/users/Profpatsch/netencode/README.md index 840ffaedd0..3538a110a6 100644 --- a/users/Profpatsch/netencode/README.md +++ b/users/Profpatsch/netencode/README.md @@ -85,7 +85,7 @@ Similar to text, records start with the length of their *whole encoded content*, * A record with one empty field, `foo`: `{9:<3:foo|u,}` * A record with two fields, `foo` and `x`: `{21:<3:foo|u,<1:x|t3:baz,}` * The same record: `{21:<1:x|t3:baz,<3:foo|u,}` -* The same record (later occurences of fields are ignored): `{28:<1:x|t3:baz,<3:foo|u,<1:x|u,}` +* The same record (earlier occurences of fields are ignored): `{<1:x|u,28:<1:x|t3:baz,<3:foo|u,}` ### sums (tagged unions) diff --git a/users/Profpatsch/netencode/default.nix b/users/Profpatsch/netencode/default.nix index 00fadf6953..6e7dce489a 100644 --- a/users/Profpatsch/netencode/default.nix +++ b/users/Profpatsch/netencode/default.nix @@ -18,6 +18,7 @@ let src = depot.users.Profpatsch.exactSource ./. [ ./netencode.cabal ./Netencode.hs + ./Netencode/Parse.hs ]; libraryHaskellDepends = [ @@ -27,7 +28,9 @@ let pkgs.haskellPackages.data-fix pkgs.haskellPackages.bytestring pkgs.haskellPackages.attoparsec - depot.users.Profpatsch.my-prelude + pkgs.haskellPackages.pa-prelude + pkgs.haskellPackages.pa-label + pkgs.haskellPackages.pa-error-tree ]; isLibrary = true; diff --git a/users/Profpatsch/netencode/netencode.cabal b/users/Profpatsch/netencode/netencode.cabal index 23c09c9065..7bff4487bb 100644 --- a/users/Profpatsch/netencode/netencode.cabal +++ b/users/Profpatsch/netencode/netencode.cabal @@ -1,20 +1,74 @@ -cabal-version: 2.4 +cabal-version: 3.0 name: netencode version: 0.1.0.0 author: Profpatsch maintainer: mail@profpatsch.de + +common common-options + ghc-options: + -Wall + -Wno-type-defaults + -Wunused-packages + -Wredundant-constraints + -fwarn-missing-deriving-strategies + + -- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html + -- for a description of all these extensions + default-extensions: + -- Infer Applicative instead of Monad where possible + ApplicativeDo + + -- Allow literal strings to be Text + OverloadedStrings + + -- Syntactic sugar improvements + LambdaCase + MultiWayIf + + -- Makes the (deprecated) usage of * instead of Data.Kind.Type an error + NoStarIsType + + -- Convenient and crucial to deal with ambiguous field names, commonly + -- known as RecordDotSyntax + OverloadedRecordDot + + -- does not export record fields as functions, use OverloadedRecordDot to access instead + NoFieldSelectors + + -- Record punning + RecordWildCards + + -- Improved Deriving + DerivingStrategies + DerivingVia + + -- Type-level strings + DataKinds + + -- to enable the `type` keyword in import lists (ormolu uses this automatically) + ExplicitNamespaces + + default-language: GHC2021 + + library - exposed-modules: Netencode + import: common-options + exposed-modules: + Netencode, + Netencode.Parse build-depends: - base ^>=4.15.1.0, + base >=4.15 && <5, + pa-prelude, + pa-label, + pa-error-tree, hedgehog, nonempty-containers, deriving-compat, - my-prelude, data-fix, bytestring, attoparsec, - - default-language: Haskell2010 + text, + semigroupoids, + selective |