Commit ffa15775 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Implement a 'cache' builtin for the CaPriCon interpreter, that can store any...

Implement a 'cache' builtin for the CaPriCon interpreter, that can store any object in a platform-independent format; polish the hypothesis lookup mechanism to handle naming conflicts
parent 1654b466
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: capricon
version: 0.7.1.1
version: 0.8
-- synopsis:
-- description:
license: GPL-3
......@@ -35,7 +35,7 @@ executable capricon
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <4.10,capricon >=0.7 && <0.8,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1
build-depends: base >=4.8 && <4.10,capricon >=0.8 && <0.9,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1
ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: exe
default-language: Haskell2010
......@@ -47,7 +47,7 @@ executable WiQEE.js
-- other-modules:
-- other-extensions:
haste-options: --opt-all
build-depends: base >=4.8 && <4.10,capricon >=0.7 && <0.8,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1,filepath >=1.4 && <1.5,haste-lib
build-depends: base >=4.8 && <4.10,capricon >=0.8 && <0.9,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1,filepath >=1.4 && <1.5,haste-lib,array
hs-source-dirs: exe
default-language: Haskell2010
-- executable coinche
......
......@@ -2,6 +2,7 @@
module Main where
import Definitive
import Language.Format
import Algebra.Monad.Concatenative
import System.IO (hIsTerminalDevice)
import System.Environment (getArgs)
......@@ -12,7 +13,17 @@ import System.Directory (getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>))
import CaPriCon.Run
nativeDict = cocDict VERSION_capricon readString writeString
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl IO String String) where datum = return (ReadImpl f_readString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl IO String [Word8]) where datum = return (ReadImpl f_readBytes)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl IO String String) where datum = return (WriteImpl writeString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
f_readString = (\x -> try (return Nothing) (Just<$>readString x))
f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x))
nativeDict = cocDict VERSION_capricon f_readString f_readBytes writeString (\x -> writeBytes x . pack)
main = do
isTerm <- hIsTerminalDevice stdin
......
......@@ -2,7 +2,7 @@
module Main where
import Definitive
import Language.Parser
import Language.Format
import Algebra.Monad.Concatenative
import System.IO (openFile,hIsTerminalDevice,IOMode(..),hClose)
import System.Environment (getArgs,lookupEnv)
......@@ -19,7 +19,9 @@ 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 Haste.Binary as JS
import qualified Prelude as P
import qualified Data.Array.Unboxed as Arr
instance Semigroup JS.JSString where (+) = JSS.append
instance Monoid JS.JSString where zero = JSS.empty
......@@ -43,27 +45,53 @@ 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
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl JS.CIO String String) where datum = return (ReadImpl getString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
runComment c = unit
toWordList :: JS.JSString -> [Word8]
toWordList = map (fromIntegral . fromEnum) . toString
getString :: String -> JS.CIO (Maybe String)
getString file = do
mres <- liftIO $ JS.getItem (fromString file)
case mres of
Right res -> return (Just $ toString (res :: JS.JSString))
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 Nothing $ JS.alert $ "Network error while retrieving "+url
Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toString (val :: JS.JSString))
getBytes :: String -> JS.CIO (Maybe [Word8])
getBytes file = do
mres <- liftIO $ JS.getItem (fromString file)
case mres of
Right res -> return (Just $ toWordList (res :: JS.JSString))
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 Nothing $ JS.alert $ "Network error while retrieving "+url
Left (JS.HttpError n msg) -> fill Nothing $ JS.alert $ "HTTP error "+fromString (show n)+": "+msg
Right val -> map Just $ liftIO $ JS.setItem (fromString file) val >> return (toWordList val)
setString :: String -> String -> JS.CIO ()
setString f v = liftIO $ JS.setItem (fromString f) (fromString v :: JS.JSString)
setBytes :: String -> [Word8] -> JS.CIO ()
setBytes f v = setString f (map (toEnum . fromIntegral) v)
hasteDict :: COCDict JS.CIO String
hasteDict = cocDict ("0.7.1.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))
hasteDict = cocDict ("0.8-js" :: String) getString getBytes setString setBytes
foo :: Bytes
foo = "abcdef"
main :: IO ()
main = JS.concurrent $ void $ do
let runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
......@@ -84,13 +112,23 @@ main = JS.concurrent $ void $ do
(\k -> foldr k (const unit) roots initState) $ \root next state -> do
JS.wait 10
root' <- cloneNode root
JS.toggleClass root' "capricon-frame"
rootChildren <- JS.getChildren root'
rootTitle <- JS.newElem "h3" <*= \head -> JS.appendChild head =<< JS.newTextElem "CaPriCon Console"
closeBtn <- JS.newElem "button" <*= \but -> JS.appendChild but =<< JS.newTextElem "Close"
JS.appendChild rootTitle closeBtn
JS.appendChild console root'
JS.setChildren root' (rootTitle:rootChildren)
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
let toggleActive = do
JS.toggleClass root' "active"
JS.focus inp
JS.onEvent closeBtn JS.Click (const toggleActive)
JS.onEvent trig JS.Click $ \_ -> toggleActive
withSubElems root' ["capricon-input","capricon-output"] $ \[inp,out] -> do
JS.withElemsQS root' ".capricon-context" $ \case
[con] -> do
......
......@@ -21,11 +21,14 @@ showStackVal dir ctx _x = case _x of
COCExpr d e -> -- "<"+show d+">:"+
showNode' dir (map (second snd) $ takeLast d (freshContext ctx)) e
COCNull -> "(null)"
COCError e -> "<!"+e+"!>"
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
data COCBuiltin io str = COCB_Print
| COCB_Open (ReadImpl io str str) | COCB_ExecModule (WriteImpl io str str)
| COCB_Cache (ReadImpl io str [Word8]) (WriteImpl io str [Word8])
| COCB_ToInt | COCB_Concat | COCB_Uni | COCB_Hyp
| COCB_Quit | COCB_Var
| COCB_Ap | COCB_Bind Bool BindType
......@@ -35,17 +38,19 @@ data COCBuiltin io str = COCB_Print | COCB_Open (OpenImpl io str) | COCB_ExecMod
| 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 ReadImpl io str bytes = ReadImpl (str -> io (Maybe bytes))
data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ())
instance Show (ReadImpl io str bytes) where show _ = "#<open>"
instance Show (WriteImpl io str bytes) where show _ = "#<write>"
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
type IOListFormat io str = (ListFormat (ReadImpl io str str), ListFormat (WriteImpl io str str),
ListFormat (ReadImpl io str [Word8]), ListFormat (WriteImpl io str [Word8]))
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl io str bytes) where encode _ _ = id
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl io str bytes) 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)
instance (ListFormat str,IOListFormat io str) => ListFormat (COCBuiltin io str)
htmlQuote :: IsCapriconString str => str -> str
htmlQuote = fromString . foldMap qChar . toString
......@@ -100,21 +105,16 @@ 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 ()
pushError :: MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m => str -> m ()
pushError s = runStackState $ modify $ (StackExtra (Opaque (COCError s)):)
runCOCBuiltin :: (MonadSubIO io m,IsCapriconString str, MonadStack (COCState str) str (COCBuiltin io str) (COCValue io str) m,IOListFormat io str,ListFormat str) => COCBuiltin io str -> m ()
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 _: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
......@@ -126,11 +126,11 @@ runCOCBuiltin COCB_Format = do
StackSymbol s:t -> uncurry ((:) . StackSymbol) (format (toString s) t)
st -> st
runCOCBuiltin (COCB_Open (OpenImpl getResource)) = do
runCOCBuiltin (COCB_Open (ReadImpl getResource)) = do
s <- runStackState get
case s of
StackSymbol f:t -> do
xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . toString
xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . maybe "" toString
runStackState (put (StackProg xs:t))
_ -> return ()
......@@ -215,6 +215,21 @@ runCOCBuiltin (COCB_ExecModule (WriteImpl writeResource)) = do
runStackState $ put $ StackDict new:t
_ -> return ()
runCOCBuiltin (COCB_Cache (ReadImpl getResource) (WriteImpl writeResource)) = do
st <- runStackState get
case st of
StackSymbol f:StackProg p:t -> do
runStackState (put t)
liftSubIO (getResource (f+".blob")) >>= \case
Just res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
_ -> do
traverse_ (execSymbol runCOCBuiltin outputComment) p
st' <- runStackState get
case st' of
v:_ -> liftSubIO $ writeResource (f+".blob") (serialize v)
_ -> unit
_ -> pushError "Invalid argument types for builtin 'cache'. Usage: <prog> <string> cache."
runCOCBuiltin COCB_Hyp = do
ass <- runStackState $ id <~ \case
StackSymbol name:StackExtra (Opaque (COCExpr d typ)):t -> (t,Just (d,(name,typ)))
......@@ -265,7 +280,7 @@ runCOCBuiltin COCB_Subst = do
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))
StackSymbol s:StackSymbol s':t -> (t,map (\(n',(n,v)) -> (if n'==s then s' else n, v)) (freshContext ctx))
st -> (st,ctx)
runExtraState (context =- ctx')
runCOCBuiltin COCB_ContextVars = do
......@@ -290,7 +305,9 @@ runCOCBuiltin COCB_InsertNodeDir = do
StackExtra (Opaque (COCDir (insert e (map fst (takeLast d ctx),x) dir))):t
st -> st
data COCValue io str = COCExpr Int (Node str) | COCNull | COCDir (NodeDir str ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
data COCValue io str = COCExpr Int (Node str)
| COCNull | COCError str
| 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)
......@@ -300,11 +317,11 @@ 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)
instance (IsCapriconString str,ListFormat str,IOListFormat io str) => ListFormat (COCValue io str)
type COCDict io str = Map str (StackVal str (COCBuiltin io str) (COCValue io str))
cocDict :: forall io str. IsCapriconString str => str -> (str -> io str) -> (str -> str -> io ()) -> COCDict io str
cocDict version getResource writeResource =
cocDict :: forall io str. IsCapriconString str => str -> (str -> io (Maybe str)) -> (str -> io (Maybe [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
cocDict version getResource getBResource writeResource writeBResource =
mkDict ((".",StackProg []):("version",StackSymbol version):
[(x,StackBuiltin b) | (x,b) <- [
("def" , Builtin_Def ),
......@@ -328,9 +345,9 @@ cocDict version getResource writeResource =
("io/exit" , Builtin_Extra COCB_Quit ),
("io/print" , Builtin_Extra COCB_Print ),
("io/open" , Builtin_Extra (COCB_Open (OpenImpl getResource))),
("io/get-env" , Builtin_Extra COCB_GetEnv ),
("io/source" , Builtin_Extra (COCB_Open (ReadImpl getResource))),
("io/cache" , Builtin_Extra (COCB_Cache (ReadImpl getBResource) (WriteImpl writeBResource))),
("string/format" , Builtin_Extra COCB_Format ),
("string/to-int" , Builtin_Extra COCB_ToInt ),
......@@ -399,5 +416,5 @@ outputComment c = (runExtraState $ do outputText =~ (\o t -> o (commentText+t)))
+ 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>"
userInput = "<div class=\"user-input\"><button class=\"capricon-trigger\">Open/Close console</button><span class=\"capricon-input-prefix\">Evaluate in this context (press Enter to run):</span><input type=\"text\" class=\"capricon-input\" /><pre class=\"capricon-output\"></pre></div>"
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment