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

capricon/capricon.cabal

@@ -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

capricon/exe/CaPriCon.hs

@@ -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

capricon/exe/WiQEE.hs

@@ -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

capricon/src/CaPriCon/Run.hs

@@ -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>"