Sire.hs (44502B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 {-# OPTIONS_GHC -Wall #-} 6 {-# OPTIONS_GHC -Werror #-} 7 8 module Sire (main, loadFile, planRexFull) where 9 10 import Control.Monad.Trans.State.Strict hiding (get, put, modify') 11 import Control.Monad.State.Class 12 13 import Data.Sorted 14 import PlunderPrelude hiding (hGetContents) 15 import Sire.Types 16 import System.FilePath.Posix 17 18 import Data.Text.IO (hPutStrLn) 19 import Fan (Fan(COw, NAT, NAT, ROW, TAb), (%%)) 20 import Fan.Convert (FromNoun(fromNoun), ToNoun(toNoun)) 21 import Fan.FFI (c_jet_blake3) 22 import Fan.Seed (LoadErr(..), loadPod, savePod) 23 import Foreign.Marshal.Alloc (allocaBytes) 24 import Foreign.Ptr (castPtr) 25 import Loot.Backend (loadClosure, loadShallow) 26 import Loot.ReplExe (closureRex, dieFan, showFan, trkFan, trkRex, rexToPex) 27 import Loot.Syntax (boxRex, keyBox) 28 import Rex (GRex, rexLine) 29 import Rex.Print (RexColor, RexColorScheme(NoColors)) 30 import Sire.Backend (eval, hasRefTo) 31 import System.Directory (doesFileExist) 32 import System.IO (hGetContents) 33 import System.Exit (exitWith, ExitCode(ExitFailure,ExitSuccess)) 34 35 import Fan.PlanRex (PlanRex(..), Pex, nounPex, pexNoun) 36 import Fan.PlanRex (pattern EMBD, pattern EVIL, pattern LEAF, pattern NODE) 37 import Fan.PlanRex (pattern WORD, pattern TEXT) 38 import Fan.PlanRex (pattern OPEN, pattern PREF, pattern SHUT, pattern INFX) 39 40 import qualified Data.ByteString as BS 41 import qualified Data.ByteString.Unsafe as BS 42 import qualified Data.Char as C 43 import qualified Data.List as L 44 import qualified Data.Set as S 45 import qualified Data.Text as T 46 import qualified Fan as F 47 import qualified Fan.Prof as Prof 48 import qualified Rex as Rx 49 import qualified Rex.Policy as Rex 50 import qualified Rex.Mechanism as Rex 51 52 53 -- Local Types ----------------------------------------------------------------- 54 55 type Any = Fan 56 type Str = Nat 57 type Rex = GRex Any 58 59 newtype Repl a = REPL (StateT Any IO a) 60 deriving newtype (Functor, Applicative, Monad, MonadIO, MonadState Fan) 61 62 data Context = CONTEXT 63 { file :: !Text 64 , line :: !Int 65 , rex :: !Pex 66 } 67 deriving (Eq, Ord) 68 69 70 type InCtx = (?ctx :: Context) 71 72 73 --------------- 74 -- Functions -- 75 --------------- 76 77 mkState :: Any -> Any -> Any -> Any -> Any 78 mkState nex ctxVal scope modules = 79 ROW (arrayFromListN 4 [nex, ctxVal, scope, modules]) 80 81 initialSireStateAny :: Any 82 initialSireStateAny = mkState 1 0 (TAb mempty) (TAb mempty) 83 84 runRepl :: Repl a -> Any -> Any 85 runRepl (REPL act) ini = unsafePerformIO (execStateT act ini) 86 87 88 -- Loading States -------------------------------------------------------------- 89 90 -- This lazily loads a state object and crashes if something isn't 91 -- as expected. This is intended only for doing queries on specific 92 -- components of the state, doing a full load in this way is very 93 -- expensive. 94 95 getRow :: Any -> Maybe (Array Any) 96 getRow (ROW x) = Just x 97 getRow _ = Nothing 98 99 getLam :: Any -> Lam 100 getLam record = 101 fromMaybe (error badRec) $ do 102 params <- getRow record 103 case toList params of 104 [p,m,r,t,a,b] -> Just 105 let 106 !pin = getBit p "pinned" 107 !mark = getBit m "inline" 108 !body = getSyr b 109 !recr = getBit r "is recurisve" 110 !tag = getNat t "lambda tag" 111 !args = getNat a "lambda args" 112 in 113 LAM{pin,mark,body,args,tag,recr} 114 _ -> Nothing 115 where 116 badRec = "bad Lambda Record:\n\n" <> unpack (planText record) 117 118 badBit cx txt = 119 "bad flag when reading lambda from state: " <> cx <> " " <> txt 120 121 getBit (NAT 0) _ = False 122 getBit (NAT 1) _ = True 123 getBit val cx = error (badBit cx $ show val) 124 125 getSyr :: Any -> Sire 126 getSyr topVal = fromMaybe (error $ "bad Sire AST:\n\n" <> unpack (planText topVal)) do 127 params <- getRow topVal 128 case toList params of 129 [NAT "V", NAT n] -> Just $ V n 130 [NAT "G", x] -> Just $ G (getBinding "glo" x) 131 [NAT "K", x] -> Just $ K x 132 [NAT "A", f, x] -> Just $ A (getSyr f) (getSyr x) 133 [NAT "L", v, b] -> Just $ L (getSyr v) (getSyr b) 134 [NAT "R", v, b] -> Just $ R (getBinds v) (getSyr b) 135 [NAT "F", l] -> Just $ F (getLam l) 136 [NAT "M", x] -> Just $ M (getSyr x) 137 _ -> Nothing 138 where 139 getBinds :: Fan -> [Sire] 140 getBinds (ROW bs) = toList (getSyr <$> bs) 141 getBinds _ = error "let binder seq is not a row" 142 143 getPin :: Any -> Maybe Any 144 getPin (F.PIN p) = Just p.item 145 getPin _ = Nothing 146 147 getBinding :: String -> Any -> Bind 148 getBinding _ctx bindPin = fromMaybe badBinding $ do 149 -- case bindPin of 150 -- F.PIN _ -> traceM ("getBinding " ++ ctx ++ " (PIN)") 151 -- _ -> traceM ("getBinding " ++ ctx ++ " (not a pin!)") 152 pin <- getPin bindPin 153 -- case pin of 154 -- ROW r -> traceM $ "getBinding " <> ctx <> " (ROW): length=" <> show (length r) 155 -- _ -> traceM $ "getBinding " <> ctx <> " (not a row!)" 156 row <- getRow pin 157 158 guard (length row == 6) 159 160 let datum = BIND_DATA 161 { key = getNat (row!0) "binding key" 162 , value = row!1 163 , code = getSyr (row!2) 164 , location = row!3 165 , name = row!4 166 , props = row!5 167 } 168 169 pure (BIND datum bindPin) 170 where 171 bindContents = case bindPin of F.PIN x -> x.item; _ -> "MALFORMED" 172 badBinding = error ( "Malformed binding:\n" 173 <> unpack (planText bindPin) <> "\n" 174 <> unpack (planText bindContents) 175 ) 176 177 getNat :: Any -> String -> Nat 178 getNat (NAT n) _ = n 179 getNat _ msg = error msg 180 181 getTable :: String -> String -> (Fan -> v) -> Fan -> Tab Any v 182 getTable field ctx getVal = \case 183 TAb vals -> map getVal vals 184 _ -> error ("invalid `" <> field <> "` field in " <> ctx) 185 186 187 getScope :: Any -> Tab Any Bind 188 getScope = getTable "scope" "state" (getBinding "scope") 189 190 getState :: Any -> SireState 191 getState stAny = fromMaybe badState $ do 192 let (nexVal, ctxVal, scopeVal, modVal) = getStateFields stAny 193 194 pure $ SIRE_STATE 195 { nextKey = getNat nexVal "invalid `nextKey` field in state" 196 , context = getNat ctxVal "invalid `context` field in state" 197 , scope = getScope scopeVal 198 , modules = getModules modVal 199 } 200 where 201 badState = error "Malformed sire state" 202 203 getModules :: Any -> Tab Any (Tab Any Bind) 204 getModules = getTable "modules" "state" (getPinned "module" getScope) 205 206 getPinned :: Text -> (Any -> a) -> (Any -> a) 207 getPinned location getItem = \case 208 F.PIN p -> getItem p.item 209 _ -> error ("Expected a pin when loading: " <> unpack location) 210 211 212 lookupVal :: Text -> Any -> Maybe Any 213 lookupVal str stAny = do 214 bind <- lookup (NAT $ utf8Nat str)(getState stAny).scope 215 pure bind.bd.value 216 217 218 -- Modifying States ------------------------------------------------------------ 219 220 -- The cache saves states that have been finalized (and switched into 221 -- the REPL module). This saves space because it moves the "current 222 -- context" into a pin, which will be shared by all ofther modules 223 -- (instead of having it pinned in later modules, but unpinned in 224 -- the state) 225 -- 226 -- However, this is a hack, so we have to undo that hack in order to 227 -- reconstruct the desired state. 228 revertSwitchToRepl :: Text -> Any -> Any 229 revertSwitchToRepl modu oldSt = 230 mkState nex ctxVal scope newModules 231 where 232 ctxVal = NAT (utf8Nat modu) 233 234 (nex, _, _, oldModVal) = getStateFields oldSt 235 236 oldModTab = getTable "recover" "modules" id oldModVal 237 238 newModules = TAb (tabDelete ctxVal oldModTab) 239 240 oldScopeVal = 241 fromMaybe (error "missing old scope in recovery") $ 242 lookup ctxVal oldModTab 243 244 scope = fromMaybe (error "module is not a pin (in revert)") 245 $ getPin oldScopeVal 246 247 {- 248 Because we are constantly threading the sire state through macro, 249 we can't keep it around in a type-safe representation. 250 251 Fortunately, the number of state-update operations that are needed 252 in Sire itself is quite small. 253 254 This implements all of the state transitions, see `SIRE_SPEC.md` 255 for details. 256 -} 257 258 switchToContext :: Str -> Any -> Any 259 switchToContext newCtx oldSt = 260 force (mkState nextKey (NAT newCtx) (TAb mempty) newModules) 261 where 262 (nextKey, oldCtxVal, oldScope, oldModVal) = getStateFields oldSt 263 264 oldContext = getNat oldCtxVal "invalid `contenxt` field in state" 265 266 oldModules = case oldModVal of 267 TAb t -> t 268 _ -> error "`modules` table is not a tab" 269 270 newModules = 271 if (oldContext == 0) then 272 TAb oldModules 273 else 274 TAb (insertMap (NAT oldContext) (F.mkPin oldScope) oldModules) 275 276 277 getStateFields :: Any -> (Any, Any, Any, Any) 278 getStateFields = \case 279 ROW v | length v == 4 -> 280 (v!0, v!1, v!2, v!3) 281 ROW _ -> 282 error "Invalid state object: row does not have four fields" 283 _ -> 284 error "Invalid state object: not a row" 285 286 287 filterScope :: InCtx => Set Str -> Any -> Any 288 filterScope whitelist st = 289 if not (null bogus) 290 then parseFail_ (WORD "logic error" Nothing) st 291 ("filter for non-existing keys: " <> intercalate ", " bogus) 292 else mkState nextKey context (TAb newScope) modules 293 where 294 (nextKey, context, scopeVal, modules) = getStateFields st 295 296 oldScope = case scopeVal of 297 TAb t -> t 298 _ -> error "state.scope is not a TAb" 299 300 filt (NAT k) _ = (k `member` whitelist) 301 filt _ _ = error "non-nat key in scope" 302 303 newScope :: Tab Any Any 304 !newScope = tabFilterWithKey filt oldScope 305 306 bogus :: [Text] 307 bogus = fmap showKey 308 $ filter (not . (`member` oldScope) . NAT) $ toList whitelist 309 310 importModule :: InCtx => Pex -> Str -> Maybe (Set Str) -> Any -> Any 311 importModule blockRex modu mWhitelist stVal = 312 mkState nextKey context (TAb newScope) modulesVal 313 where 314 moduleBinds :: Tab Any Any 315 moduleBinds = either (parseFail_ blockRex stVal) id do 316 modules <- 317 case modulesVal of 318 TAb tab -> Right tab 319 _ -> Left "state.modules is not a tab" 320 321 case lookup (NAT modu) modules of 322 Just (F.PIN F.P{item = TAb t}) -> pure t 323 Just{} -> Left nonPin 324 Nothing -> Left (notLoaded modu) 325 326 nonPin :: Text 327 nonPin = "module is not a pin" 328 329 notLoaded :: Nat -> Text 330 notLoaded m = "Module not loaded: " <> showKey m 331 332 newBinds :: Tab Any Any 333 newBinds = 334 case mWhitelist of 335 Nothing -> moduleBinds 336 Just ws -> 337 case filter (not . isInModule) (toList ws) of 338 [] -> tabFilterWithKey isInWhitelist moduleBinds 339 ss -> parseFail_ blockRex stVal 340 $ (<>) "imported symbols do not exist: " 341 (tshow $ fmap showKey ss) 342 where 343 isInModule n = NAT n `member` moduleBinds 344 345 isInWhitelist (NAT n) _ = (n `member` ws) 346 isInWhitelist _ _ = False 347 348 newScope :: Tab Any Any 349 !newScope = case scopeVal of 350 TAb sco -> tabUnion newBinds sco -- left biased 351 _ -> error "state.scope is not a tab" 352 353 (nextKey, context, scopeVal, modulesVal) = getStateFields stVal 354 355 {- 356 If both maps contain properties for the same binding key, the two 357 property-sets are merged. If two property sets for the same key 358 contain the same property, the ones from `x` are chosen. 359 mergeProps 360 :: Tab Any (Tab Any Any) 361 -> Tab Any (Tab Any Any) 362 -> Tab Any (Tab Any Any) 363 mergeProps x y = tabUnionWith tabUnion x y 364 -} 365 366 insertBinding 367 :: InCtx 368 => Pex 369 -> (Nat, Fan, Str, Any, Sire) 370 -> Any 371 -> Any 372 insertBinding rx (key, bindProps, name, val, code) stVal = 373 let 374 (nextKeyAny, context, oldScope, modules) = 375 getStateFields stVal 376 !nextKey = 377 case nextKeyAny of 378 NAT n -> n 379 _ -> parseFail_ rx stVal 380 "next-key slot in state is not a nat" 381 in if key == 0 then 382 -- If the binding key is not explicitly set, generate a new key 383 -- and use that. 384 insertBinding rx (nextKey, bindProps, name, val, code) $ 385 mkState (NAT (nextKey+1)) context oldScope modules 386 else let 387 binding = mkNewBind $ BIND_DATA 388 { key = key 389 , value = val 390 , code = code 391 , location = context 392 , name = NAT name 393 , props = bindProps 394 } 395 scope = case oldScope of 396 TAb t -> TAb (insertMap (NAT name) binding.noun t) 397 _ -> error "state.scope slot is not a tab" 398 in 399 mkState (NAT nextKey) context scope modules 400 401 expand :: InCtx => Any -> Pex -> Repl Pex 402 expand macro input = do 403 st <- get 404 case (macro %% st %% input.n %% onErr %% okOk) of 405 x@(ROW ro) -> 406 case toList ro of 407 [NAT msg, rex, NAT 0] -> macroError (nounPex rex) msg 408 [expo, newState, NAT 1] -> put newState $> nounPex expo 409 [_, _, NAT _] -> badExpo x "bad rex" 410 [_, _, _] -> badExpo x "bad tag" 411 _ -> badExpo x "not arity = 3" 412 x -> badExpo x "not row" 413 where 414 onErr = COw 3 %% NAT 0 415 okOk = COw 3 %% NAT 1 416 417 badExpo x why = parseFail input 418 $ (<>) ("Invalid macro expansion result(" <> why <> ")\n") 419 (planText x) 420 421 execute :: InCtx => Pex -> Repl () 422 execute rex = do 423 stVal <- get 424 case rex of 425 NODE _ rune _ _ -> case (lookupVal rune stVal, rune) of 426 ( Just mac, _ ) -> expand mac rex >>= execute 427 ( _, "#=" ) -> doDefine rune rex 428 ( _, "=" ) -> doDefine rune rex 429 ( _, "#*" ) -> multiCmd rex 430 ( _, "*" ) -> multiCmd rex 431 ( _, "####" ) -> doEnter rex 432 ( _, "^-^" ) -> doFilter rune mempty (Just rex) 433 ( _, "#^-^" ) -> doFilter rune mempty (Just rex) 434 ( _, "=?=" ) -> doAssert rune rex 435 ( _, "#=?=" ) -> doAssert rune rex 436 ( _, "#:|" ) -> doImport rex rune (Just rex) 437 ( _, ":|" ) -> doImport rex rune (Just rex) 438 _ | expRune rune -> execExpr rex 439 _ -> parseFail rex ("Unbound rune: " <> rune) 440 441 _ -> execExpr rex 442 443 getIndicatedModule :: String -> IO Text 444 getIndicatedModule pax = do 445 let (dir, fil) = splitFileName pax 446 unless (dir `elem` okDirs) invalid 447 case splitExtensions fil of 448 (modu, ".sire") -> pure (pack modu) 449 (modu, "") -> pure (pack modu) 450 _ -> invalid 451 where 452 453 okDirs :: [String] 454 okDirs = [ "", "./", "sire/", "./sire/" ] 455 456 invalid :: a 457 invalid = error ("Not a sire module: " <> pax) 458 459 {- 460 TODO: Caching 461 -} 462 main :: RexColor => [String] -> IO ExitCode 463 main moduleIndicators = do 464 465 modules <- traverse getIndicatedModule moduleIndicators 466 467 writeIORef F.vShowFan showFan 468 writeIORef F.vTrkFan trkFan 469 writeIORef F.vTrkRex trkRex 470 writeIORef F.vJetMatch (F.jetMatch) 471 472 let onCrash (F.PRIMOP_CRASH op arg) = do 473 dieFan op arg 474 pure (ExitFailure 2) 475 476 handle onCrash $ 477 Prof.withProcessName "Sire" $ 478 Prof.withThreadName "Sire" do 479 let go preloads modu = do 480 (ss, _hax) <- withCache \cache -> do 481 for_ preloads \pre -> do 482 doFile cache pre initialSireStateAny 483 doFile cache modu initialSireStateAny 484 repl ss (Just modu) 485 486 case reverse modules of 487 [] -> repl initialSireStateAny Nothing 488 m:ms -> go (reverse ms) m 489 490 pure ExitSuccess 491 492 -- TODO Take file lock. 493 withCache :: (IORef (Tab Any Any) -> IO a) -> IO a 494 withCache act = 495 bracket acquire release \(_, vCache) -> 496 act vCache 497 where 498 fil = "./sire.cache" 499 500 acquire :: IO (Tab Any Any, IORef (Tab Any Any)) 501 acquire = do 502 ex <- doesFileExist fil 503 c1 <- if not ex then 504 pure mempty 505 else do 506 byt <- Prof.withSimpleTracingEvent "read" "cache" $ readFile fil 507 pak <- Prof.withSimpleTracingEvent "load" "cache" $ loadPod byt 508 pure case pak of 509 Left (err :: LoadErr) -> 510 seq (error ("bad cache: " <> show err)) mempty 511 Right pin -> 512 case pin.item of 513 TAb t -> trace "loaded and hash matches" t 514 _ -> error "bad cache pin" 515 516 vCache <- newIORef c1 517 pure (c1, vCache) 518 519 release (c1, vCache) = do 520 c2 <- readIORef vCache 521 522 unless (c1 == c2) do 523 p <- F.mkPin' (TAb c2) 524 hPutStrLn stderr $ tshow ("cache hash":: Text, p.hash) 525 eByt <- Prof.withSimpleTracingEvent "save" "cache" $ try $ savePod p 526 case eByt of 527 Left (POD_INTEGRITY_CHECK_FAILED hax p2) -> do 528 trkRexM (planRexFull $ toNoun p) 529 trkRexM (planRexFull $ toNoun hax) 530 trkRexM (planRexFull $ toNoun p2) 531 Left (e :: LoadErr) -> do 532 trkRexM (planRexFull $ toNoun e) 533 pure () 534 Right byt -> do 535 () <- Prof.withSimpleTracingEvent "write" "cache" $ 536 writeFile fil byt 537 pure () 538 539 loadFile :: RexColor => FilePath -> IO Any 540 loadFile moduleIndicator = do 541 writeIORef F.vShowFan showFan 542 writeIORef F.vTrkFan trkFan 543 writeIORef F.vTrkRex trkRex 544 writeIORef F.vJetMatch (F.jetMatch) 545 546 modu <- getIndicatedModule moduleIndicator 547 548 (ss, _hax) <- withCache \cache -> 549 doFile cache modu initialSireStateAny 550 let scope = (getState ss).scope 551 case lookup "main" scope of 552 Nothing -> error "No `main` defined in this file" 553 Just vl -> pure vl.bd.value 554 555 readRexStream :: FilePath -> Handle -> IO [Either Text (Int, Rex)] 556 readRexStream pax = fmap (blox pax . fmap (encodeUtf8 . pack) . lines) . hGetContents 557 558 -- This just converts the `blockStep` state machine into a streaming 559 -- function and crashes on error. 560 blox :: FilePath -> [ByteString] -> [Either Text (Int, Rex)] 561 blox pax = go (Rex.blockState pax) 562 where 563 foo :: [Rex.Block] -> [Either Text (Int, Rex)] 564 foo = (bar <$>) 565 566 bar :: Rex.Block -> Either Text (Int, Rex) 567 bar blk = 568 case blk.errors of 569 e:_ -> Left e 570 [] -> Right (blk.lineNum, absurd <$> blk.rex) 571 572 go :: Rex.BlockState -> [ByteString] -> [Either Text (Int, Rex)] 573 go st [] = foo $ snd $ Rex.rexStep st Nothing 574 go st (b:bs) = let (st2, out) = Rex.rexStep st (Just b) 575 in foo out <> go st2 bs 576 577 inContext :: Text -> Int -> Pex -> (InCtx => IO a) -> IO a 578 inContext file line rex act = 579 let ?ctx = CONTEXT{rex, line, file} 580 in try act >>= \case 581 Right x -> pure x 582 Left (F.PRIMOP_CRASH op arg) -> 583 parseFail_ rex ss (planText $ toNoun (op, arg)) 584 where ss = initialSireStateAny 585 586 runSire :: Text -> Bool -> Any -> [Either Text (Int, Pex)] -> IO Any 587 runSire file inRepl s1 = \case 588 [] -> pure s1 589 Left msg : rs -> do 590 hPutStrLn stderr "\n" 591 hPutStrLn stderr msg 592 hPutStrLn stderr "\n" 593 if inRepl 594 then runSire file inRepl s1 rs 595 else exitWith (ExitFailure 1) 596 597 Right (ln,r) : rs -> do 598 !es2 <- try $ inContext file ln r 599 $ evaluate 600 $ runRepl (execute r) (toNoun s1) 601 case es2 of 602 Right s2 -> runSire file inRepl s2 rs 603 Left pc -> do 604 unless inRepl do throwIO (pc :: F.PrimopCrash) 605 trkM $ F.ROW $ arrayFromListN 3 606 $ ["crash", F.NAT pc.errCode, pc.errVal] 607 runSire file inRepl s1 rs 608 609 doFile :: IORef (Tab Any Any) -> Text -> Any -> IO (Any, ByteString) 610 doFile vCache modu s1 = do 611 let file = modu <> ".sire" 612 let pax = "./sire" </> unpack file 613 614 fileBytes <- readFile pax 615 616 topRexes <- openFile pax ReadMode >>= readRexStream pax 617 618 c1 <- readIORef vCache 619 620 let moduNoun = NAT (utf8Nat modu) 621 622 case fmap (over _2 rexToPex) <$> topRexes of 623 624 [] -> do 625 let msg = "Module declarations are required, but this file is empty" 626 let rex = TEXT "" Nothing 627 inContext file 0 rex $ parseFail_ rex s1 msg 628 629 -- No <- part means this is the starting point. 630 rexes@(Right (_ln, NODE _ "####" [_] Nothing) : _) -> do 631 Prof.withSimpleTracingEvent (encodeUtf8 modu) "Sire" do 632 -- Massive slow hack, stream two inputs separately. 633 -- (C interface does not currently support this) 634 let predHash = BS.replicate (32::Int) (0::Word8) :: ByteString 635 let bytesToHash = predHash <> fileBytes 636 637 hax <- allocaBytes 32 \outbuf -> 638 BS.unsafeUseAsCStringLen bytesToHash \(byt, wid) -> do 639 c_jet_blake3 (castPtr outbuf) (fromIntegral wid) (castPtr byt) 640 res <- BS.packCStringLen (outbuf, 32) 641 pure res 642 643 let mCached = do 644 entry <- lookup moduNoun c1 645 (cacheKey, st) <- fromNoun entry 646 guard (cacheKey == hax) 647 pure st 648 649 case mCached of 650 Just s2 -> do 651 let s3 = revertSwitchToRepl modu s2 652 hPutStrLn stderr $ tshow (modu, "LOADED FROM CACHE!"::Text) 653 pure (s3, hax) 654 655 Nothing -> do 656 s2 <- runSire file False s1 rexes 657 let sEnt = switchToContext "REPL" s2 658 let ent = ROW $ arrayFromListN 2 [toNoun hax, sEnt] 659 modifyIORef vCache (insertMap (toNoun modu) ent) 660 pure (s2, hax) 661 662 -- There is something before this in the load sequence. 663 -- Load that first. 664 rexes@(Right (_ln, NODE _ "####" [_, NODE _ "<-" [prior] Nothing] Nothing) : _) -> do 665 case tryReadKey prior of 666 Nothing -> terror ("Bad module name: " <> pexText prior) 667 Just nm -> do 668 (s2, predHash) <- doFile vCache (natUtf8Exn nm) s1 669 Prof.withSimpleTracingEvent (encodeUtf8 modu) "Sire" do 670 671 -- Massive slow hack, stream two inputs separately. 672 -- (C interface does not currently support this) 673 let bytesToHash = predHash <> fileBytes 674 675 hax <- allocaBytes 32 \outbuf -> 676 BS.unsafeUseAsCStringLen bytesToHash \(byt, wid) -> do 677 c_jet_blake3 (castPtr outbuf) (fromIntegral wid) (castPtr byt) 678 res <- BS.packCStringLen (outbuf, 32) 679 pure res 680 681 cacheNow <- readIORef vCache 682 let mCached = do 683 entry <- lookup moduNoun cacheNow 684 (cacheKey, st) <- fromNoun entry 685 guard (cacheKey == hax) 686 pure st 687 688 case mCached of 689 Just s3 -> do 690 let s4 = revertSwitchToRepl modu s3 691 hPutStrLn stderr $ tshow (modu, "LOADED FROM CACHE!"::Text) 692 pure (s4, hax) 693 694 Nothing -> do 695 s3 <- runSire file False s2 rexes 696 let sEnt = switchToContext "REPL" s3 697 let ent = ROW $ arrayFromListN 2 [toNoun hax, sEnt] 698 modifyIORef' vCache $ insertMap (toNoun modu) ent 699 pure (s3, hax) 700 701 Right (ln, rex@(NODE _ "####" _ _)) : _ -> 702 inContext file ln rex 703 $ parseFail_ rex s1 "Bad module declaration statement" 704 705 Right (ln, rex) : _ -> 706 inContext file ln rex 707 $ parseFail_ rex s1 "All files must start with module declaration" 708 709 Left msg : _ -> do 710 hPutStrLn stderr "\n" 711 hPutStrLn stderr msg 712 hPutStrLn stderr "\n" 713 error "TODO: Include the parsed results as well as the error" 714 -- Each error result should also include the processed result! 715 -- inContext file ln rex 716 -- $ parseFail_ rex s1 "All files must start with module declaration" 717 718 719 repl :: Any -> Maybe Text -> IO () 720 repl s1 mImport = do 721 722 trkM $ toNoun @Text $ unlines 723 [ "" 724 , "==== Sire REPL ====" 725 , "" 726 , "Since input is multi-line, there is currently no input-prompt." 727 , "Just type away!" 728 ] 729 730 let s2 = switchToContext "REPL" s1 731 732 -- Pre-load the module listed at the command line. 733 s3 <- case mImport of 734 Nothing -> pure s2 735 Just ng -> do 736 let importRex = OPEN ":|" [WORD ng Nothing] Nothing 737 inContext "REPL" 0 importRex do 738 evaluate $ importModule importRex (utf8Nat ng) Nothing s2 739 740 rexes <- readRexStream "REPL" stdin 741 _ <- runSire "REPL" True s3 (fmap (over _2 rexToPex) <$> rexes) 742 pure () 743 744 doAssert :: InCtx => Text -> Pex -> Repl () 745 doAssert ryn rx = do 746 case rx of 747 748 NODE s r ss (Just heir@(NODE _ sr _ _)) | ryn==sr -> do 749 doAssert ryn (NODE s r ss Nothing) 750 doAssert ryn heir 751 752 rex@(NODE _ _ sons mHeir) -> do 753 trkM (pexNoun rex) 754 case sons <> toList mHeir of 755 [xRex, yRex] -> do 756 xExp <- readExpr [] xRex 757 yExp <- readExpr [] yRex 758 execAssert (xRex,xExp) (yRex,yExp) 759 _ -> do 760 parseFail rex (ryn <> " expects two parameters") 761 _ -> 762 error "impossible" 763 764 765 doImport :: InCtx => Pex -> Text -> Maybe (Pex) -> Repl () 766 doImport blockRex run = \case 767 768 Nothing -> do 769 pure () 770 771 Just (NODE _ r [moduleRex] h) | run==r -> do 772 modu <- readKey moduleRex 773 modify' (importModule blockRex modu Nothing) 774 doImport blockRex run h 775 776 Just (NODE _ r [moduleRex, (NODE _ "," symbols Nothing)] h) | run==r -> do 777 modu <- readKey moduleRex 778 syms <- traverse readKey symbols 779 modify' (importModule blockRex modu (Just $ setFromList syms)) 780 doImport blockRex run h 781 782 Just rex -> do 783 parseFail rex "Bad import syntax" 784 785 786 doFilter :: InCtx => Text -> Set Nat -> Maybe (Pex) -> Repl () 787 doFilter ryn acc = \case 788 789 Nothing -> 790 modify' (filterScope acc) 791 792 Just node@(NODE _ rone sons heir) | ryn==rone -> do 793 moreKeys <- setFromList <$> traverse readKey sons 794 let overlap = S.intersection acc moreKeys 795 unless (null overlap || True) do 796 parseFail node ("duplicate symols: " <> tshow overlap) 797 doFilter ryn (S.union acc moreKeys) heir 798 799 Just wut -> do 800 parseFail wut "Bad export-filter syntax" 801 802 803 multiCmd :: InCtx => Pex -> Repl () 804 multiCmd (NODE _ _ sons mHeir) = traverse_ execute (sons <> toList mHeir) 805 multiCmd _ = error "multiCmd: impossible" 806 807 doEnter :: InCtx => Pex -> Repl () 808 doEnter topRex = 809 case topRex of 810 NODE _ _ sons mHeir -> proc (sons <> toList mHeir) 811 _ -> error "multiCmd: impossible" 812 where 813 expect = "Expected something like (#### foo) or (#### foo <- bar)" 814 815 proc = \case 816 [enter, NODE _ "<-" [from] Nothing] -> do 817 target <- readKey enter 818 wasJustAt <- readKey from 819 ss <- getState <$> get 820 when (ss.context /= wasJustAt) do 821 parseFail topRex "That's not where we were" 822 s8 <- get 823 let !s9 = switchToContext target s8 824 put s9 825 826 [enter] -> do 827 target <- readKey enter 828 ss <- getState <$> get 829 unless (ss.context == 0 && null ss.scope) $ 830 parseFail topRex $ 831 "#### without predecessor, but not in initial state" 832 modify' (switchToContext target) 833 834 _ -> do 835 parseFail topRex expect 836 837 expRune :: Text -> Bool 838 expRune = (`member` set) 839 where 840 set :: Set Text 841 set = setFromList 842 [ "|", "#|", "-", "#-", "**", "#**", "@", "#@", "@@", "#@@" 843 , "^", "#^", "&", "#&", "?", "#?", "??", "#??", ".", "#." 844 ] 845 846 readExpr :: InCtx => [Maybe Nat] -> Pex -> Repl Sire 847 readExpr e rex = do 848 case rex of 849 LEAF{} -> readPrimExpr e rex 850 EMBD{} -> readPrimExpr e rex 851 EVIL{} -> readPrimExpr e rex 852 NODE _ ryn _ _ -> do 853 stVal <- get 854 case lookupVal ryn stVal of 855 Just macVal -> expand macVal rex >>= readExpr e 856 Nothing -> readPrimExpr e rex 857 858 readMultiLine :: InCtx => [Text] -> Maybe Pex -> Repl Sire 859 readMultiLine acc = \case 860 Nothing -> pure $ K $ NAT $ utf8Nat $ intercalate "\n" $ reverse acc 861 Just h -> case h of 862 LEAF s t k | s==Rx.LINE -> readMultiLine (t:acc) k 863 _ -> parseFail h "Mis-matched node in text block" 864 865 readPrimExpr :: InCtx => [Maybe Nat] -> Pex -> Repl Sire 866 readPrimExpr e rex = case rex of 867 EMBD v -> pure (K v) 868 EVIL{} -> parseFail rex "malformed rex" 869 LEAF Rx.LINE t k -> readMultiLine [t] k 870 LEAF _ _ _ -> readPrimLeaf rex e rex 871 NODE _ r s h -> readNode r s h 872 873 where 874 readNode :: Text -> [Pex] -> Maybe Pex -> Repl Sire 875 readNode r s h = 876 let ks = s <> toList h in 877 case r of 878 "|" -> readApp ks 879 "#|" -> readApp ks 880 "-" -> readApp ks 881 "#-" -> readApp ks 882 "**" -> readLin ks 883 "#**" -> readLin ks 884 "@" -> readLet ks 885 "#@" -> readLet ks 886 "@@" -> readLetRec ks 887 "#@@" -> readLetRec ks 888 "^" -> readKet ks 889 "#^" -> readKet ks 890 "&" -> readAnonLam ks 891 "#&" -> readAnonLam ks 892 "?" -> readLam False ks 893 "#?" -> readLam False ks 894 "??" -> readLam True ks 895 "#??" -> readLam True ks 896 "." -> readRefr ks 897 "#." -> readRefr ks 898 _ -> parseFail rex ("Undefined rune: " <> r) 899 900 readAnonSig :: Pex -> Repl [Nat] 901 readAnonSig (NODE _ "|" s h) = traverse readKey (s <> toList h) 902 readAnonSig n@(LEAF{}) = singleton <$> readKey n 903 readAnonSig rx = parseFail rx "Expected something like: (x y z)" 904 905 readAnonLam :: [Pex] -> Repl Sire 906 readAnonLam [sig,bod] = do 907 argNames <- readAnonSig sig 908 let e2 = reverse (Nothing : fmap Just argNames) <> e 909 let args = fromIntegral (length argNames) 910 body <- readExpr e2 bod 911 pure $ F $ LAM{tag=0,args,body,pin=False,mark=False,recr=False} 912 913 readAnonLam [tagRex, sig, bod] = do 914 tag <- readKey tagRex 915 argNames <- readAnonSig sig 916 let e2 = reverse (Nothing : fmap Just argNames) <> e 917 let args = fromIntegral (length argNames) 918 body <- readExpr e2 bod 919 pure $ F $ LAM{tag,args,body,pin=False,mark=False,recr=False} 920 921 readAnonLam _ = parseFail rex "Expected two or three parameters" 922 923 readWutSig :: Pex -> Repl (Bool, Nat, [Nat]) 924 readWutSig topRex@LEAF{} = do 925 f <- readKey topRex 926 pure (False, f, []) 927 928 readWutSig topRex = do 929 kids <- getBarNode topRex 930 case kids of 931 [] -> parseFail topRex "Expected at least one parameter" 932 hed:xs -> do 933 (inline, f) <- getFuncHead hed 934 args <- traverse readKey xs 935 pure (inline, f, args) 936 where 937 getFuncHead :: Pex -> Repl (Bool, Nat) 938 getFuncHead hed@(NODE _ "**" s h) = 939 case s <> toList h of 940 [x] -> (True,) <$> readKey x 941 _ -> parseFail hed "Expected something like **x" 942 943 getFuncHead hed = (False,) <$> readKey hed 944 945 getBarNode = \case 946 NODE _ "|" s h -> pure (s <> toList h) 947 _ -> parseFail topRex "Expecting something like: (f x y)" 948 949 readLam :: Bool -> [Pex] -> Repl Sire 950 readLam pin [sigRex, bodRex] = do 951 (mark, f, argNames) <- readWutSig sigRex 952 let e2 = reverse (Just <$> (f:argNames)) <> e 953 let args = fromIntegral (length argNames) 954 body <- readExpr e2 bodRex 955 pure $ F $ LAM{tag=f,args,body,pin,mark,recr=(hasRefTo args body)} 956 957 readLam pin [tagRex, sigRex, bodRex] = do 958 tag <- readKey tagRex 959 (mark, f, argNames) <- readWutSig sigRex 960 let e2 = reverse (Just <$> (f:argNames)) <> e 961 let args = fromIntegral (length argNames) 962 body <- readExpr e2 bodRex 963 pure $ F $ LAM{tag,args,body,pin,mark,recr=(hasRefTo args body)} 964 965 readLam _ _ = parseFail rex "Expected two or three parameters" 966 967 readRefr :: [Pex] -> Repl Sire 968 readRefr [x] = do 969 n <- readKey x 970 resolveUnqualified rex e n 971 972 readRefr [x,y] = do 973 m <- readKey x 974 n <- readKey y 975 resolveQualified rex m n 976 977 readRefr _ = parseFail rex "Needs one or two parameters" 978 979 readKet :: [Pex] -> Repl Sire 980 readKet xs = do 981 when (length xs < 2) do 982 parseFail rex "Needs at least two paramaters" 983 v <- readExpr e (L.last xs) 984 b <- traverse (readExpr (Just "_" : e)) (L.init xs) 985 pure (L v $ apple_ b) 986 987 readLet :: [Pex] -> Repl Sire 988 readLet [nr, vr, br] = do 989 n <- readKey nr 990 v <- readExpr e vr 991 b <- readExpr (Just n : e) br 992 pure (L v b) 993 readLet _ = parseFail rex "Three paramaters are required" 994 995 readLetRec :: [Pex] -> Repl Sire 996 readLetRec [vsr, br] = do 997 bs <- readBindSeq (Just vsr) 998 ks <- pure (fst <$> bs) 999 let e' = ((Just <$> ks) <> e) 1000 vs <- traverse (readExpr e' . snd) bs 1001 b <- readExpr e' br 1002 pure (R vs b) 1003 readLetRec _ = parseFail rex "Two paramaters are required" 1004 1005 readBindSeq :: Maybe Pex -> Repl [(Nat, Pex)] 1006 readBindSeq Nothing = pure [] 1007 readBindSeq (Just (NODE _ "=" [kr,br] h)) = do 1008 k <- readKey kr 1009 ((k,br):) <$> readBindSeq h 1010 readBindSeq (Just _) = do 1011 parseFail rex "Invalid (=) bind-seq" 1012 1013 readLin :: [Pex] -> Repl Sire 1014 readLin [x] = M <$> readExpr e x 1015 readLin _ = parseFail rex "This needs to have only one parameter" 1016 1017 readApp :: [Pex] -> Repl Sire 1018 readApp [] = parseFail rex "empty application" 1019 readApp (r:rx) = do 1020 (s :| ss) <- traverse (readExpr e) (r :| rx) 1021 pure (foldl' A s ss) 1022 1023 resolveUnqualified :: InCtx => Pex -> [Maybe Nat] -> Nat -> Repl Sire 1024 resolveUnqualified blockRex e sym = do 1025 st <- getState <$> get 1026 case (L.elemIndex (Just sym) e, lookup (NAT sym) st.scope) of 1027 (Just ng, _) -> pure $ V (fromIntegral ng) 1028 (_, Just bn) -> pure $ G bn 1029 (_, _) -> parseFail blockRex ("Unresolved symbol: " <> showKey sym) 1030 1031 resolveQualified :: InCtx => Pex -> Nat -> Nat -> Repl Sire 1032 resolveQualified blockRex modu nam = do 1033 st <- getState <$> get 1034 case (lookup (NAT modu) >=> Just >=> lookup (NAT nam)) st.modules of 1035 Just bn -> pure (G bn) 1036 Nothing -> parseFail blockRex $ concat [ "Unresolved symbol: " 1037 , showKey modu 1038 , "." 1039 , showKey nam 1040 ] 1041 1042 showKey :: Nat -> Text 1043 showKey = let ?rexColors = NoColors in rexLine . boxRex . keyBox 1044 1045 readPrimLeaf :: InCtx => Pex -> [Maybe Nat] -> Pex -> Repl Sire 1046 readPrimLeaf _ e rex@(LEAF s ss (Just heir)) = 1047 map (lookupVal "#") get >>= \case 1048 Nothing -> parseFail rex "leaf-juxtaposition, but no # macro" 1049 Just hex -> do 1050 x <- expand hex $ INFX "#" [LEAF s ss Nothing, heir] Nothing 1051 readExpr e x 1052 1053 readPrimLeaf blockRex e rex = 1054 case tryReadLeaf rex of 1055 Just (IDNT n) -> resolveUnqualified blockRex e (utf8Nat n) 1056 Just (DECI n) -> pure $ K $ NAT n 1057 Just (CORD n) -> pure $ K $ NAT (utf8Nat n) 1058 Nothing -> do 1059 map (lookupVal "#") get >>= \case 1060 Just hex -> expand hex (PREF "#" [rex] Nothing) >>= readExpr e 1061 Nothing -> parseFail rex "don't know how to parse this leaf" 1062 1063 readBindBody :: InCtx => Either Nat ((Bool, Nat), [Nat]) -> Pex -> Repl Sire 1064 readBindBody Left{} = readExpr [] 1065 readBindBody (Right((_,self),args)) = readExpr $ reverse $ fmap Just $ self:args 1066 1067 planRexFull :: Any -> GRex a 1068 planRexFull = fmap absurd . itemizeRexes . closureRex Nothing . loadClosure 1069 1070 execAssert :: InCtx => (Pex, Sire) -> (Pex, Sire) -> Repl () 1071 execAssert (_xRex, xExp) (_yRex, yExp) = do 1072 let !xVal = eval xExp 1073 let !yVal = eval yExp 1074 1075 unless (xVal == yVal) do 1076 let rx = OPEN "=?=" [] 1077 $ Just $ OPEN "*" [rexToPex $ fmap absurd $ planRex xVal] 1078 $ Just $ OPEN "*" [rexToPex $ fmap absurd $ planRex yVal] 1079 $ Nothing 1080 parseFail rx "ASSERTION FAILURE" 1081 1082 execBind :: InCtx => Pex -> ToBind -> Repl () 1083 execBind rx (TO_BIND key mProp str expr) = do 1084 let val = eval expr 1085 let prp = maybe 0 eval mProp 1086 modify' (insertBinding rx (key, prp, str, val, expr)) 1087 trkRexM $ fmap absurd 1088 $ itemizeRexes 1089 $ closureRex (Just str) (loadShallow val) 1090 1091 itemizeRexes :: [GRex a] -> GRex a 1092 itemizeRexes [x] = x 1093 itemizeRexes rs = go rs 1094 where 1095 go [] = Rx.N Rx.OPEN "*" [] Nothing 1096 go [x] = Rx.N Rx.OPEN "*" [x] Nothing 1097 go (x:xs) = Rx.N Rx.OPEN "*" [x] (Just $ go xs) 1098 1099 execExpr :: InCtx => Pex -> Repl () 1100 execExpr rex = do 1101 expr <- readExpr [] rex 1102 let val = eval expr 1103 trkM val 1104 1105 doDefine :: InCtx => Text -> Pex -> Repl () 1106 doDefine ryn rex = do 1107 case rex of 1108 NODE _ _ sons (Just heir@(NODE _ sub _ _)) | ryn==sub -> do 1109 readBindCmd rex sons >>= execBind rex 1110 doDefine ryn heir 1111 1112 NODE _ _ sons mHeir -> do 1113 readBindCmd rex (sons <> toList mHeir) >>= execBind rex 1114 1115 _ -> error "readDefine: impossible" 1116 1117 readBindCmd :: InCtx => Pex -> [Pex] -> Repl ToBind 1118 readBindCmd rex = \case 1119 1120 {- 1121 TODO: Eventually we should be able to kill these hacky "bind 1122 with props" and "bind with keys" forms. 1123 1124 Instead of having this as a built-in features in Sire, we should 1125 define macros that do this, and use those instead. 1126 -} 1127 [keyRex, propsRex, binderRex, exprRex] -> do 1128 key <- readKey keyRex 1129 props <- readExpr [] propsRex 1130 binder <- readBinder binderRex 1131 expr <- readBindBody binder exprRex 1132 pure $ mkBind key (Just props) expr binder 1133 1134 [keyRex, binderRex, exprRex] -> do 1135 key <- readKey keyRex 1136 binder <- readBinder binderRex 1137 expr <- readBindBody binder exprRex 1138 pure $ mkBind key Nothing expr binder 1139 1140 [binderRex, exprRex] -> do 1141 binder <- readBinder binderRex 1142 expr <- readBindBody binder exprRex 1143 pure $ mkBind 0 Nothing expr binder 1144 1145 _ -> do 1146 parseFail rex "Define cmd needs two or three parameters" 1147 1148 where 1149 1150 mkBind key mProp body = \case 1151 Left var -> 1152 TO_BIND key mProp var body 1153 1154 Right ((mark, name), argNames) -> 1155 let recr = hasRefTo args body in 1156 TO_BIND key mProp name 1157 $ F $ LAM {pin=True, mark, tag=name, args, body, recr} 1158 where 1159 args = fromIntegral (length argNames) 1160 1161 open :: Text -> [Pex] -> Pex -> Pex 1162 open r s h = OPEN r s (Just h) 1163 1164 open_ :: Text -> [Pex] -> Pex 1165 open_ r s = OPEN r s Nothing 1166 1167 data ParseFail = PARSE_FAIL 1168 { block :: Context 1169 , problem :: Pex 1170 , _state :: Any 1171 , reason :: Text 1172 } 1173 deriving (Eq, Ord) 1174 1175 parseFailRex :: ParseFail -> Pex 1176 parseFailRex pf = 1177 id $ open "#" [wrd "block", b.rex] 1178 $ open "#" [wrd "where", col [wrd b.file, wrd (tshow b.line)]] 1179 $ open "#" [wrd "problem", pf.problem] 1180 $ open_ "#" [wrd "reason", wrd pf.reason] 1181 where 1182 wrd x = WORD x Nothing 1183 b = pf.block 1184 col ds = SHUT ":" ds Nothing 1185 1186 data MacroError = MACRO_ERROR 1187 { block :: Context 1188 , input :: Pex 1189 , _state :: Any 1190 , reason :: Text 1191 } 1192 deriving (Eq, Ord) 1193 1194 macroErrorRex :: MacroError -> Pex 1195 macroErrorRex me = 1196 id $ open "#" [wrd "block", me.block.rex] 1197 $ open "#" [wrd "where", col [wrd b.file, wrd (tshow b.line)]] 1198 $ open "#" [wrd "trouble", me.input] 1199 $ open_ "#" [wrd "reason", wrd me.reason] 1200 where 1201 wrd x = WORD x Nothing 1202 col ds = SHUT ":" ds Nothing 1203 b = me.block 1204 1205 macroError :: InCtx => Pex -> Nat -> Repl a 1206 macroError ctx msg = do 1207 st <- get 1208 let !me = MACRO_ERROR ?ctx ctx st (showKey msg) 1209 let !res = "Macro Failure!" %% pexNoun (macroErrorRex me) 1210 seq res (error "this should never happen (macroError)") 1211 1212 parseFail :: InCtx => Pex -> Text -> Repl a 1213 parseFail rex msg = do { st <- get; parseFail_ rex st msg } 1214 1215 parseFail_ :: InCtx => Pex -> Any -> Text -> a 1216 parseFail_ rex st msg = 1217 seq bottom (error "this should never happen (parseFail_)") 1218 where 1219 errRex = pexNoun $ parseFailRex $ PARSE_FAIL ?ctx rex st msg 1220 bottom = "Failed to Parse Sire" %% errRex 1221 1222 readBinder :: InCtx => Pex -> Repl (Either Nat ((Bool, Nat), [Nat])) 1223 readBinder rex = do 1224 case (tryReadKey rex, tryReadLawBinder rex) of 1225 (Just key, _) -> pure (Left key) 1226 (_, Just bind) -> pure (Right bind) 1227 (_, _) -> parseFail rex msg 1228 where 1229 msg = "Bad binder: expected foo (foo bar), (**foo bar), etc" 1230 1231 tryReadLawBinder :: Pex -> Maybe ((Bool, Nat), [Nat]) 1232 tryReadLawBinder rex = do 1233 kids <- case rex of 1234 NODE _ "|" sons heir -> pure (sons <> toList heir) 1235 _ -> Nothing 1236 case kids of 1237 [] -> Nothing 1238 headRex : tailRexes -> do 1239 (,) <$> tryReadSigHead headRex 1240 <*> traverse tryReadKey tailRexes 1241 1242 tryReadSigHead :: Pex -> Maybe (Bool, Nat) 1243 tryReadSigHead = \case 1244 NODE _ "**" [son] Nothing -> (True,) <$> tryReadKey son 1245 rex -> (False,) <$> tryReadKey rex 1246 1247 1248 -- Parsing Leaves -------------------------------------------------------------- 1249 1250 readKey :: InCtx => Pex -> Repl Nat 1251 readKey rex = maybe bad pure (tryReadKey rex) 1252 where 1253 bad = parseFail rex "Bad key: expected something like: 234, foo, 'foo'" 1254 1255 data Leaf = DECI Nat | IDNT Text | CORD Text 1256 1257 -- TODO: Should `tryReadLeaf` also support embeded constant values? 1258 1259 tryReadLeaf :: Pex -> Maybe Leaf 1260 tryReadLeaf = \case 1261 TEXT t Nothing -> Just (CORD t) 1262 WORD t Nothing -> tryReadWord t 1263 _ -> Nothing 1264 where 1265 tryReadWord t = do 1266 (c, _) <- T.uncons t 1267 if C.isDigit c 1268 then do guard (all C.isDigit t) 1269 DECI <$> readMay t 1270 else Just (IDNT t) 1271 1272 tryReadKey :: Pex -> Maybe Nat 1273 tryReadKey = fmap leafNat . tryReadLeaf 1274 1275 leafNat :: Leaf -> Nat 1276 leafNat = \case { DECI n -> n; IDNT i -> utf8Nat i; CORD s -> utf8Nat s }