Query.hs 5.17 KB
Newer Older
Marc Coiffier's avatar
Marc Coiffier committed
1
2
3
4
5
{-# LANGUAGE CPP, ExistentialQuantification, ViewPatterns, RecursiveDo #-}
module Curly.Session.Commands.Query where

import Curly.Core
import Curly.Core.Annotated
6
import Curly.Core.Documentation
Marc Coiffier's avatar
Marc Coiffier committed
7
8
9
10
11
12
13
import Curly.Core.Library
import Curly.UI
import Curly.Core.Parser
import Curly.Style
import Language.Format hiding (space)
import Curly.Session.Commands.Common

14
whereCmd,whyCmd,whenceCmd,whatCmd,howCmd,formatCmd,patternCmd :: Interactive Command
Marc Coiffier's avatar
Marc Coiffier committed
15
16
17

viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
  where viewPath = nbsp >> do
18
          path <- absPath ""
Marc Coiffier's avatar
Marc Coiffier committed
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
          withMountain $ case localContext^?atMs path of
            Just (Pure (_,v)) -> liftIOWarn $ showV path v
            _ -> onPath path
                 <+? serveStrLn ("Error: "+showPath path+" isn't a function.")
        viewSym = (nbsp >>) . (<+? onExpr) $ do
          n <- dirArg
          lookingAt (eoi+eol)
          l <- getSession this
          liftIOWarn $ case l^.symbols.at n of
            Just s -> showV [] s
            _ -> serveStrLn $ "Error: "+n+": no such symbol."

whyDoc = unlines [
  "{section {title Show Function Documentation}"
  ,"{p {em Usage:} why PATH {em OR} why's NAME}"
  ,"{p Show the documentation for the function at PATH, or of the symbol NAME.}}"
  ]
whyCmd = viewCmd whyDoc zero (const zero) $ \_ (by leafDoc -> d) ->
37
  withStyle (serveStrLn $ docString ?terminal ?style d)
Marc Coiffier's avatar
Marc Coiffier committed
38

39
40
41
42
43
44
whenceDoc = unlines [
  "{section {title Show Function Strictness}"
  ,"{p {em Usage:} whence PATH {em OR} whence's NAME}"
  ,"{p Show the strictness for the function at PATH, or of the symbol NAME.}}"
  ]
whenceCmd = viewCmd whenceDoc zero (const zero) $ \_ (by leafVal -> v) ->
45
46
  serveStrLn (pretty (snd $ exprStrictness v))

47

Marc Coiffier's avatar
Marc Coiffier committed
48
49
50
51
52
53
howDoc = unlines [
  "{section {title Show Function Implementation}"
  ,"{p {em Usage:} how PATH {em OR} how's EXPR}"
  ,"{p Show the implementation of the function at PATH, or an expression EXPR in the local context.}}"
  ]
data VerboseVar = VerboseVar GlobalID (Maybe Int)
54
55
instance Documented VerboseVar where
  document (VerboseVar v n) = Pure $ pretty v+maybe "" (\x -> "["+show x+"]") n
Marc Coiffier's avatar
Marc Coiffier committed
56
57
58
59
60
61
serveHow v | envLogLevel>=Verbose = serveStrLn (pretty (map withSym (semantic v) :: Expression GlobalID VerboseVar))
           | otherwise = serveStrLn (pretty (map fst (semantic v) :: Expression GlobalID GlobalID))
  where withSym (s,Pure (Argument n)) = VerboseVar s (Just n)
        withSym (s,_) = VerboseVar s Nothing
howCmd = viewCmd howDoc onExpr (const zero) $ \_ (by leafVal -> v) -> serveHow v
  where onExpr = do
62
          e <- optimized =<< accessorExpr HorizSpaces
Marc Coiffier's avatar
Marc Coiffier committed
63
64
65
66
67
68
69
70
          serveHow e
          
whatDoc = unlines [
  "{section {title Show Function Type}"
  ,"{p {em Usage:} what PATH {em OR} what's EXPR}"
  ,"{p Show the type of the function at PATH, or an expression EXPR in the local context.}}"
  ]
whatCmd = viewCmd whatDoc onExpr (const zero) $ \_ (by leafVal -> v) -> serveWhat v
71
  where serveWhat v = serveStrLn (show (exprType v))
Marc Coiffier's avatar
Marc Coiffier committed
72
        onExpr = do
73
          e <- optimized =<< accessorExpr HorizSpaces
Marc Coiffier's avatar
Marc Coiffier committed
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
          serveWhat e

rangeFile :: Traversal' SourceRange String
rangeFile k (SourceRange (Just s) a b) = k s <&> \s' -> SourceRange (Just s') a b
rangeFile _ x = pure x

whereDoc = unlines [
  "{section {title Go To Function}"
  ,"{p {em Usage:} where PATH}"
  ,"{p Start an editing session for the function at PATH.}}"
  ]
whereCmd = viewCmd whereDoc zero onPath $ \path (by leafPos -> r) -> case r of
  SourceRange (Just f) (_,l,c) _ -> editSource f (l,c) reloadMountain
  _ -> serveStrLn $ "No source position available for "+showPath path 
  where onPath p = withMountain $ do
          case ?mountain^?atMs p.t'Pure.flLibrary.symbols.traverse.leafPos.rangeFile of
            Just s -> liftIOWarn $ editSource s (0,0) reloadMountain
            _ -> zero
92
93
94

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
95
  pat <- nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "pattern" . pure . Pure) dirArg)
96
  
97
  path <- nbhspace >> absPath ""
98
99
100
101
102
103
104
105
  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
106
    withStyle $ withPatterns $ serveStrLn (docString ?terminal ?style (document (map (\v -> fromMaybe (nodoc (format "Unmatched pattern %s" (show pat))) (evalDocWithPatterns ?patterns (params v) pat)) ctx)))
107
    
108
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
109
110
  ph:pt <- many1' (nbhspace >> dirArg <*= guard . (/="="))
  between nbhspace nbhspace (several "=")
111
112
  pat <- docLine "pat" []
  liftIO $ runAtomic ?sessionState (patterns.at ph.l'Just (Join zero).at pt =- Just (Pure pat))