ilyakooo0/urbit
1
0
Fork 0
mirror of https://github.com/ilyakooo0/urbit.git synced 2024-12-15 01:52:42 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #3561 from urbit/m/king-ascii

Browse Source 
kh: abolish unicode syntax in favor of ascii
This commit is contained in:
fang 2020-09-25 11:12:23 +02:00 committed by GitHub
commit dc7f9bd08c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
11 changed files with 151 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
pkg/hs/proto/lib/Untyped/Parser.hs
View File

@ -79,61 +79,61 @@ data Mode = Wide | Tall
type Parser = StateT Mode (Parsec Void Text)
withLocalState ∷ Monad m => s → StateT s m a → StateT s m a
withLocalState :: Monad m => s -> StateT s m a -> StateT s m a
withLocalState val x = do { old <- get; put val; x <* put old }
inWideMode ∷ Parser a → Parser a
inWideMode :: Parser a -> Parser a
inWideMode = withLocalState Wide
ace, pal, par ∷ Parser ()
ace, pal, par :: Parser ()
ace = void (char ' ')
pal = void (char '(')
par = void (char ')')
-- Simple Lexers ---------------------------------------------------------------
gap ∷ Parser ()
gap :: Parser ()
gap = choice [ char ' ' >> void (some spaceChar)
, newline >> void (many spaceChar)
]
whitespace ∷ Parser ()
whitespace :: Parser ()
whitespace = ace <|> void gap
-- Literals --------------------------------------------------------------------
alpha ∷ Parser Char
alpha :: Parser Char
alpha = oneOf (['a'..'z'] ++ ['A'..'Z'])
sym ∷ Parser Sym
sym :: Parser Sym
sym = bucSym <|> pack <$> some alpha
where bucSym = char '$' *> pure ""
atom ∷ Parser Nat
atom :: Parser Nat
atom = do
init ← some digitChar
rest ← many (char '.' *> some digitChar)
init <- some digitChar
rest <- many (char '.' *> some digitChar)
guard True -- TODO Validate '.'s
pure (Prelude.read $ concat $ init:rest)
nat ∷ Parser Nat
nat :: Parser Nat
nat = Prelude.read <$> some digitChar
tape ∷ Parser Text
tape :: Parser Text
tape = do
between (char '"') (char '"') $
pack <$> many (label "tape char" (anySingleBut '"'))
cord ∷ Parser Text
cord :: Parser Text
cord = do
between (char '\'') (char '\'') $
pack <$> many (label "cord char" (anySingleBut '\''))
tag ∷ Parser Text
tag :: Parser Text
tag = try (char '%' >> sym)
literal ∷ Parser CST
literal :: Parser CST
literal = choice
[ Yes <$ string "%.y"
, No <$ string "%.n"
@ -156,48 +156,48 @@ literal = choice
- accept the `tall` form or:
- swich to `Wide` mode and then accept the wide form.
-}
parseRune ∷ Parser a → Parser a → Parser a
parseRune :: Parser a -> Parser a -> Parser a
parseRune tall wide = get >>= \case
Wide → wide
Tall → tall <|> inWideMode wide
Wide -> wide
Tall -> tall <|> inWideMode wide
rune0 ∷ a → Parser a
rune0 :: a -> Parser a
rune0 = pure
rune1 ∷ (a→b) → Parser a → Parser b
rune1 :: (a->b) -> Parser a -> Parser b
rune1 node x = parseRune tall wide
where tall = do gap; p←x; pure (node p)
wide = do pal; p←x; par; pure (node p)
where tall = do gap; p<-x; pure (node p)
wide = do pal; p<-x; par; pure (node p)
rune2 ∷ (a→b→c) → Parser a → Parser b → Parser c
rune2 :: (a->b->c) -> Parser a -> Parser b -> Parser c
rune2 node x y = parseRune tall wide
where tall = do gap; p←x; gap; q←y; pure (node p q)
wide = do pal; p←x; ace; q←y; par; pure (node p q)
where tall = do gap; p<-x; gap; q<-y; pure (node p q)
wide = do pal; p<-x; ace; q<-y; par; pure (node p q)
rune3 ∷ (a→b→c→d) → Parser a → Parser b → Parser c → Parser d
rune3 :: (a->b->c->d) -> Parser a -> Parser b -> Parser c -> Parser d
rune3 node x y z = parseRune tall wide
where tall = do gap; p←x; gap; q←y; gap; r←z; pure (node p q r)
wide = do pal; p←x; ace; q←y; ace; r←z; par; pure (node p q r)
where tall = do gap; p<-x; gap; q<-y; gap; r<-z; pure (node p q r)
wide = do pal; p<-x; ace; q<-y; ace; r<-z; par; pure (node p q r)
rune4 ∷ (a→b→c→d→e) → Parser a → Parser b → Parser c → Parser d → Parser e
rune4 :: (a->b->c->d->e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e
rune4 node x y z g = parseRune tall wide
where tall = do gap; p←x; gap; q←y; gap; r←z; gap; s←g; pure (node p q r s)
wide = do pal; p←x; ace; q←y; ace; r←z; ace; s←g; pure (node p q r s)
where tall = do gap; p<-x; gap; q<-y; gap; r<-z; gap; s<-g; pure (node p q r s)
wide = do pal; p<-x; ace; q<-y; ace; r<-z; ace; s<-g; pure (node p q r s)
runeN ∷ ([a]→b) → Parser a → Parser b
runeN :: ([a]->b) -> Parser a -> Parser b
runeN node elem = node <$> parseRune tall wide
where tall = gap >> elems
where elems = term <|> elemAnd
elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs)
elemAnd = do x <- elem; gap; xs <- elems; pure (x:xs)
term = string "==" *> pure []
wide = pal *> option [] elems <* par
where elems = (:) <$> elem <*> many (ace >> elem)
runeNE ∷ (NonEmpty a → b) → Parser a → Parser b
runeNE :: (NonEmpty a -> b) -> Parser a -> Parser b
runeNE node elem = node <$> parseRune tall wide
where tall = do
let elems = term <|> elemAnd
elemAnd = do x ← elem; gap; xs ← elems; pure (x:xs)
elemAnd = do x <- elem; gap; xs <- elems; pure (x:xs)
term = string "==" *> pure []
fst <- gap *> elem
rst <- gap *> elems
@ -206,36 +206,36 @@ runeNE node elem = node <$> parseRune tall wide
-- Irregular Syntax ------------------------------------------------------------
inc ∷ Parser CST -- +(3)
inc :: Parser CST -- +(3)
inc = do
string "+("
h ← cst
h <- cst
char ')'
pure h
equals ∷ Parser (CST, CST) -- =(3 4)
equals :: Parser (CST, CST) -- =(3 4)
equals = do
string "=("
x ← cst
x <- cst
ace
y ← cst
y <- cst
char ')'
pure (x, y)
tuple ∷ ∀a. Parser a → Parser [a]
tuple :: forall a. Parser a -> Parser [a]
tuple p = char '[' >> elems
where
xs ∷ Parser [a]
xs = do { x ← p; (x:) <$> tail }
xs :: Parser [a]
xs = do { x <- p; (x:) <$> tail }
tail ∷ Parser [a]
tail :: Parser [a]
tail = (pure [] <* char ']')
<|> (ace >> elems)
elems ∷ Parser [a]
elems :: Parser [a]
elems = (pure [] <* char ']') <|> xs
appIrr ∷ Parser CST
appIrr :: Parser CST
appIrr = do
char '('
x <- cst
@ -244,7 +244,7 @@ appIrr = do
char ')'
pure (AppIrr x y)
irregular ∷ Parser CST
irregular :: Parser CST
irregular =
inWideMode $
choice [ Tupl <$> tuple cst
@ -255,14 +255,14 @@ irregular =
-- Runes -----------------------------------------------------------------------
pat ∷ Parser Pat
pat :: Parser Pat
pat = choice [ PatTag <$> tag
, char '*' $> PatTar
]
cases ∷ Parser [(Pat, CST)]
cases :: Parser [(Pat, CST)]
cases = do
mode ← get
mode <- get
guard (mode == Tall)
end <|> lop
where
@ -270,9 +270,9 @@ cases = do
end = string "==" $> []
lop = do { p <- pat; gap; b <- cst; gap; ((p,b):) <$> goo }
wutHep ∷ Parser CST
wutHep :: Parser CST
wutHep = do
mode ← get
mode <- get
guard (mode == Tall)
gap
ex <- cst
@ -280,15 +280,15 @@ wutHep = do
cs <- cases
pure (WutHep ex cs)
barCen ∷ Parser CST
barCen :: Parser CST
barCen = do
mode ← get
mode <- get
guard (mode == Tall)
gap
cs <- cases
pure (BarCen cs)
rune ∷ Parser CST
rune :: Parser CST
rune = runeSwitch [ ("|=", rune2 BarTis sym cst)
, ("|-", rune4 BarHep sym sym cst cst)
, (":-", rune2 ColHep cst cst)
@ -313,13 +313,13 @@ rune = runeSwitch [ ("|=", rune2 BarTis sym cst)
, ("~/", rune2 SigFas cst cst)
]
runeSwitch ∷ [(Text, Parser a)] → Parser a
runeSwitch = choice . fmap (\(s, p) → string s *> p)
runeSwitch :: [(Text, Parser a)] -> Parser a
runeSwitch = choice . fmap (\(s, p) -> string s *> p)
-- CST Parser ------------------------------------------------------------------
cst ∷ Parser CST
cst :: Parser CST
cst = irregular <|> rune <|> literal
@ -327,19 +327,19 @@ cst = irregular <|> rune <|> literal
hoonFile = do
option () whitespace
h ← cst
h <- cst
option () whitespace
eof
pure h
parse ∷ Text → Either Text CST
parse :: Text -> Either Text CST
parse txt =
runParser (evalStateT hoonFile Tall) "stdin" txt & \case
Left e → Left (pack $ errorBundlePretty e)
Right x → pure x
Left e -> Left (pack $ errorBundlePretty e)
Right x -> pure x
parseHoonTest ∷ Text → IO ()
parseHoonTest :: Text -> IO ()
parseHoonTest = parseTest (evalStateT hoonFile Tall)
main ∷ IO ()
main :: IO ()
main = (head <$> getArgs) >>= parseHoonTest

4
pkg/hs/urbit-eventlog-lmdb/lib/Urbit/EventLog/LMDB.hs
View File

@ -300,7 +300,7 @@ streamEvents log first = do
for_ batch yield
streamEvents log (first + word (length batch))
streamEffectsRows :: ∀e. HasLogFunc e
streamEffectsRows :: forall e. HasLogFunc e
=> EventLog -> Word64
-> ConduitT () (Word64, ByteString) (RIO e) ()
streamEffectsRows log = go
@ -352,7 +352,7 @@ readBatch log first = start
{-|
Read 1000 rows from the database, starting from key `first`.
-}
readRowsBatch :: ∀e. HasLogFunc e
readRowsBatch :: forall e. HasLogFunc e
=> Env -> Dbi -> Word64 -> RIO e (V.Vector (Word64, ByteString))
readRowsBatch env dbi first = readRows
where

2
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -835,7 +835,7 @@ runMultipleShips ships = do
--------------------------------------------------------------------------------
connTerm :: ∀e. HasLogFunc e => FilePath -> RIO e ()
connTerm :: forall e. HasLogFunc e => FilePath -> RIO e ()
connTerm = Term.runTerminalClient

4
pkg/hs/urbit-king/lib/Urbit/Vere/LMDB.hs
View File

@ -169,7 +169,7 @@ streamEvents log first = do
for_ batch yield
streamEvents log (first + word (length batch))
streamEffectsRows :: ∀e. HasLogFunc e
streamEffectsRows :: forall e. HasLogFunc e
=> EventLog -> EventId
-> ConduitT () (Word64, ByteString) (RIO e) ()
streamEffectsRows log = go
@ -221,7 +221,7 @@ readBatch log first = start
{-
Read 1000 rows from the database, starting from key `first`.
-}
readRowsBatch :: ∀e. HasLogFunc e
readRowsBatch :: forall e. HasLogFunc e
=> Env -> Dbi -> Word64 -> RIO e (V.Vector (Word64, ByteString))
readRowsBatch env dbi first = readRows
where

6
pkg/hs/urbit-king/lib/Urbit/Vere/NounServ.hs
View File

@ -44,7 +44,7 @@ data Server i o a = Server
--------------------------------------------------------------------------------
withRIOThread ∷ RIO e a → RIO e (Async a)
withRIOThread :: RIO e a -> RIO e (Async a)
withRIOThread act = do
env <- ask
io $ async $ runRIO env $ act
@ -87,7 +87,7 @@ wsConn pre inp out wsc = do
--------------------------------------------------------------------------------
wsClient :: ∀i o e. (ToNoun o, FromNoun i, Show o, Show i, HasLogFunc e)
wsClient :: forall i o e. (ToNoun o, FromNoun i, Show o, Show i, HasLogFunc e)
=> Text -> W.Port -> RIO e (Client i o)
wsClient pax por = do
env <- ask
@ -118,7 +118,7 @@ wsServApp cb pen = do
atomically $ cb (mkConn inp out)
wsConn "NOUNSERV (wsServ) " inp out wsc
wsServer :: ∀i o e. (ToNoun o, FromNoun i, Show i, Show o, HasLogFunc e)
wsServer :: forall i o e. (ToNoun o, FromNoun i, Show i, Show o, HasLogFunc e)
=> RIO e (Server i o W.Port)
wsServer = do
con <- io $ newTBMChanIO 5

8
pkg/hs/urbit-king/lib/Urbit/Vere/Term.hs
View File

@ -104,7 +104,7 @@ connClient c = Client
, take = Serv.cRecv c
}
connectToRemote :: ∀e. HasLogFunc e
connectToRemote :: forall e. HasLogFunc e
=> Port
-> Client
-> RAcquire e (Async (), Async ())
@ -130,7 +130,7 @@ data HackConfigDir = HCD { _hcdPax :: FilePath }
makeLenses ''HackConfigDir
instance HasPierPath HackConfigDir where pierPathL = hcdPax
runTerminalClient :: ∀e. HasLogFunc e => FilePath -> RIO e ()
runTerminalClient :: forall e. HasLogFunc e => FilePath -> RIO e ()
runTerminalClient pier = runRAcquire $ do
mPort <- runRIO (HCD pier) readPortsFile
port <- maybe (error "Can't connect") pure mPort
@ -173,7 +173,7 @@ _spin_idle_us = 500000
{-|
Initializes the generalized input/output parts of the terminal.
-}
localClient :: ∀e. HasLogFunc e
localClient :: forall e. HasLogFunc e
=> STM ()
-> RAcquire e (TermSize, Client)
localClient doneSignal = fst <$> mkRAcquire start stop
@ -415,7 +415,7 @@ localClient doneSignal = fst <$> mkRAcquire start stop
-- Moves the cursor left without any mutation of the LineState. Used only
-- in cursor spinning.
_termSpinnerMoveLeft :: Int → RIO e ()
_termSpinnerMoveLeft :: Int -> RIO e ()
_termSpinnerMoveLeft = T.cursorLeft
-- Displays and sets the current line

10
pkg/hs/urbit-king/lib/Urbit/Vere/Term/Render.hs
View File

@ -16,17 +16,17 @@ import qualified System.Console.ANSI as ANSI
-- Types -----------------------------------------------------------------------
clearScreen ∷ MonadIO m ⇒ m ()
clearScreen :: MonadIO m => m ()
clearScreen = liftIO $ ANSI.clearScreen
clearLine ∷ MonadIO m ⇒ m ()
clearLine :: MonadIO m => m ()
clearLine = liftIO $ ANSI.clearLine
soundBell ∷ MonadIO m ⇒ m ()
soundBell :: MonadIO m => m ()
soundBell = liftIO $ putStr "\a"
cursorLeft ∷ MonadIO m ⇒ Int → m ()
cursorLeft :: MonadIO m => Int -> m ()
cursorLeft = liftIO . ANSI.cursorBackward
cursorRight ∷ MonadIO m ⇒ Int → m ()
cursorRight :: MonadIO m => Int -> m ()
cursorRight = liftIO . ANSI.cursorForward

2
pkg/hs/urbit-king/test/HoonMapSetTests.hs
View File

@ -38,7 +38,7 @@ type TreeTests = [TreeTest]
-- Utils -----------------------------------------------------------------------
roundTrip :: ∀a. Eq a => (a -> a) -> a -> Bool
roundTrip :: forall a. Eq a => (a -> a) -> a -> Bool
roundTrip f x = f x == x

2
pkg/hs/urbit-noun-core/lib/Urbit/Noun/Jam.hs
View File

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -O2 #-}
{-|
Fast implementation of Jam (Noun → Atom).
Fast implementation of Jam (Noun -> Atom).
This is based on the implementation of `flat`.
-}

2
pkg/hs/urbit-noun/lib/Urbit/Noun.hs
View File

@ -49,7 +49,7 @@ data LoadErr
instance Exception LoadErr
loadFile :: ∀a. FromNoun a => FilePath -> IO (Either LoadErr a)
loadFile :: forall a. FromNoun a => FilePath -> IO (Either LoadErr a)
loadFile pax = try $ do
byt <- try (readFile pax) >>= either (throwIO . FileErr) pure
non <- cueBS byt & either (throwIO . CueErr) pure

134
pkg/hs/urbit-noun/lib/Urbit/Noun/Tree.hs
View File

@ -27,14 +27,14 @@ import GHC.Natural (Natural)
-- Types -----------------------------------------------------------------------
data NounVal a = NounVal
{ non ∷ Noun
, val ∷ !a
{ non :: Noun
, val :: !a
}
data HoonTreeNode a = NTN
{ n ∷ NounVal a
, l ∷ HoonTree a
, r ∷ HoonTree a
{ n :: NounVal a
, l :: HoonTree a
, r :: HoonTree a
}
deriving (Eq, Ord, Show)
@ -43,10 +43,10 @@ data HoonTree a = E | Node (HoonTreeNode a)
pattern N n l r = Node (NTN n l r)
newtype HoonSet a = HoonSet { unHoonSet ∷ HoonTree a }
newtype HoonSet a = HoonSet { unHoonSet :: HoonTree a }
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
newtype HoonMap k v = HoonMap { unHoonMap ∷ HoonTree (k, v) }
newtype HoonMap k v = HoonMap { unHoonMap :: HoonTree (k, v) }
deriving newtype (Eq, Ord, Show, FromNoun, ToNoun)
@ -61,17 +61,17 @@ instance Ord (NounVal a) where
instance ToNoun (NounVal a) where
toNoun = non
instance Show a ⇒ Show (NounVal a) where
instance Show a => Show (NounVal a) where
show = show . val
instance FromNoun a ⇒ FromNoun (NounVal a) where
instance FromNoun a => FromNoun (NounVal a) where
parseNoun x = NounVal x <$> parseNoun x
instance ToNoun a ⇒ ToNoun (HoonTree a) where
instance ToNoun a => ToNoun (HoonTree a) where
toNoun E = A 0
toNoun (Node n) = toNoun n
instance FromNoun a ⇒ FromNoun (HoonTree a) where
instance FromNoun a => FromNoun (HoonTree a) where
parseNoun (A 0) = pure E
parseNoun n = Node <$> parseNoun n
@ -82,60 +82,60 @@ deriveNoun ''HoonTreeNode
type Nat = Natural
slowMug ∷ Noun → Nat
slowMug :: Noun -> Nat
slowMug = trim 0xcafe_babe . \case
A a → a
C h t → mix (slowMug h) $ mix 0x7fff_ffff (slowMug t)
A a -> a
C h t -> mix (slowMug h) $ mix 0x7fff_ffff (slowMug t)
where
trim ∷ Nat → Nat → Nat
trim :: Nat -> Nat -> Nat
trim syd key =
if 0/=ham then ham else trim (succ syd) key
where
haz = muk syd (met 3 key) key
ham = mix (rsh 0 31 haz) (end 0 31 haz)
mix ∷ Nat → Nat → Nat
mix :: Nat -> Nat -> Nat
mix = xor
-- Murmur3
muk ∷ Nat → Nat → Nat → Nat
muk :: Nat -> Nat -> Nat -> Nat
muk seed len =
fromIntegral . murmur3 (word32 seed) . resize . atomBytes
where
resize ∷ ByteString → ByteString
resize :: ByteString -> ByteString
resize buf =
case compare (length buf) (int len) of
EQ → buf
LT → error "bad-muk"
GT → error "bad-muk"
-- LT → buf <> replicate (len - length buf) 0
-- GT → take len buf
EQ -> buf
LT -> error "bad-muk"
GT -> error "bad-muk"
-- LT -> buf <> replicate (len - length buf) 0
-- GT -> take len buf
int ∷ Integral i ⇒ i → Int
int :: Integral i => i -> Int
int = fromIntegral
word32 ∷ Integral i ⇒ i → Word32
word32 :: Integral i => i -> Word32
word32 = fromIntegral
bex ∷ Nat → Nat
bex :: Nat -> Nat
bex = (2^)
end ∷ Nat → Nat → Nat → Nat
end :: Nat -> Nat -> Nat -> Nat
end blockSize blocks n =
n `mod` (bex (bex blockSize * blocks))
rsh ∷ Nat → Nat → Nat → Nat
rsh :: Nat -> Nat -> Nat -> Nat
rsh blockSize blocks n =
shiftR n $ fromIntegral $ (bex blockSize * blocks)
met ∷ Nat → Nat → Nat
met :: Nat -> Nat -> Nat
met bloq = go 0
where
go c 0 = c
go c n = go (succ c) (rsh bloq 1 n)
-- XX TODO
mug ∷ Noun → Nat
mug :: Noun -> Nat
mug = slowMug
@ -144,7 +144,7 @@ mug = slowMug
{-
Orders in ascending double mug hash order, collisions fall back to dor.
-}
mor ∷ Noun → Noun → Bool
mor :: Noun -> Noun -> Bool
mor a b = if c == d then dor a b else c < d
where
c = mug $ A $ mug a
@ -153,7 +153,7 @@ mor a b = if c == d then dor a b else c < d
{-
Orders in ascending tree depth.
-}
dor ∷ Noun → Noun → Bool
dor :: Noun -> Noun -> Bool
dor a b | a == b = True
dor (A a) (C _ _) = True
dor (C x y) (A b) = False
@ -166,80 +166,80 @@ dor (C x y) (C p q) = dor x p
Collisions fall back to dor.
-}
gor ∷ Noun → Noun → Bool
gor :: Noun -> Noun -> Bool
gor a b = if c==d then dor a b else c<d
where (c, d) = (mug a, mug b)
morVal, gorVal ∷ NounVal a → NounVal a → Bool
morVal, gorVal :: NounVal a -> NounVal a -> Bool
morVal = on mor non
gorVal = on gor non
--------------------------------------------------------------------------------
nounVal ∷ ToNoun a ⇒ Iso' a (NounVal a)
nounVal :: ToNoun a => Iso' a (NounVal a)
nounVal = iso to val
where
to x = NounVal (toNoun x) x
treeToList ∷ ∀a. HoonTree a → [a]
treeToList :: forall a. HoonTree a -> [a]
treeToList = go []
where
go ∷ [a] → HoonTree a → [a]
go :: [a] -> HoonTree a -> [a]
go acc = \case
E → acc
Node (NTN v l r) → go (go (val v : acc) l) r
E -> acc
Node (NTN v l r) -> go (go (val v : acc) l) r
setFromHoonSet ∷ Ord a ⇒ HoonSet a → Set a
setFromHoonSet :: Ord a => HoonSet a -> Set a
setFromHoonSet = setFromList . treeToList . unHoonSet
mapFromHoonMap ∷ Ord k ⇒ HoonMap k v → Map k v
mapFromHoonMap :: Ord k => HoonMap k v -> Map k v
mapFromHoonMap = mapFromList . treeToList . unHoonMap
setToHoonSet ∷ ∀a. (Ord a, ToNoun a) ⇒ Set a → HoonSet a
setToHoonSet :: forall a. (Ord a, ToNoun a) => Set a -> HoonSet a
setToHoonSet = HoonSet . foldr put E . fmap (view nounVal) . setToList
where
put x = \case
E → N x E E
Node a | x == n a → Node a
Node a | gorVal x (n a) → lef x a
Node a → rit x a
E -> N x E E
Node a | x == n a -> Node a
Node a | gorVal x (n a) -> lef x a
Node a -> rit x a
rit x a = put x (r a) & \case
E → error "bad-put-set"
Node c | morVal (n a) (n c) → N (n a) (l a) (Node c)
Node c → N (n c) (N (n a) (l a) (l c)) (r c)
E -> error "bad-put-set"
Node c | morVal (n a) (n c) -> N (n a) (l a) (Node c)
Node c -> N (n c) (N (n a) (l a) (l c)) (r c)
lef x a = put x (l a) & \case
E → error "bad-put-set"
Node c | morVal (n a) (n c) → N (n a) (Node c) (r a)
Node c → N (n c) (l c) (N (n a) (r c) (r a))
E -> error "bad-put-set"
Node c | morVal (n a) (n c) -> N (n a) (Node c) (r a)
Node c -> N (n c) (l c) (N (n a) (r c) (r a))
p ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → NounVal a
p :: (ToNoun a, ToNoun b) => NounVal (a,b) -> NounVal a
p = view (from nounVal . to fst . nounVal)
pq ∷ (ToNoun a, ToNoun b) ⇒ NounVal (a,b) → (NounVal a, NounVal b)
pq :: (ToNoun a, ToNoun b) => NounVal (a,b) -> (NounVal a, NounVal b)
pq = boof . view (from nounVal)
where
boof (x, y) = (x ^. nounVal, y ^. nounVal)
mapToHoonMap ∷ ∀k v. (ToNoun k, ToNoun v, Ord k, Ord v) ⇒ Map k v → HoonMap k v
mapToHoonMap :: forall k v. (ToNoun k, ToNoun v, Ord k, Ord v) => Map k v -> HoonMap k v
mapToHoonMap = HoonMap . foldr put E . fmap (view nounVal) . mapToList
where
put ∷ NounVal (k, v) → HoonTree (k, v) → HoonTree (k, v)
put :: NounVal (k, v) -> HoonTree (k, v) -> HoonTree (k, v)
put kv@(pq -> (b, c)) = \case
E → N kv E E
Node a | kv == n a → Node a
Node a | b == p (n a) → N kv (l a) (r a)
Node a | gorVal b (p $ n a) → lef kv a
Node a → rit kv a
E -> N kv E E
Node a | kv == n a -> Node a
Node a | b == p (n a) -> N kv (l a) (r a)
Node a | gorVal b (p $ n a) -> lef kv a
Node a -> rit kv a
lef kv@(pq -> (b, c)) a = put kv (l a) & \case
E → error "bad-put-map"
Node d | morVal (p $ n a) (p $ n d) → N (n a) (Node d) (r a)
Node d → N (n d) (l d) (N (n a) (r d) (r a))
E -> error "bad-put-map"
Node d | morVal (p $ n a) (p $ n d) -> N (n a) (Node d) (r a)
Node d -> N (n d) (l d) (N (n a) (r d) (r a))
rit kv@(pq -> (b, c)) a = put kv (r a) & \case
E → error "bad-put-map"
Node d | morVal (p $ n a) (p $ n d) → N (n a) (l a) (Node d)
Node d → N (n d) (N (n a) (l a) (l d)) (r d)
E -> error "bad-put-map"
Node d | morVal (p $ n a) (p $ n d) -> N (n a) (l a) (Node d)
Node d -> N (n d) (N (n a) (l a) (l d)) (r d)