summaryrefslogtreecommitdiff
path: root/psci/Completion.hs
blob: 0e5c1d31c67ae8640b24e290afc19f84a6261acb (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
module Completion where

import Data.Maybe (mapMaybe)
import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
import Data.Char (isUpper)
import Data.Function (on)
import Data.Traversable (traverse)

import Control.Applicative ((<$>), (<*>))
import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
import Control.Monad.Trans.State.Strict

import System.Console.Haskeline

import qualified Language.PureScript as P
import qualified Language.PureScript.Names as N

import qualified Directive as D
import Types

-- Completions may read the state, but not modify it.
type CompletionM = ReaderT PSCiState IO

-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.
liftCompletionM :: CompletionM a -> StateT PSCiState IO a
liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)

-- Haskeline completions

data CompletionContext
  = CtxDirective String
  | CtxFilePath String
  | CtxModule
  | CtxIdentifier
  | CtxType
  | CtxFixed String
  deriving (Show)

-- |
-- Loads module, function, and file completions.
--
completion :: CompletionFunc (StateT PSCiState IO)
completion = liftCompletionM . completion'

completion' :: CompletionFunc CompletionM
completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions

-- |
-- Decide what kind of completion we need based on input. This function expects
-- a list of complete words (to the left of the cursor) as the first argument,
-- and the current word as the second argument.
completionContext :: [String] -> String -> [CompletionContext]
completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"]
completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w
completionContext ws w | headSatisfies (== "import") ws = completeImport ws w
completionContext _ _ = [CtxIdentifier]

completeDirective :: [String] -> String -> [CompletionContext]
completeDirective ws w =
  case ws of
    []    -> [CtxDirective w]
    [dir] -> case D.directivesFor <$> stripPrefix ":" dir of
                -- only offer completions if the directive is unambiguous
                Just [dir'] -> directiveArg w dir'
                _           -> []

    -- All directives take exactly one argument. If we haven't yet matched,
    -- that means one argument has already been supplied. So don't complete
    -- any others.
    _     -> []

directiveArg :: String -> Directive -> [CompletionContext]
directiveArg _ Browse = [CtxModule]
directiveArg w Load   = [CtxFilePath w]
directiveArg _ Quit   = []
directiveArg _ Reset  = []
directiveArg _ Help   = []
directiveArg _ Show   = map CtxFixed replQueryStrings
directiveArg _ Type   = [CtxIdentifier]
directiveArg _ Kind   = [CtxType]

completeImport :: [String] -> String -> [CompletionContext]
completeImport ws w' =
  case (ws, w') of
    (["import"], w) | headSatisfies isUpper w -> [CtxModule]
    (["import"], _)                           -> [CtxModule, CtxFixed "qualified"]
    (["import", "qualified"], _)              -> [CtxModule]
    _                                         -> []

headSatisfies :: (a -> Bool) -> [a] -> Bool
headSatisfies p str =
  case str of
    (c:_)  -> p c
    _     -> False

-- | Callback for Haskeline's `completeWordWithPrev`.
-- Expects:
--   * Line contents to the left of the word, reversed
--   * Word to be completed
findCompletions :: String -> String -> CompletionM [Completion]
findCompletions prev word = do
  let ctx = completionContext (words (reverse prev)) word
  completions <- concat <$> traverse getCompletions ctx
  return $ sortBy directivesFirst completions
  where
  getCompletions :: CompletionContext -> CompletionM [Completion]
  getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion

  prefixedBy :: String -> String -> Maybe Completion
  prefixedBy w cand = if w `isPrefixOf` cand
                        then Just (simpleCompletion cand)
                        else Nothing

getCompletion :: CompletionContext -> CompletionM [Either String Completion]
getCompletion ctx =
  case ctx of
    CtxFilePath f        -> map Right <$> listFiles f
    CtxModule            -> map Left <$> getModuleNames
    CtxIdentifier        -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
    CtxType              -> map Left <$> getTypeNames
    CtxFixed str         -> return [Left str]
    CtxDirective d       -> return (map Left (completeDirectives d))

  where
  completeDirectives :: String -> [String]
  completeDirectives = map (':' :) . D.directiveStringsFor


getLoadedModules :: CompletionM [P.Module]
getLoadedModules = asks (map snd . psciLoadedModules)

getImportedModules :: CompletionM [ImportedModule]
getImportedModules = asks psciImportedModules

getModuleNames :: CompletionM [String]
getModuleNames = moduleNames <$> getLoadedModules

mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
mapLoadedModulesAndQualify f = do
  ms <- getLoadedModules
  let argPairs = do m <- ms
                    fm <- f m
                    return (m, fm)
  concat <$> traverse (uncurry getAllQualifications) argPairs

getIdentNames :: CompletionM [String]
getIdentNames = mapLoadedModulesAndQualify identNames

getDctorNames :: CompletionM [String]
getDctorNames = mapLoadedModulesAndQualify dctorNames

getTypeNames :: CompletionM [String]
getTypeNames = mapLoadedModulesAndQualify typeDecls

-- | Given a module and a declaration in that module, return all possible ways
-- it could have been referenced given the current PSCiState - including fully
-- qualified, qualified using an alias, and unqualified.
getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]
getAllQualifications m (declName, decl) = do
  imports <- getAllImportsOf m
  let fullyQualified = qualifyWith (Just (P.getModuleName m))
  let otherQuals = nub (concatMap qualificationsUsing imports)
  return $ fullyQualified : otherQuals
  where
  qualifyWith mMod = show (P.Qualified mMod declName)
  referencedBy refs = P.isExported (Just refs) decl

  qualificationsUsing (_, importType, asQ') =
    let q = qualifyWith asQ'
    in case importType of
          P.Implicit      -> [q]
          P.Explicit refs -> if referencedBy refs
                               then [q]
                               else []
          P.Hiding refs   -> if referencedBy refs
                               then []
                               else [q]


-- | Returns all the ImportedModule values referring to imports of a particular
-- module.
getAllImportsOf :: P.Module -> CompletionM [ImportedModule]
getAllImportsOf = asks . allImportsOf

nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
nubOnFst = nubBy ((==) `on` fst)

typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
  where
  getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
  getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
  getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
  getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
  getTypeName _ = Nothing

identNames :: P.Module -> [(N.Ident, P.Declaration)]
identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
  where
  getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
  getDeclName d@(P.ValueDeclaration ident _ _ _)  = Just (ident, d)
  getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)
  getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
  getDeclName _ = Nothing

dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
dctorNames m = nubOnFst $ concatMap dctors dnames
  where
  getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
  getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d)
  getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
  getDataDeclName _ = Nothing

  dnames :: [(N.ProperName, P.Declaration)]
  dnames = (mapMaybe getDataDeclName onlyDataDecls)

  onlyDataDecls :: [P.Declaration]
  onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))

  dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)]
  dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name))

moduleNames :: [P.Module] -> [String]
moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]

directivesFirst :: Completion -> Completion -> Ordering
directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
  where
  go (':' : xs) (':' : ys) = compare xs ys
  go (':' : _) _ = LT
  go _ (':' : _) = GT
  go xs ys = compare xs ys