chrisdone/duet
1
1
Fork 0
mirror of https://github.com/chrisdone/duet.git synced 2025-01-08 23:18:45 +03:00
Code Issues Projects Releases Wiki Activity

Start of React version of IDE

Browse Source
This commit is contained in:
Chris Done 2017-10-21 14:10:14 +01:00
parent 45e57de808
commit bc0e19e031
7 changed files with 20873 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
duet.cabal
View File

@ -100,7 +100,8 @@ executable duet-ide
buildable: False
other-modules:
Shared
Reflex.Dom.Widget.Advanced
React.Flux.Persist
React.Flux.Events
default-language:
Haskell2010
hs-source-dirs:
@ -121,11 +122,11 @@ executable duet-ide
containers,
aeson,
ghcjs-base,
reflex,
reflex-dom,
react-flux,
ghcjs-dom,
these,
bifunctors,
dependent-sum,
data-default,
basic-lens
basic-lens,
deepseq

2
stack-ghcjs.yaml
View File

@ -9,6 +9,8 @@ extra-deps:
- reflex-dom-0.3
- ref-tf-0.4
- basic-lens-0.0.2
- react-flux-1.2.3
- basic-lens-0.0.2
extra-package-dbs: []

7
static/index.html
View File

@ -4,12 +4,17 @@
<title>Duet delta</title>
<meta name="viewport" content="width=device-width, initial-scale=1">
<meta charset="utf-8">
<link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css" integrity="sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u" crossorigin="anonymous">
<script
src="https://code.jquery.com/jquery-3.2.1.min.js"
integrity="sha256-hwg4gsxgFZhOsEEamdOYGBf13FyQuiTwlAQgxVSNgt4="
crossorigin="anonymous"></script>
<script src="react.js"></script>
<style>
.show-dicts {margin-left: 15px;}
</style>
</head>
<body>
<div id="app"></div>
<script language="javascript" src="all.js"></script>
</body>
</html>

20683
static/react.js vendored Normal file
View File

File diff suppressed because it is too large Load Diff

363
web/IDE.hs
View File

@ -1,297 +1,102 @@
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
{-# LANGUAGE BangPatterns, TypeFamilies, DeriveGeneric, DeriveAnyClass, OverloadedStrings, LambdaCase #-}
module Main where
import Control.Exception
import Control.Monad
import Data.Map.Lazy (Map)
import qualified Data.Map.Lazy as M
import Data.Maybe
import Data.Monoid
import Control.Concurrent
import Control.DeepSeq
import Control.Monad.State (execStateT, StateT, get, put, modify)
import Data.Aeson
import Data.Text (Text)
import qualified Data.Text as T
import Duet.Parser
import Duet.Printer
import Duet.Types
import Reflex.Dom
import Reflex.Dom.Widget.Advanced
import GHC.Generics
import GHCJS.Foreign.Callback
import GHCJS.Marshal (FromJSVal(..), ToJSVal(..), toJSVal_aeson)
import GHCJS.Types (JSVal, JSString)
import React.Flux ((@=))
import React.Flux (ReactStore, ViewEventHandler, SomeStoreAction, ReactView)
import qualified React.Flux as Flux
import qualified React.Flux.Events as Flux.Events
import React.Flux.Internal (ReactElementM)
import qualified React.Flux.Lifecycle as Flux.Lifecycle
import qualified React.Flux.Persist as Flux.Persist
--------------------------------------------------------------------------------
-- Types
data State =
State {stateMode :: Mode}
deriving (Generic, NFData, Show, FromJSON, ToJSON)
data Mode =
ExpressionMode
deriving (Generic, NFData, Show, FromJSON, ToJSON)
data Action
= ReplaceState !State
| KeyDown !Int
deriving (Generic, NFData, Show, FromJSON, ToJSON)
--------------------------------------------------------------------------------
-- Main entry point
main :: IO ()
main =
mainWidget
(do (astEl, astEv) <- el' "div" (newEditorEvent expressionEditor Nothing)
astDyn <- holdDyn Nothing (fmap Just astEv)
keysDyn <-
holdDyn
"No keys down."
(fmapMaybe (pure . show) (domEvent Keydown astEl))
el "div" (dynText keysDyn)
keysDyn <-
holdDyn
"No keys pressed."
(fmapMaybe (pure . show) (domEvent Keypress astEl))
el "div" (dynText keysDyn)
printedDyn <-
mapDyn
(maybe "No AST currently." (printExpression defaultPrint))
astDyn
el "div" (dynText printedDyn))
main = do
mstate <- Flux.Persist.getAppStateVal
maybe (return ()) (Flux.alterStore store . ReplaceState) mstate
Flux.Events.onBodyKeydown (Flux.alterStore store . KeyDown)
Flux.reactRender "app" (Flux.defineControllerView "State" store appview) ()
--------------------------------------------------------------------------------
-- Expression editing
-- Store setup
expressionEditor
:: MonadWidget t m
=> Editor t m f (Expression UnkindedType Identifier Location)
expressionEditor =
Editor
{ editorPrinter = printExpression defaultPrint
, editorParser = parseTextWith expParser "expression" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer = renderExpression
}
-- | Dispatch an action on the store.
dispatch :: Action -> SomeStoreAction
dispatch a = Flux.SomeStoreAction store a
renderExpression
:: MonadWidget t m
=> f
-> Expression UnkindedType Identifier Location
-> m (Event t (Maybe (Either SomeException (Expression UnkindedType Identifier Location))))
renderExpression _ e =
case e of
VariableExpression {} -> atomic
LiteralExpression {} -> atomic
ConstructorExpression {} -> atomic
ConstantExpression {} -> atomic
ApplicationExpression l f x -> do
text "("
fDyn <- child f
xDyn <- child x
text ")"
appsDyn <- combineDyn (ApplicationExpression l) fDyn xDyn
bubble appsDyn
IfExpression l cond then' else' -> do
text "if"
condDyn <- child cond
text "then"
thenDyn <- child then'
text "else"
elseDyn <- child else'
makeIfDyn <- combineDyn (IfExpression l) condDyn thenDyn
ifDyn <- combineDyn ($) makeIfDyn elseDyn
bubble ifDyn
InfixExpression l left op right -> do
leftDyn <- child left
opDyn <- newEditorDynamic operatorEditor op
rightDyn <- child right
makeOpDyn <- combineDyn (InfixExpression l) leftDyn opDyn
opDyn <- combineDyn ($) makeOpDyn rightDyn
bubble opDyn
LambdaExpression l (Alternative l' params expr) -> do
text "\\"
paramsDyn <- newEditorDynamic parametersEditor params
text "->"
exprDyn <- child expr
lamDyn <-
combineDyn
(\ps e -> LambdaExpression l (Alternative l' ps e))
paramsDyn
exprDyn
bubble lamDyn
CaseExpression l expr alts ->
do text "case"
exprDyn <- child expr
text "of"
altsDyn <- newEditorDynamic alternativesEditor alts
caseDyn <- combineDyn (CaseExpression l) exprDyn altsDyn
bubble caseDyn
_ -> do
divClass "warning" (text ("Unsupported node type: " <> show e))
pure (updated (constDyn (Just (Right e))))
-- | The app's model.
store :: ReactStore State
store = Flux.mkStore State {stateMode = ExpressionMode}
--------------------------------------------------------------------------------
-- Model
instance Flux.StoreData State where
type StoreAction State = Action
transform action state = do
putStrLn ("Action: " ++ show action)
state' <- execStateT (interpretAction action) state
_ <- forkIO (Flux.Persist.setAppStateVal state')
pure state'
--------------------------------------------------------------------------------
-- Interpret actions
interpretAction :: Action -> StateT State IO ()
interpretAction =
\case
KeyDown k -> interpretKeyPress k
ReplaceState s -> put s
interpretKeyPress :: Int -> StateT State IO ()
interpretKeyPress k = do
s <- get
case stateMode s of
ExpressionMode ->
case codeAsLetter k of
Nothing -> pure ()
Just {} -> pure ()
codeAsLetter :: Int -> Maybe Char
codeAsLetter i =
if (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
then Just c
else Nothing
where
atomic = do
text (printExpression defaultPrint e)
pure (updated (constDyn (Just (Right e))))
child v = newEditorDynamic expressionEditor v
c = toEnum i
--------------------------------------------------------------------------------
-- Operator editing
-- View
operatorEditor
:: MonadWidget t m
=> Editor t m f (String, Expression UnkindedType Identifier Location)
operatorEditor =
Editor
{ editorPrinter = \(string, _op) -> string
, editorParser =
\input ->
parseTextWith operatorParser "operator" (" " <> T.pack input <> " ")
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ (string, op) -> do
text string
pure (updated (constDyn (Just (Right (string, op)))))
}
--------------------------------------------------------------------------------
-- Parameter editor
parameterEditor
:: MonadWidget t m
=> Editor t m f (Pattern UnkindedType Identifier Location)
parameterEditor =
Editor
{ editorPrinter = printPat defaultPrint
, editorParser = parseTextWith funcParam "parameter" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ param -> do
text (printPat defaultPrint param)
pure (updated (constDyn (Just (Right param))))
}
parametersEditor
:: MonadWidget t m
=> Editor t m f [Pattern UnkindedType Identifier Location]
parametersEditor =
Editor
{ editorPrinter = unwords . map (printPat defaultPrint)
, editorParser = parseTextWith funcParams "parameters" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ params -> do
paramDyns <-
mapM
(\param -> do
e <- newEditorEvent parameterEditor (Just param)
text " "
holdDyn [param] (fmapMaybe (pure . pure) e))
params
paramsDyn <- mconcatDyn paramDyns
bubble paramsDyn
}
--------------------------------------------------------------------------------
-- Pattern editor
patternEditor
:: MonadWidget t m
=> Editor t m f (Pattern UnkindedType Identifier Location)
patternEditor =
Editor
{ editorPrinter = printPat defaultPrint
, editorParser = parseTextWith altPat "pattern" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ pat -> do
text (printPat defaultPrint pat)
pure (updated (constDyn (Just (Right pat))))
}
--------------------------------------------------------------------------------
-- Alt editor
alternativeEditor
:: MonadWidget t m
=> Editor t m f (Pattern UnkindedType Identifier Location, Expression UnkindedType Identifier Location)
alternativeEditor =
Editor
{ editorPrinter = printAlt defaultPrint
, editorParser = parseTextWith (altParser Nothing 1) "alternative" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ (pat, expr) -> do
patDyn <- newEditorDynamic patternEditor pat
text " -> "
exprDyn <- newEditorDynamic expressionEditor expr
altDyn <- combineDyn (,) patDyn exprDyn
bubble altDyn
}
alternativesEditor
:: MonadWidget t m
=> Editor t m f [(Pattern UnkindedType Identifier Location, Expression UnkindedType Identifier Location)]
alternativesEditor =
Editor
{ editorPrinter = unlines . map (printAlt defaultPrint)
, editorParser = parseTextWith altsParser "alternatives" . T.pack
, editorHandler = \_key _input _a -> Nothing
, editorRenderer =
\_ alts -> do
altDyns <-
mapM
(\alt ->
el "div" (newEditorEvent alternativeEditor (Just alt)) >>=
holdDyn [alt] . fmapMaybe (pure . pure))
alts
altsDyn <- mconcatDyn altDyns
bubble altsDyn
}
--------------------------------------------------------------------------------
-- Editor combinators
-- | An editor's definition: print, parse, render.
data Editor t m f a = Editor
{ editorPrinter :: a -> String
, editorParser :: String -> Either SomeException a
, editorRenderer :: Maybe f -> a -> m (Event t (Maybe (Either SomeException a)))
, editorHandler :: Int -> String -> a -> Maybe (f, a)
}
-- | Run an editor with a definite value
newEditorDynamic
:: MonadWidget t m
=> Editor t m f a -> a -> m (Dynamic t a)
newEditorDynamic e a = newEditorEvent e (Just a) >>= holdDyn a
-- | Produce an editor from a printer, parser and renderer.
newEditorEvent
:: MonadWidget t m
=> Editor t m f a -> Maybe a -> m (Event t a)
newEditorEvent (Editor printer parser renderer handler) mdef = do
rec inputWidget <-
divClass
"duet-input"
(textArea
def
{ _textAreaConfig_initialValue = maybe "" printer mdef
, _textAreaConfig_setValue =
fmapMaybe
(>>= either (const Nothing) (Just . printer))
currentValuesEv
})
parseResultDyn <-
foldDyn
(const . Just . parser)
(fmap Right mdef)
(_textArea_input inputWidget)
widgetDyn <-
mapDyn
(\case
Nothing -> pure (updated (constDyn Nothing))
Just (Left e) -> do
divClass "bg-danger" (text (show e))
pure (updated (constDyn (Just (Left e))))
Just (Right e) -> renderer Nothing e)
parseResultDyn
streamsEv <- dyn widgetDyn
currentValuesEv <- switchPromptly never streamsEv
pure
(fmapMaybe
(>>= either (const Nothing) Just)
(leftmost [updated parseResultDyn, currentValuesEv]))
-- | Bubble the value of an AST element upwards as a correctly parsed,
-- available value.
bubble
:: MonadWidget t m
=> Dynamic t a -> m (Event t (Maybe (Either SomeException a)))
bubble = pure . fmapMaybe (Just . Just . Right) . updated
-- | The app's view.
appview :: State -> () -> ReactElementM ViewEventHandler ()
appview _ _ = pure ()

51
web/React/Flux/Events.hs Normal file
View File

@ -0,0 +1,51 @@
-- |
module React.Flux.Events where
import Control.Concurrent
import Control.DeepSeq
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics
import GHCJS.Foreign.Callback
import GHCJS.Marshal (FromJSVal(..), ToJSVal(..), toJSVal_aeson)
import GHCJS.Types (JSVal, JSString)
import React.Flux ((@=))
import React.Flux (ReactStore, ViewEventHandler, SomeStoreAction, ReactView)
import qualified React.Flux as Flux
import React.Flux.Internal (ReactElementM)
import qualified React.Flux.Lifecycle as Flux.Lifecycle
import qualified React.Flux.Persist as Flux.Persist
--------------------------------------------------------------------------------
-- Event handling additions
foreign import javascript unsafe
"$($1).draggable({ stop: function(_,o){ $3(o.offset.left,o.offset.top) }, helper: 'clone', revert: $2, revertDuration: 0 })"
js_draggable :: JSVal -> Bool -> Callback (JSVal -> JSVal -> IO ()) -> IO ()
onDrag :: JSVal -> Bool -> (Double -> Double -> IO ()) -> IO ()
onDrag el revert cont = do
callback <-
asyncCallback2
(\x' y' -> do
Just x <- fromJSVal x'
Just y <- fromJSVal y'
cont x y)
js_draggable el revert callback
foreign import javascript unsafe
"jQuery(document.body).keydown(function(e){if(e.target==document.body)$1(e.which);});"
js_Body_Keydown :: Callback (JSVal -> IO ()) -> IO ()
-- | Do something when there's a keydown in the body (not in an input element or whatnot).
onBodyKeydown :: (Int -> IO ()) -> IO ()
onBodyKeydown cont = do
callback <-
asyncCallback1
(\jsval -> do
i <- fromJSVal jsval
case i of
Just x -> cont x
Nothing -> return ())
js_Body_Keydown callback

42
web/React/Flux/Persist.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
module React.Flux.Persist where
import Control.Concurrent
import Control.Exception
import Data.Aeson
import Data.Aeson.Types
import GHCJS.Foreign.Callback
import GHCJS.Marshal (FromJSVal(..), ToJSVal(..), toJSVal_aeson)
import GHCJS.Types (JSVal, JSString)
foreign import javascript unsafe
"(function(){ if (sessionStorage.getItem($1)) return JSON.parse(sessionStorage.getItem($1)); })()"
js_sessionStorage_getItemVal :: JSString -> IO JSVal
foreign import javascript unsafe
"sessionStorage.setItem($1,JSON.stringify($2));"
js_sessionStorage_setItemVal :: JSString -> JSVal -> IO ()
-- | Get the app state.
getAppStateVal :: FromJSON a => IO (Maybe a)
getAppStateVal = do
jv <- js_sessionStorage_getItemVal "app-state"
value <- fromJSVal jv
evaluate (value >>= parseMaybe parseJSON)
where
eitherToMaybe = either (const Nothing) Just
-- | Set the app state.
setAppStateVal
:: ToJSON a
=> a -> IO ()
setAppStateVal app = do
_ <-
forkIO
(do !val <- toJSVal_aeson app
js_sessionStorage_setItemVal "app-state" val)
return ()