diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,19 @@ (!) Breaking change ``` +2.2.0.0 [2026-09-30] +-------------------- +``` + Create Mini.String.XML + hash(class): Add Hashable instance for pairs + hash(class): Add Hashable instance for Maybe + hash(class): Add Hashable instance for Either + hash(class): Add Hashable instance for NonEmpty + string(uri): Format + string(uri): Add Hashable instances +(!) data(map): Fix Hashable instance +``` + 2.1.0.0 [2026-09-07] -------------------- ``` diff --git a/mini.cabal b/mini.cabal --- a/mini.cabal +++ b/mini.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: mini -version: 2.1.0.0 +version: 2.2.0.0 license: MIT license-file: LICENSE author: Victor Wallsten @@ -49,6 +49,7 @@ Mini.Random.SplitMix Mini.String.URI Mini.String.UTF8 + Mini.String.XML Mini.Transformers.Class Mini.Transformers.Either Mini.Transformers.Maybe diff --git a/src/Mini/Data/Map.hs b/src/Mini/Data/Map.hs --- a/src/Mini/Data/Map.hs +++ b/src/Mini/Data/Map.hs @@ -105,7 +105,6 @@ Show, Traversable, compare, - concatMap, const, error, flip, @@ -181,8 +180,8 @@ instance (Ord k) => Monoid (Map k a) where mempty = E -instance (Hashable a) => Hashable (Map k a) where - toBytes = concatMap toBytes +instance (Hashable k, Hashable a) => Hashable (Map k a) where + toBytes = foldrWith (\k a b -> toBytes k <> toBytes a <> b) [] -- | Primitive recursion on maps (internally structured as trees) map diff --git a/src/Mini/Hash/Class.hs b/src/Mini/Hash/Class.hs --- a/src/Mini/Hash/Class.hs +++ b/src/Mini/Hash/Class.hs @@ -24,6 +24,11 @@ Int64, Int8, ) +import Data.List.NonEmpty ( + NonEmpty ( + (:|) + ), + ) import Data.Word ( Word, Word16, @@ -40,8 +45,16 @@ import Prelude ( Bool, Char, + Either ( + Left, + Right + ), Enum, Integral, + Maybe ( + Just, + Nothing + ), concatMap, div, fmap, @@ -52,6 +65,7 @@ take, ($), (.), + (<>), ) -- Classes @@ -105,8 +119,22 @@ instance Hashable Word64 where toBytes = finiteBitsIntegralToBytes +instance (Hashable a) => Hashable (Maybe a) where + toBytes Nothing = [] + toBytes (Just a) = toBytes a + +instance (Hashable a, Hashable b) => Hashable (Either a b) where + toBytes (Left a) = toBytes a + toBytes (Right b) = toBytes b + +instance (Hashable a, Hashable b) => Hashable (a, b) where + toBytes (a, b) = toBytes a <> toBytes b + instance (Hashable a) => Hashable [a] where toBytes = concatMap toBytes + +instance (Hashable a) => Hashable (NonEmpty a) where + toBytes (a :| as) = toBytes a <> toBytes as instance (Hashable a) => Hashable (Array i a) where toBytes = concatMap toBytes diff --git a/src/Mini/String/URI.hs b/src/Mini/String/URI.hs --- a/src/Mini/String/URI.hs +++ b/src/Mini/String/URI.hs @@ -96,6 +96,10 @@ import Data.Word ( Word8, ) +import Mini.Hash.Class ( + Hashable, + toBytes, + ) import qualified Mini.String.UTF8 as UTF8 ( decode, encode, @@ -177,6 +181,14 @@ <> maybe "" (("?" <>) . show) q <> maybe "" (("#" <>) . show) f +instance Hashable URI where + toBytes (URI s a p q f) = + toBytes s + <> toBytes a + <> toBytes p + <> toBytes q + <> toBytes f + -- | The authority component of a URI data Authority = -- | without the leading @"\/\/"@ @@ -189,6 +201,9 @@ <> show h <> maybe "" ((":" <>) . show) p +instance Hashable Authority where + toBytes (Authority u h p) = toBytes u <> toBytes h <> toBytes p + -- | The host component of an authority data Host = IPv4 Address @@ -203,6 +218,12 @@ show (IPvF v a) = "v" <> show v <> "." <> show a show (RegName a) = show a +instance Hashable Host where + toBytes (IPv4 a) = toBytes a + toBytes (IPv6 a) = toBytes a + toBytes (IPvF v a) = toBytes v <> toBytes a + toBytes (RegName a) = toBytes a + -- | The path component of a URI data Path = Path @@ -219,6 +240,9 @@ <> intercalate "/" (fmap show segs) <> bool "" "/" t +instance Hashable Path where + toBytes (Path l segs t) = toBytes l <> toBytes segs <> toBytes t + -- | The address of a host newtype Address = Address String deriving (Eq, Ord) @@ -226,6 +250,9 @@ instance Show Address where show (Address a) = a +instance Hashable Address where + toBytes (Address a) = toBytes a + -- | The fragment component of a URI newtype Fragment = -- | without the leading @"#"@ @@ -235,6 +262,9 @@ instance Show Fragment where show (Fragment f) = f +instance Hashable Fragment where + toBytes (Fragment f) = toBytes f + -- | The port component of an authority newtype Port = -- | without the leading @":"@ @@ -244,6 +274,9 @@ instance Show Port where show (Port p) = p +instance Hashable Port where + toBytes (Port p) = toBytes p + -- | The query component of a URI newtype Query = -- | without the leading @"?"@ @@ -253,6 +286,9 @@ instance Show Query where show (Query q) = q +instance Hashable Query where + toBytes (Query q) = toBytes q + -- | The scheme component of a URI newtype Scheme = -- | without the trailing @":"@ @@ -262,6 +298,9 @@ instance Show Scheme where show (Scheme s) = s +instance Hashable Scheme where + toBytes (Scheme s) = toBytes s + -- | A segment of a path newtype Segment = -- | without any delimiting @"\/"@ @@ -271,6 +310,9 @@ instance Show Segment where show (Segment s) = s +instance Hashable Segment where + toBytes (Segment s) = toBytes s + -- | The userinfo component of an authority newtype UserInfo = -- | without the trailing @"\@"@ @@ -280,6 +322,9 @@ instance Show UserInfo where show (UserInfo u) = u +instance Hashable UserInfo where + toBytes (UserInfo u) = toBytes u + -- | The version of a future IP newtype Version = -- | without the leading @"v"@ and trailing @"."@ @@ -289,6 +334,9 @@ instance Show Version where show (Version v) = v +instance Hashable Version where + toBytes (Version v) = toBytes v + -- Parsers -- | Parse an absolute URI (a generic URI without a fragment) @@ -342,7 +390,7 @@ encode :: Char -> String encode = concatMap (('%' :) . twoDigitHex) . UTF8.encode where - twoDigitHex w = [hex $ w `shiftR` 4, hex $ w .&. 0x0f] + twoDigitHex w = [hex $ w `shiftR` 4, hex $ w .&. 0x0F] hex n = toEnum . fromEnum . (+ n) . bool 0x37 0x30 $ n <= 9 -- | Parse a percent-encoded octet sequence in UTF-8 format into a character diff --git a/src/Mini/String/XML.hs b/src/Mini/String/XML.hs new file mode 100644 --- /dev/null +++ b/src/Mini/String/XML.hs @@ -0,0 +1,613 @@ +-- | XML 1.0 (Fifth Edition): +module Mini.String.XML ( + -- * Types + Document ( + Document + ), + Element ( + Element + ), + Node ( + NodeCData, + NodeComment, + NodeElement, + NodePI + ), + Misc ( + MiscComment, + MiscPI, + MiscSpace + ), + PI ( + PI + ), + Attributes ( + Attributes + ), + EType ( + EType + ), + CData ( + CData + ), + Key ( + Key + ), + Value ( + Value + ), + Comment ( + Comment + ), + Target ( + Target + ), + Instruction ( + Instruction + ), + Space ( + Space + ), + + -- * Parsers + document, + + -- * Encoding + encode, + decode, +) where + +import Control.Applicative ( + empty, + many, + optional, + some, + (<|>), + ) +import Data.Bits ( + shiftL, + ) +import Data.Bool ( + bool, + ) +import Data.Char ( + digitToInt, + ) +import Mini.Data.Map ( + Map, + ) +import qualified Mini.Data.Map as Map ( + foldrWith, + insert, + member, + ) +import Mini.Hash.Class ( + Hashable, + toBytes, + ) +import Mini.Transformers.Parser ( + ParserT, + accept, + noneOf, + oneOf, + reject, + sat, + string, + symbol, + till, + ) +import Prelude ( + Char, + Eq, + Maybe, + Monad, + Ord, + Show, + String, + concatMap, + dropWhile, + foldl, + fromEnum, + maybe, + mempty, + null, + pure, + show, + toEnum, + ($), + (&&), + (*), + (*>), + (+), + (.), + (<$), + (<$>), + (<*), + (<*>), + (<=), + (<>), + (==), + (>=), + (>>=), + (||), + ) + +-- Types + +-- | An XML document +data Document = Document [Misc] Element [Misc] + deriving (Eq, Ord) + +instance Show Document where + show (Document ms e ms') = concatMap show ms <> show e <> concatMap show ms' + +instance Hashable Document where + toBytes = toBytes . show + +-- | An element +data Element = Element EType Attributes [Node] + deriving (Eq, Ord) + +instance Show Element where + show (Element t as ns) = + "<" + <> show t + <> show as + <> bool + ( ">" + <> concatMap show ns + <> " show t + <> ">" + ) + ("/>") + (null ns) + +instance Hashable Element where + toBytes = toBytes . show + +-- | An element node +data Node + = NodeCData CData + | NodeComment Comment + | NodeElement Element + | NodePI PI + deriving (Eq, Ord) + +instance Show Node where + show (NodeCData cd) = show cd + show (NodeComment c) = show c + show (NodeElement e) = show e + show (NodePI p) = show p + +instance Hashable Node where + toBytes = toBytes . show + +-- | A miscellaneous component +data Misc + = MiscComment Comment + | MiscPI PI + | MiscSpace Space + deriving (Eq, Ord) + +instance Show Misc where + show (MiscComment c) = show c + show (MiscPI p) = show p + show (MiscSpace s) = show s + +instance Hashable Misc where + toBytes = toBytes . show + +-- | Element attributes +newtype Attributes = Attributes (Map Key Value) + deriving (Eq, Ord) + +-- | Values are shown within double quotes +instance Show Attributes where + show (Attributes as) = + Map.foldrWith + (\k v b -> " " <> show k <> "=\"" <> show v <> "\"" <> b) + [] + as + +instance Hashable Attributes where + toBytes = toBytes . show + +-- | A processing instruction +data PI = PI Target (Maybe Instruction) + deriving (Eq, Ord) + +instance Show PI where + show (PI t i) = " show t <> maybe "" ((' ' :) . show) i <> "?>" + +instance Hashable PI where + toBytes = toBytes . show + +-- | An element type +newtype EType = EType String + deriving (Eq, Ord) + +instance Show EType where + show (EType t) = t + +instance Hashable EType where + toBytes = toBytes . show + +-- | Character data +newtype CData = CData String + deriving (Eq, Ord) + +-- | Encodes @<&@ into predefined entities +instance Show CData where + show (CData cd) = concatMap enc cd + where + enc '&' = "&" + enc '<' = "<" + enc c = [c] + +instance Hashable CData where + toBytes = toBytes . show + +-- | An attribute key +newtype Key = Key String + deriving (Eq, Ord) + +instance Show Key where + show (Key k) = k + +instance Hashable Key where + toBytes = toBytes . show + +-- | An attribute value +newtype Value + = -- | without the surrounding quotes + Value String + deriving (Eq, Ord) + +-- | Encodes @<&"@ into predefined entities +instance Show Value where + show (Value v) = concatMap enc v + where + enc '&' = "&" + enc '<' = "<" + enc '"' = """ + enc c = [c] + +instance Hashable Value where + toBytes = toBytes . show + +-- | A comment +newtype Comment + = -- | without the leading @""@ + Comment String + deriving (Eq, Ord) + +instance Show Comment where + show (Comment c) = "" + +instance Hashable Comment where + toBytes = toBytes . show + +-- | A PI target +newtype Target = Target String + deriving (Eq, Ord) + +instance Show Target where + show (Target t) = t + +instance Hashable Target where + toBytes = toBytes . show + +-- | A PI instruction +newtype Instruction = Instruction String + deriving (Eq, Ord) + +instance Show Instruction where + show (Instruction i) = i + +instance Hashable Instruction where + toBytes = toBytes . show + +-- | Miscellaneous whitespace +newtype Space = Space String + deriving (Eq, Ord) + +instance Show Space where + show (Space s) = s + +instance Hashable Space where + toBytes = toBytes . show + +-- Parsers + +-- | Parse an XML document. +-- +-- Enforces well-formedness constraints /Element Type Match/, /Unique Att Spec/, +-- and /Legal Character/. +-- +-- Rejects documents containing a document type declaration or non-predefined +-- entity references. +-- +-- Normalizes line breaks according to section 2.11 /End-of-Line Handling/. +-- +-- Decodes predefined entity references and numeric references. +document :: (Monad m) => ParserT Char m Document +document = Document <$> prolog <*> element <*> many misc + +-- Encoding + +-- | Turn a character into a predefined or decimal reference +encode :: Char -> String +encode '&' = "&" +encode '<' = "<" +encode '>' = ">" +encode '"' = """ +encode '\'' = "'" +encode c = "&#" <> show (fromEnum c) <> ";" + +-- | Parse a predefined or numeric reference into a legal character +decode :: (Monad m) => ParserT Char m Char +decode = symbol '&' *> (entityRef <|> charRef) <* symbol ';' + where + entityRef = + ('&' <$ string "amp") + <|> ('<' <$ string "lt") + <|> ('>' <$ string "gt") + <|> ('"' <$ string "quot") + <|> ('\'' <$ string "apos") + charRef = symbol '#' *> (dec <|> hex) + dec = + some (oneOf ['0' .. '9']) + >>= ( \n -> + bool + empty + (pure $ toEnum n) + $ isLegal n + ) + . foldl (\b a -> digitToInt a + b * 10) 0 + . dropWhile (== '0') + hex = + (symbol 'x' *> some (oneOf $ ['0' .. '9'] <> ['a' .. 'f'] <> ['A' .. 'F'])) + >>= ( \n -> + bool + empty + (pure $ toEnum n) + $ isLegal n + ) + . foldl (\b a -> digitToInt a + (b `shiftL` 4)) 0 + . dropWhile (== '0') + isLegal = + ( \n -> + n == 0x9 + || n == 0xA + || n == 0xD + || n >= 0x20 && n <= 0xD7FF + || n >= 0xE000 && n <= 0xFFFD + || n >= 0x10000 && n <= 0x10FFFF + ) + . fromEnum + +-- Helpers + +char :: (Monad m) => ParserT Char m Char +char = + ('\n' <$ string "\r\n") + <|> ('\n' <$ symbol '\r') + <|> ( sat $ + ( \n -> + n == 0x9 + || n == 0xA + || n >= 0x20 && n <= 0xD7FF + || n >= 0xE000 && n <= 0xFFFD + || n >= 0x10000 && n <= 0x10FFFF + ) + . fromEnum + ) + +space :: (Monad m) => ParserT Char m Space +space = + Space + <$> ( some . sat $ + (\n -> n == 0x20 || n == 0x9 || n == 0xD || n == 0xA) . fromEnum + ) + +nameStartChar :: (Monad m) => ParserT Char m Char +nameStartChar = + symbol ':' + <|> oneOf ['A' .. 'Z'] + <|> symbol '_' + <|> oneOf ['a' .. 'z'] + <|> sat + ( ( \n -> + n >= 0xC0 && n <= 0xD6 + || n >= 0xD8 && n <= 0xF6 + || n >= 0xF8 && n <= 0x2FF + || n >= 0x370 && n <= 0x37D + || n >= 0x37F && n <= 0x1FFF + || n >= 0x200C && n <= 0x200D + || n >= 0x2070 && n <= 0x218F + || n >= 0x2C00 && n <= 0x2FEF + || n >= 0x3001 && n <= 0xD7FF + || n >= 0xF900 && n <= 0xFDCF + || n >= 0xFDF0 && n <= 0xFFFD + || n >= 0x10000 && n <= 0xEFFFF + ) + . fromEnum + ) + +nameChar :: (Monad m) => ParserT Char m Char +nameChar = + nameStartChar + <|> symbol '-' + <|> symbol '.' + <|> oneOf ['0' .. '9'] + <|> sat + ( ( \n -> + n == 0xB7 + || n >= 0x0300 && n <= 0x036F + || n >= 0x203F && n <= 0x2040 + ) + . fromEnum + ) + +name :: (Monad m) => ParserT Char m String +name = (:) <$> nameStartChar <*> many nameChar + +value :: (Monad m) => ParserT Char m Value +value = + Value + <$> ( (doubleQuoted $ many (noneOf "<&\"" <|> decode)) + <|> (singleQuoted $ many (noneOf "<&'" <|> decode)) + ) + +cData :: (Monad m) => ParserT Char m CData +cData = CData <$> (some $ reject (string "]]>") *> exclude "<&") + +comment :: (Monad m) => ParserT Char m Comment +comment = + Comment + <$> ( string "" + ) + +pi :: (Monad m) => ParserT Char m PI +pi = + PI + <$> (string " target) + <*> optional + (Instruction <$> (space *> many (reject (string "?>") *> char))) + <* string "?>" + +target :: (Monad m) => ParserT Char m Target +target = Target <$> (reject (oneOf "Xx" *> oneOf "Mm" *> oneOf "Ll") *> name) + +cdSect :: (Monad m) => ParserT Char m CData +cdSect = CData <$> (string " (char `till` string "]]>")) + +-- NOTE: rejecting doctypedecl +prolog :: (Monad m) => ParserT Char m [Misc] +prolog = optional xmlDecl *> many misc + +xmlDecl :: (Monad m) => ParserT Char m () +xmlDecl = + () + <$ ( string " versionInfo + *> optional encodingDecl + *> optional sdDecl + *> optional space + *> string "?>" + ) + +versionInfo :: (Monad m) => ParserT Char m () +versionInfo = + () + <$ ( space + *> string "version" + *> eq + *> (doubleQuoted versionNum <|> singleQuoted versionNum) + ) + +eq :: (Monad m) => ParserT Char m Char +eq = optional space *> symbol '=' <* optional space + +versionNum :: (Monad m) => ParserT Char m () +versionNum = () <$ (string "1." *> some (oneOf ['0' .. '9'])) + +misc :: (Monad m) => ParserT Char m Misc +misc = + (MiscComment <$> comment) + <|> (MiscPI <$> pi) + <|> (MiscSpace <$> space) + +sdDecl :: (Monad m) => ParserT Char m () +sdDecl = + () + <$ ( space + *> string "standalone" + *> eq + *> ( doubleQuoted (string "yes" <|> string "no") + <|> singleQuoted (string "yes" <|> string "no") + ) + ) + +element :: (Monad m) => ParserT Char m Element +element = do + t <- symbol '<' *> (EType <$> name) + as <- attributes + (Element t as [] <$ string "/>") + <|> ( do + ns <- symbol '>' *> nodes + t' <- + string " (EType <$> name) + <* optional space + <* symbol '>' + bool + empty + (pure $ Element t as ns) + $ t == t' + ) + +attributes :: (Monad m) => ParserT Char m Attributes +attributes = (many (space *> attribute) <* optional space) >>= go mempty + where + go t ((k, v) : as) = bool (go (Map.insert k v t) as) empty $ k `Map.member` t + go t [] = pure $ Attributes t + +attribute :: (Monad m) => ParserT Char m (Key, Value) +attribute = (,) <$> (Key <$> name) <* eq <*> value + +nodes :: (Monad m) => ParserT Char m [Node] +nodes = go <$> many node + where + go (NodeCData (CData cd) : NodeCData (CData cd') : rest) = + NodeCData (CData $ cd <> cd') : go rest + go (n : ns) = n : go ns + go [] = [] + +node :: (Monad m) => ParserT Char m Node +node = + ( NodeCData + <$> ( cData + <|> (CData <$> (pure <$> decode)) + <|> cdSect + ) + ) + <|> (NodeComment <$> comment) + <|> (NodeElement <$> element) + <|> (NodePI <$> pi) + +encodingDecl :: (Monad m) => ParserT Char m () +encodingDecl = + () + <$ ( space + *> string "encoding" + *> eq + *> (doubleQuoted encName <|> singleQuoted encName) + ) + +encName :: (Monad m) => ParserT Char m () +encName = + () + <$ ( (:) + <$> oneOf (['A' .. 'Z'] <> ['a' .. 'z']) + <*> many + ( oneOf + ( ['A' .. 'Z'] + <> ['a' .. 'z'] + <> ['0' .. '9'] + <> "._-" + ) + ) + ) + +doubleQuoted :: (Monad m) => ParserT Char m a -> ParserT Char m a +doubleQuoted p = symbol '"' *> p <* symbol '"' + +singleQuoted :: (Monad m) => ParserT Char m a -> ParserT Char m a +singleQuoted p = symbol '\'' *> p <* symbol '\'' + +exclude :: (Monad m) => String -> ParserT Char m Char +exclude str = accept (noneOf str) *> char