Commit f9b0c5bf authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Update the format language to allow for rudimentary predicates, thus extending...

Update the format language to allow for rudimentary predicates, thus extending the 'show' function with query semantics
parent 915ea886
......@@ -4,7 +4,7 @@ module Curly.Core.Documentation(
DocNode(..),Documentation,Documented(..),
docNodeAttrs,docNodeSubs,
docTag,docTag',nodoc,mkDoc,docAtom,docLine,
DocParams,
DocParams,DocPatterns,
evalDoc,evalDocWithPatterns,
-- * Rendering documentation
-- ** Styles
......@@ -45,20 +45,65 @@ instance Documented Int where
document n = docTag' "int" [Pure (show n)]
type DocParams = Forest (Map String) Documentation
evalDocWithPatterns :: DocParams -> DocParams -> Documentation -> Maybe Documentation
evalDocWithPatterns pats vars = eval
where eval (Pure x) = return (Pure x)
eval (Join (DocTag "$" [] xs)) = do
xs' <- traverse eval xs
path <- for xs' $ \x -> x^?t'Pure
Join vars^?at path.t'Just.t'Pure
eval (Join (DocTag "pattern" [] xs)) = do
xs' <- traverse eval xs
path <- for xs' $ \x -> x^?t'Pure
pat <- Join pats^?at path.t'Just.t'Pure
eval pat
eval (Join (DocTag "or" [] xs)) = foldMap eval xs
eval (Join (DocTag t as xs)) = Join . DocTag t as <$> traverse eval xs
type DocPatterns = Map String ([String],Documentation)
evalDocWithPatterns :: DocPatterns -> DocParams -> Documentation -> Maybe Documentation
evalDocWithPatterns pats vars = eval vars
where eval vars = eval'
where
eval' (Pure x) = return (Pure x)
eval' (Join (DocTag "$" [] xs)) = do
xs' <- traverse eval' xs
path <- for xs' $ \x -> x^?t'Pure
Join vars^?at path.t'Just.t'Pure
eval' (Join (DocTag "or" [] xs)) = foldMap eval' xs
eval' (Join (DocTag "when" [] [x,y])) = eval' x >> eval' y
eval' (Join (DocTag "unless" [] [x,y])) = maybe (Just ()) (const Nothing) (eval' x) >> eval' y
eval' (Join (DocTag op [] [ea,eb]))
| op`elem`["<",">","<=",">="] = do
let valList = many' (map Left number <+? map Right (many1' (satisfy (not . inRange '0' '9'))))
liftOp cmp x@(Pure a) (Pure b) = x <$ do
[a',b'] <- traverse (matches Just valList) [a,b]
guard (cmp a' b')
liftOp cmp x@(Join (DocTag a _ xs)) (Join (DocTag b _ ys)) = x <$ do
guard (a==b)
sequence_ (zipWith (liftOp cmp) xs ys)
liftOp _ _ _ = Nothing
toCmp "<" = (<)
toCmp ">" = (>)
toCmp "<=" = (<=)
toCmp ">=" = (>=)
toCmp _ = undefined
join $ liftA2 (liftOp (toCmp op)) (eval' ea) (eval' eb)
| op=="=" = do
let cmp (Pure a) (Pure b) = Pure a <$ matches Just (wildcards b) a
cmp (Join (DocTag a _ xs)) (Join (DocTag b _ ys)) = do
guard (a==b)
zs <- sequence (zipWith cmp xs ys)
return (Join $ DocTag a [] zs)
cmp _ _ = Nothing
join $ liftA2 cmp (eval' ea) (eval' eb)
eval' x@(Join (DocTag "call" _ xs@(_:_))) = do
p:args <- traverse eval' xs
p <- p^?t'Pure
(pargs,pat) <- pats^.at p
callTag args pargs pat
eval' (Join (DocTag t as xs)) = do
xs' <- traverse eval' xs
case pats^.at t of
Just (pargs,pat) -> callTag xs' pargs pat
Nothing -> return (Join $ DocTag t as xs')
callTag args pargs pat = do
let vars' = compose (zipWith (\n v -> insert n (Pure v)) pargs args) vars
eval vars' pat
wildcards "*" = unit
wildcards ('*':'*':t) = wildcards ('*':t)
wildcards ('*':t@(c:_)) = do
skipMany1' (satisfy (/=c))`sepBy`many1' (single c)
wildcards t
wildcards (c:t) = single c >> wildcards t
wildcards [] = eoi
evalDoc :: DocParams -> Documentation -> Maybe Documentation
evalDoc = evalDocWithPatterns zero
......
......@@ -2,7 +2,7 @@
module Curly.Core.Library(
-- * Modules
-- ** Nodes
ModDir(..),Module,Mountain,Context,context,localContext,
ModDir(..),i'ModDir,Module,Mountain,Context,context,localContext,
atM,atMs,fromPList,
-- ** Leaves
ModLeaf,SourcePos,SourceRange(..),
......@@ -59,6 +59,8 @@ instance Format a => Format (Chunked a) where
newtype ModDir s a = ModDir [(s,a)]
deriving (Semigroup,Monoid,Show)
i'ModDir :: Iso [(s,a)] [(s',a')] (ModDir s a) (ModDir s' a')
i'ModDir = iso (\(ModDir m) -> m) ModDir
type Module a = Free (ModDir String) a
instance Documented a => Documented (Module a) where
document (Join (ModDir l)) = docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l)
......
......@@ -17,23 +17,25 @@ cabal-version: >=1.10
data-dir: data
data-files:
kate/highlight-curly.xml
emacs/curly-mode.el
emacs/curly-conf-mode.el
mime/curly.xml
applications/curly-context.desktop
applications/curly-library.desktop
applications/curly-source.desktop
applications/curly-uri.desktop
bash/completions/curly
bash/completions/defcomp.curly-script.shf
bash/completions/curly.script.shf
bash/completions/curly.arg.shf
bash/completions/cyfile
bash/completions/curly.script.shf
bash/completions/curly.sh
applications/curly-uri.desktop
applications/curly-source.desktop
applications/curly-library.desktop
applications/curly-context.desktop
bash/completions/cyfile
bash/completions/defcomp.curly-script.shf
emacs/curly-conf-mode.el
emacs/curly-mode.el
install.sh
kate/highlight-curly.xml
list
make/curly.mk
mime/curly.xml
proto/vc/http
proto/vc/https
make/curly.mk
library
default-language: Haskell2010
......
......@@ -260,8 +260,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 Nothing) = ioTgt $ traverse_ putStrLn dataFiles
runTarget (DumpDataFile (Just f)) = ioTgt $ do
runTarget (DumpDataFile f) = ioTgt $ do
fn <- getDataFileName f
readBytes fn >>= writeHBytes stdout
runTarget (SetServer _) = ioTgt unit
......@@ -280,21 +279,3 @@ nextParams (AddBanner b) = confBanner %~ (+b+"\n")
nextParams (SetInstance i) = confInstance %- i
nextParams _ = id
dataFiles = [
"proto/vc/http","proto/vc/https",
"kate/highlight-curly.xml",
"emacs/curly-mode.el",
"emacs/curly-conf-mode.el",
"mime/curly.xml",
"bash/completions/curly",
"bash/completions/defcomp.curly-script.shf",
"bash/completions/curly.script.shf",
"bash/completions/curly.arg.shf",
"bash/completions/cyfile",
"bash/completions/curly.sh",
"applications/curly-uri.desktop",
"applications/curly-source.desktop",
"applications/curly-library.desktop",
"applications/curly-context.desktop",
"make/curly.mk"
]
......@@ -187,7 +187,7 @@ localServer hasLocalClient thr acc conn@(Connection clt srv) = do
["key","del","server",k] -> completeKeyName k
("key":_) -> []
["show",p] -> completeAbsPath w False p
["show",_,k] -> completeWord [p | (p,Pure _) <- pats^.ascList] k
["show",_,k] -> completeWord (keys pats) k
["vcs",c] -> completeWord ["list","get","commit","checkout","branch"] c
["vcs","list",k] -> completeKeyName k
["vcs","list",k,b] -> completeBranchName k b
......@@ -204,6 +204,7 @@ localServer hasLocalClient thr acc conn@(Connection clt srv) = do
("repository":_) -> []
["compareTypes",x] -> completeWord ["shape","constraints"] x
["cd",p] -> completeAbsPath w True p
["ls",p] -> completeAbsPath w True p
("import":t) -> completeAbsPath [] False (last t)
(_:t) -> completeAbsPath w False (last t)
return True
......
......@@ -55,7 +55,7 @@ editSource f (l,c) m = readBytes f >>= ?edit ".cy" (l,c) >>= maybe unit (\b -> w
data SessionState = SessionState {
_wd :: [String],
_style :: Style,
_patterns :: DocParams,
_patterns :: DocPatterns,
_this :: Library,
_warnings :: (Maybe String,[Warning])
}
......@@ -67,7 +67,7 @@ style :: Lens' SessionState Style
style = lens _style (\x y -> x { _style = y })
warnings :: Lens' SessionState (Maybe String,[Warning])
warnings = lens _warnings (\x y -> x { _warnings = y })
patterns :: Lens' SessionState DocParams
patterns :: Lens' SessionState DocPatterns
patterns = lens _patterns (\x y -> x { _patterns = y })
withSessionState :: (?curlyPlex :: CurlyPlex, MonadIO m) => ((?sessionState :: IORef SessionState) => m a) -> m a
......@@ -89,7 +89,7 @@ withSessionLib ma = do
withStyle :: (?sessionState :: IORef SessionState,MonadIO m) => ((?style :: Style) => m a) -> m a
withStyle m = getSession style >>= \s -> let ?style = s in m
withPatterns :: (?sessionState :: IORef SessionState,MonadIO m) => ((?patterns :: DocParams) => m a) -> m a
withPatterns :: (?sessionState :: IORef SessionState,MonadIO m) => ((?patterns :: DocPatterns) => m a) -> m a
withPatterns m = getSession patterns >>= \ps -> let ?patterns = ps in m
getSession :: (?sessionState :: IORef SessionState,MonadIO m) => Lens' SessionState a -> m a
getSession l = liftIO (readIORef ?sessionState <&> by l)
......
......@@ -57,9 +57,9 @@ showDoc = "{section {title Formatted Query} {p {em Usage:} show PATH PATTERN} {p
showCmd = withDoc showDoc . fill False $ do
path <- (nbhspace >> ((several "{}" >> getSession wd) <+? absPath ""))
<+? getSession wd
pat <- option' (docTag' "pattern" [Pure "default"])
(nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "pattern" . pure . Pure) dirArg))
withMountain $ let ctx = fold $ c'list $ localContext^??atMs path in do
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),
......@@ -68,10 +68,18 @@ showCmd = withDoc showDoc . fill False $ do
(["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
] zero
in p
withStyle $ withPatterns $ serveStrLn (docString ?terminal ?style (document (map (\v -> fromMaybe (nodoc (format "Unmatched pattern %s" (show pat))) (evalDocWithPatterns ?patterns (params v) pat)) ctx)))
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)))
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 "=")
pat <- docLine "pat" []
liftIO $ runAtomic ?sessionState (patterns.at ph.l'Just (Join zero).at pt =- Just (Pure pat))
liftIO $ runAtomic ?sessionState (patterns.at ph =- Just (pt,pat))
......@@ -117,19 +117,19 @@ vcsCmd = withDoc vcsDoc $ False <$ do
lid <- expected "library ID" (nbhspace >> libID)
ls <- checkout pref lid
liftIO $ do
writeString (root+name+".cyx") $ unlines [
writeString (root+".curly") $ unlines [
"#!/usr/bin/env curly",
intercalate "\n" [format "mount deps %s%s = %s"
(show l) (foldMap (" "+) suf)
intercalate "\n" [format "mount deps.%s%s = %s"
(show l) (foldMap ("."+) suf)
$ c'string $ case x of
Just pref -> format "source[deps %s] %s.cy"
Just pref -> format "source[deps.%s] %s.cy"
(show l') (drop (length root) pref+foldMap ("/"+) suf)
Nothing -> format "library %s" (show l')
| (l,suf,l',x) <- ls],
format "mount root = source[deps %s] %s.cy" (show lid) name,
format "mount root = source[deps.%s] %s.cy" (show lid) name,
"+default - interactive"
]
modifyPermissions (pref+".cyx") (set (each.executePerm) True)
modifyPermissions (root+".curly") (set (each.executePerm) True)
"branch" -> do
guardWarn "Cannot modify a branch without almighty access" (?access >= Almighty)
......
......@@ -71,7 +71,7 @@ data Target = Help | Version
| Server ServerType
| ListServer ServerType (Maybe Template)
| ShowLib FilePath
| DumpDataFile (Maybe FilePath)
| DumpDataFile FilePath
| SetPrelude String
| AddPrelude String
| SetBanner String
......@@ -99,7 +99,7 @@ instance Show Target where
show (SetInstance i) = "instance "+i
show (Echo _ s) = "echo "+s
show (Translate f s p) = format "translate %s @ %s = %s" f (show s) (intercalate " " p)
show (DumpDataFile f) = "dump-data-file "+fromMaybe "" f
show (DumpDataFile f) = "dump-data-file "+f
instance FormatArg Target where argClass _ = 'T'
t'Help :: Traversal' Target ()
......@@ -177,7 +177,7 @@ curlyOpts = [
sepOpt "Files",
Option ['t'] ["translate"] (ReqArg (target . mkTranslate) "FILE[@SYS][=PATH]") "Translates a Curly function for a system",
Option ['d'] ["dump"] (ReqArg (target . ShowLib) "FILE") "Shows the contents of the given source or library file",
Option [] ["dump-data-file"] (OptArg (target . DumpDataFile) "FILE") "Dumps the contents of an installed data file. Without arguments, lists the files that can be dumped."
Option [] ["dump-data-file"] (ReqArg (target . DumpDataFile) "FILE") "Dumps the contents of an installed data file. The 'list' files contains all available names"
]
where tryParse err p s = fromMaybe (error (err s)) (matches Just p s)
mkMount = tryParse (format "Couldn't parse mount option '%s'") (inputSource "." <&> pure . uncurry Mount)
......
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