diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index c23213e4..992861d0 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -30,6 +30,7 @@ import Data.ByteString.Char8 qualified as BS8 import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Data +import Data.Coerce import Data.Function as Export import Data.Functor as Export import Data.Hashable @@ -336,6 +337,7 @@ data BadFormException c = BadFormException (Syntax c) | ArityMismatch (Syntax c) | NotLambda (Syntax c) | NotBuiltinLambda Id + | RuntimeError (Syntax c) | TypeCheckError (Syntax c) newtype BadValueException = BadValueException String @@ -349,6 +351,8 @@ instance IsContext c => Show (BadFormException c) where show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy show (NotLambda sy) = show $ "NotLambda" <+> pretty sy show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy + show (RuntimeError sy) = show $ "RuntimeError" <+> pretty sy + show (NotBuiltinLambda sy) = show $ "NotBuiltinLambda" <+> pretty sy instance Exception (BadFormException C) @@ -618,7 +622,7 @@ eval' dict0 syn' = handle (handleForm syn') $ do let dict = dict0 <> dict1 -- liiftIO $ print $ show $ "TRACE EXP" <+> pretty syn - let importDecls = HS.fromList [ "define", "define-macro" :: Id ] + let importDecls = HS.fromList [ "import", "define", "define-macro" :: Id ] case syn' of @@ -655,6 +659,29 @@ eval' dict0 syn' = handle (handleForm syn') $ do ListVal [ SymbolVal "eval", e ] -> eval e >>= eval ListVal [ SymbolVal "import", StringLike fn ] -> do + + let importsName = "*runtime-imports*" + let alreadyError = RuntimeError $ mkForm "runtime-error" [ mkStr @c ["already imported", pretty fn] ] + let disappearedMessage = [mkStr @c [coerce importsName, "misteriously disappeared" :: Text]] + let disappeared = RuntimeError $ mkForm "runtime-error" disappearedMessage + + initial <- newTVarIO (mempty :: HashMap Id (HashSet Id)) >>= mkOpaque + + imp_ <- lookupValueDef initial importsName >>= \case + OpaqueVal e -> fromOpaque @(TVar (HashMap Id (HashSet Id))) e & \case + Just x -> pure x + Nothing -> throwIO disappeared + + _ -> throwIO (RuntimeError (mkStr @c $ show $ pretty importsName <> "misteriously disappeared")) + + + + seen <- atomically $ stateTVar imp_ (\e -> (HM.lookup (mkId fn) e, HM.insert (mkId fn) mempty e)) + + -- liftIO $ print $ pretty "import" <+> pretty fn + + unless (isNothing seen) $ throwIO alreadyError + -- FIXME: fancy-error-handling syn <- liftIO (TIO.readFile fn) <&> parseTop >>= either(error.show) pure @@ -665,7 +692,7 @@ eval' dict0 syn' = handle (handleForm syn') $ do -- liftIO $ mapM_ (print . pretty) decls - mapM_ eval decls + evalTop decls pure nil @@ -828,6 +855,19 @@ lookupValue i = do Just (BindValue s) -> pure s _ -> throwIO (NameNotBound i) +lookupValueDef :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) + => Syntax c + -> Id + -> RunM c m (Syntax c) +lookupValueDef defVal i = do + ask >>= readTVarIO + <&> (fmap bindAction . HM.lookup i) + >>= \case + Just (BindValue s) -> pure s + _ -> do + bind i defVal + pure defVal + nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) nil_ m w = m w >> pure (List noContext []) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index c9d721b2..b60bf50e 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -25,6 +25,7 @@ module Data.Config.Suckless.Syntax , nil , mkList , mkBool + , MkId(..) , MkForm(..) , MkSym(..) , MkInt(..) @@ -331,6 +332,15 @@ instance IsContext c => FromJSON (Syntax c) where pure $ List noContext (Symbol noContext (Id "object") : pairs) parseJSON _ = fail "Cannot parse JSON to Syntax" +class MkId a where + mkId :: a -> Id + +instance MkId Text where + mkId = Id + +instance MkId String where + mkId = Id . Text.pack + class IsContext c => MkSym c a where mkSym :: a -> Syntax c @@ -352,6 +362,15 @@ instance IsContext c => MkStr c String where instance IsContext c => MkStr c Text where mkStr s = Literal noContext $ LitStr s +instance IsContext c => MkStr c [Text] where + mkStr s = mkStr $ mconcat s + +instance IsContext c => MkStr c [String] where + mkStr s = mkStr $ mconcat s + +instance IsContext c => MkStr c [Doc ann] where + mkStr s = mkStr $ show (hsep s) + mkBool :: forall c . IsContext c => Bool -> Syntax c mkBool v = Literal noContext (LitBool v)