kill me

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
+    doCommand conn `traverse` decodeStrictText msg
-        Just c -> doCommand c
-        Nothing -> WS.sendTextData @Text conn "\"error while parsing json\""
 
-doCommand :: Command -> IO ()
+doCommand :: WS.Connection -> Command -> IO ()
-doCommand (Annotate s) = undefined
+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
+

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
 

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
 

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 }
+layout0(p)  : '{' '}'                   { [] }
-            | VL  layout_list0(VS,p)  VR    { $2 }
+            | 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
 

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

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