Commit 8aa00f69 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Modify the 'show' command to handle expressions in addition to symbols with the '(EXPR)' syntax

parent 91a9d8a0
......@@ -3,7 +3,7 @@ module Curly.Core.Documentation(
-- * The Documentation format
DocNode(..),Documentation,Documented(..),
docNodeAttrs,docNodeSubs,
docTag,docTag',nodoc,mkDoc,docAtom,docLine,
docTag,docTag',nodoc,mkDoc,showRawDoc,docAtom,docLine,
DocParams,DocPatterns,
evalDoc,evalDocWithPatterns,
-- * Rendering documentation
......@@ -146,6 +146,14 @@ docAtom = tag <+? txt
docLine :: (ParseToken c, ParseStream c s, TokenPayload c ~ Char, Monad m)
=> String -> [(String,String)] -> ParserT s m Documentation
docLine n as = Join . DocTag n as <$> many1' (skipMany' (oneOf " \t") >> docAtom)
showRawDoc :: Documentation -> String
showRawDoc x = case x of
Join (DocTag t as xs) -> "{" + foldMap quoteChar t + foldMap showAttr as + foldMap showSub xs + "}"
Pure s -> foldMap quoteChar s
where quoteChar ' ' = "\\ "
quoteChar c = [c]
showAttr (x,v) = ":" + foldMap quoteChar x + "=" + foldMap quoteChar v
showSub x = " "+showRawDoc x
data ShowState = BeginP | InP | EndP Bool
data TagDisplay = Inline | Block Bool
......
......@@ -4,7 +4,7 @@
#endif
module Curly.Core.Parser (
-- * Expressions and operators
OpMap,OpChar(..),OpParser,Warning(..),CurlyParserException(..),showWarning,l'library,
OpMap,OpChar(..),OpParser,withParsedString,Warning(..),CurlyParserException(..),showWarning,l'library,
Spaces(..),parseCurly,currentPos,spc,nbsp,
expr,accessorExpr,tom,atom,
......@@ -97,6 +97,13 @@ parseNBSpaces :: (Monad m,ParseStream c s, TokenPayload c ~ Char) => Spaces -> P
parseNBSpaces HorizSpaces = nbhsp
parseNBSpaces AnySpaces = nbsp
withParsedString :: Monad m => OpParser m a -> OpParser m (String,a)
withParsedString ma = do
h <- runStreamState (id <~ \(OpStream h l) -> (OpStream [] l,h))
a <- ma
h' <- runStreamState (id <~ \(OpStream h' l) -> (OpStream (h'+h) l,reverse h'))
return (h',a)
instance Lens1 a a (Cofree f a) (Cofree f a) where
l'1 k (Step x f) = k x <&> \x' -> Step x' f
instance Lens2 (f (Cofree f a)) (f (Cofree f a)) (Cofree f a) (Cofree f a) where
......
#!/bin/sh
# echo "proto/https $@" >&2
case "$1" in
get) suf="${3#??}"; curl -s "https://$2/${3%$suf}/$suf.blob";;
esac
......@@ -65,6 +65,12 @@ t'IOTgt :: Traversal' TargetType (IO ())
t'IOTgt k (IOTgt m) = IOTgt<$>k m
t'IOTgt _ x = return x
forkValue :: IO a -> IO a
forkValue ma = do
v <- newEmptyMVar
forkIO $ ma >>= putMVar v
return (takeMVar v^.thunk)
initCurly = do
setLocaleEncoding utf8
getDataFileName "proto/vc" >>= \p -> modifyIORef vcsProtoRoots (p:)
......@@ -94,8 +100,8 @@ initCurly = do
ks <- getKeyStore
now <- currentTime
branches <- map fold $ for (ks^.ascList) $ \(l,(_,pub,_,_,_)) -> do
map (first (pub,)) . by ascList <$> getBranches pub
map ((now+15,) . by ascList . concat) $ for branches $ \((pub,b),h) -> getAll =<< deepBranch' (Just h)
map (first (pub,)) . by ascList <$> forkValue (getBranches pub)
map ((now+15,) . by ascList . concat) $ for branches $ \((pub,b),h) -> forkValue (getAll =<< deepBranch' (Just h))
getL _ lid = fromMaybe zero <$> vcbLoad conn (LibraryKey lid)
runAtomic repositories (modify (touch (CustomRepo "curly-vc://" getLs getL)))
......@@ -260,6 +266,7 @@ runTarget (Translate f sys path) = ioTgt $ do
modifyPermissions f (_sysProgPerms sys)
_ -> putStrLn $ "Error: the path "+show path+" doesn't seem to point to a function in the default context"
runTarget (DumpDataFile "builtins.cyl") = ioTgt $ writeHBytes stdout (builtinsLib^.flBytes)
runTarget (DumpDataFile f) = ioTgt $ do
fn <- getDataFileName f
readBytes fn >>= writeHBytes stdout
......
......@@ -55,29 +55,43 @@ editCmd = viewCmd editDoc zero onPath $ \path (by leafPos -> r) -> case r of
showDoc = "{section {title Formatted Query} {p {em Usage:} show PATH PATTERN} {p Show the function at PATH according to the given pattern}}"
showCmd = withDoc showDoc . fill False $ do
path <- (nbhspace >> ((several "{}" >> getSession wd) <+? absPath ""))
<+? getSession wd
epath <- map Right (nbhspace >> between (single '(') (single ')') (withParsedString (expr AnySpaces)))
<+? map Left ((nbhspace >> ((several "{}" >> getSession wd) <+? absPath ""))
<+? (lookingAt (hspace >> eol) >> getSession wd))
pat <- option' (docTag' "call" [Pure "default"])
(nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "call" . pure . Pure) dirArg))
withMountain $ let ctx = fold $ c'list $ localContext^??atMs path in withPatterns $ do
let params (n,v) = let Join p = composing (uncurry insert) [
(["type"],Pure $ document (exprType (v^.leafVal))),
(["name"],Pure $ Pure $ identName n),
(["doc"],Pure $ v^.leafDoc),
(["impl"],Pure $ Pure $ showImpl (v^.leafVal)),
(["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
] zero
in p
l'void :: Lens Void Void a a
l'void = lens (\_ -> undefined :: Void) (\x _ -> x)
applyFilter (Pure v) = case evalDocWithPatterns ?patterns (params v) pat of
Just d -> Pure d
Nothing -> Join (ModDir [])
applyFilter (Join (ModDir l)) = Join (ModDir (select
(has (l'2.(t'Pure.l'void .+ t'Join.i'ModDir.traverse.l'void)))
(map2 applyFilter l)))
withStyle $ serveStrLn (docString ?terminal ?style (document (applyFilter ctx)))
withMountain $ withPatterns $ withStyle $ case epath of
Left path -> let ctx = fold $ c'list $ localContext^??atMs path in do
let params (n,v) = let Join p = composing (uncurry insert) [
(["flavor"],Pure $ Pure "Symbol"),
(["type"],Pure $ document (exprType (v^.leafVal))),
(["name"],Pure $ Pure $ identName n),
(["doc"],Pure $ v^.leafDoc),
(["impl"],Pure $ Pure $ showImpl (v^.leafVal)),
(["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
] zero
in p
l'void :: Lens Void Void a a
l'void = lens (\_ -> undefined :: Void) (\x _ -> x)
applyFilter (Pure v) = case evalDocWithPatterns ?patterns (params v) pat of
Just d -> Pure d
Nothing -> Join (ModDir [])
applyFilter (Join (ModDir l)) = Join (ModDir (select
(has (l'2.(t'Pure.l'void .+ t'Join.i'ModDir.traverse.l'void)))
(map2 applyFilter l)))
serveStrLn (docString ?terminal ?style (document (applyFilter ctx)))
Right (n,e) -> do
v <- optExprIn <$> getSession this <*> pure e
let Join params = composing (uncurry insert) [
(["flavor"],Pure $ Pure "Expression"),
(["name"],Pure $ Pure n),
(["type"],Pure $ document (exprType v)),
(["impl"],Pure $ Pure $ showImpl v),
(["strictness"],Pure $ document (snd $ exprStrictness v))
] zero
serveStrLn (docString ?terminal ?style (fromMaybe (nodoc $ "Cannot show pattern "+showRawDoc pat)
(evalDocWithPatterns ?patterns params pat)))
patternCmd = withDoc "{section {title Define Formatting Patterns} {p {em Usage:} pattern PATH = PATTERN} {p Defines a new query pattern accessible with \\{pattern PATH\\}}}" . fill False $ do
ph:pt <- many1' (nbhspace >> dirArg <*= guard . (/="="))
between nbhspace nbhspace (several "=")
......
......@@ -23,6 +23,7 @@ import Curly.Core.Library
import Curly.Core.Parser
import Curly.Core.Security
import Curly.Core.Annotated
import Curly.Core.Documentation
import Curly.UI.Options
import Data.IORef
import Data.List (sortBy)
......@@ -199,7 +200,15 @@ parseCurlyArgs args = fromMaybe [] $ matches Just (tokenize (map2 Right curlyOpt
naked ('+':s) = Right [Flag s]
naked ('@':s) = Right [Target (SetServer (readServer s))]
naked (':':s) = Right [Target (SetInstance s)]
naked s = Left s
naked s = case matches Just url s of
Just t -> Right t
_ -> Left s
url = do
proto <- many1' (noneOf ":")
path <- single ':' >> remaining
let lid = packageID (docTag' "=" [docTag' "$" [Pure "name"],Pure path])^.thunk
(pure proto >*> (like "package" >> eoi)) >> return [Mount [path] (Library lid)]
type CurlyConfig = [(Maybe String,CurlyOpt)]
......
......@@ -11,7 +11,7 @@ module Curly.UI.Options (
TargetParams,confServer,confPrelude,confBanner,confInstance,confThreads,defaultConf,getConf,withPrelude,
-- * Misc
curlyOpts,inputSource,curlyFileName,noCurlySuf,visible,symPath,showSymPath
curlyOpts,packageID,inputSource,curlyFileName,noCurlySuf,visible,symPath,showSymPath
) where
import Definitive
......@@ -257,17 +257,21 @@ inputSource base = do
m <- option' (n+".cache") (sep >> visible "")
return (Resource (base</>n) (base</>m))
search = like "package" >> sep >> do
let tag x l = Join (DocTag x [] l)
tpl <- (docAtom <*= guard . has t'Join)
<+? (visible "" <&> \x -> tag "=" [tag "$" [Pure "name"],Pure x])
let sid = availableLibs
<&> \ls -> fromMaybe (error $ format "Could not find package matching %s" (pretty tpl))
$ find (\(_,d) -> nonempty (showDummyTemplate d tpl)) ls <&> fst
return (Library $ sid^.thunk)
<+? (visible "" <&> \x -> docTag' "=" [docTag' "$" [Pure "name"],Pure x])
return (Library $ packageID tpl^.thunk)
lib = like "library" >> sep >> (fileLib <+? map Library readable)
where fileLib = single '@' >> map LibraryFile (visible "")
blts = Library (builtinsLib^.flID) <$ like "builtins"
packageID :: Template -> IO LibraryID
packageID tpl = do
ls <- availableLibs
case [l | (l,d) <- ls
, nonempty (showDummyTemplate d tpl)] of
[l] -> return l
_ -> error $ format "Could not find package matching %s" (showRawDoc tpl)
data CurlyPlex = CurlyPlex {
_mounts :: [([String],InputSource)],
_targets :: [Target],
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment