content: {-# OPTIONS -fspec-constr-count=0 #-}
  ------------------------------------------------------------------------------
  -- Copyright 2012-2021, Microsoft Research, Daan Leijen.
  --
  -- This is free software; you can redistribute it and/or modify it under the
  -- terms of the Apache License, Version 2.0. A copy of the License can be
  -- found in the LICENSE file at the root of this distribution.
  -----------------------------------------------------------------------------
  {-
      Main module.
  -}
  -----------------------------------------------------------------------------
  module Interpreter.Command
                ( Command(..), ShowCommand(..)
                , readCommand
                , commandHelp
                ) where
  
  import Data.Char         ( isSpace, toLower )
  import Data.List         ( isPrefixOf )
  import Lib.PPrint   ( Doc, text,vcat,(<->),hang,empty,fill,(<.>),color)
  import Common.ColorScheme
  import Common.Name  ( Name, newName )
  import Text.Parsec hiding (Error)
  
  type Parser a = Parsec String () a
  
  {--------------------------------------------------------------------------
    Interpreter Command parsing
  --------------------------------------------------------------------------}
  -- | A commmand line command.
  data Command  = Quit
                | Error    !String
                | Load     ![FilePath] !Bool {- force full rebuild? -}
                | Reload
                | Eval     !String
                | TypeOf   !String
                | KindOf   !String
                | Define   !String
                | TypeDef  !String
                | Options  !String
                | Edit     !FilePath
                | Shell    !String
                | ChangeDir !FilePath
                | Show     !ShowCommand
                | None
                deriving (Show)
  
  -- | A /show/ command -- @?@.
  data ShowCommand
                = ShowSource
                | ShowTypeSigs
                | ShowKindSigs
                | ShowSynonyms
                | ShowDefines
                | ShowHelp
                | ShowVersion
                deriving (Show)
  
  {--------------------------------------------------------------------------
    Read a command
  --------------------------------------------------------------------------}
  readCommand :: String -> Command
  readCommand line
    = parseCommand (edit [] line)
  
  
  {---------------------------------------------------------------
    Edit the command line: remove backspaces
  ---------------------------------------------------------------}
  edit xs []
    = reverse xs
  
  edit xs (c:cs)
    = case c of
        '\b'   | not (null xs) -> edit (tail xs) cs
               | otherwise     -> edit xs cs
        other  -> edit (c:xs) cs
  
  {--------------------------------------------------------------------------
    Parse a command line into a command, raises an exception on failure.
  --------------------------------------------------------------------------}
  -- | Parse a command line into a command, raises an exception on failure.
  parseCommand :: String -> Command
  parseCommand input
    = case parse (wrap command) "" input of
        Left err  -> Error ("error in command: " ++ show err)
        Right cmd -> cmd
  
  command :: Parser Command
  command
    =   do{ special ":"; cmdeval }
    <|> do{ expression }
    <|> return None
    <?> "command"
  
  
  cmdeval
    =   do{ symbol "l" <|> symbol "load"; fpaths <- filenames; return (Load fpaths False) }
    <|> do{ symbol "f" <|> symbol "fload"; fpaths <- filenames; return (Load fpaths True) }
    <|> do{ symbol "r" <|> symbol "reload"; return Reload }
    <|> do{ symbol "q" <|> symbol "quit"; return Quit }
    -- external
    <|> do{ symbol "e" <|> symbol "edit"; fpath <- option "" filename; return (Edit fpath) }
    <|> do{ symbol "cd"; fpath <- option "" filename; return (ChangeDir fpath) }
    <|> do{ special "!"; cmd <- shellCommand; return (Shell cmd) }
    -- help
    <|> do{ special "?" <|> symbol "h" <|> symbol "help"; return (Show ShowHelp) }
    -- complex
    <|> do{ symbol "t" <|> symbol "type" <|> symbol "b" <|> symbol "browse";
          (do p <- getPosition; x <- expr; return (TypeOf (replicate (sourceColumn p-1) ' ' ++ x))
           <|>
           return (Show ShowTypeSigs))}
    <|> do{ symbol "set"; opts <- commandLine; return (Options opts) }
    <|> do{ symbol "s" <|> symbol "source"
          ; return (Show (ShowSource))}
    <|> do{ symbol "k" <|> symbol "kind";
            (do p <- getPosition; x <- expr; return (KindOf (replicate (sourceColumn p-1) ' ' ++ x))
             <|>
             return (Show ShowKindSigs))}
    <|> do{ symbol "d" <|> symbol "defines"
          ; return (Show ShowDefines) }
    <|> do{ symbol "alias"; return (Show ShowSynonyms) }
    <|> do{ symbol "w" <|> symbol "warranty" <|> symbol "version"; return (Show ShowVersion) }
    <?> "command"
  
  commandHelp :: ColorScheme -> Doc
  commandHelp colors
    = hang 2 (infotext "commands:" <-> vcat
      [cmd "<expression>" ""          "evaluate the given expression"
      {-
      ,cmd "val"      "<definition>"  "add a value definition"
      ,cmd "fun"      "<definition>"  "add a function definition"
      ,cmd "type"     "<definition>"  "add a new type definition"
      ,cmd "alias"    "<definition>"  "add a type synonym definition"
      ,empty
      -}
      ,cmd ":l[oad]"  "{modulename}"  "load module(s)"
      ,cmd ":f[load]" "{modulename}"  "force load module(s) rebuilding everything"
      ,cmd ":r[eload]" ""             "reload the current module(s)"
  --    ,cmd ":f[ind]" "<identifier>"   "edit file containing the identifier"
      ,cmd ":e[dit]" "[filename]"     "edit file (and jump to error location)"
      ,cmd ":set"    "<options>"      "set (command line) options"
      ,empty
      ,cmd ":t[ype]" "[expression]"   "show type signature(s) (of a given expression)"
      ,cmd ":k[ind]" ""               "show kind signatures in scope"
      -- ,cmd ":s[ource]" ""             "show the source code of the current module"
      -- ,cmd ":d[efines]" "[identifier]" "show interactively defined values"
      ,cmd ":alias"   ""              "show type alias signatures"
      ,cmd ":version"  ""             "show version and warranty information"
      ,cmd ":cd"     ""               "show the current directory"
      ,cmd ":cd"     "<directory>"    "change the current directory"
      ,cmd ":!"      "<command>"      "run a shell command"
      ,cmd ":?"      ""               "show this information"
      ,cmd ":q[uit]"  ""              "quit the interpreter"
      ,empty
      ]) <->
      hang 2 (infotext "remarks:" <-> vcat
      [-- text "The type command can also be cotype, rectype, or struct."
       text "Use :set -? to see help on command line flags."
      ])
    where
      cmd c arg explain
        = fill 12 (text c) <.> fill 14 (text arg) <.> infotext explain
  
      infotext s
        = color (colorInterpreter colors) (text s)
  
  
  expression :: Parser Command
  expression
    = do src <- expr
         if (isPrefixOf "fun" src)
           then return (Define src)
          else if (isPrefixOf "val" src)
           then return (Define src)
          else if (any (\decl -> isPrefixOf decl src) ["type","open type","extend type","co type","div type","alias","struct"])
           then return (TypeDef src)
           else return (Eval src)
  
  expr :: Parser String
  expr
    = anything <?> "expression"
  
  shellCommand :: Parser String
  shellCommand
    = anything <?> "shell command"
  
  commandLine :: Parser String
  commandLine
    = many (noneOf "\n") <?> "options"
  
  anything :: Parser String
  anything
    = lexeme (many1 (noneOf "\^Z"))
  
  identifier :: Parser Name
  identifier
    = lexeme (
      do c  <- lower <|> upper
         cs <- idchars
         return (newName (c:cs))
      <?> "identifier")
  
  {-
  nat :: Parser Int
  nat
    = lexeme (
      do{ ds <- many1 digit
        ; return (foldl (\n d -> 10*n + digitToInt d) 0 ds)
        })
    <?> "number"
  -}
  
  filenames :: Parser [String]
  filenames
    = many filename
  
  filename :: Parser String
  filename
    = lexeme (
      do{ char '"'
        ; s <- many1 (noneOf "\"\n")
        ; char '"'
        ; return s
        }
      <|>
      do{ many1 (noneOf "\"\n \t")  }
      <?> "file name")
  
  
  {--------------------------------------------------------------------------
    Whitespace and lexemes
  --------------------------------------------------------------------------}
  special :: String -> Parser ()
  special name
    = lexeme (do{ string name; return () })
  
  symbol :: String -> Parser ()
  symbol name
    = lexeme (try (do{ istring name; notFollowedBy alphaNum }))
  
  istring :: String -> Parser ()
  istring s
    = (mapM_ (\c -> satisfy (\d -> toLower d == toLower c)) s)
      <?> s
  
  
  lexeme p
      = do{ x <- p; whiteSpace; return x  }
  
  wrap p
    = do{ whiteSpace
        ; x <- p
        ; eof
        ; return x
        }
  
  --whiteSpace
  whiteSpace
    = skipMany white
  
  white
    = simpleSpace <|> {- oneLineComment <|> -} multiLineComment <?> ""
  
  simpleSpace
    = skipMany1 (satisfy isSpace)
  
  oneLineComment :: Parser ()
  oneLineComment
    = do{ try (string "--")
        ; skipMany (satisfy (/= '\n'))
        ; return ()
        }
  
  multiLineComment
    = do { try (string "{-")
         ; inComment
         }
  
  inComment
      =   do{ try (string "-}") ; return () }
      <|> do{ multiLineComment             ; inComment}
      <|> do{ skipMany1 (noneOf startEnd)  ; inComment}
      <|> do{ oneOf startEnd               ; inComment}
      <?> "end of comment"
      where
        startEnd   = "{-}"
  
  p << q
    = do{ x <- p; q; return x }
  
  -- Parsers from `Syntax.Lexer`
  
  idchars :: Parser String
  idchars
    = do cs <- many idchar
         return (concat cs)
  
  idchar :: Parser String
  idchar
    = do c <- alphanum <|> oneOf "_"
         return [c]
    <|>
      try (do char '-'
              c <- letter
              return ['-',c])
  
  alphanum = letter <|> digit
  