Make preparations for the implementation of a compiled CaPriCon format;...

Make preparations for the implementation of a compiled CaPriCon format; implement a console-based interface for the WiQEE site

capricon/capricon.cabal

@@ -2,7 +2,7 @@
 -- see http://haskell.org/cabal/users-guide/
 
 name:                capricon
-version:             0.7
+version:             0.7.1
 -- synopsis:            
 -- description:         
 license:             GPL-3
@@ -39,6 +39,17 @@ executable capricon
   ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
   hs-source-dirs:      exe
   default-language:    Haskell2010
+executable WiQEE.js
+  if !impl(haste)
+    buildable: False
+  main-is:             WiQEE.hs
+  default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
+  -- other-modules:       
+  -- other-extensions:    
+  haste-options: --opt-all
+  build-depends: base,definitive-base, definitive-parser, capricon, haste-lib, filepath
+  hs-source-dirs:      exe
+  default-language:    Haskell2010
 -- executable coinche
 --   main-is:             Coinche.hs
 --   default-extensions:  RebindableSyntax

capricon/exe/CaPriCon.hs

@@ -12,12 +12,12 @@ import System.Directory (getXdgDirectory, XdgDirectory(..))
 import System.FilePath ((</>))
 import CaPriCon.Run
 
-myDict = cocDict VERSION_capricon
+nativeDict = cocDict VERSION_capricon readString writeString
 
 main = do
   isTerm <- hIsTerminalDevice stdin
   libdir <- getXdgDirectory XdgData "capricon"
-  symList <- newIORef (keys myDict)
+  symList <- newIORef (keys nativeDict)
   let getAll = unsafeInterleaveIO $ do
         ln <- readline "CaPriCon> "
         lns <- getAll
@@ -34,9 +34,9 @@ main = do
   args <- (foldMap (\x -> [libdir</>x,x]) <$> getArgs) >>= map (stringWords . fold) . traverse (try (return []) . readString)
   execS (foldr (\sym mr -> do
                    execSymbol runCOCBuiltin outputComment sym
-                   (hasQuit,out) <- runExtraState (liftA2 (,) (getl endState) (getl outputText))
+                   (hasQuit,out) <- runExtraState (liftA2 (,) (getl endState) (getl outputText) <* (outputText =- id))
                    d <- runDictState get
                    lift (writeIORef symList (keys d))
                    lift (putStr (out ""))
                    unless hasQuit mr
-               ) unit (args+str)^..concatT) (defaultState myDict (COCState False [] zero id))
+               ) unit (args+str)^..concatT) (defaultState nativeDict (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/exe/WiQEE.hs

+{-# LANGUAGE OverloadedStrings, 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 System.FilePath (dropFileName,(</>))
+import qualified Haste.Foreign as JS
+import qualified Haste as JS
+import qualified Haste.DOM as JS
+import qualified Haste.Events as JS
+import qualified Haste.Concurrent as JS
+import qualified Haste.Ajax as JS
+import qualified Haste.JSString as JSS
+import qualified Haste.LocalStorage as JS
+import qualified Prelude as P
+
+instance Semigroup JS.JSString where (+) = JSS.append
+instance Monoid JS.JSString where zero = JSS.empty
+instance Sequence JS.JSString where splitAt = JSS.splitAt
+instance StackSymbol JS.JSString where
+  atomClass c = case c JSS.! 0 of
+    '{' | JSS.length c==1 -> OpenBrace
+    '}' | JSS.length c==1 -> CloseBrace
+    '\'' -> Quoted (drop 1 c)
+    '"' -> Quoted (take (JSS.length c-2) (drop 1 c))
+    ':' -> Comment (drop 1 c)
+    _ -> maybe (Other c) Number $ matches Just readable (toString c)
+instance IsCapriconString JS.JSString where
+  toString = JSS.unpack
+
+instance Functor JS.CIO where map = P.fmap
+instance SemiApplicative JS.CIO where (<*>) = (P.<*>)
+instance Unit JS.CIO where pure = P.return
+instance Applicative JS.CIO
+instance Monad JS.CIO where join = (P.>>=id)
+instance MonadIO JS.CIO where liftIO = JS.liftIO
+instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id
+
+runComment c = unit
+
+hasteDict :: COCDict JS.CIO String
+hasteDict = cocDict ("0.7.1-js" :: String) get (\_ _ -> return ())
+  where get file = do
+          mres <- liftIO $ JS.getItem (fromString file)
+          case mres of
+            Right res -> return res
+            Left _ -> do
+              here <- toString <$> JS.getLocationHref
+                
+              let url = fromString (dropFileName here</>file)
+              res <- JS.ajax JS.GET url
+              case res of
+                Left JS.NetworkError -> fill "" $ JS.alert $ "Network error while retrieving "+url
+                Left (JS.HttpError n msg) -> fill "" $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
+                Right val -> liftIO $ JS.setItem (fromString file) val >> return (toString (val :: JS.JSString))
+
+foo :: Bytes
+foo = "abcdef"
+        
+main :: IO ()
+main = JS.concurrent $ void $ do
+  let 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")
+  (initState,_) <- runWordsState (map fromString $ stringWords prelude) (defaultState hasteDict (COCState False [] zero id))
+
+  roots <- JS.elemsByClass "capricon-steps"
+  Just console <- JS.elemById "capricon-console"
+
+  (\k -> foldr k (const unit) roots initState) $ \root next state -> do
+    JS.wait 10
+    root' <- cloneNode root
+    JS.appendChild console root'
+    withSubElems root ["capricon-trigger"] $ \[trig] -> void $ do
+      withSubElems root' ["capricon-input"] $ \[inp] -> void $ do
+        JS.onEvent trig JS.Click $ \_ -> do
+          JS.toggleClass root' "active"
+          JS.focus inp
+    withSubElems root' ["capricon-input","capricon-output"] $ \[inp,out] -> do
+      JS.withElemsQS root' ".capricon-context" $ \case
+        [con] -> do
+          context <- JS.getProp con "textContent"
+          (state',_) <- runWordsState (stringWords (fromString context)) state
+          JS.onEvent inp JS.KeyPress $ \case
+            JS.KeyData 13 False False False False -> do
+              Just v <- JS.getValue inp
+              (_,x) <- runWordsState (stringWords v) state'
+              JS.setProp out "textContent" (toString x)
+            _ -> unit
+          next state'
+
+cloneNode :: MonadIO m => JS.Elem -> m JS.Elem
+cloneNode x = liftIO $ JS.ffi "(function (n) { return n.cloneNode(true); })" x

capricon/src/Algebra/Monad/Concatenative.hs

-{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase #-}
-module Algebra.Monad.Concatenative(ConcatT,concatT,MonadStack(..),StackBuiltin(..),StackVal(..),t'StackDict,StackState,defaultState,Opaque(..)) where
+{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase, DeriveGeneric #-}
+module Algebra.Monad.Concatenative(StackBuiltin(..),StackVal(..),t'StackDict,StackState,defaultState,StackSymbol(..),AtomClass(..),ConcatT,concatT,MonadStack(..),Opaque(..)) where
 
 import Definitive
 import Language.Parser
+import GHC.Generics
 
 newtype Opaque a = Opaque a
+                 deriving (Generic)
 instance Show (Opaque a) where show _ = "#<opaque>"
 data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
                     | Builtin_Clear | Builtin_Stack
@@ -19,7 +21,7 @@ data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
                     | Builtin_CurrentDict | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
                     | Builtin_Quote
                     | Builtin_Extra b
-                    deriving Show
+                    deriving (Show,Generic)
 data StackVal s b a = StackBuiltin (StackBuiltin b)
                     | StackInt Int
                     | StackSymbol s
@@ -27,7 +29,7 @@ data StackVal s b a = StackBuiltin (StackBuiltin b)
                     | StackDict (Map s (StackVal s b a))
                     | StackProg [s]
                     | StackExtra (Opaque a)
-                    deriving Show
+                    deriving (Show,Generic)
 
 t'StackDict :: Traversal' (StackVal s b a) (Map s (StackVal s b a))
 t'StackDict k (StackDict d) = StackDict <$> k d
@@ -40,6 +42,7 @@ data StackState st s b a = StackState {
   _dict :: Map s (StackVal s b a),
   _extraState :: st
   }
+  deriving Generic
 
 stack :: Lens' (StackState st s b a) [StackVal s b a]
 stack = lens _stack (\x y -> x { _stack = y })
@@ -176,7 +179,7 @@ class (StackSymbol s,Monad m) => MonadStack st s b a m | m -> st s b a where
   runDictState :: State (Map s (StackVal s b a)) x -> m x
 
 newtype ConcatT st b o s m a = ConcatT { _concatT :: StateT (StackState st s b o) m a }
-                          deriving (Functor,SemiApplicative,Unit,Applicative,MonadIO,MonadTrans)
+                          deriving (Functor,SemiApplicative,Unit,Applicative,MonadTrans)
 instance Monad m => Monad (ConcatT st b o s m) where join = coerceJoin ConcatT
 instance (StackSymbol s,Monad m) => MonadStack st s b a (ConcatT st b a s m) where
   execSymbol x y z = ConcatT $ execSymbolImpl (execBuiltin (map _concatT x) (map _concatT y)) (map _concatT y) z

capricon/src/CaPriCon/Run.hs

-{-# LANGUAGE CPP, NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP, NoMonomorphismRestriction, OverloadedStrings, ScopedTypeVariables, DeriveGeneric, ConstraintKinds, UndecidableInstances #-}
 module CaPriCon.Run where
 
 import Definitive
-import Language.Parser
+import Language.Format
 import Algebra.Monad.Concatenative
-import System.Environment (lookupEnv)
 import Data.CaPriCon
+import GHC.Generics (Generic)
+
+class Monad m => MonadSubIO io m where
+  liftSubIO :: io a -> m a
+instance MonadSubIO IO IO where liftSubIO = id
+instance MonadSubIO io m => MonadSubIO io (ConcatT st b o s m) where
+  liftSubIO ma = lift $ liftSubIO ma
 
 takeLast n l = drop (length l-n) l
 
+showStackVal :: IsCapriconString str => NodeDir str ([str],StringPattern str) -> [(str,Node str)] -> StackVal str (COCBuiltin io str) (COCValue io str) -> str
 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
+    COCDir d -> fromString $ show d
+  StackSymbol s -> fromString $ show s
+  StackInt n -> fromString $ show n
+  _ -> fromString $ show _x
+data COCBuiltin io str = COCB_Print | COCB_Open (OpenImpl io str) | COCB_ExecModule (WriteImpl io str) | 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,Generic)
+data OpenImpl io str = OpenImpl (str -> io str)
+data WriteImpl io str = WriteImpl (str -> str -> io ())
+instance Show (OpenImpl io str) where show _ = "#<open>"
+instance Show (WriteImpl io str) where show _ = "#<write>"
 
-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 })
+type ListSerializable a = (Serializable Word8 ([Word8] -> [Word8]) [Word8] a)
+type ListFormat a = (Format Word8 ([Word8] -> [Word8]) [Word8] a)
+instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (OpenImpl io str) where encode _ _ = id
+instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl io str) where encode _ _ = id
+instance ListSerializable str => ListSerializable (COCBuiltin io str)
+instance (ListFormat str,ListFormat (OpenImpl io str), ListFormat (WriteImpl io str)) => ListFormat (COCBuiltin io str)
 
-htmlQuote = foldMap qChar
+htmlQuote :: IsCapriconString str => str -> str
+htmlQuote = fromString . foldMap qChar . toString
   where qChar '<' = "&lt;"
         qChar '>' = "&gt;"
         qChar '&' = "&amp;"
         qChar c = [c]
-stringWords = fromBlank
-  where fromBlank (c:t) | c `elem` " \n\t\r" = fromBlank t
+stringWords :: IsCapriconString str => str -> [str]
+stringWords = map fromString . fromBlank . toString
+  where fromBlank (c:t) | c `elem` [' ', '\t', '\r', '\n'] = fromBlank t
                         | c == '"' = fromQuote id t
                         | otherwise = fromWChar (c:) t
         fromBlank "" = []
@@ -59,10 +64,43 @@ stringWords = fromBlank
           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
+        fromWChar k (c:t) | c `elem` [' ', '\t', '\r', '\n'] = k "":fromBlank t
                           | otherwise = fromWChar (k.(c:)) t
         fromWChar k "" = [k ""]
 
+literate :: forall str. IsCapriconString str => Parser String [str]
+literate = intercalate [":s\n"] <$> sepBy' (cmdline "> " <+? cmdline "$> " <+? commentline) (single '\n')
+  where
+    wrapResult :: Bool -> [str] -> [str]
+    wrapResult isParagraph l = (if isParagraph then ":rbp" else ":rbs") : l + [if isParagraph then ":rep" else ":res"]
+    cmdline :: Parser String () -> Parser String [str]
+    cmdline pre = map (\x -> [":cp"+intercalate "\n" (map fst x)]
+                             + wrapResult True (foldMap snd x))
+                  (sepBy1' go (single '\n'))
+      where go = do pre; many' (noneOf ['\n']) <&> \x -> (fromString x,map fromString (stringWords x))
+    commentline = map (foldMap (pure . (":s"+) <|> \(x,t) -> t+[":cs"+x])) $ (<* lookingAt eol)
+      $ many' (map (Left . fromString) (many1' (noneOf ['{','\n'] <+?
+                                                (fill '{' $ single '{' <* lookingAt (noneOf ['{']))))
+                <+? map Right (between "{{" "}}"
+                                (many1' (noneOf ['}'] <+? fill '}' (single '}' <* lookingAt (noneOf ['}'])))
+                                 <&> \x -> (fromString x,wrapResult False (stringWords (fromString x))))))
+
+data COCState str = COCState {
+  _endState :: Bool,
+  _context :: [(str,Node str)],
+  _showDir :: NodeDir str ([str],StringPattern str),
+  _outputText :: str -> str
+  }
+endState :: Lens' (COCState str) Bool
+endState = lens _endState (\x y -> x { _endState = y })
+context :: Lens' (COCState str) [(str,Node str)]
+context = lens _context (\x y -> x { _context = y })
+showDir :: Lens' (COCState str) (NodeDir str ([str],StringPattern str))
+showDir = lens _showDir (\x y -> x { _showDir = y })
+outputText :: Lens' (COCState str) (str -> str)
+outputText = lens _outputText (\x y -> x { _outputText = y })
+
+runCOCBuiltin :: (MonadSubIO io m,IsCapriconString str, MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m) => COCBuiltin io str -> m ()
 runCOCBuiltin COCB_Quit = runExtraState (endState =- True)
 runCOCBuiltin COCB_Print = do
   s <- runStackState get
@@ -72,44 +110,32 @@ runCOCBuiltin COCB_Print = do
 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))
+    StackSymbol _:t -> do
+      -- v <- liftIO $ lookupEnv (toString s)
+      let v = Nothing -- TODO
+      runStackState (put (StackSymbol (fromString $ 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 (c:s) t = first (fromString [c]+) (format s t)
       format "" t = ("",t)
   runStackState $ modify $ \case
-    StackSymbol s:t -> uncurry ((:) . StackSymbol) (format s t)
+    StackSymbol s:t -> uncurry ((:) . StackSymbol) (format (toString s) t)
     st -> st
 
-runCOCBuiltin COCB_Open = do
+runCOCBuiltin (COCB_Open (OpenImpl getResource)) = 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))
+      xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . toString
       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+">"]
-        userInput = "<div class=\"user-input\"><input type=\"text\" class=\"capricon-input\" /><pre class=\"capricon-output\"></pre><button class=\"capricon-submit\">Run</button></div>"
-        cmdline pre = map (\x -> (":"+wrapLabel "hideparagraph" ("<div class=\"capricon-steps\"><pre class=\"capricon capricon-paragraph capricon-context\">"+htmlQuote (intercalate "\n" (map fst x))+"</pre>"+userInput+"</div>"))
-                                 : 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
+  StackSymbol s:t -> StackInt (read (toString s)):t
   st -> st
 runCOCBuiltin COCB_Concat = runStackState $ modify $ \case
   StackSymbol s:StackSymbol s':t -> StackSymbol (s'+s):t
@@ -176,7 +202,7 @@ runCOCBuiltin COCB_TypeOf = do
       Nothing -> COCNull
     st -> st
 
-runCOCBuiltin COCB_ExecModule = do
+runCOCBuiltin (COCB_ExecModule (WriteImpl writeResource)) = do
   st <- runStackState get
   case st of
     StackSymbol f:StackProg p:t -> do
@@ -185,7 +211,7 @@ runCOCBuiltin COCB_ExecModule = do
       traverse_ (execSymbol runCOCBuiltin outputComment) p
       new <- runDictState (id <~ (old,))
       newH <- runExtraState (outputText <~ \x -> (oldH,x))
-      lift $ writeString f (newH "")
+      liftSubIO $ writeResource f (newH "")
       runStackState $ put $ StackDict new:t
     _ -> return ()
 
@@ -254,7 +280,7 @@ runCOCBuiltin COCB_SetShowDir = do
     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)
+                                                                                     | w <- map fromString $ words (toString ws)])) d)
     st -> (st,return ())
   runExtraState mod'
 runCOCBuiltin COCB_InsertNodeDir = do
@@ -264,9 +290,21 @@ runCOCBuiltin COCB_InsertNodeDir = do
       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))
+data COCValue io str = COCExpr Int (Node str) | COCNull | COCDir (NodeDir str ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
+                     deriving Generic
+instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackVal s b a)
+instance (IsCapriconString s,ListFormat s,ListFormat b,ListFormat a) => ListFormat (StackVal s b a)
+instance (ListSerializable b) => ListSerializable (StackBuiltin b)
+instance (ListFormat b) => ListFormat (StackBuiltin b)
+instance (ListSerializable a) => ListSerializable (Opaque a)
+instance (ListFormat a) => ListFormat (Opaque a)
+
+instance ListSerializable str => ListSerializable (COCValue io str)
+instance (IsCapriconString str,ListFormat str,ListFormat (OpenImpl io str), ListFormat (WriteImpl io str)) => ListFormat (COCValue io str)
+type COCDict io str = Map str (StackVal str (COCBuiltin io str) (COCValue io str))
 
-cocDict version =
+cocDict :: forall io str. IsCapriconString str => str -> (str -> io str) -> (str -> str -> io ()) -> COCDict io str
+cocDict version getResource writeResource =
   mkDict ((".",StackProg []):("version",StackSymbol version):
            [(x,StackBuiltin b) | (x,b) <- [
                ("def"                     , Builtin_Def                           ),
@@ -290,7 +328,7 @@ cocDict version =
                
                ("io/exit"                 , Builtin_Extra COCB_Quit               ),
                ("io/print"                , Builtin_Extra COCB_Print              ),
-               ("io/open"                 , Builtin_Extra COCB_Open               ), 
+               ("io/open"                 , Builtin_Extra (COCB_Open (OpenImpl getResource))), 
                ("io/get-env"              , Builtin_Extra COCB_GetEnv             ),
                                      
                ("string/format"           , Builtin_Extra COCB_Format             ),
@@ -311,7 +349,7 @@ cocDict version =
                ("dict/insert"             , Builtin_Insert                        ),
                ("dict/delete"             , Builtin_Delete                        ),
                ("dict/keys"               , Builtin_Keys                          ),
-               ("dict/module"             , Builtin_Extra COCB_ExecModule         ),
+               ("dict/module"             , Builtin_Extra (COCB_ExecModule (WriteImpl writeResource))),
 
                ("term-index/pattern-index"     , Builtin_Extra COCB_GetShowDir         ),
                ("term-index/set-pattern-index" , Builtin_Extra COCB_SetShowDir         ),
@@ -333,13 +371,33 @@ cocDict version =
                ("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))
+  where mkDict :: [(str,StackVal str (COCBuiltin io str) (COCValue io str))] -> Map str (StackVal str (COCBuiltin io str) (COCValue io str))
+        mkDict = foldr addElt (c'map zero)
+        addElt (x,v) = atP (first fromString $ splitPath $ toString x) %- Just v
+        splitPath ('/':x) = ("",uncurry (:) (first fromString $ 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)
 
-outputComment c = runExtraState $ do outputText =~ \o t -> o (c+t)
+outputComment c = (runExtraState $ do outputText =~ (\o t -> o (commentText+t)))
+  where commentText = case toString c of
+          'r':'b':p:[] -> let x = if p=='p' then "paragraph" else ""
+                              tag = if p=='p' then "div" else "span"
+                          in "<"+tag+" class=\"capricon-"+x+"result\">"
+          'r':'e':p:[] -> "</"+(if p=='p' then "div" else "span")+">"
+          'c':'p':_ -> let nlines = length (lines (toString c))
+                       in wrapStart True nlines+"<div class=\"capricon-steps\"><pre class=\"capricon capricon-paragraph capricon-context\">"
+                          +htmlQuote (drop 2 c)+"</pre>"+userInput+"</div>"+wrapEnd
+          'c':'s':_ -> wrapStart False 1+"<code class=\"capricon\">"+htmlQuote (drop 2 c)+"</code>"+wrapEnd
+          's':_ -> drop 1 c
+          _ -> ""
 
+        wrapStart isP nlines =
+          let hide = if isP then "hideparagraph" else "hidestache"
+          in "<label class=\"hide-label\"><input type=\"checkbox\" class=\"capricon-hide\" checked=\"checked\"/><span class=\"capricon-"
+             + hide +"\"></span><span class=\"capricon-reveal\" data-linecount=\""
+             + fromString (show nlines)+"\">"
+        wrapEnd = "</span></label>"
+        userInput = "<div class=\"user-input\"><button class=\"capricon-trigger\">Open/Close console</button><span class=\"capricon-input-prefix\">Enter some code: </span><input type=\"text\" class=\"capricon-input\" /><pre class=\"capricon-output\"></pre></div>"
+  

capricon/src/Data/CaPriCon.hs

-{-# LANGUAGE UndecidableInstances #-}
-module Data.CaPriCon where
+{-# LANGUAGE UndecidableInstances, OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric, ConstraintKinds #-}
+module Data.CaPriCon(