begin hm visualiser

2024-03-14 16:26:51 -06:00
parent c85ba57247
commit 932fed8e5c
11 changed files with 158 additions and 121 deletions
--- 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
        }

--- 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)
+
--- 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 ]
+
--- 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'

--- 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'
-