purescript-0.4.15: psci/Main.hs

-----------------------------------------------------------------------------
--
-- Module      :  Main
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- PureScript Compiler Interactive.
--
-----------------------------------------------------------------------------

{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}

module Main where

import Commands

import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.State.Strict

import Data.List (intercalate, isPrefixOf, nub, sortBy)
import Data.Maybe (mapMaybe)
import Data.Foldable (traverse_)
import Data.Traversable (traverse)
import Data.Version (showVersion)

import Parser

import System.Console.Haskeline
import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
import System.Exit
import System.Environment.XDG.BaseDir
import System.FilePath ((</>), isPathSeparator)
import qualified System.Console.CmdTheLine as Cmd
import System.Process

import Text.Parsec (ParseError)

import qualified Data.Map as M
import qualified Language.PureScript as P
import qualified Paths_purescript as Paths
import qualified System.IO.UTF8 as U (print, readFile)

-- |
-- The PSCI state.
-- Holds a list of imported modules, loaded files, and partial let bindings.
-- The let bindings are partial,
-- because it makes more sense to apply the binding to the final evaluated expression.
--
data PSCiState = PSCiState
  { psciImportedFilenames   :: [FilePath]
  , psciImportedModuleNames :: [P.ModuleName]
  , psciLoadedModules       :: [P.Module]
  , psciLetBindings         :: [P.Value -> P.Value]
  }

-- State helpers

-- |
-- Updates the state to have more imported modules.
--
updateImportedFiles :: FilePath -> PSCiState -> PSCiState
updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }

-- |
-- Updates the state to have more imported modules.
--
updateImports :: P.ModuleName -> PSCiState -> PSCiState
updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }

-- |
-- Updates the state to have more loaded files.
--
updateModules :: [P.Module] -> PSCiState -> PSCiState
updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }

-- |
-- Updates the state to have more let bindings.
--
updateLets :: (P.Value -> P.Value) -> PSCiState -> PSCiState
updateLets name st = st { psciLetBindings = name : psciLetBindings st }

-- File helpers
-- |
-- Load the necessary modules.
--
defaultImports :: [P.ModuleName]
defaultImports = [P.ModuleName [P.ProperName "Prelude"]]

-- |
-- Locates the node executable.
-- Checks for either @nodejs@ or @node@.
--
findNodeProcess :: IO (Maybe String)
findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
  where names = ["nodejs", "node"]

-- |
-- Grabs the filename where the history is stored.
--
getHistoryFilename :: IO FilePath
getHistoryFilename = getUserConfigFile "purescript" "psci_history"

-- |
-- Grabs the filename where prelude is.
--
getPreludeFilename :: IO FilePath
getPreludeFilename = Paths.getDataFileName "prelude/prelude.purs"

-- |
-- Loads a file for use with imports.
--
loadModule :: FilePath -> IO (Either String [P.Module])
loadModule filename = either (Left . show) Right . P.runIndentParser filename P.parseModules <$> U.readFile filename

-- |
-- Expands tilde in path.
--
expandTilde :: FilePath -> IO FilePath
expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
expandTilde p = return p
-- Messages

-- |
-- The help message.
--
helpMessage :: String
helpMessage = "The following commands are available:\n\n    " ++
  intercalate "\n    " (map (intercalate "    ") help)

-- |
-- The welcome prologue.
--
prologueMessage :: String
prologueMessage = intercalate "\n"
  [ " ____                 ____            _       _   "
  , "|  _ \\ _   _ _ __ ___/ ___|  ___ _ __(_)_ __ | |_ "
  , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
  , "|  __/| |_| | | |  __/___) | (__| |  | | |_) | |_ "
  , "|_|    \\__,_|_|  \\___|____/ \\___|_|  |_| .__/ \\__|"
  , "                                       |_|        "
  , ""
  , ":? shows help"
  , ""
  , "Expressions are terminated using Ctrl+D"
  ]

-- |
-- The quit message.
--
quitMessage :: String
quitMessage = "See ya!"

-- Haskeline completions

-- |
-- Loads module, function, and file completions.
--
completion :: CompletionFunc (StateT PSCiState IO)
completion = completeWord Nothing " \t\n\r" findCompletions
  where
  findCompletions :: String -> StateT PSCiState IO [Completion]
  findCompletions str = do
    ms <- psciLoadedModules <$> get
    files <- listFiles str
    let matches = filter (isPrefixOf str) (names ms)
    return $ sortBy sorter $ map simpleCompletion matches ++ files
  getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
  getDeclName Nothing (P.ValueDeclaration ident _ _ _ _) = Just ident
  getDeclName (Just exts) (P.ValueDeclaration ident _ _ _ _) | isExported = Just ident
    where
    isExported = any exports exts
    exports (P.ValueRef ident') = ident == ident'
    exports (P.PositionedDeclarationRef _ r) = exports r
    exports _ = False
  getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
  getDeclName _ _ = Nothing
  names :: [P.Module] -> [String]
  names ms = nub [ show qual
              | P.Module moduleName ds exts <- ms
              , ident <- mapMaybe (getDeclName exts) ds
              , qual <- [ P.Qualified Nothing ident
                        , P.Qualified (Just moduleName) ident]
              ]
  sorter :: Completion -> Completion -> Ordering
  sorter (Completion _ d1 _) (Completion _ d2 _) = compare d1 d2

-- Compilation

-- | Compilation options.
--
options :: P.Options
options = P.Options False True False True (Just "Main") True "PS" [] [] False

-- |
-- Makes a volatile module to execute the current expression.
--
createTemporaryModule :: Bool -> PSCiState -> P.Value -> P.Module
createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} value =
  let
    moduleName = P.ModuleName [P.ProperName "Main"]
    importDecl m = P.ImportDeclaration m Nothing Nothing
    traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
    trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
    itValue = foldl (\x f -> f x) value lets
    mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
    itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] Nothing itValue
    mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] Nothing mainValue
    decls = if exec then [itDecl, mainDecl] else [itDecl]
  in
    P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing

-- |
-- Takes a value declaration and evaluates it with the current state.
--
handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
handleDeclaration value st = do
  let m = createTemporaryModule True st value
  case P.compile options (psciLoadedModules st ++ [m]) of
    Left err -> outputStrLn err
    Right (js, _, _) -> do
      process <- lift . lift $ findNodeProcess
      result  <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
      case result of
        Just (ExitSuccess,   out, _)   -> outputStrLn out
        Just (ExitFailure _, _,   err) -> outputStrLn err
        Nothing                        -> outputStrLn "Couldn't find node.js"

-- |
-- Takes a value and prints its type
--
handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
handleTypeOf value st = do
  let m = createTemporaryModule False st value
  case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
    Left err -> outputStrLn err
    Right (_, _, env') ->
      case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
        Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty
        Nothing -> outputStrLn "Could not find type"

-- Commands

-- |
-- Parses the input and returns either a Metacommand or an expression.
--
getCommand :: InputT (StateT PSCiState IO) (Either ParseError (Maybe Command))
getCommand = do
  firstLine <- getInputLine "> "
  case firstLine of
    Nothing -> return (Right Nothing)
    Just s@ (':' : _) -> return . either Left (Right . Just) $ parseCommand s -- The start of a command
    Just s -> either Left (Right . Just) . parseCommand <$> go [s]
  where
    go :: [String] -> InputT (StateT PSCiState IO) String
    go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine "  "

-- |
-- Performs an action for each meta-command given, and also for expressions..
--
handleCommand :: Command -> InputT (StateT PSCiState IO) ()
handleCommand (Expression val) = lift get >>= handleDeclaration val
handleCommand Help = outputStrLn helpMessage
handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
handleCommand (Let l) = lift $ modify (updateLets l)
handleCommand (LoadFile filePath) = do
  absPath <- lift . lift $ expandTilde filePath
  exists <- lift . lift $ doesFileExist absPath
  if exists then do
    lift $ modify (updateImportedFiles absPath)
    either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)
  else
    outputStrLn $ "Couldn't locate: " ++ filePath
handleCommand Reset = do
  files <- psciImportedFilenames <$> lift get
  modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) files
  case modulesOrFirstError of
    Left err -> lift . lift $ putStrLn err >> exitFailure
    Right modules -> lift $ put (PSCiState files defaultImports modules [])
handleCommand (TypeOf val) = lift get >>= handleTypeOf val
handleCommand _ = outputStrLn "Unknown command"

inputFiles :: Cmd.Term [FilePath]
inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
                                                     , Cmd.posDoc = "Optional .purs files to load on start" }

loadUserConfig :: IO (Maybe [Command])
loadUserConfig = do
  configFile <- (</> ".psci") <$> getCurrentDirectory
  exists <- doesFileExist configFile
  if exists
  then do
    ls <- lines <$> U.readFile configFile
    case mapM parseCommand ls of
      Left err -> U.print err >> exitFailure
      Right cs -> return $ Just cs
  else
    return Nothing

-- |
-- The PSCI main loop.
--
loop :: [FilePath] -> IO ()
loop files = do
  config <- loadUserConfig
  preludeFilename <- getPreludeFilename
  modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)
  case modulesOrFirstError of
    Left err -> putStrLn err >> exitFailure
    Right modules -> do
      historyFilename <- getHistoryFilename
      let settings = defaultSettings {historyFile = Just historyFilename}
      flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
        outputStrLn prologueMessage
        traverse_ (mapM_ handleCommand) config
        go
      where
        go :: InputT (StateT PSCiState IO) ()
        go = do
          c <- getCommand
          case c of
            Left err -> outputStrLn (show err) >> go
            Right Nothing -> go
            Right (Just Quit) -> outputStrLn quitMessage
            Right (Just c') -> handleCommand c' >> go

term :: Cmd.Term (IO ())
term = loop <$> inputFiles

termInfo :: Cmd.TermInfo
termInfo = Cmd.defTI
  { Cmd.termName = "psci"
  , Cmd.version  = showVersion Paths.version
  , Cmd.termDoc  = "Interactive mode for PureScript"
  }

main :: IO ()
main = Cmd.run (term, termInfo)