From 2d0731647f46f5336f61bcfe1505605f4753bf5e Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 1 May 2017 13:33:42 +0100 Subject: [PATCH] WIP --- web/Main.hs | 247 +++++++++++++++++++++++++++++++++++--------------- web/Snap.hs | 26 +++++- web/Snappy.hs | 107 +++++++++++++++------- 3 files changed, 270 insertions(+), 110 deletions(-) diff --git a/web/Main.hs b/web/Main.hs index eecae16..dc1fa9f 100644 --- a/web/Main.hs +++ b/web/Main.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Main where +import Control.Arrow import Control.Monad import Control.Monad.Catch.Pure import Control.Monad.Fix @@ -11,6 +13,7 @@ import Control.Monad.Trans import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Typeable @@ -36,38 +39,41 @@ main = do (pure 500) (pure 250) (pure defaultSource) - let result = + let process src = + case parseText "" (T.pack src) of + Left e -> Left (show e) + Right bindings -> + case runCatch + (do (specialSigs, specialTypes, bindGroups, signatures) <- + runTypeChecker bindings + e0 <- lookupNameByString "main" bindGroups + fix + (\loop e xs -> do + e' <- + expandDeepSeq specialSigs signatures e bindGroups + if e' /= e && length xs < 100 + then loop e' (e : xs) + else pure (reverse (e : xs))) + e0 + []) of + Left e -> Left (displayException e) + Right v -> Right v + processedSource = fmap - (\source -> - case parseText "" (T.pack source) of - Left e -> Left (show e) - Right bindings -> - case runCatch - (do (specialSigs, specialTypes, bindGroups) <- - runTypeChecker bindings - e0 <- lookupNameByString "main" bindGroups - fix - (\loop e xs -> do - e' <- expand specialSigs e bindGroups - if e' /= e && length xs < 100 - then loop e' (e : xs) - else pure (reverse (e : xs))) - e0 - []) of - Left e -> Left (displayException e) - Right v -> Right v) + process (Snappy.eventToDynamic defaultSource (Snappy.textboxChange source)) Snappy.textbox snap (pure 20) - (pure 290) + (pure 300) (pure 500) (pure 250) (fmap (\case Left err -> err - Right steps -> unlines (map (printExpression (const Nothing)) steps)) - result) + Right steps -> + unlines (map (printExpression (const Nothing)) steps)) + processedSource) pure () -------------------------------------------------------------------------------- @@ -76,12 +82,23 @@ main = do data CheckerException = RenamerException (SpecialTypes Name) RenamerException | InferException (SpecialTypes Name) InferException + | StepException StepException deriving (Typeable, Show) instance Exception CheckerException where displayException = \case RenamerException specialTypes e -> displayRenamerException specialTypes e InferException specialTypes e -> displayInferException specialTypes e + StepException s -> displayStepperException () s + +displayStepperException :: a -> StepException -> String +displayStepperException _ = + \case + CouldntFindName n -> "Not in scope: " ++ curlyQuotes (printit n) + CouldntFindNameByString n -> + "The starter variable isn't defined: " ++ + curlyQuotes n ++ + "\nPlease define a variable called " ++ curlyQuotes n displayInferException :: SpecialTypes Name -> InferException -> [Char] displayInferException specialTypes = @@ -112,66 +129,88 @@ displayInferException specialTypes = displayRenamerException :: SpecialTypes Name -> RenamerException -> [Char] displayRenamerException _specialTypes = \case - IdentifierNotInScope scope name -> - "Not in scope " ++ curlyQuotes (printit name) ++ "\n" ++ - "Current scope:\n\n" ++ unlines (map printit (M.keys scope)) + IdentifierNotInVarScope scope name -> + "Not in variable scope " ++ curlyQuotes (printit name) ++ "\n" ++ + "Current scope:\n\n" ++ unlines (map printit (M.elems scope)) + IdentifierNotInConScope scope name -> + "Not in constructors scope " ++ curlyQuotes (printit name) ++ "\n" ++ + "Current scope:\n\n" ++ unlines (map printit (M.elems scope)) runTypeChecker :: (MonadThrow m, MonadCatch m) - => [BindGroup Identifier l] - -> m (SpecialSigs Name, SpecialTypes Name, [BindGroup Name (TypeSignature Name l)]) -runTypeChecker bindings = - evalSupplyT - (do specialTypes <- defaultSpecialTypes - theShow <- supplyTypeName "Show" - (specialSigs, signatures) <- builtInSignatures theShow specialTypes - let signatureSubs = - M.fromList - (map - (\(TypeSignature name@(ValueName _ ident) _) -> - (Identifier ident, name)) - signatures) - (renamedBindings, _) <- - catch - (renameBindGroups signatureSubs bindings) - (\e -> - throwM (RenamerException specialTypes e)) - env <- setupEnv theShow specialTypes mempty - bindGroups <- - lift - (catch - (typeCheckModule env signatures specialTypes renamedBindings) + => [Decl FieldType Identifier l] + -> m (SpecialSigs Name, SpecialTypes Name, [BindGroup Name (TypeSignature Name l)], [TypeSignature Name Name]) +runTypeChecker decls = + let bindings = + mapMaybe + (\case + BindGroupDecl d -> Just d + _ -> Nothing) + decls + types = + mapMaybe + (\case + DataDecl d -> Just d + _ -> Nothing) + decls + in evalSupplyT + (do specialTypes <- defaultSpecialTypes + theShow <- supplyTypeName "Show" + (specialSigs, signatures0) <- builtInSignatures theShow specialTypes + sigs' <- + renameDataTypes specialTypes types >>= + mapM (dataTypeSignatures specialTypes) + let signatures = signatures0 ++ concat sigs' + {-liftIO + (mapM_ (putStrLn . printTypeSignature specialTypes) (concat sigs'))-} + let signatureSubs = + M.fromList + (map + (\(TypeSignature name _) -> + case name of + ValueName _ ident -> (Identifier ident, name) + ConstructorName _ ident -> (Identifier ident, name)) + signatures) + (renamedBindings, _) <- + catch + (renameBindGroups signatureSubs bindings) (\e -> - throwM (InferException specialTypes e))) - return (specialSigs, specialTypes, bindGroups)) - [0 ..] + throwM (RenamerException specialTypes e)) + env <- setupEnv theShow specialTypes mempty + bindGroups <- + lift + (catch + (typeCheckModule env signatures specialTypes renamedBindings) + (throwM . InferException specialTypes)) + return (specialSigs, specialTypes, bindGroups, signatures)) + [0 ..] -------------------------------------------------------------------------------- -- Default environment defaultSource :: String defaultSource = - unlines - [ "compose = \\f g x -> f (g x)" - , "id = \\x -> x" - , "and = \\x y -> if x\n\ - \ then if y\n\ - \ then True\n\ - \ else False\n\ - \ else False" - , "main = id (if and True False" - , " then \"Yay!\"" - , " else id id \"Nay!\")" - ] + + "data List a = Nil | Cons a (List a)\n\ + \id = \\x -> x\n\ + \not = \\p -> if p\n\ + \ then False\n\ + \ else True\n\ + \map = \\f l ->\n\ + \ case l of\n\ + \ Nil -> Nil\n\ + \ Cons a xs -> Cons (f a) (map f xs)\n\ + \main = map not (Cons True (Cons False Nil))" -- | Built-in pre-defined functions. builtInSignatures - :: Monad m + :: MonadThrow m => Name -> SpecialTypes Name -> SupplyT Int m (SpecialSigs Name, [TypeSignature Name Name]) builtInSignatures theShow specialTypes = do the_show <- supplyValueName "show" - the_True <- supplyValueName "True" - the_False <- supplyValueName "False" + sigs <- dataTypeSignatures specialTypes (specialTypesBool specialTypes) + the_True <- getSig "True" sigs + the_False <- getSig "False" sigs return ( SpecialSigs {specialSigsTrue = the_True, specialSigsFalse = the_False} , [ TypeSignature @@ -181,18 +220,65 @@ builtInSignatures theShow specialTypes = do (Qualified [IsIn theShow [(GenericType 0)]] (GenericType 0 --> specialTypesString specialTypes))) - , TypeSignature - the_True - (Forall [] (Qualified [] (specialTypesBool specialTypes))) - , TypeSignature - the_False - (Forall [] (Qualified [] (specialTypesBool specialTypes))) - ]) + ] ++ + sigs) where + getSig ident sigs = + case listToMaybe + (mapMaybe + (\case + (TypeSignature n@(ValueName _ i) _) + | i == ident -> Just n + (TypeSignature n@(ConstructorName _ i) _) + | i == ident -> Just n + _ -> Nothing) + sigs) of + Nothing -> throwM (BuiltinNotDefined ident) + Just sig -> pure sig (-->) :: Type Name -> Type Name -> Type Name a --> b = ApplicationType (ApplicationType (specialTypesFunction specialTypes) a) b +dataTypeSignatures + :: Monad m + => SpecialTypes Name -> DataType Type Name -> m [TypeSignature Name Name] +dataTypeSignatures specialTypes dt@(DataType _ vs cs) = mapM construct cs + where + construct (DataTypeConstructor cname fs) = + pure + (TypeSignature + cname + (let varsGens = map (second GenericType) (zip vs [0 ..]) + in Forall + (map typeVariableKind vs) + (Qualified + [] + (foldr + makeArrow + (foldl + ApplicationType + (dataTypeConstructor dt) + (map snd varsGens)) + (map (varsToGens varsGens) fs))))) + where + varsToGens :: [(TypeVariable Name, Type Name)] -> Type Name -> Type Name + varsToGens varsGens = go + where + go = + \case + v@(VariableType tyvar) -> + case lookup tyvar varsGens of + Just gen -> gen + Nothing -> v + ApplicationType t1 t2 -> ApplicationType (go t1) (go t2) + g@GenericType {} -> g + c@ConstructorType {} -> c + makeArrow :: Type Name -> Type Name -> Type Name + a `makeArrow` b = + ApplicationType + (ApplicationType (specialTypesFunction specialTypes) a) + b + -- | Setup the class environment. setupEnv :: MonadThrow m @@ -211,10 +297,21 @@ setupEnv theShow specialTypes env = addInstance [] (IsIn theShow [specialTypesInteger specialTypes]) lift (update env) +-------------------------------------------------------------------------------- +-- Built-in types + -- | Special types that Haskell uses for pattern matching and literals. defaultSpecialTypes :: Monad m => SupplyT Int m (SpecialTypes Name) defaultSpecialTypes = do - theBool <- supplyTypeName "Bool" + boolDataType <- + do name <- supplyTypeName "Bool" + true <- supplyConstructorName "True" + false <- supplyConstructorName "False" + pure + (DataType + name + [] + [DataTypeConstructor true [], DataTypeConstructor false []]) theArrow <- supplyTypeName "(->)" theChar <- supplyTypeName "Char" theString <- supplyTypeName "String" @@ -223,7 +320,7 @@ defaultSpecialTypes = do theFractional <- supplyTypeName "Fractional" return (SpecialTypes - { specialTypesBool = ConstructorType (TypeConstructor theBool StarKind) + { specialTypesBool = boolDataType , specialTypesChar = ConstructorType (TypeConstructor theChar StarKind) , specialTypesString = ConstructorType (TypeConstructor theString StarKind) , specialTypesFunction = diff --git a/web/Snap.hs b/web/Snap.hs index f00a584..9a2ed8f 100644 --- a/web/Snap.hs +++ b/web/Snap.hs @@ -416,6 +416,15 @@ transform a (Matrix m) = do newtype Textbox = Textbox JSVal +class Removable a where + remove :: a -> IO () + +instance Removable Textbox where + remove (Textbox j) = js_remove j + +instance Removable Text where + remove (Text j) = js_remove j + -- | Create a text box for the user to write into. textbox :: Snap -> Double -> Double -> Double -> Double -> String -> IO Textbox textbox (Snap _ e) x y w h t = do @@ -460,13 +469,13 @@ change (Textbox j) cont = do js_change j callback setAttrInt :: Textbox -> String -> Double -> IO () -setAttrInt (Textbox j) key val = do +setAttrInt (Textbox j) key val' = do k' <- toJSVal key - js_setAttrInt j k' val + js_setAttrInt j k' val' setAttrStr :: Textbox -> String -> IO () -setAttrStr (Textbox j) val = do - val' <- toJSVal val +setAttrStr (Textbox j) val0 = do + val' <- toJSVal val0 js_setAttrStr j val' #ifdef __GHCJS__ @@ -478,6 +487,15 @@ js_textbox :: JSVal -> Double -> Double -> Double -> Double -> JSVal -> IO JSVal js_textbox = undefined #endif +#ifdef __GHCJS__ +foreign import javascript unsafe + "$1.remove()" + js_remove :: JSVal -> IO () +#else +js_remove :: JSVal -> IO () +js_remove = undefined +#endif + -------------------------------------------------------------------------------- -- Generalized constrained heterogeneity diff --git a/web/Snappy.hs b/web/Snappy.hs index 1ec7484..ff1b099 100644 --- a/web/Snappy.hs +++ b/web/Snappy.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} @@ -11,9 +11,11 @@ module Snappy where import Control.Concurrent import Control.Monad import Data.IORef -import Data.IORef +import Data.List import Data.Maybe +import Data.String import qualified Data.Text as T +import Data.Tuple import qualified Snap import System.IO.Unsafe @@ -22,7 +24,7 @@ import System.IO.Unsafe data Event a = forall origin s. Event { eventSubscribers :: IORef [origin -> IO ()] - , eventFromOrigin :: s -> origin -> (Maybe a,s) + , eventFromOrigin :: s -> origin -> ([a],s) , eventState :: s } @@ -43,7 +45,7 @@ zipEvents f e1 e2 = (do subscribersRef <- newIORef mempty tvar1 <- newEmptyMVar tvar2 <- newEmptyMVar - let !ev = Event subscribersRef (\s (a, b) -> (Just (f a b), s)) () + let !ev = Event subscribersRef (\s (a, b) -> (pure (f a b), s)) () let listen e us them pair = bindEvent e @@ -65,18 +67,33 @@ scanEvent f nil (Event subscribers fromOrigin oldState) = subscribers (\s origin -> let (a, _) = fromOrigin oldState origin - s' = fmap (f s) a - in (s', fromMaybe s s')) + in swap + (mapAccumL + (\s0 a0 -> + let r = f s0 a0 + in (r, r)) + s + a)) nil {-# INLINE scanEvent #-} +explodeEvent :: Event [a] -> Event a +explodeEvent (Event subscribers fromOrigin oldState) = + Event + subscribers + (\s origin -> + let (a, s') = fromOrigin s origin + in (concat a, s')) + oldState +{-# INLINE explodeEvent #-} + mapMaybeEvent :: (a -> Maybe b) -> Event a -> Event b mapMaybeEvent f (Event subscribers fromOrigin oldState) = Event subscribers (\s origin -> let (a, s') = fromOrigin s origin - in (a >>= f, s')) + in (mapMaybe f a, s')) oldState {-# INLINE mapMaybeEvent #-} @@ -87,6 +104,7 @@ filterEvent p = if p a then Just a else Nothing) +{-# INLINE filterEvent #-} bindEvent :: Event a -> (a -> IO ()) -> IO () bindEvent Event {..} m = do @@ -96,9 +114,7 @@ bindEvent Event {..} m = do (++ [ \v -> do s <- readIORef stateRef let (v', s') = eventFromOrigin s v - case v' of - Nothing -> return () - Just v'' -> m v'' + mapM_ m v' writeIORef stateRef s' ]) @@ -110,6 +126,9 @@ data Dynamic a = Dynamic , dynEvent :: Maybe (Event a) } +instance IsString str => IsString (Dynamic str) where + fromString = pure . fromString + instance Functor Dynamic where fmap f (Dynamic def event) = Dynamic (f def) (fmap (fmap f) event) @@ -152,7 +171,11 @@ scanDynamic f nil e = ,dynEvent = Just (scanEvent f nil e)} bindDynamic :: Dynamic a -> (a -> IO ()) -> IO () -bindDynamic (Dynamic _ event) m = +bindDynamic (Dynamic val event) m = do + void + (forkIO + (do yield + m val)) maybe (return ()) (\e -> @@ -168,6 +191,26 @@ dynamicDef (Dynamic def _) = def eventToDynamic :: a -> Event a -> Dynamic a eventToDynamic d e = Dynamic {dynDefault = d, dynEvent = Just e} +-------------------------------------------------------------------------------- +-- Removable elements + +class Removable (elem :: * -> *) where + remove :: elem a -> IO () + +removable + :: forall void elem. + Removable elem + => (forall t. IO (elem t, Event void)) -> IO () +removable create = do + (v, end) <- create + bindEvent end (\_ -> remove v) + +-------------------------------------------------------------------------------- +-- List of elements + +list :: Event (IO a) -> IO () +list d = bindEvent d (\m -> void m) + -------------------------------------------------------------------------------- -- Drag event @@ -208,7 +251,7 @@ dragEvent d = do pure (Event { eventSubscribers = subscribersRef - , eventFromOrigin = \s origin -> (Just origin, s) + , eventFromOrigin = \s origin -> (pure origin, s) , eventState = st }) @@ -217,26 +260,23 @@ changeEvent d = do subscribersRef <- newIORef mempty Snap.change d - (\text -> do + (\text' -> do subscribers <- readIORef subscribersRef - mapM_ (\subscriber -> subscriber text) subscribers) - threadRef <- newIORef Nothing + mapM_ (\subscriber -> subscriber text') subscribers) + goahead <- newMVar () Snap.keyup d - (\k text -> do - mthreadId <- readIORef threadRef - maybe (return ()) killThread mthreadId - threadId <- - forkIO - (do threadDelay (1000 * 50) - subscribers <- readIORef subscribersRef - mapM_ (\subscriber -> subscriber (T.unpack text)) subscribers) - atomicWriteIORef threadRef (Just threadId)) + (\_k text' -> do + () <- takeMVar goahead + subscribers <- readIORef subscribersRef + mapM_ (\subscriber -> subscriber (T.unpack text')) subscribers + void (forkIO (do threadDelay (1000 * 50) + putMVar goahead ()))) st <- newIORef () pure (Event { eventSubscribers = subscribersRef - , eventFromOrigin = \s origin -> (Just origin, s) + , eventFromOrigin = \s origin -> (pure origin, s) , eventState = st }) @@ -279,7 +319,7 @@ clickEvent d = do pure (Event { eventSubscribers = subscribersRef - , eventFromOrigin = \s origin -> (Just origin, s) + , eventFromOrigin = \s origin -> (pure origin, s) , eventState = st }) @@ -350,12 +390,15 @@ rect snap xdynamic ydynamic wdynamic hdynamic fdynamic = do -------------------------------------------------------------------------------- -- Text object -data Text = Text +data Text t = Text { textObject :: Snap.Text , textClicked :: Event ClickEvent } -text :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic String -> IO Text +instance Removable Text where + remove (Text s _) = Snap.remove s + +text :: Snap.Snap -> Dynamic Double -> Dynamic Double -> Dynamic String -> IO (Text t) text snap xdynamic ydynamic tdynamic = do let x = dynamicDef xdynamic y = dynamicDef ydynamic @@ -384,11 +427,14 @@ text snap xdynamic ydynamic tdynamic = do -------------------------------------------------------------------------------- -- Textbox object -data Textbox = Textbox +data Textbox t = Textbox { textboxObject :: Snap.Textbox , textboxChange :: Event String } +instance Removable Textbox where + remove (Textbox s _) = Snap.remove s + textbox :: Snap.Snap -> Dynamic Double @@ -396,14 +442,13 @@ textbox -> Dynamic Double -> Dynamic Double -> Dynamic String - -> IO Textbox + -> IO (Textbox t) textbox snap xdynamic ydynamic wdynamic hdynamic tdynamic = do let x = dynamicDef xdynamic y = dynamicDef ydynamic w = dynamicDef wdynamic h = dynamicDef hdynamic c <- Snap.textbox snap x y w h (dynamicDef tdynamic) - t <- Snap.newMatrix bindDynamic xdynamic (\x' -> Snap.setAttrInt c "left" x')