Vous avez reçu un message "Your GitLab account has been locked ..." ? Pas d'inquiétude : lisez cet article https://docs.gricad-pages.univ-grenoble-alpes.fr/help/unlock/

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

Make better backquotes for CaPriCon

The old "{@ ... @}" syntax was a bit clunky, so I looked for a way to
make it more like the Lisp backquotes. That meant re-using the '}'
keyword for closing both quotes, and unquotes.

Since that meant introducing additional state into the interpreter, I
took it as an opportunity to put that information to good use, and
actually start discriminating between "constant" quotes and "exec"
quotes. Indeed, the ",{ ... } exec" pattern seemed to be common enough
that it deserved its own concept. Enter "${ ... }", and the notion of
"exec step".

This new distinction will also allow some rudimentary levels of
"compilation" to be offered to the users, by means of a function that
turns every "verb step" into the "exec step" that corresponds to that
verb's value at the time of linking. It's quite simple, but if it
could eliminate verb lookups from commonly-used functions, it could be
a nice easy performance win.
parent a9059965
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: capricon
version: 0.11
version: 0.12
-- 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.10 && <0.12,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
build-depends: base >=4.8 && <4.10,capricon >=0.10 && <0.13,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
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: array >=0.5 && <0.6,base >=4.8 && <4.10,capricon >=0.10 && <0.12,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,filepath >=1.4 && <1.5,haste-lib
build-depends: array >=0.5 && <0.6,base >=4.8 && <4.10,capricon >=0.10 && <0.13,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,filepath >=1.4 && <1.5,haste-lib
hs-source-dirs: exe
default-language: Haskell2010
-- executable coinche
......
......@@ -27,8 +27,9 @@ instance Monoid JS.JSString where zero = JSS.empty
instance Sequence JS.JSString where splitAt = JSS.splitAt
instance StackSymbol JS.JSString where
atomClass c = case c JSS.! 0 of
'{' | JSS.length c==1 -> OpenBrace
'}' | JSS.length c==1 -> CloseBrace
'{' | JSS.length c==1 -> Open Brace
',' | JSS.length c==2 && c JSS.! 1 == '{' -> Open Splice
'}' | JSS.length c==1 -> Close
'\'' -> Quoted (drop 1 c)
'"' -> Quoted (take (JSS.length c-2) (drop 1 c))
':' -> Comment (drop 1 c)
......@@ -152,7 +153,7 @@ runWordsState ws st = ($st) $ from (stateT.concatT) $^ do
runWithFS :: JS.JSString -> FSIO a -> JS.CIO a
runWithFS fsname (FSIO r) = newFS fsname >>= r^..readerT
hasteDict = cocDict ("0.11-js" :: String) getString getBytes setString setBytes
hasteDict = cocDict ("0.12-js" :: String) getString getBytes setString setBytes
main :: IO ()
main = do
......
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase, DeriveGeneric #-}
module Algebra.Monad.Concatenative(
-- * Extensible stack types
StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackClosure(..),execValue,
StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),ClosureAction(..),StackClosure(..),execValue,
t'StackDict,
-- * The MonadStack class
StackState,defaultState,
MonadStack(..),
AtomClass(..),
BraceKind(..),AtomClass(..),
-- ** A concrete implementation
ConcatT,concatT,Opaque(..)) where
......@@ -17,14 +17,16 @@ 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)
data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | ExecStep (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)
data ClosureAction = CloseConstant | CloseExec
deriving (Show,Generic)
data StackClosure s b a = StackClosure ClosureAction [(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))
i'StackClosure :: Iso' ([(StackProgram s b a,StackClosure s b a)],StackProgram s b a,ClosureAction) (StackClosure s b a)
i'StackClosure = iso (\(cs,c,act) -> StackClosure act cs c) (\(StackClosure act cs c) -> (cs,c,act))
t'ClosureStep :: Traversal' (StackStep s b a) (StackClosure s b a)
t'ClosureStep k (ClosureStep b c) = ClosureStep b<$>k c
......@@ -41,26 +43,26 @@ 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)
(_,p) <- flatten =<< forl closureSplices clos (\c -> flatten c <&> \(act,p) -> StackClosure act [] p)
stack =~ (StackProg p:)
where flatten (StackClosure cs c) = do
pref <- map fold $ for cs $ \(i,StackClosure _ p) -> (i+) <$> do
where flatten (StackClosure act cs c) = do
pref <- map fold $ for cs $ \(i,StackClosure act' _ p) -> (i+) <$> do
traverse_ (runStep execBuiltin' onComment) p
stack <~ \case
(h:t) -> (t,[ConstStep h])
(h:t) -> (t,[case act' of CloseConstant -> ConstStep h ; CloseExec -> ExecStep h])
[] -> ([],[])
return (pref + c)
return (act,pref + c)
runStep execBuiltin' onComment (VerbStep s) = getl (dict.at s) >>= \case
Just v -> runVal v
Just v -> runStep execBuiltin' onComment (ExecStep 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 execBuiltin' onComment (ExecStep (StackProg p)) = traverse_ (runStep execBuiltin' onComment) p
runStep execBuiltin' _ (ExecStep (StackBuiltin b)) = execBuiltin' b
runStep _ _ (ExecStep x) = stack =~ (x:)
runStep _ onComment (CommentStep c) = onComment c
runStep _ _ (ClosureStep True (StackClosure _ p)) = stack =~ (StackProg p:)
runStep _ _ (ClosureStep True (StackClosure _ _ p)) = stack =~ (StackProg p:)
runStep execBuiltin' onComment (ClosureStep _ c) = runClosure execBuiltin' onComment c
data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
......@@ -91,9 +93,10 @@ t'StackDict :: Traversal' (StackVal s b a) (Map s (StackVal s b a))
t'StackDict k (StackDict d) = StackDict <$> k d
t'StackDict _ x = return x
data BraceKind = Brace | Splice ClosureAction
data StackState st s b a = StackState {
_stack :: [StackVal s b a],
_progStack :: [StackClosure s b a],
_progStack :: [(BraceKind,StackClosure s b a)],
_dict :: Map s (StackVal s b a),
_extraState :: st
}
......@@ -101,20 +104,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) [StackClosure s b a]
progStack :: Lens' (StackState st s b a) [(BraceKind,StackClosure s b a)]
progStack = lens _progStack (\x y -> x { _progStack = 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 | OpenSplice | CloseSplice | Number Int | Quoted s | Comment s | Other s
data AtomClass s = Close | Open BraceKind | 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 "{" = Open Brace
atomClass ",{" = Open (Splice CloseConstant)
atomClass "${" = Open (Splice CloseExec)
atomClass "}" = Close
atomClass ('\'':t) = Quoted t
atomClass ('"':t) = Quoted (init t)
atomClass (':':t) = Comment t
......@@ -124,27 +127,26 @@ execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackB
execSymbolImpl execBuiltin' onComment atom = do
st <- get
case (atomClass atom,st^.progStack) of
(OpenBrace,_) -> progStack =~ (StackClosure [] []:)
(OpenSplice,StackClosure cs p:ps) ->
progStack =- StackClosure [] []:StackClosure ((reverse 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
(Open Brace,_) -> progStack =~ ((Brace,StackClosure CloseExec [] []):)
(Open s@(Splice act),(k,StackClosure act' cs p):ps) ->
progStack =- (s,StackClosure act [] []):(k,StackClosure act' ((reverse p,StackClosure act [] []):cs) []):ps
(Open (Splice _),[]) -> unit
(Close,(Splice _,StackClosure act cs p):(k,StackClosure act' cs' p'):ps) ->
progStack =- (k,StackClosure act' (set (t'1.l'2) (StackClosure act (reverse cs) (reverse p)) cs') p'):ps
(CloseBrace,StackClosure cs p:ps) -> do
(Close,(Brace,StackClosure act cs p):ps) -> do
progStack =- ps
let c = StackClosure (reverse cs) (reverse p)
let c = StackClosure act (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
(Close,_) -> 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)
execStep ((k,StackClosure act cs p):ps) stp = progStack =- ((k,StackClosure act cs (stp:p)):ps)
execBuiltinImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
execBuiltinImpl runExtra onComment = go
......
......@@ -27,6 +27,7 @@ data COCValue io str = COCExpr (ContextNode str (COCAxiom str))
| COCAlgebraic (Algebraic str)
| COCDir (NodeDir str (COCAxiom str) ([str],StackVal str (COCBuiltin io str) (COCValue io str)))
deriving Generic
instance ListSerializable ClosureAction ; instance ListFormat ClosureAction
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)
......@@ -62,11 +63,14 @@ showStackVal toRaw dir ctx = fix $ \go _x -> case _x of
StackDict d -> "[<"+intercalate "," (map (\(k,v) -> k+": "+go v) (d^.ascList))+">]"
StackProg p ->
let showStep (ConstStep x) = go x
showStep (ExecStep 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)+" }"
showClosure (StackClosure act cs c) =
(case act of CloseExec -> "$" ; _ -> ",")
+"{ "+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_Quit
......
......@@ -19,7 +19,7 @@ library
default-language: Haskell2010
executable logos
build-depends: base >=4.9 && <4.10,capricon >=0.10 && <0.12,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,GLFW >=0.5 && <0.6,hreadline >=0.2 && <0.3,JuicyPixels >=3.2 && <3.3,logos >=0.1 && <0.2,OpenGL >=3.0 && <3.1,StateVar >=1.1 && <1.2,vector >=0.12 && <0.13
build-depends: base >=4.9 && <4.10,capricon >=0.10 && <0.13,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2,GLFW >=0.5 && <0.6,hreadline >=0.2 && <0.3,JuicyPixels >=3.2 && <3.3,logos >=0.1 && <0.2,OpenGL >=3.0 && <3.1,StateVar >=1.1 && <1.2,vector >=0.12 && <0.13
default-extensions: TypeSynonymInstances, NoMonomorphismRestriction, StandaloneDeriving, GeneralizedNewtypeDeriving, TypeOperators, RebindableSyntax, FlexibleInstances, FlexibleContexts, FunctionalDependencies, TupleSections, MultiParamTypeClasses, Rank2Types, AllowAmbiguousTypes, RoleAnnotations, ViewPatterns, LambdaCase
hs-source-dirs: exe
ghc-options: -threaded
......
......@@ -3,7 +3,7 @@ IFSBAK="$IFS"
declare -A PKGS
while read pkg ver; do
PKGS[$pkg]="$ver"
done < <(stack ls dependencies)
done < <(stack ls dependencies "$@")
for file in */*.cabal; do
while IFS= read line; do
case "$line" in
......
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