begin hm visualiser
This commit is contained in:
crumbtoo
@@ -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
|
||||
|
||||
|
||||
12
app/Main.hs
12
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
|
||||
|
||||
@@ -15,5 +15,5 @@ import GM
|
||||
|
||||
driver :: RLPCIO ()
|
||||
driver = forFiles_ $ \f ->
|
||||
withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
|
||||
withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
|
||||
|
||||
|
||||
68
app/Server.hs
Normal file
68
app/Server.hs
Normal file
@@ -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 ]
|
||||
|
||||
@@ -93,6 +93,9 @@ library
|
||||
, clay
|
||||
, jmacro
|
||||
, js-jquery
|
||||
, aeson
|
||||
, lens-aeson
|
||||
-- , servant
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
@@ -113,6 +116,7 @@ executable rlpc
|
||||
main-is: Main.hs
|
||||
other-modules: RlpDriver
|
||||
, CoreDriver
|
||||
, Server
|
||||
|
||||
build-depends: base >=4.17.0.0 && <4.20.0.0
|
||||
, rlp
|
||||
@@ -121,6 +125,9 @@ executable rlpc
|
||||
, unordered-containers >= 0.2.20 && < 0.3
|
||||
, lens >=5.2.3 && <6.0
|
||||
, text >= 2.0.2 && < 2.2
|
||||
, websockets
|
||||
, aeson
|
||||
, recursion-schemes >= 5.2.2 && < 5.3
|
||||
|
||||
hs-source-dirs: app
|
||||
default-language: GHC2021
|
||||
|
||||
@@ -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
|
||||
}
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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 ]
|
||||
|
||||
|
||||
@@ -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'
|
||||
|
||||
|
||||
@@ -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'
|
||||
|
||||
|
||||
1
visualisers/hmvis
Submodule
1
visualisers/hmvis
Submodule
Submodule visualisers/hmvis added at 8371c86933
Reference in New Issue
Block a user