diff --git a/CHANGELOG.md b/CHANGELOG.md index 9921c0c..88e5ac0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,3 +15,5 @@ } ``` +# Release 1.0.0 + diff --git a/README.md b/README.md index 2f38469..1573d64 100644 --- a/README.md +++ b/README.md @@ -103,6 +103,7 @@ Listed in order of importance. - [ ] Actual compiler errors -- no more unexceptional `error` calls - [ ] Better CLI dump flags - [ ] Annotate the AST with token positions for errors +- [ ] More examples ### March Release Plan - [ ] Tests diff --git a/app/Main.hs b/app/Main.hs index f48824b..27377d0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -63,7 +63,7 @@ options = RLPCOptions evaluatorReader :: ReadM Evaluator evaluatorReader = maybeReader $ \case "gm" -> Just EvaluatorGM - "tim" -> Just EvaluatorTI + "ti" -> Just EvaluatorTI _ -> Nothing mmany :: (Alternative f, Monoid m) => f m -> f m diff --git a/rlp.cabal b/rlp.cabal index a48324a..a487328 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -7,7 +7,7 @@ license: GPL-2.0-only -- license-file: LICENSE author: crumbtoo maintainer: crumb@disroot.org --- copyright: +copyright: Madeleine Sydney Ĺšlaga category: Language build-type: Simple extra-doc-files: README.md diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 2993c67..474ecfc 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -28,14 +28,12 @@ module Compiler.RLPC , evalRLPCIO , evalRLPC , rlpcLogFile - , rlpcDebugOpts + , rlpcDFlags , rlpcEvaluator , rlpcInputFiles , DebugFlag(..) - , whenFlag - , flagDDumpEval - , flagDDumpOpts - , flagDDumpAST + , whenDFlag + , whenFFlag , def , liftErrorful ) @@ -43,6 +41,7 @@ module Compiler.RLPC ---------------------------------------------------------------------------------- import Control.Arrow ((>>>)) import Control.Exception +import Control.Monad import Control.Monad.Reader import Control.Monad.State (MonadState(state)) import Control.Monad.Errorful @@ -51,19 +50,19 @@ import Data.Functor.Identity import Data.Default.Class import Data.Foldable import GHC.Generics (Generic) +import Data.Maybe import Data.Hashable (Hashable) import Data.HashSet (HashSet) import Data.HashSet qualified as S import Data.Coerce -import Lens.Micro -import Lens.Micro.TH +import Lens.Micro.Platform import System.Exit ---------------------------------------------------------------------------------- newtype RLPCT m a = RLPCT { runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a } - deriving (Functor, Applicative, Monad) + deriving (Functor, Applicative, Monad, MonadReader RLPCOptions) type RLPC = RLPCT Identity @@ -98,7 +97,8 @@ liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) data RLPCOptions = RLPCOptions { _rlpcLogFile :: Maybe FilePath - , _rlpcDebugOpts :: DebugOpts + , _rlpcDFlags :: HashSet DebugFlag + , _rlpcFFlags :: HashSet CompilerFlag , _rlpcEvaluator :: Evaluator , _rlpcHeapTrigger :: Int , _rlpcInputFiles :: [FilePath] @@ -113,38 +113,33 @@ data Evaluator = EvaluatorGM | EvaluatorTI instance Default RLPCOptions where def = RLPCOptions { _rlpcLogFile = Nothing - , _rlpcDebugOpts = mempty + , _rlpcDFlags = mempty + , _rlpcFFlags = mempty , _rlpcEvaluator = EvaluatorGM , _rlpcHeapTrigger = 200 , _rlpcInputFiles = [] } -type DebugOpts = HashSet DebugFlag +-- debug flags are passed with -dFLAG +type DebugFlag = String -data DebugFlag = DDumpEval - | DDumpOpts - | DDumpAST - deriving (Show, Eq, Generic) - -instance Hashable DebugFlag +type CompilerFlag = String makeLenses ''RLPCOptions pure [] -whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m () -whenFlag l m = asks (^. l) >>= \a -> if a then m else pure () +-- TODO: rewrite this with prisms once microlens-pro drops :3 +whenDFlag :: (Monad m) => DebugFlag -> RLPCT m () -> RLPCT m () +whenDFlag f m = do + -- mfw no `At` instance for HashSet + fs <- view rlpcDFlags + let a = S.member f fs + when a m --- there's probably a better way to write this. my current knowledge of lenses --- is too weak. -flagGetter :: DebugFlag -> SimpleGetter RLPCOptions Bool -flagGetter d = to $ \s -> s ^. rlpcDebugOpts & S.member d - -flagDDumpEval :: SimpleGetter RLPCOptions Bool -flagDDumpEval = flagGetter DDumpEval - -flagDDumpOpts :: SimpleGetter RLPCOptions Bool -flagDDumpOpts = flagGetter DDumpOpts - -flagDDumpAST :: SimpleGetter RLPCOptions Bool -flagDDumpAST = flagGetter DDumpAST +whenFFlag :: (Monad m) => CompilerFlag -> RLPCT m () -> RLPCT m () +whenFFlag f m = do + -- mfw no `At` instance for HashSet + fs <- view rlpcFFlags + let a = S.member f fs + when a m