packages feed

iri 0.2 → 0.5.1.2

raw patch · 41 files changed

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
iri.cabal view
@@ -1,120 +1,169 @@-name:-  iri-version:-  0.2-category:-  IRI, URI, URL, Data, Network-synopsis:-  RFC-based International Resource Identifier library+cabal-version: 3.0+name: iri+version: 0.5.1.2+category: URI, URL, IRI, Network+synopsis: RFC-compliant universal resource identifier library (URL, URI, IRI) description:-  This library provides a universal data model for representation of both URI (URL) and IRI.+  This library provides a universal data model for representation of URI, URL and IRI.   It comes packed with parsing, rendering and serialisation functionality.   It is implemented in conformance with the RFC-3986 and RFC-3987 specifications and   is intended as a standard tool for all tasks related to resource identifiers.-  .-  The data is represented in Unicode,-  and the API automates all the encoding fuss.-homepage:-  https://github.com/nikita-volkov/iri -bug-reports:-  https://github.com/nikita-volkov/iri/issues -author:-  Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:-  Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:-  (c) 2017, Nikita Volkov-license:-  MIT-license-file:-  LICENSE-build-type:-  Simple-cabal-version:-  >=1.10 +homepage: https://github.com/nikita-volkov/iri+bug-reports: https://github.com/nikita-volkov/iri/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2017 Nikita Volkov+license: MIT+license-file: LICENSE+ source-repository head-  type:-    git-  location:-    git://github.com/nikita-volkov/iri.git+  type: git+  location: https://github.com/nikita-volkov/iri -library-  hs-source-dirs:-    library+common base+  default-language: Haskell2010   default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+    BangPatterns+    BlockArguments+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveFoldable+    DeriveFunctor+    DeriveGeneric+    DeriveTraversable+    DerivingStrategies+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    LambdaCase+    LiberalTypeSynonyms+    MagicHash+    MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    NumericUnderscores+    OverloadedStrings+    ParallelListComp+    PatternGuards+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    StrictData+    TemplateHaskell+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+    UnboxedTuples+    ViewPatterns++common executable+  import: base+  ghc-options:+    -O2+    -threaded+    -with-rtsopts=-N+    -rtsopts+    -funbox-strict-fields++common test+  import: base+  ghc-options:+    -threaded+    -with-rtsopts=-N++library+  import: base+  hs-source-dirs: library   exposed-modules:-    Iri.Rendering.Text-    Iri.Rendering.TextBuilder-    Iri.Rendering.Ptr.Poking-    Iri.Rendering.ByteString-    Iri.Parsing.ByteString+    Iri.Data+    Iri.Optics     Iri.Parsing.Attoparsec.ByteString     Iri.Parsing.Attoparsec.Text+    Iri.Parsing.ByteString     Iri.Parsing.Text     Iri.QuasiQuoter-    Iri.Data-    Iri.Optics+    Iri.Rendering.ByteString+    Iri.Rendering.Ptr.Poking+    Iri.Rendering.Text+    Iri.Rendering.TextBuilder+   other-modules:-    Iri.Rendering.Text.Internal-    Iri.Rendering.TextBuilder.Internal-    Iri.Data.Types+    Iri.CodePointPredicates.Core+    Iri.CodePointPredicates.Rfc3986+    Iri.CodePointPredicates.Rfc3987     Iri.Data.Functions+    Iri.Data.Instances.Eq+    Iri.Data.Instances.Generic+    Iri.Data.Instances.Hashable     Iri.Data.Instances.Lift+    Iri.Data.Instances.Ord     Iri.Data.Instances.Show-    Iri.Data.Instances.Eq+    Iri.Data.Types+    Iri.MonadPlus+    Iri.Optics.Basics+    Iri.Optics.Defs+    Iri.PercentEncoding     Iri.Prelude+    Iri.Rendering.Ptr.Poke+    Iri.Rendering.Text.Internal+    Iri.Rendering.TextBuilder.Internal     Iri.Utf8CodePoint     Iri.Vector-    Iri.MonadPlus-    Iri.CodePointPredicates.Core-    Iri.CodePointPredicates.Rfc3986-    Iri.CodePointPredicates.Rfc3987-    Iri.Rendering.Poke-    Iri.PercentEncoding+   build-depends:-    th-lift-instances >=0.1.11 && <0.2,-    th-lift >=0.7.7 && <0.8,-    template-haskell >=2.9 && <3,-    unordered-containers >=0.2 && <0.3,+    attoparsec >=0.13 && <0.15,+    base >=4.15 && <5,+    bytestring >=0.10 && <0.13,+    contravariant >=1.4 && <2,+    hashable >=1.2 && <2,+    ip >=1.7.8 && <2,+    iri:punycode,+    profunctors >=5.2 && <6,     ptr >=0.16.1 && <0.17,-    attoparsec >=0.13 && <0.14,-    punycode >=2 && <3,-    ip >=1.1 && <2,-    text ==1.*,-    text-builder >=0.5.1 && <0.6,-    bytestring >=0.10 && <0.11,-    vector >=0.10 && <0.13,+    template-haskell >=2.17 && <3,+    text >=2 && <3,+    text-builder ^>=1,+    th-lift >=0.8 && <0.9,+    th-lift-instances >=0.1.20 && <0.2,+    unordered-containers >=0.2 && <0.3,+    vector >=0.13 && <0.14,     vector-builder >=0.3.4 && <0.4,-    profunctors >=5.2 && <6,-    contravariant >=1.4 && <2,-    semigroups >=0.18 && <0.20,-    bug ==1.*,-    base-prelude >=1 && <2,-    base >=4.7 && <5+    vector-instances >=3.4 && <4,+    wide-word >=0.1.6 && <2, -test-suite tests-  type:-    exitcode-stdio-1.0-  hs-source-dirs:-    tests-  main-is:-    Main.hs-  default-extensions:-    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples-  default-language:-    Haskell2010+library punycode+  hs-source-dirs: punycode+  default-language: Haskell2010   build-depends:-    -- +    base >=4.13 && <5,+    bytestring >=0.10 && <0.13,+    cereal >=0.5.8.3 && <0.6,+    mtl >=2 && <3,+    text >=2 && <3,++  exposed-modules: Data.Text.Punycode+  other-modules:+    Data.Text.Punycode.Decode+    Data.Text.Punycode.Encode+    Data.Text.Punycode.Shared++test-suite test+  import: test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  build-depends:     iri,-    -- testing:-    tasty >=0.12 && <0.13,-    tasty-quickcheck >=0.9 && <0.10,-    tasty-hunit >=0.9 && <0.10,-    quickcheck-instances >=0.3.11 && <0.4,-    QuickCheck >=2.8.1 && <3,-    ---    rerebase >=1.1 && <2+    rerebase <2,+    tasty >=0.12 && <2,+    tasty-hunit >=0.9 && <0.11,
library/Iri/CodePointPredicates/Core.hs view
@@ -1,9 +1,7 @@-module Iri.CodePointPredicates.Core-where--import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate)-import qualified Data.Vector as A+module Iri.CodePointPredicates.Core where +import qualified Data.Vector.Unboxed as A+import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||))  type Predicate =   Int -> Bool@@ -19,11 +17,13 @@   elem i (fmap ord string)  infixr 2 |||+ (|||) :: Predicate -> Predicate -> Predicate (|||) left right i =   left i || right i  infixr 3 &&&+ (&&&) :: Predicate -> Predicate -> Predicate (&&&) left right i =   left i && right i@@ -36,7 +36,7 @@ inCharRange min max =   inRange (ord min) (ord max) -{-| 7-bit -}+-- | 7-bit septimal :: Predicate septimal i =   i < 0x80@@ -47,11 +47,13 @@  control :: Predicate control i =-  i <= 0x1F ||-  i == 0x7F+  i+    <= 0x1F+    || i+    == 0x7F  asciiAlphanumeric :: Predicate asciiAlphanumeric =-  inCharRange 'a' 'z' |||-  inCharRange 'A' 'Z' |||-  inCharRange '0' '9'+  inCharRange 'a' 'z'+    ||| inCharRange 'A' 'Z'+    ||| inCharRange '0' '9'
library/Iri/CodePointPredicates/Rfc3986.hs view
@@ -1,105 +1,100 @@-{-|-References:-- <https://www.ietf.org/rfc/rfc3986 RFC3986: Uniform Resource Identifier (URI): Generic Syntax>--@-URI           = scheme ":" hier-part [ "?" query ] [ "#" fragment ]--hier-part     = "//" authority path-abempty-              / path-absolute-              / path-rootless-              / path-empty--URI-reference = URI / relative-ref--absolute-URI  = scheme ":" hier-part [ "?" query ]--relative-ref  = relative-part [ "?" query ] [ "#" fragment ]--relative-part = "//" authority path-abempty-              / path-absolute-              / path-noscheme-              / path-empty--scheme        = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )--authority     = [ userinfo "@" ] host [ ":" port ]-userinfo      = *( unreserved / pct-encoded / sub-delims / ":" )-host          = IP-literal / IPv4address / reg-name-port          = *DIGIT--IP-literal    = "[" ( IPv6address / IPvFuture  ) "]"--IPvFuture     = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )--IPv6address   =                            6( h16 ":" ) ls32-              /                       "::" 5( h16 ":" ) ls32-              / [               h16 ] "::" 4( h16 ":" ) ls32-              / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32-              / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32-              / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32-              / [ *4( h16 ":" ) h16 ] "::"              ls32-              / [ *5( h16 ":" ) h16 ] "::"              h16-              / [ *6( h16 ":" ) h16 ] "::"--h16           = 1*4HEXDIG-ls32          = ( h16 ":" h16 ) / IPv4address-IPv4address   = dec-octet "." dec-octet "." dec-octet "." dec-octet-dec-octet     = DIGIT                 ; 0-9-              / %x31-39 DIGIT         ; 10-99-              / "1" 2DIGIT            ; 100-199-              / "2" %x30-34 DIGIT     ; 200-249-              / "25" %x30-35          ; 250-255--reg-name      = *( unreserved / pct-encoded / sub-delims )--path          = path-abempty    ; begins with "/" or is empty-              / path-absolute   ; begins with "/" but not "//"-              / path-noscheme   ; begins with a non-colon segment-              / path-rootless   ; begins with a segment-              / path-empty      ; zero characters--path-abempty  = *( "/" segment )-path-absolute = "/" [ segment-nz *( "/" segment ) ]-path-noscheme = segment-nz-nc *( "/" segment )-path-rootless = segment-nz *( "/" segment )-path-empty    = 0<pchar>--segment       = *pchar-segment-nz    = 1*pchar-segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )-              ; non-zero-length segment without any colon ":"--pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"--query         = *( pchar / "/" / "?" )--fragment      = *( pchar / "/" / "?" )--pct-encoded   = "%" HEXDIG HEXDIG--unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"-reserved      = gen-delims / sub-delims-gen-delims    = ":" / "/" / "?" / "#" / "[" / "]" / "@"-sub-delims    = "!" / "$" / "&" / "'" / "(" / ")"-              / "*" / "+" / "," / ";" / "="-@---}-module Iri.CodePointPredicates.Rfc3986-where+-- |+-- References:+-- - <https://www.ietf.org/rfc/rfc3986 RFC3986: Uniform Resource Identifier (URI): Generic Syntax>+--+-- @+-- URI           = scheme ":" hier-part [ "?" query ] [ "#" fragment ]+--+-- hier-part     = "//" authority path-abempty+--               / path-absolute+--               / path-rootless+--               / path-empty+--+-- URI-reference = URI / relative-ref+--+-- absolute-URI  = scheme ":" hier-part [ "?" query ]+--+-- relative-ref  = relative-part [ "?" query ] [ "#" fragment ]+--+-- relative-part = "//" authority path-abempty+--               / path-absolute+--               / path-noscheme+--               / path-empty+--+-- scheme        = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )+--+-- authority     = [ userinfo "@" ] host [ ":" port ]+-- userinfo      = *( unreserved / pct-encoded / sub-delims / ":" )+-- host          = IP-literal / IPv4address / reg-name+-- port          = *DIGIT+--+-- IP-literal    = "[" ( IPv6address / IPvFuture  ) "]"+--+-- IPvFuture     = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )+--+-- IPv6address   =                            6( h16 ":" ) ls32+--               /                       "::" 5( h16 ":" ) ls32+--               / [               h16 ] "::" 4( h16 ":" ) ls32+--               / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+--               / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+--               / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32+--               / [ *4( h16 ":" ) h16 ] "::"              ls32+--               / [ *5( h16 ":" ) h16 ] "::"              h16+--               / [ *6( h16 ":" ) h16 ] "::"+--+-- h16           = 1*4HEXDIG+-- ls32          = ( h16 ":" h16 ) / IPv4address+-- IPv4address   = dec-octet "." dec-octet "." dec-octet "." dec-octet+-- dec-octet     = DIGIT                 ; 0-9+--               / %x31-39 DIGIT         ; 10-99+--               / "1" 2DIGIT            ; 100-199+--               / "2" %x30-34 DIGIT     ; 200-249+--               / "25" %x30-35          ; 250-255+--+-- reg-name      = *( unreserved / pct-encoded / sub-delims )+--+-- path          = path-abempty    ; begins with "/" or is empty+--               / path-absolute   ; begins with "/" but not "//"+--               / path-noscheme   ; begins with a non-colon segment+--               / path-rootless   ; begins with a segment+--               / path-empty      ; zero characters+--+-- path-abempty  = *( "/" segment )+-- path-absolute = "/" [ segment-nz *( "/" segment ) ]+-- path-noscheme = segment-nz-nc *( "/" segment )+-- path-rootless = segment-nz *( "/" segment )+-- path-empty    = 0<pchar>+--+-- segment       = *pchar+-- segment-nz    = 1*pchar+-- segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )+--               ; non-zero-length segment without any colon ":"+--+-- pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"+--+-- query         = *( pchar / "/" / "?" )+--+-- fragment      = *( pchar / "/" / "?" )+--+-- pct-encoded   = "%" HEXDIG HEXDIG+--+-- unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"+-- reserved      = gen-delims / sub-delims+-- gen-delims    = ":" / "/" / "?" / "#" / "[" / "]" / "@"+-- sub-delims    = "!" / "$" / "&" / "'" / "(" / ")"+--               / "*" / "+" / "," / ";" / "="+-- @+module Iri.CodePointPredicates.Rfc3986 where -import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate) import Iri.CodePointPredicates.Core-import qualified Data.Vector as A--{-|-Reference:+import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||)) -@-unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"-@--}+-- |+-- Reference:+--+-- @+-- unreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~"+-- @ unreserved :: Predicate unreserved =   asciiAlphanumeric ||| oneOfChars "-._~"@@ -111,14 +106,16 @@ {-# NOINLINE scheme #-} scheme :: Predicate scheme =-  cached $-  asciiAlphanumeric ||| oneOfChars "+.-"+  cached+    $ asciiAlphanumeric+    ||| oneOfChars "+.-"  {-# NOINLINE domainLabel #-} domainLabel :: Predicate domainLabel =-  cached $-  asciiAlphanumeric ||| oneOfChars "-_~"+  cached+    $ asciiAlphanumeric+    ||| oneOfChars "-_~"  {- pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"@@ -126,24 +123,26 @@ {-# NOINLINE unencodedPathSegment #-} unencodedPathSegment :: Predicate unencodedPathSegment =-  cached $-  unreserved ||| subDelims ||| oneOfChars ":@"--{-|-Reference:--@-query         = *( pchar / "/" / "?" )-@+  cached+    $ unreserved+    ||| subDelims+    ||| oneOfChars ":@" -Notice that we've added the "|" char, because some real life URIs seem to contain it.-Also we've excluded the '+' char, because it gets decoded as a space char.--}+-- |+-- Reference:+--+-- @+-- query         = *( pchar / "/" / "?" )+-- @+--+-- Notice that we've added the "|" char, because some real life URIs seem to contain it.+-- Also we've excluded the '+' char, because it gets decoded as a space char. {-# NOINLINE unencodedQuery #-} unencodedQuery :: Predicate unencodedQuery =-  cached $-  (unencodedPathSegment ||| oneOfChars "/?|") &&& (/= 43)+  cached+    $ (unencodedPathSegment ||| oneOfChars "/?|[]\"'")+    &&& (/= 43)  unencodedFragment :: Predicate unencodedFragment =@@ -152,11 +151,14 @@ {-# NOINLINE unencodedQueryComponent #-} unencodedQueryComponent :: Predicate unencodedQueryComponent =-  cached $-  unencodedQuery &&& not . oneOfChars "=&;"+  cached+    $ unencodedQuery+    &&& not+    . oneOfChars "=&;"  {-# NOINLINE unencodedUserInfoComponent #-} unencodedUserInfoComponent :: Predicate unencodedUserInfoComponent =-  cached $-  unreserved ||| subDelims+  cached+    $ unreserved+    ||| subDelims
library/Iri/CodePointPredicates/Rfc3987.hs view
@@ -1,125 +1,121 @@-{-|-References:-- <https://www.ietf.org/rfc/rfc3987 RFC3987>--@-The following rules are different from those in [RFC3986]:--IRI            = scheme ":" ihier-part [ "?" iquery ]-                      [ "#" ifragment ]--ihier-part     = "//" iauthority ipath-abempty-               / ipath-absolute-               / ipath-rootless-               / ipath-empty--IRI-reference  = IRI / irelative-ref--absolute-IRI   = scheme ":" ihier-part [ "?" iquery ]--irelative-ref  = irelative-part [ "?" iquery ] [ "#" ifragment ]--irelative-part = "//" iauthority ipath-abempty-                    / ipath-absolute--               / ipath-noscheme-               / ipath-empty--iauthority     = [ iuserinfo "@" ] ihost [ ":" port ]-iuserinfo      = *( iunreserved / pct-encoded / sub-delims / ":" )-ihost          = IP-literal / IPv4address / ireg-name--ireg-name      = *( iunreserved / pct-encoded / sub-delims )--ipath          = ipath-abempty   ; begins with "/" or is empty-               / ipath-absolute  ; begins with "/" but not "//"-               / ipath-noscheme  ; begins with a non-colon segment-               / ipath-rootless  ; begins with a segment-               / ipath-empty     ; zero characters--ipath-abempty  = *( "/" isegment )-ipath-absolute = "/" [ isegment-nz *( "/" isegment ) ]-ipath-noscheme = isegment-nz-nc *( "/" isegment )-ipath-rootless = isegment-nz *( "/" isegment )-ipath-empty    = 0<ipchar>--isegment       = *ipchar-isegment-nz    = 1*ipchar-isegment-nz-nc = 1*( iunreserved / pct-encoded / sub-delims-                     / "@" )-               ; non-zero-length segment without any colon ":"--ipchar         = iunreserved / pct-encoded / sub-delims / ":"-               / "@"--iquery         = *( ipchar / iprivate / "/" / "?" )--ifragment      = *( ipchar / "/" / "?" )--iunreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~" / ucschar--ucschar        = %xA0-D7FF / %xF900-FDCF / %xFDF0-FFEF-               / %x10000-1FFFD / %x20000-2FFFD / %x30000-3FFFD-               / %x40000-4FFFD / %x50000-5FFFD / %x60000-6FFFD-               / %x70000-7FFFD / %x80000-8FFFD / %x90000-9FFFD-               / %xA0000-AFFFD / %xB0000-BFFFD / %xC0000-CFFFD-               / %xD0000-DFFFD / %xE1000-EFFFD--iprivate       = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD--Some productions are ambiguous.  The "first-match-wins" (a.k.a.-"greedy") algorithm applies.  For details, see [RFC3986].--The following rules are the same as those in [RFC3986]:--scheme         = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )--port           = *DIGIT--IP-literal     = "[" ( IPv6address / IPvFuture  ) "]"--IPvFuture      = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )--IPv6address    =                            6( h16 ":" ) ls32-               /                       "::" 5( h16 ":" ) ls32-               / [               h16 ] "::" 4( h16 ":" ) ls32-               / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32-               / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32-               / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32-               / [ *4( h16 ":" ) h16 ] "::"              ls32-               / [ *5( h16 ":" ) h16 ] "::"              h16-               / [ *6( h16 ":" ) h16 ] "::"--h16            = 1*4HEXDIG-ls32           = ( h16 ":" h16 ) / IPv4address--IPv4address    = dec-octet "." dec-octet "." dec-octet "." dec-octet--dec-octet      = DIGIT                 ; 0-9-               / %x31-39 DIGIT         ; 10-99-               / "1" 2DIGIT            ; 100-199-               / "2" %x30-34 DIGIT     ; 200-249-               / "25" %x30-35          ; 250-255--pct-encoded    = "%" HEXDIG HEXDIG--unreserved     = ALPHA / DIGIT / "-" / "." / "_" / "~"-reserved       = gen-delims / sub-delims-gen-delims     = ":" / "/" / "?" / "#" / "[" / "]" / "@"-sub-delims     = "!" / "$" / "&" / "'" / "(" / ")"-               / "*" / "+" / "," / ";" / "="--This syntax does not support IPv6 scoped addressing zone identifiers.-@---}-module Iri.CodePointPredicates.Rfc3987-where+-- |+-- References:+-- - <https://www.ietf.org/rfc/rfc3987 RFC3987>+--+-- @+-- The following rules are different from those in [RFC3986]:+--+-- IRI            = scheme ":" ihier-part [ "?" iquery ]+--                       [ "#" ifragment ]+--+-- ihier-part     = "//" iauthority ipath-abempty+--                / ipath-absolute+--                / ipath-rootless+--                / ipath-empty+--+-- IRI-reference  = IRI / irelative-ref+--+-- absolute-IRI   = scheme ":" ihier-part [ "?" iquery ]+--+-- irelative-ref  = irelative-part [ "?" iquery ] [ "#" ifragment ]+--+-- irelative-part = "//" iauthority ipath-abempty+--                     / ipath-absolute+--+--                / ipath-noscheme+--                / ipath-empty+--+-- iauthority     = [ iuserinfo "@" ] ihost [ ":" port ]+-- iuserinfo      = *( iunreserved / pct-encoded / sub-delims / ":" )+-- ihost          = IP-literal / IPv4address / ireg-name+--+-- ireg-name      = *( iunreserved / pct-encoded / sub-delims )+--+-- ipath          = ipath-abempty   ; begins with "/" or is empty+--                / ipath-absolute  ; begins with "/" but not "//"+--                / ipath-noscheme  ; begins with a non-colon segment+--                / ipath-rootless  ; begins with a segment+--                / ipath-empty     ; zero characters+--+-- ipath-abempty  = *( "/" isegment )+-- ipath-absolute = "/" [ isegment-nz *( "/" isegment ) ]+-- ipath-noscheme = isegment-nz-nc *( "/" isegment )+-- ipath-rootless = isegment-nz *( "/" isegment )+-- ipath-empty    = 0<ipchar>+--+-- isegment       = *ipchar+-- isegment-nz    = 1*ipchar+-- isegment-nz-nc = 1*( iunreserved / pct-encoded / sub-delims+--                      / "@" )+--                ; non-zero-length segment without any colon ":"+--+-- ipchar         = iunreserved / pct-encoded / sub-delims / ":"+--                / "@"+--+-- iquery         = *( ipchar / iprivate / "/" / "?" )+--+-- ifragment      = *( ipchar / "/" / "?" )+--+-- iunreserved    = ALPHA / DIGIT / "-" / "." / "_" / "~" / ucschar+--+-- ucschar        = %xA0-D7FF / %xF900-FDCF / %xFDF0-FFEF+--                / %x10000-1FFFD / %x20000-2FFFD / %x30000-3FFFD+--                / %x40000-4FFFD / %x50000-5FFFD / %x60000-6FFFD+--                / %x70000-7FFFD / %x80000-8FFFD / %x90000-9FFFD+--                / %xA0000-AFFFD / %xB0000-BFFFD / %xC0000-CFFFD+--                / %xD0000-DFFFD / %xE1000-EFFFD+--+-- iprivate       = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD+--+-- Some productions are ambiguous.  The "first-match-wins" (a.k.a.+-- "greedy") algorithm applies.  For details, see [RFC3986].+--+-- The following rules are the same as those in [RFC3986]:+--+-- scheme         = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )+--+-- port           = *DIGIT+--+-- IP-literal     = "[" ( IPv6address / IPvFuture  ) "]"+--+-- IPvFuture      = "v" 1*HEXDIG "." 1*( unreserved / sub-delims / ":" )+--+-- IPv6address    =                            6( h16 ":" ) ls32+--                /                       "::" 5( h16 ":" ) ls32+--                / [               h16 ] "::" 4( h16 ":" ) ls32+--                / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+--                / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+--                / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32+--                / [ *4( h16 ":" ) h16 ] "::"              ls32+--                / [ *5( h16 ":" ) h16 ] "::"              h16+--                / [ *6( h16 ":" ) h16 ] "::"+--+-- h16            = 1*4HEXDIG+-- ls32           = ( h16 ":" h16 ) / IPv4address+--+-- IPv4address    = dec-octet "." dec-octet "." dec-octet "." dec-octet+--+-- dec-octet      = DIGIT                 ; 0-9+--                / %x31-39 DIGIT         ; 10-99+--                / "1" 2DIGIT            ; 100-199+--                / "2" %x30-34 DIGIT     ; 200-249+--                / "25" %x30-35          ; 250-255+--+-- pct-encoded    = "%" HEXDIG HEXDIG+--+-- unreserved     = ALPHA / DIGIT / "-" / "." / "_" / "~"+-- reserved       = gen-delims / sub-delims+-- gen-delims     = ":" / "/" / "?" / "#" / "[" / "]" / "@"+-- sub-delims     = "!" / "$" / "&" / "'" / "(" / ")"+--                / "*" / "+" / "," / ";" / "="+--+-- This syntax does not support IPv6 scoped addressing zone identifiers.+-- @+module Iri.CodePointPredicates.Rfc3987 where -import Iri.Prelude hiding ((|||), (&&&), inRange, Predicate) import Iri.CodePointPredicates.Core import qualified Iri.CodePointPredicates.Rfc3986 as A-+import Iri.Prelude hiding (Predicate, inRange, (&&&), (|||))  scheme :: Predicate scheme =@@ -144,24 +140,22 @@ unencodedPathSegment =   unreserved ||| A.subDelims ||| oneOfChars ":@" -{-|-Reference:--@-iquery         = *( ipchar / iprivate / "/" / "?" )-@--Notice that we've added the "|" char, because some real life URIs seem to contain it.-Also we've excluded the '+' char, because it gets decoded as a space char.--}+-- |+-- Reference:+--+-- @+-- iquery         = *( ipchar / iprivate / "/" / "?" )+-- @+--+-- Notice that we've added the "|" char, because some real life URIs seem to contain it.+-- Also we've excluded the '+' char, because it gets decoded as a space char. unencodedQuery :: Predicate unencodedQuery =   (unencodedPathSegment ||| private ||| oneOfChars "/?|") &&& (/= 43) -{-|-Notice that we've added the "|" char, because some real life URIs seem to contain it.-Also we've excluded the '+' char, because it gets decoded as a space char.--}+-- |+-- Notice that we've added the "|" char, because some real life URIs seem to contain it.+-- Also we've excluded the '+' char, because it gets decoded as a space char. unencodedFragment :: Predicate unencodedFragment =   (unencodedPathSegment ||| oneOfChars "/?|") &&& (/= 43)@@ -183,29 +177,89 @@ -} ucs :: Predicate ucs x =-  x >= 0xA0 && x <= 0xD7FF ||-  x >= 0xF900 && x <= 0xFDCF ||-  x >= 0xFDF0 && x <= 0xFFEF ||-  x >= 0x10000 && x <= 0x1FFFD ||-  x >= 0x20000 && x <= 0x2FFFD ||-  x >= 0x30000 && x <= 0x3FFFD ||-  x >= 0x40000 && x <= 0x4FFFD ||-  x >= 0x50000 && x <= 0x5FFFD ||-  x >= 0x60000 && x <= 0x6FFFD ||-  x >= 0x70000 && x <= 0x7FFFD ||-  x >= 0x80000 && x <= 0x8FFFD ||-  x >= 0x90000 && x <= 0x9FFFD ||-  x >= 0xA0000 && x <= 0xAFFFD ||-  x >= 0xB0000 && x <= 0xBFFFD ||-  x >= 0xC0000 && x <= 0xCFFFD ||-  x >= 0xD0000 && x <= 0xDFFFD ||-  x >= 0xE1000 && x <= 0xEFFFD+  x+    >= 0xA0+    && x+    <= 0xD7FF+    || x+    >= 0xF900+    && x+    <= 0xFDCF+    || x+    >= 0xFDF0+    && x+    <= 0xFFEF+    || x+    >= 0x10000+    && x+    <= 0x1FFFD+    || x+    >= 0x20000+    && x+    <= 0x2FFFD+    || x+    >= 0x30000+    && x+    <= 0x3FFFD+    || x+    >= 0x40000+    && x+    <= 0x4FFFD+    || x+    >= 0x50000+    && x+    <= 0x5FFFD+    || x+    >= 0x60000+    && x+    <= 0x6FFFD+    || x+    >= 0x70000+    && x+    <= 0x7FFFD+    || x+    >= 0x80000+    && x+    <= 0x8FFFD+    || x+    >= 0x90000+    && x+    <= 0x9FFFD+    || x+    >= 0xA0000+    && x+    <= 0xAFFFD+    || x+    >= 0xB0000+    && x+    <= 0xBFFFD+    || x+    >= 0xC0000+    && x+    <= 0xCFFFD+    || x+    >= 0xD0000+    && x+    <= 0xDFFFD+    || x+    >= 0xE1000+    && x+    <= 0xEFFFD  {- iprivate       = %xE000-F8FF / %xF0000-FFFFD / %x100000-10FFFD -} private :: Predicate private x =-  x >= 0xE000 && x <= 0xF8FF ||-  x >= 0xF0000 && x <= 0xFFFFD ||-  x >= 0x100000 && x <= 0x10FFFD+  x+    >= 0xE000+    && x+    <= 0xF8FF+    || x+    >= 0xF0000+    && x+    <= 0xFFFFD+    || x+    >= 0x100000+    && x+    <= 0x10FFFD
library/Iri/Data.hs view
@@ -1,19 +1,19 @@-{-|-References:--* <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>-* <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC>--}+-- |+-- References:+--+-- * <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>+-- * <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC> module Iri.Data-(-  module Iri.Data.Types,-  module Iri.Data.Functions,-)+  ( module Iri.Data.Types,+    module Iri.Data.Functions,+  ) where -import Iri.Data.Types import Iri.Data.Functions-import Iri.Data.Instances.Lift-import Iri.Data.Instances.Eq-import Iri.Data.Instances.Show-+import Iri.Data.Instances.Eq ()+import Iri.Data.Instances.Generic ()+import Iri.Data.Instances.Hashable ()+import Iri.Data.Instances.Lift ()+import Iri.Data.Instances.Ord ()+import Iri.Data.Instances.Show ()+import Iri.Data.Types
library/Iri/Data/Functions.hs view
@@ -1,11 +1,9 @@-module Iri.Data.Functions-where+module Iri.Data.Functions where -import Iri.Prelude import Iri.Data.Types-+import Iri.Prelude -{-| Try to specialize a general IRI to HTTP -}+-- | Try to specialize a general IRI to HTTP httpIriFromIri :: Iri -> Either Text HttpIri httpIriFromIri (Iri (Scheme scheme) hierarchy query fragment) =   do@@ -16,10 +14,10 @@     case hierarchy of       AuthorisedHierarchy (Authority userInfo host port) path -> case userInfo of         MissingUserInfo -> Right (HttpIri security host port path query fragment)-        PresentUserInfo (User user) _ -> Left ("User Info is present")+        PresentUserInfo (User _) _ -> Left ("User Info is present")       _ -> Left ("Not an authorised hierarchy") -{-| Generalize an HTTP IRI to IRI -}+-- | Generalize an HTTP IRI to IRI iriFromHttpIri :: HttpIri -> Iri iriFromHttpIri (HttpIri (Security secure) host port path query fragment) =   Iri scheme hierarchy query fragment
library/Iri/Data/Instances/Eq.hs view
@@ -1,9 +1,9 @@-module Iri.Data.Instances.Eq-where+{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude-import Iri.Data.Types+module Iri.Data.Instances.Eq where +import Iri.Data.Types+import Iri.Prelude  deriving instance Eq Iri
+ library/Iri/Data/Instances/Generic.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Iri.Data.Instances.Generic where++import Iri.Data.Types+import Iri.Prelude++deriving instance Generic Iri++deriving instance Generic Scheme++deriving instance Generic Hierarchy++deriving instance Generic Authority++deriving instance Generic UserInfo++deriving instance Generic User++deriving instance Generic Password++deriving instance Generic Host++deriving instance Generic RegName++deriving instance Generic DomainLabel++deriving instance Generic Port++deriving instance Generic Path++deriving instance Generic PathSegment++deriving instance Generic Query++deriving instance Generic Fragment++deriving instance Generic HttpIri++deriving instance Generic Security
+ library/Iri/Data/Instances/Hashable.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Iri.Data.Instances.Hashable where++import Iri.Data.Instances.Eq ()+import Iri.Data.Instances.Generic ()+import Iri.Data.Types+import Iri.Prelude++instance Hashable Iri++instance Hashable Scheme++instance Hashable Hierarchy++instance Hashable Authority++instance Hashable UserInfo++instance Hashable User++instance Hashable Password++instance Hashable Host++instance Hashable RegName++instance Hashable DomainLabel++instance Hashable Port++instance Hashable Path++instance Hashable PathSegment++instance Hashable Query++instance Hashable Fragment++instance Hashable HttpIri++instance Hashable Security
library/Iri/Data/Instances/Lift.hs view
@@ -1,41 +1,47 @@-module Iri.Data.Instances.Lift-where+{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude+module Iri.Data.Instances.Lift where++import qualified Data.WideWord.Word128 import Iri.Data.Types+import Iri.Prelude import Language.Haskell.TH.Lift---deriveLift ''Iri--deriveLift ''Scheme--deriveLift ''Hierarchy--deriveLift ''Authority--deriveLift ''UserInfo--deriveLift ''User--deriveLift ''Password--deriveLift ''Host--deriveLift ''RegName--deriveLift ''DomainLabel--deriveLift ''Port--deriveLift ''Path--deriveLift ''PathSegment+import Language.Haskell.TH.Syntax+import qualified Net.IPv6 -deriveLift ''Query+fmap concat+  $ traverse deriveLift+  $ [ ''RegName,+      ''DomainLabel+    ] -deriveLift ''Fragment+instance Lift Host where+  lift = \case+    NamedHost regName ->+      AppE (ConE 'NamedHost) <$> lift regName+    IpV4Host ipV4 ->+      AppE (ConE 'IpV4Host) <$> $(makeLift ''IPv4) ipV4+    IpV6Host (Net.IPv6.IPv6 word128) -> do+      word128Exp <- $(makeLift ''Data.WideWord.Word128.Word128) word128+      pure (AppE (ConE 'IpV6Host) (AppE (ConE 'Net.IPv6.IPv6) word128Exp)) -deriveLift ''HttpIri+  liftTyped =+    Code . fmap TExp . lift -deriveLift ''Security+fmap concat+  $ traverse deriveLift+  $ [ ''Authority,+      ''Fragment,+      ''Hierarchy,+      ''HttpIri,+      ''Iri,+      ''Password,+      ''Path,+      ''PathSegment,+      ''Port,+      ''Query,+      ''Scheme,+      ''Security,+      ''User,+      ''UserInfo+    ]
+ library/Iri/Data/Instances/Ord.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Iri.Data.Instances.Ord where++import Iri.Data.Instances.Eq ()+import Iri.Data.Types+import Iri.Prelude++deriving instance Ord Iri++deriving instance Ord Scheme++deriving instance Ord Hierarchy++deriving instance Ord Authority++deriving instance Ord UserInfo++deriving instance Ord User++deriving instance Ord Password++deriving instance Ord Host++deriving instance Ord RegName++deriving instance Ord DomainLabel++deriving instance Ord Port++deriving instance Ord Path++deriving instance Ord PathSegment++deriving instance Ord Query++deriving instance Ord Fragment++deriving instance Ord HttpIri++deriving instance Ord Security
library/Iri/Data/Instances/Show.hs view
@@ -1,19 +1,19 @@-module Iri.Data.Instances.Show-where+{-# OPTIONS_GHC -Wno-orphans #-} -import Iri.Prelude+module Iri.Data.Instances.Show where++import qualified Data.Text as B import Iri.Data.Types+import Iri.Prelude import qualified Iri.Rendering.Text.Internal as A-import qualified Data.Text as B - instance Show Iri where   show =-    B.unpack . A.iri+    mappend "\"" . flip mappend "\"" . B.unpack . A.iri  instance Show HttpIri where   show =-    B.unpack . A.httpIri+    mappend "\"" . flip mappend "\"" . B.unpack . A.httpIri  deriving instance Show Scheme @@ -44,4 +44,3 @@ deriving instance Show Fragment  deriving instance Show Security-
library/Iri/Data/Types.hs view
@@ -1,99 +1,83 @@-{-|-References:--* <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>-* <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC>--} {-# OPTIONS_GHC -funbox-strict-fields #-}-module Iri.Data.Types-where -import Iri.Prelude---{-|-Thorough structure of IRI.--}-data Iri =-  Iri !Scheme !Hierarchy !Query !Fragment+-- |+-- References:+--+-- * <https://tools.ietf.org/rfc/rfc3986.txt URI RFC>+-- * <https://tools.ietf.org/rfc/rfc3987.txt IRI RFC>+module Iri.Data.Types where -newtype Scheme =-  Scheme ByteString+import Iri.Prelude -data Hierarchy =-  AuthorisedHierarchy !Authority !Path |-  AbsoluteHierarchy !Path |-  RelativeHierarchy !Path+-- |+-- Thorough structure of IRI or URI.+data Iri = Iri !Scheme !Hierarchy !Query !Fragment -data Authority =-  Authority !UserInfo !Host !Port+newtype Scheme = Scheme ByteString -data UserInfo =-  PresentUserInfo !User !Password |-  MissingUserInfo+data Hierarchy+  = AuthorisedHierarchy !Authority !Path+  | AbsoluteHierarchy !Path+  | RelativeHierarchy !Path -newtype User =-  User Text+data Authority = Authority !UserInfo !Host !Port -data Password =-  PresentPassword !Text |-  MissingPassword+data UserInfo+  = PresentUserInfo !User !Password+  | MissingUserInfo -data Host =-  NamedHost !RegName |-  IpV4Host !IPv4 |-  IpV6Host !IPv6+newtype User = User ByteString -newtype RegName =-  RegName (Vector DomainLabel)+data Password+  = PresentPassword !ByteString+  | MissingPassword -newtype DomainLabel =-  DomainLabel Text+data Host+  = NamedHost !RegName+  | IpV4Host !IPv4+  | IpV6Host !IPv6 -data Port =-  PresentPort !Word16 |-  MissingPort+newtype RegName = RegName (Vector DomainLabel) -newtype Path =-  Path (Vector PathSegment)+data DomainLabel = DomainLabel Text -newtype PathSegment =-  PathSegment Text+data Port+  = PresentPort !Word16+  | MissingPort -{-|-Since the exact structure of the query string is not standardised and-methods used to parse the query string may differ between websites,-we simply represent it as a decoded Unicode string.+newtype Path = Path (Vector PathSegment) -See <https://en.wikipedia.org/wiki/Query_string>.--}-newtype Query =-  Query Text+newtype PathSegment = PathSegment ByteString -newtype Fragment =-  Fragment Text+-- |+-- Since the exact structure of the query string is not standardised and+-- methods used to parse the query string may differ between websites,+-- we simply represent it as percent-decoded bytes.+--+-- See <https://en.wikipedia.org/wiki/Query_string>.+newtype Query = Query ByteString +newtype Fragment = Fragment ByteString  -- * Special cases-------------------------- --- ** HTTP special case ------------------------- -{-|-HTTP being by far the most common use-case for resource identifiers,-it's been isolated into a dedicated data-type,-which is optimised for that particular case.+-- ** HTTP special case -Compared to the general IRI definition it:+------------------------- -* only supports the HTTP and HTTPS schemes-* misses the Username and Password components-* requires the Host component-* requires the Path component to be absolute--}-data HttpIri =-  HttpIri !Security !Host !Port !Path !Query !Fragment+-- |+-- HTTP being by far the most common use-case for resource identifiers,+-- it's been isolated into a dedicated data-type,+-- which is optimised for that particular case.+--+-- Compared to the general URI definition it:+--+-- * only supports the HTTP and HTTPS schemes+-- * misses the Username and Password components+-- * requires the Host component+-- * requires the Path component to be absolute+data HttpIri = HttpIri !Security !Host !Port !Path !Query !Fragment -newtype Security =-  Security Bool+newtype Security = Security Bool
library/Iri/MonadPlus.hs view
@@ -1,30 +1,43 @@-module Iri.MonadPlus-where--import Iri.Prelude hiding (null, length)+module Iri.MonadPlus where +import Iri.Prelude hiding (foldl)+import qualified Ptr.ByteString as ByteString+import qualified Ptr.Poking as Poking  {-# INLINE foldl #-}-foldl :: MonadPlus m => (a -> b -> a) -> a -> m b -> m a+foldl :: (MonadPlus m) => (a -> b -> a) -> a -> m b -> m a foldl step start elementParser =   loop start   where     loop state =       mplus-        (do-          element <- elementParser-          loop $! step state element)+        ( do+            element <- elementParser+            loop $! step state element+        )         (return state)  {-# INLINE foldlM #-}-foldlM :: MonadPlus m => (a -> b -> m a) -> a -> m b -> m a+foldlM :: (MonadPlus m) => (a -> b -> m a) -> a -> m b -> m a foldlM step start elementParser =   loop start   where     loop state =       join-        (mplus-          (do-            element <- elementParser-            return (step state element >>= loop))-          (return (return state)))+        ( mplus+            ( do+                element <- elementParser+                return (step state element >>= loop)+            )+            (return (return state))+        )++{-# INLINE foldByteString #-}+foldByteString :: (MonadPlus m) => m ByteString -> m ByteString+foldByteString =+  fmap ByteString.poking+    . foldl (\poking -> mappend poking . Poking.bytes) mempty++{-# INLINE fold #-}+fold :: (MonadPlus m, Monoid a) => m a -> m a+fold = foldl mappend mempty
library/Iri/Optics.hs view
@@ -1,103 +1,13 @@-{-|-These are the beginnings of a Lens API.-It is compatible with the general Van Laarhoven lens libraries, such as \"lens\".--Many more definitions can be implemented, so do PRs if you miss any!--}+-- |+-- These are the beginnings of a Lens API.+-- It is compatible with the general Van Laarhoven lens libraries, such as \"lens\".+--+-- Many more definitions can be implemented, so do PRs if you miss any! module Iri.Optics-(-  -- * Definitions-  Lens,-  Lens',-  Prism,-  Prism',-  -- * Prisms-  iriHttpIriPrism,-  uriByteStringIriPrism,-  uriByteStringHttpIriPrism,-  iriTextIriPrism,-  iriTextHttpIriPrism,-  -- * Lenses-  iriSchemeLens,-  iriHierarchyLens,-  iriQueryLens,-  iriFragmentLens,-)+  ( module Basics,+    module Defs,+  ) where -import Iri.Prelude-import Iri.Data-import qualified Iri.Rendering.ByteString as A-import qualified Iri.Parsing.ByteString as B-import qualified Iri.Rendering.Text as C-import qualified Iri.Parsing.Text as D---type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t--type Lens' s a = Lens s s a a--type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)--type Prism' s a = Prism s s a a--{-# INLINE prism #-}-prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b-prism bt seta =-  dimap seta (either pure (fmap bt)) . right'--{-# INLINE lens #-}-lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b-lens sa sbt afb s =-  sbt s <$> afb (sa s)---- * Prisms----------------------------iriHttpIriPrism :: Prism' Iri HttpIri-iriHttpIriPrism =-  prism iriFromHttpIri (\ iri -> either (const (Left iri)) Right (httpIriFromIri iri))--uriByteStringIriPrism :: Prism' ByteString Iri-uriByteStringIriPrism =-  prism A.uri (\ bytes -> either (const (Left bytes)) Right (B.uri bytes))--uriByteStringHttpIriPrism :: Prism' ByteString HttpIri-uriByteStringHttpIriPrism =-  uriByteStringIriPrism . iriHttpIriPrism--iriTextIriPrism :: Prism' Text Iri-iriTextIriPrism =-  prism C.iri (\ text -> either (const (Left text)) Right (D.iri text))--iriTextHttpIriPrism :: Prism' Text HttpIri-iriTextHttpIriPrism =-  iriTextIriPrism . iriHttpIriPrism----- * Lenses----------------------------iriSchemeLens :: Lens' Iri ByteString-iriSchemeLens =-  lens-    (\ (Iri (Scheme x) _ _ _) -> x)-    (\ (Iri _ hierarchy query fragment) x -> Iri (Scheme x) hierarchy query fragment)--iriHierarchyLens :: Lens' Iri Hierarchy-iriHierarchyLens =-  lens-    (\ (Iri _ x _ _) -> x)-    (\ (Iri scheme _ query fragment) x -> Iri scheme x query fragment)--iriQueryLens :: Lens' Iri Text-iriQueryLens =-  lens-    (\ (Iri _ _ (Query x) _) -> x)-    (\ (Iri scheme hierarchy _ fragment) x -> Iri scheme hierarchy (Query x) fragment)--iriFragmentLens :: Lens' Iri Text-iriFragmentLens =-  lens-    (\ (Iri _ _ _ (Fragment x)) -> x)-    (\ (Iri scheme hierarchy query _) x -> Iri scheme hierarchy query (Fragment x))+import Iri.Optics.Basics as Basics (Lens, Lens', Prism, Prism', Traversal, Traversal')+import Iri.Optics.Defs as Defs
+ library/Iri/Optics/Basics.hs view
@@ -0,0 +1,34 @@+module Iri.Optics.Basics where++import Iri.Prelude++type Lens s t a b = forall f. (Functor f) => (a -> f b) -> s -> f t++type Lens' s a = Lens s s a a++type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)++type Prism' s a = Prism s s a a++type Traversal s t a b = forall f. (Applicative f) => (a -> f b) -> s -> f t++type Traversal' s a = Traversal s s a a++type Iso s t a b = forall p f. (Profunctor p, Functor f) => p a (f b) -> p s (f t)++type Iso' s a = Iso s s a a++{-# INLINE prism #-}+prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta =+  dimap seta (either pure (fmap bt)) . right'++{-# INLINE prism' #-}+prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a+prism' as sma =+  prism as (\s -> maybe (Left s) Right (sma s))++{-# INLINE lens #-}+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens sa sbt afb s =+  sbt s <$> afb (sa s)
+ library/Iri/Optics/Defs.hs view
@@ -0,0 +1,74 @@+module Iri.Optics.Defs where++import qualified Data.Text.Encoding as Text+import Iri.Data+import Iri.Optics.Basics+import qualified Iri.Parsing.ByteString as B+import qualified Iri.Parsing.Text as D+import Iri.Prelude+import qualified Iri.Rendering.ByteString as A+import qualified Iri.Rendering.Text as C++-- * Definitions by source++-------------------------++-- ** Text++-------------------------++textIriIri :: Prism' Text Iri+textIriIri =+  prism C.iri (\text -> either (const (Left text)) Right (D.iri text))++textIriHttpIri :: Prism' Text HttpIri+textIriHttpIri =+  textIriIri . iriHttpIri++-- ** ByteString++-------------------------++byteStringIri :: Prism' ByteString Iri+byteStringIri =+  prism A.uri (\bytes -> either (const (Left bytes)) Right (B.uri bytes))++byteStringHttpIri :: Prism' ByteString HttpIri+byteStringHttpIri =+  byteStringIri . iriHttpIri++byteStringTextInUtf8 :: Prism' ByteString Text+byteStringTextInUtf8 = prism' Text.encodeUtf8 (either (const Nothing) Just . Text.decodeUtf8')++-- ** IRI++-------------------------++iriHttpIri :: Prism' Iri HttpIri+iriHttpIri = prism' iriFromHttpIri (either (const Nothing) Just . httpIriFromIri)++iriScheme :: Lens' Iri Scheme+iriScheme = lens (\(Iri x _ _ _) -> x) (\(Iri _ hierarchy query fragment) x -> Iri x hierarchy query fragment)++iriHierarchy :: Lens' Iri Hierarchy+iriHierarchy = lens (\(Iri _ x _ _) -> x) (\(Iri scheme _ query fragment) x -> Iri scheme x query fragment)++iriQuery :: Lens' Iri Query+iriQuery = lens (\(Iri _ _ x _) -> x) (\(Iri scheme hierarchy _ fragment) x -> Iri scheme hierarchy x fragment)++iriFragment :: Lens' Iri Fragment+iriFragment = lens (\(Iri _ _ _ x) -> x) (\(Iri scheme hierarchy query _) x -> Iri scheme hierarchy query x)++-- ** Scheme++-------------------------++schemeByteString :: Lens' Scheme ByteString+schemeByteString = lens (\(Scheme x) -> x) (const Scheme)++-- ** Fragment++-------------------------++fragmentByteString :: Lens' Fragment ByteString+fragmentByteString = lens (\(Fragment x) -> x) (const Fragment)
library/Iri/Parsing/Attoparsec/ByteString.hs view
@@ -1,33 +1,28 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module Iri.Parsing.Attoparsec.ByteString-(-  uri,-  httpUri,-)+  ( uri,+    httpUri,+    regName,+  ) where -import Iri.Prelude hiding (foldl, hash)-import Iri.Data import Data.Attoparsec.ByteString hiding (try) import qualified Data.Attoparsec.ByteString.Char8 as F import qualified Data.ByteString as K-import qualified Data.Text as T-import qualified Data.Text.Punycode as A import qualified Data.Text.Encoding as B import qualified Data.Text.Encoding.Error as L-import qualified Data.HashMap.Strict as O+import qualified Data.Text.Punycode as A import qualified Data.Vector as S-import qualified VectorBuilder.Builder as P-import qualified VectorBuilder.Vector as Q-import qualified VectorBuilder.MonadPlus as E-import qualified Iri.PercentEncoding as I import qualified Iri.CodePointPredicates.Rfc3986 as C+import Iri.Data import qualified Iri.MonadPlus as R-import qualified Ptr.Poking as G-import qualified Ptr.ByteString as H-import qualified Text.Builder as J+import qualified Iri.PercentEncoding as I+import Iri.Prelude hiding (foldl, hash) import qualified Net.IPv4 as M import qualified Net.IPv6 as N-+import qualified TextBuilder as J+import qualified VectorBuilder.MonadPlus as E  {-# INLINE percent #-} percent :: Parser Word8@@ -84,34 +79,32 @@ labeled label parser =   parser <?> label -{-|-Parser of a well-formed URI conforming to the RFC3986 standard into IRI.-Performs URL- and Punycode-decoding.--}-{-# INLINABLE uri #-}+-- |+-- Parser of a well-formed URI conforming to the RFC3986 or RFC3987 standards.+-- Performs URL- and Punycode-decoding.+{-# INLINEABLE uri #-} uri :: Parser Iri uri =   labeled "URI" $ do     parsedScheme <- scheme-    colon+    _ <- colon     parsedHierarchy <- hierarchy     parsedQuery <- query     parsedFragment <- fragment     return (Iri parsedScheme parsedHierarchy parsedQuery parsedFragment) -{-|-Same as 'uri', but optimized specifially for the case of HTTP URIs.--}-{-# INLINABLE httpUri #-}+-- |+-- Same as 'uri', but optimized specifially for the case of HTTP URIs.+{-# INLINEABLE httpUri #-} httpUri :: Parser HttpIri httpUri =   labeled "HTTP URI" $ do-    satisfy (\ x -> x == 104 || x == 72)-    satisfy (\ x -> x == 116 || x == 84)-    satisfy (\ x -> x == 116 || x == 84)-    satisfy (\ x -> x == 112 || x == 80)-    secure <- satisfy (\ b -> b == 115 || b == 83) $> True <|> pure False-    string "://"+    _ <- satisfy (\x -> x == 104 || x == 72)+    _ <- satisfy (\x -> x == 116 || x == 84)+    _ <- satisfy (\x -> x == 116 || x == 84)+    _ <- satisfy (\x -> x == 112 || x == 80)+    secure <- satisfy (\b -> b == 115 || b == 83) $> True <|> pure False+    _ <- string "://"     parsedHost <- host     parsedPort <- PresentPort <$> (colon *> port) <|> pure MissingPort     parsedPath <- (forwardSlash *> path) <|> pure (Path mempty)@@ -145,64 +138,67 @@ {-# INLINE scheme #-} scheme :: Parser Scheme scheme =-  labeled "Scheme" $-  fmap Scheme (takeWhile1 (C.scheme . fromIntegral))+  labeled "Scheme"+    $ fmap Scheme (takeWhile1 (C.scheme . fromIntegral)) -{-# INLINABLE presentUserInfo #-}+{-# INLINEABLE presentUserInfo #-} presentUserInfo :: (User -> Password -> a) -> Parser a presentUserInfo result =-  labeled "User info" $-  do-    user <- User <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)-    passwordFollows <- True <$ colon <|> pure False-    if passwordFollows-      then do-        password <- PresentPassword <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)-        return (result user password)-      else return (result user MissingPassword)+  labeled "User info"+    $ do+      user <- User <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)+      passwordFollows <- True <$ colon <|> pure False+      if passwordFollows+        then do+          password <- PresentPassword <$> urlEncodedString (C.unencodedUserInfoComponent . fromIntegral)+          return (result user password)+        else return (result user MissingPassword)  {-# INLINE host #-} host :: Parser Host host =-  labeled "Host" $-  IpV6Host <$> ipV6 <|>-  IpV4Host <$> M.parserUtf8 <|>-  NamedHost <$> domainName+  labeled "Host"+    $ asum+      [ IpV6Host <$> ipV6,+        IpV4Host <$> M.parserUtf8,+        NamedHost <$> regName+      ] -{-# INLINABLE ipV6 #-}+{-# INLINEABLE ipV6 #-} ipV6 :: Parser IPv6 ipV6 =   do     a <- F.hexadecimal-    colon+    _ <- colon     b <- F.hexadecimal-    colon+    _ <- colon     c <- F.hexadecimal-    colon+    _ <- colon     d <- F.hexadecimal-    colon+    _ <- colon     mplus-      (do-        e <- F.hexadecimal-        colon-        f <- F.hexadecimal-        colon-        g <- F.hexadecimal-        colon-        h <- F.hexadecimal-        return (N.fromWord16s a b c d e f g h))-      (do-        colon-        return (N.fromWord16s a b c d 0 0 0 0))+      ( do+          e <- F.hexadecimal+          _ <- colon+          f <- F.hexadecimal+          _ <- colon+          g <- F.hexadecimal+          _ <- colon+          h <- F.hexadecimal+          return (N.fromWord16s a b c d e f g h)+      )+      ( do+          _ <- colon+          return (N.fromWord16s a b c d 0 0 0 0)+      ) -{-# INLINE domainName #-}-domainName :: Parser RegName-domainName =+{-# INLINE regName #-}+regName :: Parser RegName+regName =   fmap RegName (E.sepBy1 domainLabel (word8 46)) -{-|-Domain label with Punycode decoding applied.--}+-- |+-- Domain label with Punycode decoding applied if need be. {-# INLINE domainLabel #-} domainLabel :: Parser DomainLabel domainLabel =@@ -230,19 +226,21 @@       else return (Path segments)   where     segmentsAreEmpty segments =-      S.length segments == 1 &&-      (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)+      S.length segments+        == 1+        && (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment)  {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment pathSegment =   fmap PathSegment (urlEncodedString (C.unencodedPathSegment . fromIntegral)) -{-# INLINABLE utf8Chunks #-}+{-# INLINEABLE utf8Chunks #-} utf8Chunks :: Parser ByteString -> Parser Text utf8Chunks chunk =-  labeled "UTF8 chunks" $-  R.foldlM progress (mempty, mempty, B.streamDecodeUtf8) chunk >>= finish+  labeled "UTF8 chunks"+    $ R.foldlM progress (mempty, mempty, B.streamDecodeUtf8) chunk+    >>= finish   where     progress (!builder, _, decode) bytes =       case unsafeDupablePerformIO (try (evaluate (decode bytes))) of@@ -250,17 +248,20 @@           return (builder <> J.text decodedChunk, undecodedBytes, newDecode)         Left (L.DecodeError error _) ->           fail (showString "UTF8 decoding: " error)+        Left _ ->+          fail "Unexpected decoding error"     finish (builder, undecodedBytes, _) =       if K.null undecodedBytes-        then return (J.run builder)+        then return (J.toText builder)         else fail (showString "UTF8 decoding: Bytes remaining: " (show undecodedBytes)) -{-# INLINABLE urlEncodedString #-}-urlEncodedString :: (Word8 -> Bool) -> Parser Text+{-# INLINEABLE urlEncodedString #-}+urlEncodedString :: (Word8 -> Bool) -> Parser ByteString urlEncodedString unencodedBytesPredicate =-  labeled "URL-encoded string" $-  utf8Chunks $-  takeWhile1 unencodedBytesPredicate <|> encoded+  labeled "URL-encoded string"+    $ R.foldByteString+    $ takeWhile1 unencodedBytesPredicate+    <|> encoded   where     encoded =       K.singleton <$> percentEncodedByte@@ -269,30 +270,33 @@ percentEncodedByte :: Parser Word8 percentEncodedByte =   labeled "Percent-encoded byte" $ do-    percent +    _ <- percent     byte1 <- anyWord8     byte2 <- anyWord8     I.matchPercentEncodedBytes (fail "Broken percent encoding") return byte1 byte2 -{-# INLINABLE query #-}+{-# INLINE query #-} query :: Parser Query query =-  labeled "Query" $-  (question *> (Query <$> queryOrFragmentBody)) <|> pure (Query mempty)+  labeled "Query"+    $ (question *> (Query <$> queryOrFragmentBody))+    <|> pure (Query mempty) -{-# INLINABLE fragment #-}+{-# INLINE fragment #-} fragment :: Parser Fragment fragment =-  labeled "Fragment" $-  (hash *> (Fragment <$> queryOrFragmentBody)) <|> pure (Fragment mempty)+  labeled "Fragment"+    $ (hash *> (Fragment <$> queryOrFragmentBody))+    <|> pure (Fragment mempty) -{-|-The stuff after the question or the hash mark.--}-{-# INLINABLE queryOrFragmentBody #-}-queryOrFragmentBody :: Parser Text+-- |+-- The stuff after the question or the hash mark.+{-# INLINEABLE queryOrFragmentBody #-}+queryOrFragmentBody :: Parser ByteString queryOrFragmentBody =-  utf8Chunks $-  takeWhile1 (C.unencodedQuery . fromIntegral) <|>-  " " <$ plus <|>-  K.singleton <$> percentEncodedByte+  R.foldByteString+    $ takeWhile1 (C.unencodedQuery . fromIntegral)+    <|> " "+    <$ plus+    <|> K.singleton+    <$> percentEncodedByte
library/Iri/Parsing/Attoparsec/Text.hs view
@@ -1,56 +1,65 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module Iri.Parsing.Attoparsec.Text-(-  iri,-  httpIri,-)+  ( iri,+    httpIri,+    hierarchy,+    scheme,+    host,+    regName,+    domainLabel,+    port,+    path,+    pathSegment,+    query,+    fragment,+  ) where -import Iri.Prelude-import Iri.Data import Data.Attoparsec.Text hiding (try) import qualified Data.ByteString as K-import qualified Data.Text as T import qualified Data.Text.Encoding as B import qualified Data.Text.Encoding.Error as L import qualified Data.Vector as S-import qualified VectorBuilder.MonadPlus as E import qualified Iri.CodePointPredicates.Rfc3987 as C+import Iri.Data import qualified Iri.MonadPlus as R-import qualified Text.Builder as J+import Iri.Prelude import qualified Net.IPv4 as M import qualified Net.IPv6 as N-+import qualified Ptr.ByteString as ByteString+import qualified Ptr.Poking as Poking+import qualified TextBuilder as J+import qualified VectorBuilder.MonadPlus as E  {-# INLINE labeled #-} labeled :: String -> Parser a -> Parser a labeled label parser =   parser <?> label -{-|-Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.-Performs URL-decoding.--}-{-# INLINABLE iri #-}+-- |+-- Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'.+-- Performs URL-decoding.+{-# INLINEABLE iri #-} iri :: Parser Iri iri =   labeled "IRI" $ do     parsedScheme <- scheme-    char ':'+    _ <- char ':'     parsedHierarchy <- hierarchy     parsedQuery <- query     parsedFragment <- fragment     return (Iri parsedScheme parsedHierarchy parsedQuery parsedFragment) -{-|-Same as 'iri', but optimized specifially for the case of HTTP IRIs.--}-{-# INLINABLE httpIri #-}+-- |+-- Same as 'iri', but optimized specifially for the case of HTTP IRIs.+{-# INLINEABLE httpIri #-} httpIri :: Parser HttpIri httpIri =   labeled "HTTP IRI" $ do-    asciiCI "http"-    secure <- satisfy (\ x -> x == 's' || x == 'S') $> True <|> pure False-    string "://"+    _ <- asciiCI "http"+    secure <- satisfy (\x -> x == 's' || x == 'S') $> True <|> pure False+    _ <- string "://"     parsedHost <- host     parsedPort <- PresentPort <$> (char ':' *> port) <|> pure MissingPort     parsedPath <- ((char '/') *> path) <|> pure (Path mempty)@@ -84,43 +93,46 @@ {-# INLINE scheme #-} scheme :: Parser Scheme scheme =-  labeled "Scheme" $-  fmap (Scheme . B.encodeUtf8) (takeWhile1 (C.scheme . ord))+  labeled "Scheme"+    $ fmap (Scheme . B.encodeUtf8) (takeWhile1 (C.scheme . ord)) -{-# INLINABLE presentUserInfo #-}+{-# INLINEABLE presentUserInfo #-} presentUserInfo :: (User -> Password -> a) -> Parser a presentUserInfo result =-  labeled "User info" $-  do-    user <- User <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)-    passwordFollows <- True <$ char ':' <|> pure False-    if passwordFollows-      then do-        password <- PresentPassword <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)-        return (result user password)-      else return (result user MissingPassword)+  labeled "User info"+    $ do+      user <- User <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)+      passwordFollows <- True <$ char ':' <|> pure False+      if passwordFollows+        then do+          password <- PresentPassword <$> urlEncodedComponent (C.unencodedUserInfoComponent . ord)+          return (result user password)+        else return (result user MissingPassword)  {-# INLINE host #-} host :: Parser Host host =-  labeled "Host" $-  IpV6Host <$> N.parser <|>-  IpV4Host <$> M.parser <|>-  NamedHost <$> domainName+  labeled "Host"+    $ IpV6Host+    <$> N.parser+    <|> IpV4Host+    <$> M.parser+    <|> NamedHost+    <$> regName -{-# INLINE domainName #-}-domainName :: Parser RegName-domainName =+{-# INLINE regName #-}+regName :: Parser RegName+regName =   fmap RegName (E.sepBy1 domainLabel (char '.')) -{-|-Domain label with Punycode decoding applied.--}+-- |+-- Domain label with Punycode decoding applied. {-# INLINE domainLabel #-} domainLabel :: Parser DomainLabel domainLabel =-  labeled "Domain label" $-  DomainLabel <$> takeWhile1 (C.unencodedRegName . ord)+  labeled "Domain label"+    $ DomainLabel+    <$> takeWhile1 (C.unencodedRegName . ord)  {-# INLINE port #-} port :: Parser Word16@@ -137,25 +149,36 @@       else return (Path segments)   where     segmentsAreEmpty segments =-      S.length segments == 1 &&-      (case S.unsafeHead segments of PathSegment headSegmentText -> T.null headSegmentText)+      S.length segments+        == 1+        && (case S.unsafeHead segments of PathSegment headSegment -> K.null headSegment)  {-# INLINE pathSegment #-} pathSegment :: Parser PathSegment pathSegment =   fmap PathSegment (urlEncodedComponent (C.unencodedPathSegment . ord)) -{-# INLINABLE urlEncodedComponent #-}-urlEncodedComponent :: (Char -> Bool) -> Parser Text+{-# INLINEABLE urlEncodedComponent #-}+urlEncodedComponent :: (Char -> Bool) -> Parser ByteString urlEncodedComponent unencodedCharPredicate =-  labeled "URL-encoded component" $-  fmap J.run $-  R.foldl mappend mempty $-  (J.text <$> takeWhile1 unencodedCharPredicate) <|> urlEncodedSequence+  labeled "URL-encoded component"+    $ fmap ByteString.poking+    $ R.fold+    $ (Poking.bytes . B.encodeUtf8 <$> takeWhile1 unencodedCharPredicate)+    <|> (Poking.word8 <$> urlEncodedByte) -{-# INLINABLE urlEncodedSequence #-}-urlEncodedSequence :: Parser J.Builder-urlEncodedSequence =+{-# INLINEABLE urlEncodedComponentText #-}+urlEncodedComponentText :: (Char -> Bool) -> Parser Text+urlEncodedComponentText unencodedCharPredicate =+  labeled "URL-encoded component"+    $ fmap J.toText+    $ R.foldl mappend mempty+    $ (J.text <$> takeWhile1 unencodedCharPredicate)+    <|> urlEncodedSequenceTextBuilder++{-# INLINEABLE urlEncodedSequenceTextBuilder #-}+urlEncodedSequenceTextBuilder :: Parser J.TextBuilder+urlEncodedSequenceTextBuilder =   labeled "URL-encoded sequence" $ do     start <- progress (mempty, mempty, B.streamDecodeUtf8) =<< urlEncodedByte     R.foldlM progress (start) urlEncodedByte >>= finish@@ -166,6 +189,8 @@           return (builder <> J.text decodedChunk, undecodedBytes, newDecode)         Left (L.DecodeError error _) ->           fail (showString "UTF8 decoding: " error)+        Left _ ->+          fail "Unexpected decoding error"     finish (builder, undecodedBytes, _) =       if K.null undecodedBytes         then return builder@@ -175,7 +200,7 @@ urlEncodedByte :: Parser Word8 urlEncodedByte =   do-    char '%' +    _ <- char '%'     digit1 <- fromIntegral <$> hexadecimalDigit     digit2 <- fromIntegral <$> hexadecimalDigit     return (shiftL digit1 4 .|. digit2)@@ -188,29 +213,31 @@     let x = ord c     if x >= 48 && x < 58       then return (x - 48)-      else if x >= 65 && x < 71-        then return (x - 55)-        else if x >= 97 && x < 103-          then return (x - 97)-          else fail ("Not a hexadecimal digit: " <> show c)+      else+        if x >= 65 && x < 71+          then return (x - 55)+          else+            if x >= 97 && x < 103+              then return (x - 87)+              else fail ("Not a hexadecimal digit: " <> show c) -{-# INLINABLE query #-}+{-# INLINEABLE query #-} query :: Parser Query query =-  labeled "Query" $-  (char '?' *> queryBody) <|> pure (Query mempty)+  labeled "Query"+    $ (char '?' *> queryBody)+    <|> pure (Query mempty) -{-|-The stuff after the question mark.--}-{-# INLINABLE queryBody #-}+-- |+-- The stuff after the question mark.+{-# INLINEABLE queryBody #-} queryBody :: Parser Query queryBody =   fmap Query (urlEncodedComponent (C.unencodedQuery . ord)) -{-# INLINABLE fragment #-}+{-# INLINEABLE fragment #-} fragment :: Parser Fragment fragment =-  labeled "Fragment" $-  (char '#' *> (Fragment <$> urlEncodedComponent (C.unencodedFragment . ord))) <|>-  pure (Fragment mempty)+  labeled "Fragment"+    $ (char '#' *> (Fragment <$> urlEncodedComponent (C.unencodedFragment . ord)))+    <|> pure (Fragment mempty)
library/Iri/Parsing/ByteString.hs view
@@ -1,29 +1,55 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module Iri.Parsing.ByteString-(-  uri,-  httpUri,-)+  ( uri,+    httpUri,+    regName,+    uriQuery,+  ) where -import Iri.Prelude+import qualified Data.Attoparsec.ByteString as B+import qualified Data.ByteString as ByteString import Iri.Data import qualified Iri.Parsing.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString as B+import Iri.Prelude +parser :: B.Parser a -> ByteString -> Either Text a+parser parser =+  either (Left . fromString) Right+    . B.parseOnly (parser <* B.endOfInput) -{-|-Parser of a well-formed URI conforming to the RFC3986 standard into IRI.-Performs URL- and Punycode-decoding.--}+-- |+-- Parser of a well-formed URI conforming to the RFC3986 standard into IRI.+-- Performs URL- and Punycode-decoding. uri :: ByteString -> Either Text Iri uri =-  either (Left . fromString) Right .-  B.parseOnly (A.uri <* B.endOfInput)+  parser A.uri -{-|-Same as 'uri', but optimized specifially for the case of HTTP URIs.--}+-- |+-- Same as 'uri', but optimized specifially for the case of HTTP URIs. httpUri :: ByteString -> Either Text HttpIri httpUri =-  either (Left . fromString) Right .-  B.parseOnly (A.httpUri <* B.endOfInput)+  parser A.httpUri++-- |+-- Domain name parser.+regName :: ByteString -> Either Text RegName+regName =+  parser A.regName++-- |+-- Assuming we have a valid URI as input, extract the query part from it.+uriQuery :: ByteString -> Either Text Query+uriQuery x =+  case ByteString.break (== 63) x of+    (_, questionAndAfterQuestion) -> case ByteString.uncons questionAndAfterQuestion of+      Just (_, afterQuestion) -> case ByteString.break (== 35) afterQuestion of+        (beforeHash, _) -> Right (Query beforeHash)+      Nothing ->+        Left "Does not start with a question mark"++-- |+-- Assuming we have a valid URI as input, extract the fragment part from it.+uriFragment :: ByteString -> Fragment+uriFragment = ByteString.break (== 35) >>> snd >>> ByteString.drop 1 >>> Fragment
library/Iri/Parsing/Text.hs view
@@ -1,29 +1,66 @@ module Iri.Parsing.Text-(-  iri,-  httpIri,-)+  ( iri,+    httpIri,+    hierarchy,+    scheme,+    host,+    regName,+    domainLabel,+    port,+    path,+    pathSegment,+    query,+    fragment,+  ) where -import Iri.Prelude+import qualified Data.Attoparsec.Text as B import Iri.Data import qualified Iri.Parsing.Attoparsec.Text as A-import qualified Data.Attoparsec.Text as B+import Iri.Prelude +fromParser :: B.Parser a -> Text -> Either Text a+fromParser parser =+  either (Left . fromString) Right+    . B.parseOnly (parser <* B.endOfInput) -{-|-Parser of a well-formed IRI conforming to the RFC3987 standard into IRI.-Performs URL-decoding.--}+-- |+-- Parser of a well-formed IRI conforming to the RFC3987 standard into 'Iri'.+-- Performs URL-decoding. iri :: Text -> Either Text Iri-iri =-  either (Left . fromString) Right .-  B.parseOnly (A.iri <* B.endOfInput)+iri = fromParser A.iri -{-|-Same as 'iri', but optimized specifially for the case of HTTP IRIs.--}+-- |+-- Same as 'iri', but optimized specifially for the case of HTTP IRIs. httpIri :: Text -> Either Text HttpIri-httpIri =-  either (Left . fromString) Right .-  B.parseOnly (A.httpIri <* B.endOfInput)+httpIri = fromParser A.httpIri++hierarchy :: Text -> Either Text Hierarchy+hierarchy = fromParser A.hierarchy++scheme :: Text -> Either Text Scheme+scheme = fromParser A.scheme++host :: Text -> Either Text Host+host = fromParser A.host++regName :: Text -> Either Text RegName+regName = fromParser A.regName++domainLabel :: Text -> Either Text DomainLabel+domainLabel = fromParser A.domainLabel++port :: Text -> Either Text Word16+port = fromParser A.port++path :: Text -> Either Text Path+path = fromParser A.path++pathSegment :: Text -> Either Text PathSegment+pathSegment = fromParser A.pathSegment++query :: Text -> Either Text Query+query = fromParser A.query++fragment :: Text -> Either Text Fragment+fragment = fromParser A.fragment
library/Iri/PercentEncoding.hs view
@@ -2,17 +2,18 @@  import Iri.Prelude - {-# INLINE matchHexByte #-} matchHexByte :: a -> (Word8 -> a) -> Word8 -> a matchHexByte failure success x =   if x >= 48 && x <= 57     then success (x - 48)-    else if x >= 65 && x <= 70-      then success (x - 55)-      else if x >= 97 && x <= 102-        then success (x - 87)-        else failure+    else+      if x >= 65 && x <= 70+        then success (x - 55)+        else+          if x >= 97 && x <= 102+            then success (x - 87)+            else failure  {-# INLINE matchPercentEncodedBytes #-} matchPercentEncodedBytes :: a -> (Word8 -> a) -> Word8 -> Word8 -> a
library/Iri/Prelude.hs view
@@ -1,64 +1,82 @@+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+ module Iri.Prelude-(-  module Exports,-)+  ( module Exports,+  ) where ---- base-prelude---------------------------import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO)---- base---------------------------import Foreign as Exports hiding (void)---- contravariant--------------------------+import Control.Applicative as Exports+import Control.Arrow as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip) import Data.Functor.Contravariant as Exports import Data.Functor.Contravariant.Divisible as Exports---- profunctors---------------------------import Data.Profunctor.Unsafe as Exports+import Data.Functor.Identity as Exports+import Data.HashMap.Strict as Exports (HashMap)+import Data.Hashable as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (First (..), Last (..))+import Data.Ord as Exports import Data.Profunctor.Choice as Exports import Data.Profunctor.Strong as Exports---- semigroups--------------------------+import Data.Profunctor.Unsafe as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports import Data.Semigroup as Exports---- bytestring---------------------------import Data.ByteString as Exports (ByteString)---- text--------------------------+import Data.String as Exports import Data.Text as Exports (Text)---- ip--------------------------+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Vector as Exports (Vector)+import Data.Vector.Instances ()+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports hiding (alignment, sizeOf)+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Instances.TH.Lift () import Net.IPv4 as Exports (IPv4) import Net.IPv6 as Exports (IPv6)---- vector---------------------------import Data.Vector as Exports (Vector)---- unordered-containers---------------------------import Data.HashMap.Strict as Exports (HashMap)---- th-lift-instances---------------------------import Instances.TH.Lift as Exports---- bug---------------------------import Bug as Exports------------------------------------------------------------------------------------import qualified Language.Haskell.TH.Lift as A-A.deriveLift ''IPv4-A.deriveLift ''IPv6+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))
library/Iri/QuasiQuoter.hs view
@@ -1,19 +1,18 @@ module Iri.QuasiQuoter-(-  uri,-  httpUri,-)+  ( uri,+    httpUri,+    iri,+    httpIri,+  ) where -import Iri.Prelude hiding (exp)-import Iri.Data-import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Quote-import qualified Iri.Parsing.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString as B import qualified Data.Attoparsec.Text as C+import qualified Iri.Parsing.Attoparsec.ByteString as A import qualified Iri.Parsing.Attoparsec.Text as D-+import Iri.Prelude hiding (exp)+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax  exp :: (String -> Q Exp) -> QuasiQuoter exp exp =@@ -22,42 +21,38 @@     unsupported _ =       fail "Not supported" -{-|-IRI literal parsed from textual URI.--}+-- |+-- 'Iri' literal from ASCII representation. uri :: QuasiQuoter uri =-  exp $ \ string ->-  case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of-    Right iri -> lift iri-    Left error -> fail (showString "URI parsing: " error)+  exp $ \string ->+    case B.parseOnly (A.uri <* B.endOfInput) (fromString string) of+      Right uri -> lift uri+      Left error -> fail (showString "URI parsing: " error) -{-|-HTTP IRI literal parsed from textual URI.--}+-- |+-- 'HttpIri' literal from ASCII representation. httpUri :: QuasiQuoter httpUri =-  exp $ \ string ->-  case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of-    Right iri -> lift iri-    Left error -> fail (showString "HTTP URI parsing: " error)+  exp $ \string ->+    case B.parseOnly (A.httpUri <* B.endOfInput) (fromString string) of+      Right uri -> lift uri+      Left error -> fail (showString "HTTP URI parsing: " error) -{-|-IRI literal parsed from textual IRI.--}+-- |+-- 'Iri' literal from IRI representation. iri :: QuasiQuoter iri =-  exp $ \ string ->-  case C.parseOnly (D.iri <* C.endOfInput) (fromString string) of-    Right iri -> lift iri-    Left error -> fail (showString "IRI parsing: " error)+  exp $ \string ->+    case C.parseOnly (D.iri <* C.endOfInput) (fromString string) of+      Right iri -> lift iri+      Left error -> fail (showString "IRI parsing: " error) -{-|-HTTP IRI literal parsed from textual IRI.--}+-- |+-- 'HttpIri' literal from IRI representation. httpIri :: QuasiQuoter httpIri =-  exp $ \ string ->-  case C.parseOnly (D.httpIri <* C.endOfInput) (fromString string) of-    Right iri -> lift iri-    Left error -> fail (showString "HTTP IRI parsing: " error)+  exp $ \string ->+    case C.parseOnly (D.httpIri <* C.endOfInput) (fromString string) of+      Right iri -> lift iri+      Left error -> fail (showString "HTTP IRI parsing: " error)
library/Iri/Rendering/ByteString.hs view
@@ -1,18 +1,16 @@-module Iri.Rendering.ByteString-where+module Iri.Rendering.ByteString where -import Iri.Prelude import Iri.Data+import Iri.Prelude import qualified Iri.Rendering.Ptr.Poking as A import qualified Ptr.ByteString as F --{-| Render as URI ASCII bytes -}+-- | Render as URI ASCII bytes uri :: Iri -> ByteString uri =   F.poking . A.uri -{-| Render as URI ASCII bytes -}+-- | Render as URI ASCII bytes httpUri :: HttpIri -> ByteString httpUri =   F.poking . A.httpUri
− library/Iri/Rendering/Poke.hs 
@@ -1,14 +0,0 @@-module Iri.Rendering.Poke-where--import Iri.Prelude-import Iri.Data-import Ptr.Poke---{-# NOINLINE urlEncodedByte #-}-urlEncodedByte :: Poke Word8-urlEncodedByte =-  divide (\byte -> ('%', byte))-    asciiChar-    (divide (flip divMod 16) asciiHexDigit asciiHexDigit)
+ library/Iri/Rendering/Ptr/Poke.hs view
@@ -0,0 +1,12 @@+module Iri.Rendering.Ptr.Poke where++import Iri.Prelude+import Ptr.Poke++{-# NOINLINE urlEncodedByte #-}+urlEncodedByte :: Poke Word8+urlEncodedByte =+  divide+    (\byte -> ('%', byte))+    asciiChar+    (divide (flip divMod 16) asciiHexDigit asciiHexDigit)
library/Iri/Rendering/Ptr/Poking.hs view
@@ -1,52 +1,52 @@+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+ module Iri.Rendering.Ptr.Poking-(-  uri,-  httpUri,-  scheme,-  host,-  path,-  query,-)+  ( uri,+    httpUri,+    scheme,+    host,+    path,+    query,+  ) where -import Iri.Prelude hiding (null, poke)-import Iri.Data-import Ptr.Poking+import qualified Data.ByteString as ByteString+import qualified Data.Text as C import qualified Data.Text.Encoding as A-import qualified Data.Text.Encoding.Error as A import qualified Data.Text.Punycode as B-import qualified Data.Text as C-import qualified Data.HashMap.Strict as G-import qualified Data.Vector as H-import qualified Net.IPv4 as D-import qualified Net.IPv6 as E-import qualified Iri.Vector as F import qualified Iri.CodePointPredicates.Core as I import qualified Iri.CodePointPredicates.Rfc3986 as I+import Iri.Data+import Iri.Prelude hiding (null, poke)+import qualified Iri.Rendering.Ptr.Poke as L import qualified Iri.Utf8CodePoint as K-import qualified Iri.Rendering.Poke as L-+import qualified Iri.Vector as F+import qualified Net.IPv4 as D+import qualified Net.IPv6 as E+import Ptr.Poking  uri :: Iri -> Poking uri (Iri schemeValue hierarchyValue queryValue fragmentValue) =-  scheme schemeValue <> -  asciiChar ':' <>-  hierarchy hierarchyValue <>-  (prependIfNotNull-    (asciiChar '?')-    (query queryValue)) <>-  (prependIfNotNull-    (asciiChar '#')-    (fragment fragmentValue))+  scheme schemeValue+    <> asciiChar ':'+    <> hierarchy hierarchyValue+    <> ( prependIfNotNull+           (asciiChar '?')+           (query queryValue)+       )+    <> ( prependIfNotNull+           (asciiChar '#')+           (fragment fragmentValue)+       )  httpUri :: HttpIri -> Poking httpUri (HttpIri (Security secure) hostValue portValue pathValue queryValue fragmentValue) =-  (if secure then bytes "https://" else bytes "http://") <>-  host hostValue <>-  prependIfNotNull (asciiChar ':') (port portValue) <>-  prependIfNotNull (asciiChar '/') (path pathValue) <>-  prependIfNotNull (asciiChar '?') (query queryValue) <>-  prependIfNotNull (asciiChar '#') (fragment fragmentValue)+  (if secure then "https://" else "http://")+    <> host hostValue+    <> prependIfNotNull (asciiChar ':') (port portValue)+    <> prependIfNotNull (asciiChar '/') (path pathValue)+    <> prependIfNotNull (asciiChar '?') (query queryValue)+    <> prependIfNotNull (asciiChar '#') (fragment fragmentValue)  scheme :: Scheme -> Poking scheme (Scheme value) =@@ -54,7 +54,7 @@  hierarchy :: Hierarchy -> Poking hierarchy =-  \ case+  \case     AuthorisedHierarchy authorityValue pathValue ->       bytes "//" <> authority authorityValue <> prependIfNotNull (asciiChar '/') (path pathValue)     AbsoluteHierarchy pathValue ->@@ -64,25 +64,25 @@  authority :: Authority -> Poking authority (Authority userInfoValue hostValue portValue) =-  appendIfNotNull (asciiChar '@') (userInfo userInfoValue) <>-  host hostValue <>-  prependIfNotNull (asciiChar ':') (port portValue)+  appendIfNotNull (asciiChar '@') (userInfo userInfoValue)+    <> host hostValue+    <> prependIfNotNull (asciiChar ':') (port portValue)  userInfo :: UserInfo -> Poking userInfo =-  \ case+  \case     PresentUserInfo (User user) password -> case password of       PresentPassword password -> userInfoComponent user <> asciiChar ':' <> userInfoComponent password       MissingPassword -> userInfoComponent user     MissingUserInfo -> mempty -userInfoComponent :: Text -> Poking+userInfoComponent :: ByteString -> Poking userInfoComponent =-  urlEncodedText I.unencodedUserInfoComponent+  urlEncodedBytes I.unencodedUserInfoComponent  host :: Host -> Poking host =-  \ case+  \case     NamedHost value -> domainName value     IpV4Host value -> ipV4 value     IpV6Host value -> ipV6 value@@ -107,7 +107,7 @@  port :: Port -> Poking port =-  \ case+  \case     PresentPort value -> asciiIntegral value     MissingPort -> mempty @@ -117,28 +117,38 @@  pathSegment :: PathSegment -> Poking pathSegment (PathSegment value) =-  urlEncodedText I.unencodedPathSegment value+  urlEncodedBytes I.unencodedPathSegment value  query :: Query -> Poking query (Query value) =-  urlEncodedText I.unencodedQuery value+  urlEncodedBytes I.unencodedQuery value  fragment :: Fragment -> Poking fragment (Fragment value) =-  urlEncodedText I.unencodedFragment value+  urlEncodedBytes I.unencodedFragment value -{-| Apply URL-encoding to text -}+urlEncodedBytes :: I.Predicate -> ByteString -> Poking+urlEncodedBytes unencodedPredicate =+  ByteString.foldl' (\poking -> mappend poking . byte) mempty+  where+    byte x =+      if unencodedPredicate (fromIntegral x)+        then word8 x+        else urlEncodedByte x++-- | Apply URL-encoding to text urlEncodedText :: I.Predicate -> Text -> Poking urlEncodedText unencodedPredicate =-  C.foldl' (\ poking -> mappend poking . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty+  C.foldl' (\poking -> mappend poking . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty  urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Poking urlEncodedUnicodeCodePoint unencodedPredicate codePoint =-  K.unicodeCodePoint codePoint-    (\ b1 -> if unencodedPredicate codePoint then word8 b1 else urlEncodedByte b1)-    (\ b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)-    (\ b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)-    (\ b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4)+  K.unicodeCodePoint+    codePoint+    (\b1 -> if unencodedPredicate codePoint then word8 b1 else urlEncodedByte b1)+    (\b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)+    (\b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)+    (\b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4)  urlEncodedByte :: Word8 -> Poking urlEncodedByte =
library/Iri/Rendering/Text.hs view
@@ -1,8 +1,6 @@ module Iri.Rendering.Text-(-  module Iri.Rendering.Text.Internal,-)+  ( module Iri.Rendering.Text.Internal,+  ) where  import Iri.Rendering.Text.Internal-import Iri.Data
library/Iri/Rendering/Text/Internal.hs view
@@ -1,18 +1,56 @@-module Iri.Rendering.Text.Internal-where+module Iri.Rendering.Text.Internal where -import Iri.Prelude import Iri.Data.Types+import Iri.Prelude import qualified Iri.Rendering.TextBuilder.Internal as A-import qualified Text.Builder as B-+import qualified TextBuilder as B -{-| Render as a Unicode IRI text -}+-- | Render as a Unicode IRI text iri :: Iri -> Text-iri =-  B.run . A.iri+iri = B.toText . A.iri -{-| Render as a Unicode IRI text -}+-- | Render as a Unicode IRI text httpIri :: HttpIri -> Text-httpIri =-  B.run . A.httpIri+httpIri = B.toText . A.httpIri++scheme :: Scheme -> Text+scheme = B.toText . A.scheme++hierarchy :: Hierarchy -> Text+hierarchy = B.toText . A.hierarchy++authority :: Authority -> Text+authority = B.toText . A.authority++userInfo :: UserInfo -> Text+userInfo = B.toText . A.userInfo++host :: Host -> Text+host = B.toText . A.host++regName :: RegName -> Text+regName = B.toText . A.regName++domainLabel :: DomainLabel -> Text+domainLabel = B.toText . A.domainLabel++ipV4 :: IPv4 -> Text+ipV4 = B.toText . A.ipV4++ipV6 :: IPv6 -> Text+ipV6 = B.toText . A.ipV6++port :: Port -> Text+port = B.toText . A.port++path :: Path -> Text+path = B.toText . A.path++pathSegment :: PathSegment -> Text+pathSegment = B.toText . A.pathSegment++query :: Query -> Text+query = B.toText . A.query++fragment :: Fragment -> Text+fragment = B.toText . A.fragment
library/Iri/Rendering/TextBuilder.hs view
@@ -1,8 +1,6 @@ module Iri.Rendering.TextBuilder-(-  module Iri.Rendering.TextBuilder.Internal,-)+  ( module Iri.Rendering.TextBuilder.Internal,+  ) where  import Iri.Rendering.TextBuilder.Internal-import Iri.Data.Types
library/Iri/Rendering/TextBuilder/Internal.hs view
@@ -1,55 +1,68 @@ module Iri.Rendering.TextBuilder.Internal-(-  iri,-  httpIri,-)+  ( iri,+    httpIri,+    scheme,+    hierarchy,+    authority,+    userInfo,+    host,+    regName,+    domainLabel,+    ipV4,+    ipV6,+    port,+    path,+    pathSegment,+    query,+    fragment,+  ) where -import Iri.Prelude hiding (null)-import Iri.Data.Types-import Text.Builder+import qualified Data.ByteString as ByteString+import qualified Data.Text as C import qualified Data.Text.Encoding as A import qualified Data.Text.Encoding.Error as A-import qualified Data.Text.Punycode as B-import qualified Data.Text as C-import qualified Data.HashMap.Strict as G-import qualified Data.Vector as H+import qualified Iri.CodePointPredicates.Core as CorePredicates+import qualified Iri.CodePointPredicates.Rfc3986 as Rfc3986Predicates+import qualified Iri.CodePointPredicates.Rfc3987 as Rfc3987Predicates+import Iri.Data.Types+import Iri.Prelude hiding (null)+import qualified Iri.Utf8CodePoint as K+import qualified Iri.Vector as F import qualified Net.IPv4 as D import qualified Net.IPv6 as E-import qualified Iri.Vector as F-import qualified Iri.CodePointPredicates.Core as I-import qualified Iri.CodePointPredicates.Rfc3987 as I-import qualified Iri.Utf8CodePoint as K-+import TextBuilder -iri :: Iri -> Builder+iri :: Iri -> TextBuilder iri (Iri schemeValue hierarchyValue queryValue fragmentValue) =-  scheme schemeValue <> -  char ':' <>-  hierarchy hierarchyValue <>-  (prependIfNotNull-    (char '?')-    (query queryValue)) <>-  (prependIfNotNull-    (char '#')-    (fragment fragmentValue))+  scheme schemeValue+    <> char ':'+    <> hierarchy hierarchyValue+    <> ( prependIfNotNull+           (char '?')+           (query queryValue)+       )+    <> ( prependIfNotNull+           (char '#')+           (fragment fragmentValue)+       ) -httpIri :: HttpIri -> Builder+httpIri :: HttpIri -> TextBuilder httpIri (HttpIri (Security secure) hostValue portValue pathValue queryValue fragmentValue) =-  (if secure then string "https://" else string "http://") <>-  host hostValue <>-  prependIfNotNull (char ':') (port portValue) <>-  prependIfNotNull (char '/') (path pathValue) <>-  prependIfNotNull (char '?') (query queryValue) <>-  prependIfNotNull (char '#') (fragment fragmentValue)+  (if secure then string "https://" else string "http://")+    <> host hostValue+    <> prependIfNotNull (char ':') (port portValue)+    <> prependIfNotNull (char '/') (path pathValue)+    <> prependIfNotNull (char '?') (query queryValue)+    <> prependIfNotNull (char '#') (fragment fragmentValue) -scheme :: Scheme -> Builder+scheme :: Scheme -> TextBuilder scheme (Scheme bytes) =   text (A.decodeUtf8With A.lenientDecode bytes) -hierarchy :: Hierarchy -> Builder+hierarchy :: Hierarchy -> TextBuilder hierarchy =-  \ case+  \case     AuthorisedHierarchy authorityValue pathValue ->       string "//" <> authority authorityValue <> prependIfNotNull (char '/') (path pathValue)     AbsoluteHierarchy pathValue ->@@ -57,99 +70,115 @@     RelativeHierarchy pathValue ->       path pathValue -authority :: Authority -> Builder+authority :: Authority -> TextBuilder authority (Authority userInfoValue hostValue portValue) =-  appendIfNotNull (char '@') (userInfo userInfoValue) <>-  host hostValue <>-  prependIfNotNull (char ':') (port portValue)+  appendIfNotNull (char '@') (userInfo userInfoValue)+    <> host hostValue+    <> prependIfNotNull (char ':') (port portValue) -userInfo :: UserInfo -> Builder+userInfo :: UserInfo -> TextBuilder userInfo =-  \ case+  \case     PresentUserInfo (User user) password -> case password of-      PresentPassword password -> userInfoComponent user <> char ':'  <> userInfoComponent password+      PresentPassword password -> userInfoComponent user <> char ':' <> userInfoComponent password       MissingPassword -> userInfoComponent user     MissingUserInfo -> mempty -userInfoComponent :: Text -> Builder+userInfoComponent :: ByteString -> TextBuilder userInfoComponent =-  urlEncodedText I.unencodedUserInfoComponent+  urlEncodedBytesOrText Rfc3987Predicates.unencodedUserInfoComponent Rfc3986Predicates.unencodedUserInfoComponent -host :: Host -> Builder+host :: Host -> TextBuilder host =-  \ case-    NamedHost value -> domainName value+  \case+    NamedHost value -> regName value     IpV4Host value -> ipV4 value     IpV6Host value -> ipV6 value -domainName :: RegName -> Builder-domainName (RegName vector) =+regName :: RegName -> TextBuilder+regName (RegName vector) =   F.intercalate domainLabel (char '.') vector -domainLabel :: DomainLabel -> Builder-domainLabel (DomainLabel value) =-  text value+domainLabel :: DomainLabel -> TextBuilder+domainLabel (DomainLabel x) =+  text x -ipV4 :: IPv4 -> Builder+ipV4 :: IPv4 -> TextBuilder ipV4 =   text . D.encode -ipV6 :: IPv6 -> Builder+ipV6 :: IPv6 -> TextBuilder ipV6 =   text . E.encode -port :: Port -> Builder+port :: Port -> TextBuilder port =-  \ case-    PresentPort value -> unsignedDecimal value+  \case+    PresentPort value -> decimal value     MissingPort -> mempty -path :: Path -> Builder+path :: Path -> TextBuilder path (Path pathSegmentVector) =   F.intercalate pathSegment (char '/') pathSegmentVector -pathSegment :: PathSegment -> Builder+pathSegment :: PathSegment -> TextBuilder pathSegment (PathSegment value) =-  urlEncodedText I.unencodedPathSegment value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedPathSegment Rfc3986Predicates.unencodedPathSegment value -query :: Query -> Builder+query :: Query -> TextBuilder query (Query value) =-  urlEncodedText I.unencodedQuery value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedQuery Rfc3986Predicates.unencodedQuery value -fragment :: Fragment -> Builder+fragment :: Fragment -> TextBuilder fragment (Fragment value) =-  urlEncodedText I.unencodedFragment value+  urlEncodedBytesOrText Rfc3987Predicates.unencodedFragment Rfc3986Predicates.unencodedFragment value -{-| Apply URL-encoding to text -}-urlEncodedText :: I.Predicate -> Text -> Builder+urlEncodedBytesOrText :: CorePredicates.Predicate -> CorePredicates.Predicate -> ByteString -> TextBuilder+urlEncodedBytesOrText unencodedPredicate1 unencodedPredicate2 bytes =+  case A.decodeUtf8' bytes of+    Right text -> urlEncodedText unencodedPredicate1 text+    Left _ -> urlEncodedBytes unencodedPredicate2 bytes++-- | Apply URL-encoding to text+urlEncodedBytes :: CorePredicates.Predicate -> ByteString -> TextBuilder+urlEncodedBytes unencodedPredicate =+  ByteString.foldl'+    ( \builder ->+        mappend builder . \byte ->+          if unencodedPredicate (fromIntegral byte)+            then unicodeCodepoint (fromIntegral byte)+            else urlEncodedByte byte+    )+    mempty++-- | Apply URL-encoding to text+urlEncodedText :: CorePredicates.Predicate -> Text -> TextBuilder urlEncodedText unencodedPredicate =-  C.foldl' (\ builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty+  C.foldl' (\builder -> mappend builder . urlEncodedUnicodeCodePoint unencodedPredicate . ord) mempty -urlEncodedUnicodeCodePoint :: I.Predicate -> Int -> Builder+urlEncodedUnicodeCodePoint :: CorePredicates.Predicate -> Int -> TextBuilder urlEncodedUnicodeCodePoint unencodedPredicate codePoint =   if unencodedPredicate codePoint-    then-      unicodeCodePoint codePoint+    then unicodeCodepoint codePoint     else-      K.unicodeCodePoint codePoint-        (\ b1 -> urlEncodedByte b1)-        (\ b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)-        (\ b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)-        (\ b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4)+      K.unicodeCodePoint+        codePoint+        (\b1 -> urlEncodedByte b1)+        (\b1 b2 -> urlEncodedByte b1 <> urlEncodedByte b2)+        (\b1 b2 b3 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3)+        (\b1 b2 b3 b4 -> urlEncodedByte b1 <> urlEncodedByte b2 <> urlEncodedByte b3 <> urlEncodedByte b4) -urlEncodedByte :: Word8 -> Builder-urlEncodedByte x =-  case divMod x 16 of-    (d1, d2) -> char '%' <> hexadecimalDigit d1 <> hexadecimalDigit d2+urlEncodedByte :: Word8 -> TextBuilder+urlEncodedByte x = char '%' <> hexadecimal x -prependIfNotNull :: Builder -> Builder -> Builder+prependIfNotNull :: TextBuilder -> TextBuilder -> TextBuilder prependIfNotNull prepended it =-  if null it+  if isEmpty it     then mempty     else prepended <> it -appendIfNotNull :: Builder -> Builder -> Builder+appendIfNotNull :: TextBuilder -> TextBuilder -> TextBuilder appendIfNotNull appended it =-  if null it+  if isEmpty it     then mempty     else it <> appended
library/Iri/Utf8CodePoint.hs view
@@ -1,14 +1,11 @@-{- |-Utilities for the UTF-8 encoding.--}+-- |+-- Utilities for the UTF-8 encoding. module Iri.Utf8CodePoint where  import Iri.Prelude --{-|-Church encoding of a UTF8-encoded character.--}+-- |+-- Church encoding of a UTF8-encoded character. type Utf8CodePoint =   forall a.   (Word8 -> a) ->@@ -19,31 +16,30 @@  {-# INLINE char #-} char :: Char -> Utf8CodePoint-char =-  unicodeCodePoint . ord+char a =+  unicodeCodePoint (ord a)  {-# INLINE unicodeCodePoint #-} unicodeCodePoint :: Int -> Utf8CodePoint unicodeCodePoint x f1 f2 f3 f4 =   if x <= 0x7F-    then-      f1 (fromIntegral x)-    else +    then f1 (fromIntegral x)+    else       if x <= 0x07FF         then           f2-          (fromIntegral ((x `shiftR` 6) + 0xC0))-          (fromIntegral ((x .&. 0x3F) + 0x80))+            (fromIntegral ((x `shiftR` 6) + 0xC0))+            (fromIntegral ((x .&. 0x3F) + 0x80))         else           if x <= 0xFFFF             then               f3-              (fromIntegral (x `shiftR` 12) + 0xE0)-              (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)-              (fromIntegral (x .&. 0x3F) + 0x80)+                (fromIntegral (x `shiftR` 12) + 0xE0)+                (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)+                (fromIntegral (x .&. 0x3F) + 0x80)             else               f4-              (fromIntegral (x `shiftR` 18) + 0xF0)-              (fromIntegral ((x `shiftR` 12) .&. 0x3F) + 0x80)-              (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)-              (fromIntegral (x .&. 0x3F) + 0x80)+                (fromIntegral (x `shiftR` 18) + 0xF0)+                (fromIntegral ((x `shiftR` 12) .&. 0x3F) + 0x80)+                (fromIntegral ((x `shiftR` 6) .&. 0x3F) + 0x80)+                (fromIntegral (x .&. 0x3F) + 0x80)
library/Iri/Vector.hs view
@@ -1,12 +1,10 @@-module Iri.Vector-where+module Iri.Vector where -import Iri.Prelude hiding (null, length) import Data.Vector-+import Iri.Prelude hiding (length, null)  {-# INLINE intercalate #-}-intercalate :: (Semigroup monoid, Monoid monoid) => (element -> monoid) -> monoid -> Vector element -> monoid+intercalate :: (Monoid monoid) => (element -> monoid) -> monoid -> Vector element -> monoid intercalate project separator vector =   if null vector     then mempty
+ punycode/Data/Text/Punycode.hs view
@@ -0,0 +1,4 @@+module Data.Text.Punycode (encode, PunycodeDecodeException (..), decode) where++import Data.Text.Punycode.Decode (PunycodeDecodeException (..), decode)+import Data.Text.Punycode.Encode (encode)
+ punycode/Data/Text/Punycode/Decode.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.Text.Punycode.Decode (PunycodeDecodeException (..), decode) where++import Control.Exception.Base+import qualified Data.ByteString as BS+import Data.Char+import Data.Serialize hiding (decode)+import qualified Data.Text as T+import Data.Text.Punycode.Shared+import Data.Typeable+import Data.Word++data PunycodeDecodeException+  = GenericDecodeException+  | InternalStringTooShort+  | InputTooShort+  | RightOfHyphenShouldBeAlphanumeric+  | LeftOfHyphenShouldBeBasic+  | CantStartWithDash+  | InvalidCodePoint+  deriving (Eq, Show, Typeable)++instance Exception PunycodeDecodeException++-- | Decode a string into its unicode form+decode :: BS.ByteString -> Either PunycodeDecodeException T.Text+decode input+  | input == BS.pack [45, 45] = Right $ T.pack "-"+  | not (BS.null input) && BS.length (BS.filter (== 45) input) == 1 && BS.head input == 45 = Left CantStartWithDash+  | T.any (not . isExtendedBasic) before = Left LeftOfHyphenShouldBeBasic+  | otherwise = case runGet (inner2 initial_n 0 initial_bias before) after of+      Right out -> out+      Left _ -> Left InputTooShort+  where+    (before, after)+      | BS.any f input = (T.pack $ map (chr . fromIntegral) $ BS.unpack $ BS.init b1, a1)+      | otherwise = (T.empty, input)+    f = (== (fromIntegral $ ord '-'))+    (b1, a1) = BS.breakEnd f input++inner2 :: Int -> Int -> Int -> T.Text -> Get (Either PunycodeDecodeException T.Text)+inner2 n oldi bias output = do+  b <- isEmpty+  helper b+  where+    helper False = do+      i <- inner base 1 oldi bias+      helper' i+      where+        helper' Nothing = return $ Left RightOfHyphenShouldBeAlphanumeric+        helper' (Just i) = case output' of+          Right output'' -> inner2 n' (i' + 1) bias' output''+          Left err -> return $ Left err+          where+            bias' = adapt (i - oldi) (T.length output + 1) (oldi == 0)+            n' = n + i `div` (T.length output + 1)+            i' = i `mod` (T.length output + 1)+            output' = insertInto output n' i'+    helper True = return $ Right output++inner :: Int -> Int -> Int -> Int -> Get (Maybe Int)+inner k w i bias = do+  word8 <- getWord8+  helper $ word8ToDigit word8+  where+    helper Nothing = return Nothing+    helper (Just digit)+      | digit < t = return $ Just i'+      | otherwise = inner (k + base) w' i' bias+      where+        w' = w * (base - t)+        i' = i + digit * w+        t+          | k <= bias + tmin = tmin+          | k >= bias + tmax = tmax+          | otherwise = k - bias++insertInto :: T.Text -> Int -> Int -> Either PunycodeDecodeException T.Text+insertInto input n i+  | T.length input < i = Left InternalStringTooShort+  | otherwise = case n' of+      Just n'' -> Right $ T.concat [T.take i input, T.singleton n'', T.drop i input]+      Nothing -> Left InvalidCodePoint+  where+    n' = safeChr n++safeChr :: Int -> Maybe Char+safeChr x+  | x >= 0 && x <= fromEnum (maxBound :: Char) = Just $ chr x+  | otherwise = Nothing++word8ToDigit :: Word8 -> Maybe Int+word8ToDigit = helper . fromIntegral+  where+    helper word8+      | word8 >= ord 'a' && word8 <= ord 'z' = Just $ word8 - (ord 'a')+      | word8 >= ord 'A' && word8 <= ord 'Z' = Just $ word8 - (ord 'A')+      | word8 >= ord '0' && word8 <= ord '9' = Just $ 26 + word8 - (ord '0')+      | otherwise = Nothing++isExtendedBasic :: Char -> Bool+isExtendedBasic x+  | isBasic x = True+  | ord x == 128 = True+  | otherwise = False
+ punycode/Data/Text/Punycode/Encode.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleContexts #-}++module Data.Text.Punycode.Encode (encode) where++import Control.Monad+import Control.Monad.State hiding (state)+import Control.Monad.Writer+import qualified Data.ByteString as BS+import Data.Char+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Text.Punycode.Shared+import Data.Word++data PunycodeState = PunycodeState+  { n :: Int,+    delta :: Int,+    bias :: Int,+    h :: Int+  }++-- | Encode a string into its ascii form+encode :: T.Text -> BS.ByteString+encode = execWriter . initialWriter++initialWriter :: (MonadWriter BS.ByteString m) => T.Text -> m ()+initialWriter input = do+  tell basics+  when (b > 0) $ tell $ BS.singleton $ fromIntegral $ ord '-'+  evalStateT (inner3 (map ord $ T.unpack input) b) $+    PunycodeState+      { n = initial_n,+        delta = 0,+        bias = initial_bias,+        h = b+      }+  where+    basics = TE.encodeUtf8 $ T.filter isBasic input+    b = BS.length basics++inner3 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => [Int] -> Int -> m ()+inner3 input b = do+  state <- get+  helper state+  where+    helper state+      | h' < length input = do+          put $ state {n = m, delta = delta'}+          mapM_ (inner2 b) input+          state' <- get+          put $ state' {delta = (delta state') + 1, n = (n state') + 1}+          inner3 input b+      | otherwise = return ()+      where+        m = minimum $ filter (>= n') input+        n' = n state+        h' = h state+        delta' = (delta state) + (m - n') * (h' + 1)++inner2 :: (MonadState PunycodeState m, MonadWriter BS.ByteString m) => Int -> Int -> m ()+inner2 b c = do+  state <- get+  helper state+  where+    helper state+      | c == n' = do+          q <- inner delta' base bias'+          tell $ BS.singleton $ baseToAscii q+          put $ state {bias = adapt delta' (h' + 1) (h' == b), delta = 0, h = (h state) + 1}+      | otherwise = put $ state {delta = delta'}+      where+        delta' = (delta state) + d+          where+            d+              | c < n' = 1+              | otherwise = 0+        n' = n state+        bias' = bias state+        h' = h state++inner :: (MonadWriter BS.ByteString m) => Int -> Int -> Int -> m Int+inner q k bias'+  | q < t = return q+  | otherwise = do+      tell $ BS.singleton $ baseToAscii $ t + ((q - t) `mod` (base - t))+      inner ((q - t) `div` (base - t)) (k + base) bias'+  where+    t+      | k <= bias' + tmin = tmin+      | k >= bias' + tmax = tmax+      | otherwise = k - bias'++baseToAscii :: Int -> Word8+baseToAscii i+  | i < 26 = fromIntegral $ i + (ord 'a')+  | otherwise = fromIntegral $ (i - 26) + (ord '0')
+ punycode/Data/Text/Punycode/Shared.hs view
@@ -0,0 +1,39 @@+module Data.Text.Punycode.Shared where++import Data.Char (ord)++base :: Int+base = 36++tmin :: Int+tmin = 1++tmax :: Int+tmax = 26++skew :: Int+skew = 38++damp :: Int+damp = 700++initial_bias :: Int+initial_bias = 72++initial_n :: Int+initial_n = 128++adapt :: Int -> Int -> Bool -> Int+adapt delta numpoints firsttime = helper+  where+    helper = loop 0 $ delta' + (delta' `div` numpoints)+      where+        delta'+          | firsttime = delta `div` damp+          | otherwise = delta `div` 2+    loop k delta'+      | delta' > ((base - tmin) * tmax) `div` 2 = loop (k + base) $ delta' `div` (base - tmin)+      | otherwise = k + (((base - tmin + 1) * delta') `div` (delta' + skew))++isBasic :: Char -> Bool+isBasic = (< initial_n) . ord
+ test/Main.hs view
@@ -0,0 +1,124 @@+module Main where++import qualified Data.Text as T+import qualified Iri.Parsing.ByteString as D+import qualified Iri.Parsing.Text as F+import Iri.QuasiQuoter+import qualified Iri.Rendering.ByteString as E+import qualified Iri.Rendering.Text as C+import Test.Tasty+import Test.Tasty.HUnit+import Prelude++main :: IO ()+main =+  defaultMain+    $ testGroup "All tests"+    $ [ testCase "No path"+          $ assertEqual+            ""+            (Right "https://ru.wikipedia.org?query")+            ( fmap+                C.iri+                (D.uri "https://ru.wikipedia.org?query")+            ),+        testCase "Cyrillic path" $ do+          assertEqual+            ""+            (Right "https://ru.wikipedia.org/wiki/Баренцбург")+            ( fmap+                C.iri+                (D.uri "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3")+            ),+        testCase "Complex query" $ do+          assertEqual+            ""+            (Right "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb")+            ( fmap+                C.iri+                (D.uri "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb")+            ),+        testCase "Rendering"+          $ let inputs =+                  [ "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3",+                    "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb"+                  ]+             in forM_ inputs $ \input ->+                  assertEqual "" (Right input) (fmap E.uri (D.uri input)),+        testCase "about:blank" $ assertEqual "" "about:blank" (E.uri [uri|about:blank|]),+        testCase "Empty hierarchy" $ assertEqual "" "about:" (E.uri [uri|about:|]),+        testCase "HTTP URI Text Rendering"+          $ assertEqual+            ""+            "https://ru.wikipedia.org/wiki/Баренцбург"+            (C.httpIri [httpUri|https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3|]),+        testCase "HTTP URI Show"+          $ assertEqual+            ""+            "\"https://ru.wikipedia.org/wiki/Баренцбург\""+            (show [httpUri|https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3|]),+        testCase "Messed up URIs"+          $ let testUri uri =+                  assertEqual "Original and parsed URIs are not equal" (Right uri) (fmap E.uri (D.uri uri))+             in traverse_+                  testUri+                  [ "http://m.ru.hellomagazine.com/krasota-i-zdorove/ukhod-za-kozhey-i-volosami/11373-5-prichesok-kotorye-sdelayut-vas-molozhe.html?utm_medium=teaser&utm_campaign=gnezdo1&utm_term=15376&utm_content=[TID",+                    "https://m.tsargrad.tv/news/komediju_113156?%90\"%20"+                  ],+        testCase "User Info"+          $ assertEqual "" (Right "http://user:password@localhost:993") (fmap E.uri (D.uri "http://user:password@localhost:993")),+        testGroup "IRI parser vs. URI parser"+          $ let testUriIri iri uri =+                  testCase (iri <> " vs. " <> uri)+                    $ assertEqual "" (F.iri (fromString iri)) (D.uri (fromString uri))+             in [ testUriIri+                    "https://ru.wikipedia.org/wiki/Баренцбург"+                    "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3",+                  testUriIri+                    "https://www.w3.org/International/articles/idn-and-iri/JP納豆/引き割り納豆.html"+                    "https://www.w3.org/International/articles/idn-and-iri/JP%E7%B4%8D%E8%B1%86/%E5%BC%95%E3%81%8D%E5%89%B2%E3%82%8A%E7%B4%8D%E8%B1%86.html",+                  testUriIri+                    "http://点心和烤鸭.w3.mag.keio.ac.jp"+                    "http://xn--0trv4xfvn8el34t.w3.mag.keio.ac.jp/"+                ],+        testCase "Hex digit parsing bug reproduction - lowercase hex digits"+          $ do+            -- Bug: lowercase hex digits 'a'-'f' were calculated as (ascii - 97) instead of (ascii - 87)+            -- This caused %6a (should be ASCII 106 = 'j') to be parsed incorrectly+            -- %6a = 6*16 + 10 = 106 = 'j', but with bug: 6*16 + 0 = 96 = '`'+            let result = F.iri "https://example.com/test%6a" -- should be 'j'+            case result of+              Left err -> assertFailure $ "Should parse successfully: " ++ T.unpack err+              Right iri ->+                let rendered = C.iri iri -- Use text rendering to see decoded content+                 in assertBool "Should contain 'j' when correctly parsed" ('j' `T.elem` rendered),+        testCase "Lowercase hex digits a-f UTF-8 parsing"+          $ do+            -- Test that %c3%a9 (UTF-8 for é) parses correctly with lowercase hex+            -- This tests the fix for hex digits 'c' and 'a' which were affected by the bug+            let result = F.iri "https://example.com/caf%c3%a9"+            case result of+              Left _ -> assertFailure "Should parse UTF-8 encoded URL successfully"+              Right iri ->+                let rendered = C.iri iri -- Use text rendering to see the decoded UTF-8+                 in assertBool "Should contain é character when correctly decoded" ('é' `T.elem` rendered),+        testGroup "Mess"+          $ [ testCase "1"+                $ assertEqual+                  ""+                  (Right "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB")+                  (fmap E.uri (D.uri "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB")),+              testGroup "2"+                $ [ testCase "show"+                      $ assertEqual+                        ""+                        (Right "\"https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html\"")+                        (fmap show (D.uri "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html")),+                    testCase "Text rendering"+                      $ assertEqual+                        ""+                        (Right "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html")+                        (fmap C.iri (D.uri "https://www.pleer.ru/search_%e4%eb%ff+%e1%e5%eb%fc%ff+%f1%f3%f8%e8%eb%ea%e0.html"))+                  ]+            ]+      ]
− tests/Main.hs 
@@ -1,93 +0,0 @@-module Main where--import Prelude-import Test.QuickCheck.Instances-import Test.Tasty-import Test.Tasty.Runners-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck-import Iri.QuasiQuoter-import qualified Iri.Data as A-import qualified Iri.Parsing.ByteString as D-import qualified Iri.Parsing.Text as F-import qualified Iri.Rendering.Text as C-import qualified Iri.Rendering.ByteString as E---main =-  defaultMain $-  testGroup "All tests" $-  [-    testCase "No path" $-    assertEqual ""-      (Right "https://ru.wikipedia.org?query")-      (fmap C.iri-        (D.uri "https://ru.wikipedia.org?query"))-    ,-    testCase "Cyrillic path" $ do-      assertEqual ""-        (Right "https://ru.wikipedia.org/wiki/Баренцбург")-        (fmap C.iri-          (D.uri "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3"))-    ,-    testCase "Complex query" $ do-      assertEqual ""-        (Right "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb")-        (fmap C.iri-          (D.uri "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb"))-    ,-    testCase "Rendering" $-    let-      inputs =-        [-          "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3"-          ,-          "https://news.yandex.ru/yandsearch?cl4url=iz.ru/669426/2017-11-10/smi-inoagenty-obiazhut-soobshchat-ob-etom-v-sotcsetiakh&lang=ru&from=main_portal&stid=5bdMOjSopWu34pdT-391&lr=213&msid=1510328052.50316.22874.7658&mlid=1510327228.glob_225.904af5bb"-        ]-      in-        forM_ inputs $ \ input ->-        let-          Right iri = D.uri input-          in assertEqual "" input (E.uri iri)-    ,-    testCase "about:blank" $ assertEqual "" "about:blank" (E.uri [uri|about:blank|])-    ,-    testCase "Empty hierarchy" $ assertEqual "" "about:" (E.uri [uri|about:|])-    ,-    testCase "HTTP URI Text Rendering" $-    assertEqual ""-      "https://ru.wikipedia.org/wiki/Баренцбург"-      (C.httpIri [httpUri|https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3|])-    ,-    testCase "HTTP URI Show" $-    assertEqual ""-      "https://ru.wikipedia.org/wiki/Баренцбург"-      (show [httpUri|https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3|])-    ,-    parsing-  ]--parsing =-  testGroup "Parsing" $-  [-    testCase "User Info" $-    assertEqual "" (Right "http://user:password@localhost:993") (fmap E.uri (D.uri "http://user:password@localhost:993"))-    ,-    testCase "URI, IRI" $-    assertEqual ""-      (D.uri "https://ru.wikipedia.org/wiki/%D0%91%D0%B0%D1%80%D0%B5%D0%BD%D1%86%D0%B1%D1%83%D1%80%D0%B3")-      (F.iri "https://ru.wikipedia.org/wiki/Баренцбург")-    ,-    testGroup "Mess" $-    [-      testCase "1" $-      assertEqual ""-        (Right "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB")-        (fmap E.uri (D.uri "https://www.kupivip.ru/catalog/muzhchinam/odezhda?srcid=goo-tm-open&lpu=|source:google|medium:cpc|adposition:1t1|creative:195388077752|term:%2B%D0%B2%D0%B8%D0%BF%20%2B%D0%BA%D1%83%D0%BF%D0%B8|campaignid:801742449|campaign:goo_tm_mob_s_male|other:m|ad:1|&gclid=CjwKEAjwgb3OBRDNi_2TwZ6u7D4SJADsmW8QKiRxDZZ0hRAnyspAcVW582c7zzQSA7CC0FavPR63dBoCrKPw_wcB"))-      ,-      testCase "2" $-      assertEqual ""-        (Right "https://www.pleer.ru/search_%E4%EB%FF+%E1%E5%EB%FC%FF+%F1%F3%F8%E8%EB%EA%E0.html")-        (fmap show (D.uri "https://www.pleer.ru/search_%E4%EB%FF+%E1%E5%EB%FC%FF+%F1%F3%F8%E8%EB%EA%E0.html"))-    ]-  ]