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

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

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
+

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
 

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|

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.
 --

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 }) ->

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

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"
 

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