Query.hs 4.2 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

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."

Marc Coiffier's avatar
Marc Coiffier committed
43
44
45
editDoc = unlines [
  "{section {title Edit Function}"
  ,"{p {em Usage:} edit PATH}"
Marc Coiffier's avatar
Marc Coiffier committed
46
47
  ,"{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

Marc Coiffier's avatar
Marc Coiffier committed
56
57
58
59
showDoc = "{section {title Formatted Query} {p {em Usage:} show PATH PATTERN} {p Show the function at PATH according to the given pattern}}"
showCmd = withDoc showDoc . fill False $ do
  path <- (nbhspace >> ((several "{}" >> getSession wd) <+? absPath ""))
          <+? getSession wd
60
61
62
  pat <- option' (docTag' "call" [Pure "default"])
         (nbhspace >> ((docAtom <*= guard . has t'Join) <+? map (docTag' "call" . pure . Pure) dirArg))
  withMountain $ let ctx = fold $ c'list $ localContext^??atMs path in withPatterns $ do
63
64
    let params (n,v) = let Join p = composing (uncurry insert) [
                             (["type"],Pure $ document (exprType (v^.leafVal))),
Marc Coiffier's avatar
Marc Coiffier committed
65
                             (["name"],Pure $ Pure $ identName n),
66
                             (["doc"],Pure $ v^.leafDoc),
Marc Coiffier's avatar
Marc Coiffier committed
67
                             (["impl"],Pure $ Pure $ showImpl (v^.leafVal)),
68
69
70
                             (["strictness"],Pure $ document (snd $ exprStrictness $ v^.leafVal))
                             ] zero
                       in p
71
72
73
74
75
76
77
78
79
        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)))
    withStyle $ serveStrLn (docString ?terminal ?style (document (applyFilter ctx)))
80
    
Marc Coiffier's avatar
Marc Coiffier committed
81
patternCmd = withDoc "{section {title Define Formatting Patterns} {p {em Usage:} pattern PATH = PATTERN} {p Defines a new query pattern accessible with \\{pattern PATH\\}}}" . fill False $ do
82
83
  ph:pt <- many1' (nbhspace >> dirArg <*= guard . (/="="))
  between nbhspace nbhspace (several "=")
84
  pat <- docLine "pat" []
85
  liftIO $ runAtomic ?sessionState (patterns.at ph =- Just (pt,pat))