Implement a browser-runnable version of the CaPriCon interpreter (using Haste)

.gitignore

@@ -4,3 +4,8 @@ curly/doc/bundle
 woosh
 grow
 Curly_Test.hs
+*.hi
+*.o
+*.js
+*.jsmod
+*/dist
\ No newline at end of file

capricon/capricon.cabal

@@ -2,7 +2,7 @@
 -- see http://haskell.org/cabal/users-guide/
 
 name:                capricon
-version:             0.6.4
+version:             0.7
 -- synopsis:            
 -- description:         
 license:             GPL-3
@@ -18,19 +18,24 @@ data-dir: data
 data-files: prelude
                              
 library
-  exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon
+  exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon CaPriCon.Run
   default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-  build-depends: base >=4.9 && <4.10,definitive-base >=2.6 && <2.7, definitive-parser
-  ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
+  build-depends: base,definitive-base, definitive-parser
+  if !impl(haste)
+    ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
   hs-source-dirs: src
   default-language: Haskell2010
-                     
+
 executable capricon
+  if impl(haste)
+    buildable: False
+  else
+    build-depends: hreadline, directory, filepath
   main-is:             CaPriCon.hs
   default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
   -- other-modules:       
   -- other-extensions:    
-  build-depends: base >=4.9 && <4.10,definitive-base >=2.6 && <2.7, definitive-parser, capricon, hreadline, directory, filepath
+  build-depends: base,definitive-base, definitive-parser, capricon
   ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
   hs-source-dirs:      exe
   default-language:    Haskell2010

capricon/exe/CaPriCon.hs

@@ -2,360 +2,22 @@
 module Main where
 
 import Definitive
-import Language.Parser
 import Algebra.Monad.Concatenative
-import System.IO (openFile,hIsTerminalDevice,IOMode(..),hClose)
-import System.Environment (getArgs,lookupEnv)
+import System.IO (hIsTerminalDevice)
+import System.Environment (getArgs)
 import Console.Readline (readline,addHistory,setCompletionEntryFunction)
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Data.IORef
 import System.Directory (getXdgDirectory, XdgDirectory(..))
 import System.FilePath ((</>))
-import Data.CaPriCon
+import CaPriCon.Run
 
-takeLast n l = drop (length l-n) l
-
-showStackVal dir ctx _x = case _x of
-  StackExtra (Opaque _x) -> case _x of
-    COCExpr d e -> -- "<"+show d+">:"+
-      showNode' dir (takeLast d ctx) e
-    COCNull -> "(null)"
-    COCDir d -> show d
-  StackSymbol s -> show s
-  StackInt n -> show n
-  _ -> show _x
-data COCBuiltin = COCB_Print | COCB_Open | COCB_ExecModule | COCB_GetEnv
-                | COCB_ToInt | COCB_Concat | COCB_Uni | COCB_Hyp
-                | COCB_Quit | COCB_Var
-                | COCB_Ap | COCB_Bind Bool BindType
-                | COCB_TypeOf | COCB_Mu
-                | COCB_HypBefore | COCB_Subst | COCB_Rename
-                | COCB_ContextVars
-                | COCB_GetShowDir | COCB_SetShowDir | COCB_InsertNodeDir
-                | COCB_Format
-                deriving Show
-
-data COCState = COCState {
-  _endState :: Bool,
-  _context :: [(String,Node)],
-  _showDir :: NodeDir ([String],StringPattern),
-  _outputHandle :: Handle
-  }
-endState :: Lens' COCState Bool
-endState = lens _endState (\x y -> x { _endState = y })
-context :: Lens' COCState [(String,Node)]
-context = lens _context (\x y -> x { _context = y })
-showDir :: Lens' COCState (NodeDir ([String],StringPattern))
-showDir = lens _showDir (\x y -> x { _showDir = y })
-outputHandle :: Lens' COCState Handle
-outputHandle = lens _outputHandle (\x y -> x { _outputHandle = y })
-
-htmlQuote = foldMap qChar
-  where qChar '<' = "&lt;"
-        qChar '>' = "&gt;"
-        qChar '&' = "&amp;"
-        qChar c = [c]
-stringWords = fromBlank
-  where fromBlank (c:t) | c `elem` " \n\t\r" = fromBlank t
-                        | c == '"' = fromQuote id t
-                        | otherwise = fromWChar (c:) t
-        fromBlank "" = []
-        fromQuote k ('"':t) = ('"':k "\""):fromBlank t
-        fromQuote k ('\\':c:t) = fromQuote (k.(qChar c:)) t
-          where qChar 'n' = '\n' ; qChar 't' = '\t' ; qChar x = x
-        fromQuote k (c:t) = fromQuote (k.(c:)) t
-        fromQuote k "" = ['"':k "\""]
-        fromWChar k (c:t) | c `elem` " \n\t\r" = k "":fromBlank t
-                          | otherwise = fromWChar (k.(c:)) t
-        fromWChar k "" = [k ""]
-
-runCOCBuiltin COCB_Quit = runExtraState (endState =- True)
-runCOCBuiltin COCB_Print = do
-  s <- runStackState get
-  o <- runExtraState (getl outputHandle)
-  lift $ for_ (take 1 s) $ \case
-    StackSymbol s' -> writeHString o s'
-    _ -> return ()
-runCOCBuiltin COCB_GetEnv = do
-  st <- runStackState get
-  case st of
-    StackSymbol s:t -> do
-      v <- lift $ lookupEnv s
-      runStackState (put (StackSymbol (maybe "" id v):t))
-    _ -> return ()
-
-runCOCBuiltin COCB_Format = do
-  ex <- runExtraState get
-  let format ('%':'s':s) (StackSymbol h:t) = first (h+) (format s t)
-      format ('%':'v':s) (x:t) = first (showStackVal (ex^.showDir) (ex^.context) x+) (format s t)
-      format (c:s) t = first (c:) (format s t)
-      format "" t = ("",t)
-  runStackState $ modify $ \case
-    StackSymbol s:t -> uncurry ((:) . StackSymbol) (format s t)
-    st -> st
-
-runCOCBuiltin COCB_Open = do
-  s <- runStackState get
-  case s of
-    StackSymbol f:t -> do
-      xs <- lift (try (return []) (try (readString f) (readString (f+".md")) >>= maybe undefined return . matches Just literate))
-      runStackState (put (StackProg xs:t))
-    _ -> return ()
-  where literate = intercalate [":\n"] <$> sepBy' (cmdline (several "> ") <+? cmdline (several "$> ")
-                                                            <+? commentline) (single '\n')
-        wrapLabel hide x = "<label class=\"hide-label\"><input type=\"checkbox\" class=\"capricon-hide\" checked=\"checked\"/><span class=\"capricon-"+hide+"\"></span><span class=\"capricon-reveal\">"+x+"</span></label>"
-        wrapResult tag x l = (":<"+tag+" class=\"capricon-"+x+"result\">") : l + [":</"+tag+">"]
-        
-        cmdline pre = map (\x -> (":"+wrapLabel "hideparagraph" ("<pre class=\"capricon capricon-paragraph\">"+htmlQuote (intercalate "\n" (map fst x))+"</pre>"))
-                                 : wrapResult "div" "paragraph" (foldMap snd x)) (sepBy1' go (single '\n'))
-          where go = do pre; many' (noneOf "\n") <&> \x -> (x,stringWords x)
-        commentline = map (foldMap (pure . (':':) <|> \(x,t) -> t+[':':(wrapLabel "hidestache" $ "<code class=\"capricon\">"+htmlQuote x+"</code>")])) $ (<* lookingAt eol)
-          $ many' (map Left (many1' (noneOf "{\n" <+? (fill '{' $ single '{' <* lookingAt (noneOf "{"))))
-                    <+? map Right (between (several "{{") (several "}}")
-                                    (many1' (noneOf "}" <+? fill '}' (single '{' <* lookingAt (noneOf "}"))) <&> \x -> (x,wrapResult "span" "" (stringWords x)))))
-                      
-                      
-runCOCBuiltin COCB_ToInt = runStackState $ modify $ \case
-  StackSymbol s:t -> StackInt (read s):t
-  st -> st
-runCOCBuiltin COCB_Concat = runStackState $ modify $ \case
-  StackSymbol s:StackSymbol s':t -> StackSymbol (s'+s):t
-  st -> st
-
-runCOCBuiltin COCB_Uni = do
-  ctx <- runExtraState (getl context)
-  runStackState $ modify $ \case
-    StackInt n:t -> StackExtra (Opaque (COCExpr (length ctx) (Universe n))):t
-    st -> st
-runCOCBuiltin COCB_Var = do
-  ctx <- runExtraState (getl context)
-  runStackState $ modify $ \case
-    StackSymbol name:t | Just i <- lookup name (zipWith (second . const) [0..] ctx) ->
-                         StackExtra (Opaque (COCExpr (length ctx) (Cons (Ap (Sym i) [])))):t
-    st -> st
-runCOCBuiltin COCB_Ap = do
-  ctx <- runExtraState (getl context)
-  let adj d dd x = inc_depth (dd+nctx-d) x
-      nctx = length ctx
-      env = map snd ctx
-  runStackState $ modify $ \case
-    (StackExtra (Opaque (COCExpr df f)):StackExtra (Opaque (COCExpr dx x)):t) ->
-      let x' = adj dx 1 x ; f' = adj df 0 f in
-        StackExtra (Opaque (COCExpr nctx (subst f' (Cons (Ap (Sym 0) [x'])) env))):t
-    x -> x
-runCOCBuiltin (COCB_Bind close bt) = do
-  ctx <- runExtraState (getl context) 
-  let d = length ctx
-      setVal (StackExtra (Opaque (COCExpr d' e')))
-        | i <- d-d'
-        , d==d' || not close
-        , (_,(x,tx):_) <- splitAt i ctx
-        = StackExtra (Opaque (COCExpr (d'-1) (Bind bt x tx e')))
-      setVal (StackDict dict) = StackDict (map setVal dict)
-      setVal (StackList l) = StackList (map setVal l)
-      setVal x = x
-      setStack (x:t) = setVal x:if close then setStack t else t
-      setStack [] = []
-                                                         
-  ctx' <- runStackState $ id <~ map (,if close && nonempty ctx then tail ctx else ctx) setStack
-  runDictState $ modify $ map setVal
-  runExtraState (context =- ctx')
-runCOCBuiltin COCB_Mu = do
-  ctx <- runExtraState (getl context)
-  let locEnv d = map snd (takeLast d ctx)
-  runStackState $ modify $ \case
-    StackExtra (Opaque (COCExpr d e)):t -> 
-      case type_of e (locEnv d) >>= \te -> mu_type te (locEnv d) of
-        Just mte -> let args (Bind Prod _ tx e') = tx:args e'
-                        args _ = []
-                    in (:t) $ StackExtra $ Opaque $ COCExpr d $
-                       subst e (Cons (Ap (Mu [] (args mte) (Ap (Sym 0) [])) [])) (locEnv d)
-        Nothing -> StackExtra (Opaque COCNull):t
-    st -> st
-runCOCBuiltin COCB_TypeOf = do
-  ctx <- runExtraState (getl context)
-  runStackState $ modify $ \case
-    StackExtra (Opaque (COCExpr d (Cons (Ap (Sym i) [])))):t
-      | (_,ti):_ <- drop i ctx ->
-          StackExtra (Opaque (COCExpr (d-i-1) ti)):t
-    StackExtra (Opaque (COCExpr d e)):t -> (:t) $ StackExtra $ Opaque $ case type_of e (takeLast d (map snd ctx)) of
-      Just te -> COCExpr d te
-      Nothing -> COCNull
-    st -> st
-
-runCOCBuiltin COCB_ExecModule = do
-  st <- runStackState get
-  case st of
-    StackSymbol f:StackProg p:t -> do
-      old <- runDictState get
-      o <- lift $ openFile f WriteMode
-      oldH <- runExtraState (outputHandle <~ \x -> (o,x))
-      traverse_ (execSymbol runCOCBuiltin runComment) p
-      new <- runDictState (id <~ (old,))
-      runExtraState (outputHandle =- oldH)
-      lift $ hClose o
-      runStackState $ put $ StackDict new:t
-    _ -> return ()
-
-runCOCBuiltin COCB_Hyp = do
-  ass <- runStackState $ id <~ \case
-    StackSymbol name:StackExtra (Opaque (COCExpr d typ)):t -> (t,Just (d,(name,typ)))
-    st -> (st,Nothing)
-  case ass of
-    Just (d,x) -> runExtraState $ context =~ \ctx -> (second (inc_depth (length ctx-d)) x:ctx)
-    Nothing -> return ()
-runCOCBuiltin COCB_HypBefore = do
-  ctx <- runExtraState (getl context)
-  let csz = length ctx
-      adj hi i j = if i+j>=hi then j+1 else j
-  ctx' <- runStackState $ id <~ \case
-    StackSymbol h:StackSymbol h':StackExtra (Opaque (COCExpr d e)):t
-      | (hi,_):_ <- select ((==h) . fst . snd) (zip [0..] ctx)
-      , all (>hi+d-csz) (free_vars e) ->
-        let ctx' = foldr (\x k i -> case compare hi i of
-                             LT -> x:k (i+1)
-                             EQ -> second (adjust_depth (adj hi i)) x:(h',inc_depth (csz-(d+hi+1)) e):k (i+1)
-                             GT -> second (adjust_depth (adj hi i)) x:k (i+1))
-                   (\_ -> []) ctx 0
-            adjE x@(StackExtra (Opaque (COCExpr d' e'))) =
-              let i = csz-d'
-              in if i<=hi then StackExtra (Opaque (COCExpr (d+1) (adjust_depth (adj (hi+1) i) e')))
-                 else x
-            adjE x = x
-        in (map adjE t,ctx')
-    st -> (st,ctx)
-  runExtraState (context =- ctx')
-runCOCBuiltin COCB_Subst = do
-  ctx <- runExtraState (getl context)
-  let csz = length ctx
-  ctx' <- runStackState $ id <~ \case
-    StackSymbol h:StackExtra (Opaque (COCExpr d e)):t
-      | (hi,_):_ <- select ((==h) . fst . snd) (zip [0..] ctx)
-      , all (>hi+d-csz) (free_vars e) ->
-        let ctx' = foldr (\x k i env -> case compare i hi of
-                             LT -> second (\xv -> substn e (hi-i) xv env) x:k (i+1) (tail env)
-                             EQ -> k (i+1) (tail env)
-                             GT -> x:k (i+1) (tail env)) (\_ _ -> []) ctx 0 (map snd ctx)
-            adjE x@(StackExtra (Opaque (COCExpr d' e'))) =
-              let i = csz - d'
-              in if i<=hi then StackExtra (Opaque (COCExpr (d-1) ((substn e (hi-i) e' (map snd (drop i ctx))))))
-                 else x
-            adjE x = x
-        in (map adjE t,ctx')
-    st -> (st,ctx)
-  runExtraState (context =- ctx')
-runCOCBuiltin COCB_Rename = do
-  ctx <- runExtraState (getl context)
-  ctx' <- runStackState $ id <~ \case
-    StackSymbol s:StackSymbol s':t -> (t,map (\(n,v) -> (if n==s then s' else n, v)) ctx)
-    st -> (st,ctx)
-  runExtraState (context =- ctx')
-runCOCBuiltin COCB_ContextVars = do
-  ctx <- runExtraState (getl context)
-  runStackState $ modify (StackList (map (StackSymbol . fst) ctx):)
-
-runCOCBuiltin COCB_GetShowDir = do
-  dir <- runExtraState (getl showDir)
-  runStackState $ modify $ (StackExtra (Opaque (COCDir (map (\(c,l) -> (c,StackSymbol (intercalate " " $ map (id <|> head . flip drop c) l))) dir))):)
-runCOCBuiltin COCB_SetShowDir = do
-  mod' <- runStackState $ id <~ \case
-    StackExtra (Opaque (COCDir d)):t -> (t,showDir =- map (\(c,StackSymbol ws) -> (c,[case select ((==w) . fst) (zip c [0..]) of
-                                                                                        (_,i):_ -> Right i
-                                                                                        _ -> Left w
-                                                                                     | w <- words ws])) d)
-    st -> (st,return ())
-  runExtraState mod'
-runCOCBuiltin COCB_InsertNodeDir = do
-  ctx <- runExtraState (getl context)
-  runStackState $ modify $ \case
-    x:StackExtra (Opaque (COCExpr d e)):StackExtra (Opaque (COCDir dir)):t ->
-      StackExtra (Opaque (COCDir (insert e (map fst (takeLast d ctx),x) dir))):t
-    st -> st
-
-data COCValue = COCExpr Int Node | COCNull | COCDir (NodeDir ([String],StackVal String COCBuiltin COCValue))
-
-cocDict = mkDict ((".",StackProg []):("version",StackSymbol VERSION_capricon):
-                   [(x,StackBuiltin b) | (x,b) <- [
-                       ("def"                     , Builtin_Def                           ),
-                       ("$"                       , Builtin_DeRef                         ),
-                       ("lookup"                  , Builtin_Lookup                        ),
-                       ("exec"                    , Builtin_Exec                          ),
-                       ("quote"                   , Builtin_Quote                         ),
-
-                       ("stack"                   , Builtin_Stack                         ),
-                       ("clear"                   , Builtin_Clear                         ),
-                       ("pop"                     , Builtin_Pop                           ),
-                       ("popn"                    , Builtin_PopN                          ),
-                       ("dup"                     , Builtin_Dup                           ),
-                       ("dupn"                    , Builtin_DupN                          ),
-                       ("swap"                    , Builtin_Swap                          ),
-                       ("swapn"                   , Builtin_SwapN                         ),
-                       ("pick"                    , Builtin_Pick                          ),
-
-                       ("["                       , Builtin_ListBegin                     ),
-                       ("]"                       , Builtin_ListEnd                       ),
-                       
-                       ("io/exit"                 , Builtin_Extra COCB_Quit               ),
-                       ("io/print"                , Builtin_Extra COCB_Print              ),
-                       ("io/open"                 , Builtin_Extra COCB_Open               ), 
-                       ("io/get-env"              , Builtin_Extra COCB_GetEnv             ),
-                                             
-                       ("string/format"           , Builtin_Extra COCB_Format             ),
-                       ("string/to-int"           , Builtin_Extra COCB_ToInt              ),
-                       
-                       ("arith/+"                 , Builtin_Add                           ),
-                       ("arith/-"                 , Builtin_Sub                           ),
-                       ("arith/*"                 , Builtin_Mul                           ),
-                       ("arith/div"               , Builtin_Div                           ),
-                       ("arith/mod"               , Builtin_Mod                           ),
-                       ("arith/sign"              , Builtin_Sign                          ),
-                       
-                       ("list/each"               , Builtin_Each                          ),
-                       ("list/range"              , Builtin_Range                         ),
-
-                       ("dict/vocabulary"         , Builtin_CurrentDict                   ),
-                       ("dict/empty"              , Builtin_Empty                         ),
-                       ("dict/insert"             , Builtin_Insert                        ),
-                       ("dict/delete"             , Builtin_Delete                        ),
-                       ("dict/keys"               , Builtin_Keys                          ),
-                       ("dict/module"             , Builtin_Extra COCB_ExecModule         ),
-
-                       ("term-index/pattern-index"     , Builtin_Extra COCB_GetShowDir         ),
-                       ("term-index/set-pattern-index" , Builtin_Extra COCB_SetShowDir         ),
-                       ("term-index/index-insert"      , Builtin_Extra COCB_InsertNodeDir      ),
-                       
-                       ("term/universe"            , Builtin_Extra COCB_Uni                ),
-                       ("term/variable"            , Builtin_Extra COCB_Var                ),
-                       ("term/apply"               , Builtin_Extra COCB_Ap                 ),
-                       ("term/lambda"              , Builtin_Extra (COCB_Bind False Lambda )),
-                       ("term/forall"              , Builtin_Extra (COCB_Bind False Prod   )  ),
-                       ("term/mu"                  , Builtin_Extra COCB_Mu                 ),
-
-                       ("context/intro"           , Builtin_Extra COCB_Hyp                ),
-                       ("context/intro-before"    , Builtin_Extra COCB_HypBefore          ),
-                       ("context/extro-lambda"    , Builtin_Extra (COCB_Bind True Lambda  ) ),
-                       ("context/extro-forall"    , Builtin_Extra (COCB_Bind True Prod    )   ),
-                       ("context/rename"          , Builtin_Extra COCB_Rename             ),
-                       ("context/substitute"      , Builtin_Extra COCB_Subst              ),
-                       ("context/type"            , Builtin_Extra COCB_TypeOf             ),
-                       ("context/hypotheses"      , Builtin_Extra COCB_ContextVars        )
-                       ]])
-  where mkDict = foldr addElt (c'map zero)
-        addElt (x,v) = atP (splitPath x) %- Just v
-        splitPath ('/':x) = ("",uncurry (:) (splitPath x))
-        splitPath (h:t) = let ~(w,l) = splitPath t in (h:w,l)
-        splitPath [] = ("",[])
-        atP (h,[]) = at h
-        atP (h,x:t) = at h.l'Just (StackDict zero).t'StackDict.atP (x,t)
-
-runComment c = do
-  o <- runExtraState (getl outputHandle)
-  lift $ writeHString o c
+myDict = cocDict VERSION_capricon
 
 main = do
   isTerm <- hIsTerminalDevice stdin
   libdir <- getXdgDirectory XdgData "capricon"
-  symList <- newIORef (keys cocDict)
+  symList <- newIORef (keys myDict)
   let getAll = unsafeInterleaveIO $ do
         ln <- readline "CaPriCon> "
         lns <- getAll
@@ -371,9 +33,10 @@ main = do
   str <- stringWords <$> if isTerm then getAll else readHString stdin
   args <- (foldMap (\x -> [libdir</>x,x]) <$> getArgs) >>= map (stringWords . fold) . traverse (try (return []) . readString)
   execS (foldr (\sym mr -> do
-                   execSymbol runCOCBuiltin runComment sym
-                   hasQuit <- runExtraState (getl endState)
+                   execSymbol runCOCBuiltin outputComment sym
+                   (hasQuit,out) <- runExtraState (liftA2 (,) (getl endState) (getl outputText))
                    d <- runDictState get
                    lift (writeIORef symList (keys d))
+                   lift (putStr (out ""))
                    unless hasQuit mr
-               ) unit (args+str)^..concatT) (defaultState cocDict (COCState False [] zero stdout))
+               ) unit (args+str)^..concatT) (defaultState myDict (COCState False [] zero id))

capricon/exe/CaPriCon_haste.hs

+{-# LANGUAGE CPP, RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies, NoMonomorphismRestriction #-}
+module Main where
+
+import Definitive
+import Language.Parser
+import Algebra.Monad.Concatenative
+import System.IO (openFile,hIsTerminalDevice,IOMode(..),hClose)
+import System.Environment (getArgs,lookupEnv)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import Data.IORef
+import Data.CaPriCon
+import CaPriCon.Run
+import qualified Haste.Foreign as JS
+import qualified Haste as JS
+import qualified Haste.DOM as JS
+import qualified Haste.Events as JS
+
+runComment c = unit
+
+main :: IO ()
+main = do
+  let runWords r ws = do
+        st <- readIORef r
+        (st',v) <- runWordsState ws st
+        writeIORef r st'
+        return v
+      runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
+        foldr (\w tl -> do
+                  x <- runExtraState (getl endState)
+                  unless x $ do execSymbol runCOCBuiltin runComment w; tl) unit ws
+        out <- runExtraState (outputText <~ \x -> (id,x))
+        return (out "")
+      withSubElem root cl = JS.withElemsQS root ('.':cl) . traverse_
+      withSubElems _ [] k = k []
+      withSubElems root (h:t) k = withSubElem root h $ \h' -> withSubElems root t $ \t' -> k (h':t')
+  
+  prelude <- JS.withElem "capricon-prelude" (\e -> JS.getProp e "textContent")
+  -- JS.alert $ JS.toJSString prelude
+  (initState,_) <- runWordsState (stringWords prelude) (defaultState (cocDict "0.7") (COCState False [] zero id))
+  
+  roots <- JS.elemsByClass "capricon-steps"
+  (\k -> foldr k (const unit) roots initState) $ \root next state -> do
+    withSubElems root ["capricon-input","capricon-submit","capricon-output"] $ \[inp,sub,out] -> do
+      JS.withElemsQS root ".capricon-context" $ \case
+        [con] -> do
+          context <- JS.getProp con "textContent"
+          -- JS.alert $ JS.toJSString context
+          (state',_) <- runWordsState (stringWords context) state
+          JS.onEvent sub JS.Click $ \_ -> do
+            Just v <- JS.getValue inp
+            (_,x) <- runWordsState (stringWords v) state'
+            JS.setProp out "textContent" x
+          next state'
+        
+  return ()

capricon/src/CaPriCon/Run.hs

+{-# LANGUAGE CPP, NoMonomorphismRestriction #-}
+module CaPriCon.Run where
+
+import Definitive
+import Language.Parser
+import Algebra.Monad.Concatenative
+import System.Environment (lookupEnv)
+import Data.CaPriCon
+
+takeLast n l = drop (length l-n) l
+
+showStackVal dir ctx _x = case _x of
+  StackExtra (Opaque _x) -> case _x of
+    COCExpr d e -> -- "<"+show d+">:"+
+      showNode' dir (map (second snd) $ takeLast d (freshContext ctx)) e
+    COCNull -> "(null)"
+    COCDir d -> show d
+  StackSymbol s -> show s
+  StackInt n -> show n
+  _ -> show _x
+data COCBuiltin = COCB_Print | COCB_Open | COCB_ExecModule | COCB_GetEnv
+                | COCB_ToInt | COCB_Concat | COCB_Uni | COCB_Hyp
+                | COCB_Quit | COCB_Var
+                | COCB_Ap | COCB_Bind Bool BindType
+                | COCB_TypeOf | COCB_Mu
+                | COCB_HypBefore | COCB_Subst | COCB_Rename
+                | COCB_ContextVars
+                | COCB_GetShowDir | COCB_SetShowDir | COCB_InsertNodeDir
+                | COCB_Format
+                deriving Show
+
+data COCState = COCState {
+  _endState :: Bool,
+  _context :: [(String,Node)],
+  _showDir :: NodeDir ([String],StringPattern),
+  _outputText :: String -> String
+  }
+endState :: Lens' COCState Bool
+endState = lens _endState (\x y -> x { _endState = y })
+context :: Lens' COCState [(String,Node)]
+context = lens _context (\x y -> x { _context = y })
+showDir :: Lens' COCState (NodeDir ([String],StringPattern))
+showDir = lens _showDir (\x y -> x { _showDir = y })
+outputText :: Lens' COCState (String -> String)
+outputText = lens _outputText (\x y -> x { _outputText = y })
+
+htmlQuote = foldMap qChar
+  where qChar '<' = "&lt;"
+        qChar '>' = "&gt;"
+        qChar '&' = "&amp;"
+        qChar c = [c]
+stringWords = fromBlank
+  where fromBlank (c:t) | c `elem` " \n\t\r" = fromBlank t
+                        | c == '"' = fromQuote id t
+                        | otherwise = fromWChar (c:) t
+        fromBlank "" = []
+        fromQuote k ('"':t) = ('"':k "\""):fromBlank t
+        fromQuote k ('\\':c:t) = fromQuote (k.(qChar c:)) t
+          where qChar 'n' = '\n' ; qChar 't' = '\t' ; qChar x = x
+        fromQuote k (c:t) = fromQuote (k.(c:)) t
+        fromQuote k "" = ['"':k "\""]
+        fromWChar k (c:t) | c `elem` " \n\t\r" = k "":fromBlank t
+                          | otherwise = fromWChar (k.(c:)) t
+        fromWChar k "" = [k ""]
+
+runCOCBuiltin COCB_Quit = runExtraState (endState =- True)
+runCOCBuiltin COCB_Print = do
+  s <- runStackState get
+  for_ (take 1 s) $ \case
+    StackSymbol s' -> runExtraState (outputText =~ \o t -> o (s'+t))
+    _ -> return ()
+runCOCBuiltin COCB_GetEnv = do
+  st <- runStackState get
+  case st of
+    StackSymbol s:t -> do
+      v <- lift $ lookupEnv s
+      runStackState (put (StackSymbol (maybe "" id v):t))
+    _ -> return ()
+
+runCOCBuiltin COCB_Format = do
+  ex <- runExtraState get
+  let format ('%':'s':s) (StackSymbol h:t) = first (h+) (format s t)
+      format ('%':'v':s) (x:t) = first (showStackVal (ex^.showDir) (ex^.context) x+) (format s t)
+      format (c:s) t = first (c:) (format s t)
+      format "" t = ("",t)
+  runStackState $ modify $ \case
+    StackSymbol s:t -> uncurry ((:) . StackSymbol) (format s t)
+    st -> st
+
+runCOCBuiltin COCB_Open = do
+  s <- runStackState get
+  case s of
+    StackSymbol f:t -> do
+      xs <- lift (try (return []) (try (readString f) (readString (f+".md")) >>= maybe undefined return . matches Just literate))
+      runStackState (put (StackProg xs:t))