ppr debug flags

ddump-parsed

README.md

@@ -22,21 +22,38 @@ $ cabal test --test-show-details=direct
 ```
 
 ### Use
+
+#### TLDR
+
 ```sh
-# Compile and evaluate examples/factorial.hs, with evaluation info dumped to stderr
-$ rlpc -ddump-eval examples/factorial.hs
-# Compile and evaluate t.hs, with evaluation info dumped to t.log
-$ rlpc -ddump-eval -l t.log t.hs
-# Print the raw structure describing the compiler options
-# (option parsing still must succeed in order to print)
-$ rlpc -ddump-opts t.hs
+# Compile and evaluate examples/factorial.cr, with evaluation info dumped to stderr
+$ rlpc -ddump-eval examples/factorial.cr
+# Compile and evaluate t.cr, with evaluation info dumped to t.log
+$ rlpc -ddump-eval -l t.log t.cr
+# Compile and evaluate t.rl, dumping the desugared Core
+$ rlpc -ddump-desugared t.rl
 ```
 
+#### Options
+
+```sh
+Usage: rlpc [-l|--log FILE] [-d DEBUG FLAG] [-f COMPILATION FLAG] 
+            [-e|--evaluator gm|ti] [--heap-trigger INT] [-x|--language rlp|core]
+            FILES...
+```
+
+Available debug flags include:
+* `-ddump-desugared`: dump Core generated from rl'
+* `-ddump-parsed-core`: dump raw Core AST
+* `-ddump-parsed`: dump raw rl' AST
+* `-ddump-eval`: dump evaluation logs
+* `-dALL`: disable debug message filtering. enables **all** debug messages
+
 ### Potential Features
 Listed in order of importance.
 - [x] ADTs
 - [x] First-class functions
-- [ ] Higher-kinded types
+- [x] Higher-kinded types
 - [ ] Typeclasses
 - [x] Parametric polymorphism
 - [x] Hindley-Milner type inference

app/CoreDriver.hs

@@ -5,6 +5,8 @@ module CoreDriver
 --------------------------------------------------------------------------------
 import Compiler.RLPC
 import Control.Monad
+import Data.Text                    qualified as T
+import Lens.Micro.Platform
 
 import Core.Lex
 import Core.Parse
@@ -15,3 +17,8 @@ driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
     withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
 
+driverSource :: T.Text -> RLPCIO ()
+driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
+    where
+        printRes = liftIO . print . view _1
+

app/Main.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE BlockArguments, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
 import Compiler.RLPC
+import Compiler.RlpcError
 import Control.Exception
 import Options.Applicative      hiding (ParseError)
 import Control.Monad
@@ -11,12 +13,13 @@ import Data.Text                (Text)
 import Data.Text                qualified as T
 import Data.Text.IO             qualified as TIO
 import Data.List
+import Data.Maybe               (listToMaybe)
 import System.IO
 import System.Exit              (exitSuccess)
 import Core
 import TI
 import GM
-import Lens.Micro.Mtl
+import Lens.Micro.Platform
 
 import CoreDriver               qualified
 import RlpDriver                qualified
@@ -65,7 +68,7 @@ options = RLPCOptions
                 \triggering the garbage collector"
         <> value 50
         )
-    <*> option languageReader
+    <*> optional # option languageReader
         (  long "language"
         <> short 'x'
         <> metavar "rlp|core"
@@ -80,6 +83,8 @@ languageReader :: ReadM Language
 languageReader = maybeReader $ \case
     "rlp"   -> Just LanguageRlp
     "core"  -> Just LanguageCore
+    "rl"    -> Just LanguageRlp
+    "cr"    -> Just LanguageCore
     _       -> Nothing
 
 debugFlagReader :: ReadM DebugFlag
@@ -102,10 +107,34 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    void $ evalRLPCIO opts driver
+    void $ evalRLPCIO opts dispatch
+
+dispatch :: RLPCIO ()
+dispatch = getLang >>= \case
+    Just LanguageCore -> CoreDriver.driver
+    Just LanguageRlp  -> RlpDriver.driver
+    Nothing           -> addFatal err
+        where
+            -- TODO: why didn't i make the srcspan optional LOL
+            err = errorMsg (SrcSpan 0 0 0 0) $ Text
+                [ "Could not determine source language from filetype."
+                , "Possible Solutions:\n\
+                  \  Suffix the file with `.cr' for Core, or `.rl' for rl'\n\
+                  \  Specify a language with `rlpc -x core' or `rlpc -x rlp'"
+                ]
+  where
+    getLang = liftA2 (<|>)
+        (view rlpcLanguage)
+        -- TODO: we only check the first file lol
+        ((listToMaybe >=> inferLanguage) <$> view rlpcInputFiles)
+
 
 driver :: RLPCIO ()
-driver = view rlpcLanguage >>= \case
-    LanguageCore -> CoreDriver.driver
-    LanguageRlp  -> RlpDriver.driver
+driver = undefined
+
+inferLanguage :: FilePath -> Maybe Language
+inferLanguage fp
+    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+    | otherwise                 = Nothing
 

app/RlpDriver.hs

@@ -1,11 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
 module RlpDriver
     ( driver
     )
     where
 --------------------------------------------------------------------------------
 import Compiler.RLPC
+import Control.Monad
+
+import Rlp.Lex
+import Rlp.Parse
+import Rlp2Core
+import GM
 --------------------------------------------------------------------------------
 
 driver :: RLPCIO ()
-driver = undefined
+driver = forFiles_ $ \f ->
+    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
 

rlp.cabal

@@ -88,6 +88,9 @@ library
         LambdaCase
         ViewPatterns
         DataKinds
+        DerivingVia
+        StandaloneDeriving
+        DerivingStrategies
 
 executable rlpc
     import:           warnings
@@ -98,8 +101,7 @@ executable rlpc
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
                  , optparse-applicative >= 0.18.1 && < 0.19
-                 , microlens >= 0.4.13 && < 0.5
-                 , microlens-mtl >= 0.2.0 && < 0.3
+                 , microlens-platform
                  , mtl >= 2.3.1 && < 2.4
                  , unordered-containers >= 0.2.20 && < 0.3
                  , text >= 2.0.2 && < 2.1

src/Compiler/RLPC.hs

@@ -10,7 +10,6 @@ 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
     (
@@ -18,6 +17,7 @@ module Compiler.RLPC
       RLPCT(RLPCT),
     -- ** Special cases
       RLPC, RLPCIO
+    , liftIO
     -- ** Running
     , runRLPCT
     , evalRLPCT, evalRLPCIO, evalRLPC
@@ -61,6 +61,7 @@ import Data.Coerce
 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
@@ -84,7 +85,11 @@ type RLPC = RLPCT Identity
 
 type RLPCIO = RLPCT IO
 
+instance MonadTrans RLPCT where
+    lift = RLPCT . lift . lift
+
 instance (MonadIO m) => MonadIO (RLPCT m) where
+    liftIO = lift . liftIO
 
 evalRLPC :: RLPCOptions
          -> RLPC a
@@ -114,7 +119,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcFFlags      :: HashSet CompilerFlag
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
-    , _rlpcLanguage    :: Language
+    , _rlpcLanguage    :: Maybe Language
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -135,7 +140,7 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
-        , _rlpcLanguage = LanguageRlp
+        , _rlpcLanguage = Nothing
         }
 
 -- debug flags are passed with -dFLAG
@@ -175,10 +180,18 @@ evalRLPCIO opt r = do
         Nothing -> die "Failed, no code compiled."
 
 putRlpcErrs :: RLPCOptions -> [MsgEnvelope RlpcError] -> IO ()
-putRlpcErrs opts = filter byTag
-               >>> traverse_ (putStrLn . ('\n':) . prettyRlpcMsg)
+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) =

src/Compiler/RlpcError.hs

@@ -47,7 +47,7 @@ instance IsRlpcError RlpcError where
 
 data Severity = SevWarning
               | SevError
-              | SevDebug Text
+              | SevDebug Text -- ^ Tag
               deriving Show
 
 makeLenses ''MsgEnvelope

src/Control/Monad/Errorful.hs

@@ -50,7 +50,7 @@ instance (MonadIO m) => MonadIO (ErrorfulT e m) where
     liftIO = lift . liftIO
 
 instance (Functor m) => Functor (ErrorfulT e m) where
-    fmap f (ErrorfulT m) = ErrorfulT (m & mapped . _1 . _Just %~ f)
+    fmap f (ErrorfulT m) = ErrorfulT (m <&> _1 . _Just %~ f)
 
 instance (Applicative m) => Applicative (ErrorfulT e m) where
     pure a = ErrorfulT . pure $ (Just a, [])
@@ -63,12 +63,12 @@ instance (Monad m) => Monad (ErrorfulT e m) where
     ErrorfulT m >>= k = ErrorfulT $ do
         (a,es) <- m
         case a of
-            Just x      -> runErrorfulT (k x)
+            Just x      -> runErrorfulT (k x) <&> _2 %~ (es<>)
             Nothing     -> pure (Nothing, es)
 
 mapErrorful :: (Functor m) => (e -> e') -> ErrorfulT e m a -> ErrorfulT e' m a
 mapErrorful f (ErrorfulT m) = ErrorfulT $
-    m & mapped . _2 . mapped %~ f
+    m <&> _2 . mapped %~ f
 
 -- when microlens-pro drops we can write this as
 --    mapErrorful f = coerced . mapped . _2 . mapped %~ f

src/Core/Parse.y

@@ -234,7 +234,7 @@ parseCoreProgR = ddumpast <=< (hoistRlpcT generalise . parseCoreProg)
 
         ddumpast :: Program' -> RLPCT m Program'
         ddumpast p = do
-            addDebugMsg "dump-ast" . show $ p
+            addDebugMsg "dump-parsed-core" . show $ p
             pure p
 
 happyBind :: RLPC a -> (a -> RLPC b) -> RLPC b

src/Core/Syntax.hs

@@ -41,6 +41,7 @@ module Core.Syntax
     , Binding'
     , HasRHS(_rhs)
     , HasLHS(_lhs)
+    , Pretty(pretty)
     )
     where
 ----------------------------------------------------------------------------------
@@ -56,7 +57,7 @@ import Data.HashMap.Strict          qualified as H
 import Data.Hashable
 import Data.Text                    qualified as T
 import Data.Char
-import GHC.Generics
+import GHC.Generics                 (Generic, Generically(..))
 -- Lift instances for the Core quasiquoters
 import Language.Haskell.TH.Syntax   (Lift)
 -- import Lens.Micro.TH                (makeLenses)
@@ -215,3 +216,61 @@ instance HasLHS (Binding b) (Binding b) b b where
         (\ (k := _) -> k)
         (\ (_ := e) k' -> k' := e)
 
+--------------------------------------------------------------------------------
+
+-- TODO: print type sigs with corresponding scdefs
+-- TODO: emit pragmas for datatags
+instance (Pretty b) => Pretty (Program b) where
+    pretty = vsepOf (programScDefs . each . to pretty)
+
+instance (Pretty b) => Pretty (ScDef b) where
+    pretty sc = hsep [name, as, "=", hang empty 1 e]
+        where
+            name = ttext $ sc ^. _lhs . _1
+            as = sc & hsepOf (_lhs . _2 . each . to ttext)
+            e = pretty $ sc ^. _rhs
+
+instance (Pretty b) => Pretty (Expr b) where
+    prettyPrec _ (Var n)      = ttext n
+    prettyPrec _ (Con t a)    = "Pack{" <> (ttext t <+> ttext a) <> "}"
+    prettyPrec _ (Lam bs e)   = hsep ["λ", hsep (prettyPrec 1 <$> bs), "->", pretty e]
+    prettyPrec _ (Let r bs e) = hsep [word, explicitLayout bs]
+                             $$ hsep ["in", pretty e]
+        where word = if r == Rec then "letrec" else "let"
+    prettyPrec p (App f x)    = maybeParens (p>0) $
+        prettyPrec 0 f <+> prettyPrec 1 x
+    prettyPrec _ (Lit l)      = pretty l
+    prettyPrec p (Case e as)  = maybeParens (p>0) $
+        "case" <+> pretty e <+> "of"
+        $$ nest 2 (explicitLayout as)
+
+{-
+
+x = pretty $ desugarRlpProg [rlpProg|
+    main = 3
+    data B = T | F
+|]
+
+-}
+
+instance (Pretty b) => Pretty (Alter b) where
+    pretty (Alter c as e) =
+        hsep [pretty c, hsep (pretty <$> as), "->", pretty e]
+
+instance Pretty AltCon where
+    pretty (AltData n) = ttext n
+    pretty (AltLit l) = pretty l
+    pretty (AltTag t) = ttext t
+    pretty AltDefault = "_"
+
+instance Pretty Lit where
+    pretty (IntL n) = ttext n
+
+instance (Pretty b) => Pretty (Binding b) where
+    pretty (k := v) = hsep [pretty k, "=", pretty v]
+
+explicitLayout :: (Pretty a) => [a] -> Doc
+explicitLayout as = vcat inner <+> "}" where
+    inner = zipWith (<+>) delims (pretty <$> as)
+    delims = "{" : repeat ";"
+

src/Core2Core.hs

@@ -21,16 +21,27 @@ import Control.Arrow            ((>>>))
 import Data.Text                qualified as T
 import Data.HashMap.Strict      (HashMap)
 import Numeric                  (showHex)
+
+import Data.Pretty
+import Compiler.RLPC
 -- import Lens.Micro.Platform
 import Control.Lens
 import Core.Syntax
 import Core.Utils
 ----------------------------------------------------------------------------------
 
+-- | General optimisations
+
 core2core :: Program' -> Program'
 core2core p = undefined
 
--- | G-machine preprocessing.
+gmPrepR :: (Monad m) => Program' -> RLPCT m Program'
+gmPrepR p = do
+    let p' = gmPrep p
+    addDebugMsg "dump-gm-preprocessed" $ render . pretty $ p'
+    pure p'
+
+-- | G-machine-specific preprocessing.
 
 gmPrep :: Program' -> Program'
 gmPrep p = p & appFloater (floatNonStrictCases globals)
@@ -46,7 +57,6 @@ gmPrep p = p & appFloater (floatNonStrictCases globals)
 defineData :: Program' -> Program'
 defineData p = p & programScDefs <>~ defs
     where
-        -- defs = ifoldMap' _ (p ^. programDataTags)
         defs = p ^. programDataTags
              . to (ifoldMap (\k (t,a) -> [ScDef k [] (Con t a)]))
 

src/Data/Pretty.hs

@@ -1,17 +1,51 @@
-{-# LANGUAGE OverloadedStrings #-}
 module Data.Pretty
     ( Pretty(..)
+    , ttext
+    -- * Pretty-printing lens combinators
+    , hsepOf, vsepOf
+    , module Text.PrettyPrint
+    , maybeParens
     )
     where
 ----------------------------------------------------------------------------------
+import Text.PrettyPrint             hiding ((<>))
+import Text.PrettyPrint.HughesPJ    hiding ((<>))
 import Data.String                  (IsString(..))
+import Data.Text.Lens
+import Data.Monoid
+import Data.Text                    qualified as T
+import Control.Lens
 ----------------------------------------------------------------------------------
 
 class Pretty a where
-    -- pretty :: a -> ISeq
-    -- prettyPrec :: a -> Int -> ISeq
+    pretty :: a -> Doc
+    prettyPrec :: Int -> a -> Doc
 
-    -- {-# MINIMAL pretty | prettyPrec #-}
-    -- pretty a = prettyPrec a 0
-    -- prettyPrec a _ = iBracket (pretty a)
+    {-# MINIMAL pretty | prettyPrec #-}
+    pretty = prettyPrec 0
+    prettyPrec a _ = pretty a
+
+instance Pretty String where
+    pretty = Text.PrettyPrint.text
+
+instance Pretty T.Text where
+    pretty = Text.PrettyPrint.text . view unpacked
+
+newtype Showing a = Showing a
+
+instance (Show a) => Pretty (Showing a) where
+    prettyPrec p (Showing a) = fromString $ showsPrec p a ""
+
+deriving via Showing Int instance Pretty Int
+
+--------------------------------------------------------------------------------
+
+ttext :: Pretty t => t -> Doc
+ttext = pretty
+
+hsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+hsepOf l = foldrOf l (<+>) mempty
+
+vsepOf :: Getting (Endo Doc) s Doc -> s -> Doc
+vsepOf l = foldrOf l ($+$) mempty
 

src/Rlp/Parse.y

@@ -228,6 +228,7 @@ Expr1       :: { RlpExpr' RlpcPs }
             : '(' Expr ')'              { $1 .> $2 <. $3 }
             | Lit                       { fmap LitE $1 }
             | Var                       { fmap VarE $1 }
+            | Con                       { fmap VarE $1 }
 
 InfixOp     :: { Located PsName }
             : consym                    { mkPsName $1 }
@@ -251,7 +252,10 @@ parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
         st = programInitState s
 
 parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
-parseRlpProgR s = liftErrorful $ pToErrorful parseRlpProg st
+parseRlpProgR s = do
+    a <- liftErrorful $ pToErrorful parseRlpProg st
+    addDebugMsg @_ @String "dump-parsed" $ show a
+    pure a
   where
         st = programInitState s
 

src/Rlp2Core.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveTraversable #-}
 module Rlp2Core
-    ( desugarRlpProg
+    ( desugarRlpProgR
+    , desugarRlpProg
     , desugarRlpExpr
     )
     where
@@ -15,6 +16,7 @@ import Control.Comonad
 -- import Lens.Micro
 -- import Lens.Micro.Internal
 import Control.Lens
+import Compiler.RLPC
 import Data.List                        (mapAccumL)
 import Data.Text                        (Text)
 import Data.Text                        qualified as T
@@ -26,6 +28,7 @@ import Data.Maybe                       (fromJust, fromMaybe)
 import Data.Functor.Bind
 import Data.Function                    (on)
 import Debug.Trace
+
 import Effectful.State.Static.Local
 import Effectful.Labeled
 import Effectful
@@ -33,6 +36,7 @@ import Text.Show.Deriving
 
 import Core.Syntax                      as Core
 import Compiler.Types
+import Data.Pretty                      (render, pretty)
 import Rlp.Syntax                       as Rlp
 import Rlp.Parse.Types                  (RlpcPs, PsName)
 --------------------------------------------------------------------------------
@@ -55,6 +59,12 @@ deriveShow1 ''Branch
 
 --------------------------------------------------------------------------------
 
+desugarRlpProgR :: forall m. (Monad m) => RlpProgram RlpcPs -> RLPCT m Program'
+desugarRlpProgR p = do
+    let p' = desugarRlpProg p
+    addDebugMsg "dump-desugared" $ render (pretty p')
+    pure p'
+
 desugarRlpProg :: RlpProgram RlpcPs -> Program'
 desugarRlpProg = rlpProgToCore
 
@@ -107,10 +117,19 @@ exprToCore (VarE n) = pure $ Var (dsNameToName n)
 
 exprToCore (AppE a b) = (liftA2 App `on` exprToCore . unXRec) a b
 
+exprToCore (OAppE f a b) = (liftA2 mkApp `on` exprToCore . unXRec) a b
+    where
+        mkApp s t = (Var f `App` s) `App` t
+
 exprToCore (CaseE (unXRec -> e) as) = do
     e' <- exprToCore e
     Case e' <$> caseAltToCore `traverse` as
 
+exprToCore (LitE l) = litToCore l
+
+litToCore :: (NameSupply :> es) => Rlp.Lit RlpcPs -> Eff es Expr'
+litToCore (Rlp.IntL n) = pure . Lit $ Core.IntL n
+
 -- TODO: where-binds
 caseAltToCore :: (NameSupply :> es)
               => (Alt RlpcPs, Where RlpcPs) -> Eff es Alter'
@@ -127,6 +146,7 @@ conToRose (ConP cn as) = Fix . Branch cn <$> patToForrest `traverse` as
             Right <$> liftA2 (,) uniqueName br
           where
             br = unwrapFix <$> conToRose (unXRec p)
+conToRose _ = error "conToRose: not a ConP!"
 
 branchToCore :: Expr' -> Branch Alter' -> Alter'
 branchToCore e (Branch cn as) = Alter (AltData cn) myBinds e'