rc (#13)
* update readme * Literal -> Lit, LitE -> Lit * commentary * infer * hindley milner inference :D * comments and better type errors * type IsString + test unification error * infer nonrec let binds infer nonrec let binds * small * LitE -> Lit * LitE -> Lit * TyInt -> TyCon "Int#" * parse type sigs; program type sigs * parse types * parse programs (with types :D) * parse programs (with type sigs :D) * Name = Text Name = Text * RlpcError * i'm on an airplane rn, my eyelids grow heavy, and i forgot my medication. should this be my final commit (of the week): gootbye * kinda sorta typechecking * back and medicated! * errorful (it's not good) * type-checked quasiquoters * fix hm tests * Compiler.JustRun * lex \ instead of \\ * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * add version bounds * grammar reference * 4:00 AM psychopath code * oh boy am i going to hate this code in 12 hours * application and lits appl * something * goofy * Show1 instances * fixation fufilled - back to work! * works * labels * infix decl * expr fixups * where * cool * aaaaa * decls fix * finally in a decent state * replace uses of many+satisfy with takeWhileP * layout layouts oh my layouts * i did not realise my fs is case insensitive * tysigs * its fine * threaded lexer * decent starting point * man this sucks * aagh * okay layouts kinda * kitten i'll be honest mommy's about to kill herself * see previous commit and scale back the part where i'm joking * version bounds * we're so back * fixy * cool * FIX REAL * oh my god * works * now we're fucking GETTING SOMEWHERE * i really need to learn git proper * infix exprs * remove debug flags * renamerlp * rename rlp * compiles (kill me) man * RlpcError -> IsRlpcError * when the "Test suite rlp-test: PASS" hits i'm like atlas and the world is writing two lines of code * errorful parser * errorful parser small * msgenvelope * errors! * allow uppercase sc names in preperation for Rlp2Core * letrec * infer letrec expressions * minor docs * checklist * minor docs * stable enough for a demo hey? * small fixups * new tag syntax; preparing for Core patterns new tag syntax; preparing for data names * temporary pragma system * resolve named data in case exprs * named constr tests * nearing release :3 * minor changes putting this on hold; implementing TTG first * some * oh my god guys!!! `Located` is a lax semimonoidal endofunctor on the category Hask!!!  * it's also a comonad. lol. * idk * show * abandon ship * at long last more no more undefineds * i should've made a lisp man this sucks * let layout * ttg boilerplate * fixup! ttg boilerplate * fixup! ttg boilerplate * organisation and cleaning organisation and tidying * error messages * driver progress * formatting * *R functions * -ddump-ast * debug tags * -ddump-eval * core driver * XRec fix * rlp2core base * ccoool * something * rlp TH * sc * expandableAlt * expandableAlt * fix layout_let * parse case exprs * case unrolling * rose * her light cuts deep time and time again ('her' of course referring to the field of computer science) * tidying * NameSupply effect * tidy * fix incomplete byTag * desugar * WIP associate postproc corecursive * sigh i'm gonna have to nuke the ast again in a month * remove old files * remove old files * fix top-level layout * define datatags * diagram * diagram * Update README.md * ppr debug flags ddump-parsed * ppr typesigs * ppr datatags * remove unnecessary comment * tidying * .hs -> .cr update examples * fix evil parser bug (it was a fucking typo) * fix evil lexer bug (it was actually quite subtle unlike prev.) * examples * examples * letrec + typechecking core * Update README.md * Rlp2Core: simple let binds * Rlp2Core: pattern let binds * small core fixes * update examples * formatting * typed coreExpr quoter * typechecking things * lt * decent state! * constants for bool tags * print# gm primitive * bind VarP after pats * fix: tag nested data names * gte gm prim * more nightmare GM fixes * QuickSort example works i'm gonig to cry * remove debug code * remove debug tracers * ready? * update readme * remove bad, incorrct, outdated docs --------- Co-authored-by: crumbtoo <crumb@disroot.org>
This commit was merged in pull request #13.
This commit is contained in:
crumb
59
src/Compiler/JustRun.hs
Normal file
59
src/Compiler/JustRun.hs
Normal file
@@ -0,0 +1,59 @@
|
||||
{-|
|
||||
Module : Compiler.JustRun
|
||||
Description : No-BS, high-level wrappers for major pipeline pieces.
|
||||
|
||||
A collection of wrapper functions to demo processes such as lexing, parsing,
|
||||
type-checking, and evaluation. This module intends to export "no-BS" functions
|
||||
that use Prelude types such as @Either@ and @String@ rather than more complex
|
||||
types such as @RLPC@ or @Text@.
|
||||
-}
|
||||
module Compiler.JustRun
|
||||
( justLexCore
|
||||
, justParseCore
|
||||
, justTypeCheckCore
|
||||
, justHdbg
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Core.Lex
|
||||
import Core.Parse
|
||||
import Core.HindleyMilner
|
||||
import Core.Syntax (Program')
|
||||
import Compiler.RLPC
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Monad ((>=>), void)
|
||||
import Control.Comonad
|
||||
import Control.Lens
|
||||
import Data.Text qualified as T
|
||||
import Data.Function ((&))
|
||||
import System.IO
|
||||
import GM
|
||||
import Rlp.Parse
|
||||
import Rlp2Core
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
justHdbg :: String -> IO GmState
|
||||
justHdbg s = do
|
||||
p <- evalRLPCIO def (parseRlpProgR >=> desugarRlpProgR $ T.pack s)
|
||||
withFile "/tmp/t.log" WriteMode $ hdbgProg p
|
||||
|
||||
justLexCore :: String -> Either [MsgEnvelope RlpcError] [CoreToken]
|
||||
justLexCore s = lexCoreR (T.pack s)
|
||||
& mapped . each %~ extract
|
||||
& rlpcToEither
|
||||
|
||||
justParseCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justParseCore s = parse (T.pack s)
|
||||
& rlpcToEither
|
||||
where parse = lexCoreR >=> parseCoreProgR
|
||||
|
||||
justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
|
||||
justTypeCheckCore s = typechk (T.pack s)
|
||||
& rlpcToEither
|
||||
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
|
||||
|
||||
rlpcToEither :: RLPC a -> Either [MsgEnvelope RlpcError] a
|
||||
rlpcToEither r = case evalRLPC def r of
|
||||
(Just a, _) -> Right a
|
||||
(Nothing, es) -> Left es
|
||||
|
||||
@@ -10,96 +10,116 @@ errors and the family of RLPC monads.
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
-- only used for mtl instances
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE DeriveGeneric, DerivingStrategies, DerivingVia #-}
|
||||
{-# LANGUAGE BlockArguments, ViewPatterns #-}
|
||||
module Compiler.RLPC
|
||||
( RLPC
|
||||
, RLPCT
|
||||
, RLPCIO
|
||||
, RLPCOptions(RLPCOptions)
|
||||
, addFatal
|
||||
, addWound
|
||||
, MonadErrorful
|
||||
, Severity(..)
|
||||
, Evaluator(..)
|
||||
, evalRLPCT
|
||||
, evalRLPCIO
|
||||
, evalRLPC
|
||||
, rlpcLogFile
|
||||
, rlpcDebugOpts
|
||||
, rlpcEvaluator
|
||||
, rlpcInputFiles
|
||||
, DebugFlag(..)
|
||||
, whenFlag
|
||||
, flagDDumpEval
|
||||
, flagDDumpOpts
|
||||
, flagDDumpAST
|
||||
, def
|
||||
(
|
||||
-- * Rlpc Monad transformer
|
||||
RLPCT(RLPCT),
|
||||
-- ** Special cases
|
||||
RLPC, RLPCIO
|
||||
, liftIO
|
||||
-- ** Running
|
||||
, runRLPCT
|
||||
, evalRLPCT, evalRLPCIO, evalRLPC
|
||||
-- * Rlpc options
|
||||
, Language(..), Evaluator(..)
|
||||
, DebugFlag(..), CompilerFlag(..)
|
||||
-- ** Lenses
|
||||
, rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
|
||||
-- * Misc. MTL-style functions
|
||||
, liftErrorful, hoistRlpcT
|
||||
-- * Misc. Rlpc Monad -related types
|
||||
, RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
|
||||
, MsgEnvelope(..), Severity(..)
|
||||
, addDebugMsg
|
||||
, whenDFlag, whenFFlag
|
||||
-- * Misc. Utilities
|
||||
, forFiles_, withSource
|
||||
-- * Convenient re-exports
|
||||
, addFatal, addWound, def
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Arrow ((>>>))
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State (MonadState(state))
|
||||
import Control.Monad.Errorful
|
||||
import Control.Monad.IO.Class
|
||||
import Compiler.RlpcError
|
||||
import Compiler.Types
|
||||
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 Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.IO qualified as T
|
||||
import System.IO
|
||||
import Text.ANSI qualified as Ansi
|
||||
import Text.PrettyPrint hiding ((<>))
|
||||
import Lens.Micro.Platform
|
||||
import Lens.Micro.Platform.Internal
|
||||
import System.Exit
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- TODO: fancy errors
|
||||
newtype RLPCT e m a = RLPCT {
|
||||
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
|
||||
newtype RLPCT m a = RLPCT {
|
||||
runRLPCT :: ReaderT RLPCOptions (ErrorfulT (MsgEnvelope RlpcError) m) a
|
||||
}
|
||||
-- TODO: incorrect ussage of MonadReader. RLPC should have its own
|
||||
-- environment access functions
|
||||
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
|
||||
deriving ( Functor, Applicative, Monad
|
||||
, MonadReader RLPCOptions, MonadErrorful (MsgEnvelope RlpcError))
|
||||
|
||||
deriving instance (MonadIO m) => MonadIO (RLPCT e m)
|
||||
rlpc :: (IsRlpcError e, Monad m)
|
||||
=> (RLPCOptions -> (Maybe a, [MsgEnvelope e]))
|
||||
-> RLPCT m a
|
||||
rlpc f = RLPCT . ReaderT $ \opt ->
|
||||
ErrorfulT . pure $ f opt & _2 . each . mapped %~ liftRlpcError
|
||||
|
||||
instance MonadTrans (RLPCT e) where
|
||||
type RLPC = RLPCT Identity
|
||||
|
||||
type RLPCIO = RLPCT IO
|
||||
|
||||
instance MonadTrans RLPCT where
|
||||
lift = RLPCT . lift . lift
|
||||
|
||||
instance (MonadState s m) => MonadState s (RLPCT e m) where
|
||||
state = lift . state
|
||||
|
||||
type RLPC e = RLPCT e Identity
|
||||
|
||||
type RLPCIO e = RLPCT e IO
|
||||
|
||||
evalRLPCT :: RLPCOptions
|
||||
-> RLPCT e m a
|
||||
-> m (Either e (a, [e]))
|
||||
evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
|
||||
instance (MonadIO m) => MonadIO (RLPCT m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
evalRLPC :: RLPCOptions
|
||||
-> RLPC e a
|
||||
-> Either e (a, [e])
|
||||
evalRLPC o m = coerce $ evalRLPCT o m
|
||||
-> RLPC a
|
||||
-> (Maybe a, [MsgEnvelope RlpcError])
|
||||
evalRLPC opt r = runRLPCT r
|
||||
& flip runReaderT opt
|
||||
& runErrorful
|
||||
|
||||
evalRLPCIO :: (Exception e)
|
||||
=> RLPCOptions
|
||||
-> RLPCIO e a
|
||||
-> IO (a, [e])
|
||||
evalRLPCIO o m = do
|
||||
m' <- evalRLPCT o m
|
||||
case m' of
|
||||
-- TODO: errors
|
||||
Left e -> throwIO e
|
||||
Right a -> pure a
|
||||
|
||||
evalRLPCT :: RLPCOptions
|
||||
-> RLPCT m a
|
||||
-> m (Maybe a, [MsgEnvelope RlpcError])
|
||||
evalRLPCT opt r = runRLPCT r
|
||||
& flip runReaderT opt
|
||||
& runErrorfulT
|
||||
|
||||
liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT (MsgEnvelope e) m a -> RLPCT m a
|
||||
liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
|
||||
|
||||
hoistRlpcT :: (forall a. m a -> n a)
|
||||
-> RLPCT m a -> RLPCT n a
|
||||
hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
|
||||
ErrorfulT $ f $ evalRLPCT opt rma
|
||||
|
||||
data RLPCOptions = RLPCOptions
|
||||
{ _rlpcLogFile :: Maybe FilePath
|
||||
, _rlpcDebugOpts :: DebugOpts
|
||||
, _rlpcDFlags :: HashSet DebugFlag
|
||||
, _rlpcFFlags :: HashSet CompilerFlag
|
||||
, _rlpcEvaluator :: Evaluator
|
||||
, _rlpcHeapTrigger :: Int
|
||||
, _rlpcLanguage :: Maybe Language
|
||||
, _rlpcInputFiles :: [FilePath]
|
||||
}
|
||||
deriving Show
|
||||
@@ -107,58 +127,126 @@ data RLPCOptions = RLPCOptions
|
||||
data Evaluator = EvaluatorGM | EvaluatorTI
|
||||
deriving Show
|
||||
|
||||
data Severity = Error
|
||||
| Warning
|
||||
| Debug
|
||||
deriving Show
|
||||
|
||||
-- temporary until we have a new doc building system
|
||||
type ErrorDoc = String
|
||||
|
||||
class Diagnostic e where
|
||||
errorDoc :: e -> ErrorDoc
|
||||
|
||||
instance (Monad m) => MonadErrorful e (RLPCT e m) where
|
||||
addWound = RLPCT . lift . addWound
|
||||
addFatal = RLPCT . lift . addFatal
|
||||
data Language = LanguageRlp | LanguageCore
|
||||
deriving Show
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
instance Default RLPCOptions where
|
||||
def = RLPCOptions
|
||||
{ _rlpcLogFile = Nothing
|
||||
, _rlpcDebugOpts = mempty
|
||||
, _rlpcDFlags = mempty
|
||||
, _rlpcFFlags = mempty
|
||||
, _rlpcEvaluator = EvaluatorGM
|
||||
, _rlpcHeapTrigger = 200
|
||||
, _rlpcInputFiles = []
|
||||
, _rlpcLanguage = Nothing
|
||||
}
|
||||
|
||||
type DebugOpts = HashSet DebugFlag
|
||||
-- debug flags are passed with -dFLAG
|
||||
type DebugFlag = Text
|
||||
|
||||
data DebugFlag = DDumpEval
|
||||
| DDumpOpts
|
||||
| DDumpAST
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
instance Hashable DebugFlag
|
||||
type CompilerFlag = Text
|
||||
|
||||
makeLenses ''RLPCOptions
|
||||
pure []
|
||||
|
||||
whenFlag :: (MonadReader s m) => SimpleGetter s Bool -> m () -> m ()
|
||||
whenFlag l m = asks (^. l) >>= \a -> if a then m else pure ()
|
||||
addDebugMsg :: (Monad m, IsText e) => Text -> e -> RLPCT m ()
|
||||
addDebugMsg tag e = addWound . debugMsg tag $ Text [e ^. unpacked . packed]
|
||||
|
||||
-- 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
|
||||
-- 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
|
||||
|
||||
flagDDumpEval :: SimpleGetter RLPCOptions Bool
|
||||
flagDDumpEval = flagGetter DDumpEval
|
||||
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
|
||||
|
||||
flagDDumpOpts :: SimpleGetter RLPCOptions Bool
|
||||
flagDDumpOpts = flagGetter DDumpOpts
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
flagDDumpAST :: SimpleGetter RLPCOptions Bool
|
||||
flagDDumpAST = flagGetter DDumpAST
|
||||
evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a
|
||||
evalRLPCIO opt r = do
|
||||
(ma,es) <- evalRLPCT opt r
|
||||
putRlpcErrs opt es
|
||||
case ma of
|
||||
Just x -> pure x
|
||||
Nothing -> die "Failed, no code compiled."
|
||||
|
||||
putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
|
||||
putRlpcErrs opt es = case opt ^. rlpcLogFile of
|
||||
Just lf -> withFile lf WriteMode putter
|
||||
Nothing -> putter stderr
|
||||
where
|
||||
putter h = hPutStrLn h `traverse_` renderRlpcErrs opt es
|
||||
|
||||
renderRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> [String]
|
||||
renderRlpcErrs opts = (if don'tBother then id else filter byTag)
|
||||
>>> fmap prettyRlpcMsg
|
||||
where
|
||||
dflags = opts ^. rlpcDFlags
|
||||
don'tBother = "ALL" `S.member` (opts ^. rlpcDFlags)
|
||||
|
||||
byTag :: MsgEnvelope RlpcError -> Bool
|
||||
byTag (view msgSeverity -> SevDebug t) =
|
||||
t `S.member` dflags
|
||||
byTag _ = True
|
||||
|
||||
prettyRlpcMsg :: MsgEnvelope RlpcError -> String
|
||||
prettyRlpcMsg m@(view msgSeverity -> SevDebug _) = prettyRlpcDebugMsg m
|
||||
prettyRlpcMsg m = render $ docRlpcErr m
|
||||
|
||||
prettyRlpcDebugMsg :: MsgEnvelope RlpcError -> String
|
||||
prettyRlpcDebugMsg msg =
|
||||
T.unpack . foldMap mkLine $ [ t' | t <- ts, t' <- T.lines t ]
|
||||
where
|
||||
mkLine s = "-d" <> tag <> ": " <> s <> "\n"
|
||||
Text ts = msg ^. msgDiagnostic
|
||||
SevDebug tag = msg ^. msgSeverity
|
||||
|
||||
docRlpcErr :: MsgEnvelope RlpcError -> Doc
|
||||
docRlpcErr msg = header
|
||||
$$ nest 2 bullets
|
||||
$$ source
|
||||
where
|
||||
source = vcat $ zipWith (<+>) rule srclines
|
||||
where
|
||||
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
||||
srclines = ["", "<problematic source code>", ""]
|
||||
filename = msgColour "<input>"
|
||||
pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
|
||||
<> ":"
|
||||
<> tshow (msg ^. msgSpan . srcspanColumn)
|
||||
|
||||
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
|
||||
<> errorColour "error" <> msgColour ":"
|
||||
|
||||
bullets = let Text ts = msg ^. msgDiagnostic
|
||||
in vcat $ hang "•" 2 . ttext . msgColour <$> ts
|
||||
|
||||
msgColour = Ansi.white . Ansi.bold
|
||||
errorColour = Ansi.red . Ansi.bold
|
||||
ttext = text . T.unpack
|
||||
tshow :: (Show a) => a -> Text
|
||||
tshow = T.pack . show
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
forFiles_ :: (Monad m)
|
||||
=> (FilePath -> RLPCT m a)
|
||||
-> RLPCT m ()
|
||||
forFiles_ k = do
|
||||
fs <- view rlpcInputFiles
|
||||
forM_ fs k
|
||||
|
||||
-- TODO: catch any exceptions, i.e. non-existent files should be handled by the
|
||||
-- compiler
|
||||
withSource :: (MonadIO m) => FilePath -> (Text -> RLPCT m a) -> RLPCT m a
|
||||
withSource f k = liftIO (T.readFile f) >>= k
|
||||
|
||||
|
||||
77
src/Compiler/RlpcError.hs
Normal file
77
src/Compiler/RlpcError.hs
Normal file
@@ -0,0 +1,77 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
|
||||
module Compiler.RlpcError
|
||||
( IsRlpcError(..)
|
||||
, MsgEnvelope(..)
|
||||
, Severity(..)
|
||||
, RlpcError(..)
|
||||
, msgSpan
|
||||
, msgDiagnostic
|
||||
, msgSeverity
|
||||
, liftRlpcErrors
|
||||
, errorMsg
|
||||
, debugMsg
|
||||
-- * Located Comonad
|
||||
, Located(..)
|
||||
, SrcSpan(..)
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Monad.Errorful
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import GHC.Exts (IsString(..))
|
||||
import Lens.Micro.Platform
|
||||
import Lens.Micro.Platform.Internal
|
||||
import Compiler.Types
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data MsgEnvelope e = MsgEnvelope
|
||||
{ _msgSpan :: SrcSpan
|
||||
, _msgDiagnostic :: e
|
||||
, _msgSeverity :: Severity
|
||||
}
|
||||
deriving (Functor, Show)
|
||||
|
||||
newtype RlpcError = Text [Text]
|
||||
deriving Show
|
||||
|
||||
instance IsString RlpcError where
|
||||
fromString = Text . pure . T.pack
|
||||
|
||||
class IsRlpcError e where
|
||||
liftRlpcError :: e -> RlpcError
|
||||
|
||||
instance IsRlpcError RlpcError where
|
||||
liftRlpcError = id
|
||||
|
||||
data Severity = SevWarning
|
||||
| SevError
|
||||
| SevDebug Text -- ^ Tag
|
||||
deriving Show
|
||||
|
||||
makeLenses ''MsgEnvelope
|
||||
|
||||
liftRlpcErrors :: (Functor m, IsRlpcError e)
|
||||
=> ErrorfulT e m a
|
||||
-> ErrorfulT RlpcError m a
|
||||
liftRlpcErrors = mapErrorful liftRlpcError
|
||||
|
||||
instance (IsRlpcError e) => IsRlpcError (MsgEnvelope e) where
|
||||
liftRlpcError msg = msg ^. msgDiagnostic & liftRlpcError
|
||||
|
||||
errorMsg :: SrcSpan -> e -> MsgEnvelope e
|
||||
errorMsg s e = MsgEnvelope
|
||||
{ _msgSpan = s
|
||||
, _msgDiagnostic = e
|
||||
, _msgSeverity = SevError
|
||||
}
|
||||
|
||||
debugMsg :: Text -> e -> MsgEnvelope e
|
||||
debugMsg tag e = MsgEnvelope
|
||||
-- TODO: not pretty, but it is a debug message after all
|
||||
{ _msgSpan = SrcSpan 0 0 0 0
|
||||
, _msgDiagnostic = e
|
||||
, _msgSeverity = SevDebug tag
|
||||
}
|
||||
|
||||
99
src/Compiler/Types.hs
Normal file
99
src/Compiler/Types.hs
Normal file
@@ -0,0 +1,99 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Compiler.Types
|
||||
( SrcSpan(..)
|
||||
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
|
||||
, Located(..)
|
||||
, _Located
|
||||
, located
|
||||
, nolo
|
||||
, (<<~), (<~>), (<#>)
|
||||
|
||||
-- * Re-exports
|
||||
, Comonad
|
||||
, Apply
|
||||
, Bind
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Control.Comonad
|
||||
import Data.Functor.Apply
|
||||
import Data.Functor.Bind
|
||||
import Control.Lens hiding ((<<~))
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Token wrapped with a span (line, column, absolute, length)
|
||||
data Located a = Located SrcSpan a
|
||||
deriving (Show, Lift, Functor)
|
||||
|
||||
located :: Lens (Located a) (Located b) a b
|
||||
located = lens extract ($>)
|
||||
|
||||
instance Apply Located where
|
||||
liftF2 f (Located sa p) (Located sb q)
|
||||
= Located (sa <> sb) (p `f` q)
|
||||
|
||||
instance Bind Located where
|
||||
Located sa a >>- k = Located (sa <> sb) b
|
||||
where
|
||||
Located sb b = k a
|
||||
|
||||
instance Comonad Located where
|
||||
extract (Located _ a) = a
|
||||
extend ck w@(Located p _) = Located p (ck w)
|
||||
|
||||
data SrcSpan = SrcSpan
|
||||
!Int -- ^ Line
|
||||
!Int -- ^ Column
|
||||
!Int -- ^ Absolute
|
||||
!Int -- ^ Length
|
||||
deriving (Show, Lift)
|
||||
|
||||
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
||||
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
||||
(\ (a,b,c,d) -> SrcSpan a b c d)
|
||||
|
||||
srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
|
||||
srcspanLine = tupling . _1
|
||||
srcspanColumn = tupling . _2
|
||||
srcspanAbs = tupling . _3
|
||||
srcspanLen = tupling . _4
|
||||
|
||||
-- | debug tool
|
||||
nolo :: a -> Located a
|
||||
nolo = Located (SrcSpan 0 0 0 0)
|
||||
|
||||
instance Semigroup SrcSpan where
|
||||
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
|
||||
l = min la lb
|
||||
c = min ca cb
|
||||
a = min aa ab
|
||||
s = case aa `compare` ab of
|
||||
EQ -> max sa sb
|
||||
LT -> max sa (ab + lb - aa)
|
||||
GT -> max sb (aa + la - ab)
|
||||
|
||||
-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for
|
||||
-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style.
|
||||
|
||||
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
|
||||
(<<~) = (<<=)
|
||||
|
||||
infixl 4 <<~
|
||||
|
||||
-- | Similar to '(<*>)', but with a cokleisli arrow.
|
||||
|
||||
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
|
||||
mc <~> ma = mc >>- \f -> ma =>> f
|
||||
|
||||
infixl 4 <~>
|
||||
|
||||
-- this is getting silly
|
||||
|
||||
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
|
||||
fab <#> a = fmap ($ a) fab
|
||||
|
||||
infixl 4 <#>
|
||||
|
||||
makePrisms ''Located
|
||||
|
||||
Reference in New Issue
Block a user