plunder

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

Convert.hs (9052B)

      1 -- Copyright 2023 The Plunder Authors
      2 -- Use of this source code is governed by a BSD-style license that can be
      3 -- found in the LICENSE file.
      4 
      5 module Fan.Convert where
      6 
      7 import Data.Sorted
      8 import Fan
      9 import PlunderPrelude
     10 
     11 import GHC.Word (Word(W#))
     12 import Hash256  (Hash256, hashToByteString, toHash256)
     13 
     14 import qualified Data.Vector as V
     15 
     16 
     17 --------------------------------------------------------------------------------
     18 
     19 class ToNoun a where
     20     toNoun :: a -> Fan
     21 
     22 class FromNoun a where
     23     fromNoun :: Fan -> Maybe a
     24 
     25 instance ToNoun () where
     26     toNoun () = NAT 0
     27 
     28 instance FromNoun () where
     29     fromNoun (NAT 0) = Just ()
     30     fromNoun _       = Nothing
     31 
     32 instance ToNoun Bool where
     33     toNoun True  = NAT 1
     34     toNoun False = NAT 0
     35 
     36 instance FromNoun Bool where
     37     fromNoun (NAT 0) = Just False
     38     fromNoun (NAT 1) = Just True
     39     fromNoun _       = Nothing
     40 
     41 instance ToNoun Fan where
     42     toNoun = id
     43 instance FromNoun Fan where
     44     fromNoun = Just . id
     45 
     46 instance ToNoun Pin where
     47     toNoun p = PIN p
     48 instance FromNoun Pin where
     49     fromNoun (PIN p) = Just p
     50     fromNoun _       = Nothing
     51 
     52 instance ToNoun Natural where
     53     toNoun n = NAT n
     54 instance FromNoun Natural where
     55     fromNoun (NAT n) = Just n
     56     fromNoun _       = Nothing
     57 
     58 instance ToNoun Word where
     59     toNoun (W# w) = NAT (NatS# w)
     60 
     61 maxWord :: Word
     62 maxWord = maxBound
     63 
     64 instance FromNoun Word where
     65     fromNoun (NAT (NatS# w)) = Just (W# w)
     66     fromNoun _               = Nothing
     67 
     68 instance ToNoun Word8 where
     69     toNoun w = toNoun (fromIntegral w :: Word)
     70 instance FromNoun Word8 where
     71     fromNoun = wordFromNoun
     72 
     73 instance ToNoun Word32 where
     74     toNoun w = toNoun (fromIntegral w :: Word)
     75 instance FromNoun Word32 where
     76     fromNoun = wordFromNoun
     77 
     78 instance ToNoun Word64 where
     79     toNoun w = toNoun (fromIntegral w :: Word)
     80 instance FromNoun Word64 where
     81     fromNoun n = do -- we assume 64 bit system, so Word==Word64
     82         w :: Word <- fromNoun n
     83         pure (fromIntegral w)
     84 
     85 instance FromNoun Int where
     86     fromNoun n = do -- INFO this could overflow for positive values above 2^63
     87         w :: Word <- fromNoun n
     88         pure (fromIntegral w)
     89 
     90 wordFromNoun :: forall w. (Bounded w, Integral w) => Fan -> Maybe w
     91 wordFromNoun n = do
     92     w :: Word <- fromNoun n
     93     guard (w <= fromIntegral (maxBound :: w))
     94     pure (fromIntegral w)
     95 
     96 instance (ToNoun a,ToNoun b) => ToNoun (a,b)
     97   where
     98     toNoun (x,y) =
     99         ROW $ arrayFromListN 2 [toNoun x, toNoun y]
    100 
    101 instance (ToNoun a,ToNoun b,ToNoun c) => ToNoun (a,b,c)
    102   where
    103     toNoun (x,y,z) =
    104         ROW $ arrayFromListN 3 [toNoun x, toNoun y, toNoun z]
    105 
    106 instance (ToNoun a,ToNoun b,ToNoun c,ToNoun d) => ToNoun (a,b,c,d)
    107   where
    108     toNoun (p,q,r,s) =
    109         ROW $ arrayFromListN 4 [toNoun p,toNoun q,toNoun r,toNoun s]
    110 
    111 instance
    112     (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e)
    113        => ToNoun (a, b, c, d, e)
    114   where
    115     toNoun (p, q, r, s, t) =
    116         ROW $ arrayFromListN 5 $
    117             [toNoun p, toNoun q, toNoun r, toNoun s, toNoun t]
    118 
    119 instance
    120     (ToNoun a, ToNoun b, ToNoun c, ToNoun d, ToNoun e, ToNoun f)
    121         => ToNoun (a, b, c, d, e, f)
    122   where
    123     toNoun (p, q, r, s, t, u) =
    124         ROW $ arrayFromListN 6 $
    125             [toNoun p, toNoun q, toNoun r, toNoun s, toNoun t, toNoun u]
    126 
    127 instance (FromNoun a,FromNoun b)
    128     => FromNoun (a,b)
    129   where
    130     fromNoun n = do
    131         r <- getRawRow n
    132         guard (length r == 2)
    133         (,) <$> fromNoun (r!0)
    134             <*> fromNoun (r!1)
    135 
    136 instance (FromNoun a,FromNoun b,FromNoun c)
    137     => FromNoun (a,b,c)
    138   where
    139     fromNoun n = do
    140         r <- getRawRow n
    141         guard (length r == 3)
    142         (,,) <$> fromNoun (r!0)
    143              <*> fromNoun (r!1)
    144              <*> fromNoun (r!2)
    145 
    146 instance (FromNoun a,FromNoun b,FromNoun c,FromNoun d)
    147     => FromNoun (a,b,c,d)
    148   where
    149     fromNoun n = do
    150         r <- getRawRow n
    151         guard (length r == 4)
    152         (,,,) <$> fromNoun (r!0)
    153               <*> fromNoun (r!1)
    154               <*> fromNoun (r!2)
    155               <*> fromNoun (r!3)
    156 
    157 instance
    158     (FromNoun a,FromNoun b,FromNoun c,FromNoun d,FromNoun e)
    159         => FromNoun (a, b, c, d, e)
    160   where
    161     fromNoun n = do
    162         r <- getRawRow n
    163         guard (length r == 5)
    164         (,,,,) <$> fromNoun (r!0)
    165                <*> fromNoun (r!1)
    166                <*> fromNoun (r!2)
    167                <*> fromNoun (r!3)
    168                <*> fromNoun (r!4)
    169 
    170 instance
    171     (FromNoun a, FromNoun b, FromNoun c, FromNoun d, FromNoun e, FromNoun f)
    172         => FromNoun (a, b, c, d, e, f)
    173   where
    174     fromNoun n = do
    175         r <- getRawRow n
    176         guard (length r == 6)
    177         (,,,,,) <$> fromNoun (r!0)
    178                 <*> fromNoun (r!1)
    179                 <*> fromNoun (r!2)
    180                 <*> fromNoun (r!3)
    181                 <*> fromNoun (r!4)
    182                 <*> fromNoun (r!5)
    183 
    184 instance ToNoun ByteString where
    185     toNoun = BAR
    186 
    187 instance FromNoun ByteString where
    188     fromNoun (BAR n) = Just n
    189     fromNoun  _      = Nothing
    190 
    191 instance ToNoun LByteString where
    192     toNoun = BAR . toStrict
    193 
    194 instance FromNoun LByteString where
    195     fromNoun (BAR n) = Just (fromStrict n)
    196     fromNoun  _      = Nothing
    197 
    198 instance ToNoun Hash256 where
    199     toNoun = BAR . hashToByteString
    200 
    201 instance FromNoun Hash256 where
    202     fromNoun = \case
    203         BAR x | length x == 32 -> Just (toHash256 x)
    204         _                      -> Nothing
    205 
    206 instance ToNoun Text where
    207     toNoun = NAT . utf8Nat
    208 
    209 instance FromNoun Text where
    210     fromNoun (NAT n) = either (const Nothing) Just (natUtf8 n)
    211     fromNoun _       = Nothing
    212 
    213 getRawRow :: Fan -> Maybe (Array Fan)
    214 getRawRow (ROW xs) = Just xs
    215 getRawRow _        = Nothing
    216 
    217 getRowVec :: Fan -> Maybe (Vector Fan)
    218 getRowVec = fmap V.fromArray . getRawRow
    219 
    220 getRawSet :: Fan -> Maybe (ArraySet Fan)
    221 getRawSet (SET xs) = Just xs
    222 getRawSet _        = Nothing
    223 
    224 getRawTable :: Fan -> Maybe (Tab Fan Fan)
    225 getRawTable (TAb m) = Just m
    226 getRawTable _       = Nothing
    227 
    228 getRawBar :: Fan -> Maybe ByteString
    229 getRawBar (BAR b) = Just b
    230 getRawBar _       = Nothing
    231 
    232 instance ToNoun a => ToNoun (Array a) where
    233     toNoun = ROW . fmap toNoun
    234 
    235 instance FromNoun a => FromNoun (Array a) where
    236     fromNoun n = getRawRow n >>= mapM fromNoun
    237 
    238 instance ToNoun a => ToNoun (Vector a) where
    239     toNoun = toNoun . V.toArray
    240 
    241 instance FromNoun a => FromNoun (Vector a) where
    242     fromNoun n = V.fromArray <$> fromNoun n
    243 
    244 -- | Since we are very unlikely to ever want actual noun linked-lists
    245 -- at an API boundary, we represent lists as rows.
    246 instance ToNoun a => ToNoun [a] where
    247     toNoun = ROW . arrayFromList . fmap toNoun
    248 
    249 -- | Since we are very unlikely to ever want actual noun linked-lists
    250 -- at an API boundary, we represent lists as rows.
    251 instance FromNoun a => FromNoun [a] where
    252     fromNoun n = toList @(Vector a) <$> fromNoun n
    253 
    254 
    255 instance ToNoun a => ToNoun (ArraySet a) where
    256     toNoun = SET . setFromList . map toNoun . toList
    257 
    258 instance (Ord a, FromNoun a) => FromNoun (ArraySet a) where
    259     fromNoun n = do
    260         r <- getRawSet n
    261         setFromList <$> forM (toList r) fromNoun
    262 
    263 instance (Ord a, ToNoun a) => ToNoun (Set a) where
    264     toNoun = SET . setFromList . map toNoun . toList
    265 
    266 instance (Ord a, FromNoun a) => FromNoun (Set a) where
    267     fromNoun n = do
    268         r <- getRawSet n
    269         setFromList <$> forM (toList r) fromNoun
    270 
    271 instance (Ord k, ToNoun k, ToNoun v) => ToNoun (Tab k v) where
    272     toNoun = TAb . mapFromList . map (both toNoun toNoun) . mapToList
    273       where
    274         both f g (a, b) = (f a, g b)
    275 
    276 instance (Ord k, FromNoun k, FromNoun v) => FromNoun (Tab k v) where
    277     fromNoun n = do
    278         r <- getRawTable n
    279         pairs <- forM (mapToList r) $ \(k, v) -> do
    280             kf <- fromNoun k
    281             kv <- fromNoun v
    282             pure (kf, kv)
    283         pure $ mapFromList pairs
    284 
    285 instance (Ord k, ToNoun k, ToNoun v) => ToNoun (Map k v) where
    286     toNoun = TAb . mapFromList . map (both toNoun toNoun) . mapToList
    287       where
    288         both f g (a, b) = (f a, g b)
    289 
    290 instance (Ord k, FromNoun k, FromNoun v) => FromNoun (Map k v) where
    291     fromNoun n = do
    292         r <- getRawTable n
    293         pairs <- forM (mapToList r) $ \(k, v) -> do
    294             kf <- fromNoun k
    295             kv <- fromNoun v
    296             pure (kf, kv)
    297         pure $ mapFromList pairs
    298 
    299 instance (ToNoun a) => ToNoun (Maybe a) where
    300     toNoun Nothing  = NAT 0
    301     toNoun (Just a) = (NAT 0) %% (toNoun a)
    302 
    303 instance (FromNoun a) => FromNoun (Maybe a) where
    304     fromNoun (NAT 0) = Just Nothing
    305     fromNoun n       = do
    306         let (h, t) = boom n
    307         case h of
    308             NAT 0 -> Just <$> fromNoun t
    309             _     -> Nothing
    310 
    311 -- Hack: inputs are cast to unsigned
    312 instance ToNoun a => ToNoun (IntMap a) where
    313     toNoun = TAb . mapFromList . fmap f . mapToList
    314       where
    315         f (k,v) = (NAT (fromIntegral k), toNoun v)
    316 
    317 instance FromNoun a => FromNoun (IntMap a) where
    318     fromNoun = \case
    319         TAb t -> fmap mapFromList
    320                    $ for (mapToList t) \(kF,vF) -> do
    321                        k::Word64 <- fromNoun kF
    322                        v         <- fromNoun vF
    323                        pure (fromIntegral k, v)
    324         _     -> Nothing