Skip to content

Commit ebdb4a1

Browse files
tanitani
committed
Merge branch 'feat/microhs-cache-persistence'
2 parents f927206 + a629d20 commit ebdb4a1

File tree

10 files changed

+370
-330
lines changed

10 files changed

+370
-330
lines changed

‎CMakeLists.txt‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -130,6 +130,8 @@ build_and_install_libmhs(${MICROHS_BIN} ${MICROHS_SRC_DIR})
130130

131131
add_library(mhs_repl_lib STATIC
132132
src/mhs_repl.cpp
133+
src/mhs_stdout_capture_posix.cpp
134+
src/mhs_stdout_capture_win.cpp
133135
)
134136

135137
add_dependencies(mhs_repl_lib mhs_obj)

‎src/Repl.hs‎

Lines changed: 56 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,6 @@ import MHSPrelude
2020
import Control.Exception (try, SomeException, displayException)
2121
import Data.IORef
2222
import Data.List (nub)
23-
import Data.Text (pack, unpack)
2423
import System.IO (putStrLn)
2524

2625
import Foreign.C.String (CString, peekCString, peekCStringLen, newCString)
@@ -32,9 +31,7 @@ import Foreign.Storable (poke)
3231

3332
import Repl.Context
3433
import Repl.Error
35-
import Repl.Utils
3634
import Repl.Analysis
37-
import Repl.Compiler
3835
import Repl.Executor
3936

4037
--------------------------------------------------------------------------------
@@ -80,54 +77,80 @@ mhsReplFreeCString :: CString -> IO ()
8077
mhsReplFreeCString = free
8178

8279
--------------------------------------------------------------------------------
83-
-- Unified runner
80+
-- Unified runners
8481
--------------------------------------------------------------------------------
8582

86-
runReplAction
87-
:: (ReplCtx -> String -> IO (Either ReplError ReplCtx))
88-
-> ReplHandle -> CString -> CSize -> Ptr CString -> IO CInt
89-
runReplAction act h srcPtr srcLen errPtr = do
83+
withHandleInput
84+
:: ReplHandle
85+
-> CString
86+
-> CSize
87+
-> (IORef ReplCtx -> String -> IO a)
88+
-> IO a
89+
withHandleInput h srcPtr srcLen k = do
9090
ref <- deRefStablePtr h
9191
src <- peekSource srcPtr srcLen
92-
ctx <- readIORef ref
93-
result <- try (act ctx src) :: IO (Either SomeException (Either ReplError ReplCtx))
94-
let normalized = case result of
95-
Left ex -> Left (ReplRuntimeError (displayException ex))
96-
Right r -> r
97-
case normalized of
98-
Left e -> writeErrorCString errPtr (prettyReplError e) >> pure c_ERR
99-
Right ctx' -> writeIORef ref ctx' >> pure c_OK
92+
k ref src
93+
94+
normalizeResult
95+
:: Either SomeException (Either ReplError a)
96+
-> Either ReplError a
97+
normalizeResult result =
98+
case result of
99+
Left ex -> Left (ReplRuntimeError (displayException ex))
100+
Right val -> val
101+
102+
runStatefulAction
103+
:: (ReplCtx -> String -> IO (Either ReplError ReplCtx))
104+
-> ReplHandle
105+
-> CString
106+
-> CSize
107+
-> Ptr CString
108+
-> IO CInt
109+
runStatefulAction act h srcPtr srcLen errPtr =
110+
withHandleInput h srcPtr srcLen $ \ref src -> do
111+
ctx <- readIORef ref
112+
result <- try (act ctx src) :: IO (Either SomeException (Either ReplError ReplCtx))
113+
case normalizeResult result of
114+
Left err -> writeErrorCString errPtr (prettyReplError err) >> pure c_ERR
115+
Right ctx' -> writeIORef ref ctx' >> pure c_OK
116+
117+
runQueryAction
118+
:: (ReplCtx -> String -> IO (Either ReplError String))
119+
-> ReplHandle
120+
-> CString
121+
-> CSize
122+
-> Ptr CString
123+
-> IO CInt
124+
runQueryAction act h srcPtr srcLen outPtr =
125+
withHandleInput h srcPtr srcLen $ \ref src -> do
126+
ctx <- readIORef ref
127+
result <- try (act ctx src) :: IO (Either SomeException (Either ReplError String))
128+
case normalizeResult result of
129+
Left err -> writeErrorCString outPtr (prettyReplError err) >> pure c_ERR
130+
Right value -> newCString value >>= poke outPtr >> pure c_OK
100131

101132
--------------------------------------------------------------------------------
102133
-- Public FFI API
103134
--------------------------------------------------------------------------------
104135

105136
mhsReplDefine :: ReplHandle -> CString -> CSize -> Ptr CString -> IO CInt
106-
mhsReplDefine = runReplAction replDefine
137+
mhsReplDefine = runStatefulAction replDefine
107138

108139
mhsReplRun :: ReplHandle -> CString -> CSize -> Ptr CString -> IO CInt
109-
mhsReplRun = runReplAction replRun
140+
mhsReplRun = runStatefulAction replRun
110141

111142
mhsReplExecute :: ReplHandle -> CString -> CSize -> Ptr CString -> IO CInt
112-
mhsReplExecute = runReplAction replExecute
143+
mhsReplExecute = runStatefulAction replExecute
113144

114145
mhsReplIsComplete :: ReplHandle -> CString -> CSize -> IO CString
115-
mhsReplIsComplete h srcPtr srcLen = do
116-
ref <- deRefStablePtr h
117-
src <- peekSource srcPtr srcLen
118-
ctx <- readIORef ref
119-
status <- replIsComplete ctx src
120-
newCString status
146+
mhsReplIsComplete h srcPtr srcLen =
147+
withHandleInput h srcPtr srcLen $ \ref src -> do
148+
ctx <- readIORef ref
149+
status <- replIsComplete ctx src
150+
newCString status
121151

122152
mhsReplInspect :: ReplHandle -> CString -> CSize -> Ptr CString -> IO CInt
123-
mhsReplInspect h srcPtr srcLen resPtr = do
124-
ref <- deRefStablePtr h
125-
name <- peekSource srcPtr srcLen
126-
ctx <- readIORef ref
127-
result <- replInspect ctx name
128-
case result of
129-
Left e -> writeErrorCString resPtr (prettyReplError e) >> pure c_ERR
130-
Right info -> newCString info >>= poke resPtr >> pure c_OK
153+
mhsReplInspect = runQueryAction replInspect
131154

132155
mhsReplCanParseDefinition :: CString -> CSize -> IO CInt
133156
mhsReplCanParseDefinition ptr len = do

‎src/Repl/Analysis.hs‎

Lines changed: 48 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,10 @@ module Repl.Analysis (
22
canParseDefinition,
33
canParseExpression,
44
extractDefinitionNames,
5+
SplitPlan(..),
6+
firstValidSplitPlan,
7+
trimWs,
8+
matchKeywordPrefix,
59
completionCandidates,
610
reservedIds,
711
isIncomplete
@@ -10,14 +14,19 @@ module Repl.Analysis (
1014
import qualified Prelude ()
1115
import MHSPrelude
1216
import Data.List (nub)
17+
import Data.Maybe (listToMaybe, mapMaybe)
1318

1419
import MicroHs.Parse (parse, pExprTop, pTopModule)
1520
import MicroHs.Expr (EModule(..), EDef(..), patVars)
1621
import MicroHs.Ident (Ident, SLoc(..))
1722
import MicroHs.Lex (Token(..), lex)
1823

1924
import Repl.Error
20-
import Repl.Utils (ensureTrailingNewline, buildModule)
25+
import Repl.Utils (ensureTrailingNewline, buildModule, indent, allwsLine, isws)
26+
27+
data SplitPlan
28+
= SplitDefineOnly String
29+
| SplitDefineThenRun String String
2130

2231
--------------------------------------------------------------------------------
2332
-- Parser helpers
@@ -106,3 +115,41 @@ isIncomplete s = go [] s
106115
match '[' ']' = True
107116
match '{' '}' = True
108117
match _ _ = False
118+
119+
firstValidSplitPlan :: String -> String -> Maybe SplitPlan
120+
firstValidSplitPlan currentDefs snippet =
121+
let snippetLines = lines (ensureTrailingNewline snippet)
122+
in listToMaybe (mapMaybe (classifySplit currentDefs snippetLines) [length snippetLines, length snippetLines - 1 .. 0])
123+
124+
classifySplit :: String -> [String] -> Int -> Maybe SplitPlan
125+
classifySplit currentDefs snippetLines splitIndex
126+
| not (canParseDefinition candidateDefs) = Nothing
127+
| all allwsLine runLines = Just (SplitDefineOnly defPart)
128+
| canParseExpression runPart = Just (SplitDefineThenRun defPart runPart)
129+
| canParseExpression doRunPart = Just (SplitDefineThenRun defPart doRunPart)
130+
| otherwise = Nothing
131+
where
132+
(defLines, runLines) = splitAt splitIndex snippetLines
133+
defPart = unlines defLines
134+
runPart = unlines (dropWhileEndLocal allwsLine runLines)
135+
doRunPart = "do\n" ++ indent runPart
136+
candidateDefs = currentDefs ++ defPart
137+
138+
dropWhileEndLocal :: (a -> Bool) -> [a] -> [a]
139+
dropWhileEndLocal f = reverse . dropWhile f . reverse
140+
141+
trimWs :: String -> String
142+
trimWs = dropWhile isws . reverse . dropWhile isws . reverse
143+
144+
matchKeywordPrefix :: String -> String -> Maybe String
145+
matchKeywordPrefix keyword snippet
146+
| startsWith keyword snippet && hasBoundary keyword snippet =
147+
Just (drop (length keyword) snippet)
148+
| otherwise = Nothing
149+
where
150+
hasBoundary key s =
151+
let rest = drop (length key) s
152+
in null rest || isws (head rest)
153+
154+
startsWith :: String -> String -> Bool
155+
startsWith prefix s = take (length prefix) s == prefix

0 commit comments

Comments
 (0)