Commit 471fe179 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Unify syntactic conventions for module names on the command-line, in...

Unify syntactic conventions for module names on the command-line, in interactive sessions, and in source files
parent 07b86c82
......@@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: curly-core
version: 0.4.2
version: 0.5
-- synopsis:
-- description:
license: MIT
......@@ -42,6 +42,6 @@ library
DeriveGeneric
AllowAmbiguousTypes
other-extensions: UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns, TypeFamilies, CPP, RecursiveDo, GADTs, DeriveGeneric, OverloadedStrings, NoMonomorphismRestriction, DeriveDataTypeable, ExistentialQuantification, BangPatterns
build-depends: AES >=0.2 && <0.3,base >=4.9 && <4.10,base64-bytestring >=1.0 && <1.1,containers >=0.5 && <0.6,cryptohash >=0.11 && <0.12,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5,directory >=1.3 && <1.4,entropy >=0.3 && <0.4,hinotify >=0.3 && <0.4,network >=2.6 && <2.7,process >=1.4 && <1.5,zlib >=0.6 && <0.7
build-depends: AES >=0.2 && <0.3,base >=4.9 && <4.10,base64-bytestring >=1.0 && <1.1,containers >=0.5 && <0.6,cryptohash >=0.11 && <0.12,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.5 && <2.6,directory >=1.3 && <1.4,entropy >=0.3 && <0.4,hinotify >=0.3 && <0.4,network >=2.6 && <2.7,process >=1.4 && <1.5,zlib >=0.6 && <0.7
hs-source-dirs: src
default-language: Haskell2010
......@@ -5,7 +5,7 @@
module Curly.Core.Parser (
-- * Expressions and operators
OpMap,OpChar(..),OpParser,Warning(..),CurlyParserException(..),showWarning,l'library,
Spaces,parseCurly,currentPos,hspace,space,spc,hspc,nbsp,nbhsp,
Spaces(..),parseCurly,currentPos,spc,nbsp,
expr,accessorExpr,tom,atom,
-- * Basic blocks for warning generation
......@@ -21,7 +21,7 @@ import Curly.Core.Documentation
import Curly.Core.Library
import IO.Filesystem
import Data.Char (isAlpha)
import Language.Format hiding (space)
import Language.Format hiding (space,hspace)
import Control.Exception
import Data.Typeable (Typeable)
......@@ -88,7 +88,14 @@ mkStream = OpStream "" . mk ('\0',0,0,0)
type OpMap_Val = ((Int,Bool),String)
type OpMap = Cofree (Map Char) (Maybe OpMap_Val)
type OpParser m = ParserT OpStream (RWST Void [Warning] (Int,OpMap,(Map String (NameExpr GlobalID),Library)) m)
type Spaces = forall s m c. (Monad m,ParseStream c s, TokenPayload c ~ Char) => ParserT s m ()
data Spaces = HorizSpaces | AnySpaces
parseSpaces :: (Monad m,ParseStream c s, TokenPayload c ~ Char) => Spaces -> ParserT s m ()
parseSpaces HorizSpaces = hspc
parseSpaces AnySpaces = spc
parseNBSpaces :: (Monad m,ParseStream c s, TokenPayload c ~ Char) => Spaces -> ParserT s m ()
parseNBSpaces HorizSpaces = nbhsp
parseNBSpaces AnySpaces = nbsp
instance Lens1 a a (Cofree f a) (Cofree f a) where
l'1 k (Step x f) = k x <&> \x' -> Step x' f
......@@ -137,7 +144,8 @@ mkRange p p' = SourceRange Nothing p p'
mkLet (Left (s,v)) = maybe id (flip mkApply) v . mkAbstract s
mkLet (Right t) = \e -> foldl1' mkApply (t+[e])
space, spc, hspc, nbsp, nbhsp, hspace :: Spaces
space, spc, hspc, nbsp, nbhsp, hspace
:: (Monad m,ParseStream c s, TokenPayload c ~ Char) => ParserT s m ()
space = hspace + (eol >> skipMany' ("#" >> skipMany' (satisfy (/='\n')) >> eol))
hspace = void $ oneOf [' ', '\t']
spc = skipMany' space
......@@ -180,7 +188,7 @@ mkSymIn :: Semantic e i (String,Maybe (NameExpr GlobalID)) => Map String (NameEx
mkSymIn m = \n -> mkSymbol (n,lookup n m)
tom, expr, accessorExpr :: Monad m => Spaces -> OpParser m SourceExpr
expr sp = foldl1' mkApply<$>sepBy1' (tom sp) (skipMany1' sp)
expr sp = foldl1' mkApply<$>sepBy1' (tom sp) (parseNBSpaces sp)
accessorExpr sp = expr sp <*= \e -> defAccessors (map fst (toList e))
completing :: Monad m => OpParser Id a -> OpParser m [(String,a)]
......@@ -204,7 +212,7 @@ tom sp = do
pref <- opPref
case opmap^.at '_' of
Just tl -> flip fix pref $ \mkSuf (d,e) ->
(skipMany' _sp >> suffix (liftA2 (&&) p (<=d)) (e:) tl >>= mkSuf)
(parseSpaces _sp >> suffix (liftA2 (&&) p (<=d)) (e:) tl >>= mkSuf)
<+? return (d,e)
_ -> return pref
opPref = (tokParam opmap >>= suffix (>=0) id) <+? map ((maxBound :: Int,) . mkSymbol . Just) atom
......@@ -228,7 +236,7 @@ tom sp = do
tl <- param m '_'
guard (any (maybe False (p . fst . fst)) tl)
let exprSuf tl@(Step _ tlm) | empty tlm = zero
| otherwise = between spc spc (operation space (>=0))
| otherwise = between spc spc (operation AnySpaces (>=0))
>>= \(_,e) -> suffix p (mod . (e:)) tl
case tl :: OpMap of
Step (Just ((d,isR),n)) m' | p d -> do
......@@ -256,15 +264,15 @@ tom sp = do
atom :: Monad m => OpParser m SourceExpr
atom = withPostfix
=<< wrapCurly (expected "lambda-expression" lambda) <+? wrapRound (expr space) <+? (expected "symbol" close)
=<< wrapCurly (expected "lambda-expression" lambda) <+? wrapRound (expr AnySpaces) <+? (expected "symbol" close)
where
close = liftA2 (&) (liftA2 mkSymIn (lift $ getl l'typeMap) name <+? string '"' <+? string '\'')
$ option' id $ wrapRound $ do
sepBy1' (tom space) nbsp <&> \args e -> foldl' mkApply e args
sepBy1' (tom AnySpaces) nbsp <&> \args e -> foldl' mkApply e args
withPostfix s = foldl' (\e n -> mkApply (mkSymbol ('.':n,Nothing)) e) s
<$> many' (single '.' >> many1' letter)
string c = between (single c) (single c) $ mkConcat . g . foldr f ("",[]) <$> many' stringExpr
where stringExpr = map Left (single '$' >> wrapCurly (expr space))
where stringExpr = map Left (single '$' >> wrapCurly (expr AnySpaces))
<+? map Right (single '\\' >> unquote<$>token <+? satisfy (/=c))
unquote 'n' = '\n'
unquote 't' = '\t'
......@@ -282,7 +290,7 @@ atom = withPostfix
old <- lift get
args <- fold <$> sepBy1' lambdaArg nbsp
_ <- floating ":"
e <- expr space
e <- expr AnySpaces
lift (put old)
return $ foldr mkLet e args
......@@ -297,7 +305,7 @@ lambdaArg = letBinding + funPrefix + do
old <- lift get
args <- fold <$> many' (nbsp >> lambdaArg)
_ <- floating (opKeyword "=")
e <- expr space
e <- expr AnySpaces
lift (put old)
register n
return [Left (n,Just (foldr mkLet e args))]
......@@ -306,7 +314,7 @@ lambdaArg = letBinding + funPrefix + do
lift $ l'typeMap =~ insert ctor (typeExpr ctt) . insert dtor (typeExpr dtt)
register ctor ; register dtor
return []
funPrefix = wrapRound $ pure . Right<$>sepBy1' (tom space) nbsp
funPrefix = wrapRound $ pure . Right<$>sepBy1' (tom AnySpaces) nbsp
typeExpr :: Type GlobalID -> NameExpr GlobalID
typeExpr t = mkAbstract (pureIdent "#0") (mkSymbol (pureIdent "#0",Pure (Argument 0))) & from i'NameNode.t'Join.annType %- t
......@@ -331,7 +339,7 @@ curlyFile = do
mods <- ("#!/lib/symbol!#" <+? "symbol") >> swaying (modTree`sepBy'`nbhsp) <* (eol+eoi)
mods' <- traverse resolve mods
pre <- currentPos
e <- floating (expr space)
e <- floating (expr AnySpaces)
post <- currentPos
lift $ l'library =~ compose [
addImport (fold mods'),
......@@ -382,7 +390,7 @@ curlyLine = swaying (foldr1 (<+?) [defLine,descLine,typeLine,classLine,comment,i
args <- fold <$> many' (nbsp >> lambdaArg)
_ <- floating (opKeyword "=")
pre <- currentPos
e <- expr hspace
e <- expr HorizSpaces
post <- currentPos
lift (put old)
register sym
......@@ -449,7 +457,7 @@ defRigidSymbols args = compose [defTypeSym a False NoRange (rigidTypeFun a) expr
typeSum :: Monad m => OpParser m (SourcePos,Library -> Type GlobalID,SourcePos)
typeSum = do
let typeNode = (fill Nothing delim <+? map Just (tom hspace)) >>= maybe zero pure
let typeNode = (fill Nothing delim <+? map Just (tom HorizSpaces)) >>= maybe zero pure
delim = between hspc nbsp ("and"<+?oneOf (c'string "&|"))
pre <- currentPos
exprs <- sepBy1' (foldl1' mkApply <$> sepBy1' typeNode nbhsp) delim
......
......@@ -29,6 +29,6 @@ executable curly-dht
GeneralizedNewtypeDeriving
RankNTypes
other-extensions: DeriveGeneric, TypeFamilies, ScopedTypeVariables, PatternSynonyms, ViewPatterns
build-depends: base >=4.9 && <4.10,curly-core >=0.4 && <0.5,curly-kademlia >=1.1 && <1.2,definitive-base >=2.6 && <2.7,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5
build-depends: base >=4.9 && <4.10,curly-core >=0.5 && <0.6,curly-kademlia >=1.1 && <1.2,definitive-base >=2.6 && <2.7,definitive-network >=1.4 && <1.5,definitive-parser >=2.5 && <2.6
hs-source-dirs: src
default-language: Haskell2010
......@@ -29,6 +29,6 @@ library
GeneralizedNewtypeDeriving
RankNTypes
other-extensions: UndecidableInstances, RecursiveDo, ScopedTypeVariables, NoMonomorphismRestriction, PatternSynonyms, CPP, TypeFamilies, StandaloneDeriving
build-depends: base >=4.9 && <4.10,curly-core >=0.4 && <0.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-parser >=2.4 && <2.5
build-depends: base >=4.9 && <4.10,curly-core >=0.5 && <0.6,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-parser >=2.5 && <2.6
hs-source-dirs: src
default-language: Haskell2010
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: curly
version: 0.56
version: 0.57
-- synopsis:
-- description:
license: MIT
......@@ -33,6 +33,7 @@ data-files:
applications/curly-context.desktop
proto/vc/http
proto/vc/https
make/curly.mk
library
default-language: Haskell2010
......@@ -49,7 +50,7 @@ library
RankNTypes
TypeFamilies
other-extensions: CPP, ExistentialQuantification, ViewPatterns, TypeFamilies, ScopedTypeVariables, RecursiveDo, DeriveGeneric, NoMonomorphismRestriction
build-depends: base >=4.9 && <4.10,cryptohash >=0.11 && <0.12,curly-core >=0.4 && <0.5,curly-system >=0.3 && <0.4,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.4 && <1.5,readline >=1.0 && <1.1,unix >=2.7 && <2.8
build-depends: base >=4.9 && <4.10,cryptohash >=0.11 && <0.12,curly-core >=0.5 && <0.6,curly-system >=0.3 && <0.4,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.5 && <2.6,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.4 && <1.5,readline >=1.0 && <1.1,unix >=2.7 && <2.8
hs-source-dirs: src
executable curly
......@@ -69,4 +70,4 @@ executable curly
GeneralizedNewtypeDeriving
RankNTypes
TypeFamilies
build-depends: base >=4.9 && <4.10,cryptohash >=0.11 && <0.12,curly >=0.56 && <0.57,curly-core >=0.4 && <0.5,curly-system >=0.3 && <0.4,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.4 && <2.5,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.4 && <1.5,readline >=1.0 && <1.1,unix >=2.7 && <2.8
build-depends: base >=4.9 && <4.10,cryptohash >=0.11 && <0.12,curly >=0.57 && <0.58,curly-core >=0.5 && <0.6,curly-system >=0.3 && <0.4,curly-terminfo >=0.4 && <0.5,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.5 && <2.6,directory >=1.3 && <1.4,filepath >=1.4 && <1.5,process >=1.4 && <1.5,readline >=1.0 && <1.1,unix >=2.7 && <2.8
Curly.url := https://coiffiem.gricad-pages.univ-grenoble-alpes.fr/curly/pkg/curly.tar.xz
Curly.flags :=
ifeq ($(OS),Windows_NT)
Curly.platform := Windows
else
Curly.platform := $(shell sh -c 'uname -s 2>/dev/null || echo other')
endif
ifeq ($(THIS_PLATFORM),Windows)
Curly.which := where
else
Curly.which := which
endif
Curly.curly := $(shell $(Curly.which) curly 2>/dev/null)
ifeq ($(Curly.curly),)
$(error "Could not find a 'curly' command anywhere. For Linux platforms, you can try installing it from $(Curly.url)")
endif
.PHONY: Curly.target
Curly.target:
$(Curly.curly) $(Curly.flags)
clean: Curly.flags = %clean
clean: Curly.target
......@@ -291,5 +291,6 @@ dataFiles = [
"applications/curly-uri.desktop",
"applications/curly-source.desktop",
"applications/curly-library.desktop",
"applications/curly-context.desktop"
"applications/curly-context.desktop",
"make/curly.mk"
]
......@@ -136,11 +136,24 @@ localServer hasLocalClient thr acc conn@(Connection clt srv) = do
pats <- getSession patterns
ks <- getKeyStore
clientKeyNames <- unsafeInterleaveIO getClientKeys <&> map (by l'1)
let completePath path = [s' | Join (ModDir n) <- localContext^??atMs (subPath w path)
, (s',_) <- n
, lst`isPrefix`s']
let completePath base onlyDirs p =
case matches Just (liftA2 (\p b -> if b || empty p then p+[""] else p)
(symPath "")
(option' False (True <$ single '.'))) p of
Just path -> let i = init path ; lst = last path
in [showSymPath (i + s'')
| Join (ModDir n) <- localContext^??atMs (subPath base i)
, (s',sub) <- n
, lst`isPrefix`s'
, s'' <- if has t'Join sub
then [[s'],[s',""]]
else if not onlyDirs
then [[s']] else []]
Nothing -> []
completeAbsPath _ ('.':p) = map ('.':) $ completePath [] True p
completeAbsPath b p = completePath b True p
completeWord l s = [s' | s' <- l, s`isPrefix`s']
completeCommand = completeWord commandNames
completeCommand = completeWord (commandNames + ["import","define","type","family"])
completeKeyName = completeWord (keys ks)
completeClientKeyName = completeWord clientKeyNames
completeBranchName k = completeWord brancheNames
......@@ -171,7 +184,7 @@ localServer hasLocalClient thr acc conn@(Connection clt srv) = do
["key","del","server",k] -> completeKeyName k
("key":_) -> []
["format",k] -> completeWord [p | (p,Pure _) <- pats^.ascList] k
("format":_:p) -> completePath (init p)
["format",_,p] -> completePath w False p
["vcs",c] -> completeWord ["list","get","commit","checkout","branch"] c
["vcs","list",k] -> completeKeyName k
["vcs","list",k,b] -> completeBranchName k b
......@@ -181,13 +194,15 @@ localServer hasLocalClient thr acc conn@(Connection clt srv) = do
["vcs","branch",_,c,u] | c`elem`["fork","link"] -> completeKeyName u
["vcs","branch",_,c,u,b] | c`elem`["fork","link"] -> completeBranchName u b
["vcs","commit",b] -> completeBranchName curlyPublisher b
("vcs":"commit":_:p) -> completePath (init p)
["vcs","commit",_,p] -> completePath w False p
("vcs":_) -> []
["configure",p] -> completeWord [show n+":"+s | (n,s) <- curlyFiles ?curlyConfig^.ascList] p
["repository",cmd] -> completeWord ["list","add","contents","browse"] cmd
("repository":_) -> []
["compareTypes",x] -> completeWord ["shape","constraints"] x
(_:t) -> completePath (init t)
["cd",p] -> completeAbsPath w p
("import":t) -> completePath [] False (last t)
(_:t) -> completePath w False (last t)
return True
EndOfTransmission -> return False
BannerRequest b -> True <$ do
......
......@@ -95,9 +95,9 @@ compareTypesCmd = withDoc compareTypesDoc $ False <$ do
nbsp
shapeCmp <- (True <$ several "shape") <+? (False <$ several "constraints")
nbsp
a <- exprT =<< tom space
a <- exprT =<< tom AnySpaces
nbsp
b <- exprT =<< tom hspace
b <- exprT =<< tom HorizSpaces
serveStrLn $ if shapeCmp then show (compare a b) else show (compareConstrainedness a b)
showInstancesDoc = "{section {title Show Instances} Shows all the instances of the current execution context}"
......@@ -116,7 +116,7 @@ subTag t = t'Join.docNodeSubs.traverse.sat (isTag t)
helpDoc = "{section {title Show Help} Show the help for the given function, or all of them.}"
helpCmd = withDoc helpDoc $ False <$ do
args <- many' (nbhsp >> dirArg)
args <- many' (nbhspace >> dirArg)
term <- liftIO setupTermFromEnv
liftIOWarn $ case args of
[] -> withStyle $ do
......@@ -138,7 +138,7 @@ configDoc = unlines [
" {line If many configurations are available, the first one whose name matches the selector is edited.}}}"
]
configCmd = withDoc configDoc $ False <$ do
sel <- option' 0 ((nbhsp >> many1' (noneOf "\n")) >*> number)
sel <- option' 0 ((nbhspace >> many1' (noneOf "\n")) >*> number)
case lookup sel (curlyFiles ?curlyConfig) of
Just file | ?access >= Admin -> liftIOWarn (readBytes file >>= ?edit "" (0,0) >>= maybe unit (writeBytes file))
| otherwise -> serveStrLn "Error: You are not allowed to access the instance configuration"
......@@ -167,13 +167,13 @@ interactiveSession ack = while sessionLine
case ln of
Just _ -> return False
Nothing -> guard (empty ws) >> cmdLine
parseCmd = hspc >> do
e <- optimized =<< accessorExpr hspace
lookingAt (hspc >> eol)
parseCmd = hspace >> do
e <- optimized =<< accessorExpr HorizSpaces
lookingAt (hspace >> eol)
serveHow e
return False
cmdLine = do
s <- remaining
cmd <- hspc >> many1' (satisfy (\c -> not (isSpace c || c=='\'')))
maybe (runStreamState (put s) >> parseCmd) snd (foldMap snd commands^.at cmd) <* hspc <* (eol+eoi)
cmd <- hspace >> many1' (satisfy (\c -> not (isSpace c || c=='\'')))
maybe (runStreamState (put s) >> parseCmd) snd (foldMap snd commands^.at cmd) <* hspace <* (eol+eoi)
......@@ -123,5 +123,8 @@ type Command = (Documentation,OpParser IO Bool)
withDoc d m = (mkDoc d,m)
dirArg :: (MonadParser s m p, ParseStream c s, TokenPayload c ~ Char, Monad m) => p String
dirArg = many1' $ noneOf " \t\n(){}"
dirArgs = sepBy1' dirArg nbhsp
absPath :: (?sessionState :: IORef SessionState, MonadParser s m p, ParseStream c s, TokenPayload c ~ Char, Monad m, MonadIO p)
=> String -> p [String]
absPath lim = liftA2 subPath (getSession wd) (symPath lim)
......@@ -23,7 +23,7 @@ cleanCmd = withDoc cleanDoc $ False <$ liftIO (do sequence_ [clean c | (_,Source
_ -> unit
metaDoc = "{section {title Show Metadata} Show the metadata associated with the given path}"
metaCmd = withDoc metaDoc $ fill False $ withMountain $ do
path <- many' (nbhsp >> dirArg)
path <- many' (nbhspace >> dirArg)
let mod = ?mountain >>= \fl -> mapF (\m -> ModDir (m^.ascList)) (Join (fl^.flLibrary.metadata.iso (\(Metadata m) -> m) Metadata))
serveStrLn $ maybe "" showMetaDir (mod^?atMs path)
......@@ -32,7 +32,7 @@ reloadCmd = withDoc reloadDoc (False <$ reloadMountain)
fixDoc = "{section {title Fix Error} Runs an editing session for fixing the last error.}"
fixCmd = withDoc fixDoc $ False <$ do
i <- option' 1 (nbhsp >> number)
i <- option' 1 (nbhspace >> number)
(s,ws) <- getSession warnings
case (s,drop (i-1) ws) of
(Just s, Warning (l,c) _:_) -> liftIOWarn $ editSource s (l,c) reloadMountain
......
......@@ -28,7 +28,7 @@ keyDoc = unlines [
"}"
]
keyCmd = withDoc keyDoc $ False <$ do
x <- expected "key command" (nbhsp >> dirArg)
x <- expected "key command" (nbhspace >> dirArg)
let setKey name v = do
ks <- getKeyStore
if name`isKeyIn`ks then serveStrLn (format "Error: the key '%s' already exists" name) >> zero
......@@ -55,50 +55,50 @@ keyCmd = withDoc keyDoc $ False <$ do
| (name,(f,_,priv,_,all)) <- m^.ascList]
+[(name,"client ",fp,priv,mlookup fp fpAllowed) | (name,fp,priv) <- kl]
"gen" -> do
isDistant <- option' True (nbhsp >> (False<$several "client" <+? True<$several "server"))
name <- expected "key name" (nbhsp >> dirArg)
isDistant <- option' True (nbhspace >> (False<$several "client" <+? True<$several "server"))
name <- expected "key name" (nbhspace >> dirArg)
if isDistant then
if ?access>=Almighty then genPrivateKey >>= \k -> modifyKeyStore (insert name (let pub = publicKey k in (fingerprint pub,pub,Just k,zero,zero)))
else serveStrLn "Error: you are not authorized to create server keys"
else liftIOWarn $ clientKeyGen True name
"del" -> do
isDistant <- option' True (nbhsp >> (False<$several "client" <+? True<$several "server"))
name <- expected "key name" (nbhsp >> dirArg)
isDistant <- option' True (nbhspace >> (False<$several "client" <+? True<$several "server"))
name <- expected "key name" (nbhspace >> dirArg)
if isDistant then
if ?access>=Almighty then modifyKeyStore (delete name)
else serveStrLn "Error: you are not authorized to delete server keys"
else liftIOWarn $ clientKeyGen False name
"set" -> do
name <- expected "key name" (nbhsp >> dirArg)
ph:pt <- expected "metadata path" (many1' (nbhsp >> dirArg <*= \a -> guard (a/="=")))
expected "keyword '='" (nbhsp >> single '=')
value <- expected "value" (nbhsp >> many1' (noneOf "\n"))
name <- expected "key name" (nbhspace >> dirArg)
ph:pt <- expected "metadata path" (many1' (nbhspace >> dirArg <*= \a -> guard (a/="=")))
expected "keyword '='" (nbhspace >> single '=')
value <- expected "value" (nbhspace >> many1' (noneOf "\n"))
if ?access >= Almighty
then modifyKeyStore $ at name.t'Just.l'4.mat ph %~ insert pt (Pure value)
else serveStrLn "Error: you are not authorized to set key metadata"
"meta" -> do
name <- expected "key name" (nbhsp >> dirArg)
path <- many' (nbhsp >> dirArg)
name <- expected "key name" (nbhspace >> dirArg)
path <- many' (nbhspace >> dirArg)
mm <- getKeyStore <&> \ks -> ks^?at name.t'Just.l'4.getter (\(Metadata m) -> Join m).at path.t'Just
maybe unit (serveStrLn . showMetaDir . mapF (\m -> ModDir (m^.ascList))) mm
"grant" -> do
tp <- expected "access type" (nbhsp >> (dirArg >*> readable))
name <- expected "key name" (nbhsp >> dirArg)
tp <- expected "access type" (nbhspace >> (dirArg >*> readable))
name <- expected "key name" (nbhspace >> dirArg)
if ?access >= Admin && tp <= ?access then do
modifyKeyStore $ at name %~ map (l'5.at (getConf confInstance).sat (\x -> fold x <= ?access)
%- case tp of Deny -> Nothing ; _ -> Just tp)
else serveStrLn "Error: you are not authorized to grant these permissions"
"export" -> do
name <- expected "key name" (nbhsp >> dirArg)
proof <- option' False (nbhsp >> True<$several "proof")
name <- expected "key name" (nbhspace >> dirArg)
proof <- option' False (nbhspace >> True<$several "proof")
v <- lookup name <$> getKeyStore
case v of
Just (_,pub,priv,meta,_) -> serveStrLn (show (Zesty (pub,if proof && ?access >= Almighty then map (,meta) priv else Nothing)))
Nothing -> serveStrLn ("Error: Unknown key '"+name+"'")
"import" -> do
name <- expected "key name" (nbhsp >> dirArg)
name <- expected "key name" (nbhspace >> dirArg)
try (serveStrLn "Error: Invalid key") $ expected "client key name or raw key export" $ do
nbhsp
nbhspace
Zesty (pub,priv) <- (single '#' >> dirArg) >*> readable
<+? Zesty . (,Nothing) <$> do
name' <- dirArg
......
......@@ -6,15 +6,11 @@ import Curly.Core.Library
import Curly.UI
import Curly.Core.Parser
import Data.IORef
import Language.Format hiding (space)
import Language.Format
import Curly.Session.Commands.Common
import Curly.Core.Documentation
import Curly.Style (setupTermFromEnv)
lsPath :: (?sessionState :: IORef SessionState) => OpParser IO [String]
lsPath = do
args <- many' (nbhsp >> dirArg)
getSession wd <&> (`subPath`args)
import Curly.UI.Options (symPath)
lsCmd,wdCmd,cdCmd,treeCmd :: Interactive Command
lsDoc = unlines [
......@@ -23,7 +19,7 @@ lsDoc = unlines [
,"{p List the contents of the working directory, or those of the relative path given on the command-line.}}"
]
lsCmd = withDoc lsDoc $ False <$ do
p <- lsPath
p <- hspace >> absPath ""
withMountain $ serveStrLn $
if has (atMs p.t'Pure) localContext
then "Error: "+showPath p+" is a function"
......@@ -36,7 +32,7 @@ treeDoc = unlines [
,"{p Recursively list the contents of the working directory, or those of the relative path given on the command-line.}}"
]
treeCmd = withDoc treeDoc $ False <$ do
p <- lsPath
p <- hspace >> absPath ""
term <- liftIO setupTermFromEnv
withStyle $ withMountain $ serveStrLn . docString term ?style . document . map fst . Join . fold . c'list $ (localContext^??atMs p.t'Join)
......@@ -49,12 +45,14 @@ cdDoc = unlines [
]
cdCmd = withDoc cdDoc (fill False $ withargs <+? noarg)
where noarg = liftIO (modifyIORef ?sessionState (wd %- []))
withargs = nbhsp >> do
oldpath <- getSession wd
dirs <- dirArgs
inRoot m = do
old <- liftIO $ runAtomic ?sessionState (wd <~ \x -> ([],x))
m <* liftIO (modifyIORef ?sessionState (set wd old))
withargs = nbhspace >> do
isAbs <- option' False (True <$ single '.')
newpath <- (if isAbs then inRoot else id) (absPath "")
withMountain $ do
let newpath = subPath oldpath dirs
m = c'list (localContext^??atMs newpath)
let m = c'list (localContext^??atMs newpath)
liftIOWarn $ if nonempty (fold $ c'list (m^??each.t'Join))
then modifyIORef ?sessionState (wd %- newpath)
else serveStrLn $ if has (each.t'Pure) m
......
......@@ -15,7 +15,7 @@ whereCmd,whyCmd,whenceCmd,whatCmd,howCmd,formatCmd,patternCmd :: Interactive Com
viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
where viewPath = nbsp >> do
path <- liftA2 subPath (getSession wd) dirArgs
path <- absPath ""
withMountain $ case localContext^?atMs path of
Just (Pure (_,v)) -> liftIOWarn $ showV path v
_ -> onPath path
......@@ -59,7 +59,7 @@ serveHow v | envLogLevel>=Verbose = serveStrLn (pretty (map withSym (semantic v)
withSym (s,_) = VerboseVar s Nothing
howCmd = viewCmd howDoc onExpr (const zero) $ \_ (by leafVal -> v) -> serveHow v
where onExpr = do
e <- optimized =<< accessorExpr hspace
e <- optimized =<< accessorExpr HorizSpaces
serveHow e
whatDoc = unlines [
......@@ -70,7 +70,7 @@ whatDoc = unlines [
whatCmd = viewCmd whatDoc onExpr (const zero) $ \_ (by leafVal -> v) -> serveWhat v
where serveWhat v = serveStrLn (show (exprType v))
onExpr = do
e <- optimized =<< accessorExpr hspace
e <- optimized =<< accessorExpr HorizSpaces
serveWhat e
rangeFile :: Traversal' SourceRange String
......@@ -92,9 +92,9 @@ whereCmd = viewCmd whereDoc zero onPath $ \path (by leafPos -> r) -> case r of
formatDoc = "{section {title Formatted Query} {p {em Usage:} format PATTERN PATH} {p Show the function at PATH according to the pattern PAT}}"
formatCmd = withDoc formatDoc . fill False $ do
pat <- nbhsp >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "pattern" . pure . Pure) dirArg)
pat <- nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "pattern" . pure . Pure) dirArg)
path <- liftA2 subPath (getSession wd) (many' (nbhsp >> dirArg))
path <- nbhspace >> absPath ""
withMountain $ let ctx = fold $ c'list $ localContext^??atMs path in do
let params (n,v) = let Join p = composing (uncurry insert) [
(["type"],Pure $ document (exprType (v^.leafVal))),
......@@ -106,7 +106,7 @@ formatCmd = withDoc formatDoc . fill False $ do
withStyle $ withPatterns $ serveStrLn (docString ?terminal ?style (document (map (\v -> fromMaybe (nodoc (format "Unmatched pattern %s" (show pat))) (evalDocWithPatterns ?patterns (params v) pat)) ctx)))
patternCmd = withDoc "{section {title Define Patterns} {p {em Usage:} pattern PATH = PATTERN} {p Defines a new query pattern accessible with \\{pattern PATH\\}}}" . fill False $ do
ph:pt <- many1' (nbhsp >> dirArg <*= guard . (/="="))
between nbhsp nbhsp (several "=")
ph:pt <- many1' (nbhspace >> dirArg <*= guard . (/="="))
between nbhspace nbhspace (several "=")
pat <- docLine "pat" []
liftIO $ runAtomic ?sessionState (patterns.at ph.l'Just (Join zero).at pt =- Just (Pure pat))
......@@ -10,19 +10,27 @@ import Curly.Core.Documentation
import Curly.System
import Language.Format hiding (space)
import Curly.Session.Commands.Common
import Curly.UI
runCmd :: Interactive Command
runDoc = unlines [
"{section {title Run Curly Expression (Experimental)}",
" {p {em Usage:} run EXPRESSION}",
" {p {em Usage:} run EXPRESSION {em OR} run PATH}",
" {p Runs a Curly expression.}}"
]
runCmd = withDoc runDoc $ False <$ do
e <- nbsp >> accessorExpr hspace
l <- getSession this
liftIOWarn $ do
let ex = anonymous (exprIn l e)
logLine Verbose $ "Running expression "+pretty (semantic ex :: Expression GlobalID (Symbol GlobalID))
runIt <- jitExpr (?curlyPlex^.jitContext) ex
runIt
nbsp >> (runExpr <+? runSym)
where runExpr = do
e <- between (single '(') (single ')') (accessorExpr HorizSpaces)