mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
voidlizard
parent
3450c97baa
commit
3a8041f93e
48
bf6/hbs23
48
bf6/hbs23
|
|
@ -5,37 +5,51 @@
|
|||
; # (println (grep (sym "-g") *args))
|
||||
|
||||
(match *args
|
||||
|
||||
( (list? [sym? store] ...)
|
||||
(begin
|
||||
(local optdef (kw -g 1 --group-key 1))
|
||||
(local cli (cli:split optdef ...))
|
||||
(local opts (nth 0 cli))
|
||||
(local gk1 (lookup:uw --group-key opts))
|
||||
(local gk2 (lookup:uw -g opts))
|
||||
(local gk (car (filter [fn x . [not [nil? x]]] `[,gk1 ,gk2])))
|
||||
(local fname (head (nth 1 cli)))
|
||||
(local optdef
|
||||
`( [-g 1 GROUPKEY]
|
||||
[--group-key 1 GROUPKEY] ))
|
||||
|
||||
(local kwa `[ ,(if gk [list :gk gk] '() )
|
||||
]
|
||||
)
|
||||
(local split (cli:split optdef ...))
|
||||
(local opts (nth 0 split))
|
||||
(local args (nth 1 split))
|
||||
|
||||
[local r
|
||||
(local gk (@? GROUPKEY opts))
|
||||
(local fname (head args))
|
||||
|
||||
(local kwa `[ ,(if gk [list :gk gk] '() ) ])
|
||||
|
||||
; (display kwa)
|
||||
|
||||
(display
|
||||
(if fname
|
||||
(hbs2:tree:metadata:file kwa fname)
|
||||
(hbs2:tree:metadata:stdin kwa))]
|
||||
|
||||
(display r)
|
||||
|
||||
(hbs2:tree:metadata:file kwa fname)
|
||||
(hbs2:tree:metadata:stdin kwa)))
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
|
||||
( (list? [sym? cat] ...)
|
||||
(begin
|
||||
(println "FUCKING CAT" space ...))
|
||||
|
||||
)
|
||||
|
||||
( (list? [sym? keyring] [sym? new] ...)
|
||||
(begin
|
||||
|
||||
(local optdef `( [-n 1 NUM]
|
||||
[--number 1 NUM]
|
||||
))
|
||||
|
||||
(local opts (nth 0 (cli:split optdef ...)))
|
||||
; (println opts)
|
||||
(print (hbs2:keyring:new (@? NUM opts)))
|
||||
)
|
||||
)
|
||||
|
||||
( _ (--help) )
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -248,17 +248,27 @@ file-name: "qqq.txt"
|
|||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
groupKeyFromSyntax :: Syntax c -> Maybe HashRef
|
||||
groupKeyFromSyntax :: Syntax c -> Either (Syntax c) (Maybe HashRef)
|
||||
groupKeyFromSyntax = \case
|
||||
ListVal es -> headMay [ v | ListVal [ TextLike "gk", HashLike v ] <- es ]
|
||||
_ -> Nothing
|
||||
ListVal es -> do
|
||||
let mbGk = headMay [ z | z@(ListVal [ TextLike "gk", v ]) <- es ]
|
||||
|
||||
case mbGk of
|
||||
Just (ListVal [ TextLike "gk", HashLike v]) -> Right (Just v)
|
||||
Just w@(ListVal [ TextLike "gk", v]) -> Left w
|
||||
_ -> Right Nothing
|
||||
|
||||
_ -> Right Nothing
|
||||
|
||||
loadGroupKeyFromSyntax :: ( ForMetadata c m )
|
||||
=> Syntax c
|
||||
-> RunM c m (Maybe (GroupKey 'Symm 'HBS2Basic))
|
||||
|
||||
loadGroupKeyFromSyntax syn = runMaybeT do
|
||||
hash <- groupKeyFromSyntax syn & toMPlus
|
||||
hash <- case groupKeyFromSyntax syn of
|
||||
Right w -> toMPlus w
|
||||
Left e -> throwIO (BadFormException e)
|
||||
|
||||
toMPlus =<< lift (loadGroupKey hash)
|
||||
|
||||
metadataFromSyntax :: Syntax c -> HashMap Text Text
|
||||
|
|
@ -278,8 +288,11 @@ doCreateMetadataTree meta0 syn getLbs = do
|
|||
|
||||
gk <- loadGroupKeyFromSyntax syn
|
||||
|
||||
when (isJust gkh && isNothing gk) do
|
||||
throwIO (GroupKeyNotFound 1)
|
||||
-- notice $ "GK" <+> pretty (isRight gkh) <+> pretty gk
|
||||
|
||||
case (gkh, gk) of
|
||||
(Right (Just _), Nothing) -> throwIO (GroupKeyNotFound 1)
|
||||
_ -> none
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
|
|
|
|||
|
|
@ -1410,6 +1410,8 @@ internalEntries = do
|
|||
[k, ListVal es ] -> pure $ headDef nil [ r | r@(ListVal (w:_)) <- es, k == w ]
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
|
||||
--TODO: integral sum
|
||||
|
||||
entry $ bindMatch "upper" $ \case
|
||||
|
|
@ -1524,6 +1526,8 @@ internalEntries = do
|
|||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
entry $ bindAlias "@?" "lookup:uw"
|
||||
|
||||
entry $ bindMatch "lookup" $ \case
|
||||
[k, ListVal es ] -> do
|
||||
let val = headDef nil [ mkList rest | ListVal (w:rest) <- es, k == w ]
|
||||
|
|
@ -2155,8 +2159,15 @@ internalEntries = do
|
|||
|
||||
opts <- Map.fromList <$> S.toList_ do
|
||||
for_ p $ \case
|
||||
StringLike x -> S.yield (x, 0)
|
||||
ListVal [StringLike x, LitIntVal n] -> S.yield (x, n)
|
||||
StringLike x ->
|
||||
S.yield (x, (0, mkSym x))
|
||||
|
||||
ListVal [StringLike x, LitIntVal n] ->
|
||||
S.yield (x, (n, mkSym @c x))
|
||||
|
||||
ListVal [StringLike x, LitIntVal n, StringLike alias] ->
|
||||
S.yield (x, (n, mkSym @c alias))
|
||||
|
||||
_ -> pure ()
|
||||
|
||||
-- error $ show opts
|
||||
|
|
@ -2166,12 +2177,12 @@ internalEntries = do
|
|||
|
||||
( w@(StringLike piece) : rest ) -> do
|
||||
case Map.lookup piece opts of
|
||||
Nothing -> S.yield (Right w) >> go rest
|
||||
Just 0 -> S.yield (Left (nil @c)) >> go rest
|
||||
Just 1 -> S.yield (Left (mkList [w, headDef nil rest])) >> go (drop 1 rest)
|
||||
Just n' -> do
|
||||
Nothing -> S.yield (Right w) >> go rest
|
||||
Just (0,s) -> S.yield (Left (mkList [s, mkBool True])) >> go rest
|
||||
Just (1,s) -> S.yield (Left (mkList [s, headDef nil rest])) >> go (drop 1 rest)
|
||||
Just (n',s) -> do
|
||||
let n = fromIntegral n'
|
||||
S.yield (Left (mkList [w, mkList (take n rest)]))
|
||||
S.yield (Left (mkList [s, mkList (take n rest)]))
|
||||
go (drop n rest)
|
||||
|
||||
( w : rest ) -> do
|
||||
|
|
|
|||
Loading…
Reference in New Issue