msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

compiles (kill me)

Browse Source 
man
This commit is contained in:
crumbtoo
2024-01-19 14:09:26 -07:00
parent f22d4238f5
commit f47f325e34
9 changed files with 126 additions and 172 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
src/Compiler/JustRun.hs
View File

@@ -26,21 +26,22 @@ import Data.Function ((&))
import GM
----------------------------------------------------------------------------------
justLexSrc :: String -> Either RlpcError [CoreToken]
-- justLexSrc :: String -> Either RlpcError [CoreToken]
justLexSrc s = lexCoreR (T.pack s)
& fmap (map $ \ (Located _ _ _ t) -> t)
& rlpcToEither
justParseSrc :: String -> Either RlpcError Program'
-- justParseSrc :: String -> Either RlpcError Program'
justParseSrc s = parse (T.pack s)
& rlpcToEither
where parse = lexCoreR >=> parseCoreProgR
justTypeCheckSrc :: String -> Either RlpcError Program'
-- justTypeCheckSrc :: String -> Either RlpcError Program'
justTypeCheckSrc s = typechk (T.pack s)
& rlpcToEither
where typechk = lexCoreR >=> parseCoreProgR >=> checkCoreProgR
rlpcToEither :: RLPC e a -> Either e a
rlpcToEither = evalRLPC def >>> fmap fst
rlpcToEither = undefined
{-# WARNING rlpcToEither "unimpl" #-}

78
src/Compiler/RLPC.hs
View File

@@ -17,8 +17,6 @@ module Compiler.RLPC
, RLPCIO
, RLPCOptions(RLPCOptions)
, RlpcError(..)
, IsRlpcError(..)
, rlpc
, addFatal
, addWound
, MonadErrorful
@@ -27,9 +25,6 @@ module Compiler.RLPC
, evalRLPCT
, evalRLPCIO
, evalRLPC
, addRlpcWound
, addRlpcFatal
, liftRlpcErrs
, rlpcLogFile
, rlpcDebugOpts
, rlpcEvaluator
@@ -60,46 +55,25 @@ import Lens.Micro
import Lens.Micro.TH
----------------------------------------------------------------------------------
-- TODO: fancy errors
newtype RLPCT e m a = RLPCT {
runRLPCT :: ReaderT RLPCOptions (ErrorfulT e m) a
newtype RLPCT m a = RLPCT {
runRLPCT :: forall e. (RlpcError e)
=> ReaderT RLPCOptions (ErrorfulT e m) a
}
-- TODO: incorrect ussage of MonadReader. RLPC should have its own
-- environment access functions
deriving (Functor, Applicative, Monad, MonadReader RLPCOptions)
deriving instance (MonadIO m) => MonadIO (RLPCT e m)
type RLPC = RLPCT Identity
instance MonadTrans (RLPCT e) where
lift = RLPCT . lift . lift
type RLPCIO = RLPCT IO
instance (MonadState s m) => MonadState s (RLPCT e m) where
state = lift . state
instance Functor (RLPCT m) where
instance Applicative (RLPCT m) where
instance Monad (RLPCT m) where
type RLPC e = RLPCT e Identity
evalRLPC = undefined
evalRLPCT = undefined
evalRLPCIO = undefined
type RLPCIO e = RLPCT e IO
evalRLPCT :: RLPCOptions
-> RLPCT e m a
-> m (Either e (a, [e]))
evalRLPCT o = runRLPCT >>> flip runReaderT o >>> runErrorfulT
evalRLPC :: RLPCOptions
-> RLPC e a
-> Either e (a, [e])
evalRLPC o m = coerce $ evalRLPCT o m
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
liftErrorful :: (RlpcError e) => ErrorfulT e m a -> RLPCT m a
liftErrorful e = undefined
data RLPCOptions = RLPCOptions
{ _rlpcLogFile :: Maybe FilePath
@@ -113,32 +87,6 @@ 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
instance (Monad m) => MonadErrorful e (RLPCT e m) where
addWound = RLPCT . lift . addWound
addFatal = RLPCT . lift . addFatal
liftRlpcErrs :: (IsRlpcError e, Monad m)
=> RLPCT e m a -> RLPCT RlpcError m a
liftRlpcErrs m = RLPCT . ReaderT $ \r ->
mapErrors liftRlpcErr $ runRLPCT >>> (`runReaderT` r) $ m
addRlpcWound :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcWound = addWound . liftRlpcErr
addRlpcFatal :: (IsRlpcError e, Monad m) => e -> RLPCT RlpcError m ()
addRlpcFatal = addWound . liftRlpcErr
rlpc :: (Monad m) => ErrorfulT e m a -> RLPCT e m a
rlpc = RLPCT . ReaderT . const
----------------------------------------------------------------------------------
instance Default RLPCOptions where

34
src/Compiler/RlpcError.hs
View File

@@ -1,15 +1,39 @@
{-# LANGUAGE TemplateHaskell #-}
module Compiler.RlpcError
( RlpcError(..)
, IsRlpcError(..)
, MsgEnvelope(..)
, Severity
, RlpcErrorDoc(..)
, SrcSpan(..)
, msgSpan
, msgDiagnostic
, msgSeverity
)
where
----------------------------------------------------------------------------------
import Control.Monad.Errorful
import Lens.Micro.TH
----------------------------------------------------------------------------------
data RlpcError = RlpcErr String -- temp
deriving Show
data MsgEnvelope = MsgEnvelope
{ _msgSpan :: SrcSpan
, _msgDiagnostic :: forall e. (RlpcError e) => e
, _msgSeverity :: Severity
}
class IsRlpcError a where
liftRlpcErr :: a -> RlpcError
class RlpcError e where
liftRlpcError :: e -> RlpcErrorDoc
data RlpcErrorDoc
data Severity = SevWarning
| SevError
deriving Show
data SrcSpan = SrcSpan
!Int -- ^ Line
!Int -- ^ Column
!Int -- ^ Length
makeLenses ''MsgEnvelope

48
src/Control/Monad/Errorful.hs
View File

@@ -14,60 +14,52 @@ module Control.Monad.Errorful
import Control.Monad.Trans
import Data.Functor.Identity
import Data.Coerce
import Data.HashSet (HashSet)
import Data.HashSet qualified as H
import Lens.Micro
----------------------------------------------------------------------------------
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Either e (a, [e])) }
newtype ErrorfulT e m a = ErrorfulT { runErrorfulT :: m (Maybe a, [e]) }
type Errorful e = ErrorfulT e Identity
pattern Errorful :: (Either e (a, [e])) -> Errorful e a
pattern Errorful :: (Maybe a, [e]) -> Errorful e a
pattern Errorful a = ErrorfulT (Identity a)
runErrorful :: Errorful e a -> Either e (a, [e])
runErrorful :: Errorful e a -> (Maybe a, [e])
runErrorful m = coerce (runErrorfulT m)
class (Applicative m) => MonadErrorful e m | m -> e where
addWound :: e -> m ()
addFatal :: e -> m a
-- not sure if i want to add this yet...
-- catchWound :: m a -> (e -> m a) -> m a
addWound :: e -> m ()
addFatal :: e -> m a
instance (Applicative m) => MonadErrorful e (ErrorfulT e m) where
addWound e = ErrorfulT $ pure . Right $ ((), [e])
addFatal e = ErrorfulT $ pure . Left $ e
addWound e = ErrorfulT $ pure (Just (), [e])
addFatal e = ErrorfulT $ pure (Nothing, [e])
instance MonadTrans (ErrorfulT e) where
lift m = ErrorfulT (Right . (,[]) <$> m)
lift m = ErrorfulT ((\x -> (Just x,[])) <$> m)
instance (MonadIO m) => MonadIO (ErrorfulT e m) where
liftIO = lift . liftIO
instance (Functor m) => Functor (ErrorfulT e m) where
fmap f (ErrorfulT m) = ErrorfulT $ fmap (_1 %~ f) <$> m
fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
instance (Applicative m) => Applicative (ErrorfulT e m) where
pure a = ErrorfulT (pure . Right $ (a, []))
pure a = ErrorfulT . pure $ (Just a, [])
m <*> a = ErrorfulT (m' `apply` a')
where
m' = runErrorfulT m
a' = runErrorfulT a
-- TODO: strict concatenation
apply = liftA2 $ liftA2 (\ (f,e1) (x,e2) -> (f x, e1 ++ e2))
ErrorfulT m <*> ErrorfulT n = ErrorfulT $ m `apply` n where
apply :: m (Maybe (a -> b), [e]) -> m (Maybe a, [e]) -> m (Maybe b, [e])
apply = liftA2 $ \ (mf,e1) (ma,e2) -> (mf <*> ma, e1 <> e2)
instance (Monad m) => Monad (ErrorfulT e m) where
ErrorfulT m >>= k = ErrorfulT $ do
m' <- m
case m' of
Right (a,es) -> runErrorfulT (k a)
Left e -> pure (Left e)
(a,es) <- m
case a of
Just x -> runErrorfulT (k x)
Nothing -> pure (Nothing, es)
mapErrors :: (Monad m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
mapErrors f m = ErrorfulT $ do
x <- runErrorfulT m
case x of
Left e -> pure . Left $ f e
Right (a,es) -> pure . Right $ (a, f <$> es)
mapErrors f m = undefined

8
src/Core/Examples.hs
View File

@@ -15,6 +15,13 @@ import Core.Syntax
import Core.TH
----------------------------------------------------------------------------------
fac3 = undefined
sumList = undefined
constDivZero = undefined
idCase = undefined
{--
letrecExample :: Program'
letrecExample = [coreProg|
pair x y f = f x y;
@@ -216,3 +223,4 @@ idCase = [coreProg|
-- , ScDef "Cons" [] $ Con 2 2
-- ]
--}

11
src/Core/HindleyMilner.hs
View File

@@ -49,8 +49,7 @@ data TypeError
deriving (Show, Eq)
-- TODO:
instance IsRlpcError TypeError where
liftRlpcErr = RlpcErr . show
instance RlpcError TypeError where
-- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may
-- throw any number of fatal or nonfatal errors. Run with @runErrorful@.
@@ -88,10 +87,10 @@ checkCoreProg p = scDefs
where scname = sc ^. _lhs._1
-- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks.
checkCoreProgR :: Program' -> RLPC RlpcError Program'
checkCoreProgR p = do
liftRlpcErrs . rlpc . checkCoreProg $ p
pure p
-- checkCoreProgR :: Program' -> RLPC Program'
checkCoreProgR = undefined
{-# WARNING checkCoreProgR "unimpl" #-}
-- | Infer the type of an expression under some context.
--

25
src/Core/Lex.x
View File

@@ -167,24 +167,23 @@ lexWith :: (Text -> CoreToken) -> Lexer
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s)
-- | The main lexer driver.
lexCore :: Text -> RLPC SrcError [Located CoreToken]
lexCore :: Text -> RLPC [Located CoreToken]
lexCore s = case m of
Left e -> addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = SrcErrLexical e
}
Left e -> undefined
Right ts -> pure ts
where
m = runAlex s lexStream
lexCoreR :: Text -> RLPC RlpcError [Located CoreToken]
lexCoreR = liftRlpcErrs . lexCore
{-# WARNING lexCore "unimpl" #-}
lexCoreR :: Text -> RLPC [Located CoreToken]
lexCoreR t = undefined
{-# WARNING lexCoreR "unimpl" #-}
-- | @lexCore@, but the tokens are stripped of location info. Useful for
-- debugging
lexCore' :: Text -> RLPC SrcError [CoreToken]
lexCore' :: Text -> RLPC [CoreToken]
lexCore' s = fmap f <$> lexCore s
where f (Located _ _ _ t) = t
@@ -200,12 +199,10 @@ data ParseError = ParErrLexical String
deriving Show
-- TODO:
instance IsRlpcError SrcError where
liftRlpcErr = RlpcErr . show
instance RlpcError SrcError where
-- TODO:
instance IsRlpcError ParseError where
liftRlpcErr = RlpcErr . show
instance RlpcError ParseError where
alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->

52
src/Core/Parse.y
View File

@@ -10,7 +10,6 @@ module Core.Parse
, parseCoreProg
, parseCoreProgR
, module Core.Lex -- temp convenience
, parseTmp
, SrcError
, Module
)
@@ -34,7 +33,7 @@ import Data.HashMap.Strict qualified as H
%name parseCoreProg StandaloneProgram
%tokentype { Located CoreToken }
%error { parseError }
%monad { RLPC SrcError }
%monad { RLPC } { happyBind } { happyPure }
%token
let { Located _ _ _ TokenLet }
@@ -189,34 +188,21 @@ Con : '(' consym ')' { $2 }
{
parseError :: [Located CoreToken] -> RLPC SrcError a
parseError (Located y x l _ : _) = addFatal err
where err = SrcError
{ _errSpan = (y,x,l)
, _errSeverity = Error
, _errDiagnostic = SrcErrParse
}
parseError :: [Located CoreToken] -> RLPC a
parseError (Located y x l _ : _) = undefined
parseTmp :: IO (Module Name)
parseTmp = do
s <- TIO.readFile "/tmp/t.hs"
case parse s of
Left e -> error (show e)
Right (ts,_) -> pure ts
where
parse = evalRLPC def . (lexCore >=> parseCore)
{-# WARNING parseError "unimpl" #-}
exprPragma :: [String] -> RLPC SrcError (Expr Name)
exprPragma ("AST" : e) = astPragma e
exprPragma _ = addFatal err
where err = SrcError
{ _errSpan = (0,0,0) -- TODO: span
, _errSeverity = Warning
, _errDiagnostic = SrcErrUnknownPragma "" -- TODO: missing pragma
}
exprPragma :: [String] -> RLPC (Expr Name)
exprPragma ("AST" : e) = undefined
exprPragma _ = undefined
astPragma :: [String] -> RLPC SrcError (Expr Name)
astPragma = pure . read . unwords
{-# WARNING exprPragma "unimpl" #-}
astPragma :: [String] -> RLPC (Expr Name)
astPragma _ = undefined
{-# WARNING astPragma "unimpl" #-}
insTypeSig :: (Hashable b) => (b, Type) -> Program b -> Program b
insTypeSig ts = programTypeSigs %~ uncurry H.insert ts
@@ -230,8 +216,16 @@ insScDef sc = programScDefs %~ (sc:)
singletonScDef :: (Hashable b) => ScDef b -> Program b
singletonScDef sc = insScDef sc mempty
parseCoreProgR :: [Located CoreToken] -> RLPC RlpcError Program'
parseCoreProgR = liftRlpcErrs . parseCoreProg
parseCoreProgR :: [Located CoreToken] -> RLPC Program'
parseCoreProgR a = undefined
{-# WARNING parseCoreProgR "unimpl" #-}
happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b
happyBind m k = m >>= k
happyPure :: a -> RLPC a
happyPure a = pure a
}

31
src/Core/TH.hs
View File

@@ -19,6 +19,7 @@ import Data.Default.Class (def)
import Data.Text qualified as T
import Core.Parse
import Core.Lex
import Core.Syntax (Expr(Var))
import Core.HindleyMilner (checkCoreProgR)
----------------------------------------------------------------------------------
@@ -58,30 +59,20 @@ coreProgT = QuasiQuoter
}
qCore :: String -> Q Exp
qCore s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parse = evalRLPC def . (lexCore >=> parseCore)
qCore s = undefined
{-# WARNING qCore "unimpl" #-}
qCoreExpr :: String -> Q Exp
qCoreExpr s = case parseExpr (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parseExpr = evalRLPC def . (lexCore >=> parseCoreExpr)
qCoreExpr s = undefined
{-# WARNING qCoreExpr "unimpl" #-}
qCoreProg :: String -> Q Exp
qCoreProg s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,ts) -> lift m
where
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR)
qCoreProg s = undefined
{-# WARNING qCoreProg "unimpl" #-}
qCoreProgT :: String -> Q Exp
qCoreProgT s = case parse (T.pack s) of
Left e -> error (show e)
Right (m,_) -> lift m
where
parse = evalRLPC def . (lexCoreR >=> parseCoreProgR >=> checkCoreProgR)
qCoreProgT s = undefined