From c72d93216aad591503a6ddc750755248810478f4 Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Thu, 14 Mar 2024 16:26:51 -0600 Subject: [PATCH] begin hm visualiser --- app/CoreDriver.hs | 5 +- app/Main.hs | 12 +++- app/RlpDriver.hs | 2 +- app/Server.hs | 68 ++++++++++++++++++++ rlp.cabal | 4 ++ src/Compiler/RLPC.hs | 10 ++- src/Core/Syntax.hs | 24 ++++++- src/Rlp/AltSyntax.hs | 36 +++++++++-- src/Rlp/HindleyMilner.hs | 7 ++- src/Rlp/HindleyMilner/Visual.hs | 107 +------------------------------- visualisers/hmvis | 1 + 11 files changed, 155 insertions(+), 121 deletions(-) create mode 100644 app/Server.hs create mode 160000 visualisers/hmvis diff --git a/app/CoreDriver.hs b/app/CoreDriver.hs index f33954a..46fc790 100644 --- a/app/CoreDriver.hs +++ b/app/CoreDriver.hs @@ -15,10 +15,11 @@ import GM driver :: RLPCIO () driver = forFiles_ $ \f -> - withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR) + withSource f (lexCoreR >=> parseCoreProgR >=> undefined >=> evalProgR) driverSource :: T.Text -> RLPCIO () -driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes +driverSource = lexCoreR >=> parseCoreProgR + >=> undefined >=> 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..39ffcf8 --- /dev/null +++ b/app/Server.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase, BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +module Server + ( server + ) + where +-------------------------------------------------------------------------------- +import GHC.Generics (Generic, Generically(..)) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +import Data.Pretty +import Data.Aeson +import Control.Applicative +import Control.Monad +import Control.Concurrent +import Network.WebSockets qualified as WS + +import Data.Functor.Foldable + +import Misc.CofreeF +import Rlp.AltSyntax +import Rlp.HindleyMilner +import Rlp.AltParse +-------------------------------------------------------------------------------- + +server :: IO () +server = do + WS.runServer "127.0.0.1" 9002 application + +application :: WS.ServerApp +application pending = + WS.acceptRequest pending >>= talk + +newtype Command = Annotate Text + +instance FromJSON Command where + parseJSON = withObject "command object" $ \v -> do + cmd :: Text <- v .: "command" + case cmd of + "annotate" -> Annotate <$> v .: "data" + _ -> empty + +data Response = Annotated Value + | PartiallyAnnotated Value + deriving (Generic) + deriving (ToJSON) + via Generically Response + +talk :: WS.Connection -> IO () +talk conn = 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 :: Command -> IO () +doCommand (Annotate s) = undefined + +parse = undefined + +serialisedAnnotated :: Cofree (RlpExprF PsName) (Type PsName) + -> Value +serialisedAnnotated = cata \case + t :<$ e -> object [ "e" .= e, "type" .= rout @Text t ] + diff --git a/rlp.cabal b/rlp.cabal index ae30ae2..6fee992 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -92,6 +92,9 @@ library , clay , jmacro , js-jquery + , aeson + , lens-aeson + -- , servant hs-source-dirs: src default-language: GHC2021 @@ -112,6 +115,7 @@ executable rlpc main-is: Main.hs other-modules: RlpDriver , CoreDriver + , Server build-depends: base >=4.17.0.0 && <4.20.0.0 , rlp diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index bffe6e9..27265b0 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -26,8 +26,9 @@ module Compiler.RLPC , DebugFlag(..), CompilerFlag(..) -- ** Lenses , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage + , rlpcServer -- * Misc. MTL-style functions - , liftErrorful, liftMaybe, hoistRlpcT + , liftErrorful, liftEither, liftMaybe, hoistRlpcT -- * Misc. Rlpc Monad -related types , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..) , MsgEnvelope(..), Severity(..) @@ -111,6 +112,11 @@ liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e) liftMaybe :: (Monad m) => Maybe a -> RLPCT m a liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, []) +liftEither :: (Monad m, IsRlpcError e) + => Either [e] a -> RLPCT m a +liftEither = RLPCT . lift . ErrorfulT . pure + . either (const (Nothing,[])) ((,[]) . Just) + hoistRlpcT :: (forall a. m a -> n a) -> RLPCT m a -> RLPCT n a hoistRlpcT f rma = RLPCT $ ReaderT $ \opt -> @@ -123,6 +129,7 @@ data RLPCOptions = RLPCOptions , _rlpcEvaluator :: Evaluator , _rlpcHeapTrigger :: Int , _rlpcLanguage :: Maybe Language + , _rlpcServer :: Bool , _rlpcInputFiles :: [FilePath] } deriving Show @@ -143,6 +150,7 @@ instance Default RLPCOptions where , _rlpcEvaluator = EvaluatorGM , _rlpcHeapTrigger = 200 , _rlpcInputFiles = [] + , _rlpcServer = False , _rlpcLanguage = Nothing } diff --git a/src/Core/Syntax.hs b/src/Core/Syntax.hs index 3bcfada..a72578f 100644 --- a/src/Core/Syntax.hs +++ b/src/Core/Syntax.hs @@ -59,7 +59,9 @@ import Data.Functor.Classes import Data.Text qualified as T import Data.Char import Data.These -import GHC.Generics (Generic, Generic1, Generically(..)) +import Data.Aeson +import GHC.Generics ( Generic, Generic1 + , Generically(..), Generically1(..)) import Text.Show.Deriving import Data.Eq.Deriving import Data.Kind qualified @@ -110,7 +112,7 @@ type Kind = Type -- deriving (Eq, Show, Lift) data Var = MkVar Name Type - deriving (Eq, Show, Lift) + deriving (Eq, Show, Lift, Generic) pattern (:^) :: Name -> Type -> Var pattern n :^ t = MkVar n t @@ -780,3 +782,21 @@ instance Hashable b => Hashable1 (AlterF b) instance Hashable b => Hashable1 (BindingF b) instance Hashable b => Hashable1 (ExprF b) +deriving via (Generically Rec) + instance ToJSON Rec +deriving via (Generically Lit) + instance ToJSON Lit +deriving via (Generically AltCon) + instance ToJSON AltCon +deriving via (Generically Type) + instance ToJSON Type +deriving via (Generically Var) + instance ToJSON Var + +deriving via (Generically1 (BindingF b)) + instance ToJSON b => ToJSON1 (BindingF b) +deriving via (Generically1 (AlterF b)) + instance ToJSON b => ToJSON1 (AlterF b) +deriving via (Generically1 (ExprF b)) + instance ToJSON b => ToJSON1 (ExprF b) + diff --git a/src/Rlp/AltSyntax.hs b/src/Rlp/AltSyntax.hs index 9d8c2be..eec5234 100644 --- a/src/Rlp/AltSyntax.hs +++ b/src/Rlp/AltSyntax.hs @@ -18,23 +18,29 @@ module Rlp.AltSyntax -- * Functor-related tools , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr + + -- * Misc + , serialiseCofree ) where -------------------------------------------------------------------------------- import Data.Functor.Sum import Control.Comonad.Cofree -import Data.Fix +import Data.Fix hiding (cata) +import Data.Functor.Foldable import Data.Function (fix) -import GHC.Generics (Generic, Generic1) +import GHC.Generics ( Generic, Generic1 + , Generically(..), Generically1(..)) import Data.Hashable import Data.Hashable.Lifted import GHC.Exts (IsString) -import Control.Lens +import Control.Lens hiding ((.=)) import Data.Functor.Foldable.TH import Text.Show.Deriving import Data.Eq.Deriving import Data.Text qualified as T +import Data.Aeson import Data.Pretty import Misc.Lift1 @@ -45,7 +51,7 @@ import Core.Syntax qualified as Core type PsName = T.Text newtype Program b a = Program [Decl b a] - deriving Show + deriving (Show, Functor, Foldable, Traversable) programDecls :: Lens' (Program b a) [Decl b a] programDecls = lens (\ (Program ds) -> ds) (const Program) @@ -53,7 +59,7 @@ programDecls = lens (\ (Program ds) -> ds) (const Program) data Decl b a = FunD b [Pat b] a | DataD b [b] [DataCon b] | TySigD b (Type b) - deriving (Show, Functor) + deriving (Show, Functor, Foldable, Traversable) data DataCon b = DataCon b [Type b] deriving (Show, Generic) @@ -101,7 +107,7 @@ type RlpExpr b = Fix (RlpExprF b) data Pat b = VarP b | ConP b | AppP (Pat b) (Pat b) - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Generic1) deriveShow1 ''Alter deriveShow1 ''Binding @@ -221,3 +227,21 @@ instance Core.HasArrowStops (Type b) (Type b) (Type b) (Type b) where arrowStops k (s Core.:-> t) = (Core.:->) <$> k s <*> Core.arrowStops k t arrowStops k t = k t +deriving via (Generically1 Pat) + instance ToJSON1 Pat +deriving via (Generically (Pat b)) + instance ToJSON b => ToJSON (Pat b) +deriving via (Generically1 (Alter b)) + instance ToJSON b => ToJSON1 (Alter b) +deriving via (Generically1 (Binding b)) + instance ToJSON b => ToJSON1 (Binding b) +deriving via (Generically1 (ExprF b)) + instance ToJSON b => ToJSON1 (ExprF b) +deriving via (Generically1 (RlpExprF b)) + instance ToJSON b => ToJSON1 (RlpExprF b) + +serialiseCofree :: (Functor f, ToJSON1 f, ToJSON a) => Cofree f a -> Value +serialiseCofree = cata \case + ann :<$ e -> object [ "ann" .= ann + , "val" .= toJSON1 e ] + diff --git a/src/Rlp/HindleyMilner.hs b/src/Rlp/HindleyMilner.hs index 5cf408e..00403ad 100644 --- a/src/Rlp/HindleyMilner.hs +++ b/src/Rlp/HindleyMilner.hs @@ -163,11 +163,14 @@ fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b fixtend c (Fix f) = c f :< fmap (fixtend c) f infer :: RlpExpr PsName -> HM (Cofree (RlpExprF PsName) (Type PsName)) -infer = undefined +infer = sequenceA . fixtend (infer1 . wrapFix) typeCheckRlpProgR :: (Monad m) => Program PsName (RlpExpr PsName) -> RLPCT m (Program PsName (Cofree (RlpExprF PsName) (Type PsName))) -typeCheckRlpProgR = undefined +typeCheckRlpProgR = liftHM . traverse infer + +liftHM :: (Monad m) => HM a -> RLPCT m a +liftHM = liftEither . runHM' diff --git a/src/Rlp/HindleyMilner/Visual.hs b/src/Rlp/HindleyMilner/Visual.hs index 06d36b4..ba569cb 100644 --- a/src/Rlp/HindleyMilner/Visual.hs +++ b/src/Rlp/HindleyMilner/Visual.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LexicalNegation #-} -{-# LANGUAGE QuasiQuotes #-} module Rlp.HindleyMilner.Visual ( ) @@ -7,6 +6,7 @@ module Rlp.HindleyMilner.Visual -------------------------------------------------------------------------------- import Control.Monad import System.IO +import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Pretty hiding (annotate) @@ -17,15 +17,7 @@ import Control.Exception import Data.Functor.Foldable -import Text.Blaze.Html5 as H -import Text.Blaze.Html5.Attributes as A -import Text.Blaze.Html.Renderer.String -import Clay (Css, (?), px, pct, (**), (|>), (|+) - , (|~)) -import Clay qualified as C -import Clay.Render qualified as C -import Language.Javascript.JMacro -import Language.Javascript.JQuery qualified as JQuery +import Data.Aeson import Core.Syntax as Core import Rlp.AltSyntax as Rlp @@ -36,98 +28,3 @@ import Prelude hiding ((**)) type AnnExpr = Cofree (RlpExprF PsName) -tooltips :: Css -tooltips = do - ".has-type" ? do - C.position C.relative - C.display C.inlineBlock - C.borderBottom (px 1) C.dotted C.black - ".has-type.hovering" ? do - C.background C.green - ".has-type.hovering" |> ".type-text" ? do - C.display C.block - C.opacity 1 - C.position C.fixed - C.overflowWrap C.breakWord - ".has-type" |> ".type-text" ? do - C.display C.none - C.overflowWrap C.breakWord - C.maxWidth (pct 50) - -stylesheet :: Css -stylesheet = tooltips - -numbers :: Int -> Html -numbers n = docTypeHtml do - H.head do - H.title "naturals" - H.style "doge" - body do - pre "a list of nats" - ul $ forM_ [1..n] (li . toHtml) - -withTooltip :: Html -> Html -> Html -withTooltip normal hover = - H.div ! class_ "has-type" - $ normal *> (H.div ! class_ "type-text" $ hover) - --- withTooltip :: Html -> Html -> Html --- withTooltip normal hover = --- H.div ! class_ "has-type" --- -- ! onload "installHoverListener(this)" --- $ normal - -annExpr :: (a -> Doc ann) -> AnnExpr a -> Html -annExpr sf = code . cata \case - t :<$ InL (LitF l) -> withTooltip (rout l) (sf' t) - t :<$ InL (VarF n) -> withTooltip (rout n) (sf' t) - t :<$ InL (AppF f x) -> withTooltip (f *> " " *> x) (sf' t) - t :<$ InL (LamF bs e) -> withTooltip ("λ" *> bs' *> " -> " *> e) (sf' t) - where - bs' = fromString . show . hsep $ outPrec appPrec1 <$> bs - where - sf' = fromString . show . sf - -rootScript :: JStat -rootScript = [jmacro| - $(".has-type").on("mouseover mouseout", \e { - e.stopPropagation(); - $(this).toggleClass("hovering", e.type === "mouseover"); - var o = $(this).children(".type-text")[0]; - var x = e.clientX; - var y = e.clientY; - o.style.top = (y + 20) + 'px'; - o.style.left = (x + 20) + 'px'; - }); -|] - -jsScript :: (IsString s, JsToDoc w, JMacro w) => w -> s -jsScript = fromString . show . renderJs - -rootPage :: Html -> Html -rootPage html = docTypeHtml do - H.head do - H.title "naturals" - H.style (toHtml . C.render $ stylesheet) - H.body do - html - script ! src (fromString $ "https:" ++ JQuery.url) $ "" - script ! src "https://code.jquery.com/ui/1.13.2/jquery-ui.min.js" $ "" - script (fromString . show . renderJs $ rootScript) - -renderTmp :: Html -> IO () -renderTmp = writeFile "/tmp/t.html" . renderHtml - -renderTmp' :: Html -> IO () -renderTmp' = writeFile "/tmp/t.html" . renderHtml . rootPage - -renderExpr :: RlpExpr PsName -> IO () -renderExpr e = case runHM' . annotate $ e of - Left es -> error (show es) - Right e' -> renderTmp' . annExpr (fromString . show) $ e' - -renderExpr' :: RlpExpr PsName -> IO () -renderExpr' e = case runHM' . solve $ e of - Left es -> error (show es) - Right e' -> renderTmp' . annExpr out $ e' - diff --git a/visualisers/hmvis b/visualisers/hmvis new file mode 160000 index 0000000..8371c86 --- /dev/null +++ b/visualisers/hmvis @@ -0,0 +1 @@ +Subproject commit 8371c86933c45ddb40b30aebaf7cd58410a82b60