Commit 801f041f authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Add two new builtin functions: 'quote' and 'get-env'; include a prelude in the CaPriCon archive

parent aae15996
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: capricon
version: 0.6.3.1
version: 0.6.4
-- synopsis:
-- description:
license: GPL-3
......@@ -14,7 +14,9 @@ maintainer: marc@coiffier.net
build-type: Simple
extra-source-files: ChangeLog.md
cabal-version: >=1.10
data-dir: data
data-files: prelude
library
exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
......
'nop { { } } def
'get { nop nop lookup } def
'each list 1 dupn get def
'dict-keys dict 'keys get def
'import-keys {
{ 1 dupn 1 dupn get def } each
pop
} def
'import {
dup dict-keys import-keys
} def
[ dict term-index term context io list arith string ] { import } each
'Type { 0 universe } def
'times { range { pop dup exec } each pop } def
'foralls { { extro-forall } swap times } def
'lambdas { { extro-lambda } swap times } def
'applys { range { pop apply } each } def
'applyl { { swap apply } each } def
'printf { format print pop } def
'show { "%v\n" printf } def
'show-stack { stack { show } each } def
'show-context { "" hypotheses { dup variable type swap "%s : %v\n%s" format } each print pop } def
'showdef { pattern-index 1 swapn swap index-insert set-pattern-index } def
'external { dup open swap "%s.html" format module } def
'stache { "%v" printf } def
'vis { show-context "-------\n" printf show-stack } def
'-> { dup 1 swapn swap intro dup [ swap "'%s" format 'variable ] quote def } def
'! 'extro-lambda $ def
'? 'extro-forall $ def
'use {
dup open swap
cache-dir "%s/%s.mdc" format module
dup 'exports { import-keys } { pop } lookup
} def
'export { 'exports swap def } def
'( '[ $ def
') { ] applyl } def
'defconstr { 1 dupn swap showdef def } def
......@@ -5,7 +5,7 @@ import Definitive
import Language.Parser
import Algebra.Monad.Concatenative
import System.IO (openFile,hIsTerminalDevice,IOMode(..),hClose)
import System.Environment (getArgs)
import System.Environment (getArgs,lookupEnv)
import Console.Readline (readline,addHistory,setCompletionEntryFunction)
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.IORef
......@@ -24,7 +24,7 @@ showStackVal dir ctx _x = case _x of
StackSymbol s -> show s
StackInt n -> show n
_ -> show _x
data COCBuiltin = COCB_Print | COCB_Open | COCB_ExecModule
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
......@@ -76,6 +76,13 @@ runCOCBuiltin COCB_Print = do
lift $ for_ (take 1 s) $ \case
StackSymbol s' -> writeHString o s'
_ -> return ()
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))
_ -> return ()
runCOCBuiltin COCB_Format = do
ex <- runExtraState get
......@@ -273,6 +280,7 @@ cocDict = mkDict ((".",StackProg []):("version",StackSymbol VERSION_capricon):
("$" , Builtin_DeRef ),
("lookup" , Builtin_Lookup ),
("exec" , Builtin_Exec ),
("quote" , Builtin_Quote ),
("stack" , Builtin_Stack ),
("clear" , Builtin_Clear ),
......@@ -289,8 +297,9 @@ cocDict = mkDict ((".",StackProg []):("version",StackSymbol VERSION_capricon):
("io/exit" , Builtin_Extra COCB_Quit ),
("io/print" , Builtin_Extra COCB_Print ),
("io/open" , Builtin_Extra COCB_Open ),
("io/open" , Builtin_Extra COCB_Open ),
("io/get-env" , Builtin_Extra COCB_GetEnv ),
("string/format" , Builtin_Extra COCB_Format ),
("string/to-int" , Builtin_Extra COCB_ToInt ),
......
......@@ -17,6 +17,7 @@ data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
| Builtin_DeRef | Builtin_Def
| Builtin_Exec
| Builtin_CurrentDict | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
| Builtin_Quote
| Builtin_Extra b
deriving Show
data StackVal s b a = StackBuiltin (StackBuiltin b)
......@@ -109,14 +110,14 @@ execBuiltin runExtra onComment = go
_ -> st
_ -> st
go Builtin_Dup = stack =~ \st -> case st of x:t -> x:x:t ; _ -> st
go Builtin_DupN = stack =~ \st -> case st of StackInt n:t | (h,x:t') <- splitAt n t -> (x:h)+(x:t') ; _ -> st
go Builtin_DupN = stack =~ \st -> case st of StackInt n:t | x:_ <- drop n t -> x:t ; _ -> st
go Builtin_Range = stack =~ \st -> case st of StackInt n:t -> StackList [StackInt i | i <- [0..n-1]]:t ; _ -> st
go Builtin_Each = do
st <- get
case st^.stack of
e:StackList l:t -> do
stack =- t
for_ l $ \x -> do stack =~ (e:) . (x:) ; go Builtin_Exec
for_ l $ \x -> do stack =~ (x:) ; execVal e
_ -> return ()
go Builtin_CurrentDict = getl dict >>= \d -> stack =~ (StackDict d:)
......@@ -127,11 +128,12 @@ execBuiltin runExtra onComment = go
go Builtin_Delete = stack =~ \case
StackSymbol s:StackDict d:t -> StackDict (delete s d):t
st -> st
go Builtin_Lookup = stack =~ \case
StackSymbol s:StackDict d:t -> case lookup s d of
Just x -> StackSymbol s:x:t
Nothing -> StackDict d:t
st -> st
go Builtin_Lookup = join $ do
stack <~ \case
el:th:StackSymbol s:StackDict d:t -> case lookup s d of
Just x -> (x:t,execVal th)
Nothing -> (t,execVal el)
st -> (st,return ())
go Builtin_Keys = stack =~ \case
StackDict d:t -> StackList (map StackSymbol (keys d)):t
st -> st
......@@ -154,11 +156,18 @@ execBuiltin runExtra onComment = go
go Builtin_Exec = do
st <- get
case st^.stack of
StackProg p:t -> do stack =- t ; traverse_ (execSymbolImpl go onComment) p
StackBuiltin b:t -> do stack =- t ; go b
StackProg p:t -> do stack =- t ; execVal (StackProg p)
StackBuiltin p:t -> do stack =- t ; execVal (StackBuiltin p)
_ -> return ()
go Builtin_Quote = stack =~ \case
StackList l:t -> StackProg [s | StackSymbol s <- l]:t
st -> st
go (Builtin_Extra x) = runExtra x
execVal (StackProg p) = traverse_ (execSymbolImpl go onComment) p
execVal (StackBuiltin b) = go b
execVal _ = return ()
class (StackSymbol s,Monad m) => MonadStack st s b a m | m -> st s b a where
execSymbol :: (b -> m ()) -> (s -> m ()) -> s -> m ()
......
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