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

Introduce a 'format' command for structured queries

parent a101f7de
ifeq ($(WATCH),true)
STACK_FLAGS += --file-watch
endif
ifeq ($(NOTIFY),true)
STACK_FLAGS += --exec scripts/notify-build-success
endif
build:
stack build $(STACK_FLAGS)
......
......@@ -63,7 +63,7 @@ type ExprStrictness = ([Strictness],Strictness)
data StrictnessHead = StH_B Builtin
| StH_V Int
| StH_Fix String ExprStrictness
deriving (Eq,Ord,Show,Generic)
deriving (Eq,Ord,Generic)
instance Serializable StrictnessHead
instance Format StrictnessHead
......@@ -72,8 +72,8 @@ data Strictness = Delayed String ExprStrictness
deriving (Eq,Ord,Generic)
instance Serializable Strictness
instance Format Strictness
instance Show Strictness where
showsPrec n st t = sh n [] st + t
instance Documented Strictness where
document st = docTag' "strictness" [Pure (sh 0 [] st)]
where sh n env (Delayed s e) = let env' = newVar s env
in par 0 n $ format "\\%s. %s" (head env') (shS 0 env' e)
sh _ env (HNF h []) = shH env h
......
......@@ -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,docAtom,docLine,evalDoc,
-- * Rendering documentation
-- ** Styles
TagStyle(..),TermColor(..),TagDisplay(..),Style,defaultStyle,
......@@ -35,8 +35,8 @@ docTag' t = docTag t []
type Documentation = Free DocNode String
class Documented t where
document :: t -> Documentation
instance Documented Documentation where
document = id
instance Documented a => Documented (Free DocNode a) where
document = join . map document
instance Documented String where
document = Pure
instance Documented Int where
......@@ -137,8 +137,9 @@ defaultStyle = fromAList [
("nodoc",zero & tagColor.l'1 %- Just (ColorNumber 67)),
("section",isBl zero),
("em",isB zero),
("ul",((tagDisplay %- Just (Block True)) . (tagIndent %- Just 2)) zero),
("li",((tagDisplay %- Just (Block False)) . (tagPrefix %- Just "* ")) zero),
("ul",compose [set tagDisplay (Just (Block True)), set tagIndent (Just 2)] zero),
("li",((tagDisplay %- Just (Block False)) . (tagPrefix %- Just "- ")) zero),
("modDir",set tagPrefix (Just "* ") zero),
("ln",set tagDisplay (Just (Block False)) zero),
("sub",set tagIndent (Just 2) zero)
]
......@@ -163,15 +164,17 @@ instance Terminal DummyTerminal where
docString :: Terminal trm => trm -> Style -> Documentation -> String
docString trm stl d = getId ((doc' d^..i'RWST) ((),(BeginP,zero,0))) & \(_,_,t) -> t
where doc' (Join (DocTag t as subs)) = do
where addStyles s s' = (s+s') & set tagPrefix (s'^.tagPrefix + s^.tagPrefix)
doc' (Join (DocTag t as subs)) = do
l'2.l'2 =~ compose [tagDisplay %- Nothing,tagIndent %- Nothing]
pref <- saving l'2 $ saving l'3 $ do
l'2 =~ \(_,s) -> (False,(s + fold [stl^.at c.folded | ("class",c) <- (("class",t):as)]))
l'2 =~ \(_,s) -> (False,(s + foldl' addStyles zero [stl^.at c.folded | ("class",c) <- (("class",t):as)]))
s <- getl (l'2.l'2)
maybe unit (\i -> l'3 =~ (+i)) (s^.tagIndent)
maybe unit (\i -> l'3 =~ maybe id ((+) . length) (s^.tagPrefix) . (+i)) (s^.tagIndent)
maybe unit setDisplay (s^.tagDisplay)
case t of
"nodoc" -> styleStart >> tell "Not documented."
"nodoc" -> doc' (Pure "Not documented.")
_ -> subDoc subs
styleEnd
getl (l'2.l'2.tagPrefix)
......@@ -186,7 +189,8 @@ docString trm stl d = getId ((doc' d^..i'RWST) ((),(BeginP,zero,0))) & \(_,_,t)
InP -> tell " "
_ -> unit
styleStart
tell t
ind <- getl l'3
tell (withIndent ind t)
l'1 =- InP
subDoc docs = traverse_ doc' docs
......@@ -214,9 +218,16 @@ docString trm stl d = getId ((doc' d^..i'RWST) ((),(BeginP,zero,0))) & \(_,_,t)
maybe unit (const (tell $ restoreDefaultColors trm)) (fg+bg)
addPrefix p = tell p >> (l'3 =~ (+ length p))
indent = getl l'1 >>= \st -> case st of
BeginP -> getl l'3 >>= \n -> tell (take n (repeat ' '))
_ -> unit
indent = do
st <- getl l'1
pref <- getl (l'2.l'2.tagPrefix)
case st of
BeginP -> getl l'3 >>= \n -> tell (take (n - maybe 0 length pref) (repeat ' '))
_ -> unit
withIndent n = go
where go "" = ""
go ('\n':t) = '\n' : (take n (repeat ' ') + go t)
go (c:t) = c : go t
bType b st = b || case st of EndP x -> x ; _ -> False
setDisplay (Block b) = getl l'1 >>= \st -> do
......
......@@ -61,13 +61,13 @@ newtype ModDir s a = ModDir [(s,a)]
deriving (Semigroup,Monoid,Show)
type Module a = Free (ModDir String) a
instance Documented a => Documented (Module a) where
document (Join (ModDir l)) = docTag' "ul" (map doc' l)
where doc' (s,Pure n) | s==pretty n = docTag' "li" [Pure s]
| otherwise = docTag' "li" [document n,Pure "as",Pure s]
doc' (s,Join (ModDir l)) = docTag "li" [("class","modDir")]
[docTag' "ln" [Pure (s+":")]
,docTag' "ul" (map doc' l)]
document (Pure s) = docTag' "li" [document s]
document (Join (ModDir l)) = docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l)
where doc' (s,Pure n) | s==pretty n = Pure s
| otherwise = document n
doc' (s,Join (ModDir l)) = docTag' "p"
[docTag "ln" [("class","modName")] [Pure (s+":")]
,docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l)]
document (Pure s) = document s
instance (Serializable s,Serializable a) => Serializable (ModDir s a) where
encode = coerceEncode (ModDir . getChunked)
......@@ -279,7 +279,7 @@ scoped = iso f g
instDeps = c'set $ fromKList [k | (Just k,_) <- toList is]
g (syn,i',s',is',isd,e') = Library syn i s is e
where symVal (GlobalID _ (Just (s,l))) = fromMaybe (error $ "Couldn't find library "+show l) (findLib l)
^.flLibrary.symbols.at s.l'Just undefLeaf
^.flLibrary.symbols.at s.l'Just undefLeaf
symVal (GlobalID i Nothing) = s^.at i.l'Just undefLeaf
fromSym (s,Just sym) = (s,Pure sym)
fromSym (s,Nothing) = (s,Join (symVal s^.leafVal))
......
......@@ -21,6 +21,7 @@ module Curly.Core.Types (
import Definitive
import Curly.Core
import Curly.Core.Documentation
import Language.Format
import qualified Data.Map
import Control.DeepSeq
......@@ -234,6 +235,8 @@ instance Identifier s => Show (Type s) where
subs = interleave ("\n where ":repeat "\n ") $ "":[
format "%s = %s" short long
| (_,(Just short,long)) <- pathList]
instance Identifier s => Documented (Type s) where
document t = docTag' "type" [Pure (show t)]
zipTypes :: (Monad m,Identifier s) => (TypeShape s -> TypeShape s -> m ()) -> Type s -> Type s -> m (Type s)
zipTypes zipNodes (Type ta) (Type tb) =
......
......@@ -15,6 +15,7 @@ import Curly.Core.Peers
import Curly.Core.Security
import Curly.Core.VCS
import Curly.Session.Commands
import Curly.Style
import Curly.UI
import Curly.UI.Options hiding (nbsp,spc)
import Data.IORef
......@@ -110,11 +111,14 @@ runCurlySession thr clt srv = (Connection<$>newChan<*>newChan) >>= \conn -> mdo
FileClient f -> (Almighty,) <$> forkMVar (fileClient f conn)
takeMVar sem
localServer :: (?curlyPlex :: CurlyPlex, ?curlyConfig :: CurlyConfig, ?targetParams :: TargetParams, ?sessionState :: IORef SessionState) => Bool -> (ThreadId -> IO ()) -> Access -> Connection -> IO ()
localServer :: (?curlyPlex :: CurlyPlex, ?curlyConfig :: CurlyConfig, ?targetParams :: TargetParams, ?sessionState :: IORef SessionState)
=> Bool -> (ThreadId -> IO ()) -> Access -> Connection -> IO ()
localServer hasLocalClient thr acc conn@(Connection clt srv) = do
forkIO watchSources
start <- newEmptyMVar
compPlex <- newIORef ?curlyPlex
term <- setupTermFromEnv
let ?terminal = term
let getClientKeys = do
clt <- dupChan (connClient conn)
serve conn KeyListRequest
......
......@@ -61,6 +61,7 @@ commands = [
("how",howCmd),
("what",whatCmd),
("whence",whenceCmd),
("format",formatCmd),
("compareTypes",compareTypesCmd),
("showInstances",showInstancesCmd),
("where",whereCmd)]),
......@@ -82,6 +83,7 @@ commandNames = let
?access = undefined
?clientOps = undefined
?subSession = undefined
?terminal = undefined
in map fst $ foldMap snd commands
quitCmd,helpCmd,configCmd,killCmd,compareTypesCmd,showInstancesCmd :: Interactive Command
......
......@@ -111,7 +111,8 @@ type Interactive t = (?sessionState :: IORef SessionState
,?quitSession :: IO ()
,?access :: Access
,?subSession :: CurlyConfig -> OpParser IO ()
,?clientOps :: KeyOps)
,?clientOps :: KeyOps
,?terminal :: POSIXTerm)
=> t
type Command = (Documentation,OpParser IO Bool)
......
......@@ -11,7 +11,7 @@ import Curly.Style
import Language.Format hiding (space)
import Curly.Session.Commands.Common
whereCmd,whyCmd,whenceCmd,whatCmd,howCmd :: Interactive Command
whereCmd,whyCmd,whenceCmd,whatCmd,howCmd,formatCmd :: Interactive Command
viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
where viewPath = nbsp >> do
......@@ -34,7 +34,7 @@ whyDoc = unlines [
,"{p Show the documentation for the function at PATH, or of the symbol NAME.}}"
]
whyCmd = viewCmd whyDoc zero (const zero) $ \_ (by leafDoc -> d) ->
setupTermFromEnv >>= \t -> withStyle (serveStrLn $ docString t ?style d)
withStyle (serveStrLn $ docString ?terminal ?style d)
whenceDoc = unlines [
"{section {title Show Function Strictness}"
......@@ -42,7 +42,8 @@ whenceDoc = unlines [
,"{p Show the strictness for the function at PATH, or of the symbol NAME.}}"
]
whenceCmd = viewCmd whenceDoc zero (const zero) $ \_ (by leafVal -> v) ->
serveStrLn (show (exprStrictness v))
serveStrLn (pretty (snd $ exprStrictness v))
howDoc = unlines [
"{section {title Show Function Implementation}"
......@@ -88,3 +89,18 @@ whereCmd = viewCmd whereDoc zero onPath $ \path (by leafPos -> r) -> case r of
case ?mountain^?atMs p.t'Pure.flLibrary.symbols.traverse.leafPos.rangeFile of
Just s -> liftIOWarn $ editSource s (0,0) reloadMountain
_ -> zero
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
path <- nbhsp >> liftA2 subPath (getSession wd) dirArgs
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))),
(["name"],Pure $ Pure (identName n)),
(["doc"],Pure $ v^.leafDoc),
(["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
] zero
in p
withStyle $ serveStrLn (docString ?terminal ?style (document (map (\v -> fromMaybe nodoc (evalDoc (params v) pat)) ctx)))
module Curly.Style(
-- * Writing documentation out
setupTerm,setupTermFromEnv) where
POSIXTerm,setupTerm,setupTermFromEnv) where
import Definitive
import Curly.Core.Documentation
......
#!/bin/bash
notify-send "Stack: Compilation completed successfully"
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