Commit 1d045b9d authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Add a templating feature to all concatenative languages implemented with...

Add a templating feature to all concatenative languages implemented with Algebra.Monad.Concatenative

At its simplest, a template is just a regular quote (between '{' and
'}'). Inside a template, you can drill some holes with the syntax {@
code... @}. The holes thus drilled are automatically filled from left
to right when the template is instanciated, that is, when its value
comes into scope.

For example, you can write a generic function to define custom
setters for individual variables like so :

  'defvar { dup "set-%s" format { {@ swap @} swap def } def } def
  'A defvar 'B defvar
  3 set-A 5 set-B
  A B + A *
parent 9aadcdf4
{-# 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
module Algebra.Monad.Concatenative(
-- * Extensible stack types
StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackClosure(..),
t'StackDict,
-- * The MonadStack class
StackState,defaultState,
MonadStack(..),
AtomClass(..),
-- ** A concrete implementation
ConcatT,concatT,Opaque(..)) where
import Definitive
import Language.Parser
import GHC.Generics
import GHC.Generics (Generic)
newtype Opaque a = Opaque a
deriving (Generic)
instance Show (Opaque a) where show _ = "#<opaque>"
data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | CommentStep s | ClosureStep Bool (StackClosure s b a)
deriving (Show,Generic)
data StackClosure s b a = StackClosure [(StackProgram s b a,StackClosure s b a)] (StackProgram s b a)
deriving (Show,Generic)
type StackProgram s b a = [StackStep s b a]
i'StackClosure :: Iso' ([(StackProgram s b a,StackClosure s b a)],StackProgram s b a) (StackClosure s b a)
i'StackClosure = iso (\(cs,c) -> StackClosure cs c) (\(StackClosure cs c) -> (cs,c))
t'ClosureStep :: Traversal' (StackStep s b a) (StackClosure s b a)
t'ClosureStep k (ClosureStep b c) = ClosureStep b<$>k c
t'ClosureStep _ x = pure x
allSteps :: Fold' (StackClosure s b a) (StackStep s b a)
allSteps = from i'StackClosure.(l'1.each.l'1.each .+ l'2.each)
subClosure :: Int -> Fold' (StackClosure s b a) (StackClosure s b a)
subClosure 0 = id
subClosure n = (allSteps.t'ClosureStep.subClosure (n+1))
.+ (from i'StackClosure.l'1.each.l'2.subClosure (n-1))
closureSplices :: Fold' (StackClosure s b a) (StackClosure s b a)
closureSplices = allSteps.t'ClosureStep.subClosure (1::Int)
runClosure execBuiltin' onComment clos = do
p <- flatten =<< forl closureSplices clos (\c -> StackClosure [] <$> flatten c)
stack =~ (StackProg p:)
where flatten (StackClosure cs c) = do
pref <- map fold $ for cs $ \(i,StackClosure _ p) -> (i+) <$> do
traverse_ (runStep execBuiltin' onComment) p
stack <~ \(h:t) -> (t,[ConstStep h])
return (pref + c)
runStep execBuiltin' onComment (VerbStep s) = getl (dict.at s) >>= \case
Just v -> runVal v
Nothing -> stack =~ (StackSymbol s:)
where runVal (StackBuiltin b) = execBuiltin' b
runVal (StackProg p) = traverse_ (runStep execBuiltin' onComment) p
runVal x = stack =~ (x:)
runStep _ _ (ConstStep v) = stack =~ (v:)
runStep _ onComment (CommentStep c) = onComment c
runStep _ _ (ClosureStep True (StackClosure _ p)) = stack =~ (StackProg p:)
runStep execBuiltin' onComment (ClosureStep _ c) = runClosure execBuiltin' onComment c
data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
| Builtin_Clear | Builtin_Stack
| Builtin_Pick | Builtin_Shift | Builtin_Shaft
......@@ -27,7 +80,7 @@ data StackVal s b a = StackBuiltin (StackBuiltin b)
| StackSymbol s
| StackList [StackVal s b a]
| StackDict (Map s (StackVal s b a))
| StackProg [s]
| StackProg (StackProgram s b a)
| StackExtra (Opaque a)
deriving (Show,Generic)
......@@ -37,8 +90,7 @@ t'StackDict _ x = return x
data StackState st s b a = StackState {
_stack :: [StackVal s b a],
_progStack :: [s],
_depth :: Int,
_progStack :: [StackClosure s b a],
_dict :: Map s (StackVal s b a),
_extraState :: st
}
......@@ -46,20 +98,20 @@ data StackState st s b a = StackState {
stack :: Lens' (StackState st s b a) [StackVal s b a]
stack = lens _stack (\x y -> x { _stack = y })
progStack :: Lens' (StackState st s b a) [s]
progStack :: Lens' (StackState st s b a) [StackClosure s b a]
progStack = lens _progStack (\x y -> x { _progStack = y })
depth :: Lens' (StackState st s b a) Int
depth = lens _depth (\x y -> x { _depth = y })
dict :: Lens' (StackState st s b a) (Map s (StackVal s b a))
dict = lens _dict (\x y -> x { _dict = y })
extraState :: Lens st st' (StackState st s b a) (StackState st' s b a)
extraState = lens _extraState (\x y -> x { _extraState = y })
data AtomClass s = OpenBrace | CloseBrace | Number Int | Quoted s | Comment s | Other s
data AtomClass s = OpenBrace | CloseBrace | OpenSplice | CloseSplice | Number Int | Quoted s | Comment s | Other s
class Ord s => StackSymbol s where atomClass :: s -> AtomClass s
instance StackSymbol String where
atomClass "{" = OpenBrace
atomClass "{@" = OpenSplice
atomClass "}" = CloseBrace
atomClass "@}" = CloseSplice
atomClass ('\'':t) = Quoted t
atomClass ('"':t) = Quoted (init t)
atomClass (':':t) = Comment t
......@@ -68,25 +120,28 @@ instance StackSymbol String where
execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (s -> m ()) -> s -> m ()
execSymbolImpl execBuiltin' onComment atom = do
st <- get
case atomClass atom of
OpenBrace -> do depth =~ (+1) ; when (st^.depth > 0) (progStack =~ (atom:))
CloseBrace -> do
depth =~ subtract 1
if st^.depth == 1 then do
stack =~ (StackProg (reverse $ st^.progStack):)
progStack =- []
else progStack =~ (atom:)
Quoted a | st^.depth==0 -> stack =~ (StackSymbol a:)
Comment a -> onComment a
Number n | st^.depth==0 -> stack =~ (StackInt n:)
_ -> case st^.depth of
0 -> case st^.dict.at atom of
Just v -> exec v
Nothing -> stack =~ (StackSymbol atom:)
_ -> progStack =~ (atom:)
where exec (StackBuiltin b) = execBuiltin' b
exec (StackProg p) = traverse_ (execSymbolImpl execBuiltin' onComment) p
exec x = stack =~ (x:)
case (atomClass atom,st^.progStack) of
(OpenBrace,_) -> progStack =~ (StackClosure [] []:)
(OpenSplice,StackClosure cs p:ps) ->
progStack =- StackClosure [] []:StackClosure ((p,StackClosure [] []):cs) []:ps
(CloseSplice,StackClosure cs p:StackClosure cs' p':ps) ->
progStack =- StackClosure (set (t'1.l'2) (StackClosure (reverse cs) (reverse p)) cs') p':ps
(CloseBrace,StackClosure cs p:ps) -> do
progStack =- ps
let c = StackClosure (reverse cs) (reverse p)
execStep ps (ClosureStep (not $ has (closureSplices .+ (from i'StackClosure.l'1.each.l'2)) c) c)
(CloseBrace,[]) -> unit
(OpenSplice,[]) -> unit
(CloseSplice,_) -> unit
(Quoted a,ps) -> execStep ps (ConstStep (StackSymbol a))
(Comment a,ps) -> execStep ps (CommentStep a)
(Number n,ps) -> execStep ps (ConstStep (StackInt n))
(Other s,ps) -> execStep ps (VerbStep s)
where execStep [] stp = runStep execBuiltin' onComment stp
execStep (StackClosure cs p:ps) stp = progStack =- (StackClosure cs (stp:p):ps)
execBuiltin :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
execBuiltin runExtra onComment = go
......@@ -169,17 +224,18 @@ execBuiltin runExtra onComment = go
StackBuiltin p:t -> do stack =- t ; execVal (StackBuiltin p)
_ -> return ()
go Builtin_Quote = stack =~ \case
StackList l:t -> StackProg [s | StackSymbol s <- l]:t
StackList l:t -> StackProg (map ConstStep l):t
st -> st
go (Builtin_Extra x) = runExtra x
execVal (StackProg p) = traverse_ (execSymbolImpl go onComment) p
execVal (StackProg p) = traverse_ (runStep 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 ()
execProgram :: (b -> m ()) -> (s -> m ()) -> StackProgram s b a -> m ()
runStackState :: State [StackVal s b a] x -> m x
runExtraState :: State st x -> m x
runDictState :: State (Map s (StackVal s b a)) x -> m x
......@@ -189,11 +245,12 @@ newtype ConcatT st b o s m a = ConcatT { _concatT :: StateT (StackState st s b o
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
execProgram x y p = ConcatT $ traverse_ (runStep (execBuiltin (map _concatT x) (map _concatT y)) (map _concatT y)) p
runStackState st = ConcatT $ (\x -> return (swap $ stack (map swap (st^..state)) x))^.stateT
runExtraState st = ConcatT $ (\x -> return (swap $ extraState (map swap (st^..state)) x))^.stateT
runDictState st = ConcatT $ (\x -> return (swap $ dict (map swap (st^..state)) x))^.stateT
defaultState = StackState [] [] 0
defaultState = StackState [] []
concatT :: Iso (ConcatT st b o s m a) (ConcatT st' b' o' s' m' a') (StateT (StackState st s b o) m a) (StateT (StackState st' s' b' o') m' a')
concatT = iso ConcatT (\(ConcatT x) -> x)
......@@ -24,7 +24,11 @@ data COCValue io str = COCExpr (ContextNode str)
| COCConvertible (Maybe (Int,Int))
| COCDir (NodeDir str ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
deriving Generic
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackStep s b a)
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackClosure s b a)
instance (ListSerializable s,ListSerializable b,ListSerializable a) => ListSerializable (StackVal s b a)
instance (IsCapriconString s,ListFormat s,ListFormat b,ListFormat a) => ListFormat (StackStep s b a)
instance (IsCapriconString s,ListFormat s,ListFormat b,ListFormat a) => ListFormat (StackClosure 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)
......@@ -52,7 +56,14 @@ showStackVal toRaw dir ctx = fix $ \go _x -> case _x of
StackInt n -> fromString $ show n
StackList l -> "["+intercalate "," (map go l)+"]"
StackDict d -> "[<"+intercalate "," (map (\(k,v) -> k+": "+go v) (d^.ascList))+">]"
StackProg p -> "{ "+intercalate " " p+" }"
StackProg p ->
let showStep (ConstStep x) = go x
showStep (ClosureStep b c) = fromString (show b)+":"+showClosure c
showStep (VerbStep v) = v
showStep (CommentStep x) = ":"+x
showSteps p' = intercalate " " (map showStep p')
showClosure (StackClosure cs c) = "{ "+intercalate " " (map (\(i,c') -> showSteps i+" "+showClosure c') cs + map showStep c)+" }"
in "{ "+showSteps p+" }"
_ -> fromString $ show _x
data COCBuiltin io str = COCB_Print
| COCB_Open (ReadImpl io str str) | COCB_ExecModule (WriteImpl io str str)
......@@ -155,7 +166,11 @@ modifyCOCEnv (Just (modE,ctx)) = do
runExtraState (context =- ctx)
modifyAllExprs modE
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 :: forall str io m.
(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
......@@ -178,8 +193,10 @@ runCOCBuiltin (COCB_Open (ReadImpl getResource)) = do
s <- runStackState get
case s of
StackSymbol f:t -> do
runStackState $ put t
xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . maybe "" toString
runStackState (put (StackProg xs:t))
let ex = execSymbol runCOCBuiltin outputComment
ex "{" >> traverse_ ex xs >> ex "}"
_ -> return ()
runCOCBuiltin COCB_ToInt = runStackState $ modify $ \case
......@@ -245,7 +262,7 @@ runCOCBuiltin (COCB_ExecModule (WriteImpl writeResource)) = do
StackSymbol f:StackProg p:t -> do
old <- runDictState get
oldH <- runExtraState (outputText <~ \x -> (id,x))
traverse_ (execSymbol runCOCBuiltin outputComment) p
execProgram runCOCBuiltin outputComment p
new <- runDictState (id <~ (old,))
newH <- runExtraState (outputText <~ \x -> (oldH,x))
liftSubIO $ writeResource f (newH "")
......@@ -260,7 +277,7 @@ runCOCBuiltin (COCB_Cache (ReadImpl getResource) (WriteImpl writeResource)) = do
liftSubIO (getResource (f+".blob")) >>= \case
Just res | Just v <- matches Just datum res -> runStackState $ modify $ (v:)
_ -> do
traverse_ (execSymbol runCOCBuiltin outputComment) p
execProgram runCOCBuiltin outputComment p
st' <- runStackState get
case st' of
v:_ -> liftSubIO $ writeResource (f+".blob") (serialize v)
......
'message { format pop } def
'keycallbacks empty def
'key {
dup 2 shaft 1 dupn 2 shaft
"%s %s" format keycallbacks swap { exec pop pop } { swap "Unhandled key: %s %s\n" message } lookup } def
'bind-key { keycallbacks 2 shaft insert 'keycallbacks swap def } def
100 100 window
'components [ [ 'vertexPosition 3 ] [ 'vertexNormal 3 ] [ 'vertexUV 2 ] [ 'vertexColor 4 ] ] def
'vertexColor 0 0 0 0 vcons def
'vertexUV 0 0 0 0 vcons def
'vertexNormal 0 0 0 0 vcons def
'point { 1 vcons [ 1 shaft vertexNormal vertexUV vertexColor ] } def
'rgba { vcons 'vertexColor swap def } def
'rgb { 1 rgba } def
'texpoint { 0 0 vcons 'vertexUV swap def } def
'normal { 0 vcons 'vertexNormal swap def } def
'red { 1 0 0 0.5 rgba } def
'green { 0 1 0 0.5 rgba } def
'blue { 0 0 1 0.5 rgba } def
'white { 1 1 1 rgb } def
'white2 { 1 1 1 0.5 rgba } def
'tile "textures/Gravel-2450.jpg" image def
"tileTexture" uniform tile defuniform
'rgb-triangle
[ blue 1 0 texpoint 1 0 0 point
, red 0 1 texpoint 0 1 0 point
, green 0 0 texpoint 0 0 0 point ]
components 'TRIANGLES mesh def
'rgb-square
[ 0 0 1 normal blue 1 0 texpoint 1 0 0 point
, green 0 1 texpoint 0 1 0 point
, red 0 0 texpoint 0 0 0 point
, green 0 1 texpoint 0 1 0 point
, blue 1 0 texpoint 1 0 0 point
, white 1 1 texpoint 1 1 0 point ]
components 'TRIANGLES mesh def
'cue
[ blue 0 0 0 point 1 0 0 point
, red 0 0 0 point 0 1 0 point
, green 0 0 0 point 0 0 1 point ]
components 'LINES mesh def
'modelMat dup uniform def
modelMat identity defuniform
'=> { modelMat swap [ 2 shaft ] } def
'scene [
10 range {
'i swap def
10 range {
'j swap def
0.125 0.125 0 0 vcons translation , 0.8 scale ,
i j 0 0 vcons translate , 0.2 scale => rgb-square
} each
} each
] def
'refresh { [ 1 1 0 0 vcons translation => cue scene ] draw } def
'dxy vx vx 20 ** vy ++ normalize rotation def
'dyx dxy transpose def
'dyz vy vy 20 ** vz ++ normalize rotation def
'dzy dyz transpose def
'view-xy-angle vx def
'view-zy-angle vz def
'view-trans -1 -1 0 0 vcons translation def
'viewMat dup uniform def , viewMat view-trans defuniform
'projMat dup uniform def
'resize {
identity swap scale , vz negate translate , vx vy vz vz negate mcons **
projMat swap defuniform } def
'set-camera { viewMat view-trans , vx view-xy-angle rotate , vz view-zy-angle rotate defuniform } def
'ctrl false def
"press LEFT" { 'view-xy-angle { dxy ** } modify set-camera refresh } bind-key
"press RIGHT" { 'view-xy-angle { dyx ** } modify set-camera refresh } bind-key
"press UP" { 'view-zy-angle { dyz ** } modify set-camera refresh } bind-key
"press DOWN" { 'view-zy-angle { dzy ** } modify set-camera refresh } bind-key
"press ESC" { quit } bind-key
"press Q" { ctrl { quit } { } if } bind-key
"press LCTRL" { 'ctrl true def } bind-key
"release LCTRL" { 'ctrl false def } bind-key
1 resize refresh
'keep-looping false def
'auto-loop { keep-looping { 'LEFT 'press key 'auto-loop $ 20000 delay } { } if } def
'auto-toggle { 'keep-looping { 1 swap - } modify } def
"press L" { auto-toggle auto-loop } bind-key
#version 330 core
in vec4 fragmentColor;
in vec2 fragmentUV;
uniform sampler2D tileTexture;
void main() {
vec4 texCol = texture(tileTexture,vec2(1) - fragmentUV);
gl_FragColor = vec4((fragmentColor.rgb * fragmentColor.a + texCol.rgb) / (1+fragmentColor.a),texCol.a);
// gl_FragColor = fragmentColor;
}
'printf { format print } def
'show { "%s\n" printf } def
'show-stack { stack { show } each } def
'modify { 1 dupn $ swap exec def } def
', { } def
'seconds { 1000000 * } def
'vx 1 0 0 0 vcons def
'vy 0 1 0 0 vcons def
'vz 0 0 1 0 vcons def
'vw 0 0 0 1 vcons def
'identity vx vy vz vw mcons def
'translate { translation ** } def
'rotate { rotation ** } def
'eject { ejection ** } def
'negate { -1 ** } def
'scale { dup dup 1 vcons skew ** } def
'-- { negate ++ } def
'normalize { dup norm recip ** } def
'if { 2 3 shift pick exec } def
'true 1 def
'false 0 def
Markdown is supported
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