@@ -11,7 +11,7 @@ module Wy.Foundation ) where foundationText = unlines [ - "#{f.split("\n").map { |l| l.gsub('"', '\"') }.join("\",\n \"")}"] + "#{f.split("\n").map { |l| l.gsub("\\", "\\\\\\").gsub('"', '\"') }.join("\",\n \"")}"] EOS File.open('build/foundation.hs', 'w') { |f| f << cnt } haskell/inline.rb @@ -1,10 +1,113 @@ +def(module, name, body, + primitive('module') +) + +def(import, name, + primitive('import') +) + module(Foundation, + def(macrop, exp, priority, body, + primitive('macrop') + ) + + def(lambda, parameters\, body, + primitive('lambda') + ) - // A few macros defining macros to get started + def(`, expr, + primitive('`') + ) + macrop(macro(`exp, `body), 10, `(macrop($exp, 10, $body))); macro(macrox(`exp, `body), `(macrop($exp, 10, `($body)))); macro(macropx(`exp, `priority, `body), `(macrop($exp, $priority, `($body)))); + // Expressions inspection + // + + def(applic?, expression, + primitive('applic?') + ) + + def(fnName, expression, + primitive('fnName') + ) + + def(params, expression, + primitive('params') + ) + + def(nthParam, expression, idx, + primitive('nthParam') + ) + + def(defined?, expression, + primitive('defined?') + ) + + def(empty?, expression, + primitive('applic?') + ) + + // Comparison and arithmetic operators + // + def(==, lexpr, rexpr, + primitive('==') + ) + + def(!=, lexpr, rexpr, + primitive('!=') + ) + + def(<, lexpr, rexpr, + primitive('<') + ) + + def(>, lexpr, rexpr, + primitive('>') + ) + + def(<=, lexpr, rexpr, + primitive('<=') + ) + + def(>=, lexpr, rexpr, + primitive('>=') + ) + + def(!, lexpr, rexpr, + primitive('!') + ) + + def(&&, lexpr, rexpr, + primitive('&&') + ) + + def(||, lexpr, rexpr, + primitive('||') + ) + + def(=, name, value, + primitive('=') + ) + + def(+, lexpr, rexpr, + primitive('+') + ) + + def(-, lexpr, rexpr, + primitive('-') + ) + + def(*, lexpr, rexpr, + primitive('*') + ) + + def(/, lexpr, rexpr, + primitive('/') + ) + // Arithmetic operators macrop(`a = `b, 1, if(applic?(a), @@ -15,11 +118,10 @@ module(Foundation, ) macropx(`a += `b, 1, $a = $a + $b); macropx(`a -= `b, 1, $a = $a - $b); - macropx(`a << `b, 1, <<($a, $b)); - macropx(`a >> `b, 1, >>($a, $b)); macropx(`a || `b, 2, ||($a, $b)); macropx(`a && `b, 3, &&($a, $b)); macropx(`a == `b, 4, ==($a, $b)); + macropx(`a != `b, 4, !=($a, $b)); macropx(`a <= `b, 5, <=($a, $b)); macropx(`a >= `b, 5, >=($a, $b)); macropx(`a < `b, 5, <($a, $b)); @@ -41,6 +143,10 @@ module(Foundation, ) ) + def(::, elmt, list, + primitive('::') + ) + // Access to module definitions from outside macro(`mod :: `def, if(applic?(def), @@ -52,25 +158,102 @@ module(Foundation, ) ) - macrox(unless(`cond, `body), if(!($cond), $body)) + // Control structures + // - foldl1 = lambda(fn, arr, foldl(fn, head(arr), tail(arr))) + def(if, cond, body, contra, + primitive('if') + ) + + macrox(unless(`cond, `body, `contra?), if(!($cond), $body, $contra)) + + def(foldr, fn, init, list, + primitive('foldr') + ) + foldr1 = lambda(fn, arr, foldr(fn, head(arr), tail(arr))) + def(foldl, fn, init, list, + primitive('foldl') + ) + + foldl1 = lambda(fn, arr, foldl(fn, head(arr), tail(arr))) + map = lambda(fn, arr, foldr(lambda(x, ys, [fn(x)] + ys), [], arr)) for = lambda(arr, l, foldl(lambda(acc, x, l(x)), null, arr) ) + def(callcc, fn, + primitive('callcc') + ) + + // Error handling + // + UnknownRef = { type: 'UnknownRef' } ArgumentError = { type: 'ArgumentError' } SysError = [UnknownRef, ArgumentError] + def(try, body, catches\, + primitive('try') + ) + + def(raise, err, + primitive('raise') + ) + macrox(catch(`err, `var?, `body?), [$err, lambda($var, $body)]) + + // Data structures + + def(L, elmts\, + primitive('L') + ) + + def(@, list, elmt, + primitive('@') + ) + + def(<<, list, elmt, + primitive('<<') + ) + macropx(`a << `b, 1, <<($a, $b)); + + def(>>, elmt, list, + primitive('>>') + ) + macropx(`a >> `b, 1, >>($a, $b)); + + def(@!, ref, val, + primitive('@!') + ) + + def(push!, list, val, + primitive('push!') + ) + + def(length, l, + primitive('length') + ) + head = lambda(a, a.0) + tail = lambda(a, slice(a, 1)) + def(toS, elmt, + primitive('toS') + ) + + def(slice, list, start, end, + primitive('slice') + ) + + def(reverse, l, + primitive('reverse') + ) + join = lambda(arr, sep?, foldl1( lambda(a, b, @@ -92,6 +275,20 @@ module(Foundation, ) ) ) + + // IO + + def(print, elmts\, + primitive('print') + ) + + def(load, f, + primitive('load') + ) + + def(arguments, + primitive(arguments) + ) ) import(Foundation) haskell/src/foundation.wy @@ -1,5 +1,5 @@ module Wy.Prim - ( primitives + ( defWy ) where import Control.Monad(liftM, liftM2, foldM) @@ -19,6 +19,20 @@ import Wy.Parser(ASTType(..), parseWy) import Wy.Interpr import Wy.Types +-- Main definition function, used to import all primitives in the running +-- environment. + +defWy ps = do + env <- ask + case last ps of + (ASTStmt [ASTApplic (ASTId n) [ASTString primName]]) | n == "primitive" -> do + defName <- extractId $ head ps + case M.lookup primName $ primitives M.empty of + Nothing -> throwError $ ArgumentErr ("Unknown primitive referenced in def: " ++ primName) + Just x -> liftIO $ varUpdate env defName x + x -> do params <- mapM extractId $ init ps + return $ WyLambda params (last ps) env + primitives f = arithmPrim $ basePrim $ dataPrim $ packagePrim $ metaPrim $ stdIOPrim f basePrim f = @@ -131,6 +145,7 @@ arithmPrim f = defp "/" (opEvalM wyDiv) $ defp "!" (\ps -> liftM (WyBool . not . truthy) (eval $ ps !! 0)) $ defp "==" (opEval $ boolComp (==)) $ + defp "!=" (opEval $ boolComp (/=)) $ defp "<=" (opEval $ boolComp (<=)) $ defp ">=" (opEval $ boolComp (>=)) $ defp "<" (opEval $ boolComp (<)) $ @@ -333,10 +348,6 @@ stdIOPrim f = defp n l = M.insert n (WyPrimitive n l) -extractId (ASTId i) = return i -extractId (ASTStmt [ASTId i]) = return i -extractId x = throwError $ ArgumentErr $ "Non identifier value when one was expected: " ++ (show x) - extractName (ASTId i) = return i extractName (ASTStmt [ASTId i]) = return i extractName (ASTString s) = return s haskell/src/prim.hs @@ -36,10 +36,12 @@ mhead [] = Nothing mhead (x:xs) = Just x main = do params <- getArgs - p <- newIORef $ primitives M.empty - m <- newIORef M.empty + p <- newIORef $ M.insert "def" (WyPrimitive "def" defWy) M.empty + m <- newIORef M.empty let blankEnv = S.empty |> Frame p m False - env <- liftM snd $ wyInterpr blankEnv "foundation" foundationText + e <- wyInterpr blankEnv "foundation" foundationText + either (putStrLn . show) (showWy >=> putStrLn) $ fst e + let env = snd e case mhead params of Just x -> do cnt <- readFile x e <- wyInterpr env x cnt haskell/src/repl.hs @@ -6,7 +6,8 @@ module Wy.Types ( ASTType(..), WyError(..), - WyType(..), readRef, mapReadRef, newWyRef, truthy, wyToAST, showWy, macroPivot, + WyType(..), readRef, mapReadRef, newWyRef, truthy, wyToAST, showWy, macroPivot, + extractId, wyPlus, wyMinus, wyDiv, wyMult, WyEnv, Frame(..), macroValue, varValue, macroUpdate, varUpdate, envStack, envAdd, envAddMod, Eval, localM, localIO, runEval, appErr1, appErr2 @@ -154,6 +155,10 @@ instance Ord (IORef WyType) where wyToAST (WyTemplate t) = t wyToAST x = ASTWyWrapper x +extractId (ASTId i) = return i +extractId (ASTStmt [ASTId i]) = return i +extractId x = throwError $ ArgumentErr $ "Non identifier value when one was expected: " ++ (show x) + -- Environment definition -- haskell/src/types.hs 52046ef92e7e93976db38a1e22de796402c9e9d2 Matthieu Riou mriou@apache.org http://github.com/matthieu/witty/commit/b65e6ee6f95c470ba416d65ec2c2077ef512a501 b65e6ee6f95c470ba416d65ec2c2077ef512a501 2009-02-27T22:26:06-08:00 2009-02-27T22:26:06-08:00 The whole witty library in a single file, less than 300 lines. eb21dd11ef91abb9e7583b39e2c45d7bcb1b833d Matthieu Riou mriou@apache.org