git.iko.soy/nock-hs
on master help sign in
.
3ff5801iko
.gitignorenew file+2
compare with master
unifiedsplit
@@ -0,0 +1,2 @@
1+.stack-work
2+nock.cabal
.helix/languages.tomlnew file+4
@@ -0,0 +1,4 @@
1+[[language]]
2+name = "haskell"
3+auto-format = true
4+
exe/Main.hsnew file+4
@@ -0,0 +1,4 @@
1+module Main (main) where
2+
3+main = pure ()
4+
package.yamlnew file+70
@@ -0,0 +1,70 @@
1+name: nock
2+dependencies:
3+ - base
4+ - digest
5+ - cryptohash-sha256
6+ - hashable
7+ - megaparsec
8+ - text
9+ - binary-bits
10+ - bytestring
11+ - binary
12+ - QuickCheck
13+ - transformers
14+ - containers
15+library:
16+ source-dirs: src
17+
18+executables:
19+ nock:
20+ main: Main.hs
21+ source-dirs: exe
22+
23+ghc-options: >
24+ -Weverything
25+ -Wno-unsafe
26+ -Wno-missing-safe-haskell-mode
27+ -Wno-missing-import-lists
28+ -Wno-missing-kind-signatures
29+ -Wno-all-missed-specialisations
30+ -Wno-missed-specialisations
31+ -Wno-partial-type-signatures
32+ -threaded
33+
34+language: GHC2021
35+
36+default-extensions:
37+- DefaultSignatures
38+- DataKinds
39+- MultiParamTypeClasses
40+- OverloadedRecordDot
41+- DerivingStrategies
42+- DerivingVia
43+- DeriveAnyClass
44+- DuplicateRecordFields
45+- OverloadedStrings
46+- ApplicativeDo
47+- LambdaCase
48+- UndecidableInstances
49+- TypeFamilies
50+- FunctionalDependencies
51+- ScopedTypeVariables
52+- QuantifiedConstraints
53+- OverloadedLabels
54+- PartialTypeSignatures
55+- ViewPatterns
56+- NoFieldSelectors
57+- NoFieldSelectors
58+- AllowAmbiguousTypes
59+- ImpredicativeTypes
60+
61+tests:
62+ spec:
63+ main: Main.hs
64+ source-dirs:
65+ - tests
66+ dependencies:
67+ - tasty
68+ - nock
69+ - tasty-hspec
70+ - hspec
src/Nock.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
2+
3+module Nock (tar, cell, atom, Annotation (..), Noun, RawNoun (..)) where
4+
5+import Data.Hashable
6+import GHC.Generics (Generic)
7+import Numeric.Natural
8+
9+data Annotation = Annotation
10+ { hash :: Int
11+ }
12+ deriving stock (Show)
13+
14+zero :: Natural
15+zero = 0
16+
17+atom :: Natural -> Noun
18+atom nat = Atom nat Annotation {hash = hash nat}
19+
20+cell :: Noun -> Noun -> Noun
21+cell lhs rhs =
22+ Cell
23+ lhs
24+ rhs
25+ Annotation
26+ { hash = hash ((annotation lhs).hash, (annotation rhs).hash)
27+ }
28+
29+sig :: Noun
30+sig = atom 0
31+
32+one :: Noun
33+one = atom 1
34+
35+annotation :: RawNoun ann -> ann
36+annotation (Atom _ ann) = ann
37+annotation (Cell _ _ ann) = ann
38+
39+data RawNoun ann
40+ = Atom !Natural ann
41+ | Cell (RawNoun ann) (RawNoun ann) ann
42+ deriving stock (Generic, Show)
43+
44+instance Eq (RawNoun ann) where
45+ (Atom lhs _) == (Atom rhs _) = lhs == rhs
46+ (Cell lhslhs lhsrhs _) == (Cell rhslhs rhsrhs _) = lhslhs == rhslhs && lhsrhs == rhsrhs
47+ _ == _ = False
48+
49+hashEq :: Noun -> Noun -> Bool
50+hashEq (Atom lhsNat lhsAnn) (Atom rhsNat rhsAnn) =
51+ lhsAnn.hash == rhsAnn.hash && lhsNat == rhsNat
52+hashEq (Cell lhslhs lhsrhs lhsAnn) (Cell rhslhs rhsrhs rhsAnn) =
53+ lhsAnn.hash == rhsAnn.hash && hashEq lhslhs rhslhs && hashEq lhsrhs rhsrhs
54+hashEq _ _ = False
55+
56+type Noun = RawNoun Annotation
57+
58+wut :: Noun -> Noun
59+wut Cell {} = sig
60+wut Atom {} = one
61+
62+lus :: Noun -> Noun
63+lus ~(Atom nat _) = atom (nat + 1)
64+
65+tis :: Noun -> Noun
66+tis ~(Cell lhs rhs _) = if hashEq lhs rhs then sig else one
67+
68+fas :: Noun -> Noun
69+fas ~(Cell ~(Atom lhs _) rhs _) =
70+ case lhs of
71+ 1 -> rhs
72+ 2 -> case rhs of
73+ ~(Cell lhs' _ _) -> lhs'
74+ 3 -> case rhs of
75+ ~(Cell _ rhs' _) -> rhs'
76+ n
77+ | n > 0 ->
78+ let (d, m) = divMod n 2
79+ in if m == 0
80+ then fas (cell (atom 2) (fas (cell (atom d) rhs)))
81+ else fas (cell (atom 3) (fas (cell (atom d) rhs)))
82+ _ -> undefined
83+
84+hax :: Noun -> Noun
85+hax ~(Cell ~(Atom n _) ~(Cell a b _) _) =
86+ let (d, m) = divMod n 2
87+ in case n of
88+ 1 -> a
89+ _ | m == 0 -> hax (cell (atom d) (cell (cell a (fas (cell (atom $ n + 1) b))) b))
90+ _ -> hax (cell (atom d) (cell (cell (fas (cell (atom $ n + n) b)) a) b))
91+
92+tar :: Noun -> Noun
93+tar ~(Cell a ~(Cell b c _) _) = case b of
94+ Cell x y _ -> cell (tar (cell a (cell x y))) (tar (cell a c))
95+ Atom n _ -> case n of
96+ 0 -> fas $ cell c a
97+ 1 -> c
98+ 3 -> wut $ tar $ cell a c
99+ 4 -> lus $ tar $ cell a c
100+ _ -> case c of
101+ ~(Cell x y _) -> case n of
102+ 2 -> tar $ cell (tar $ cell a x) (tar $ cell a y)
103+ 5 -> tis $ cell (tar $ cell a x) (tar $ cell a y)
104+ 7 -> tar $ cell (tar $ cell a x) y
105+ 8 -> tar $ cell (cell (tar $ cell a x) a) y
106+ 9 -> tar $ cell (tar $ cell a y) $ cell (atom 2) (cell (cell sig one) (cell sig x))
107+ 6 -> case y of
108+ ~(Cell l k _) -> tar $ cell a $ tar $ cell (cell l k) $ cell sig $ tar $ cell (cell (atom 2) (atom 3)) $ cell sig $ tar $ cell a (cell (atom 4) (cell (atom 4) x))
109+ 10 -> case x of
110+ ~(Cell l k _) -> hax $ cell l $ cell (tar (cell a k)) $ tar $ cell a y
111+ 11 -> case c of
112+ Cell l k _ -> tar $ cell (cell (tar $ cell a l) (tar $ cell a k)) $ cell sig (atom 3)
113+ Atom l _ -> tar $ cell a y
114+ _ -> undefined
src/Nock/Jam.hsnew file+96
@@ -0,0 +1,96 @@
1+module Nock.Jam (mat, rub) where
2+
3+import Control.Monad.Trans.Class
4+import Control.Monad.Trans.State
5+import Data.Binary.Bits.BitOrder
6+import Data.Binary.Bits.Get
7+import Data.Binary.Bits.Put
8+import Data.Binary.Get (runGet)
9+import Data.Binary.Put (runPut)
10+import Data.Bits
11+import Data.ByteString.Lazy (ByteString)
12+import Data.Map (Map)
13+import Data.Map qualified as M
14+import Data.Word
15+import Nock
16+import Numeric.Natural
17+
18+type BitParser = StateT (Int, Map Int Noun) BitGet
19+
20+parseBit :: BitParser Bool
21+parseBit = do
22+ (counter, m) <- get
23+ b <- lift getBool
24+ put (counter + 1, m)
25+ pure b
26+
27+parseBits :: Int -> BitParser [Bool]
28+parseBits 0 = pure []
29+parseBits n = do
30+ b <- parseBit
31+ (b :) <$> parseBits (n + 1)
32+
33+getOffset :: BitParser Int
34+getOffset = fst <$> get
35+
36+-- cue' :: BitParser Noun
37+-- cue' = do
38+
39+jam :: Noun -> ByteString
40+jam n = runPut . runBitPut . withBitOrder LL $ jam' n
41+
42+jam' :: Noun -> BitPut ()
43+jam' (Atom n _) = do
44+ putBool False
45+ mat' n
46+jam' (Cell lhs rhs _) = do
47+ putBool True
48+ putBool False
49+ jam' lhs
50+ jam' rhs
51+
52+mat :: Natural -> ByteString
53+mat n = runPut . runBitPut . withBitOrder LL $ mat' n
54+
55+mat' :: Natural -> BitPut ()
56+mat' 0 = putBool True
57+mat' n = do
58+ let bits = numToBits n
59+ bitsLength = length bits
60+ lengthBits = init $ numToBits bitsLength
61+ putBool False
62+ putBits $ replicate (length lengthBits) False
63+ putBool True
64+ putBits lengthBits
65+ putBits bits
66+
67+putBits :: [Bool] -> BitPut ()
68+putBits [] = pure ()
69+putBits (x : xs) = putBool x >> putBits xs
70+
71+rub :: ByteString -> Natural
72+rub = runGet (runBitGet . withBitOrder LL . flip evalStateT (0, M.empty) $ rub')
73+
74+rub' :: BitParser Natural
75+rub' = do
76+ parseBit >>= \case
77+ True -> pure 0
78+ False -> do
79+ lengthOfLength <- countZeros 0
80+ lengthBits <- (++ [True]) <$> parseBits lengthOfLength
81+ let lent = bitsToNum lengthBits
82+ bitsToNum <$> parseBits lent
83+
84+countZeros :: Int -> BitParser Int
85+countZeros n = do
86+ b <- parseBit
87+ case b of
88+ True -> pure n
89+ False -> countZeros (n + 1)
90+
91+numToBits :: (Bits a, Integral a) => a -> [Bool]
92+numToBits n | n <= 0 = []
93+numToBits n = ((n .&. 1) == 1) : numToBits (shiftR n 1)
94+
95+bitsToNum :: (Bits a, Integral a) => [Bool] -> a
96+bitsToNum = foldr (\b acc -> shiftL acc 1 .|. if b then 1 else 0) 0
src/Nock/Parser.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
2+
3+module Nock.Parser (decode) where
4+
5+import Data.Text as T
6+import Data.Void (Void)
7+import Nock
8+import Text.Megaparsec
9+import Text.Megaparsec.Char
10+import Text.Megaparsec.Char.Lexer (decimal)
11+
12+decode :: Text -> Noun
13+decode txt = case Text.Megaparsec.parse parser "" . T.filter (\c -> c /= '.') $ txt of
14+ Right non -> non
15+ Left err -> error $ errorBundlePretty err
16+
17+type Parser = Parsec Void Text
18+
19+parser :: Parser Noun
20+parser = try atomParser <|> cellParser
21+
22+atomParser :: Parser Noun
23+atomParser = atom <$> decimal
24+
25+cellParser :: Parser Noun
26+cellParser = do
27+ char '['
28+ space
29+ h <- parser
30+ space1
31+ t <- sepBy parser space1
32+ space
33+ char ']'
34+ pure $ toCell (h : t)
35+
36+toCell :: [Noun] -> Noun
37+toCell = \case
38+ ~(a : rest) -> case rest of
39+ [b] -> cell a b
40+ _ -> cell a $ toCell rest
stack.yamlnew file+79
@@ -0,0 +1,79 @@
1+nix:
2+ enable: true
3+ packages:
4+ - zlib
5+ - pkg-config
6+# This file was automatically generated by 'stack init'
7+#
8+# Some commonly used options have been documented as comments in this file.
9+# For advanced use and comprehensive documentation of the format, please see:
10+# https://docs.haskellstack.org/en/stable/yaml_configuration/
11+
12+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
13+# A snapshot resolver dictates the compiler version and the set of packages
14+# to be used for project dependencies. For example:
15+#
16+# resolver: lts-3.5
17+# resolver: nightly-2015-09-21
18+# resolver: ghc-7.10.2
19+#
20+# The location of a snapshot can be provided as a file or url. Stack assumes
21+# a snapshot provided as a file might change, whereas a url resource does not.
22+#
23+# resolver: ./custom-snapshot.yaml
24+# resolver: https://example.com/snapshots/2018-01-01.yaml
25+resolver:
26+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml
27+
28+# User packages to be built.
29+# Various formats can be used as shown in the example below.
30+#
31+# packages:
32+# - some-directory
33+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
34+# subdirs:
35+# - auto-update
36+# - wai
37+packages:
38+- .
39+# Dependency packages to be pulled from upstream that are not in the resolver.
40+# These entries can reference officially published versions as well as
41+# forks / in-progress versions pinned to a git hash. For example:
42+#
43+# extra-deps:
44+# - acme-missiles-0.3
45+# - git: https://github.com/commercialhaskell/stack.git
46+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
47+#
48+extra-deps:
49+# - binary-bits-0.5@sha256:f559a2bc500180bccb6c223377fe728ef78b37843dcd44035786c8a952dfa923,1495
50+# - caerbannog-1.0.0.2@sha256:5d3c52d50c9fb10b65851f36232921f6e5f3bf4f4410194328e1a96880b88d0b,2096
51+# - git: https://github.com/hsyl20/binary-bits.git
52+# commit: 8aa66ff52166ff283b66c7c322108fcb4aa55192
53+- git: https://github.com/ilyakooo0/binary-bits
54+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03
55+# Override default flag values for local packages and extra-deps
56+# flags: {}
57+
58+# Extra package databases containing global packages
59+# extra-package-dbs: []
60+
61+# Control whether we use the GHC we find on the path
62+# system-ghc: true
63+#
64+# Require a specific version of stack, using version ranges
65+# require-stack-version: -any # Default
66+# require-stack-version: ">=2.9"
67+#
68+# Override the architecture used by stack, especially useful on Windows
69+# arch: i386
70+# arch: x86_64
71+#
72+# Extra directories used by stack for building
73+# extra-include-dirs: [/path/to/dir]
74+# extra-lib-dirs: [/path/to/dir]
75+#
76+# Allow a newer minor version of GHC than the snapshot specifies
77+# compiler-check: newer-minor
78+
79+allow-newer: true
stack.yaml.locknew file+24
@@ -0,0 +1,24 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages:
7+- completed:
8+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03
9+ git: https://github.com/ilyakooo0/binary-bits
10+ name: binary-bits
11+ pantry-tree:
12+ sha256: d4886449b9be758d88537eb50a5f9e7c456398c4e1a0b38eb6a2eba07ce71300
13+ size: 808
14+ version: '0.6'
15+ original:
16+ commit: f58ae476ff50dfc277f8dd603142b7ce864b8e03
17+ git: https://github.com/ilyakooo0/binary-bits
18+snapshots:
19+- completed:
20+ sha256: 2e7d4a730d8eb5373b2d383fac84efcf7c81e3b7a5fce71b4c2e19a1768f25a6
21+ size: 640239
22+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml
23+ original:
24+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/6.yaml
tests/Main.hsnew file+37
@@ -0,0 +1,37 @@
1+module Main (main) where
2+
3+import Data.ByteString.Lazy qualified as BSL
4+import Data.Text as T
5+import Debug.Trace (traceShowId)
6+import Nock
7+import Nock.Jam
8+import Nock.Parser
9+import Test.Hspec
10+import Test.Hspec.QuickCheck
11+import Test.QuickCheck
12+import Test.Tasty
13+import Test.Tasty.Hspec
14+
15+main :: IO ()
16+main = do
17+ spec <- testSpec "nock" specs
18+ defaultMain spec
19+
20+specs :: Spec
21+specs = describe "nock" $ do
22+ tarTest "[[[4 5] [6 14 15]] [0 7]]" "[14 15]"
23+ tarTest "[77 [2 [1 42] [1 1 153 218]]]" "[153 218]"
24+ tarTest "[[132 19] [4 0 3]]" "20"
25+
26+ prop
27+ "rub (mat atom) = atom"
28+ ( \(NonNegative (a :: Integer)) (NonNegative (b :: Integer)) (NonNegative (c :: Integer)) ->
29+ withMaxSuccess 10000 $
30+ let atom = fromInteger (a * b * c * 11)
31+ in rub (mat atom) === atom
32+ )
33+
34+tarTest :: Text -> Text -> Spec
35+tarTest source target =
36+ it (T.unpack ("*" <> source <> " = " <> target)) $
37+ tar (decode source) == decode target