diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main(main) + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/opentheory-unicode.cabal b/opentheory-unicode.cabal new file mode 100644 --- /dev/null +++ b/opentheory-unicode.cabal @@ -0,0 +1,49 @@ +name: opentheory-unicode +version: 1.137 +category: Text +synopsis: Unicode characters +license: MIT +license-file: LICENSE +cabal-version: >= 1.8.0.2 +build-type: Simple +author: Joe Leslie-Hurd +maintainer: Joe Leslie-Hurd +description: + Unicode characters - this package was automatically generated from the + OpenTheory package char-1.137 + +library + build-depends: + base >= 4.0 && < 5.0, + QuickCheck >= 2.4.0.1 && < 3.0, + opentheory-primitive >= 1.3 && < 2.0, + opentheory >= 1.193 && < 1.196, + opentheory-byte >= 1.123 && < 1.124, + opentheory-bits >= 1.63 && < 1.64, + opentheory-parser >= 1.154 && < 1.156, + opentheory-probability >= 1.46 && < 1.47 + + hs-source-dirs: src + + ghc-options: -Wall + + exposed-modules: + OpenTheory.Unicode + OpenTheory.Unicode.UTF8 + +executable opentheory-unicode-test + build-depends: + base >= 4.0 && < 5.0, + QuickCheck >= 2.4.0.1 && < 3.0, + opentheory-primitive >= 1.3 && < 2.0, + opentheory >= 1.193 && < 1.196, + opentheory-byte >= 1.123 && < 1.124, + opentheory-bits >= 1.63 && < 1.64, + opentheory-parser >= 1.154 && < 1.156, + opentheory-probability >= 1.46 && < 1.47 + + hs-source-dirs: src, testsrc + + ghc-options: -Wall + + main-is: Main.hs diff --git a/src/OpenTheory/Unicode.hs b/src/OpenTheory/Unicode.hs new file mode 100644 --- /dev/null +++ b/src/OpenTheory/Unicode.hs @@ -0,0 +1,55 @@ +{- | +module: $Header$ +description: Unicode characters +license: MIT + +maintainer: Joe Leslie-Hurd +stability: provisional +portability: portable +-} + +module OpenTheory.Unicode +where + +import qualified OpenTheory.Natural.Bits as Bits +import qualified OpenTheory.Natural.Uniform as Uniform +import qualified OpenTheory.Primitive.Natural as Natural +import qualified OpenTheory.Primitive.Random as Random +import qualified Test.QuickCheck as QuickCheck + +newtype Unicode = Unicode { unUnicode :: Natural.Natural } + deriving (Eq, Ord, Show) + +destPlane :: Natural.Natural -> Natural.Natural +destPlane n = Bits.shiftRight n 16 + +destPosition :: Natural.Natural -> Natural.Natural +destPosition n = Bits.bound n 16 + +invariant :: Natural.Natural -> Bool +invariant n = + let pl = destPlane n in + let pos = destPosition n in + pos < 65534 && + if not (pl == 0) then pl < 17 + else + not (55296 <= pos && pos < 57344) && not (64976 <= pos && pos < 65008) + +plane :: Unicode -> Natural.Natural +plane = destPlane . unUnicode + +position :: Unicode -> Natural.Natural +position = destPosition . unUnicode + +random :: Random.Random -> Unicode +random r = + let n0 = Uniform.random 1111998 r in + let n1 = if n0 < 55296 then n0 else n0 + 2048 in + let n2 = if n1 < 64976 then n1 else n1 + 32 in + let pl = n2 `div` 65534 in + let pos = n2 `mod` 65534 in + let n = pos + Bits.shiftLeft pl 16 in + Unicode n + +instance QuickCheck.Arbitrary Unicode where + arbitrary = fmap random QuickCheck.arbitrary diff --git a/src/OpenTheory/Unicode/UTF8.hs b/src/OpenTheory/Unicode/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/OpenTheory/Unicode/UTF8.hs @@ -0,0 +1,133 @@ +{- | +module: $Header$ +description: Unicode characters +license: MIT + +maintainer: Joe Leslie-Hurd +stability: provisional +portability: portable +-} + +module OpenTheory.Unicode.UTF8 +where + +import qualified OpenTheory.Natural.Bits as Bits +import qualified OpenTheory.Parser as Parser +import qualified OpenTheory.Parser.Stream as Stream +import qualified OpenTheory.Primitive.Byte as Byte +import qualified OpenTheory.Primitive.Natural as Natural +import qualified OpenTheory.Unicode as Unicode + +parseAscii :: Parser.Parser Byte.Byte Natural.Natural +parseAscii = + Parser.token + (\b -> if Byte.bit b 7 then Nothing else Just (Byte.toNatural b)) + +isContinuationByte :: Byte.Byte -> Bool +isContinuationByte b = Byte.bit b 7 && not (Byte.bit b 6) + +parseMultibyte :: Parser.Parser Byte.Byte Natural.Natural +parseMultibyte = + Parser.sequenceParser + (Parser.token + (\b -> + if Byte.bit b 6 then + if Byte.bit b 5 then + if Byte.bit b 4 then + if Byte.bit b 3 then Nothing else Just (parse4 b) + else Just (parse3 b) + else Just (parse2 b) + else Nothing)) + where + {-parse2 :: Byte.Byte -> Parser.Parser Byte.Byte Natural.Natural-} + parse2 b = + Parser.filterParser + (Parser.foldN addContinuationByte 0 + (Byte.toNatural (Byte.and b 31))) (\n -> 128 <= n) + + {-parse3 :: Byte.Byte -> Parser.Parser Byte.Byte Natural.Natural-} + parse3 b = + Parser.filterParser + (Parser.foldN addContinuationByte 1 + (Byte.toNatural (Byte.and b 15))) (\n -> 2048 <= n) + + {-parse4 :: Byte.Byte -> Parser.Parser Byte.Byte Natural.Natural-} + parse4 b = + Parser.filterParser + (Parser.foldN addContinuationByte 2 + (Byte.toNatural (Byte.and b 7))) (\n -> 65536 <= n) + + {-addContinuationByte :: + Byte.Byte -> Natural.Natural -> Maybe Natural.Natural-} + addContinuationByte b n = + if isContinuationByte b then + Just (Byte.toNatural (Byte.and b 63) + Bits.shiftLeft n 6) + else Nothing + +parseNatural :: Parser.Parser Byte.Byte Natural.Natural +parseNatural = Parser.orelse parseAscii parseMultibyte + +parseUnicode :: Parser.Parser Byte.Byte Unicode.Unicode +parseUnicode = + Parser.mapPartial parseNatural + (\n -> + if Unicode.invariant n then Just (Unicode.Unicode n) else Nothing) + +parse :: Parser.Parser Byte.Byte (Either Byte.Byte Unicode.Unicode) +parse = + Parser.orelse (Parser.mapParser parseUnicode Right) + (Parser.mapParser Parser.anyToken Left) + +decode :: [Byte.Byte] -> [Either Byte.Byte Unicode.Unicode] +decode b = fst (Stream.toList (Parser.parse parse (Stream.fromList b))) + +encodeAscii :: Natural.Natural -> [Byte.Byte] +encodeAscii n = Byte.fromNatural n : [] + +encodeUnicode :: Unicode.Unicode -> [Byte.Byte] +encodeUnicode = + \c -> + let n = Unicode.unUnicode c in + if n < 128 then encodeAscii n + else if n < 2048 then encode2 n + else if n < 65536 then encode3 n + else encode4 n + where + {-encode2 :: Natural.Natural -> [Byte.Byte]-} + encode2 n = + let n1 = Bits.shiftRight n 6 in + let b0 = Byte.or 192 (Byte.fromNatural n1) in + let b1 = Byte.or 128 (Byte.fromNatural (Bits.bound n 6)) in + b0 : b1 : [] + + {-encode3 :: Natural.Natural -> [Byte.Byte]-} + encode3 n = + let n1 = Bits.shiftRight n 6 in + let n2 = Bits.shiftRight n1 6 in + let b0 = Byte.or 224 (Byte.fromNatural n2) in + let b1 = Byte.or 128 (Byte.fromNatural (Bits.bound n1 6)) in + let b2 = Byte.or 128 (Byte.fromNatural (Bits.bound n 6)) in + b0 : b1 : b2 : [] + + {-encode4 :: Natural.Natural -> [Byte.Byte]-} + encode4 n = + let n1 = Bits.shiftRight n 6 in + let n2 = Bits.shiftRight n1 6 in + let n3 = Bits.shiftRight n2 6 in + let b0 = Byte.or 240 (Byte.fromNatural n3) in + let b1 = Byte.or 128 (Byte.fromNatural (Bits.bound n2 6)) in + let b2 = Byte.or 128 (Byte.fromNatural (Bits.bound n1 6)) in + let b3 = Byte.or 128 (Byte.fromNatural (Bits.bound n 6)) in + b0 : b1 : b2 : b3 : [] + +encode :: [Unicode.Unicode] -> [Byte.Byte] +encode c = concat (map encodeUnicode c) + +reencodeUnicode :: Either Byte.Byte Unicode.Unicode -> [Byte.Byte] +reencodeUnicode x = + case x of + Left b -> b : [] + Right c -> encodeUnicode c + +reencode :: [Either Byte.Byte Unicode.Unicode] -> [Byte.Byte] +reencode c = concat (map reencodeUnicode c) diff --git a/testsrc/Main.hs b/testsrc/Main.hs new file mode 100644 --- /dev/null +++ b/testsrc/Main.hs @@ -0,0 +1,43 @@ +{- | +module: Main +description: Unicode characters - testing +license: MIT + +maintainer: Joe Leslie-Hurd +stability: provisional +portability: portable +-} +module Main + ( main ) +where + +import qualified OpenTheory.List as List +import qualified OpenTheory.Primitive.Byte as Byte +import qualified OpenTheory.Unicode as Unicode +import qualified OpenTheory.Unicode.UTF8 as UTF8 +import OpenTheory.Primitive.Test + +proposition0 :: [Byte.Byte] -> Bool +proposition0 b = UTF8.reencode (UTF8.decode b) == b + +proposition1 :: [Byte.Byte] -> Bool +proposition1 b = List.naturalLength (UTF8.decode b) <= List.naturalLength b + +proposition2 :: [Unicode.Unicode] -> Bool +proposition2 c = List.naturalLength c <= List.naturalLength (UTF8.encode c) + +proposition3 :: [Either Byte.Byte Unicode.Unicode] -> Bool +proposition3 c = + List.naturalLength c <= List.naturalLength (UTF8.reencode c) + +proposition4 :: [Unicode.Unicode] -> Bool +proposition4 c = UTF8.decode (UTF8.encode c) == map Right c + +main :: IO () +main = + do check "Proposition 0:\n !b. UTF8.reencode (UTF8.decode b) = b\n " proposition0 + check "Proposition 1:\n !b. length (UTF8.decode b) <= length b\n " proposition1 + check "Proposition 2:\n !c. length c <= length (UTF8.encode c)\n " proposition2 + check "Proposition 3:\n !c. length c <= length (UTF8.reencode c)\n " proposition3 + check "Proposition 4:\n !c. UTF8.decode (UTF8.encode c) = map right c\n " proposition4 + return ()