Commit 681c9487 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

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
parent dc7540f6
......@@ -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
......
......@@ -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))
{-# 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 ()
{-# 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
{-# 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
......
{-# 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>"
{-# LANGUAGE UndecidableInstances #-}
module Data.CaPriCon where
{-# LANGUAGE UndecidableInstances, OverloadedStrings, NoMonomorphismRestriction, DeriveGeneric, ConstraintKinds #-}
module Data.CaPriCon(