Query.hs 5.76 KB
Newer Older
1
{-# LANGUAGE CPP, ExistentialQuantification, ViewPatterns, RecursiveDo, QuasiQuotes #-}
Marc Coiffier's avatar
Marc Coiffier committed
2
3
4
5
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

Marc Coiffier's avatar
Marc Coiffier committed
14
15
16
17
18
19
20
21
22
23
24
25
26
editCmd,showCmd,patternCmd :: Interactive Command

data VerboseVar = VerboseVar GlobalID (Maybe Int)
instance Documented VerboseVar where
  document (VerboseVar v n) = Pure $ pretty v+maybe "" (\x -> "["+show x+"]") n
showImpl v | envLogLevel>=Verbose = pretty (map withSym (semantic v) :: Expression GlobalID VerboseVar)
           | otherwise = pretty (map fst (semantic v) :: Expression GlobalID GlobalID)
  where withSym (s,Pure (Argument n)) = VerboseVar s (Just n)
        withSym (s,_) = VerboseVar s Nothing
          
rangeFile :: Traversal' SourceRange String
rangeFile k (SourceRange (Just s) a b) = k s <&> \s' -> SourceRange (Just s') a b
rangeFile _ x = pure x
Marc Coiffier's avatar
Marc Coiffier committed
27
28
29

viewCmd doc onExpr onPath showV = withDoc doc . fill False $ (several "'s" >> viewSym) <+? viewPath
  where viewPath = nbsp >> do
30
          path <- absPath ""
Marc Coiffier's avatar
Marc Coiffier committed
31
32
33
34
35
36
37
38
39
40
41
42
          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."

43
44
45
46
47
editDoc = [q_string|
{title Edit Function}
{p {em Usage:} edit PATH}
{p Start an editing session for the function at PATH.}
|]
Marc Coiffier's avatar
Marc Coiffier committed
48
editCmd = viewCmd editDoc zero onPath $ \path (by leafPos -> r) -> case r of
Marc Coiffier's avatar
Marc Coiffier committed
49
50
51
52
53
54
  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
55

56
57
58
59
60
61
62
63
64
65
66
67
showExprDefault pat n v = do
  let Join params = composing (uncurry insert) [
        (["flavor"],Pure $ Pure "Expression"),
        (["name"],Pure $ Pure n),
        (["type"],Pure $ document (exprType v)),
        (["raw-type"],Pure $ Pure $ show (exprType v & \(Type e) -> e)),
        (["impl"],Pure $ Pure $ showImpl v),
        (["strictness"],Pure $ document (snd $ exprStrictness v))
        ] zero
  serveStrLn (docString ?terminal ?style (fromMaybe (nodoc $ "Cannot show pattern "+showRawDoc pat)
                                          (evalDocWithPatterns ?patterns params pat)))

68
69
70
71
72
73
showDoc = [q_string|
{title Formatted Query}
{p {em Usage:} show (PATH|\\(EXPR\\)) [PATTERN]}
{p Show information about functions under PATH, or an ad-hoc expression.}
{p The pattern will default to '\{call show-default\}' if left unspecified.}
|]
Marc Coiffier's avatar
Marc Coiffier committed
74
showCmd = withDoc showDoc . fill False $ do
75
76
77
  epath <- map Right (nbhspace >> between (single '(') (single ')') (withParsedString (expr AnySpaces)))
           <+? map Left ((nbhspace >> ((several "{}" >> getSession wd) <+? absPath ""))
                         <+? (lookingAt (hspace >> eol) >> getSession wd))
78
  pat <- option' (docTag' "call" [Pure "show-default"])
79
         (nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "call" . pure . Pure) dirArg))
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
  withMountain $ withPatterns $ withStyle $ case epath of
    Left path -> let ctx = fold $ c'list $ localContext^??atMs path in do
      let params (n,v) = let Join p = composing (uncurry insert) [
                               (["flavor"],Pure $ Pure "Symbol"),
                               (["type"],Pure $ document (exprType (v^.leafVal))),
                               (["name"],Pure $ Pure $ identName n),
                               (["doc"],Pure $ v^.leafDoc),
                               (["impl"],Pure $ Pure $ showImpl (v^.leafVal)),
                               (["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
                               ] zero
                         in p
          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)))
      serveStrLn (docString ?terminal ?style (document (applyFilter ctx)))

    Right (n,e) -> do
      v <- optExprIn <$> getSession this <*> pure e
103
      showExprDefault pat n v
104
105
106
107
108
109
patternDoc = [q_string|
{title Define Formatting Patterns}
{p {em Usage:} pattern NAME ARG... = PATTERN {em OR} pattern NAME}
{p Defines a new query pattern accessible with \{pattern PATTERN PARAM...\}}
{p If you only specify the pattern name, its current definition will be printed instead.}
|]
110
patternCmd = withDoc patternDoc . fill False $ do
111
  ph:pt <- many1' (nbhspace >> dirArg <*= guard . (/="="))
112
113
114
115
116
117
118
119
120
121
  let setPat = do
        between nbhspace nbhspace (several "=")
        pat <- docLine "pat" []
        liftIO $ runAtomic ?sessionState (patterns.at ph =- Just (pt,pat))
      showPat = do
        pat <- liftIO $ runAtomic ?sessionState (getl (patterns.at ph))
        case pat of
          Just (_,pat) -> serveStrLn (format "pattern %s%s = %s" ph (foldMap (" "+) pt) (showRawDoc pat))
          Nothing -> serveStrLn (format "The pattern %s doesn't exist." ph)
  setPat <+? showPat