summaryrefslogtreecommitdiff
path: root/psci/Parser.hs
blob: 05eda111176bbc1c918e21ec13ffd0ba3a1a7077 (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
-----------------------------------------------------------------------------
--
-- Module      :  Parser
-- Copyright   :  (c) Phil Freeman 2014
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Parser for PSCI.
--
-----------------------------------------------------------------------------

module Parser
  ( parseCommand
  ) where

import Prelude hiding (lex)

import Data.Char (isSpace)
import Data.List (intercalate)

import Control.Applicative hiding (many)

import Text.Parsec hiding ((<|>))

import qualified Language.PureScript as P
import Language.PureScript.Parser.Common (mark, same)

import qualified Directive as D
import Types

-- |
-- Parses PSCI metacommands or expressions input from the user.
--
parseCommand :: String -> Either String Command
parseCommand cmdString =
  case cmdString of
    (':' : cmd) -> parseDirective cmd
    _ -> parseRest psciCommand cmdString

parseRest :: P.TokenParser a -> String -> Either String a
parseRest p s = either (Left . show) Right $ do
  ts <- P.lex "" s
  P.runTokenParser "" (p <* eof) ts

psciCommand :: P.TokenParser Command
psciCommand = choice (map try parsers)
  where
  parsers =
    [ psciLet
    , psciImport
    , psciOtherDeclaration
    , psciExpression
    ]

trim :: String -> String
trim = trimEnd . trimStart

trimStart :: String -> String
trimStart = dropWhile isSpace

trimEnd :: String -> String
trimEnd = reverse . trimStart . reverse

parseDirective :: String -> Either String Command
parseDirective cmd =
  case D.directivesFor' dstr of
    [(d, _)] -> commandFor d
    []       -> Left "Unrecognized directive. Type :? for help."
    ds       -> Left ("Ambiguous directive. Possible matches: " ++
                  intercalate ", " (map snd ds) ++ ". Type :? for help.")
  where
  (dstr, arg) = break isSpace cmd

  commandFor d = case d of
    Help   -> return ShowHelp
    Quit   -> return QuitPSCi
    Reset  -> return ResetState
    Browse -> BrowseModule <$> parseRest P.moduleName arg
    Load   -> return $ LoadFile (trim arg)
    Show   -> ShowInfo <$> parseReplQuery' (trim arg)
    Type   -> TypeOf <$> parseRest P.parseValue arg
    Kind   -> KindOf <$> parseRest P.parseType arg

-- |
-- Parses expressions entered at the PSCI repl.
--
psciExpression :: P.TokenParser Command
psciExpression = Expression <$> P.parseValue

-- |
-- PSCI version of @let@.
-- This is essentially let from do-notation.
-- However, since we don't support the @Eff@ monad,
-- we actually want the normal @let@.
--
psciLet :: P.TokenParser Command
psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
  where
  manyDecls :: P.TokenParser [P.Declaration]
  manyDecls = mark (many1 (same *> P.parseLocalDeclaration))

-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
psciImport :: P.TokenParser Command
psciImport = Import <$> P.parseImportDeclaration'

-- | Any other declaration that we don't need a 'special case' parser for
-- (like let or import declarations).
psciOtherDeclaration :: P.TokenParser Command
psciOtherDeclaration = Decls . (:[]) <$> do
  decl <- discardPositionInfo <$> P.parseDeclaration
  if acceptable decl
    then return decl
    else fail "this kind of declaration is not supported in psci"

discardPositionInfo :: P.Declaration -> P.Declaration
discardPositionInfo (P.PositionedDeclaration _ _ d) = d
discardPositionInfo d = d

acceptable :: P.Declaration -> Bool
acceptable (P.DataDeclaration _ _ _ _) = True
acceptable (P.TypeSynonymDeclaration _ _ _) = True
acceptable (P.ExternDeclaration _ _ _ _) = True
acceptable (P.ExternDataDeclaration _ _) = True
acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
acceptable (P.TypeClassDeclaration _ _ _ _) = True
acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
acceptable _ = False

parseReplQuery' :: String -> Either String ReplQuery
parseReplQuery' str =
  case parseReplQuery str of
    Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++
                      intercalate ", " replQueryStrings ++ ".")
    Just query -> Right query