Skip to content

Commit

Permalink
Implement a 'cache' builtin for the CaPriCon interpreter, that can st…
Browse files Browse the repository at this point in the history 
…ore any object in a platform-independent format; polish the hypothesis lookup mechanism to handle naming conflicts
  • Loading branch information
Marc Coiffier committed Oct 17, 2018
1 parent 1654b46 commit ffa1577
Show file tree
Hide file tree
Showing 4 changed files with 119 additions and 53 deletions.
6 changes: 3 additions & 3 deletions capricon/capricon.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
13 changes: 12 additions & 1 deletion capricon/exe/CaPriCon.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
module Main where

import Definitive
import Language.Format
import Algebra.Monad.Concatenative
import System.IO (hIsTerminalDevice)
import System.Environment (getArgs)
Expand All @@ -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
Expand Down
80 changes: 59 additions & 21 deletions capricon/exe/WiQEE.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
73 changes: 45 additions & 28 deletions capricon/src/CaPriCon/Run.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 ()

Expand Down Expand Up @@ -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)))
Expand Down Expand Up @@ -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
Expand All @@ -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)
Expand All @@ -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 ),
Expand All @@ -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 ),

Expand Down Expand Up @@ -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>"

0 comments on commit ffa1577

Please sign in to comment.