mirror of
https://github.com/urbit/shrub.git
synced 2024-11-23 20:26:54 +03:00
stylish-haskell
This commit is contained in:
parent
2d2029106b
commit
c474a94d13
84
.stylish-haskell.yaml
Normal file
84
.stylish-haskell.yaml
Normal file
@ -0,0 +1,84 @@
|
||||
steps:
|
||||
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
|
||||
# by default.
|
||||
# - unicode_syntax:
|
||||
# # In order to make this work, we also need to insert the UnicodeSyntax
|
||||
# # language pragma. If this flag is set to true, we insert it when it's
|
||||
# # not already present. You may want to disable it if you configure
|
||||
# # language extensions using some other method than pragmas. Default:
|
||||
# # true.
|
||||
# add_language_pragma: true
|
||||
|
||||
- simple_align:
|
||||
cases: true
|
||||
top_level_patterns: true
|
||||
records: true
|
||||
|
||||
# Import cleanup
|
||||
- imports:
|
||||
align: group
|
||||
list_align: after_alias
|
||||
pad_module_names: true
|
||||
long_list_align: inline
|
||||
empty_list_align: inherit
|
||||
list_padding: 4
|
||||
separate_lists: false
|
||||
space_surround: false
|
||||
|
||||
- language_pragmas:
|
||||
style: vertical
|
||||
align: true
|
||||
remove_redundant: true
|
||||
|
||||
- tabs:
|
||||
spaces: 4
|
||||
|
||||
- trailing_whitespace: {}
|
||||
|
||||
# squash: {}
|
||||
|
||||
columns: 80
|
||||
|
||||
newline: lf
|
||||
|
||||
language_extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DataKinds
|
||||
- DefaultSignatures
|
||||
- DeriveAnyClass
|
||||
- DeriveDataTypeable
|
||||
- DeriveFoldable
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- EmptyDataDecls
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- FunctionalDependencies
|
||||
- GADTs
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MagicHash
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- NoImplicitPrelude
|
||||
- NumericUnderscores
|
||||
- OverloadedStrings
|
||||
- PartialTypeSignatures
|
||||
- PatternSynonyms
|
||||
- QuasiQuotes
|
||||
- Rank2Types
|
||||
- RankNTypes
|
||||
- RecordWildCards
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- TemplateHaskell
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- TypeFamilies
|
||||
- TypeOperators
|
||||
- UnboxedTuples
|
||||
- UnicodeSyntax
|
||||
- ViewPatterns
|
@ -12,12 +12,12 @@ module Noun
|
||||
import ClassyPrelude
|
||||
import Control.Lens
|
||||
|
||||
import Noun.Core
|
||||
import Noun.Convert
|
||||
import Noun.Conversions
|
||||
import Noun.Atom
|
||||
import Noun.Jam
|
||||
import Noun.Conversions
|
||||
import Noun.Convert
|
||||
import Noun.Core
|
||||
import Noun.Cue
|
||||
import Noun.Jam
|
||||
import Noun.TH
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -13,25 +13,25 @@ module Noun.Atom
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens hiding (Index)
|
||||
import Control.Lens hiding (Index)
|
||||
|
||||
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
|
||||
import GHC.Exts (sizeofByteArray#)
|
||||
import GHC.Int (Int(..))
|
||||
import GHC.Integer.GMP.Internals (BigNat(..), bigNatToWord, sizeofBigNat#)
|
||||
import GHC.Integer.GMP.Internals (indexBigNat#)
|
||||
import GHC.Integer.GMP.Internals (wordToBigNat, byteArrayToBigNat#, zeroBigNat)
|
||||
import GHC.Int (Int(..))
|
||||
import GHC.Integer.GMP.Internals (byteArrayToBigNat#, wordToBigNat, zeroBigNat)
|
||||
import GHC.Natural (Natural(..))
|
||||
import GHC.Prim (plusWord#, clz#, minusWord#)
|
||||
import GHC.Prim (Word#, subIntC#, timesWord#, int2Word#)
|
||||
import GHC.Prim (clz#, minusWord#, plusWord#)
|
||||
import GHC.Prim (Word#, int2Word#, subIntC#, timesWord#)
|
||||
import GHC.Word (Word(..))
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
import qualified Data.Primitive.Types as Prim
|
||||
import qualified Data.Primitive.ByteArray as Prim
|
||||
import qualified Data.Vector.Primitive as VP
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Unsafe as BU
|
||||
import qualified Data.Primitive.ByteArray as Prim
|
||||
import qualified Data.Primitive.Types as Prim
|
||||
import qualified Data.Vector.Primitive as VP
|
||||
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
|
@ -7,9 +7,9 @@ module Noun.Convert
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (hash)
|
||||
import Noun.Core
|
||||
import Noun.Atom
|
||||
import Control.Lens
|
||||
import Noun.Atom
|
||||
import Noun.Core
|
||||
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
|
||||
|
@ -1,5 +1,6 @@
|
||||
{-# OPTIONS_GHC -funbox-strict-fields #-}
|
||||
{-# LANGUAGE Strict, StrictData #-}
|
||||
{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
|
||||
module Noun.Core
|
||||
( Noun, pattern Cell, pattern Atom, nounSize
|
||||
@ -14,7 +15,7 @@ import Data.Hashable (hash)
|
||||
import GHC.Natural (Natural)
|
||||
import GHC.Prim (reallyUnsafePtrEquality#)
|
||||
import Test.QuickCheck.Arbitrary (Arbitrary(arbitrary))
|
||||
import Test.QuickCheck.Gen (Gen, scale, resize, getSize)
|
||||
import Test.QuickCheck.Gen (Gen, getSize, resize, scale)
|
||||
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
|
@ -2,12 +2,12 @@ module Noun.Cue (cue, cueBS) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Noun.Core
|
||||
import Noun.Atom
|
||||
import Noun.Core
|
||||
|
||||
import Control.Lens (view, from)
|
||||
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
|
||||
import Foreign.Ptr (Ptr, plusPtr, castPtr, ptrToWordPtr)
|
||||
import Control.Lens (from, view)
|
||||
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
|
||||
import Foreign.Ptr (Ptr, castPtr, plusPtr, ptrToWordPtr)
|
||||
import Foreign.Storable (peek)
|
||||
import GHC.Prim (ctz#)
|
||||
import GHC.Word (Word(..))
|
||||
@ -75,7 +75,7 @@ newtype Get a = Get
|
||||
|
||||
doGet :: Get a -> ByteString -> Either DecodeExn a
|
||||
doGet m bs =
|
||||
unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do
|
||||
unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do
|
||||
let endPtr = ptr `plusPtr` len
|
||||
let sz = max 50
|
||||
$ min 10_000_000
|
||||
@ -137,19 +137,19 @@ getPos = Get $ \_ _ s ->
|
||||
pure (GetResult s (pos s))
|
||||
|
||||
insRef :: Word -> Noun -> Get ()
|
||||
insRef !pos !now = Get \_ tbl s -> do
|
||||
insRef !pos !now = Get $ \_ tbl s -> do
|
||||
H.insert tbl pos now
|
||||
pure $ GetResult s ()
|
||||
|
||||
getRef :: Word -> Get Noun
|
||||
getRef !ref = Get \x tbl s -> do
|
||||
getRef !ref = Get $ \x tbl s -> do
|
||||
H.lookup tbl ref >>= \case
|
||||
Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s
|
||||
Just no -> pure (GetResult s no)
|
||||
|
||||
advance :: Word -> Get ()
|
||||
advance 0 = debugM "advance: 0" >> pure ()
|
||||
advance !n = Get \_ _ s -> do
|
||||
advance !n = Get $ \_ _ s -> do
|
||||
debugM ("advance: " <> show n)
|
||||
let newUsed = n + usedBits s
|
||||
newS = s { pos = pos s + n
|
||||
@ -164,7 +164,7 @@ advance !n = Get \_ _ s -> do
|
||||
|
||||
-- TODO Should this be (>= end) or (> end)?
|
||||
peekCurWord :: Get Word
|
||||
peekCurWord = Get \end _ s -> do
|
||||
peekCurWord = Get $ \end _ s -> do
|
||||
debugMId "peekCurWord" $ do
|
||||
if ptrToWordPtr (currPtr s) >= ptrToWordPtr end
|
||||
then pure (GetResult s 0)
|
||||
@ -172,7 +172,7 @@ peekCurWord = Get \end _ s -> do
|
||||
|
||||
-- TODO Same question as above.
|
||||
peekNextWord :: Get Word
|
||||
peekNextWord = Get \end _ s -> do
|
||||
peekNextWord = Get $ \end _ s -> do
|
||||
debugMId "peekNextWord" $ do
|
||||
let pTarget = currPtr s `plusPtr` 8
|
||||
if ptrToWordPtr pTarget >= ptrToWordPtr end
|
||||
@ -182,7 +182,7 @@ peekNextWord = Get \end _ s -> do
|
||||
peekUsedBits :: Get Word
|
||||
peekUsedBits =
|
||||
debugMId "peekUsedBits" $ do
|
||||
Get \_ _ s -> pure (GetResult s (usedBits s))
|
||||
Get $ \_ _ s -> pure (GetResult s (usedBits s))
|
||||
|
||||
{-|
|
||||
Get a bit.
|
||||
@ -219,7 +219,7 @@ dAtomBits :: Word -> Get Atom
|
||||
dAtomBits !(fromIntegral -> bits) = do
|
||||
debugMId ("dAtomBits(" <> show bits <> ")") $ do
|
||||
fmap (view $ from atomWords) $
|
||||
VP.generateM bufSize \i -> do
|
||||
VP.generateM bufSize $ \i -> do
|
||||
debugM (show i)
|
||||
if (i == lastIdx && numExtraBits /= 0)
|
||||
then dWordBits (fromIntegral numExtraBits)
|
||||
|
@ -2,18 +2,18 @@ module Noun.Jam (jam, jamBS) where
|
||||
|
||||
import ClassyPrelude hiding (hash)
|
||||
|
||||
import Noun.Core
|
||||
import Noun.Atom
|
||||
import Noun.Core
|
||||
|
||||
import Control.Lens (view, from)
|
||||
import Data.Bits (shiftL, shiftR, setBit, clearBit, (.|.))
|
||||
import Control.Lens (from, view)
|
||||
import Data.Bits (clearBit, setBit, shiftL, shiftR, (.|.))
|
||||
import Data.Vector.Primitive ((!))
|
||||
import Foreign.Marshal.Alloc (callocBytes, free)
|
||||
import Foreign.Ptr (Ptr, castPtr, plusPtr)
|
||||
import Foreign.Storable (poke)
|
||||
import GHC.Integer.GMP.Internals (BigNat)
|
||||
import GHC.Int (Int(I#))
|
||||
import GHC.Natural (Natural(NatS#, NatJ#))
|
||||
import GHC.Integer.GMP.Internals (BigNat)
|
||||
import GHC.Natural (Natural(NatJ#, NatS#))
|
||||
import GHC.Prim (Word#, plusWord#, word2Int#)
|
||||
import GHC.Word (Word(W#))
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
@ -64,7 +64,7 @@ newtype Put a = Put
|
||||
|
||||
{-# INLINE getRef #-}
|
||||
getRef :: Put (Maybe Word)
|
||||
getRef = Put \tbl s -> PutResult s <$> H.lookup tbl (pos s)
|
||||
getRef = Put $ \tbl s -> PutResult s <$> H.lookup tbl (pos s)
|
||||
|
||||
{-
|
||||
1. Write the register to the output, and increment the output pointer.
|
||||
@ -77,15 +77,15 @@ flush = Put $ \tbl s@S{..} -> do
|
||||
|
||||
{-# INLINE update #-}
|
||||
update :: (S -> S) -> Put ()
|
||||
update f = Put \tbl s@S{..} -> pure (PutResult (f s) ())
|
||||
update f = Put $ \tbl s@S{..} -> pure (PutResult (f s) ())
|
||||
|
||||
{-# INLINE setRegOff #-}
|
||||
setRegOff :: Word -> Int -> Put ()
|
||||
setRegOff r o = update \s@S{..} -> (s {reg=r, off=o})
|
||||
setRegOff r o = update $ \s@S{..} -> (s {reg=r, off=o})
|
||||
|
||||
{-# INLINE setReg #-}
|
||||
setReg :: Word -> Put ()
|
||||
setReg r = update \s@S{..} -> (s { reg=r })
|
||||
setReg r = update $ \s@S{..} -> (s { reg=r })
|
||||
|
||||
{-# INLINE getS #-}
|
||||
getS :: Put S
|
||||
@ -129,9 +129,9 @@ writeWord wor = do
|
||||
S{..} <- getS
|
||||
setReg (reg .|. shiftL wor off)
|
||||
flush
|
||||
update \s -> s { pos = 64 + pos
|
||||
, reg = shiftR wor (64 - off)
|
||||
}
|
||||
update $ \s -> s { pos = 64 + pos
|
||||
, reg = shiftR wor (64 - off)
|
||||
}
|
||||
|
||||
{-
|
||||
To write some bits (< 64) from a word:
|
||||
@ -182,7 +182,7 @@ writeAtomWord (W# w) = writeAtomWord# w
|
||||
writeAtomBigNat :: BigNat -> Put ()
|
||||
writeAtomBigNat !(view bigNatWords -> words) = do
|
||||
let lastIdx = VP.length words - 1
|
||||
for_ [0..(lastIdx-1)] \i ->
|
||||
for_ [0..(lastIdx-1)] $ \i ->
|
||||
writeWord (words ! i)
|
||||
writeAtomWord (words ! lastIdx)
|
||||
|
||||
|
@ -4,10 +4,10 @@
|
||||
|
||||
module Noun.TH (deriveNoun) where
|
||||
|
||||
import ClassyPrelude hiding (fromList)
|
||||
import Noun.Convert
|
||||
import ClassyPrelude hiding (fromList)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Noun.Convert
|
||||
|
||||
import RIO (decodeUtf8Lenient)
|
||||
|
||||
|
@ -5,8 +5,8 @@ module Urbit.Ames where
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.IP
|
||||
import Noun
|
||||
import Network.Socket
|
||||
import Noun
|
||||
|
||||
import qualified Data.Vector as V
|
||||
import qualified Urbit.Time as Time
|
||||
@ -17,11 +17,11 @@ import qualified Vere.Ames as VA
|
||||
data GalaxyInfo = GalaxyInfo { ip :: IPv4, age :: Time.Unix }
|
||||
|
||||
data Ames = Ames
|
||||
{ live :: Bool -- ^ whether the listener is on
|
||||
, ourPort :: Maybe Int
|
||||
{ live :: Bool -- ^ whether the listener is on
|
||||
, ourPort :: Maybe Int
|
||||
-- , threadId :: Thread
|
||||
, globalDomain :: Maybe Text -- ^ something like "urbit.org"
|
||||
, imperial :: V.Vector (Maybe GalaxyInfo)
|
||||
, imperial :: V.Vector (Maybe GalaxyInfo)
|
||||
}
|
||||
|
||||
init :: Ames
|
||||
@ -52,7 +52,7 @@ ioStart ames isLocal defaultPort (Atom who) = do
|
||||
|
||||
-- TODO: set up another thread to own the recv socket, which makes the Ovums
|
||||
-- which get put into the computeQueue, like in _ames_recv_cb.
|
||||
withSocketsDo do
|
||||
withSocketsDo $ do
|
||||
s <- socket AF_INET Datagram 17
|
||||
-- bind s (SockAddrInet port )
|
||||
pure ()
|
||||
|
@ -16,18 +16,15 @@
|
||||
until a new time has been set.
|
||||
-}
|
||||
|
||||
module Urbit.Behn (Behn, init, wait, doze) where
|
||||
module Urbit.Behn (Behn(..), init, wait, doze) where
|
||||
|
||||
import Prelude hiding (init)
|
||||
import Control.Lens
|
||||
import Prelude hiding (init)
|
||||
|
||||
import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar)
|
||||
import Control.Monad (void, when)
|
||||
import Data.IORef (IORef, writeIORef, readIORef, newIORef)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
|
||||
|
||||
import qualified Urbit.Timer as Timer
|
||||
import qualified Urbit.Time as Time
|
||||
import qualified GHC.Event as Ev
|
||||
import qualified Urbit.Timer as Timer
|
||||
|
||||
|
||||
-- Behn Stuff ------------------------------------------------------------------
|
||||
|
@ -2,15 +2,15 @@
|
||||
|
||||
module Urbit.Time where
|
||||
|
||||
import Prelude
|
||||
import Control.Lens
|
||||
import Prelude
|
||||
|
||||
import Noun (FromNoun, ToNoun)
|
||||
import Data.Bits (shiftL, shiftR)
|
||||
import Data.Time.Clock (DiffTime, UTCTime)
|
||||
import Data.Time.Clock (picosecondsToDiffTime, diffTimeToPicoseconds)
|
||||
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
|
||||
import Data.Time.Clock.System (SystemTime(..), getSystemTime)
|
||||
import Data.Time.Clock.System (utcToSystemTime, systemToUTCTime)
|
||||
import Data.Time.Clock.System (systemToUTCTime, utcToSystemTime)
|
||||
import Noun (FromNoun, ToNoun)
|
||||
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
|
@ -1,16 +1,12 @@
|
||||
module Urbit.Timer ( Timer, init, stop, start
|
||||
module Urbit.Timer ( Timer(..), init, stop, start
|
||||
, Sys.getSystemTime, sysTimeGapMicroSecs
|
||||
) where
|
||||
|
||||
import Prelude hiding (init)
|
||||
import Control.Lens
|
||||
import Data.IORef
|
||||
import Prelude hiding (init)
|
||||
|
||||
import Control.Concurrent.MVar (MVar, takeMVar, newEmptyMVar, putMVar)
|
||||
import Control.Monad (void, when)
|
||||
|
||||
import qualified GHC.Event as Ev
|
||||
import qualified Data.Time.Clock.System as Sys
|
||||
import qualified GHC.Event as Ev
|
||||
|
||||
|
||||
-- Timer Stuff -----------------------------------------------------------------
|
||||
|
@ -5,7 +5,7 @@ import Data.IP
|
||||
import Data.Void
|
||||
import Noun
|
||||
|
||||
import qualified Urbit.Time as Time
|
||||
import qualified Urbit.Time as Time
|
||||
|
||||
type Packet = ByteString
|
||||
|
||||
|
@ -5,8 +5,8 @@ module Vere.Http where
|
||||
import ClassyPrelude
|
||||
import Noun
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Network.HTTP.Types as HT
|
||||
import qualified Network.HTTP.Types.Method as H
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
@ -26,7 +26,7 @@ data Request = Request
|
||||
|
||||
data ResponseHeader = ResponseHeader
|
||||
{ statusCode :: Word
|
||||
, headers :: [Header]
|
||||
, headers :: [Header]
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
@ -50,7 +50,7 @@ cvtReq r =
|
||||
H.requestBody =
|
||||
H.RequestBodyBS $ case body r of
|
||||
Nothing -> ""
|
||||
Just b -> b
|
||||
Just b -> b
|
||||
}
|
||||
|
||||
cvtRespHeaders :: H.Response a -> ResponseHeader
|
||||
|
@ -8,7 +8,7 @@ import Control.Lens
|
||||
import Noun
|
||||
import Vere.Http
|
||||
|
||||
import Control.Concurrent (ThreadId, killThread, forkIO)
|
||||
import Control.Concurrent (ThreadId, forkIO, killThread)
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Network.HTTP.Types as H
|
||||
@ -110,7 +110,7 @@ app s req respond = bracket_
|
||||
cookMeth :: W.Request -> Maybe Method
|
||||
cookMeth re =
|
||||
case H.parseMethod (W.requestMethod re) of
|
||||
Left _ -> Nothing
|
||||
Left _ -> Nothing
|
||||
Right m -> Just m
|
||||
|
||||
data Octs = Octs Atom Atom
|
||||
|
@ -1,15 +1,16 @@
|
||||
{-# OPTIONS_GHC -Wwarn #-}
|
||||
|
||||
module Vere.Isle where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Word
|
||||
|
||||
import qualified Vere.Isle.Util as C
|
||||
import qualified SDL as SDL
|
||||
import qualified Data.Vector as V
|
||||
import qualified SDL as SDL
|
||||
import qualified Vere.Isle.Util as C
|
||||
|
||||
import Data.Bits (testBit)
|
||||
import Data.Vector ((!))
|
||||
import Data.Flat (Flat)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
@ -63,13 +63,13 @@ isContinue = maybe True (not . isQuitEvent)
|
||||
|
||||
|
||||
conditionallyRun :: (Monad m) => m a -> Bool -> m Bool
|
||||
conditionallyRun f True = True <$ f
|
||||
conditionallyRun f True = True <$ f
|
||||
conditionallyRun _ False = pure False
|
||||
|
||||
|
||||
isQuitEvent :: SDL.Event -> Bool
|
||||
isQuitEvent (SDL.Event _t SDL.QuitEvent) = True
|
||||
isQuitEvent _ = False
|
||||
isQuitEvent _ = False
|
||||
|
||||
|
||||
setHintQuality :: (MonadIO m) => m ()
|
||||
|
@ -106,7 +106,7 @@ readEvents (EventLog env) first len =
|
||||
found <- mdb_cursor_get MDB_SET_KEY cur pKey pVal
|
||||
assertErr found "mdb could not read initial event of sequence"
|
||||
|
||||
vec <- V.generateM (int len) \i -> do
|
||||
vec <- V.generateM (int len) $ \i -> do
|
||||
key <- peek pKey >>= mdbValToWord64
|
||||
val <- peek pVal >>= mdbValToAtom
|
||||
|
||||
@ -114,7 +114,7 @@ readEvents (EventLog env) first len =
|
||||
|
||||
assertErr (key == idx) ("missing event in database " <> (show idx))
|
||||
|
||||
when (i + 1 /= (int len)) do
|
||||
when (i + 1 /= (int len)) $ do
|
||||
found <- mdb_cursor_get MDB_NEXT cur pKey pVal
|
||||
assertErr found "lmdb: next event not found"
|
||||
|
||||
@ -141,7 +141,7 @@ maybeErr Nothing msg = error msg
|
||||
|
||||
byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a
|
||||
byteStringAsMdbVal bs k =
|
||||
BU.unsafeUseAsCStringLen bs \(ptr,sz) ->
|
||||
BU.unsafeUseAsCStringLen bs $ \(ptr,sz) ->
|
||||
k (MDB_val (fromIntegral sz) (castPtr ptr))
|
||||
|
||||
mdbValToWord64 :: MDB_val -> IO Word64
|
||||
@ -163,7 +163,7 @@ withWordPtr w cb = do
|
||||
|
||||
get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun
|
||||
get txn db key =
|
||||
byteStringAsMdbVal key \mKey ->
|
||||
byteStringAsMdbVal key $ \mKey ->
|
||||
mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun
|
||||
|
||||
mdbValToAtom :: MDB_val -> IO Atom
|
||||
|
@ -8,9 +8,9 @@ module Vere.Persist (start, stop) where
|
||||
|
||||
import ClassyPrelude hiding (init)
|
||||
|
||||
import Database.LMDB.Raw
|
||||
import Vere.Log
|
||||
import Vere.Pier.Types
|
||||
import Database.LMDB.Raw
|
||||
|
||||
|
||||
-- Types -----------------------------------------------------------------------
|
||||
@ -45,7 +45,7 @@ persistThread :: EventLog
|
||||
-> (Writ [Eff] -> STM ())
|
||||
-> IO ()
|
||||
persistThread (EventLog env) inputQueue onPersist =
|
||||
forever do
|
||||
forever $ do
|
||||
writs <- atomically $ readQueue inputQueue
|
||||
writeEvents writs
|
||||
atomically $ traverse_ onPersist writs
|
||||
|
@ -1,11 +1,11 @@
|
||||
module Vere.Pier.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Noun
|
||||
import Database.LMDB.Raw
|
||||
import Noun
|
||||
import Urbit.Time
|
||||
|
||||
import qualified Vere.Ames as Ames
|
||||
import qualified Vere.Ames as Ames
|
||||
import qualified Vere.Http.Client as Client
|
||||
import qualified Vere.Http.Server as Server
|
||||
|
||||
|
@ -14,7 +14,7 @@ import Data.ByteString (hGet)
|
||||
import Data.ByteString.Unsafe (unsafeUseAsCString)
|
||||
import Foreign.Marshal.Alloc (alloca)
|
||||
import Foreign.Ptr (castPtr)
|
||||
import Foreign.Storable (poke, peek)
|
||||
import Foreign.Storable (peek, poke)
|
||||
import System.Exit (ExitCode)
|
||||
|
||||
import qualified Data.ByteString.Unsafe as BS
|
||||
@ -220,7 +220,7 @@ replayEvents w (wid, wmug) identity lastCommitedId getEvents = do
|
||||
loop vLast curEvent = do
|
||||
traceM ("replayEvents.loop: " <> show curEvent)
|
||||
let toRead = min 1000 (1 + lastCommitedId - curEvent)
|
||||
when (toRead > 0) do
|
||||
when (toRead > 0) $ do
|
||||
traceM ("replayEvents.loop.getEvents " <> show toRead)
|
||||
|
||||
events <- getEvents curEvent toRead
|
||||
@ -264,7 +264,7 @@ replay w ident lastEv getEvents = do
|
||||
replayEvents w ws ident lastEv getEvents
|
||||
|
||||
workerThread :: Serf -> STM Ovum -> (EventId, Mug) -> IO (Async ())
|
||||
workerThread w getEvent (evendId, mug) = async $ forever do
|
||||
workerThread w getEvent (evendId, mug) = async $ forever $ do
|
||||
ovum <- atomically $ getEvent
|
||||
|
||||
currentDate <- Time.now
|
||||
|
Loading…
Reference in New Issue
Block a user