voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-09-09 16:03:29 +03:00
parent e3655a8eb2
commit 655a901040
5 changed files with 127 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
fixme-new/lib/Fixme/Run.hs
View File

@ -309,6 +309,24 @@ runTop forms = do
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "dump" $ nil_ $ \case
[ FixmeHashLike w ] -> lift $ void $ runMaybeT do
key <- lift (selectFixmeKey w) >>= toMPlus
fme <- lift $ getFixme key
liftIO $ print $ pretty fme
_ -> throwIO $ BadFormException @C nil
-- magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
-- liftIO $ print $ pretty magic
entry $ bindMatch "fixme:key:show" $ nil_ \case
[ FixmeHashLike w ] -> lift $ void $ runMaybeT do
key <- lift (selectFixmeKey w) >>= toMPlus
liftIO $ print $ pretty key
_ -> throwIO $ BadFormException @C nil
entry $ bindMatch "fixme:scan-magic" $ nil_ $ const do
magic <- lift $ asks fixmeEnvScanMagic >>= readTVarIO
liftIO $ print $ pretty magic

2
fixme-new/lib/Fixme/Run/Internal.hs
View File

@ -182,7 +182,7 @@ scanFiles = do
let keyText = key <> fromString (show no)
let keyHash = FixmeKey $ fromString $ show $ pretty $ hashObject @HbSync (serialise keyText)
let f2 = mempty { fixmeTs = Just (fromIntegral ts)
, fixmeKey = Just keyHash
, fixmeKey = keyHash
, fixmeAttr = HM.fromList
[ ( "fixme-key-string", FixmeAttrVal keyText)
, ( "file", FixmeAttrVal (fromString fnShort))

2
fixme-new/lib/Fixme/Scan.hs
View File

@ -179,7 +179,7 @@ scanBlob fpath lbs = do
FixmeHead lno _ tag title ->
Fixme (FixmeTag tag)
(FixmeTitle title)
Nothing
mempty
Nothing
(Just (FixmeOffset (fromIntegral lno)))
Nothing

40
fixme-new/lib/Fixme/State.hs
View File

@ -7,22 +7,25 @@ module Fixme.State
, insertFixme
, insertScanned
, selectIsAlreadyScanned
, selectFixmeKey
, getFixme
, HasPredicate(..)
, SelectPredicate(..)
) where
import Fixme.Prelude
import Fixme.Prelude hiding (key)
import Fixme.Types
import Fixme.Config
import HBS2.System.Dir
import Data.Config.Suckless
import Data.Config.Suckless hiding (key)
import Data.Config.Suckless.Syntax
import DBPipe.SQLite hiding (field)
import Data.HashSet (HashSet)
import Data.HashSet qualified as HS
import Data.Aeson as Aeson
import Data.ByteString.Lazy qualified as LBS
import Data.HashMap.Strict qualified as HM
import Text.InterpolatedString.Perl6 (q,qc)
import Data.Text qualified as Text
@ -256,12 +259,37 @@ insertScanned file = do
on conflict (hash) do nothing|]
(Only k)
selectFixmeKey :: (FixmePerks m, MonadReader FixmeEnv m) => Text -> m (Maybe FixmeKey)
selectFixmeKey s = do
withState do
select @(Only FixmeKey) [qc|select distinct(o) from object where o like ? order by w desc|] (Only (s<>"%"))
<&> fmap fromOnly
<&> headMay
getFixme :: (FixmePerks m, MonadReader FixmeEnv m) => FixmeKey -> m (Maybe Fixme)
getFixme key = do
let sql = [qc|
select (cast (json_group_object(o.k, o.v) as blob)) as blob from object o
where o.o = ?
group by o.o
limit 1
|]
runMaybeT do
lift (withState $ select @(Only LBS.ByteString) sql (Only key))
<&> fmap (Aeson.decode @Fixme . fromOnly)
<&> catMaybes
<&> headMay
>>= toMPlus
insertFixme :: (FixmePerks m, MonadReader FixmeEnv m) => Fixme -> DBPipeM m ()
insertFixme fme = do
void $ runMaybeT do
o <- fixmeKey fme & toMPlus
let o = fixmeKey fme
w <- fixmeTs fme & toMPlus
let attrs = fixmeAttr fme
let txt = fixmePlain fme & Text.unlines . fmap coerce
@ -281,6 +309,12 @@ insertFixme fme = do
end
|]
for_ (fixmeStart fme) $ \s -> do
lift $ insert sql (o,w,"fixme-start",s)
for_ (fixmeEnd fme) $ \s -> do
lift $ insert sql (o,w,"fixme-end",s)
for_ (HM.toList attrs) $ \(k,v) -> do
lift $ insert sql (o,w,k,v)

81
fixme-new/lib/Fixme/Types.hs
View File

@ -27,7 +27,10 @@ import Data.Config.Suckless
import Prettyprinter.Render.Terminal
import Control.Applicative
import Data.Aeson
import Data.Aeson as Aeson
import Data.Aeson.KeyMap as Aeson hiding (null)
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.Types as Aeson
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString.Lazy qualified as LBS
@ -97,15 +100,15 @@ tsFromFromSyn = \case
_ -> Nothing
newtype FixmeTag = FixmeTag { fromFixmeTag :: Text }
deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField)
deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
deriving stock (Data,Generic)
newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text }
deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable)
deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable,FromJSON,ToJSON)
deriving stock (Data,Generic)
newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text }
deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField)
deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,FromJSON,ToJSON)
deriving stock (Data,Generic)
@ -121,16 +124,16 @@ newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text }
deriving stock (Data,Generic)
newtype FixmeTimestamp = FixmeTimestamp Word64
deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
deriving stock (Data,Generic)
newtype FixmeKey = FixmeKey Text
deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty)
deriving newtype (Eq,Ord,Show,ToField,FromField,Pretty,FromJSON,ToJSON,Semigroup,Monoid)
deriving stock (Data,Generic)
newtype FixmeOffset = FixmeOffset Word32
deriving newtype (Eq,Ord,Show,Num,ToField,FromField)
deriving newtype (Eq,Ord,Show,Num,ToField,FromField,ToJSON)
deriving newtype (Integral,Real,Enum)
deriving stock (Data,Generic)
@ -139,7 +142,7 @@ data Fixme =
Fixme
{ fixmeTag :: FixmeTag
, fixmeTitle :: FixmeTitle
, fixmeKey :: Maybe FixmeKey
, fixmeKey :: FixmeKey
, fixmeTs :: Maybe FixmeTimestamp
, fixmeStart :: Maybe FixmeOffset
, fixmeEnd :: Maybe FixmeOffset
@ -149,7 +152,7 @@ data Fixme =
deriving stock (Ord,Eq,Show,Data,Generic)
instance Monoid Fixme where
mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty
mempty = Fixme mempty mempty mempty Nothing Nothing Nothing mempty mempty
instance Semigroup Fixme where
(<>) a b = b { fixmeTs = fixmeTs b <|> fixmeTs a
@ -161,6 +164,57 @@ instance Semigroup Fixme where
, fixmeAttr = fixmeAttr a <> fixmeAttr b
}
instance FromJSON FixmeOffset where
parseJSON = \case
Number x -> pure (FixmeOffset (ceiling x))
String s -> do
n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
pure $ FixmeOffset n
_ -> fail "invalid FixmeOffset value"
instance FromJSON FixmeTimestamp where
parseJSON = \case
Number x -> pure (FixmeTimestamp (ceiling x))
String s -> do
n <- maybe (fail "invalid FixmeOffset value") pure (readMay (Text.unpack s))
pure $ FixmeTimestamp n
_ -> fail "invalid FixmeTimestamp value"
instance FromJSON Fixme where
parseJSON = withObject "Fixme" $ \o -> do
fixmeKey <- o .: "fixme-key"
fixmeTag <- o .: "fixme-tag"
fixmeTitle <- o .: "fixme-title"
fixmeStart <- o .:? "fixme-start"
fixmeEnd <- o .:? "fixme-end"
fixmeTs <- o .:? "fixme-timestamp"
fixmePlainTxt <- o .:? "fixme-text" <&> fromMaybe mempty
let fixmePlain = fmap FixmePlainLine (Text.lines fixmePlainTxt)
let wtf = [ unpackItem k v
| (k,v) <- Aeson.toList o
, k /= "fixme-text"
] & catMaybes
let fixmeAttr = HM.fromList wtf
return Fixme{..}
where
unpackItem k v = do
(FixmeAttrName (Aeson.toText k),) <$>
case v of
String x -> pure (FixmeAttrVal x)
_ -> Nothing
newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal)
deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON)
deriving stock (Data,Generic)
@ -635,7 +689,7 @@ fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of
(_,_) -> b
fixmeDerivedFields :: Fixme -> Fixme
fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
fixmeDerivedFields fx = fxEnd <> fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
where
email = HM.lookup "commiter-email" (fixmeAttr fx)
& maybe mempty (\x -> " <" <> x <> ">")
@ -645,7 +699,7 @@ fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx)) }
key = maybe mempty ( HM.singleton "fixme-key" . FixmeAttrVal . coerce) (fixmeKey fx)
key = HM.singleton "fixme-key" (FixmeAttrVal $ coerce $ (fixmeKey fx))
fxKey = mempty { fixmeAttr = key }
@ -653,6 +707,11 @@ fixmeDerivedFields fx = fx <> fxKey <> fxCo <> tag <> fxLno <> fxMisc
fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno }
fxE = join $ for (fixmeStart fx) $ \n -> do
Just $ FixmeOffset $ fromIntegral $ fromIntegral n + length (fixmePlain fx)
fxEnd = mempty { fixmeEnd = fxE }
fxCo =
maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter