@@ -32,7 +32,5 @@ updateFile updFn ps = do liftIO $ updFn f cnt return WyNull -defp n l = M.insert n (WyPrimitive n l) - asString (WyString s) = return s asString x = get >>= appErr1 (\y -> "A string was expected, got " ++ y) x haskell/src/fileio.hs @@ -85,15 +85,15 @@ module Foundation ( // Accepts either a string or a symbol. Returns true if it corresponds // to a known binding in the current environment, false otherwise. - def defined? expression ( + def defined? expr ( primitive 'defined?' ) - def empty? expression ( + def empty? expr ( primitive 'empty?' ) - def isa? expression ( + def isa? expr1 expr2 ( primitive 'isa?' ) @@ -124,7 +124,7 @@ module Foundation ( primitive '>=' ) - def (!) lexpr rexpr ( + def (!) expr ( primitive '!' ) @@ -144,7 +144,7 @@ module Foundation ( primitive '+' ) - def (-) lexpr rexpr ( + def (-) lexpr? rexpr ( primitive '-' ) @@ -212,7 +212,7 @@ module Foundation ( macro (`appl ^ `sub~) ( if (applic? appl) ( - `( ($ (wyId (fnName appl))) ($^ (params appl << sub )) ) + `( ($ (wyId (fnName appl))) ($^ (params appl << sub)) ) )( `( ($appl) ($^ [sub]) ) ) @@ -221,7 +221,7 @@ module Foundation ( // Control structures // - def if cond body contra ( + def if cond body contra? ( primitive 'if' ) @@ -291,7 +291,7 @@ module Foundation ( ) macropx (`a >> `b) 1 ((>>) $a $b) - def (@!) ref val ( + def (@!) ref pos val ( primitive '@!' ) @@ -311,7 +311,7 @@ module Foundation ( primitive 'toS' ) - def slice list start end ( + def slice list start end? ( primitive 'slice' ) haskell/src/foundation.wy @@ -13,6 +13,7 @@ import Control.Monad.State import Data.Foldable(foldrM) import Text.ParserCombinators.Parsec(parse) +import qualified Data.Sequence as S import qualified Data.Map as M import Data.IORef(newIORef, readIORef) import qualified Data.Traversable as T @@ -48,45 +49,65 @@ evalWy (WyId idn pos) | otherwise = do Nothing -> throwError $ UnknownRef ("Unknown reference: " ++ idn) pos Just v -> return v -evalWy (WyApplic fn ps pos) = put pos >> eval fn >>= apply ps +evalWy wa@(WyApplic fn vals pos) = put pos >> do + efn <- eval fn + let ps = params efn + case adjust WyNull WyList ps vals $ length vals - (fst $ unslurps ps) of + Nothing -> paramErr ps vals + Just adjv -> if (length adjv == length ps) + -- normal application + then apply adjv vals efn + -- partial application + else let rmndr = drop (length adjv) ps + newps = vals ++ map (flip WyId pos) rmndr + in return $ WyLambda rmndr (WyApplic fn newps pos) S.empty + where + params (WyLambda ps _ _) = ps + params (WyPrimitive _ ps _) = ps + params (WyCont _) = ["c"] --- evalWy (WyStmt xs) = liftM last $ applyMacros xs >>= (\x -> trace (show x) (return x)) >>= mapM evalWy evalWy (WyStmt xs) = liftM last $ applyMacros xs >>= mapM evalWy evalWy (WyBlock xs) = liftM last $ mapM evalWy xs +evalWy wy = get >>= appErr1 (\x -> "Don't know how to eval: " ++ x) wy eval ast = evalWy ast >>= liftIO . readRef -- Function application, either primitive or lambdas -apply:: [WyType] -> WyType -> Eval WyType -apply vals (WyPrimitive n fn) = fn vals -apply vals wl@(WyLambda _ _ _) = mapM evalWy vals >>= applyDirect wl -apply vals (WyCont c) = liftM head (mapM evalWy vals) >>= c -apply ps other = get >>= appErr1 (\x -> "Don't know how to apply: " ++ x ++ " " ++ show ps) other +apply:: [WyType] -> [WyType] -> WyType -> Eval WyType + +apply adjv vals (WyPrimitive n _ fn) = fn vals -- TODO primitives should use adjusted parameters +apply adjv vals wl@(WyLambda _ _ _) = mapM evalWy adjv >>= applyDirect wl +apply adjv vals (WyCont c) = liftM head (mapM evalWy vals) >>= c +apply _ vals other = get >>= appErr1 (\x -> "Don't know how to apply: " ++ x ++ " " ++ show vals) other -- Application of lambdas from argument list and evaluated values -applyDirect (WyLambda ps body lenv) vals = - localM (const $ buildFrame ps vals lenv) $ evalWy body - where - buildFrame ps vs e = - case adjust WyNull WyList ps vs $ length vs - (fst $ unslurps ps) of - Nothing -> get >>= appErr1 (\x -> "Wrong number of arguments in function call: " ++ x ++ " for " ++ show ps) (WyList vs) - Just adjV -> liftIO $ envStack (snd $ unslurps ps) adjV e + +applyDirect wl@(WyLambda ps body lenv) vals = + let buildFrame ps vs e = liftIO $ envStack (snd $ unslurps ps) vs e + in localM (const $ buildFrame ps vals lenv) $ evalWy body + +paramErr ps vs = get >>= + appErr ("Wrong number of arguments in function call: " ++ + (show . length $ vs) ++ " for " ++ (show . length $ ps)) -- Adjusts the values provided for an application to a function's arguments. Handles -- optionals and varargs. Needs a zero to set missing optionals value and a list -- wrapper function to wrap varargs. adjust :: a -> ([a] -> a) -> [String] -> [a] -> Int -> Maybe [a] + adjust z l (p:ps) (v:vs) dif | last p == '?' && dif <= 0 = liftM (z :) $ adjust z l ps (v:vs) dif | last p == '?' && dif > 0 = liftM (v :) $ adjust z l ps vs (dif - 1) - | last p == '~' && dif >= 0 = + | last p == '~' && dif > 0 = let s = slurp (v:vs) dif in liftM (l s :) $ adjust z l ps (drop (length s - 1) vs) (dif - length s) + | last p == '~' && dif <= 0 = liftM (l [] :) $ adjust z l ps (v:vs) dif | otherwise = liftM (v :) $ adjust z l ps vs dif adjust z l (p:ps) [] dif | last p == '?' && dif <= 0 || last p == '~' && dif == 0 = liftM (z :) $ adjust z l ps [] dif adjust z l [] [] dif | dif == 0 = Just [] +adjust z l (p:ps) [] dif | dif < 0 = Just [] adjust z l _ _ x = Nothing -- Consumes values matched to a vararg haskell/src/interpr.hs @@ -28,13 +28,13 @@ import Wy.FileIO defWy ps = do env <- ask defName <- extractId $ head ps + params <- mapM extractId . tail . init $ ps case last ps of (WyStmt [WyApplic (WyId n _) [WyString primName] pos]) | n == "primitive" -> do case M.lookup primName $ primitives M.empty of Nothing -> throwError $ ArgumentErr ("Unknown primitive referenced in def: " ++ primName) pos - Just x -> liftIO $ varUpdate env defName x - x -> do params <- mapM extractId $ tail $ init ps - let wl = WyLambda params (last ps) env + Just x -> liftIO $ varUpdate env defName (toPrimitive x params) + x -> do let wl = WyLambda params (last ps) env liftIO $ varInsert defName wl env return wl @@ -87,10 +87,11 @@ basePrim f = fn <- liftIO $ varValue fnNm env fstP <- evalWy . head $ tail ps lstP <- astList fstP + let lps = (fstP : (tail . tail) ps) case fn of Just f -> case lstP of - Just l -> apply l f - Nothing -> apply (fstP : (tail . tail) ps) f + Just l -> apply l l f + Nothing -> apply lps lps f Nothing -> get >>= (appErr $ "Unknown function: " ++ fnNm) ) $ defp "try" (\ps -> @@ -167,12 +168,15 @@ basePrim f = v <- liftIO . readRef $ M.findWithDefault WyNull (WyString "type") m if (v == WyString errstr) then liftM Just $ applyDirect (last xs) - [WyMap $ - M.insert (WyString "source") (WyString $ wySrcFile pos) $ - M.insert (WyString "line") (WyInt $ wySrcLine pos) $ - M.insert (WyString "column") (WyInt $ wySrcCol pos) $ - M.insert (WyString "message") (WyString $ errstr ++ ": " ++ msg) m] + [WyMap $ + M.insert (WyString "message") (WyString $ errstr ++ ": " ++ msg) $ + addSrcInfo m pos] else return Nothing + addSrcInfo m (WySourcePos l c f) = + M.insert (WyString "source") (WyString f) $ + M.insert (WyString "line") (WyInt l) $ + M.insert (WyString "column") (WyInt c) m + addSrcInfo m NoPos = m arithmPrim f = defp "+" (opEvalM wyPlus) $ @@ -418,8 +422,6 @@ stdIOPrim f = -- -- Common support functions -defp n l = M.insert n (WyPrimitive n l) - extractName (WyId i _) = return i extractName (WyStmt [x]) = extractName x extractName (WyString s) = return s haskell/src/prim.hs @@ -44,7 +44,7 @@ trim = trimR . trimR where trimR = reverse . dropWhile isSpace main = do params <- getArgs - p <- newIORef $ M.insert "def" (WyPrimitive "def" defWy) M.empty + p <- newIORef $ M.insert "def" (WyPrimitive "def" ["name", "params~", "body"] defWy) M.empty m <- newIORef M.empty let blankEnv = S.empty |> Frame p m False e <- wyInterpr blankEnv "foundation" foundationText haskell/src/repl.hs @@ -9,7 +9,8 @@ module Wy.Types extractId, wyPlus, wyMinus, wyDiv, wyMult, wyIsA, WyEnv, Frame(..), macroValue, varValue, macroUpdate, varInsert, varUpdate, envStack, envAdd, envAddMod, - Eval, localM, localIO, runEval, appErr, appErr1, appErr2 + Eval, localM, localIO, runEval, appErr, appErr1, appErr2, + WyNativeDef, toPrimitive, defp ) where import qualified Data.Sequence as S @@ -39,7 +40,7 @@ data WyType = WyString String | WyMap (M.Map WyType WyType) | WyLambda [String] WyType WyEnv | WyMacro { macroPattern:: WyType, macroBody:: WyType, macroPriority:: Integer, macroEnv:: WyEnv } - | WyPrimitive String ([WyType] -> Eval WyType) + | WyPrimitive String [String] ([WyType] -> Eval WyType) | WyCont (WyType -> Eval WyType) | WyModule String (M.Map String WyType) (M.Map String WyType) @@ -117,7 +118,7 @@ showWy (WyList s) = liftM (\x -> "[" ++ (intercalate "," x) ++ "]") $ mapM showW showWy (WyMap s) = showRet s showWy (WyLambda ss ast env) = return $ "lambda(" ++ (show ss) ++ ", " ++ (show ast) ++ ")" showWy (WyMacro p b _ env) = return $ "macro(" ++ (show p) ++ ", " ++ (show b) ++ ")" -showWy (WyPrimitive n _) = return $ "<primitive " ++ (show n) ++ ">" +showWy (WyPrimitive n _ _) = return $ "<primitive " ++ (show n) ++ ">" showWy (WyCont c) = return "<cont>" showWy (WyModule n _ _) = return $ "module " ++ n ++ " .." showWy (WyId s _) = return s @@ -160,9 +161,9 @@ wyIsA WyNull WyNull = True wyIsA (WyList _) (WyList _) = True wyIsA (WyMap _) (WyMap _) = True wyIsA (WyLambda _ _ _) (WyLambda _ _ _) = True -wyIsA (WyLambda _ _ _) (WyPrimitive _ _) = True -wyIsA (WyPrimitive _ _) (WyLambda _ _ _) = True -wyIsA (WyPrimitive _ _) (WyPrimitive _ _) = True +wyIsA (WyLambda _ _ _) (WyPrimitive _ _ _) = True +wyIsA (WyPrimitive _ _ _) (WyLambda _ _ _) = True +wyIsA (WyPrimitive _ _ _) (WyPrimitive _ _ _) = True wyIsA (WyMacro _ _ _ _) (WyMacro _ _ _ _) = True wyIsA (WyCont _) (WyCont _) = True wyIsA (WyModule _ _ _) (WyModule _ _ _) = True @@ -259,7 +260,7 @@ data WyError = UnknownRef String WySourcePos appErr2 txtFn x1 x2 pos = liftM2 txtFn (showWyE x1) (showWyE x2) >>= (throwError . (flip ArgumentErr $ pos)) appErr1 txtFn x pos = liftM txtFn (showWyE x) >>= (throwError . (flip ArgumentErr $ pos)) -appErr txtFn pos = throwError $ ArgumentErr txtFn pos +appErr txt pos = throwError $ ArgumentErr txt pos instance Error WyError where noMsg = Undef "Undefined error. Sucks to be you." @@ -275,3 +276,12 @@ localM f a = do env <- ask newEnv <- f env local (const newEnv) a + +-- +-- Helpers for primitives definition + +data WyNativeDef = WyNativeDef String ([WyType] -> Eval WyType) +toPrimitive (WyNativeDef n fn) args = WyPrimitive n args fn + +defp n l = M.insert n (WyNativeDef n l) + haskell/src/types.hs @@ -20,6 +20,9 @@ testAdjustFixed = TestCase $ assertEqual "Should leave fixed params unchanged" (Just [WyInt 1, WyInt 2]) $ adjust WyNull WyList ["a", "b"] [WyInt 1, WyInt 2] 0 testAdjustFixedErr = TestCase $ assertEqual "Should fail for insufficent fixed values" Nothing $ adjust WyNull WyList ["a", "b"] [WyInt 1] 0 +testAdjustFailTooManyParams = TestCase $ assertEqual + "Should fail with too many parameters" Nothing $ + adjust WyNull WyList ["a", "b"] [WyInt 0, WyInt 1, WyInt 2] (-1) testAdjustFixedErr2 = TestCase $ assertEqual "Should fail for too many fixed values" Nothing $ adjust WyNull WyList ["a", "b"] [WyInt 1, WyInt 2, WyInt 3] 1 testAdjustOneOpt = TestCase $ assertEqual @@ -48,7 +51,7 @@ testAdjustInterEndMissing = TestCase $ assertEqual adjustOptTests = TestList [testAdjustEmpty, testAdjustFixed, testAdjustFixedErr, testAdjustOneOpt, testAdjustOneOptMissing, testAdjustTwoOpt, testAdjustTwoOptOneMiss, testAdjustTwoOptTwoMiss, - testAdjustInter] + testAdjustInter, testAdjustFailTooManyParams] testAdjustEmptySlurpy = TestCase $ assertEqual "Should nullify missing slurpy" (Just [WyInt 0, WyNull]) $ @@ -59,12 +62,15 @@ testAdjustEndingSlurpy = TestCase $ assertEqual testAdjustMiddleSlurpy = TestCase $ assertEqual "Should fill middle slurpy" (Just [WyInt 0, WyList [WyInt 1, WyInt 2], WyInt 3]) $ adjust WyNull WyList ["a", "b~", "c"] [WyInt 0, WyInt 1, WyInt 2, WyInt 3] 2 +testAdjustEmptyMiddleSlurpy = TestCase $ assertEqual + "Should insert empty middle slurpy" (Just [WyInt 0, WyList [], WyInt 3]) $ + adjust WyNull WyList ["a", "b~", "c"] [WyInt 0, WyInt 3] 0 testAdjustFailFixedMissSlurpy = TestCase $ assertEqual - "Should fail with slurpy but missing fixed params" Nothing $ + "Should fail with slurpy but missing fixed params" (Just [WyInt 0]) $ adjust WyNull WyList ["a", "b~", "c"] [WyInt 0] (-1) adjustSlurpyTests = TestList [testAdjustEmptySlurpy, testAdjustEndingSlurpy, testAdjustMiddleSlurpy, - testAdjustFailFixedMissSlurpy] + testAdjustEmptyMiddleSlurpy, testAdjustFailFixedMissSlurpy] -- -- Pattern matching haskell/test/hunit.hs @@ -35,7 +35,7 @@ describe "Function isa?" ( ) describe "Last argument macro ^ " ( - it "should factor in operations" (((+) 1 2 ^ 3+4) == 10) + it "should factor in operations" (((+) 1 ^ 3+4) == 8) it "should work with a macro application" ^ 3 + 4 == 7 it "should be chainable" (((+) 1 ^ (+) 2 ^ (+) 3 4) == 10) it "should work in a macro definition" ( test/stdlib.wy 942a46d8c0808971422c43710252c9a10ab27d38 Matthieu Riou matthieu.riou@c3-carbon.com http://github.com/matthieu/witty/commit/4cb7aa98bf60a89ece106f57c10f41078f3c02a9 4cb7aa98bf60a89ece106f57c10f41078f3c02a9 2009-09-27T21:02:55-07:00 2009-09-27T21:02:55-07:00 Partial application as a default behavior. 5208a43a1c686306160d28cb828c53ec70cd641e Matthieu Riou matthieu.riou@c3-carbon.com