-- |
-- Parser for PSCI.
--
module Language.PureScript.Interactive.Parser
  ( parseDotFile
  , parseCommand
  ) where

import           Prelude

import           Control.Monad (join)
import           Data.Bifunctor (bimap)
import           Data.Char (isSpace)
import           Data.List (intercalate)
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import qualified Language.PureScript as P
import qualified Language.PureScript.CST as CST
import qualified Language.PureScript.CST.Monad as CSTM
import qualified Language.PureScript.Interactive.Directive as D
import           Language.PureScript.Interactive.Types

-- |
-- Parses a limited set of commands from from .purs-repl
--
parseDotFile :: FilePath -> String -> Either String [Command]
parseDotFile :: [Char] -> [Char] -> Either [Char] [Command]
parseDotFile [Char]
filePath =
  forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ParserError -> [Char]
CST.prettyPrintError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. (a, b) -> b
snd
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser (forall a. Parser a -> Parser [a]
parseMany Parser Command
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token -> Parser SourceToken
CSTM.token Token
CST.TokEof)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [LexResult]
CST.lexTopLevel
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack
  where
  parser :: Parser Command
parser = forall a. NonEmpty (Parser a) -> Parser a
CSTM.oneOf forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList
    [ [Char] -> Parser Command
psciImport [Char]
filePath
    , do
        SourceToken
tok <- Parser SourceToken
CSTM.munch
        forall a. SourceToken -> ParserErrorType -> Parser a
CSTM.parseFail SourceToken
tok forall a b. (a -> b) -> a -> b
$ [Char] -> ParserErrorType
CST.ErrCustom [Char]
"The .purs-repl file only supports import declarations"
    ]

-- |
-- Parses PSCI metacommands or expressions input from the user.
--
parseCommand :: String -> Either String [Command]
parseCommand :: [Char] -> Either [Char] [Command]
parseCommand [Char]
cmdString =
  case [Char]
cmdString of
    (Char
':' : [Char]
cmd) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either [Char] Command
parseDirective [Char]
cmd
    [Char]
_ -> forall a. Parser a -> [Char] -> Either [Char] a
parseRest ([Command] -> [Command]
mergeDecls forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser [a]
parseMany Parser Command
psciCommand) [Char]
cmdString
  where
  mergeDecls :: [Command] -> [Command]
mergeDecls (Decls [Declaration]
as : [Command]
bs) =
    case [Command] -> [Command]
mergeDecls [Command]
bs of
      Decls [Declaration]
bs' : [Command]
cs' ->
        [Declaration] -> Command
Decls ([Declaration]
as forall a. Semigroup a => a -> a -> a
<> [Declaration]
bs') forall a. a -> [a] -> [a]
: [Command]
cs'
      [Command]
cs' ->
        [Declaration] -> Command
Decls [Declaration]
as forall a. a -> [a] -> [a]
: [Command]
cs'
  mergeDecls (Command
a : [Command]
bs) =
    Command
a forall a. a -> [a] -> [a]
: [Command] -> [Command]
mergeDecls [Command]
bs
  mergeDecls [] = []

parseMany :: CST.Parser a -> CST.Parser [a]
parseMany :: forall a. Parser a -> Parser [a]
parseMany = forall a. Token -> Token -> Token -> Parser a -> Parser [a]
CSTM.manyDelimited Token
CST.TokLayoutStart Token
CST.TokLayoutEnd Token
CST.TokLayoutSep

parseOne :: CST.Parser a -> CST.Parser a
parseOne :: forall a. Parser a -> Parser a
parseOne Parser a
p = Token -> Parser SourceToken
CSTM.token Token
CST.TokLayoutStart forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token -> Parser SourceToken
CSTM.token Token
CST.TokLayoutEnd

parseRest :: CST.Parser a -> String -> Either String a
parseRest :: forall a. Parser a -> [Char] -> Either [Char] a
parseRest Parser a
p =
   forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (ParserError -> [Char]
CST.prettyPrintError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. (a, b) -> b
snd
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser (Parser a
p forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token -> Parser SourceToken
CSTM.token Token
CST.TokEof)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [LexResult]
CST.lexTopLevel
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

psciCommand :: CST.Parser Command
psciCommand :: Parser Command
psciCommand =
  forall a. NonEmpty (Parser a) -> Parser a
CSTM.oneOf forall a b. (a -> b) -> a -> b
$ forall a. [a] -> NonEmpty a
NE.fromList
    [ [Char] -> Parser Command
psciImport [Char]
""
    , Parser Command
psciDeclaration
    , Parser Command
psciExpression
    ]

trim :: String -> String
trim :: [Char] -> [Char]
trim = [Char] -> [Char]
trimEnd forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
trimStart

trimStart :: String -> String
trimStart :: [Char] -> [Char]
trimStart = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace

trimEnd :: String -> String
trimEnd :: [Char] -> [Char]
trimEnd = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
trimStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

parseDirective :: String -> Either String Command
parseDirective :: [Char] -> Either [Char] Command
parseDirective [Char]
cmd =
  case [Char] -> [(Directive, [Char])]
D.directivesFor' [Char]
dstr of
    [(Directive
d, [Char]
_)] -> Directive -> Either [Char] Command
commandFor Directive
d
    []       -> forall a b. a -> Either a b
Left [Char]
"Unrecognized directive. Type :? for help."
    [(Directive, [Char])]
ds       -> forall a b. a -> Either a b
Left ([Char]
"Ambiguous directive. Possible matches: " forall a. [a] -> [a] -> [a]
++
                  forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Directive, [Char])]
ds) forall a. [a] -> [a] -> [a]
++ [Char]
". Type :? for help.")
  where
  ([Char]
dstr, [Char]
arg) = [Char] -> [Char]
trim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace [Char]
cmd

  commandFor :: Directive -> Either [Char] Command
commandFor Directive
d = case Directive
d of
    Directive
Help     -> forall (m :: * -> *) a. Monad m => a -> m a
return Command
ShowHelp
    Directive
Quit     -> forall (m :: * -> *) a. Monad m => a -> m a
return Command
QuitPSCi
    Directive
Reload   -> forall (m :: * -> *) a. Monad m => a -> m a
return Command
ReloadState
    Directive
Clear    -> forall (m :: * -> *) a. Monad m => a -> m a
return Command
ClearState
    Directive
Paste    -> forall (m :: * -> *) a. Monad m => a -> m a
return Command
PasteLines
    Directive
Browse   -> ModuleName -> Command
BrowseModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Name a -> a
CST.nameValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> [Char] -> Either [Char] a
parseRest (forall a. Parser a -> Parser a
parseOne Parser (Name ModuleName)
CST.parseModuleNameP) [Char]
arg
    Directive
Show     -> ReplQuery -> Command
ShowInfo forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Either [Char] ReplQuery
parseReplQuery' [Char]
arg
    Directive
Type     -> Expr -> Command
TypeOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> Expr a -> Expr
CST.convertExpr [Char]
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> [Char] -> Either [Char] a
parseRest (forall a. Parser a -> Parser a
parseOne Parser (Expr ())
CST.parseExprP) [Char]
arg
    Directive
Kind     -> SourceType -> Command
KindOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> Type a -> SourceType
CST.convertType [Char]
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> [Char] -> Either [Char] a
parseRest (forall a. Parser a -> Parser a
parseOne Parser (Type ())
CST.parseTypeP) [Char]
arg
    Directive
Complete -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Command
CompleteStr [Char]
arg)
    Directive
Print
      | [Char]
arg forall a. Eq a => a -> a -> Bool
== [Char]
"" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ReplQuery -> Command
ShowInfo ReplQuery
QueryPrint
      | Bool
otherwise -> (ModuleName, Ident) -> Command
SetInteractivePrint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> [Char] -> Either [Char] a
parseRest (forall a. Parser a -> Parser a
parseOne Parser (ModuleName, Ident)
parseFullyQualifiedIdent) [Char]
arg

-- |
-- Parses expressions entered at the PSCI repl.
--
psciExpression :: CST.Parser Command
psciExpression :: Parser Command
psciExpression = Expr -> Command
Expression forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> Expr a -> Expr
CST.convertExpr [Char]
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Expr ())
CST.parseExprP

-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
psciImport :: FilePath -> CST.Parser Command
psciImport :: [Char] -> Parser Command
psciImport [Char]
filePath = do
  (SourceAnn
_, ModuleName
mn, ImportDeclarationType
declType, Maybe ModuleName
asQ) <- forall a.
[Char]
-> ImportDecl a
-> (SourceAnn, ModuleName, ImportDeclarationType, Maybe ModuleName)
CST.convertImportDecl [Char]
filePath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (ImportDecl ())
CST.parseImportDeclP
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ImportedModule -> Command
Import (ModuleName
mn, ImportDeclarationType
declType, Maybe ModuleName
asQ)

-- | Any declaration that we don't need a 'special case' parser for
-- (like import declarations).
psciDeclaration :: CST.Parser Command
psciDeclaration :: Parser Command
psciDeclaration = [Declaration] -> Command
Decls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Char] -> Declaration a -> [Declaration]
CST.convertDeclaration [Char]
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Declaration ())
CST.parseDeclP

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

parseFullyQualifiedIdent :: CST.Parser (P.ModuleName, P.Ident)
parseFullyQualifiedIdent :: Parser (ModuleName, Ident)
parseFullyQualifiedIdent = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall e s a.
(forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
-> ParserM e s a
CST.Parser forall a b. (a -> b) -> a -> b
$ \ParserState
st ParserState -> ParserError -> r
_ ParserState -> Parser (ModuleName, Ident) -> r
ksucc ->
  case forall a.
ParserState
-> Parser a -> (ParserState, Either (NonEmpty ParserError) a)
CST.runParser ParserState
st Parser (QualifiedName Ident)
CST.parseQualIdentP of
    (ParserState
st', Right (CST.QualifiedName SourceToken
_ (Just ModuleName
mn) Ident
ident)) ->
      ParserState -> Parser (ModuleName, Ident) -> r
ksucc ParserState
st' forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleName
mn, Text -> Ident
P.Ident forall a b. (a -> b) -> a -> b
$ Ident -> Text
CST.getIdent Ident
ident)
    (ParserState, Either (NonEmpty ParserError) (QualifiedName Ident))
_ ->
      ParserState -> Parser (ModuleName, Ident) -> r
ksucc ParserState
st forall a b. (a -> b) -> a -> b
$ do
        SourceToken
tok <- Parser SourceToken
CSTM.munch
        forall a. SourceToken -> ParserErrorType -> Parser a
CSTM.parseFail SourceToken
tok forall a b. (a -> b) -> a -> b
$ [Char] -> ParserErrorType
CST.ErrCustom [Char]
"Expected a fully-qualified name (eg: PSCI.Support.eval)"