ugh

app.old/CoreDriver.hs

@@ -0,0 +1,24 @@
+module CoreDriver
+    ( driver
+    )
+    where
+--------------------------------------------------------------------------------
+import Compiler.RLPC
+import Control.Monad
+import Data.Text                    qualified as T
+import Control.Lens.Combinators
+
+import Core.Lex
+import Core.Parse
+import GM
+--------------------------------------------------------------------------------
+
+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.old/Main.hs

@@ -0,0 +1,140 @@
+{-# 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
+import Control.Monad.Reader
+import Data.HashSet             qualified as S
+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 Control.Lens.Combinators hiding (argument)
+
+import CoreDriver               qualified
+import RlpDriver                qualified
+----------------------------------------------------------------------------------
+
+optParser :: ParserInfo RLPCOptions
+optParser = info (helper <*> options)
+    (  fullDesc
+    <> progDesc "Compile rl' programs"
+    <> header "rlpc - The Inglorious rl' Compiler"
+    )
+
+options :: Parser RLPCOptions
+options = RLPCOptions
+    {- --log, -l -}
+    <$> optional # strOption
+        (  long "log"
+        <> short 'l'
+        <> metavar "FILE"
+        <> help "output dumps to FILE. stderr is used if unset"
+        )
+    {- -d -}
+    <*> fmap S.fromList # many # option debugFlagReader
+        (  short 'd'
+        <> help "pass debug flags"
+        <> metavar "DEBUG FLAG"
+        )
+    {- -f -}
+    <*> fmap S.fromList # many # option compilerFlagReader
+        (  short 'f'
+        <> help "pass compilation flags"
+        <> metavar "COMPILATION FLAG"
+        )
+    {- --evaluator, -e -}
+    <*> option evaluatorReader
+        (  long "evaluator"
+        <> short 'e'
+        <> metavar "gm|ti"
+        <> value EvaluatorGM
+        <> help "the intermediate layer used to model evaluation"
+        )
+    <*> option auto
+        (  long "heap-trigger"
+        <> metavar "INT"
+        <> help "the number of nodes allowed on the heap before\
+                \triggering the garbage collector"
+        <> value 50
+        )
+    <*> optional # option languageReader
+        (  long "language"
+        <> short 'x'
+        <> metavar "rlp|core"
+        <> help "the language to be compiled -- see README"
+        )
+    <*> some (argument str $ metavar "FILES...")
+    where
+        infixr 9 #
+        f # x = f x
+
+languageReader :: ReadM Language
+languageReader = maybeReader $ \case
+    "rlp"   -> Just LanguageRlp
+    "core"  -> Just LanguageCore
+    "rl"    -> Just LanguageRlp
+    "cr"    -> Just LanguageCore
+    _       -> Nothing
+
+debugFlagReader :: ReadM DebugFlag
+debugFlagReader = str
+
+compilerFlagReader :: ReadM CompilerFlag
+compilerFlagReader = str
+
+evaluatorReader :: ReadM Evaluator
+evaluatorReader = maybeReader $ \case
+    "gm"  -> Just EvaluatorGM
+    "ti"  -> Just EvaluatorTI
+    _     -> Nothing
+
+mmany :: (Alternative f, Monoid m) => f m -> f m
+mmany v = liftA2 (<>) v (mmany v)
+
+----------------------------------------------------------------------------------
+
+main :: IO ()
+main = do
+    opts <- execParser optParser
+    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 = undefined
+
+inferLanguage :: FilePath -> Maybe Language
+inferLanguage fp
+    | ".rl" `isSuffixOf` fp     = Just LanguageRlp
+    | ".cr" `isSuffixOf` fp     = Just LanguageCore
+    | otherwise                 = Nothing
+

app.old/RlpDriver.hs

@@ -0,0 +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 = forFiles_ $ \f ->
+    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
+

app/CoreDriver.hs

@@ -10,6 +10,7 @@ import Control.Lens.Combinators
 
 import Core.Lex
 import Core.Parse
+-- import Core.SystemF
 import GM
 --------------------------------------------------------------------------------
 
@@ -18,7 +19,8 @@ driver = forFiles_ $ \f ->
     withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
+driverSource = lexCoreR >=> parseCoreProgR
+           >=> evalProgR >=> printRes
     where
         printRes = liftIO . print . view _1
 

app/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
+import Control.Lens             hiding (argument)
 import Compiler.RLPC
 import Compiler.RlpcError
 import Control.Exception
@@ -23,6 +24,7 @@ import Control.Lens.Combinators hiding (argument)
 
 import CoreDriver               qualified
 import RlpDriver                qualified
+import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -74,7 +76,11 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> some (argument str $ metavar "FILES...")
+    <*> switch
+        (  long "server"
+        <> short 's'
+        )
+    <*> many (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -107,7 +113,9 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    void $ evalRLPCIO opts dispatch
+    if opts ^. rlpcServer
+    then Server.server
+    else void $ evalRLPCIO opts dispatch
 
 dispatch :: RLPCIO ()
 dispatch = getLang >>= \case

app/RlpDriver.hs

@@ -15,5 +15,5 @@ import GM
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
+    withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
 

app/Server.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+    ( server
+    )
+    where
+--------------------------------------------------------------------------------
+import GHC.Generics                 (Generic, Generically(..))
+import Data.Text.Encoding           qualified as T
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Text.IO                 qualified as T
+import Data.Pretty                  hiding (annotate, empty)
+import Data.Aeson                   ( ToJSON(..), Value, (.:)
+                                    , FromJSON(..), encode, withObject
+                                    , decodeStrictText)
+import Data.Function
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+import Control.Concurrent
+import Network.WebSockets           qualified as WS
+import Control.Exception
+import GHC.IO
+import Control.Lens                 hiding ((.=))
+
+-- import Control.Comonad
+-- import Data.Functor.Foldable
+
+import Compiler.RLPC
+import Compiler.JustRun
+
+-- import Misc.CofreeF
+-- import Rlp.AltSyntax
+-- import Rlp.HindleyMilner
+-- import Rlp.AltParse
+--------------------------------------------------------------------------------
+
+server :: IO ()
+server = do
+    T.putStrLn "rlpc server started at 127.0.0.1:9002"
+    WS.runServer "127.0.0.1" 9002 application
+
+application :: WS.ServerApp
+application pending = do
+    WS.acceptRequest pending >>= talk
+
+data Command = Annotate Text
+             | PartiallyAnnotate Text
+             | Evaluate Text
+             deriving Show
+
+instance FromJSON Command where
+    parseJSON = withObject "command object" $ \v -> do
+        cmd :: Text <- v .: "command"
+        case cmd of
+            "evaluate"           -> Evaluate <$> v .: "source"
+            "annotate"           -> Annotate <$> v .: "source"
+            "partially-annotate" -> PartiallyAnnotate <$> v .: "source"
+            _                    -> empty
+
+data Response = Annotated Value
+              | PartiallyAnnotated Value
+              | Evaluated Value
+              | Error Value
+              deriving (Generic)
+              deriving (ToJSON)
+                via Generically Response
+
+talk :: WS.Connection -> IO ()
+talk conn = (`catchAny` print) . forever $ do
+    msg <- WS.receiveData @Text conn
+    T.putStrLn $ "received: " <> msg
+    doCommand conn `traverse` decodeStrictText msg
+
+doCommand :: WS.Connection -> Command -> IO ()
+doCommand conn c = do
+    putStr "sending: "
+    let r = encode . respond $ c
+    print r
+    WS.sendTextData conn r
+
+respond :: Command -> Response
+respond (Annotate s)
+    = error "i'm a shitty programmer! try again with the dev branch lmfao"
+
+respond (Evaluate s)
+    = justLexParseGmEval (T.unpack s)
+    & either (Error . toJSON) (Evaluated . toJSON)
+

rlp.cabal

@@ -78,6 +78,9 @@ library
     hs-source-dirs:   src
     default-language: GHC2021
 
+    ghc-options:
+        -fdefer-typed-holes
+
     default-extensions:
         OverloadedStrings
         TypeFamilies
@@ -87,12 +90,14 @@ library
         DerivingVia
         StandaloneDeriving
         DerivingStrategies
+        PartialTypeSignatures
 
 executable rlpc
     import:           warnings
     main-is:          Main.hs
     other-modules:    RlpDriver
                     , CoreDriver
+                    , Server
 
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp
@@ -101,6 +106,8 @@ executable rlpc
                  , unordered-containers >= 0.2.20 && < 0.3
                  , lens >=5.2.3 && <6.0
                  , text >= 2.0.2 && < 2.3
+                 , aeson
+                 , websockets
 
     hs-source-dirs:   app
     default-language: GHC2021

src/Compiler/JustRun.hs

@@ -12,6 +12,7 @@ module Compiler.JustRun
     , justParseCore
     , justTypeCheckCore
     , justHdbg
+    , justLexParseGmEval
     )
     where
 ----------------------------------------------------------------------------------
@@ -47,6 +48,10 @@ justParseCore s = parse (T.pack s)
                 & rlpcToEither
     where parse = lexCoreR >=> parseCoreProgR
 
+justLexParseGmEval :: String -> Either [MsgEnvelope RlpcError] [GmState]
+justLexParseGmEval = parse >>> fmap (compile >>> eval) >>> rlpcToEither
+    where parse = (T.pack >>> lexCoreR) >=> parseCoreProgR
+
 justTypeCheckCore :: String -> Either [MsgEnvelope RlpcError] Program'
 justTypeCheckCore s = typechk (T.pack s)
                     & rlpcToEither

src/Compiler/RLPC.hs

@@ -26,6 +26,7 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , rlpcServer
     -- * Misc. MTL-style functions
     , liftErrorful, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
@@ -120,6 +121,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -141,6 +143,7 @@ instance Default RLPCOptions where
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
         , _rlpcLanguage = Nothing
+        , _rlpcServer = False
         }
 
 -- debug flags are passed with -dFLAG

src/Data/Heap.hs

@@ -39,10 +39,16 @@ data Heap a = Heap [Addr] (Map Addr a)
     deriving (ToJSON1, FromJSON1)
       via Generically1 Heap
 
-deriving via Generically (Heap a)
-    instance ToJSON a => ToJSON (Heap a)
-deriving via Generically (Heap a)
-    instance FromJSON a => FromJSON (Heap a)
+instance ToJSON a => ToJSON (Heap a) where
+    toJSON (Heap as m) = toJSON m
+
+instance FromJSON (Heap a) where
+    parseJSON = _
+
+-- deriving via Generically (Heap a)
+--     instance ToJSON a => ToJSON (Heap a)
+-- deriving via Generically (Heap a)
+--     instance FromJSON a => FromJSON (Heap a)
 
 type Addr = Int
 

src/GM.hs

@@ -18,6 +18,8 @@ module GM
     , finalStateOf
     , resultOf
     , resultOfExpr
+    , compile
+    , eval
     )
     where
 ----------------------------------------------------------------------------------