Compare commits

..

No commits in common. "main" and "0.3" have entirely different histories.
main ... 0.3

22 changed files with 476 additions and 315 deletions

2
.gitignore vendored
View File

@ -1,6 +1,4 @@
.stack-work/
dist-newstyle
.vscode/
*.swp
result
bench.html

View File

@ -3,24 +3,19 @@
## Building the executable
```
$ nix build
$ $(nix-build utoy.nix)/bin/utoy
```
## Building the Docker image
```
$ docker load < $(nix build .#docker --print-out-paths)
$ docker load < $(nix-build nix/docker-image.nix)
```
## Development Shell
Includes Stack, GHC, `haskell-language-server`, `gen-hie` etc.
Includes Stack, `haskell-language-server`, `gen-hie` etc.
```
$ nix develop
$ nix-shell
```
## TODO
- [x] Benchmark, profile and optimize search
- [ ] Trim down the docker image

View File

@ -3,7 +3,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
@ -16,7 +15,8 @@ module Main (main) where
import Data.Char (chr)
import Data.FileEmbed (embedFile)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import Data.Word (Word8)
import Network.HTTP.Media ((//), (/:))
@ -24,7 +24,6 @@ import Network.Wai (Application)
import Servant
( Accept (..)
, Handler
, Header
, MimeRender (..)
, Server
, ServerError (..)
@ -48,10 +47,11 @@ import qualified Data.Text.Encoding as Encoding
import qualified Network.Wai.Handler.Warp as Warp
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import qualified Unicode.Char.General.Blocks as UnicodeBlocks
import qualified Unicode.Char.General.Names as UnicodeNames
import qualified UToy.Decode as Decode
import qualified UToy.Table as Table
import qualified UToy.Names as Names
import qualified UToy.Parsers as Parsers
main :: IO ()
@ -61,22 +61,17 @@ app :: Application
app = serve (Proxy :: Proxy API) server
type API =
Header "Host" Text :> Get '[PlainText, HTML] RootModel
:<|> "utf8" :> Capture "bytes" Text :> Get '[PlainText, HTML] Utf8Model
"bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
:<|> "text" :> Capture "text" Text :> Get '[PlainText, HTML] TextModel
:<|> "search" :> Capture "search" Text :> Get '[PlainText, HTML] SearchModel
:<|> "text" :> Capture "text" Text :> Get '[HTML] TextModel
server :: Server API
server =
rootR :<|> utf8R :<|> codepointsR :<|> textR :<|> searchR
bytesR :<|> codepointsR :<|> textR
where
rootR host' = do
pure $ RootModel $ fromMaybe "" host'
utf8R bytesP = do
bytesR bytesP = do
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
pure $ mkUtf8Model bytes
pure $ BytesModel $ Decode.decodeUtf8 bytes
codepointsR codepointsP = do
codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
@ -85,52 +80,13 @@ server =
textR textP = do
pure $ TextModel textP
searchR searchP = do
pure $ mkSearchModel searchP
-- /
newtype RootModel = RootModel
{ host :: Text
}
examples :: [Text]
examples =
[ "/text/✅🤔"
, "/codepoints/x2705+x1F914"
, "/utf8/e2.9c.85.f0.9f.a4.94"
, "/search/asterisk"
]
instance MimeRender PlainText RootModel where
mimeRender _ model = renderText $ Text.unlines $
[ "⚞ utoy ⚟"
, ""
, "This is utoy, a URL-based Unicode playground. Examples:"
, ""
] ++ map (urlBase <>) examples
where
-- We assume HTTPS here. Doesn't work for development on localhost.
urlBase = "https://" <> model.host
instance MimeRender HTML RootModel where
mimeRender _ model = renderHtml $ documentWithBody $ do
H.h1 $ H.toHtml ("⚞ utoy ⚟" :: Text)
H.p $ H.toHtml ("This is utoy, a URL-based Unicode playground. Examples:" :: Text)
H.ul $ for_ examples $ \example -> do
let url = "https://" <> model.host <> example
H.li $ H.a ! A.href (H.toValue url) $ H.toHtml example
-- /bytes/<bytes>
newtype Utf8Model = Utf8Model
newtype BytesModel = BytesModel
{ codepoints :: [([Word8], Either String Char)]
}
mkUtf8Model :: [Word8] -> Utf8Model
mkUtf8Model = Utf8Model . Decode.decodeUtf8
instance MimeRender PlainText Utf8Model where
instance MimeRender PlainText BytesModel where
mimeRender _ model = renderText $
Table.render " " $ concat
[ [ [ Table.cl $ Text.pack $ unwords $ map showByteHex bytes
@ -143,15 +99,15 @@ instance MimeRender PlainText Utf8Model where
Right c ->
[ Text.pack [c]
, Text.pack $ printf "U+%04X" c
, Text.intercalate ", " $ Names.allNames c
, fromMaybe "" $ Names.blockName c
, Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
, Text.pack $ fromMaybe "" $ blockName c
]
)
]
| (bytes, eiC) <- model.codepoints
]
instance MimeRender HTML Utf8Model where
instance MimeRender HTML BytesModel where
mimeRender _ model = renderHtml $ documentWithBody $ do
H.table $ for_ model.codepoints $ \(bytes, eiC) -> do
H.tr $ do
@ -162,8 +118,8 @@ instance MimeRender HTML Utf8Model where
Right c -> do
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.code $ H.toHtml $ Text.intercalate ", " $ Names.allNames c
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
-- /codepoints/<codepoints>
@ -172,19 +128,12 @@ newtype CodepointsModel = CodepointsModel
}
mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
mkCodepointsModel =
CodepointsModel
-- Limit number of returned codepoints. Otherwise it's
-- too easy to provoke massive response bodies with requests like
-- /codepoints/0-99999999
. take 100_000
. map go
. concatMap (uncurry enumFromTo)
mkCodepointsModel = CodepointsModel . map go . concatMap (uncurry enumFromTo)
where
go codepoint = (codepoint, toChar codepoint)
toChar codepoint
| codepoint > 0x10_FFFF = Left "Would be too big (maximum: U+10FFFF)"
| codepoint > 0x10FFFF = Left "Would be too big (maximum: U+10FFFF)"
| isSurrogate codepoint = Left "Is a surrogate"
| otherwise = Right $ chr $ fromIntegral codepoint
@ -200,8 +149,8 @@ instance MimeRender PlainText CodepointsModel where
Right c ->
[ Text.pack [c]
, Text.pack $ printf "U+%04X" c
, Text.intercalate ", " $ Names.allNames c
, fromMaybe "" $ Names.blockName c
, Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
, Text.pack $ fromMaybe "" $ blockName c
]
)
| (codepoint, eiC) <- model.codepoints
@ -218,8 +167,8 @@ instance MimeRender HTML CodepointsModel where
Right c -> do
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.code $ H.toHtml $ Text.intercalate ", " $ Names.allNames c
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
-- /text/<text>
@ -228,49 +177,15 @@ newtype TextModel = TextModel
}
instance MimeRender HTML TextModel where
mimeRender _ model = charTableHtml $ Text.unpack model.text
instance MimeRender PlainText TextModel where
mimeRender _ model = charTableText $ Text.unpack model.text
-- /search/<search>
newtype SearchModel = SearchModel
{ results :: [Char]
}
mkSearchModel :: Text -> SearchModel
mkSearchModel search = SearchModel $ take 100_000 $ Names.searchCaseInsensitive search
instance MimeRender HTML SearchModel where
mimeRender _ model = charTableHtml model.results
instance MimeRender PlainText SearchModel where
mimeRender _ model = charTableText model.results
-- Utilities
charTableHtml :: [Char] -> BL.ByteString
charTableHtml chars =
renderHtml $ documentWithBody $ do
H.table $ for_ chars $ \c -> do
mimeRender _ model = renderHtml $ documentWithBody $ do
H.table $ for_ (Text.unpack model.text) $ \c -> do
H.tr $ do
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.code $ H.toHtml $ Text.intercalate ", " $ Names.allNames c
H.td $ H.code $ H.toHtml $ fromMaybe "" $ Names.blockName c
H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
charTableText :: [Char] -> BL.ByteString
charTableText chars =
renderText $ Table.render " "
[ map Table.cl
[ Text.pack [c]
, Text.pack $ printf "U+%04X" c
, Text.intercalate ", " $ Names.allNames c
, fromMaybe "" $ Names.blockName c
]
| c <- chars
]
-- Utilities
renderText :: Text -> BL.ByteString
renderText = BL.fromStrict . Encoding.encodeUtf8
@ -281,6 +196,9 @@ showByteHex = printf " %02X"
showByteBin :: Word8 -> String
showByteBin = printf "%08b"
blockName :: Char -> Maybe String
blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
orThrow :: Either a b -> (a -> ServerError) -> Handler b
orThrow (Left err) f = throwError $ f err
orThrow (Right val) _ = pure val
@ -295,7 +213,7 @@ documentWithBody body =
H.meta ! A.charset "utf-8"
H.title "utoy"
H.style $ H.toHtml $ Encoding.decodeUtf8 $(embedFile "static/utoy.css")
H.body $ H.main body
H.body body
-- HTML routes

View File

@ -1,69 +0,0 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Criterion.Main (bench, bgroup, defaultMain, whnf)
import Data.Char (ord)
import Data.Maybe (maybeToList)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Unicode.Char.General.Names as UnicodeNames
main = defaultMain
[ bench "naiveSearchCI" $ whnf naiveSearchCI "latin"
, bench "naiveSearchCS" $ whnf naiveSearchCS "LATIN"
, bench "memoSearchCI" $ whnf memoSearchCI "latin"
, bench "memoSearchCS" $ whnf memoSearchCS "LATIN"
]
naiveSearchCI :: Text -> [Char]
naiveSearchCI search =
filter go [minBound..maxBound]
where
go c = any matches $ allNames c
matches t = Text.toLower search `Text.isInfixOf` Text.toLower (Text.pack t)
naiveSearchCS :: Text -> [Char]
naiveSearchCS search =
filter go [minBound..maxBound]
where
go c = any matches $ allNames c
matches t = search `Text.isInfixOf` Text.pack t
memoSearchCS :: Text -> [Char]
memoSearchCS search =
filter go [minBound..maxBound]
where
go c = any matches $ allNamesText c
matches t = search `Text.isInfixOf` t
memoSearchCI :: Text -> [Char]
memoSearchCI search =
filter go [minBound..maxBound]
where
go c = any matches $ allNamesTextLower c
matches t = Text.toLower search `Text.isInfixOf` t
-- | Retrieve name and aliases (suffixed with @*@) of a 'Char'.
allNames :: Char -> [String]
allNames c =
maybeToList (UnicodeNames.name c)
++ map (++ "*") (UnicodeNames.nameAliases c)
allNamesText :: Char -> [Text]
allNamesText c = Vector.unsafeIndex textNames $ ord c
textNames :: Vector.Vector [Text]
textNames = Vector.fromList $ map go [minBound..maxBound]
where
go c = map Text.pack $ allNames c
allNamesTextLower :: Char -> [Text]
allNamesTextLower c = Vector.unsafeIndex textNamesLower $ ord c
textNamesLower :: Vector.Vector [Text]
textNamesLower = Vector.fromList $ map go [minBound..maxBound]
where
go c = map (Text.toLower . Text.pack) $ allNames c

27
flake.lock generated
View File

@ -1,27 +0,0 @@
{
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1740243248,
"narHash": "sha256-GJ/fV5AE+4i38/eXmAgBZs4lKYXfScpxPYviUV8ujlk=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "a6c4bfe37c51686c042b4bdb4e650a9414e96680",
"type": "github"
},
"original": {
"owner": "nixos",
"ref": "release-24.11",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

View File

@ -1,45 +0,0 @@
{
description = "Unicode toy";
inputs.nixpkgs.url = "github:nixos/nixpkgs/release-24.11";
outputs = { self, nixpkgs }:
let
pkgs = nixpkgs.legacyPackages.x86_64-linux;
utoy = pkgs.haskellPackages.developPackage {
root = ./.;
overrides = self: super: {
unicode-data = super.unicode-data_0_6_0;
unicode-data-names = pkgs.haskell.lib.markUnbroken super.unicode-data-names;
};
};
in {
packages.x86_64-linux = rec {
docker =
pkgs.dockerTools.buildImage {
name = "git.pbrinkmeier.de/paul/utoy";
tag = utoy.version;
config.Cmd = [ "${pkgs.haskell.lib.justStaticExecutables utoy}/bin/utoy" ];
};
default = utoy;
};
devShells.x86_64-linux.default =
(pkgs.haskellPackages.developPackage {
root = ./.;
overrides = self: super: {
unicode-data = super.unicode-data_0_6_0;
unicode-data-names = pkgs.haskell.lib.markUnbroken super.unicode-data-names;
};
modifier = drv:
pkgs.haskell.lib.addBuildTools drv [
pkgs.cabal-install
pkgs.haskellPackages.implicit-hie
pkgs.haskell-language-server
];
cabal2nixOptions = "--benchmark";
}).env;
};
}

View File

@ -1,10 +1,10 @@
cradle:
cabal:
- path: "src"
component: "lib:utoy"
stack:
- path: "./src"
component: "utoy:lib"
- path: "app/Main.hs"
- path: "./app/Main.hs"
component: "utoy:exe:utoy"
- path: "bench/Main.hs"
component: "utoy:bench:utoy-bench"
- path: "./test"
component: "utoy:test:utoy-test"

9
nix/docker-image.nix Normal file
View File

@ -0,0 +1,9 @@
let
pkgs = import ./pkgs.nix {};
utoy = import ../utoy.nix;
in
pkgs.dockerTools.buildImage {
name = "git.pbrinkmeier.de/paul/utoy";
tag = utoy.version;
config.Cmd = [ "${utoy}/bin/utoy" ];
}

13
nix/haskell-deps.nix Normal file
View File

@ -0,0 +1,13 @@
haskellPackages: with haskellPackages; [
attoparsec
blaze-html
bytestring
file-embed
http-media
servant-server
text
unicode-data
unicode-data-names
wai
warp
]

25
nix/pkgs.nix Normal file
View File

@ -0,0 +1,25 @@
{ overlays ? [] }:
let
sources = import ./sources.nix;
settings = import ./settings.nix;
overlay = final: prev: {
haskell = prev.haskell // {
packages = prev.haskell.packages // {
"${settings.ghc}" = prev.haskell.packages."${settings.ghc}".override {
overrides = haskellOverlay prev;
};
};
};
};
haskellOverlay = pkgs: final: prev: {
attoparsec-iso8601 = prev.attoparsec-iso8601_1_1_0_0;
http-api-data = prev.http-api-data_0_5;
servant = pkgs.haskell.lib.doJailbreak prev.servant;
servant-server = pkgs.haskell.lib.doJailbreak prev.servant-server;
unicode-data = prev.unicode-data_0_4_0_1;
unicode-data-names = pkgs.haskell.lib.markUnbroken prev.unicode-data-names;
};
in
import sources.nixpkgs { overlays = overlays ++ [overlay]; }

5
nix/settings.nix Normal file
View File

@ -0,0 +1,5 @@
{
# GHC version to use with Nix.
# Should match the one in stack.yaml.
ghc = "ghc943";
}

26
nix/sources.json Normal file
View File

@ -0,0 +1,26 @@
{
"niv": {
"branch": "master",
"description": "Easy dependency management for Nix projects",
"homepage": "https://github.com/nmattia/niv",
"owner": "nmattia",
"repo": "niv",
"rev": "689d0e5539eddd0b0f566aee7bb18629eee7df74",
"sha256": "1rld3lk42l6b01f2gcrhq8qm9vry1awmfl29zmpiqda9dy89vbx0",
"type": "tarball",
"url": "https://github.com/nmattia/niv/archive/689d0e5539eddd0b0f566aee7bb18629eee7df74.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
"branch": "nixpkgs-unstable",
"description": "Nix Packages collection",
"homepage": "",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "9952d6bc395f5841262b006fbace8dd7e143b634",
"sha256": "0kvpf63dda6nzbqd2kyr99qh1av89mva26xykp3zb4diyicp7yji",
"type": "tarball",
"url": "https://github.com/NixOS/nixpkgs/archive/9952d6bc395f5841262b006fbace8dd7e143b634.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}

194
nix/sources.nix Normal file
View File

@ -0,0 +1,194 @@
# This file has been generated by Niv.
let
#
# The fetchers. fetch_<type> fetches specs of type <type>.
#
fetch_file = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; name = name'; }
else
pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
fetch_tarball = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
else
pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
fetch_git = name: spec:
let
ref =
if spec ? ref then spec.ref else
if spec ? branch then "refs/heads/${spec.branch}" else
if spec ? tag then "refs/tags/${spec.tag}" else
abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!";
submodules = if spec ? submodules then spec.submodules else false;
submoduleArg =
let
nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
emptyArgWithWarning =
if submodules == true
then
builtins.trace
(
"The niv input \"${name}\" uses submodules "
+ "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
+ "does not support them"
)
{}
else {};
in
if nixSupportsSubmodules
then { inherit submodules; }
else emptyArgWithWarning;
in
builtins.fetchGit
({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
fetch_local = spec: spec.path;
fetch_builtin-tarball = name: throw
''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=tarball -a builtin=true'';
fetch_builtin-url = name: throw
''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=file -a builtin=true'';
#
# Various helpers
#
# https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
sanitizeName = name:
(
concatMapStrings (s: if builtins.isList s then "-" else s)
(
builtins.split "[^[:alnum:]+._?=-]+"
((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
)
);
# The set of packages used when specs are fetched using non-builtins.
mkPkgs = sources: system:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
if builtins.hasAttr "nixpkgs" sources
then sourcesNixpkgs
else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
import <nixpkgs> {}
else
abort
''
Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
add a package called "nixpkgs" to your sources.json.
'';
# The actual fetching function.
fetch = pkgs: name: spec:
if ! builtins.hasAttr "type" spec then
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
else if spec.type == "file" then fetch_file pkgs name spec
else if spec.type == "tarball" then fetch_tarball pkgs name spec
else if spec.type == "git" then fetch_git name spec
else if spec.type == "local" then fetch_local spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
else if spec.type == "builtin-url" then fetch_builtin-url name
else
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
# If the environment variable NIV_OVERRIDE_${name} is set, then use
# the path directly as opposed to the fetched source.
replace = name: drv:
let
saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name;
ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
in
if ersatz == "" then drv else
# this turns the string into an actual Nix path (for both absolute and
# relative paths)
if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
# Ports of functions for older nix versions
# a Nix version of mapAttrs if the built-in doesn't exist
mapAttrs = builtins.mapAttrs or (
f: set: with builtins;
listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
concatMapStrings = f: list: concatStrings (map f list);
concatStrings = builtins.concatStringsSep "";
# https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
optionalAttrs = cond: as: if cond then as else {};
# fetchTarball version that is compatible between all the versions of Nix
builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; }))
else
fetchurl attrs;
# Create the final "sources" from the config
mkSources = config:
mapAttrs (
name: spec:
if builtins.hasAttr "outPath" spec
then abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = replace name (fetch config.pkgs name spec); }
) config.sources;
# The "config" used by the fetchers
mkConfig =
{ sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
, sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile)
, system ? builtins.currentSystem
, pkgs ? mkPkgs sources system
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); }

69
package.yaml Normal file
View File

@ -0,0 +1,69 @@
# Adapted from new-template.hsfiles
name: utoy
version: 0.3
git: "https://git.pbrinkmeier.de/paul/utoy"
license: MIT
author: "Paul Brinkmeier"
maintainer: "hallo@pbrinkmeier.de"
copyright: "2023 Paul Brinkmeier"
extra-source-files:
- README.md
- static/utoy.css
dependencies:
- base >= 4.7 && < 5
- attoparsec
- text
ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wmissing-export-lists
- -Wmissing-home-modules
- -Wpartial-fields
- -Wredundant-constraints
library:
source-dirs: src
executables:
utoy:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- utoy
- blaze-html
- bytestring
- file-embed
- http-media
- servant-server
- text
- unicode-data
- unicode-data-names
- wai
- warp
# Fix "Multiple files use the same module name", see
# https://stackoverflow.com/questions/67519851/multiple-files-use-the-same-module-name
when:
- condition: false
other-modules: Paths_utoy
tests:
utoy-test:
main: Spec.hs
source-dirs: test
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- utoy

21
shell.nix Normal file
View File

@ -0,0 +1,21 @@
{ pkgs ? import ./nix/pkgs.nix {} }:
let
haskellDeps = import ./nix/haskell-deps.nix;
settings = import ./nix/settings.nix;
haskellPackages = pkgs.haskell.packages."${settings.ghc}";
tools = with pkgs; [
# nix tools
niv
nix-tree
# haskell tools
stack
(haskellPackages.ghcWithPackages haskellDeps)
haskellPackages.haskell-language-server
haskellPackages.implicit-hie
];
in
pkgs.mkShellNoCC {
nativeBuildInputs = tools;
}

View File

@ -1,31 +0,0 @@
module UToy.Names (allNames, blockName, searchCaseInsensitive) where
import Data.Char (ord)
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Data.Vector (Vector)
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import qualified Unicode.Char.General.Blocks as UnicodeBlocks
import qualified Unicode.Char.General.Names as UnicodeNames
-- | Retrieve name and aliases (suffixed with @*@) of a 'Char'.
allNames :: Char -> [Text]
allNames c = map Text.pack $
maybeToList (UnicodeNames.name c)
++ map (++ "*") (UnicodeNames.nameAliases c)
blockName :: Char -> Maybe Text
blockName c = Text.pack . UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
searchCaseInsensitive :: Text -> [Char]
searchCaseInsensitive search = filter go [minBound..maxBound]
where
go c = any matches $ Vector.unsafeIndex lowerNames (ord c - ord minBound)
matches t = Text.toLower search `Text.isInfixOf` t
lowerNames :: Vector [Text]
lowerNames = Vector.fromList $ map go [minBound..maxBound]
where
go = map Text.toLower . allNames

View File

@ -17,7 +17,7 @@ cr :: Text -> Cell
cr = C AlignRight
render :: Text -> [[Cell]] -> Text
render delim cells = Text.unlines $ map showRow cells
render delim cells = Text.intercalate "\n" $ map showRow cells
where
showRow = Text.intercalate delim . map showCell . zipLongest columnWidths

10
stack-shell.nix Normal file
View File

@ -0,0 +1,10 @@
{}:
let
pkgs = import ./nix/pkgs.nix {};
haskellDeps = import ./nix/haskell-deps.nix;
settings = import ./nix/settings.nix;
in
pkgs.haskell.lib.buildStackProject {
name = "utoy";
ghc = pkgs.haskell.packages."${settings.ghc}".ghcWithPackages haskellDeps;
}

9
stack.yaml Normal file
View File

@ -0,0 +1,9 @@
resolver: ghc-9.4.3
# GHC is managed through Nix
install-ghc: false
packages:
- .
nix:
enable: true
shell-file: stack-shell.nix
path: ["nixpkgs=./nix/pkgs.nix"]

2
test/Spec.hs Normal file
View File

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"

View File

@ -1,7 +1,11 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
name: utoy
version: 0.6.2
version: 0.3
author: Paul Brinkmeier
maintainer: hallo@pbrinkmeier.de
copyright: 2023 Paul Brinkmeier
@ -20,7 +24,6 @@ library
exposed-modules:
UToy.Decode
UToy.Parsers
UToy.Names
UToy.Table
other-modules:
Paths_utoy
@ -31,9 +34,6 @@ library
attoparsec
, base >=4.7 && <5
, text
, unicode-data
, unicode-data-names
, vector
default-language: Haskell2010
executable utoy
@ -50,20 +50,24 @@ executable utoy
, http-media
, servant-server
, text
, unicode-data
, unicode-data-names
, utoy
, wai
, warp
default-language: Haskell2010
benchmark utoy-bench
test-suite utoy-test
type: exitcode-stdio-1.0
main-is: Main.hs
main-is: Spec.hs
other-modules:
Paths_utoy
hs-source-dirs:
bench
test
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
build-depends:
base >=4.7 && <5
, criterion
attoparsec
, base >=4.7 && <5
, text
, unicode-data-names
, vector
, utoy
default-language: Haskell2010

35
utoy.nix Normal file
View File

@ -0,0 +1,35 @@
let
pkgs = import ./nix/pkgs.nix {};
settings = import ./nix/settings.nix;
haskellDeps = import ./nix/haskell-deps.nix;
haskellPackages = pkgs.haskell.packages."${settings.ghc}";
utoy =
{ mkDerivation }:
mkDerivation {
version = "0.3";
pname = "utoy";
license = pkgs.lib.licenses.mit;
src =
let
buildFiles = [
./LICENSE
./utoy.cabal
./Setup.hs
./app
./src
./static
./test
];
in
pkgs.lib.sources.cleanSourceWith {
src = ./.;
filter = path: _type: pkgs.lib.any (prefix: pkgs.lib.hasPrefix (toString prefix) path) buildFiles;
};
libraryHaskellDepends = haskellDeps haskellPackages;
};
in
pkgs.haskell.lib.justStaticExecutables
(haskellPackages.callPackage utoy {})