From 47c2d345512fbf952d557bc81bb0913e0c026e13 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 15 Mar 2024 20:02:20 -0600 Subject: [PATCH] kill me --- app/Server.hs | 56 +++++++++++++++++++++++++++++++-------- src/Compiler/RlpcError.hs | 20 +++++++++++--- src/Compiler/Types.hs | 11 +++++++- src/Rlp/AltParse.y | 10 ++++--- src/Rlp/Lex.x | 3 +-- src/Rlp/Parse/Types.hs | 3 ++- 6 files changed, 82 insertions(+), 21 deletions(-) diff --git a/app/Server.hs b/app/Server.hs index 39ffcf8..ef9bd37 100644 --- a/app/Server.hs +++ b/app/Server.hs @@ -7,18 +7,26 @@ module 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 import Data.Aeson +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 Data.Functor.Foldable +import Compiler.RLPC + import Misc.CofreeF import Rlp.AltSyntax import Rlp.HindleyMilner @@ -27,19 +35,21 @@ 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 = +application pending = do WS.acceptRequest pending >>= talk newtype Command = Annotate Text + deriving Show instance FromJSON Command where parseJSON = withObject "command object" $ \v -> do cmd :: Text <- v .: "command" case cmd of - "annotate" -> Annotate <$> v .: "data" + "annotate" -> Annotate <$> v .: "source" _ -> empty data Response = Annotated Value @@ -49,20 +59,44 @@ data Response = Annotated Value via Generically Response talk :: WS.Connection -> IO () -talk conn = forever $ do +talk conn = (`catchAny` print) . forever $ do msg <- WS.receiveData @Text conn T.putStrLn $ "received: " <> msg - case decodeStrictText msg of - Just c -> doCommand c - Nothing -> WS.sendTextData @Text conn "\"error while parsing json\"" + doCommand conn `traverse` decodeStrictText msg -doCommand :: Command -> IO () -doCommand (Annotate s) = undefined +doCommand :: WS.Connection -> Command -> IO () +doCommand conn c = do + putStr "sending: " + let r = encode . respond $ c + print r + WS.sendTextData conn r -parse = undefined +respond :: Command -> Response +respond (Annotate s) + = s & (parseRlpProgR >=> typeCheckRlpProgR) + & fmap (\p -> p ^.. programDecls . each . _FunD <&> serialiseSc) + & runRLPCJsonDef + & Annotated + where + serialiseSc (n,as,e) = object + [ "name" .= n + , "args" .= as + , "body" .= serialiseAnnotated e ] -serialisedAnnotated :: Cofree (RlpExprF PsName) (Type PsName) +serialiseAnnotated :: Cofree (RlpExprF PsName) (Type PsName) -> Value -serialisedAnnotated = cata \case +serialiseAnnotated = cata \case t :<$ e -> object [ "e" .= e, "type" .= rout @Text t ] +runRLPCJsonWithDef :: (a -> Value) -> RLPC a -> Value +runRLPCJsonWithDef f = runRLPCJsonWith f def + +runRLPCJsonDef :: (ToJSON a) => RLPC a -> Value +runRLPCJsonDef = runRLPCJsonWith toJSON def + +runRLPCJsonWith :: (a -> Value) -> RLPCOptions -> RLPC a -> Value +runRLPCJsonWith f o r = object + [ "errors" .= es + , "result" .= (f <$> ma) ] + where (ma,es) = evalRLPC o r + diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 6d97912..58fd5d4 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -24,8 +24,11 @@ import Control.Monad.Errorful import Data.Text (Text) import Data.Text qualified as T import GHC.Exts (IsString(..)) -import Control.Lens +import GHC.Generics +import Control.Lens hiding ((.=)) import Compiler.Types + +import Data.Aeson ---------------------------------------------------------------------------------- data MsgEnvelope e = MsgEnvelope @@ -35,8 +38,17 @@ data MsgEnvelope e = MsgEnvelope } deriving (Functor, Show) +instance (ToJSON e) => ToJSON (MsgEnvelope e) where + toJSON msg = object + [ "span" .= _msgSpan msg + , "severity" .= _msgSeverity msg + , "diagnostic" .= _msgDiagnostic msg + ] + newtype RlpcError = Text [Text] - deriving Show + deriving (Show, Generic) + deriving (ToJSON) + via Generically [Text] instance IsString RlpcError where fromString = Text . pure . T.pack @@ -50,7 +62,9 @@ instance IsRlpcError RlpcError where data Severity = SevWarning | SevError | SevDebug Text -- ^ Tag - deriving Show + deriving (Show, Generic) + deriving (ToJSON) + via Generically Severity makeLenses ''MsgEnvelope diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index d80dc58..49f0c28 100644 --- a/src/Compiler/Types.hs +++ b/src/Compiler/Types.hs @@ -33,8 +33,10 @@ import Data.Functor.Compose import Data.Functor.Foldable import Data.Semigroup.Foldable import Data.Fix hiding (cata, ana) + import Data.Kind -import Control.Lens hiding ((<<~), (:<)) +import Data.Aeson +import Control.Lens hiding ((<<~), (:<), (.=)) import Data.List.NonEmpty (NonEmpty) import Data.Function (on) @@ -45,6 +47,13 @@ import Misc.CofreeF data Located a = Located SrcSpan a deriving (Show, Lift, Functor) +instance ToJSON SrcSpan where + toJSON (SrcSpan l c a s) = object + [ "line" .= l + , "column" .= c + , "abs" .= a + , "length" .= s] + (<~>) :: a -> b -> SrcSpan (<~>) = undefined diff --git a/src/Rlp/AltParse.y b/src/Rlp/AltParse.y index abc33fe..87f3b0b 100644 --- a/src/Rlp/AltParse.y +++ b/src/Rlp/AltParse.y @@ -195,8 +195,9 @@ list0(p) : {- epsilon -} { [] } | list0(p) p { $1 `snoc` $2 } -- layout0(p : β) :: [β] -layout0(p) : '{' layout_list0(';',p) '}' { $2 } - | VL layout_list0(VS,p) VR { $2 } +layout0(p) : '{' '}' { [] } + | VL VR { [] } + | layout1(p) { $1 } -- layout_list0(sep : α, p : β) :: [β] layout_list0(sep,p) : p { [$1] } @@ -205,6 +206,7 @@ layout_list0(sep,p) : p { [$1] } -- layout1(p : β) :: [β] layout1(p) : '{' layout_list1(';',p) '}' { $2 } + | VL layout_list1(VS,p) VS VR { $2 } | VL layout_list1(VS,p) VR { $2 } -- layout_list1(sep : α, p : β) :: [β] @@ -225,7 +227,9 @@ parseRlpExprR s = liftErrorful $ errorful (ma,es) where (_,es,ma) = runP' parseRlpExpr s -parseError = error "explode" +parseError :: (Located RlpToken, [String]) -> P a +parseError (Located ss t,ts) = addFatalHere (ss ^. srcSpanLen) $ + RlpParErrUnexpectedToken t ts extractName = view $ to extract . singular _TokenVarName diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 7bd4406..d8884aa 100644 --- a/src/Rlp/Lex.x +++ b/src/Rlp/Lex.x @@ -330,6 +330,7 @@ insertRBrace = {- traceM "inserting rbrace" >> -} insertToken TokenRBraceV cmpLayout :: P Ordering cmpLayout = do i <- indentLevel + -- traceM $ "i: " <> show i ctx <- preuse (psLayoutStack . _head) case ctx of Just (Implicit n) -> pure (i `compare` n) @@ -338,8 +339,6 @@ cmpLayout = do doBol :: LexerAction (Located RlpToken) doBol inp l = do off <- cmpLayout - i <- indentLevel - -- traceM $ "i: " <> show i -- important that we pop the lex state lest we find our lexer diverging case off of -- the line is aligned with the previous. it therefore belongs to the diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 05ee780..a138a77 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -17,6 +17,7 @@ module Rlp.Parse.Types -- * Other parser types , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction , Located(..), PsName + , srcSpanLen -- ** Lenses , _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym, _TokenConSym , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn @@ -277,7 +278,7 @@ initAlexInput s = AlexInput { _aiPrevChar = '\0' , _aiSource = s , _aiBytes = [] - , _aiPos = (1,0,0) + , _aiPos = (1,1,0) } --------------------------------------------------------------------------------