From 3c234e6002a51cef0e27fed3659aba7ff71dda11 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Tue, 23 Apr 2024 12:38:03 -0600 Subject: [PATCH] ugh --- app.old/CoreDriver.hs | 24 +++++++ app.old/Main.hs | 140 ++++++++++++++++++++++++++++++++++++++++ app.old/RlpDriver.hs | 19 ++++++ app/CoreDriver.hs | 4 +- app/Main.hs | 12 +++- app/RlpDriver.hs | 2 +- app/Server.hs | 91 ++++++++++++++++++++++++++ rlp.cabal | 7 ++ src/Compiler/JustRun.hs | 5 ++ src/Compiler/RLPC.hs | 3 + src/Data/Heap.hs | 14 ++-- src/GM.hs | 2 + 12 files changed, 315 insertions(+), 8 deletions(-) create mode 100644 app.old/CoreDriver.hs create mode 100644 app.old/Main.hs create mode 100644 app.old/RlpDriver.hs create mode 100644 app/Server.hs diff --git a/app.old/CoreDriver.hs b/app.old/CoreDriver.hs new file mode 100644 index 0000000..f33954a --- /dev/null +++ b/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 + diff --git a/app.old/Main.hs b/app.old/Main.hs new file mode 100644 index 0000000..adc9158 --- /dev/null +++ b/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 + diff --git a/app.old/RlpDriver.hs b/app.old/RlpDriver.hs new file mode 100644 index 0000000..89ad8d7 --- /dev/null +++ b/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) + diff --git a/app/CoreDriver.hs b/app/CoreDriver.hs index f33954a..7c536e9 100644 --- a/app/CoreDriver.hs +++ b/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 diff --git a/app/Main.hs b/app/Main.hs index adc9158..9dd92b0 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/RlpDriver.hs b/app/RlpDriver.hs index 89ad8d7..039a0b9 100644 --- a/app/RlpDriver.hs +++ b/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) diff --git a/app/Server.hs b/app/Server.hs new file mode 100644 index 0000000..38b5e6e --- /dev/null +++ b/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) + diff --git a/rlp.cabal b/rlp.cabal index 390e859..9b62103 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Compiler/JustRun.hs b/src/Compiler/JustRun.hs index 055062a..e7555f7 100644 --- a/src/Compiler/JustRun.hs +++ b/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 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index fb599fc..72a0cbd 100644 --- a/src/Compiler/RLPC.hs +++ b/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 diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 2da2be5..86ffa73 100644 --- a/src/Data/Heap.hs +++ b/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 diff --git a/src/GM.hs b/src/GM.hs index 81a85ca..8287b4d 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -18,6 +18,8 @@ module GM , finalStateOf , resultOf , resultOfExpr + , compile + , eval ) where ----------------------------------------------------------------------------------