begin hm visualiser

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

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'
 

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