Commit 36b12cb3 authored by László Domoszlai's avatar László Domoszlai

- suppress error when an include directory is nor found

- SAPL now has built-in support for Tuples

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@414 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent 55113953
......@@ -45,15 +45,6 @@ generateLoaderState :: ![String] ![String] ![String] !*World -> *(LoaderStateExt
*/
linkByExpr :: !LoaderStateExt !StringAppender !String !*World -> *(!LoaderStateExt, !StringAppender, !String, !*World)
/**
* Remove modules from LoaderState thus exclude them from linking
*
* @param LoaderState
* @param List of modules to exclude from linking
* @return LoaderState
*/
removeModules :: !LoaderStateExt ![String] -> LoaderStateExt
/**
* Extract warnings from loader state
*
......
......@@ -9,14 +9,6 @@ from Data.Set import newSet
import System.FilePath, System.File, System.Directory, Data.Error
from System.OSError import :: MaybeOSError, :: OSError, :: OSErrorMessage, :: OSErrorCode
println :: !String !*World -> *World
println msg world
# (console,world) = stdio world
# console = fwrites msg console
# console = fwrites "\n" console
# (_,world) = fclose console world
= world
// Module name -> file name
:: ModuleMap :== Map String String
......@@ -36,7 +28,10 @@ isDirectory path world
fileList :: !FilePath (FilePath -> Bool) !*World -> *(![FilePath], ![FilePath], !*World)
fileList path ffilter world
# (fs, world) = readDirectory path world
= perFile path (handlerr fs) [] [] world
| isOk fs
= perFile path (fromOk fs) [] [] world
// skip the error if the directory is not exists
= ([],[],world)
where
// basePath, dirlist to process, module list, override module list, world
perFile _ [] ms os world
......@@ -99,20 +94,6 @@ where
// drop filename from module name: Adjoxo;Main
moduleDirs` = (init moduleDirs) ++ [last (split ";" (last moduleDirs))]
/* TODO:
*
* 1. These modules can't be run on the client anyway
* 2. These modules have overrides on the client
* 3. These modules won't be used on the client for sure
*
* ["graph_to_sapl_string","graph_to_string_with_descriptors","sapldebug","_SystemDynamic",
* "dynamic_string", "Base64", ""ClientOverride",
* "LazyLinker", "CodeGeneratorJS"]
*/
removeModules :: !LoaderStateExt ![String] -> LoaderStateExt
removeModules ((mmap, omap, ws, idgen), ftmap, ss) dirs
= ((delList dirs mmap, omap, ws, idgen), ftmap, ss)
getWarnings :: !LoaderStateExt -> [String]
getWarnings ((_, _, ws, _), _, _) = ws
......
......@@ -9,6 +9,7 @@ from Data.Map import :: Map
, ps_constructors :: Map String ConstructorDef
, ps_functions :: Map String [SaplVar]
, ps_CAFs :: Map String Void
, ps_genFuns :: [FuncType] // generated functions during parsing
}
:: ConstructorDef = { index :: !Int
......@@ -44,7 +45,7 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
* to the Map fields of the other structure.
*
* @param first parser state
* @param second parser state
* @param second parser state (supposed to be bigger)
* @return merged parser state
*/
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
......
implementation module Sapl.SaplParser
import StdEnv, Data.Map, Data.Void, Data.Error
import Sapl.SaplTokenizer, Sapl.SaplStruct
import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString
(>>=) infixl 1
(>>=) f g = \st0 ->
......@@ -9,6 +9,9 @@ import Sapl.SaplTokenizer, Sapl.SaplStruct
Ok (r, st1) = g r st1
Error str = Error str
(>>|) infixl 1
(>>|) f g = f >>= \_ -> g
returnS r :== \s -> Ok (r,s)
returnE e :== \s -> Error e
......@@ -22,9 +25,11 @@ decLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level - 1})
getLevel :== \s -> Ok (s.ps_level, s)
addFunction name args :== \s -> Ok (name, {s & ps_functions = put (unpackVar name) args s.ps_functions})
addCAF name :== \s -> Ok (name, {s & ps_CAFs = put (unpackVar name) Void s.ps_CAFs})
defaultState = {ps_level = 0, ps_constructors = newMap, ps_functions = newMap, ps_CAFs = newMap}
defaultState = {ps_level = 0, ps_constructors = newMap, ps_functions = newMap, ps_CAFs = newMap, ps_genFuns = []}
addConstructor name def :== \s -> Ok (name, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
checkConstructor name :== \s -> Ok (isJust (get name s.ps_constructors), s)
addGenFun fun :== \s -> Ok (fun, {s & ps_genFuns = [fun:s.ps_genFuns]})
addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
......@@ -32,6 +37,29 @@ where
adddef m (SaplConstructor name idx as)
= put (unpackVar name) {index = idx, nr_cons = nr_cons, nr_args = length as, args = as} m
// Add Tuple constructor if necessary
addTupleCons name | startsWith "_Tuple" name && size name > 6 =
checkConstructor name
>>= \b = if b (returnS Void) (addConstructor (NormalVar name 0) newdef >>| addGenFun newadt >>| returnS Void)
where
(newadt, newdef) = gendefs name
gendefs name
# idxpart = name % (6, size name)
# (l,r) = case charIndex idxpart 1 '!' of
(True, idx) = (toInt (idxpart % (0,idx-1)), toInt (idxpart % (idx+1,size idxpart)))
(False, _) = (toInt idxpart, 0)
= (genadt l r, genrec l r)
genrec nrargs s = {index = 0, nr_cons = 1, nr_args = nrargs, args = [genarg i s \\ i <- [1..nrargs]]}
genadt nrargs s = FTADT (NormalVar name 0) [SaplConstructor (NormalVar name 0) 0 [genarg i s \\ i <- [1..nrargs]]]
genarg i s | s bitand (1 << (i-1)) > 0
= StrictVar "_" 0
= NormalVar "_" 0
addTupleCons _ = returnS Void
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
factor [TOpenParenthesis:ts] =
......@@ -50,7 +78,8 @@ application [TOpenParenthesis:ts] =
application [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = args_factor ts
>>= \t = addTupleCons name
>>= \_ = args_factor ts
>>= \(as, ts) = case as of
[] = returnS (SVar t, ts) // !!!
= returnS (SApplication t as, ts)
......@@ -134,7 +163,8 @@ arg_pattern [TOpenParenthesis:TLit lit:ts] =
arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
incLevel ts
>>= \ts = args ts
>>= \ts = addTupleCons cons
>>= \_ = args ts
>>= \(as, ts) = case hd ts of
TSelectAssignmentOp = body (tl ts)
= returnE (ts, "Missing select assignment operator")
......@@ -236,7 +266,7 @@ parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts
# ts = map (\(PosToken _ _ t) = t) pts
= case (program ts []) defaultState of
Ok ((fts, _),ps) = Ok (fts,ps)
Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
where
findpos rest_ts
......@@ -259,9 +289,9 @@ where
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
mergeParserStates pst1 (Just pst2)
= {pst1 &
ps_constructors = mergeMaps pst1.ps_constructors pst2.ps_constructors,
ps_functions = mergeMaps pst1.ps_functions pst2.ps_functions,
ps_CAFs = mergeMaps pst1.ps_CAFs pst2.ps_CAFs}
ps_constructors = mergeMaps pst2.ps_constructors pst1.ps_constructors,
ps_functions = mergeMaps pst2.ps_functions pst1.ps_functions,
ps_CAFs = mergeMaps pst2.ps_CAFs pst1.ps_CAFs}
where
mergeMaps m1 m2 = putList (toList m2) m1
......
......@@ -29,22 +29,26 @@ from Sapl.SaplParser import :: ParserState
escapeName :: !String !String !StringAppender -> StringAppender
/**
* Generates JS from Sapl source. Clean flavour.
* Generates JS from Sapl source.
*
* @param Flavour
* @param Trampoline on/off
* @param Sapl source
* @param A global ParserState if any
* @return (JS source / error message, error)
*/
generateJS :: !Flavour !Bool !String -> MaybeErrorString (StringAppender, ParserState)
generateJS :: !Flavour !Bool !String !(Maybe ParserState) -> MaybeErrorString (StringAppender, ParserState)
/**
* Generates JS from Sapl source of sapl expression only
* Generates JS from Sapl source of sapl expression only. It may generate functions as well, what
* is written to the output stream given as the last argument.
*
* @param Flavour
* @param Trampoline on/off
* @param souce of Sapl expression
* @param A global ParserState if any
* @param output stream for the (possibly) generated fucntions
* @return (JS source / error message, error)
*/
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) -> (MaybeErrorString StringAppender)
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) !StringAppender -> (MaybeErrorString (String, StringAppender, ParserState))
......@@ -664,22 +664,27 @@ where
defnames = map unpackBindVar newdefs
generateJS :: !Flavour !Bool !String -> MaybeErrorString (StringAppender, ParserState)
generateJS f tramp saplsrc
generateJS :: !Flavour !Bool !String !(Maybe ParserState) -> MaybeErrorString (StringAppender, ParserState)
generateJS f tramp saplsrc mbPst
# pts = tokensWithPositions saplsrc
= case parse pts of
Ok (funcs, s) # state = newState f tramp s
Ok (funcs, s) # newpst = mergeParserStates s mbPst
# state = newState f tramp newpst
# a = newAppender <++ "/*Trampoline: "
# a = if tramp (a <++ "ON") (a <++ "OFF")
# a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
= Ok (a, s)
= Ok (a, newpst)
Error msg = Error msg
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) -> (MaybeErrorString StringAppender)
exprGenerateJS f tramp saplsrc mbPst
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) !StringAppender -> (MaybeErrorString (String, StringAppender, ParserState))
exprGenerateJS f tramp saplsrc mbPst out
# pts = tokensWithPositions saplsrc
= case parseExpr pts of
Ok (body, s) # state = newState f tramp (mergeParserStates s mbPst)
Ok (body, s) # newpst = mergeParserStates s mbPst
# state = newState f tramp newpst
# a = termCoder body {state & cs_inbody=Just (NormalVar "__dummy" 0)} newAppender
= Ok a
Error msg = Error msg
\ No newline at end of file
# out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
= Ok (toString a, out, newpst)
Error msg = Error msg
\ No newline at end of file
......@@ -143,7 +143,7 @@
"sapl_fun":"string_usize",
"arity":1,
"ext_fun":"_string_usize",
"inline_exp":"[0, '_predefined._Tuple2',:!1:.length,:1:]"
"inline_exp":"[0, '_Tuple2',:!1:.length,:1:]"
},
{
"sapl_fun":"string_select",
......@@ -155,7 +155,7 @@
"sapl_fun":"string_uselect",
"arity":2,
"ext_fun":"_string_uselect",
"inline_exp":"[0, '_predefined._Tuple2',:!1:.charAt(:!2:),:1:]"
"inline_exp":"[0, '_Tuple2',:!1:.charAt(:!2:),:1:]"
},
{
"sapl_fun":"string_create1",
......@@ -300,7 +300,7 @@
"sapl_fun":"array_uselect",
"arity":2,
"ext_fun":"_array_uselect",
"inline_exp":"[0, '_predefined._Tuple2',:!1:[:!2:],:1:]"
"inline_exp":"[0, '_Tuple2',:!1:[:!2:],:1:]"
},
{
"sapl_fun":"array_size",
......@@ -312,7 +312,7 @@
"sapl_fun":"array_usize",
"arity":1,
"ext_fun":"_array_usize",
"inline_exp":"[0, '_predefined._Tuple2',:!1:.length,:1:]"
"inline_exp":"[0, '_Tuple2',:!1:.length,:1:]"
},
{
"sapl_fun":"abort",
......
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