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 6255b2d5 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Upend the CaPriCon rendering pipeline, to allow for multiple output backends...

Upend the CaPriCon rendering pipeline, to allow for multiple output backends (for now, HTML and LaTeX)
parent 6d0b2858
......@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: capricon
version: 0.12.3
version: 0.13
-- 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.13,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
build-depends: base >=4.8 && <4.10,capricon >=0.13 && <0.14,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 capricon-engine.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.13,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.14,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
......
......@@ -45,7 +45,7 @@ main = do
str <- stringWords <$> if isTerm then getAll else readHString stdin
args <- (foldMap (\x -> [libdir</>x,x]) <$> getArgs) >>= map (stringWords . fold) . traverse (try (return []) . readString)
execS (foldr (\sym mr -> do
execSymbol runCOCBuiltin outputComment sym
execSymbol runCOCBuiltin outputComment (atomClass sym)
(hasQuit,out) <- runExtraState (liftA2 (,) (getl endState) (getl outputText) <* (outputText =- id))
d <- runDictState get
lift (writeIORef symList (keys d))
......
......@@ -154,7 +154,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.12.3-js" :: String) getString getBytes setString setBytes
hasteDict = cocDict ("0.13-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(..),ClosureAction(..),StackClosure(..),execValue,
StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackComment(..),ClosureAction(..),StackClosure(..),execValue,
t'StackDict,
-- * The MonadStack class
StackState,defaultState,
......@@ -17,7 +17,14 @@ 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) | ExecStep (StackVal s b a) | CommentStep s | ClosureStep Bool (StackClosure s b a)
data StackComment s = TextComment s
| BeginCodeParagraph Int s [s]
| EndCodeParagraph
| BeginCodeSpan s
| EndCodeSpan s
deriving (Show,Generic)
data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | ExecStep (StackVal s b a) | CommentStep (StackComment s) | ClosureStep Bool (StackClosure s b a)
deriving (Show,Generic)
data ClosureAction = CloseConstant | CloseExec
deriving (Show,Generic)
......@@ -120,7 +127,7 @@ 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 = Close | Open BraceKind | Number Int | Quoted s | Comment s | Other s
data AtomClass s = Close | Open BraceKind | Number Int | Quoted s | Comment (StackComment s) | Other s
class Ord s => StackSymbol s where atomClass :: s -> AtomClass s
instance StackSymbol String where
atomClass "{" = Open Brace
......@@ -129,13 +136,13 @@ instance StackSymbol String where
atomClass "}" = Close
atomClass ('\'':t) = Quoted t
atomClass ('"':t) = Quoted (init t)
atomClass (':':t) = Comment t
atomClass (':':t) = Comment (TextComment t)
atomClass x = maybe (Other x) Number (matches Just readable x)
execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (s -> m ()) -> s -> m ()
execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (StackComment s -> m ()) -> AtomClass s -> m ()
execSymbolImpl execBuiltin' onComment atom = do
st <- get
case (atomClass atom,st^.progStack) of
case (atom,st^.progStack) of
(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
......@@ -157,7 +164,7 @@ execSymbolImpl execBuiltin' onComment atom = do
where execStep [] stp = runStep execBuiltin' onComment stp
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 :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (StackComment s -> m ()) -> StackBuiltin b -> m ()
execBuiltinImpl runExtra onComment = go
where
go Builtin_Def = get >>= \st -> case st^.stack of
......@@ -257,9 +264,9 @@ execBuiltinImpl runExtra onComment = go
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 ()
execBuiltin :: (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
execSymbol :: (b -> m ()) -> (StackComment s -> m ()) -> AtomClass s -> m ()
execProgram :: (b -> m ()) -> (StackComment s -> m ()) -> StackProgram s b a -> m ()
execBuiltin :: (b -> m ()) -> (StackComment s -> m ()) -> StackBuiltin b -> 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
......
......@@ -38,6 +38,8 @@ instance (ListSerializable b) => ListSerializable (StackBuiltin b)
instance (ListFormat b) => ListFormat (StackBuiltin b)
instance (ListSerializable a) => ListSerializable (Opaque a)
instance (ListFormat a) => ListFormat (Opaque a)
instance (ListSerializable s) => ListSerializable (StackComment s)
instance (ListFormat s) => ListFormat (StackComment s)
instance ListSerializable str => ListSerializable (COCValue io str)
instance (IsCapriconString str,ListFormat str,IOListFormat io str) => ListFormat (COCValue io str)
......@@ -66,7 +68,8 @@ showStackVal toRaw dir ctx = fix $ \go _x -> case _x of
showStep (ExecStep x) = "$("+go x+")"
showStep (ClosureStep b c) = fromString (show b)+":"+showClosure c
showStep (VerbStep v) = v
showStep (CommentStep x) = ":"+x
showStep (CommentStep (TextComment x)) = ":"+x
showStep (CommentStep c) = ":<"+fromString (show c)+">"
showSteps p' = intercalate " " (map showStep p')
showClosure (StackClosure act cs c) =
(case act of CloseExec -> "$" ; _ -> ",")
......@@ -91,7 +94,7 @@ data COCBuiltin io str = COCB_Print | COCB_Quit
| COCB_ContextVars
| COCB_GetShowDir | COCB_SetShowDir | COCB_InsertNodeDir
| COCB_Format
| COCB_Format | COCB_Render
deriving (Show,Generic)
data ReadImpl io str bytes = ReadImpl (str -> io (String :+: bytes))
......@@ -133,26 +136,24 @@ stringWordsAndSpaces unquoteStrings = map (second fromString) . fromBlank id . t
| otherwise = fromWChar (k.(c:)) t
fromWChar k "" = [(True,k "")]
literate :: forall str. IsCapriconString str => Parser String [str]
literate = liftA2 (\pref r -> pref + [":s"+fromString r])
(intercalate [":s\n"] <$> sepBy' (cmdline "> " ">? " <+? cmdline "$> " "$>? " <+? commentline) (single '\n'))
literate :: forall str. IsCapriconString str => Parser String [StackComment str :+: str]
literate = liftA2 (\pref r -> pref + [Left (TextComment $ fromString r)])
(intercalate [Left (TextComment "\n")] <$> sepBy' (cmdline "> " ">? " <+? cmdline "$> " "$>? " <+? commentline) (single '\n'))
remaining
where
wrapResult :: Bool -> [str] -> [str]
wrapResult isParagraph l = case isParagraph of
True -> ":p[":l+[":p]"]
False -> ":s[":l+[":s]"]
cmdline :: Parser String () -> Parser String () -> Parser String [str]
cmdline :: Parser String () -> Parser String () -> Parser String [StackComment str :+: str]
cmdline pre pre_ex = do
indent <- many' (oneOf [' ','\t'])
map (\(x,exs) -> [":s"+fromString indent
,":cp["+fromString (show (length x,if nonempty exs then True else False)),":cp="+intercalate "\n" (map fst x)]
+ (if nonempty exs then ":x[":[":x="+ex | ex <- exs]+[":x]"] else [])
+ (":cp]":wrapResult True (foldMap snd x)))
map (\(x,exs) -> [Left (TextComment $ fromString indent)
,Left (BeginCodeParagraph (length x) (intercalate "\n" (map fst x)) exs)]
+ map Right (foldMap snd x)
+ [Left EndCodeParagraph])
((,) <$> sepBy1' go (single '\n') <*> option' [] ("\n" >> sepBy1' go_ex (single '\n')))
where go = do pre; many' (noneOf ['\n']) <&> \x -> (fromString x,map fromString (stringWords x+["steps."]))
go_ex = do pre_ex; many' (noneOf ['\n']) <&> fromString
commentline = map (foldMap (pure . (":s"+) <|> \(x,t) -> ":s[":t+[":cs"+x,":s]" :: str])) $ (<* lookingAt eol)
where go = do pre; many' (noneOf ['\n']) <&> \x -> (fromString x,map fromString (stringWords x+["eol."]))
go_ex = do pre_ex; many' (noneOf ['\n']) <&> fromString
commentline :: Parser String [StackComment str :+: str]
commentline = map (foldMap (pure . (Left . TextComment) <|>
\(x,t) -> Left (BeginCodeSpan x):map Right t+[Left (EndCodeSpan x)])) $ (<* lookingAt eol)
$ many' (map (Left . fromString) (many1' (noneOf ['{','\n'] <+?
(fill '{' $ single '{' <* lookingAt (noneOf ['{']))))
<+? map Right (between "{{" "}}"
......@@ -215,6 +216,8 @@ runCOCBuiltin COCB_Axiom = runStackState $ modify $ \case
runCOCBuiltin COCB_Format = do
ex <- runExtraState get
let format ('%':'s':s) (StackSymbol h:t) = first (h+) (format s t)
format ('%':'a':s) (StackSymbol h:t) = first (htmlQuote h+) (format s t)
format ('%':'n':s) (StackSymbol h:t) = first (markSyntax h+) (format s t)
format ('%':'v':s) (x:t) = first (showStackVal doc2raw (ex^.showDir) (ex^.context) x+) (format s t)
format ('%':'g':s) (x:t) = first (showStackVal doc2svg (ex^.showDir) (ex^.context) x+) (format s t)
format ('%':'l':s) (x:t) = first (showStackVal doc2latex (ex^.showDir) (ex^.context) x+) (format s t)
......@@ -230,8 +233,8 @@ runCOCBuiltin (COCB_Open (ReadImpl getResource)) = do
StackSymbol f:t -> do
runStackState $ put t
xs <- liftSubIO (getResource (f+".md")) >>= maybe undefined return . matches Just literate . (const "" <|> toString)
let ex = execSymbol runCOCBuiltin outputComment
ex "{" >> traverse_ ex xs >> ex "}"
let ex = execSymbol runCOCBuiltin outputComment . (Comment <|> atomClass)
ex (Right "{") >> traverse_ ex xs >> ex (Right "}")
_ -> return ()
runCOCBuiltin COCB_ToInt = runStackState $ modify $ \case
......@@ -420,6 +423,23 @@ runCOCBuiltin COCB_InsertNodeDir = do
StackCOC (COCDir (insert e (map fst (takeLast d ctx),x) dir)):t
st -> st
runCOCBuiltin COCB_Render = runStackState $ modify $ \case
StackProg p:st -> StackProg (foldMap renderStep p):st
st -> st
where renderStep (VerbStep v) = [VerbStep v]
renderStep (ExecStep x) = [ExecStep x]
renderStep (ConstStep c) = [ConstStep c]
renderStep (CommentStep c) = renderComment c
renderStep (ClosureStep closed cl) = [ClosureStep closed (renderClos cl)]
renderClos (StackClosure act ps pt) = StackClosure act [(foldMap renderStep p,renderClos cl)
| (p,cl) <- ps] (foldMap renderStep pt)
renderComment (TextComment s) = [ConstStep (StackSymbol s), VerbStep "comment"]
renderComment (BeginCodeParagraph l code exs) = [ConstStep (StackInt l),ConstStep (StackSymbol code),ConstStep (StackList (map StackSymbol exs)), VerbStep "begin-code-paragraph"]
renderComment EndCodeParagraph = [VerbStep "end-code-paragraph"]
renderComment (BeginCodeSpan s) = [ConstStep (StackSymbol s),VerbStep "begin-code-span"]
renderComment (EndCodeSpan s) = [ConstStep (StackSymbol s),VerbStep "end-code-span"]
cocDict :: forall io str. IsCapriconString str => str -> (str -> io (String :+: str)) -> (str -> io (String :+: [Word8])) -> (str -> str -> io ()) -> (str -> [Word8] -> io ()) -> COCDict io str
cocDict version getResource getBResource writeResource writeBResource =
mkDict ((".",StackProg []):("steps.",StackProg []):("mustache.",StackProg []):("version",StackSymbol version):
......@@ -444,6 +464,7 @@ cocDict version getResource getBResource writeResource writeBResource =
("swap" , Builtin_Swap ),
("swapn" , Builtin_SwapN ),
("pick" , Builtin_Pick ),
("pre-render" , Builtin_Extra COCB_Render ),
("[" , Builtin_ListBegin ),
("]" , Builtin_ListEnd ),
......@@ -507,60 +528,15 @@ cocDict version getResource getBResource writeResource writeBResource =
atP (h,[]) = at h
atP (h,x:t) = at h.l'Just (StackDict zero).t'StackDict.atP (x,t)
outputComment c = (runExtraState $ do outputText =~ (\o t -> o (commentText+t)))
where commentText = case toString c of
'x':'=':_ -> let qcode = htmlQuote (drop 2 c) in
"<button class=\"capricon-example\" data-code=\""+qcode+"\"><pre class=\"capricon\">"+markSyntax (drop 2 c)+"</pre></button>"
'c':'p':'[':n ->
let (nlines,hasExamples) = read n :: (Int,Bool)
in wrapStart True nlines hasExamples+"<div class=\"capricon-steps\">"
+"<pre class=\"capricon capricon-paragraph capricon-context\">"
'c':'p':'=':_ -> markSyntax (drop 3 c)+"</pre>"
'c':'p':']':[] -> "<div class=\"user-input interactive\">"
+"<button class=\"capricon-trigger\">Try It Out</button>"
+"<label class=\"capricon-input-prefix\">&gt;&nbsp;<input type=\"text\" class=\"capricon-input\" /></label>"
+"<pre class=\"capricon-output\"></pre></div>"
+"</div>"+wrapEnd
's':'[':[] -> wrapStart False 1 False
'c':'s':_ -> "</span><input type=\"checkbox\"/>"+
"<span class=\"expand-then\"><code class=\"capricon capricon-steps\">"+htmlQuote (drop 2 c)+"</code>"
's':']':[] -> wrapEnd
p:'[':[] -> "<"+codeTag p+codeAttrs p+">"
p:']':[] -> "</"+codeTag p+">"
's':_ -> drop 1 c
_ -> ""
codeTag 'p' = "div"
codeTag 's' = "span"
codeTag 'x' = "div"
codeTag _ = ""
codeAttrs 'p' = " class=\"capricon-paragraphresult\""
codeAttrs 's' = " class=\"capricon-result\""
codeAttrs 'x' = " class=\"capricon-examples\""
codeAttrs _ = ""
markSyntax str = fold [if isWord then
let qw = htmlQuote w
withSpans | w=="{" = \x -> "<span class=\"quote quote-brace\">"+x
| w==",{" = \x -> "<span class=\"quote quote-splice\">"+x
| w=="${" = \x -> "<span class=\"quote quote-exec\">"+x
| w=="}" = \x -> x+"</span>"
| otherwise = \x -> x
in withSpans ("<span class=\"symbol\" data-symbol-name=\""+qw+"\">"+qw+"</span>")
else w
| (isWord,w) <- stringWordsAndSpaces False str]
wrapStart isP nlines hasExamples =
let hide = if isP then "box" else "inline"
in "<label class=\"expansible "+hide+"\">"+
if isP then
"<input type=\"checkbox\" checked=\"checked\"/>"+
"<span class=\"expand-else capricon-show\"></span>"+
"<span class=\"expand-then capricon-hide\"></span>"+
"<span class=\"expand-then"+(if hasExamples then " capricon-with-examples" else "")+"\" style=\"--num-lines: "
+ fromString (show (1.25 + (if hasExamples then 1.25 else 0) + fromIntegral nlines :: Float))+"\">"
else
"<span>"
wrapEnd = "</span></label>"
outputComment c = execProgram runCOCBuiltin (\_ -> unit) (renderComment c)
markSyntax str = fold [if isWord then
let qw = htmlQuote w
withSpans | w=="{" = \x -> "<span class=\"quote quote-brace\">"+x
| w==",{" = \x -> "<span class=\"quote quote-splice\">"+x
| w=="${" = \x -> "<span class=\"quote quote-exec\">"+x
| w=="}" = \x -> x+"</span>"
| otherwise = \x -> x
in withSpans ("<span class=\"symbol\" data-symbol-name=\""+qw+"\">"+qw+"</span>")
else w
| (isWord,w) <- stringWordsAndSpaces False str]
......@@ -430,7 +430,7 @@ main = between (void GLFW.initialize) GLFW.terminate $ do
let go = while $ do
ws <- liftIO (readChan wordChan)
(traverse_ (execSymbol runLogos (\_ -> unit)) <|> execProgram runLogos (\_ -> unit)) ws
(traverse_ (execSymbol runLogos (\_ -> unit) . atomClass) <|> execProgram runLogos (\_ -> unit)) ws
runDictState get >>= \d -> liftIO (writeIORef symList (keys d))
runExtraState $ getl running
......
......@@ -19,7 +19,7 @@ library
default-language: Haskell2010
executable logos
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
build-depends: base >=4.9 && <4.10,capricon >=0.10 && <0.14,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
......
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