diff --git a/rlp.cabal b/rlp.cabal index 59867dc..a48324a 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -73,6 +73,9 @@ library hs-source-dirs: src default-language: GHC2021 + default-extensions: + OverloadedStrings + executable rlpc import: warnings main-is: Main.hs diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index 5acedc6..0de0638 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -36,6 +36,7 @@ module Compiler.RLPC , flagDDumpOpts , flagDDumpAST , def + , liftErrorful ) where ---------------------------------------------------------------------------------- @@ -47,6 +48,7 @@ import Control.Monad.Errorful import Compiler.RlpcError import Data.Functor.Identity import Data.Default.Class +import Data.Foldable import GHC.Generics (Generic) import Data.Hashable (Hashable) import Data.HashSet (HashSet) @@ -54,26 +56,44 @@ import Data.HashSet qualified as S import Data.Coerce import Lens.Micro import Lens.Micro.TH +import System.Exit ---------------------------------------------------------------------------------- newtype RLPCT m a = RLPCT { runRLPCT :: ReaderT RLPCOptions (ErrorfulT RlpcError m) a } + deriving (Functor, Applicative, Monad) type RLPC = RLPCT Identity type RLPCIO = RLPCT IO -instance Functor (RLPCT m) where -instance Applicative (RLPCT m) where -instance Monad (RLPCT m) where +evalRLPC :: RLPCOptions + -> RLPC a + -> (Maybe a, [RlpcError]) +evalRLPC opt r = runRLPCT r + & flip runReaderT opt + & runErrorful -evalRLPC = undefined +evalRLPCT :: (Monad m) + => RLPCOptions + -> RLPCT m a + -> m (Maybe a, [RlpcError]) evalRLPCT = undefined -evalRLPCIO = undefined -liftErrorful :: ErrorfulT e m a -> RLPCT m a -liftErrorful e = undefined +evalRLPCIO :: RLPCOptions -> RLPCIO a -> IO a +evalRLPCIO opt r = do + (ma,es) <- evalRLPCT opt r + putRlpcErrs es + case ma of + Just x -> pure x + Nothing -> die "Failed, no code compiled." + +putRlpcErrs :: [RlpcError] -> IO () +putRlpcErrs = traverse_ print + +liftErrorful :: (Monad m, IsRlpcError e) => ErrorfulT e m a -> RLPCT m a +liftErrorful e = RLPCT $ lift (liftRlpcErrors e) data RLPCOptions = RLPCOptions { _rlpcLogFile :: Maybe FilePath diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 755f05d..cff9375 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} module Compiler.RlpcError ( IsRlpcError(..) , MsgEnvelope(..) @@ -8,11 +9,16 @@ module Compiler.RlpcError , msgSpan , msgDiagnostic , msgSeverity + , liftRlpcErrors ) where ---------------------------------------------------------------------------------- import Control.Monad.Errorful -import Lens.Micro.TH +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Exts (IsString(..)) +import Lens.Micro.Platform +import Lens.Micro.Platform.Internal ---------------------------------------------------------------------------------- data MsgEnvelope e = MsgEnvelope @@ -21,10 +27,17 @@ data MsgEnvelope e = MsgEnvelope , _msgSeverity :: Severity } +newtype RlpcError = Text [Text] + deriving Show + +instance IsString RlpcError where + fromString = Text . pure . T.pack + class IsRlpcError e where liftRlpcError :: e -> RlpcError -data RlpcError +instance IsRlpcError RlpcError where + liftRlpcError = id data Severity = SevWarning | SevError @@ -37,3 +50,8 @@ data SrcSpan = SrcSpan makeLenses ''MsgEnvelope +liftRlpcErrors :: (Functor m, IsRlpcError e) + => ErrorfulT e m a + -> ErrorfulT RlpcError m a +liftRlpcErrors = mapErrorful liftRlpcError + diff --git a/src/Control/Monad/Errorful.hs b/src/Control/Monad/Errorful.hs index 2f75269..5967b45 100644 --- a/src/Control/Monad/Errorful.hs +++ b/src/Control/Monad/Errorful.hs @@ -6,7 +6,7 @@ module Control.Monad.Errorful , runErrorfulT , Errorful , runErrorful - , mapErrors + , mapErrorful , MonadErrorful(..) ) where @@ -60,6 +60,11 @@ instance (Monad m) => Monad (ErrorfulT e m) where 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 = undefined +mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a +mapErrorful f (ErrorfulT m) = ErrorfulT $ + m & mapped . _2 . mapped %~ f + +-- when microlens-pro drops we can write this as +-- mapErrorful f = coerced . mapped . _2 . mappd %~ f +-- lol diff --git a/src/Core/Examples.hs b/src/Core/Examples.hs index 39680a4..2ca54e3 100644 --- a/src/Core/Examples.hs +++ b/src/Core/Examples.hs @@ -15,12 +15,12 @@ import Core.Syntax import Core.TH ---------------------------------------------------------------------------------- -fac3 = undefined -sumList = undefined -constDivZero = undefined -idCase = undefined +-- fac3 = undefined +-- sumList = undefined +-- constDivZero = undefined +-- idCase = undefined -{-- +--- letrecExample :: Program' letrecExample = [coreProg| diff --git a/src/Core/HindleyMilner.hs b/src/Core/HindleyMilner.hs index 12c7436..ba9e987 100644 --- a/src/Core/HindleyMilner.hs +++ b/src/Core/HindleyMilner.hs @@ -25,6 +25,7 @@ import Control.Monad (foldM, void) import Control.Monad.Errorful (Errorful, addFatal) import Control.Monad.State import Control.Monad.Utils (mapAccumLM) +import Text.Printf import Core.Syntax ---------------------------------------------------------------------------------- @@ -48,8 +49,20 @@ data TypeError | TyErrMissingTypeSig Name deriving (Show, Eq) --- TODO: instance IsRlpcError TypeError where + liftRlpcError = \case + -- todo: use anti-parser instead of show + TyErrCouldNotUnify t u -> Text + [ T.pack $ printf "Could not match type `%s' with `%s'." + (show t) (show u) + , "Expected: " <> tshow t + , "Got: " <> tshow u + ] + TyErrRecursiveType t x -> Text + [ T.pack $ printf "recursive type error lol" + ] + + where tshow = T.pack . show -- | Synonym for @Errorful [TypeError]@. This means an @HMError@ action may -- throw any number of fatal or nonfatal errors. Run with @runErrorful@. @@ -87,10 +100,10 @@ checkCoreProg p = scDefs where scname = sc ^. _lhs._1 -- | @checkCoreProgR p@ returns @p@ if @p@ successfully typechecks. --- checkCoreProgR :: Program' -> RLPC Program' -checkCoreProgR = undefined - -{-# WARNING checkCoreProgR "unimpl" #-} +checkCoreProgR :: Program' -> RLPC Program' +checkCoreProgR p = do + liftErrorful (checkCoreProg p) + pure p -- | Infer the type of an expression under some context. -- diff --git a/src/Core/Lex.x b/src/Core/Lex.x index 1136409..f939258 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -169,17 +169,13 @@ lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located y x l (f $ T.take l s) -- | The main lexer driver. lexCore :: Text -> RLPC [Located CoreToken] lexCore s = case m of - Left e -> undefined + Left e -> error "core lex error" Right ts -> pure ts where m = runAlex s lexStream -{-# WARNING lexCore "unimpl" #-} - lexCoreR :: Text -> RLPC [Located CoreToken] -lexCoreR t = undefined - -{-# WARNING lexCoreR "unimpl" #-} +lexCoreR = lexCore -- | @lexCore@, but the tokens are stripped of location info. Useful for -- debugging @@ -200,9 +196,11 @@ data ParseError = ParErrLexical String -- TODO: instance IsRlpcError SrcError where + liftRlpcError = Text . pure . T.pack . show -- TODO: instance IsRlpcError ParseError where + liftRlpcError = Text . pure . T.pack . show alexEOF :: Alex (Located CoreToken) alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) -> diff --git a/src/Core/Parse.y b/src/Core/Parse.y index abc6c70..a084ebf 100644 --- a/src/Core/Parse.y +++ b/src/Core/Parse.y @@ -189,7 +189,9 @@ Con : '(' consym ')' { $2 } { parseError :: [Located CoreToken] -> RLPC a -parseError (Located y x l _ : _) = undefined +parseError (Located y x l t : _) = + error $ show y <> ":" <> show x + <> ": parse error at token `" <> show t <> "'" {-# WARNING parseError "unimpl" #-} @@ -217,9 +219,7 @@ singletonScDef :: (Hashable b) => ScDef b -> Program b singletonScDef sc = insScDef sc mempty parseCoreProgR :: [Located CoreToken] -> RLPC Program' -parseCoreProgR a = undefined - -{-# WARNING parseCoreProgR "unimpl" #-} +parseCoreProgR = parseCoreProg happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b happyBind m k = m >>= k diff --git a/src/Core/TH.hs b/src/Core/TH.hs index 28bb9c6..8031314 100644 --- a/src/Core/TH.hs +++ b/src/Core/TH.hs @@ -6,7 +6,6 @@ module Core.TH ( coreExpr , coreProg , coreProgT - , core ) where ---------------------------------------------------------------------------------- @@ -14,65 +13,38 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax hiding (Module) import Language.Haskell.TH.Quote import Control.Monad ((>=>)) +import Control.Monad.IO.Class +import Control.Arrow ((>>>)) import Compiler.RLPC import Data.Default.Class (def) +import Data.Text (Text) import Data.Text qualified as T import Core.Parse import Core.Lex -import Core.Syntax (Expr(Var)) +import Core.Syntax import Core.HindleyMilner (checkCoreProgR) ---------------------------------------------------------------------------------- --- TODO: write in terms of a String -> QuasiQuoter - -core :: QuasiQuoter -core = QuasiQuoter - { quoteExp = qCore - , quotePat = error "core quasiquotes may only be used in expressions" - , quoteType = error "core quasiquotes may only be used in expressions" - , quoteDec = error "core quasiquotes may only be used in expressions" - } - coreProg :: QuasiQuoter -coreProg = QuasiQuoter - { quoteExp = qCoreProg - , quotePat = error "core quasiquotes may only be used in expressions" - , quoteType = error "core quasiquotes may only be used in expressions" - , quoteDec = error "core quasiquotes may only be used in expressions" - } +coreProg = mkqq $ lexCoreR >=> parseCoreProgR coreExpr :: QuasiQuoter -coreExpr = QuasiQuoter - { quoteExp = qCoreExpr - , quotePat = error "core quasiquotes may only be used in expressions" - , quoteType = error "core quasiquotes may only be used in expressions" - , quoteDec = error "core quasiquotes may only be used in expressions" - } +coreExpr = mkqq $ lexCoreR >=> parseCoreExpr -- | Type-checked @coreProg@ coreProgT :: QuasiQuoter -coreProgT = QuasiQuoter - { quoteExp = qCoreProgT +coreProgT = mkqq $ lexCoreR >=> parseCoreProgR >=> checkCoreProgR + +mkqq :: (Lift a) => (Text -> RLPC a) -> QuasiQuoter +mkqq p = QuasiQuoter + { quoteExp = mkq p , quotePat = error "core quasiquotes may only be used in expressions" , quoteType = error "core quasiquotes may only be used in expressions" , quoteDec = error "core quasiquotes may only be used in expressions" } -qCore :: String -> Q Exp -qCore s = undefined - -{-# WARNING qCore "unimpl" #-} - -qCoreExpr :: String -> Q Exp -qCoreExpr s = undefined - -{-# WARNING qCoreExpr "unimpl" #-} - -qCoreProg :: String -> Q Exp -qCoreProg s = undefined - -{-# WARNING qCoreProg "unimpl" #-} - -qCoreProgT :: String -> Q Exp -qCoreProgT s = undefined +mkq :: (Lift a) => (Text -> RLPC a) -> String -> Q Exp +mkq parse s = case evalRLPC def (parse $ T.pack s) of + (Just a, _) -> lift a + (Nothing, _) -> error "todo: aaahhbbhjhbdjhabsjh" diff --git a/tst/Core/HindleyMilnerSpec.hs b/tst/Core/HindleyMilnerSpec.hs index 8f498a9..7dbe178 100644 --- a/tst/Core/HindleyMilnerSpec.hs +++ b/tst/Core/HindleyMilnerSpec.hs @@ -38,9 +38,13 @@ spec = do let e = [coreExpr|3|] in check' [] (TyCon "Bool") e `shouldSatisfy` isLeft -infer' :: Context' -> Expr' -> Either TypeError Type -infer' g e = fmap fst . runErrorful $ infer g e +infer' :: Context' -> Expr' -> Either [TypeError] Type +infer' g e = case runErrorful $ infer g e of + (Just t, _) -> Right t + (Nothing, es) -> Left es -check' :: Context' -> Type -> Expr' -> Either TypeError () -check' g t e = fmap fst . runErrorful $ check g t e +check' :: Context' -> Type -> Expr' -> Either [TypeError] () +check' g t e = case runErrorful $ check g t e of + (Just t, _) -> Right () + (Nothing, es) -> Left es diff --git a/tst/Rlp/Parse/DeclsSpec.hs b/tst/Rlp/Parse/DeclsSpec.hs deleted file mode 100644 index e69de29..0000000