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
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
  where viewPath = nbsp >> do
          path <- liftA2 subPath (getSession wd) dirArgs
          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
62
63
64
65
66
67
68
69
70
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
          e <- optimized =<< accessorExpr hspace
          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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
        onExpr = do
          e <- optimized =<< accessorExpr hspace
          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
96
  pat <- nbhsp >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "pattern" . pure . Pure) dirArg)
  
97
  path <- liftA2 subPath (getSession wd) (many' (nbhsp >> dirArg))
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 (evalDocWithPatterns ?patterns (params v) pat)) ctx)))
107
    
108
109
110
111
112
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
  ph:pt <- many1' (nbhsp >> dirArg <*= guard . (/="="))
  between nbhsp nbhsp (several "=")
  pat <- docLine "pat" []
  liftIO $ runAtomic ?sessionState (patterns.at ph.l'Just (Join zero).at pt =- Just (Pure pat))