Introduce a 'format' command for structured queries

Makefile

 ifeq ($(WATCH),true)
 STACK_FLAGS += --file-watch
 endif
+ifeq ($(NOTIFY),true)
+STACK_FLAGS += --exec scripts/notify-build-success
+endif
 
 build:
 	stack build $(STACK_FLAGS)

curly-core/src/Curly/Core/Annotated.hs

@@ -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

curly-core/src/Curly/Core/Documentation.hs

@@ -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

curly-core/src/Curly/Core/Library.hs

@@ -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))

curly-core/src/Curly/Core/Types.hs

@@ -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) =

curly/src/Curly/Session.hs

@@ -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

curly/src/Curly/Session/Commands.hs

@@ -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

curly/src/Curly/Session/Commands/Common.hs

@@ -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)
 

curly/src/Curly/Session/Commands/Query.hs

@@ -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)))
+    

curly/src/Curly/Style.hs

 module Curly.Style(
   -- * Writing documentation out
-  setupTerm,setupTermFromEnv) where
+  POSIXTerm,setupTerm,setupTermFromEnv) where
  
 import Definitive
 import Curly.Core.Documentation

scripts/notify-build-success

+#!/bin/bash
+notify-send "Stack: Compilation completed successfully"