Бегун
Профиль
Группа: Модератор
Сообщений: 6986
Регистрация: 19.4.2002
Где: Нидерланды, Groni ngen
Репутация: 2
Всего: 317
|
Когда то тут было. По началу немного сумбурно, тема была вырезана из другого топа  Лаба из прошлого блока, читает и выполняет FEM - простейший абстрактный функциональный язык (всего три операции). На вкус отвратна (специально без оптимизаций, учили рекурсию и partial application функций), писалась после первых недель знакомства с Haskell, но принцип понять можно | Код | {---------------------------------------------
- FEM language implementation
- Sardar Yumatov (1679848) and others (1609874)
-
- Usage: showw (parseFEMProgram FEM_Code >>= eval)
- Example: showw (parseFEMProgram "foo a bb = a, ((T foo S P)) 5 6 7" >>= eval)
---------------------------------------------}
module FEM where
import List
import Char
type FemGetal = Int -- Fem deals with numbers only
type FemVariabele = String -- Any identifier
type CodePosition = (Int,Int) -- Term position in the source file, can be extended with file name later
-- собсно AST, без лишних классов
---------- Parsed program representation --------------
data FemTerm =
S -- increment, native function
| P -- decrement, native function
| T -- test (if-else), native function
| N FemGetal -- constant (integer) value
| V FemVariabele -- recall variable
| L [FemParsedTerm] -- execute (apply) variable (function)
type FemParsedTerm = (FemTerm, CodePosition) -- term annotated with position in source code
type FemDeclaratie = (FemVariabele, (CodePosition, [FemVariabele], FemParsedTerm)) -- function declaration
type FemProg = ([FemDeclaratie], FemParsedTerm) -- FEM program definition
---------- Token stream (tokenizer) ------------------
data Token = HOpen | HClose | Comma | Equal | Natural FemGetal | Variable String | PToken | TToken | SToken
type TokenStream = [(Token, CodePosition)]
---------- Runtime program representation ------------
data FemRuntimeTerm =
NR FemGetal -- primitive value
| LR CodePosition [FemArgument] [FemParsedTerm] -- dellayed L term
| FR String CodePosition [FemArgument] [FemVariabele] (Either FemParsedTerm FemSystemCallback) -- partially applied function
-- Lookup must not be a stack, the context always consist of top-level functions and current arguments set
type ContextLookup = ([FemDeclaratie], [FemArgument])
type FemArgument = (FemVariabele, FemRuntimeTerm)
-- Native function callback.
type FemSystemCallback = [FemDeclaratie] -> [FemArgument] -> (Result FemRuntimeTerm)
----------------- Error handling -----------------------
-- Result of any evaluation (Maybe like type, extended with error messages)
data Result a = Error String | Success a
-- Allows chaining multiple (a -> Result a) together
instance Monad Result where
Error msg >>= f = Error msg
Success rs >>= f = f rs
Error msg >> _ = Error msg
_ >> Error msg = Error msg
Success a >> Success b = Success b
return = Success
fail msg = Error msg
------------------- Pretty prints --------------------
class Source a where
toSource :: a -> String
instance Show FemTerm where
show a = toSource a
instance Source FemTerm where
toSource S = "S"
toSource P = "P"
toSource T = "T"
toSource (N n) = "N " ++ (show n)
toSource (V str) = "V " ++ str
toSource (L trms) = "(" ++ concat (intersperse " " (map (toSource.fst) trms)) ++ ")"
instance Show Token where
show HOpen = "_(_"
show HClose = "_)_"
show Comma = ", "
show Equal = " = "
show PToken = "p "
show TToken = "t "
show SToken = "s "
show (Natural int) = "@" ++ (show int)
show (Variable str) = "$" ++ str
-- for debugging only
instance Show FemRuntimeTerm where
show (NR n) = "NR " ++ (show n)
show (LR p ctx trms) = "(" ++ concat (intersperse " " (map show trms)) ++ ")"
show (FR nm p args ac func) = "Func: " ++ nm
-- Convert compiled FEM program to source
toSourceProgram :: FemProg -> String
toSourceProgram (xs, (term, q)) = ("(\n\t" ++ (concat (intersperse ",\n\t" (map toSourceDecl xs))) ++ "\n,\n\t" ++ (toSource term))
where toSourceDecl (name, (cp, xs, term)) = (name ++ " " ++ (concat (intersperse " " xs)))
-- Retrive from Result monad
showw :: (Show a) => (Result a) -> String
showw (Success foo) = (show foo)
showw (Error foo) = (show foo)
-- Print term position. Used in error messages.
showPosition (a, b) = "L" ++ (show a) ++ ":C" ++ (show b)
--------------------------- Parser -----------------------------
-- Parse FEM program into an exutable
parseFEMProgram :: String -> Result FemProg
parseFEMProgram code = tokenize code >>= trimBrackets >>= shredTokens >>= parseParts
where parseParts (decl, term) = parseDeclarations ([], decl) >>= parseTerm term
parseTerm term (decls, []) = parseTermStream term >>= assembleProgram decls
assembleProgram decls (term, []) = return (decls, term)
assembleProgram decls (term, (x:strm)) = fail ("Unexpected input after closing ')' at the end of the program: " ++ (show x))
trimBrackets ((HOpen, p):ts) =
case reverse ts of
((HClose,p):tts) -> return (reverse tts)
(tts) -> fail "Global ) at the end of the code is required!"
trimBrackets ts = return ts
-- Split FEM source code to tokens.
-- This function will parse the whole string at once (no lazy evaluation), in return
-- the function will fail correctly if given FEM code contains syntax errors.
tokenize :: String -> Result TokenStream
tokenize src = tryNextToken ([], (0,0), src) >>= returnStream
where returnStream (toks, p, rest) = return toks
tryNextToken (toks, p, []) = return (toks, p, [])
tryNextToken (toks, p, xs) = (nextToken p xs >>= addTok) >>= tryNextToken
where addTok (tok, pp, pn, rest) = return (toks ++ [(tok, pp)], pn, rest)
-- Read next token
nextToken :: CodePosition -> String -> Result (Token, CodePosition, CodePosition, String)
nextToken p@(r,c) (x:xs)
| x == '=' = return (Equal, p, (r, c+1), xs)
| x == '(' = return (HOpen, p, (r, c+1), xs)
| x == ')' = return (HClose, p, (r, c+1), xs)
| x == ',' = return (Comma, p, (r, c+1), xs)
| x == '\n' = nextToken (r+1, 0) xs
| elem x "\t \r" = nextToken (r, c+1) xs
| isAlpha x || isDigit x = tryToken p (break (not.isAlphaNum) (x:xs))
| otherwise = fail ("Not a valid FEM token. Unexpected: " ++ [x])
-- Try to parse a Variable, Natural, P, S or T Token from a String.
tryToken :: CodePosition -> (String, String) -> Result (Token, CodePosition, CodePosition, String)
tryToken p@(r,c) (term, rest)
| term == "p" || term == "P" = return (PToken, p, (r, c+1), rest)
| term == "s" || term == "S" = return (SToken, p, (r, c+1), rest)
| term == "t" || term == "T" = return (TToken, p, (r, c+1), rest)
| all isDigit term = return (Natural (read term), p, (r, c+(length term)), rest)
| isAlpha (head term) = return (Variable term, p, (r, c+(length term)), rest)
| otherwise = fail ("Not a valid number: " ++ term)
-- Split token stream to program declarations and the main term.
shredTokens :: TokenStream -> Result ([TokenStream], TokenStream)
shredTokens (x:xs) = return (decl, term)
where (term:decl) = map reverse (shred (reverse (x:xs)))
shred [] = []
shred ((Comma, p):ts) = shred ts -- so (decl, , , term) is allowed, commas are ignored
shred ts = y : shred ys
where (y, ys) = break isComma ts
isComma (Comma, p) = True
isComma _ = False
-- Parse list of variable declarations
parseDeclarations :: ([FemDeclaratie], [TokenStream]) -> Result ([FemDeclaratie], [TokenStream])
parseDeclarations (dcl, []) = return (dcl, [])
parseDeclarations (dcl, (s:sms)) = parseDeclaration s >>= addDeclaration
where addDeclaration decl = (return (decl:dcl, sms)) >>= parseDeclarations
-- Parse FEM declaration (variable)
parseDeclaration :: TokenStream -> Result FemDeclaratie
parseDeclaration [] = fail "Software bug detected: empty variable declaration. Probably parser's (shredTokens) error!"
parseDeclaration str = possibleBrakets str >>= combineResults
where combineResults ((nm,p), arg, term, []) = return (nm, (p, arg, term))
combineResults ((nm,pp), arg, term, ((t,p):ts)) = fail ((showPosition p) ++ " - Unexpected token after closing ')' of variable declaration: " ++ nm)
possibleBrakets ((HOpen, p):ts) = (parseDecl p ts) >>= expectClose -- consume (
possibleBrakets ((t,p):ts) = parseDecl p ((t,p):ts) -- no brakets variant
expectClose (n,a,t,[(HClose,p)]) = return (n,a,t,[]) -- consume )
expectClose ((n,p),a,t,[]) = fail ((showPosition p) ++ " - Expecting ')' at the end of variable declaration: " ++ n)
expectClose ((n,pp),a,t,((o,p):ts)) = fail ((showPosition p) ++ " - Expecting only ')' at the end of variable declaration: " ++ n)
parseDecl p [] = fail ((showPosition p) ++ " - Expecting variable declaration, but there is no more terms.")
parseDecl p ts = parseName ts >>= parseArguments >>= parseBody
parseName (((Variable nm), p):str) = return ((nm,p), str)
parseName ((t,p):xs) = fail ((showPosition p) ++ " - fuck Expecting variable name, got: " ++ (show t))
parseArguments ((n, p), str) = nextArgument ([], str) >>= combineArg
where combineArg (arg, ts) = return ((n,p), arg, ts)
nextArgument (arg, []) = fail ((showPosition p) ++ " - Expecting body for variable: " ++ n)
nextArgument (arg, (((Variable nm), p):ts)) = (return (arg ++ [nm], ts)) >>= nextArgument
nextArgument (arg, ((Equal, p):ts)) = return (arg, ts)
nextArgument (arg, ((t, pt):ts)) = fail ((showPosition pt) ++ " - Expecting variable name or '=', got: " ++ (show t))
parseBody ((n,p), a, []) = fail ((showPosition p) ++ " - Expecting body (code) for variable: " ++ n)
parseBody (n, a, str) = parseTermStream str >>= returnBody
where returnBody (term, rest) = return (n, a, term, rest)
-- Parse FEM term (program body)
parseTermStream :: TokenStream -> Result (FemParsedTerm, TokenStream)
parseTermStream [] = fail "Software bug detected: no input for parseTermStream!"
parseTermStream str = parseSingleTerm ([], str) >>= optimizeNesting
where optimizeNesting (tt@((t, p):trs), ts) = return (optimizeList (L tt, p), ts)
parseSingleTerm (trms, []) = return (trms, [])
parseSingleTerm (trms, ((Natural n, p):ts)) = return (trms ++ [(N n,p)], ts) >>= parseSingleTerm
parseSingleTerm (trms, ((Variable n, p):ts)) = return (trms ++ [(V n,p)], ts) >>= parseSingleTerm
parseSingleTerm (trms, ((PToken, p):ts)) = return (trms ++ [(P,p)], ts) >>= parseSingleTerm
parseSingleTerm (trms, ((TToken, p):ts)) = return (trms ++ [(T,p)], ts) >>= parseSingleTerm
parseSingleTerm (trms, ((SToken, p):ts)) = return (trms ++ [(S,p)], ts) >>= parseSingleTerm
parseSingleTerm (trms, ((Equal, p):ts)) = fail ((showPosition p) ++ " - Unexpected '=', probably ',' is missing.")
parseSingleTerm (trms, ((HClose, p):ts)) = return (trms, ts)
parseSingleTerm (trms, ((HOpen, p):ts)) = parseSingleTerm ([], ts) >>= addTermList >>= parseSingleTerm
where addTermList (trs, rest) = return (trms ++ [(L trs, p)], rest)
--parseSingleTerm (trms, ((t,p):ts)) = fail ((showPosition p) ++ " - Software bug detected. Unexpected token: " ++ (show t))
optimizeList ((L [x]), q) = (optimizeList x)
optimizeList ((L xs ), q) = ((L (map optimizeList xs)), q)
optimizeList (x, q) = (x, q)
------------------------------------ FEM Runtime --------------------------------------------
-- Evaluate program. The result will be an number or error message.
eval :: FemProg -> Result FemGetal
eval (decl, term) = evaluableTerm (decl, []) term >>= execTerm decl >>= evalTerm
where evalTerm (NR n) = return n
evalTerm (FR n p a ac f) = fail ("Can't execute partially applied function: " ++ n ++ ", expecting arguments: " ++ (concat $intersperse ", " ac))
evalTerm d = fail "Software bug detected: not number nor partial function in evalTerm!"
-- Convert an expression to evaluable object (lazy evaluation).
evaluableTerm::ContextLookup->FemParsedTerm->Result FemRuntimeTerm
evaluableTerm _ (S,p) = return (FR "S" p [] ["arg"] (Right femNative_S)) -- introduce natives
evaluableTerm _ (P,p) = return (FR "P" p [] ["arg"] (Right femNative_P))
evaluableTerm _ (T,p) = return (FR "T" p [] ["arg","true","false"] (Right femNative_T))
evaluableTerm _ ((N n), p) = return (NR n) -- introduce primitive constant
evaluableTerm _ ((L []), p) = fail ((showPosition p) ++ " - Empty group ()")
evaluableTerm (f,a) ((L (t:trms)),p) = return (LR p a (t:trms))
evaluableTerm (f,a) ((V name), p) =
case (lookup name a) of
Just term -> return term -- inject partially applied function
Nothing -> case lookup name f of
(Just (pf, arg, term)) -> return (FR name pf [] arg (Left term)) -- introduce top level function
Nothing -> fail ((showPosition p) ++ " - Variable not found: " ++ name)
{- Execute delayed/lazy term
- Function will terminate with either primitive value or partially applied FEM variable. -}
execTerm::[FemDeclaratie]->FemRuntimeTerm->Result FemRuntimeTerm
execTerm _ d@(NR n) = return d -- primitive value
execTerm flc (LR p alc (lamfunc:args)) = evaluableTerm (flc,alc) lamfunc >>= evaluableLambda args >>= execTerm flc
where evaluableLambda [] r = return r -- L [ single term ] => single term
evaluableLambda (t:ts) (NR n) = fail ((showPosition p) ++ " - Variable with at least one parameter expected, but got primitive: " ++ (show n))
evaluableLambda (t:ts) (FR nm p arg (a:ags) f) = evaluableTerm (flc,alc) t >>= addArgument >>= evaluableLambda ts -- fill in arguments. for partial application the function runs in own context, while arguments are from current context
where addArgument rt = return (FR nm p ((a,rt):arg) ags f)
evaluableLambda (t:ts) trm = execTerm flc trm >>= evaluableLambda (t:ts) -- full FR or L term, evaluate and apply the rest of arguments
execTerm _ d@(FR nm p ctx (a:as) func) = return d -- partially applied function
execTerm flc (FR nm p ctx [] func) = applyFunc func -- until either primitive val or partially applied func
where applyFunc (Left term) =
case evaluableTerm (flc,ctx) term of
Success term -> execTerm flc term
Error msg -> Error (msg ++ "\n" ++ (showPosition p) ++ " - Failed to execute: " ++ nm)
applyFunc (Right term) =
case term flc ctx of
Error msg -> Error (msg ++ "\n - Executed at: " ++ (showPosition p))
Success val -> execTerm flc val -- usually NR n
----------------------- Native bindings -------------------------
-- Increment
femNative_S :: FemSystemCallback
femNative_S lk [(a,t)] = execTerm lk t >>= updateWaarde
where updateWaarde (NR n) = return (NR (n+1)) -- direct execute
updateWaarde d@(FR n p a ac f) = return (FR "<anonymous>" (-1,-1) [] ac (Right (femLambda [] (femNative_S lk) d)))
-- Decrement
femNative_P :: FemSystemCallback
femNative_P lk [(a,t)] = execTerm lk t >>= updateWaarde
where updateWaarde (NR 0) = return (NR 0) -- direct execute
updateWaarde (NR n) = return (NR (n-1))
updateWaarde d@(FR n p a ac f) = return (FR "<anonymous>" (-1,-1) [] ac (Right (femLambda [] (femNative_P lk) d)))
-- Test (not)
femNative_T :: FemSystemCallback
femNative_T lk args = execTerm lk (takejust (lookup "arg" args)) >>= executeT -- executeT (takejust (lookup "arg" args)) --
where executeT (NR 0) = return taakTrue
executeT (NR n) = return taakFalse
executeT d@(FR n p a ac f) = return (FR "<anonymous>" (-1,-1) [] ac (Right (femLambda args (femNative_T lk) d)))
taakTrue = takejust (lookup "true" args)
taakFalse = takejust (lookup "false" args)
takejust (Just n) = n
-- Native lambda, used to wrap native (black-box) functions
femLambda oargs nat (FR n p a ac f) lk args = (return (FR n p (a++args) [] f)) >>= execTerm lk >>= execNative >>= nat
where execNative rt = return ([("arg", rt)] ++ oargs)
|
Это простейший LL(1) парсер-интерпретатор + пара debug функций. Коррктно выводит контекст ошибки (parsing, runtime) и т.п. отсюда много кода. Просто парсер укладывается в пару десятков строк. Кстати пример как реализуются не типичные для чистых декларативных языков последовательные операции посредством монад. --------------------
Опыт - сын ошибок трудных © А. С. Пушкин Процесс написания своего велосипеда повышает профессиональный уровень программиста. © Opik Оценить мои качества можно тут. |
Попытка сравнить C/Java/C#/Python 
Загрузка ...
