compiles (kill me)

man

src/Core/Examples.hs

@@ -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
 --         ]
 
+--}

src/Core/HindleyMilner.hs

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

src/Core/Lex.x

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

src/Core/Parse.y

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

src/Core/TH.hs

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