Compare commits
1 Commits
named-core
...
errorful-e
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
559fd49f2b |
@@ -15,3 +15,5 @@
|
||||
}
|
||||
```
|
||||
|
||||
# Release 1.0.0
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
Reference in New Issue
Block a user