Commit 5ab843be authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Implement the 'showExpr' builtin for macro debugging purposes

parent 7bbc63aa
...@@ -423,7 +423,7 @@ data Builtin = B_Undefined ...@@ -423,7 +423,7 @@ data Builtin = B_Undefined
| B_Relocatable Bool Hash [(Bytes,BinaryRelocation)] Bytes | B_Relocatable Bool Hash [(Bytes,BinaryRelocation)] Bytes
| B_RawIndex Int | B_RawIndex Int
| B_ShowExpr | B_ShowInd | B_ShowExpr | B_ShowSyntax
deriving (Eq,Ord,Show,Generic) deriving (Eq,Ord,Show,Generic)
instance Documented Builtin where instance Documented Builtin where
document = Pure . show' document = Pure . show'
......
...@@ -394,16 +394,25 @@ libSymbol _ (GlobalID _ (Just (i,lid))) = findLib lid >>= \l -> l^.flLibrary.sym ...@@ -394,16 +394,25 @@ libSymbol _ (GlobalID _ (Just (i,lid))) = findLib lid >>= \l -> l^.flLibrary.sym
builtinsLib :: FileLibrary builtinsLib :: FileLibrary
builtinsLib = rawLibrary False blib (serialize blib) Nothing builtinsLib = rawLibrary False blib (serialize blib) Nothing
where where
blib = blib_5 blib = blib_6
blib_6 = blib_5 & defSym ["syntax"] "showExpr" (mkBLeaf "showExpr" B_ShowExpr showExprDoc)
. defSym ["syntax"] "showSyntax" (mkBLeaf "showSyntax" B_ShowSyntax showSyntaxDoc)
. setMeta ["version"] "0.5.3"
where showSyntaxDoc = ""; showExprDoc = ""
blib_5 = blib_4 & setMeta ["name"] "curly-builtins" blib_5 = blib_4 & setMeta ["name"] "curly-builtins"
blib_4 = blib_3 & setMeta ["author","email"] "marc.coiffier@curly-lang.org" blib_4 = blib_3 & setMeta ["author","email"] "marc.coiffier@curly-lang.org"
blib_3 = blib_2 & set (sym ["string"] "showInt".leafDoc) (mkDoc "leafDoc" showIntDoc) blib_3 = blib_2 & set (sym ["string"] "showInt".leafDoc) (mkDoc "leafDoc" showIntDoc)
where showIntDoc = "{section {title Show Number} {p Produces a string representation of its argument}}" where showIntDoc = "{section {title Show Number} {p Produces a string representation of its argument}}"
blib_2 = blib_1 & setMeta ["author","email"] "marc.coiffier@curly-lang.net" blib_2 = blib_1 & setMeta ["author","email"] "marc.coiffier@curly-lang.net"
blib_1 = blib_0 & setMeta ["version"] "0.5.2" blib_1 = blib_0 & setMeta ["version"] "0.5.2"
defSym p s (i,v) = set (symbols.at s) (Just v) . set (exports.atMs (p+[s])) (Pure (i,v))
sym :: [String] -> String -> FixFold' Library (LeafExpr GlobalID)
sym p s = (symbols.at s.t'Just .+ exports.atMs (p + [s]).t'Pure.l'2) sym p s = (symbols.at s.t'Just .+ exports.atMs (p + [s]).t'Pure.l'2)
setMeta (h:t) v = metadata.from i'Metadata.at h.l'Just zero.at t %- Just (Pure v) setMeta (h:t) v = metadata.from i'Metadata.at h.l'Just zero.at t %- Just (Pure v)
setMeta [] _ = id setMeta [] _ = id
undefBuiltin = (pureIdent "undefined",undefLeaf "The 'undefined' builtin")
mkBLeaf n b d = (pureIdent n,undefLeaf "" & leafVal %- mkSymbol (pureIdent n,Pure (Builtin (builtinType b) b)) & leafDoc %- mkDoc "leafDoc" d)
blib_0 = zero blib_0 = zero
& set symbols (fromAList [(foldl' (flip const) ph pt,v) | (ph:pt,(_,v)) <- allBuiltins]) & set symbols (fromAList [(foldl' (flip const) ph pt,v) | (ph:pt,(_,v)) <- allBuiltins])
. set exports builtinsMod . set exports builtinsMod
...@@ -414,7 +423,7 @@ builtinsLib = rawLibrary False blib (serialize blib) Nothing ...@@ -414,7 +423,7 @@ builtinsLib = rawLibrary False blib (serialize blib) Nothing
,(["version"],Pure "0.5.1")] ,(["version"],Pure "0.5.1")]
builtinsMod = fromPList (map2 Pure allBuiltins) builtinsMod = fromPList (map2 Pure allBuiltins)
allBuiltins = [ allBuiltins = [
(["undefined"],(pureIdent "undefined",undefLeaf "The 'undefined' builtin")), (["undefined"],undefBuiltin),
(["seq"],mkBLeaf "seq" B_Seq seqDoc), (["seq"],mkBLeaf "seq" B_Seq seqDoc),
(["unit"],mkBLeaf "unit" B_Unit unitDoc), (["unit"],mkBLeaf "unit" B_Unit unitDoc),
(["file","open"],mkBLeaf "open" B_Open openDoc), (["file","open"],mkBLeaf "open" B_Open openDoc),
...@@ -445,99 +454,99 @@ builtinsLib = rawLibrary False blib (serialize blib) Nothing ...@@ -445,99 +454,99 @@ builtinsLib = rawLibrary False blib (serialize blib) Nothing
(["syntax","mkExprSym"],mkBLeaf "mkExprSym" B_ExprSym mkExprSymDoc), (["syntax","mkExprSym"],mkBLeaf "mkExprSym" B_ExprSym mkExprSymDoc),
(["syntax","exprInd"],mkBLeaf "exprInd" B_ExprInd exprIndDoc) (["syntax","exprInd"],mkBLeaf "exprInd" B_ExprInd exprIndDoc)
] ]
where mkBLeaf n b d = (pureIdent n,undefLeaf "" & leafVal %- mkSymbol (pureIdent n,Pure (Builtin (builtinType b) b)) & leafDoc %- mkDoc "leafDoc" d) where seqDoc = unlines [
seqDoc = unlines [ "{section {title Sequence Expressions}",
"{section {title Sequence Expressions}", " {p {em Usage:} seq x y}",
" {p {em Usage:} seq x y}", " {p Evaluates its two arguments in order.}}"
" {p Evaluates its two arguments in order.}}" ]
] unitDoc = unlines [
unitDoc = unlines [ "{section {title The Unit value}",
"{section {title The Unit value}", " {p Useful as a placeholder where values are irrelevant}}"
" {p Useful as a placeholder where values are irrelevant}}" ]
] openDoc = unlines [
openDoc = unlines [ "{section {title Open File}",
"{section {title Open File}", "{p {em Usage:} open name \\{file: ...\\}}",
"{p {em Usage:} open name \\{file: ...\\}}", "{p Opens a file and passes the file descriptor to the continuation in the second argument}}"
"{p Opens a file and passes the file descriptor to the continuation in the second argument}}" ]
] readDoc = unlines [
readDoc = unlines [ "{section {title Read From File}",
"{section {title Read From File}", "{p {em Usage:} read file n \\{str: ...\\}}",
"{p {em Usage:} read file n \\{str: ...\\}}", "{p Reads a number of bytes from the given file and passes the resulting string to the continuation.}}"
"{p Reads a number of bytes from the given file and passes the resulting string to the continuation.}}" ]
] writeDoc = unlines [
writeDoc = unlines [ "{section {title Write To File}",
"{section {title Write To File}", "{p {em Usage:} write file str}",
"{p {em Usage:} write file str}", "{p Writes the given bytes to the given file.}}"
"{p Writes the given bytes to the given file.}}" ]
] closeDoc = unlines [
closeDoc = unlines [ "{section {title Close File}",
"{section {title Close File}", "{p {em Usage:} close file}",
"{p {em Usage:} close file}", "{p Closes a file.}}"
"{p Closes a file.}}" ]
] stdoutDoc = unlines [
stdoutDoc = unlines [ "{section {title The Standard Output Descriptor}",
"{section {title The Standard Output Descriptor}", " {p You can pass this to the 'write' function to",
" {p You can pass this to the 'write' function to", " print a message to the screen}}"
" print a message to the screen}}" ]
] stdinDoc = unlines [
stdinDoc = unlines [ "{section {title The Standard Input Descriptor}",
"{section {title The Standard Input Descriptor}", " {p You can pass this to the 'read' function to",
" {p You can pass this to the 'read' function to", " retrieve user-written text.}}"
" retrieve user-written text.}}" ]
] addIntDoc = unlines [
addIntDoc = unlines [ "{section {title Add Integers}",
"{section {title Add Integers}", "{p {em Usage:} addInt a b}",
"{p {em Usage:} addInt a b}", "{p Adds two integers.}}"
"{p Adds two integers.}}" ]
] subIntDoc = unlines [
subIntDoc = unlines [ "{section {title Subtract Integers}",
"{section {title Subtract Integers}", "{p {em Usage:} subInt a b}",
"{p {em Usage:} subInt a b}", "{p Subtracts two integers.}}"
"{p Subtracts two integers.}}" ]
] mulIntDoc = unlines [
mulIntDoc = unlines [ "{section {title Multiply Integers}",
"{section {title Multiply Integers}", "{p {em Usage:} mulInt a b}",
"{p {em Usage:} mulInt a b}", "{p Multiplies two integers.}}"
"{p Multiplies two integers.}}" ]
] divIntDoc = unlines [
divIntDoc = unlines [ "{section {title Divide Integers}",
"{section {title Divide Integers}", "{p {em Usage:} divInt a b}",
"{p {em Usage:} divInt a b}", "{p Divides two integers.}}"
"{p Divides two integers.}}" ]
] cmpInt_ltDoc = unlines [
cmpInt_ltDoc = unlines [ "{section {title Compare Integers (lower than)}",
"{section {title Compare Integers (lower than)}", "{p {em Usage:} cmpInt n m x y}",
"{p {em Usage:} cmpInt n m x y}", "{p Returns x when n<m, and y otherwise.}}"
"{p Returns x when n<m, and y otherwise.}}" ]
] cmpInt_eqDoc = unlines [
cmpInt_eqDoc = unlines [ "{section {title Compare Integers (equality)}",
"{section {title Compare Integers (equality)}", "{p {em Usage:} cmpInt n m x y}",
"{p {em Usage:} cmpInt n m x y}", "{p Returns x when n=m, and y otherwise.}}"
"{p Returns x when n=m, and y otherwise.}}" ]
] addStringDoc = unlines [
addStringDoc = unlines [ "{section {title Add Strings}",
"{section {title Add Strings}", "{p {em Usage:} addString a b}",
"{p {em Usage:} addString a b}", "{p Adds two strings.}}"
"{p Adds two strings.}}" ]
] stringLengthDoc = unlines [
stringLengthDoc = unlines [ "{section {title String Length}",
"{section {title String Length}", "{p {em Usage:} stringLength s}",
"{p {em Usage:} stringLength s}", "{p Gets the length of a string.}}"
"{p Gets the length of a string.}}" ]
] showIntDoc = "{section {title Show Number} Produces a string representation of its argument}"
showIntDoc = "{section {title Show Number} Produces a string representation of its argument}" mkArrayDoc = "{section {title Make Array} {p Usage: mkArray n {i: ...}} {p Creates an array of size n, populated by calling the given function on every index from 0 to n-1}}"
mkArrayDoc = "{section {title Make Array} {p Usage: mkArray n {i: ...}} {p Creates an array of size n, populated by calling the given function on every index from 0 to n-1}}" arrayLengthDoc = "{section {title Get Array Length} {p Gets the length of an array.}}"
arrayLengthDoc = "{section {title Get Array Length} {p Gets the length of an array.}}" arrayAtDoc = "{section {title Get Array Element} {p Usage: arrayAt arr i} {p Gets the element at index i in the array arr}}"
arrayAtDoc = "{section {title Get Array Element} {p Usage: arrayAt arr i} {p Gets the element at index i in the array arr}}" arraySetDoc = "{section {title Set Array Element} {p Usage: arraySet arr i x k} {p Sets the element at index i, then evaluate k}}"
arraySetDoc = "{section {title Set Array Element} {p Usage: arraySet arr i x k} {p Sets the element at index i, then evaluate k}}" mkSyntaxNodeDoc = ""
mkSyntaxNodeDoc = "" mkSyntaxSymDoc = ""
mkSyntaxSymDoc = "" mkSyntaxExprDoc = ""
mkSyntaxExprDoc = "" syntaxIndDoc = ""
syntaxIndDoc = "" mkExprLambdaDoc = ""
mkExprLambdaDoc = "" mkExprApplyDoc = ""
mkExprApplyDoc = "" mkExprSymDoc = ""
mkExprSymDoc = "" exprIndDoc = ""
exprIndDoc = ""
type Template = Documentation type Template = Documentation
defaultTemplate :: Template defaultTemplate :: Template
...@@ -571,8 +580,8 @@ availableLibs :: IO [(LibraryID,Metadata)] ...@@ -571,8 +580,8 @@ availableLibs :: IO [(LibraryID,Metadata)]
availableLibs = do availableLibs = do
conn <- readIORef libraryVCS conn <- readIORef libraryVCS
ks <- getKeyStore ks <- getKeyStore
allLibs <- for (ks^.ascList) $ \(kn,(_,k,_,m,_)) -> forkValue $ do allLibs <- for (ks^.ascList) $ \(kn,(_,k,_,meta,_)) -> forkValue $ do
case m^.from i'Metadata.at "branches" of case meta^.from i'Metadata.at "branches" of
Just (Join bs) -> do Just (Join bs) -> do
let branches = [b | (b,m) <- bs^.ascList, lookup ["follow"] m == Just (Pure "true")] let branches = [b | (b,m) <- bs^.ascList, lookup ["follow"] m == Just (Pure "true")]
for branches $ \b -> forkValue $ do for branches $ \b -> forkValue $ do
......
...@@ -4,7 +4,7 @@ module Curly.Core.Security( ...@@ -4,7 +4,7 @@ module Curly.Core.Security(
Access(..),PrivateKey,PublicKey,SharedSecret,KeyFingerprint,Signature,Signed, Access(..),PrivateKey,PublicKey,SharedSecret,KeyFingerprint,Signature,Signed,
genPrivateKey,publicKey,fingerprint,sharedSecret,signBytes,isValidSignatureFrom,signValue,extractSignedBy,unsafeExtractSigned, genPrivateKey,publicKey,fingerprint,sharedSecret,signBytes,isValidSignatureFrom,signValue,extractSignedBy,unsafeExtractSigned,
-- * Encryption/Decryption -- * Encryption/Decryption
decrypt,encrypt, decrypt,encrypt,signedDatum,
-- * Environment -- * Environment
KeyStore,curlyKeysFile,getKeyStore,modifyKeyStore, KeyStore,curlyKeysFile,getKeyStore,modifyKeyStore,
-- * Showing and reading formats -- * Showing and reading formats
...@@ -148,7 +148,7 @@ extractSignedBy pub (Signed a s) | isValidSignatureFrom pub s (serialize a) = Ju ...@@ -148,7 +148,7 @@ extractSignedBy pub (Signed a s) | isValidSignatureFrom pub s (serialize a) = Ju
signValue :: (MonadIO m,Serializable Bytes a) => PrivateKey -> a -> m (Signed a) signValue :: (MonadIO m,Serializable Bytes a) => PrivateKey -> a -> m (Signed a)
signValue priv a = Signed a <$> signBytes priv (serialize a) signValue priv a = Signed a <$> signBytes priv (serialize a)
signedDatum :: Format Bytes a => PublicKey -> Parser Bytes (Signed a) signedDatum :: Format Bytes a => PublicKey -> Parser Bytes a
signedDatum pub = datum >>= maybe zero return . extractSignedBy pub signedDatum pub = datum >>= maybe zero return . extractSignedBy pub
timingRef :: IORef Seconds timingRef :: IORef Seconds
...@@ -228,7 +228,7 @@ modifyKeyStore m = seq identities $ liftIO $ while $ trylog (threadDelay 1000 >> ...@@ -228,7 +228,7 @@ modifyKeyStore m = seq identities $ liftIO $ while $ trylog (threadDelay 1000 >>
ks' = m ks ks' = m ks
newFile = serialize ks' newFile = serialize ks'
runKeyState (put ks') runKeyState (put ks')
logLine Debug $ "New store : "+show (map (\(f,pub,_,m,ac) -> (f,pub,m,ac)) ks')+" {{"+show newFile+"}}" logLine Debug $ "New store : "+show (map (\(f,pub,_,meta,ac) -> (f,pub,meta,ac)) ks')+" {{"+show newFile+"}}"
newFile `deepseq` return () newFile `deepseq` return ()
logLine Debug "New key store ready for write" logLine Debug "New key store ready for write"
hSeek h AbsoluteSeek 0 hSeek h AbsoluteSeek 0
......
...@@ -541,6 +541,11 @@ builtinType b = (zero :: Type s) & i'typeRel %~ case b of ...@@ -541,6 +541,11 @@ builtinType b = (zero :: Type s) & i'typeRel %~ case b of
. ln [Out,In,Out,Out] [Out,Out,Out,In,Out] poly . ln [Out,In,Out,Out] [Out,Out,Out,In,Out] poly
. ln [Out,In,Out,Out] [Out,Out,Out,Out] poly . ln [Out,In,Out,Out] [Out,Out,Out,Out] poly
B_ShowExpr -> ln' [] (exprT --> poly --> poly)
. ln [Out,In] [Out,Out] poly
B_ShowSyntax -> ln' [] (synT --> poly --> poly)
. ln [Out,In] [Out,Out] poly
B_Relocatable _ _ _ _ -> ln' [] intT B_Relocatable _ _ _ _ -> ln' [] intT
B_RawIndex _ -> ln' [] (intT --> intT) B_RawIndex _ -> ln' [] (intT --> intT)
where where
......
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