Changeset 7622 for src/Pugs/Bind.hs

Timestamp:

10/15/05 09:08:18 (3 years ago)

Author:

scook0

Message:

* Abracadabra, shalakazam, demagicalize pairs!
(This will probably break all the other backends.)
* A few minor style/readability tweaks

Files:

• src/Pugs/Bind.hs (modified) (5 diffs)

src/Pugs/Bind.hs

@@ -39 +39 @@
     where
     prms' = prms \\ (map fst bound)
-    (bound, exps') = foldr doBind ([], []) (map unPair exps)
+    (bound, exps') = foldr doBind ([], []) (map unwrapNamedArg exps)
     doBind (name, exp) (bound, exps) 
         | Just prm <- find ((matchNamedAttribute name) . paramName) prms
@@ -148 +148 @@
 -- doBindArray _ (_, _)  (_, x) = internalError $ "doBindArray: unexpected char: " ++ (show x)
 
-{-|
-Return @True@ if the given expression represents a pair (i.e. it uses the
-\"=>\" pair constructor).
--}
-isPair :: Exp -> Bool
-isPair (Pos _ exp) = isPair exp
-isPair (Cxt _ exp) = isPair exp
-isPair (Syn "=>" [(Cxt _ (Val _)), _])   = True
-isPair (Syn "=>" [(Val _), _])   = True
-isPair _                         = False
-
-{-|
-Decompose a pair-constructor 'Exp'ression (\"=>\") into a Haskell pair
-(@key :: 'String'@, @value :: 'Exp'@).
--}
-unPair :: Exp -> (String, Exp)
-unPair (Pos _ exp) = unPair exp
-unPair (Cxt _ exp) = unPair exp
-unPair (Syn "=>" [key, exp])
-    | Val (VStr k) <- unwrap key = (k, exp)
-unPair x = error ("Not a pair: " ++ show x)
+
+isNamedArg :: Exp -> Bool
+isNamedArg (Syn "named" [(Val (VStr _)), _]) = True
+isNamedArg arg@(Syn "named" _)               = error $ "malformed named arg: " ++ show arg
+isNamedArg _                                 = False
+
+unwrapNamedArg :: Exp -> (String, Exp)
+unwrapNamedArg (Syn "named" [(Val (VStr key)), val]) = (key, val)
+unwrapNamedArg x = error $ "not a well-formed named arg: " ++ show x
 
 {-|
@@ -210 +198 @@
 
     -- Check that we have enough invocants bound
-    unless (null invocants) $ do
+    when (not . null $ invocants) $ do
         let cnt = length invocants
             act = length boundInvs
@@ -218 +206 @@
             ++ (show $ subName sub)
             
-    let (boundReq, boundOpt) = partition (\x -> isRequired (fst x)) bindings -- bound params which are required
+    let (boundReq, boundOpt) = partition (isRequired . fst) bindings -- bound params which are required
         (reqPrms, optPrms)   = span isRequired params -- all params which are required, and all params which are opt
 
@@ -258 +246 @@
 
     let boundInv                = invPrms `zip` givenInvs -- invocants are just bound, params to given
-        (namedArgs, posArgs)    = partition isPair givenArgs -- pairs are named arguments, they go elsewhere
+        (namedArgs, posArgs)    = partition isNamedArg givenArgs
         (boundNamed, namedForSlurp, allPosPrms) = bindNames namedArgs argPrms -- bind pair args to params. namedForSlup = leftover pair args
         (posPrms, slurpyPrms)   = break isSlurpy allPosPrms -- split any prms not yet bound, into regular and slurpy. allPosPrms = not bound by named