urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-21 18:01:32 +03:00
Code Issues Packages Projects Releases Wiki Activity
555b9e7dcf
shrub/pkg/king/lib/Noun/Conversions.hs
Benjamin Summers efc6103fc1 %veer events now use cords instead of tapes?
2019-08-21 17:07:05 -07:00

734 lines
21 KiB
Haskell
Raw Blame History

{-# OPTIONS_GHC -Wwarn #-}
module Noun.Conversions
( Nullable(..), Jammed(..), AtomCell(..)
, Word128, Word256, Word512
, Bytes(..), Octs(..), File(..)
, Cord(..), Knot(..), Term(..), Tape(..), Tour(..)
, BigTape(..), BigCord(..)
, Wall
, UD(..), UV(..)
, Mug(..), Path(..), EvilPath(..), Ship(..)
, Lenient(..)
) where
import ClassyPrelude hiding (hash)
import Control.Lens hiding (Index)
import Data.Void
import Data.Word
import Noun.Atom
import Noun.Convert
import Noun.Core
import Noun.TH
import Text.Regex.TDFA
import Text.Regex.TDFA.Text ()
import Data.LargeWord (LargeKey, Word128, Word256)
import GHC.Exts (chr#, isTrue#, leWord#, word2Int#)
import GHC.Natural (Natural)
import GHC.Types (Char(C#))
import GHC.Word (Word32(W32#))
import Noun.Cue (cue)
import Noun.Jam (jam)
import Prelude ((!!))
import RIO (decodeUtf8Lenient)
import System.IO.Unsafe (unsafePerformIO)
import Text.Show.Pretty (ppShow)
import qualified Data.Char as C
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
-- Noun ------------------------------------------------------------------------
instance ToNoun Noun where
toNoun = id
instance FromNoun Noun where
parseNoun = pure
--- Atom -----------------------------------------------------------------------
instance ToNoun Atom where
toNoun = Atom
instance FromNoun Atom where
parseNoun = named "Atom" . \case
Atom a -> pure a
Cell _ _ -> fail "Expecting an atom, but got a cell"
-- Void ------------------------------------------------------------------------
instance ToNoun Void where
toNoun = absurd
instance FromNoun Void where
parseNoun _ = named "Void" $ fail "Can't produce void"
-- Cord ------------------------------------------------------------------------
newtype Cord = Cord { unCord :: Text }
deriving newtype (Eq, Ord, Show, IsString, NFData)
instance ToNoun Cord where
toNoun = textToUtf8Atom . unCord
instance FromNoun Cord where
parseNoun = named "Cord" . fmap Cord . parseNounUtf8Atom
-- Decimal Cords ---------------------------------------------------------------
newtype UD = UD { unUD :: Word }
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num)
instance ToNoun UD where
toNoun = toNoun . Cord . tshow . unUD
instance FromNoun UD where
parseNoun n = named "UD" do
Cord t <- parseNoun n
readMay t & \case
Nothing -> fail ("invalid decimal atom: " <> unpack (filter (/= '.') t))
Just vl -> pure (UD vl)
--------------------------------------------------------------------------------
-- @uv
newtype UV = UV { unUV :: Atom }
deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral)
instance ToNoun UV where
toNoun = toNoun . Cord . pack . toUV . fromIntegral . unUV
instance FromNoun UV where
parseNoun n = do
Cord c <- parseNoun n
case fromUV $ unpack c of
Nothing -> fail ("Invalid @uv: " <> unpack c)
Just uv -> pure (UV uv)
fromUV :: String -> Maybe Atom
fromUV = \case
('0':'v':cs) -> go (0, 0) (reverse cs)
_ -> Nothing
where
go (i, acc) [] = pure acc
go (i, acc) ('.' : cs) = go (i, acc) cs
go (i, acc) (c : cs) = do
n <- uvCharNum c
go (i+1, acc+(32^i)*n) cs
toUV :: Atom -> String
toUV = go []
where
go acc 0 = "0v" <> uvAddDots acc
go acc n = go (char n : acc) (n `div` 32)
char n = base32Chars !! (fromIntegral (n `mod` 32))
base32Chars :: [Char]
base32Chars = (['0'..'9'] <> ['a'..'v'])
uvAddDots :: String -> String
uvAddDots = reverse . go . reverse
where
go s = if null tel then hed
else hed <> "." <> go tel
where
hed = take 5 s
tel = drop 5 s
uvCharNum :: Char -> Maybe Atom
uvCharNum = \case
'0' -> pure 0
'1' -> pure 1
'2' -> pure 2
'3' -> pure 3
'4' -> pure 4
'5' -> pure 5
'6' -> pure 6
'7' -> pure 7
'8' -> pure 8
'9' -> pure 9
'a' -> pure 10
'b' -> pure 11
'c' -> pure 12
'd' -> pure 13
'e' -> pure 14
'f' -> pure 15
'g' -> pure 16
'h' -> pure 17
'i' -> pure 18
'j' -> pure 19
'k' -> pure 20
'l' -> pure 21
'm' -> pure 22
'n' -> pure 23
'o' -> pure 24
'p' -> pure 25
'q' -> pure 26
'r' -> pure 27
's' -> pure 28
't' -> pure 29
'u' -> pure 30
'v' -> pure 31
_ -> Nothing
-- Char ------------------------------------------------------------------------
instance ToNoun Char where
toNoun = Atom . fromIntegral . C.ord
{-
Hack: pulled this logic from Data.Char impl.
-}
instance FromNoun Char where
parseNoun n = named "Char" $ do
W32# w :: Word32 <- parseNoun n
if isTrue# (w `leWord#` 0x10FFFF##)
then pure (C# (chr# (word2Int# w)))
else fail "Word is not a valid character."
-- Tour ------------------------------------------------------------------------
newtype Tour = Tour [Char]
deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
-- Double Jammed ---------------------------------------------------------------
newtype Jammed a = Jammed a
deriving (Eq, Ord, Show)
instance ToNoun a => ToNoun (Jammed a) where
toNoun (Jammed a) = Atom $ jam $ toNoun a
instance FromNoun a => FromNoun (Jammed a) where
parseNoun n = named "Jammed" $ do
a <- parseNoun n
cue a & \case
Left err -> fail (show err)
Right res -> do
Jammed <$> parseNoun res
-- Atom or Cell ----------------------------------------------------------------
type Word512 = LargeKey Word256 Word256
data AtomCell a c
= ACAtom a
| ACCell c
deriving (Eq, Ord, Show)
instance (ToNoun a, ToNoun c) => ToNoun (AtomCell a c) where
toNoun (ACAtom a) = toNoun a
toNoun (ACCell c) = toNoun c
instance (FromNoun a, FromNoun c) => FromNoun (AtomCell a c) where
parseNoun n = named "(,)" $ case n of
Atom _ -> ACAtom <$> parseNoun n
Cell _ _ -> ACCell <$> parseNoun n
-- Lenient ---------------------------------------------------------------------
data Lenient a
= FailParse Noun
| GoodParse a
deriving (Eq, Ord, Show)
instance FromNoun a => FromNoun (Lenient a) where
parseNoun n =
(GoodParse <$> parseNoun n) <|> fallback
where
fallback =
fromNounErr n & \case
Right x -> pure (GoodParse x)
Left err -> do
traceM ("LENIENT.FromNoun: " <> show err)
traceM (ppShow n)
pure (FailParse n)
instance ToNoun a => ToNoun (Lenient a) where
toNoun (FailParse n) = trace ("LENIENT.ToNoun: " <> show n)
n
toNoun (GoodParse x) = toNoun x
-- Todo -- Debugging Hack ------------------------------------------------------
newtype Todo a = Todo a
deriving newtype (Eq, Ord, ToNoun)
instance Show (Todo a) where
show (Todo _) = "TODO"
instance FromNoun a => FromNoun (Todo a) where
parseNoun n = do
fromNounErr n & \case
Right x -> pure (Todo x)
Left er -> do
traceM ("[TODO]: " <> show er <> "\n" <> ppShow n <> "\n")
fail (show er)
-- Nullable --------------------------------------------------------------------
{-|
`Nullable a <-> ?@(~ a)`
This is distinct from `unit`, since there is no tag on the non-atom
case, therefore `a` must always be cell type.
-}
data Nullable a = None | Some a
deriving (Eq, Ord, Show)
instance ToNoun a => ToNoun (Nullable a) where
toNoun = toNoun . \case None -> ACAtom ()
Some x -> ACCell x
instance FromNoun a => FromNoun (Nullable a) where
parseNoun n = named "Nullable" $ do
parseNoun n >>= \case
(ACAtom ()) -> pure None
(ACCell x) -> pure (Some x)
-- List ------------------------------------------------------------------------
instance ToNoun a => ToNoun [a] where
toNoun xs = nounFromList (toNoun <$> xs)
where
nounFromList :: [Noun] -> Noun
nounFromList [] = Atom 0
nounFromList (x:xs) = Cell x (nounFromList xs)
instance FromNoun a => FromNoun [a] where
parseNoun = named "[]" . \case
Atom 0 -> pure []
Atom _ -> fail "list terminated with non-null atom"
Cell l r -> (:) <$> parseNoun l <*> parseNoun r
-- Tape ------------------------------------------------------------------------
{-
A `tape` is a list of utf8 bytes.
-}
newtype Tape = Tape { unTape :: Text }
deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
instance ToNoun Tape where
toNoun = toNoun . (unpack :: ByteString -> [Word8]) . encodeUtf8 . unTape
instance FromNoun Tape where
parseNoun n = named "Tape" $ do
as :: [Word8] <- parseNoun n
T.decodeUtf8' (pack as) & \case
Left err -> fail (show err)
Right tx -> pure (Tape tx)
-- Wall -- Text Lines ----------------------------------------------------------
type Wall = [Tape]
-- Big Cord -- Don't Print -----------------------------------------------------
newtype BigCord = BigCord Cord
deriving newtype (Eq, Ord, ToNoun, FromNoun, IsString)
instance Show BigCord where
show (BigCord (Cord t)) = show (take 32 t <> "...")
-- Big Tape -- Don't Print -----------------------------------------------------
newtype BigTape = BigTape Tape
deriving newtype (Eq, Ord, ToNoun, FromNoun, IsString)
instance Show BigTape where
show (BigTape (Tape t)) = show (take 32 t <> "...")
-- Bytes -----------------------------------------------------------------------
newtype Bytes = MkBytes { unBytes :: ByteString }
deriving newtype (Eq, Ord, Show)
instance ToNoun Bytes where
toNoun = Atom . view (from atomBytes) . unBytes
instance FromNoun Bytes where
parseNoun = named "Bytes" . fmap (MkBytes . view atomBytes) . parseNoun
-- Octs ------------------------------------------------------------------------
newtype Octs = Octs { unOcts :: ByteString }
deriving newtype (Eq, Ord, Show, IsString)
instance ToNoun Octs where
toNoun (Octs bs) =
toNoun (int2Word (length bs), bs ^. from atomBytes)
where
int2Word :: Int -> Word
int2Word = fromIntegral
instance FromNoun Octs where
parseNoun x = named "Octs" $ do
(word2Int -> len, atom) <- parseNoun x
let bs = atom ^. atomBytes
pure $ Octs $ case compare (length bs) len of
EQ -> bs
LT -> bs <> replicate (len - length bs) 0
GT -> take len bs
where
word2Int :: Word -> Int
word2Int = fromIntegral
-- File Contents -- Don't Print ------------------------------------------------
newtype File = File { unFile :: Octs }
deriving newtype (Eq, Ord, IsString, ToNoun, FromNoun)
instance Show File where
show (File (Octs bs)) = show (take 32 bs <> "...")
-- Knot ------------------------------------------------------------------------
{-
Knot (@ta) is an array of Word8 encoding an ASCII string.
-}
newtype Knot = MkKnot { unKnot :: Text }
deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
instance ToNoun Knot where
toNoun = textToUtf8Atom . unKnot
instance FromNoun Knot where
parseNoun n = named "Knot" $ do
txt <- parseNounUtf8Atom n
if all C.isAscii txt
then pure (MkKnot txt)
else fail ("Non-ASCII chars in knot: " <> unpack txt)
-- Term ------------------------------------------------------------------------
{-
A Term (@tas) is a Knot satisfying the regular expression:
([a-z][a-z0-9]*(-[a-z0-9]+)*)?
-}
newtype Term = MkTerm { unTerm :: Text }
deriving newtype (Eq, Ord, Show, Semigroup, Monoid, IsString)
instance ToNoun Term where -- XX TODO
toNoun = textToUtf8Atom . unTerm
knotRegex :: Text
knotRegex = "([a-z][a-z0-9]*(-[a-z0-9]+)*)?"
instance FromNoun Term where -- XX TODO
parseNoun n = named "Term" $ do
MkKnot t <- parseNoun n
if t =~ knotRegex
then pure (MkTerm t)
else fail ("Term not valid symbol: " <> unpack t)
-- Ship ------------------------------------------------------------------------
newtype Ship = Ship Word128 -- @p
deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
-- Path ------------------------------------------------------------------------
newtype Path = Path { unPath :: [Knot] }
deriving newtype (Eq, Ord, Semigroup, Monoid)
instance Show Path where
show = show . intercalate "/" . ("":) . unPath
newtype EvilPath = EvilPath { unEvilPath :: [Atom] }
deriving newtype (Eq, Ord, Semigroup, Monoid)
instance Show EvilPath where
show = show . unEvilPath
-- Mug -------------------------------------------------------------------------
newtype Mug = Mug Word32
deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
-- Bool ------------------------------------------------------------------------
instance ToNoun Bool where
toNoun True = Atom 0
toNoun False = Atom 1
instance FromNoun Bool where
parseNoun = named "Bool" . parse
where
parse n =
parseNoun n >>= \case
(0::Atom) -> pure True
1 -> pure False
_ -> fail "Atom is not a valid loobean"
-- Integer ---------------------------------------------------------------------
instance ToNoun Integer where
toNoun = toNoun . (fromIntegral :: Integer -> Natural)
instance FromNoun Integer where
parseNoun = named "Integer" . fmap natInt . parseNoun
where
natInt :: Natural -> Integer
natInt = fromIntegral
-- Words -----------------------------------------------------------------------
atomToWord :: forall a. (Bounded a, Integral a) => Atom -> Parser a
atomToWord atom = do
if atom > fromIntegral (maxBound :: a)
then fail "Atom doesn't fit in fixed-size word"
else pure (fromIntegral atom)
wordToNoun :: Integral a => a -> Noun
wordToNoun = Atom . fromIntegral
nounToWord :: forall a. (Bounded a, Integral a) => Noun -> Parser a
nounToWord = parseNoun >=> atomToWord
instance ToNoun Word where toNoun = wordToNoun
instance ToNoun Word8 where toNoun = wordToNoun
instance ToNoun Word16 where toNoun = wordToNoun
instance ToNoun Word32 where toNoun = wordToNoun
instance ToNoun Word64 where toNoun = wordToNoun
instance ToNoun Word128 where toNoun = wordToNoun
instance ToNoun Word256 where toNoun = wordToNoun
instance ToNoun Word512 where toNoun = wordToNoun
instance FromNoun Word where parseNoun = named "Word" . nounToWord
instance FromNoun Word8 where parseNoun = named "Word8" . nounToWord
instance FromNoun Word16 where parseNoun = named "Word16" . nounToWord
instance FromNoun Word32 where parseNoun = named "Word32" . nounToWord
instance FromNoun Word64 where parseNoun = named "Word64" . nounToWord
instance FromNoun Word128 where parseNoun = named "Word128" . nounToWord
instance FromNoun Word256 where parseNoun = named "Word256" . nounToWord
instance FromNoun Word512 where parseNoun = named "Word512" . nounToWord
-- Maybe is `unit` -------------------------------------------------------------
-- TODO Consider enforcing that `a` must be a cell.
instance ToNoun a => ToNoun (Maybe a) where
toNoun Nothing = Atom 0
toNoun (Just x) = Cell (Atom 0) (toNoun x)
instance FromNoun a => FromNoun (Maybe a) where
parseNoun = named "Maybe" . \case
Atom 0 -> pure Nothing
Atom n -> unexpected ("atom " <> show n)
Cell (Atom 0) t -> Just <$> parseNoun t
Cell n _ -> unexpected ("cell with head-atom " <> show n)
where
unexpected s = fail ("Expected unit value, but got " <> s)
-- Either is `each` ------------------------------------------------------------
instance (ToNoun a, ToNoun b) => ToNoun (Either a b) where
toNoun (Left x) = Cell (Atom 0) (toNoun x)
toNoun (Right x) = Cell (Atom 1) (toNoun x)
instance (FromNoun a, FromNoun b) => FromNoun (Either a b) where
parseNoun n = named "Either" $ do
(Atom tag, v) <- parseNoun n
case tag of
0 -> named "%|" (Left <$> parseNoun v)
1 -> named "%&" (Right <$> parseNoun v)
n -> fail ("Each has invalid head-atom: " <> show n)
-- Tuple Conversions -----------------------------------------------------------
instance ToNoun () where
toNoun () = Atom 0
instance FromNoun () where
parseNoun = named "()" . \case
Atom 0 -> pure ()
x -> fail ("expecting `~`, but got " <> show x)
instance (ToNoun a, ToNoun b) => ToNoun (a, b) where
toNoun (x, y) = Cell (toNoun x) (toNoun y)
shortRec :: Word -> Parser a
shortRec 0 = fail "expected a record, but got an atom"
shortRec 1 = fail ("record too short, only one cell")
shortRec n = fail ("record too short, only " <> show n <> " cells")
instance (FromNoun a, FromNoun b) => FromNoun (a, b) where
parseNoun n = named ("(,)") $ do
case n of
A _ -> shortRec 0
C x y -> do
(,) <$> named "1" (parseNoun x)
<*> named "2" (parseNoun y)
instance (ToNoun a, ToNoun b, ToNoun c) => ToNoun (a, b, c) where
toNoun (x, y, z) = toNoun (x, (y, z))
instance (FromNoun a, FromNoun b, FromNoun c) => FromNoun (a, b, c) where
parseNoun n = named "(,,)" $ do
case n of
A _ -> shortRec 0
C x (A _) -> shortRec 1
C x (C y z) ->
(,,) <$> named "1" (parseNoun x)
<*> named "2" (parseNoun y)
<*> named "3" (parseNoun z)
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d) => ToNoun (a, b, c, d) where
toNoun (p, q, r, s) = toNoun (p, (q, r, s))
instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d)
=> FromNoun (a, b, c, d)
where
parseNoun n = named "(,,,)" $ do
case n of
A _ -> shortRec 0
C _ (A _) -> shortRec 1
C _ (C _ (A _)) -> shortRec 2
C p (C q (C r s)) ->
(,,,) <$> named "1" (parseNoun p)
<*> named "2" (parseNoun q)
<*> named "3" (parseNoun r)
<*> named "4" (parseNoun s)
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e)
=> ToNoun (a, b, c, d, e) where
toNoun (p, q, r, s, t) = toNoun (p, (q, r, s, t))
instance (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e)
=> FromNoun (a, b, c, d, e)
where
parseNoun n = named "(,,,,)" $ do
case n of
A _ -> shortRec 0
C _ (A _) -> shortRec 1
C _ (C _ (A _)) -> shortRec 2
C _ (C _ (C _ (A _))) -> shortRec 3
C p (C q (C r (C s t))) ->
(,,,,) <$> named "1" (parseNoun p)
<*> named "2" (parseNoun q)
<*> named "3" (parseNoun r)
<*> named "4" (parseNoun s)
<*> named "5" (parseNoun t)
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f)
=> ToNoun (a, b, c, d, e, f) where
toNoun (p, q, r, s, t, u) = toNoun (p, (q, r, s, t, u))
instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
, FromNoun f
)
=> FromNoun (a, b, c, d, e, f)
where
parseNoun n = named "(,,,,,)" $ do
(p, tail) <- parseNoun n
(q, r, s, t, u) <- parseNoun tail
pure (p, q, r, s, t, u)
instance (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g)
=> ToNoun (a, b, c, d, e, f, g) where
toNoun (p, q, r, s, t, u, v) = toNoun (p, (q, r, s, t, u, v))
instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
, FromNoun f, FromNoun g
)
=> FromNoun (a, b, c, d, e, f, g)
where
parseNoun n = named "(,,,,,,)" $ do
(p, tail) <- parseNoun n
(q, r, s, t, u, v) <- parseNoun tail
pure (p, q, r, s, t, u, v)
instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
, ToNoun h
)
=> ToNoun (a, b, c, d, e, f, g, h) where
toNoun (p, q, r, s, t, u, v, w) = toNoun (p, (q, r, s, t, u, v, w))
instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
, FromNoun f, FromNoun g, FromNoun h
)
=> FromNoun (a, b, c, d, e, f, g, h)
where
parseNoun n = named "(,,,,,,,)" $ do
(p, tail) <- parseNoun n
(q, r, s, t, u, v, w) <- parseNoun tail
pure (p, q, r, s, t, u, v, w)
instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
, ToNoun h, ToNoun i
)
=> ToNoun (a, b, c, d, e, f, g, h, i) where
toNoun (p, q, r, s, t, u, v, w, x) = toNoun (p, (q, r, s, t, u, v, w, x))
instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
, FromNoun f, FromNoun g, FromNoun h, FromNoun i
)
=> FromNoun (a, b, c, d, e, f, g, h, i)
where
parseNoun n = named "(,,,,,,,,)" $ do
(p, tail) <- parseNoun n
(q, r, s, t, u, v, w, x) <- parseNoun tail
pure (p, q, r, s, t, u, v, w, x)
instance ( ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f, ToNoun g
, ToNoun h, ToNoun i, ToNoun j
)
=> ToNoun (a, b, c, d, e, f, g, h, i, j) where
toNoun (p, q, r, s, t, u, v, w, x, y) =
toNoun (p, (q, r, s, t, u, v, w, x, y))
instance ( FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e
, FromNoun f, FromNoun g, FromNoun h, FromNoun i, FromNoun j
)
=> FromNoun (a, b, c, d, e, f, g, h, i, j)
where
parseNoun n = named "(,,,,,,,,,)" $ do
(p, tail) <- parseNoun n
(q, r, s, t, u, v, w, x, y) <- parseNoun tail
pure (p, q, r, s, t, u, v, w, x, y)
-- Ugg -------------------------------------------------------------------------
deriveNoun ''Path
deriveNoun ''EvilPath
Reference in New Issue View Git Blame Copy Permalink