tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

REPL.hs (10041B)

      1 -- Interactive input is assembled into native modules, never parsed by the
      2 -- recovery frontend. Each successful submission is a transaction on source state.
      3 module REPL where
      4 
      5 import Runtime (EvaluatedForm(..), Env, T, formatT)
      6 import ContentStore (StorePath(..), AliasKind(..), ObjectRef(..), readAlias, unDomain)
      7 import Module.Manifest (manifestDomain)
      8 import Control.Exception (SomeException, AsyncException, catch, displayException, evaluate, fromException, throwIO)
      9 import Control.Monad (unless)
     10 import Control.Monad.IO.Class (liftIO)
     11 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
     12 import Data.List (isPrefixOf, sort)
     13 import Data.Char (isAlpha, isAlphaNum)
     14 import System.Console.Haskeline
     15 import qualified Data.Map as Map
     16 import qualified Data.Text as Text
     17 
     18 -- Replacing a definition replaces its whole equation group. Other definitions
     19 -- are rebuilt against the new source, rather than retaining obsolete closures.
     20 data Session = Session
     21   { sessionImports :: [String]
     22   , sessionDefinitions :: [(String, String)]
     23   , sessionForm :: EvaluatedForm
     24   , sessionStore :: StorePath
     25   }
     26 
     27 -- Classification is a convenience only; syntax/namespace validation belongs to
     28 -- the portable compiler. !def NAME blocks support every equation/layout form;
     29 -- !expr blocks remove any ambiguity for expressions containing '='.
     30 definitionName :: String -> Maybe String
     31 definitionName input = case words input of
     32   name : _ | valid name && name `notElem` ["let", "case", "do", "t"]
     33              && definitionEquals input -> Just name
     34   _ -> Nothing
     35   where
     36     valid [] = False
     37     valid (c:cs) = (isAlpha c || c == '_') && all (\x -> isAlphaNum x || x `elem` ("_?'-" :: String)) cs
     38 
     39 -- Ignore quoted '=', comments and nested expressions when selecting the
     40 -- convenience definition route. Ambiguous advanced heads use !def explicitly.
     41 definitionEquals :: String -> Bool
     42 definitionEquals = scan (0 :: Int) False
     43   where
     44     scan _ _ [] = False
     45     scan depth True ('\\':_:rest) = scan depth True rest
     46     scan depth quoted ('"':rest) = scan depth (not quoted) rest
     47     scan depth True (_:rest) = scan depth True rest
     48     scan _ False ('-':'-':_) = False
     49     scan depth False (c:rest)
     50       | c `elem` ("([{" :: String) = scan (depth + 1) False rest
     51       | c `elem` (")]}" :: String) && c /= ' ' = scan (depth - 1) False rest
     52       | c == '=' && depth == 0 = True
     53       | otherwise = scan depth False rest
     54 
     55 sessionSource :: Session -> String -> String
     56 sessionSource state expression = unlines (sessionImports state) ++
     57   "!export *\n" ++ concatMap ((++ "\n") . snd) (sessionDefinitions state) ++
     58   "replResult = (" ++ expression ++ ")\n"
     59 
     60 portableRepl :: StorePath -> (StorePath -> String -> IO [(String, T)])
     61              -> (StorePath -> FilePath -> IO Text.Text) -> IO ()
     62 portableRepl store compile load = do
     63   ref <- newIORef Map.empty
     64   let settings = Settings (completeRepl ref) Nothing True
     65   runInputT settings (loop ref (Session [] [] Decode store))
     66   where
     67     loop ref state = do
     68       input <- getInputLine "tricu < "
     69       case fmap strip input of
     70         Nothing -> pure ()
     71         Just "!exit" -> pure ()
     72         Just "" -> loop ref state
     73         Just "!clear" -> outputStr "\ESC[2J\ESC[H" >> loop ref state
     74         Just "!help" -> outputStrLn help >> loop ref state
     75         Just "!env" -> do
     76           env <- liftIO $ readIORef ref
     77           mapM_ outputStrLn (Map.keys env)
     78           loop ref state
     79         Just "!reset" -> do
     80           liftIO $ writeIORef ref Map.empty
     81           loop ref state { sessionImports = [], sessionDefinitions = [] }
     82         Just "!output" -> do
     83           outputStrLn "tree|fsl|ast|ternary|ascii|decode|number|string"
     84           choice <- getInputLine "format < "
     85           setFormat ref state (maybe "" id choice)
     86         Just line | "!format " `isPrefixOf` line -> setFormat ref state (drop 8 line)
     87                   | line == "!store" -> outputStrLn (unStorePath $ sessionStore state) >> loop ref state
     88                   | "!store " `isPrefixOf` line -> loop ref state { sessionStore = StorePath (drop 7 line) }
     89                   | "!def " `isPrefixOf` line -> do
     90                       body <- block
     91                       submit ref state (Just $ strip $ drop 5 line) body
     92                   | line == "!expr" -> block >>= submit ref state Nothing
     93                   | otherwise -> submit ref state (definitionName line) line
     94 
     95     block = do
     96       outputStrLn "Enter source; !end submits (EOF cancels)."
     97       gather []
     98       where
     99         gather rows = do
    100           next <- getInputLine "... "
    101           case next of
    102             Nothing -> pure ""
    103             Just "!end" -> pure $ unlines $ reverse rows
    104             Just row -> gather (row:rows)
    105 
    106     setFormat ref state value = case readEvaluatedForm value of
    107       Nothing -> outputStrLn "Unknown output format" >> loop ref state
    108       Just form -> loop ref state { sessionForm = form }
    109 
    110     submit ref state named input = do
    111       next <- liftIO $ transaction ref state named input `catch` \(err :: SomeException) ->
    112         case fromException err :: Maybe AsyncException of
    113           Just asynchronous -> throwIO asynchronous
    114           Nothing -> putStrLn ("Error: " ++ displayException err) >> pure state
    115       loop ref next
    116 
    117     transaction ref state (Just name) input
    118       | null input = pure state -- EOF cancels a multiline block.
    119       | name == "replResult" = ioError $ userError "replResult is reserved by the session"
    120       | otherwise = commit ref state { sessionDefinitions =
    121           filter ((/= name) . fst) (sessionDefinitions state) ++ [(name,input)] } "t" False
    122     transaction ref state Nothing input
    123       | null input || "--" `isPrefixOf` input = pure state
    124       | "!load " `isPrefixOf` input = do
    125           pin <- load (sessionStore state) (strip $ drop 6 input)
    126           commit ref state { sessionImports = sessionImports state ++ ["!import " ++ Text.unpack pin ++ " *"] } "t" False
    127       | "!use " `isPrefixOf` input = case words (drop 5 input) of
    128           [pin] -> useModule pin " *"
    129           [pin, namespace] -> useModule pin (" as " ++ namespace)
    130           _ -> ioError $ userError "Usage: !use MANIFEST [NAMESPACE]"
    131       | "!import " `isPrefixOf` input = addImport input
    132       | "!" `isPrefixOf` input = ioError $ userError "Unknown command; see !help"
    133       | otherwise = commit ref state input True
    134       where
    135         useModule target suffix = do
    136           alias <- readAlias (sessionStore state) ModuleAlias (Text.pack target)
    137           pin <- case alias of
    138             Nothing -> pure target
    139             Just value | objectRefKind value == unDomain manifestDomain -> pure (Text.unpack $ objectRefHash value)
    140             _ -> ioError $ userError "Module alias has wrong object kind"
    141           addImport ("!import " ++ pin ++ suffix)
    142         addImport line = commit ref state { sessionImports = sessionImports state ++ [line] } "t" False
    143 
    144     commit ref candidate expression display = do
    145       exports <- compile (sessionStore candidate) (sessionSource candidate expression)
    146       -- The portable compiler's complete local interface is authoritative.
    147       -- A named block must replace exactly its group, not silently add/remove
    148       -- other names. Validate before publishing session/completion state.
    149       let expected = sort ("replResult" : map fst (sessionDefinitions candidate))
    150           actual = sort (map fst exports)
    151       unless (actual == expected) $ ioError $ userError
    152         "Definition block must define exactly its named equation group"
    153       let env = Map.fromList exports
    154       value <- maybe (ioError $ userError "Portable session result missing") pure (Map.lookup "replResult" env)
    155       if display then do
    156         let rendered = formatT (sessionForm candidate) value
    157         _ <- evaluate (length rendered)
    158         putStrLn rendered
    159         else pure ()
    160       writeIORef ref (Map.delete "replResult" env)
    161       pure candidate
    162 
    163     help = unlines
    164       [ "Definitions replace the previous equation group; expressions do not persist."
    165       , "!def NAME / !expr: multiline input through !end; !import: native import"
    166       , "!load FILE: compile and open its exports; !use MANIFEST [NS]: pinned import"
    167       , "!env !reset !store [PATH] !format FORM !output !clear !exit"
    168       , "Imports resolve from the current directory; no implicit prelude."
    169       , "Failed submissions preserve successful session source and completion state."
    170       ]
    171 
    172 completeRepl :: IORef Env -> CompletionFunc IO
    173 completeRepl envRef input@(left, _right)
    174   | commandWantsFile line = completeFilename input
    175   | "!" `isPrefixOf` line = completeWord Nothing " \t" completeCommands input
    176   | otherwise = completeWord Nothing termBreakChars completeTerms input
    177   where
    178     line = reverse left
    179     completeCommands str = return $ map simpleCompletion $
    180       filter (str `isPrefixOf`) commands
    181     completeTerms str = do
    182       env <- readIORef envRef
    183       return $ map simpleCompletion $
    184         filter (str `isPrefixOf`) (sort $ Map.keys env)
    185     commands =
    186       [ "!exit"
    187       , "!output"
    188       , "!format"
    189       , "!clear"
    190       , "!reset"
    191       , "!help"
    192       , "!load"
    193       , "!use"
    194       , "!store"
    195       , "!env"
    196       , "!def"
    197       , "!expr"
    198       , "!import"
    199       ]
    200     commandWantsFile inputLine = "!load " `isPrefixOf` inputLine
    201     termBreakChars = " \t\n\r()[]{}\"'"
    202 
    203 outputFormats :: [EvaluatedForm]
    204 outputFormats = [Decode, Tree, FSL, AST, Ternary, Ascii, Number, StringLit]
    205 
    206 readEvaluatedForm :: String -> Maybe EvaluatedForm
    207 readEvaluatedForm s = case s of
    208   "tree"    -> Just Tree
    209   "fsl"     -> Just FSL
    210   "ast"     -> Just AST
    211   "ternary" -> Just Ternary
    212   "ascii"   -> Just Ascii
    213   "decode"  -> Just Decode
    214   "number"  -> Just Number
    215   "string"  -> Just StringLit
    216   _         -> Nothing
    217 
    218 storePathString :: StorePath -> FilePath
    219 storePathString (StorePath path) = path
    220 
    221 strip :: String -> String
    222 strip = f . f
    223   where f = reverse . dropWhile (`elem` [' ', '\t', '\n', '\r'])
    224 
    225 readMaybeInt :: String -> Maybe Int
    226 readMaybeInt s = case reads s of
    227   [(n, "")] -> Just n
    228   _ -> Nothing