Форум программистов [Powered by Invision Power Board]

Код
{---------------------------------------------
 - 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)