Commit ac8207b6 authored by László Domoszlai's avatar László Domoszlai

"select" statements can encode constant cases besides data constructor cases now

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@359 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent 5e49326a
definition module Sapl.SaplParser
import Sapl.SaplTokenizer, Data.Void, Data.Error
import Sapl.SaplTokenizer, Sapl.SaplStruct
import Data.Void, Data.Error
from Data.Map import :: Map
// Cannot be abstract because code generator uses it
:: ParserState = { ps_level :: Int
, ps_constructors :: Map SaplTerm ConstructorDef
, ps_functions :: Map SaplTerm [SaplTerm]
, ps_CAFs :: Map SaplTerm Void
, ps_constructors :: Map String ConstructorDef
, ps_functions :: Map String [SaplVar]
, ps_CAFs :: Map String Void
}
:: ConstructorDef = { index :: !Int
, singleton :: !Bool
, nr_args :: !Int // for efficiency
, args :: [SaplTerm]
, args :: [SaplVar]
}
/**
* Possible function types and language constructs.
*/
:: FuncType = FTRecord SaplTerm [SaplTerm]
| FTADT SaplTerm [SaplTerm]
| FTCAF SaplTerm SaplTerm
| FTMacro SaplTerm SaplTerm [SaplTerm]
| FTFunc SaplTerm SaplTerm [SaplTerm]
:: SaplTerm = SPattern (Maybe (String, [SaplTerm])) SaplTerm
| SConst Const
| SName String Int
| SStrictName String Int
| SApplication SaplTerm [SaplTerm]
| SCase SaplTerm SaplTerm SaplTerm
| SSelect SaplTerm [SaplTerm]
| SAbortBody
| SLet SaplTerm [SaplTerm]
| SLetDefinition SaplTerm SaplTerm
| SStrictLetDefinition SaplTerm SaplTerm
| SConstructor SaplTerm Int [SaplTerm]
instance == SaplTerm
instance < SaplTerm
instance toString SaplTerm
:: ErrorMsg :== String
/**
......@@ -73,3 +48,4 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
* @return merged parser state
*/
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
implementation module Sapl.SaplParser
import StdEnv, Data.Map, Data.Void, Data.Error
import Sapl.SaplTokenizer
// TODO: finishing it up, so far so good
instance toString SaplTerm
where
toString (SName name _) = name
toString (SStrictName name _) = "!"+++name
instance == SaplTerm
where
(==) (SName name1 _) (SName name2 _) = name1 == name2
(==) (SStrictName name1 _) (SStrictName name2 _) = name1 == name2
(==) _ _ = False
instance < SaplTerm
where
(<) (SName name1 _) (SName name2 _) = name1 < name2
(<) (SStrictName name1 _) (SStrictName name2 _) = name1 < name2
(<) _ _ = False
import Sapl.SaplTokenizer, Sapl.SaplStruct
(>>=) infixl 1
(>>=) f g = \st0 ->
......@@ -38,13 +20,24 @@ mandatory errmsg (Nothing, ts)
incLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level + 1})
decLevel a :== \s -> Ok (a, {s & ps_level = s.ps_level - 1})
getLevel :== \s -> Ok (s.ps_level, s)
addConstructor name args :== \s -> Ok (name, {s & ps_constructors = put name args s.ps_constructors})
addFunction name args :== \s -> Ok (name, {s & ps_functions = put name args s.ps_functions})
addCAF name :== \s -> Ok (name, {s & ps_CAFs = put name Void s.ps_CAFs})
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}
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SName name level), ts)
factor [TConst const:ts] = returnS (Just (SConst const), ts)
addConstructor name def :== \s -> Ok (name, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
addConstructors conses=:[SaplConstructor name idx as]
= \s -> Ok (conses, {s & ps_constructors = put (unpackVar name) def s.ps_constructors})
where
def = {index = idx, singleton = True, nr_args = length as, args = as}
addConstructors conses = \s -> Ok (conses, {s & ps_constructors = foldl adddef s.ps_constructors conses})
where
adddef m (SaplConstructor name idx as)
= put (unpackVar name) {index = idx, singleton = False, nr_args = length as, args = as} m
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] =
application ts
>>= \(t, ts) = case hd ts of
......@@ -58,24 +51,25 @@ application [TOpenParenthesis:ts] =
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
application ts =
factor ts
>>= \(t, ts) = case t of
Just t = returnS (t, ts)
= returnE (ts, "Invalid application")
>>= \(t, ts) = args_factor ts
application [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = args_factor ts
>>= \(as, ts) = case as of
[] = returnS (t, ts) // !!!
[] = returnS (SVar t, ts) // !!!
= returnS (SApplication t as, ts)
selectexpr [TCaseKeyword:ts] =
application [TLit lit:ts] = returnS (SLit lit, ts)
application ts = returnE (ts, "Invalid application")
selectexpr [TIfKeyword:ts] =
arg_adv ts
>>= mandatory "Missing predicate"
>>= \(pred, ts) = arg_adv ts
>>= mandatory "Missing left hand side"
>>= \(lhs, ts) = arg_adv ts
>>= mandatory "Missing right hand side"
>>= \(rhs, ts) = returnS (Just (SCase pred lhs rhs), ts)
>>= \(rhs, ts) = returnS (Just (SIf pred lhs rhs), ts)
selectexpr [TSelectKeyword:ts] =
arg_adv ts
......@@ -97,11 +91,11 @@ where
letdef_1 [TIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SLetDefinition (SName name level) t:as]
>>= \(t, ts) = letdef_2 ts [SaplLetDef (NormalVar name level) t:as]
letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \(t, ts) = letdef_2 ts [SStrictLetDefinition (SName name level) t:as]
>>= \(t, ts) = letdef_2 ts [SaplLetDef (StrictVar name level) t:as]
letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
letdef_2 [TColon: ts] as = letdef_1 ts as
letdef_2 ts as = returnS (reverse as, ts)
......@@ -134,6 +128,14 @@ where
Just r = args` ts [r:as]
= returnS (reverse as, ts)
arg_pattern [TOpenParenthesis:TLit lit:ts] =
case hd ts of
TSelectAssignmentOp = body (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
= returnE (ts, "Missing close parenthesis")
arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
incLevel ts
>>= \ts = args ts
......@@ -141,11 +143,11 @@ arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
TSelectAssignmentOp = body (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (SPattern (mbCons as) t), tl ts)
TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
= returnE (ts, "Missing close parenthesis")
>>= decLevel
where
mbCons as = if (cons=="_") Nothing (Just (cons, as))
mbCons as = if (cons=="_") PDefault (PCons cons as)
arg_pattern ts = returnS (Nothing, ts)
......@@ -159,19 +161,19 @@ arg_adv ts = factor ts
args ts = args_ ts []
where
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [SName name level:as]
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as]
args_ ts as = returnS (reverse as, ts)
args_annotated ts = args_ ts []
where
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [SName name level:as]
args_ [TStrictIdentifier name:ts] as = args_ ts [SStrictName name 0:as]
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as]
args_ [TStrictIdentifier name:ts] as = args_ ts [StrictVar name 0:as]
args_ ts as = returnS (reverse as, ts)
args_record ts = args_1 ts []
where
args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [SName name level:as]
args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [SStrictName name level:as]
args_1 [TIdentifier name:ts] as = getLevel >>= \level = args_2 ts [NormalVar name level:as]
args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [StrictVar name level:as]
args_1 ts as = returnE (ts, "Missing argument")
args_2 [TColon:ts] as = args_1 ts as
args_2 ts as = returnS (reverse as, ts)
......@@ -181,7 +183,7 @@ where
args_1 [TIdentifier name:ts] cs i =
getLevel
>>= \level = args_annotated ts
>>= \(ss,ts) = addConstructor (SName name level) {index = i, nr_args = length ss, args = ss} >>= \tname = args_2 ts [SConstructor tname i ss:cs] i
>>= \(ss,ts) = args_2 ts [SaplConstructor (NormalVar name level) i ss:cs] i
args_1 ts cs _ = returnE (ts, "Missing argument")
args_2 [TVerticalBar:ts] cs i = args_1 ts cs (i+1)
......@@ -192,14 +194,15 @@ constr [TTypeDef, TIdentifier name, TAssignmentOp, TOpenBracket: ts] =
getLevel
>>= \level = args_record ts
>>= \(as, ts) = case hd ts of
TCloseBracket = addConstructor (SName name level) {index = 0, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
TCloseBracket = addConstructor (NormalVar name level) {index = 0, singleton = True, nr_args = length as, args = as} >>= \tname = returnS (FTRecord tname as, tl ts)
= returnE (ts, "Missing close parenthesis3")
// ADT
constr [TTypeDef, TIdentifier name, TAssignmentOp: ts] =
getLevel
>>= \level = args_adt ts
>>= \(as,ts) = returnS (FTADT (SName name level) as, ts)
>>= \(as, ts) = addConstructors as
>>= \_ = returnS (FTADT (NormalVar name level) as, ts)
constr [TTypeDef:ts] = returnE (ts, "Invalid type definition")
constr ts = returnE (ts, "Not a type definition")
......@@ -207,7 +210,7 @@ constr ts = returnE (ts, "Not a type definition")
func [TIdentifier name, TCAFAssignmentOp:ts] =
getLevel
>>= \level = body ts
>>= \(t, ts) = addCAF (SName name level) >>= \tname = returnS (FTCAF tname t, ts)
>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF tname t, ts)
func [TIdentifier name:ts] =
getLevel
......@@ -218,8 +221,8 @@ func [TIdentifier name:ts] =
= returnE (ts, "Missing assignment operator")
>>= \(func, ts) = body ts
>>= \(t, ts) = if func
(addFunction (SName name level) as >>= \tname = returnS (FTFunc tname t as, ts))
(addFunction (SName name level) as >>= \tname = returnS (FTMacro tname t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc tname t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro tname t as, ts))
func ts=:[TTypeDef:_] = constr ts >>= \(f,ts) = returnS (f, ts)
func ts = returnE (ts, "Not a function or type definition")
......
definition module Sapl.SaplStruct
import StdString, StdOverloaded
import Sapl.SaplTokenizer
import Data.Maybe
/**
* Possible function types and language constructs.
*/
:: FuncType = FTRecord SaplVar [SaplVar]
| FTADT SaplVar [SaplConstructor]
| FTCAF SaplVar SaplTerm
| FTMacro SaplVar SaplTerm [SaplVar]
| FTFunc SaplVar SaplTerm [SaplVar]
:: SaplConstructor = SaplConstructor SaplVar Int [SaplVar]
:: SaplTerm = SLit Literal
| SVar SaplVar
| SApplication SaplVar [SaplTerm]
| SIf SaplTerm SaplTerm SaplTerm
| SSelect SaplTerm [(SaplPattern, SaplTerm)]
| SLet SaplTerm [SaplLetDef]
| SAbortBody
:: SaplLetDef = SaplLetDef SaplVar SaplTerm
:: SaplVar = NormalVar String Int
| StrictVar String Int
:: SaplPattern = PCons String [SaplVar]
| PLit Literal
| PDefault
instance == SaplVar
instance < SaplVar
eqStrictVar :: !String !SaplVar -> Bool
isStrictVar :: !SaplVar -> Bool
toNormalVar :: !SaplVar -> SaplVar
toStrictVar :: !SaplVar -> SaplVar
unpackVar :: !SaplVar -> String
unpackBindVar :: !SaplLetDef -> SaplVar
unpackConsName :: !SaplPattern -> Maybe String
isConsPattern :: !SaplPattern -> Bool
implementation module Sapl.SaplStruct
import StdEnv
import Data.Map, Data.Void, Data.Error
instance == SaplVar
where
(==) (NormalVar name1 _) (NormalVar name2 _) = name1 == name2
(==) (StrictVar name1 _) (StrictVar name2 _) = name1 == name2
(==) _ _ = False
instance < SaplVar
where
(<) (NormalVar name1 _) (NormalVar name2 _) = name1 < name2
(<) (StrictVar name1 _) (StrictVar name2 _) = name1 < name2
(<) _ _ = False
isStrictVar :: !SaplVar -> Bool
isStrictVar (StrictVar _ _) = True
isStrictVar _ = False
eqStrictVar :: !String !SaplVar -> Bool
eqStrictVar name1 (StrictVar name2 _) = name1 == name2
eqStrictVar _ _ = False
toNormalVar :: !SaplVar -> SaplVar
toNormalVar (StrictVar name level) = (NormalVar name level)
toNormalVar v = v
toStrictVar :: !SaplVar -> SaplVar
toStrictVar (NormalVar name level) = (StrictVar name level)
toStrictVar v = v
unpackVar :: !SaplVar -> String
unpackVar (NormalVar name _) = name
unpackVar (StrictVar name _) = name
unpackBindVar :: !SaplLetDef -> SaplVar
unpackBindVar (SaplLetDef var _) = var
unpackConsName :: !SaplPattern -> Maybe String
unpackConsName (PCons cons _) = Just cons
unpackConsName _ = Nothing
isConsPattern :: !SaplPattern -> Bool
isConsPattern (PCons _ _) = True
isConsPattern _ = False
......@@ -21,14 +21,14 @@ import StdString, Text.Unicode
| TOpenBracket
| TCloseBracket
| TTypeDef
| TConst Const
| TLit Literal
| TSelectKeyword
| TCaseKeyword
| TIfKeyword
| TLetKeyword
| TInKeyword
| TEndOfLine
instance toString Const
instance toString Literal
instance toString Token
/**
......@@ -39,7 +39,11 @@ instance toString Token
// String and Char constants may contain Clean escape sequences. If the target
// language uses different escaping technique the code generator must replace the
// escape sequences
:: Const = CString UString | CChar UString | CInt Int | CReal Real | CBool Bool
:: Literal = LString UString
| LChar UString
| LInt Int
| LReal Real
| LBool Bool
/**
* Low level function to read a token from a given position of the input string.
......@@ -57,4 +61,5 @@ read_token :: !Int !String -> (!Int, !Int, !Token)
*/
tokens :: !String -> [Token] // used by linker
tokensWithPositions :: !String -> [PosToken] // used by parser
\ No newline at end of file
......@@ -116,10 +116,10 @@ read_token base line
= rnoarg TCloseBracket 1
| matchCharAt '"' line start
# (nextbase,ustr) = read_string_lit '"' (start+1) line
= return (TConst (CString ustr), nextbase)
= return (TLit (LString ustr), nextbase)
| matchCharAt '\'' line start
# (nextbase,ustr) = read_string_lit '\'' (start+1) line
= return (TConst (CChar ustr), nextbase)
= return (TLit (LChar ustr), nextbase)
| matchCharAt '+' line start
= numberToken 1
| matchCharAt '-' line start
......@@ -132,13 +132,12 @@ read_token base line
| otherwise
# stop = skipChars line start not_stopchar
= case tstr stop of
"False" = return (TConst (CBool False), stop)
"false" = return (TConst (CBool False), stop)
"True" = return (TConst (CBool True), stop)
"true" = return (TConst (CBool True), stop)
"False" = return (TLit (LBool False), stop)
"false" = return (TLit (LBool False), stop)
"True" = return (TLit (LBool True), stop)
"true" = return (TLit (LBool True), stop)
"select" = return (TSelectKeyword, stop)
"if" = return (TCaseKeyword, stop)
"case" = return (TCaseKeyword, stop)
"if" = return (TIfKeyword, stop)
"let" = return (TLetKeyword, stop)
"in" = return (TInKeyword, stop)
str = if (str.[0] == '!')
......@@ -155,9 +154,9 @@ where
# fpart = skipChars line (start+p1) isDigit
# (real, stop) = if ((size line) > fpart && line.[fpart] == '.')
(True, skipChars line (fpart+1) isDigit) (False, fpart)
= return (TConst (if real
(CReal (toReal (tstr stop)))
(CInt (toInt (tstr stop)))), stop)
= return (TLit (if real
(LReal (toReal (tstr stop)))
(LInt (toInt (tstr stop)))), stop)
tokensWithPositions :: !String -> [PosToken]
tokensWithPositions inp = tokens_ 1 1 0 []
......@@ -181,14 +180,14 @@ where
True = let (_, newbase, t) = read_token base inp in tokens_ newbase [t:ts]
= reverse ts
instance toString Const
instance toString Literal
where
toString (CString ustr) = "\"" +++ toJSLiteral ustr +++ "\""
toString (CChar uchr) = "'" +++ toJSLiteral uchr +++ "'"
toString (CInt int) = toString int
toString (CReal real) = toString real
toString (CBool True) = "True"
toString (CBool False) = "False"
toString (LString ustr) = "\"" +++ toJSLiteral ustr +++ "\""
toString (LChar uchr) = "'" +++ toJSLiteral uchr +++ "'"
toString (LInt int) = toString int
toString (LReal real) = toString real
toString (LBool True) = "True"
toString (LBool False) = "False"
instance toString Token
where
......@@ -207,9 +206,9 @@ where
toString TOpenBracket = "{"
toString TCloseBracket = "}"
toString TTypeDef = "::"
toString (TConst const) = toString const
toString (TLit lit) = toString lit
toString TSelectKeyword = "select"
toString TCaseKeyword = "if"
toString TIfKeyword = "if"
toString TLetKeyword = "let"
toString TInKeyword = "in"
toString TEndOfLine = "\n"
......@@ -222,4 +221,3 @@ where
ss f = or [is_ss c \\ c <-: f]
is_ss c = not (isAlphanum c || c == '_' || c == '.')
This diff is collapsed.
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