Changeset 12924

Timestamp:

09/01/06 15:11:03 (2 years ago)

Author:

gaal

Message:

* Basic support for parsing Signatures with :().

Only named parameters are parsed, and optionals (incorrectly)
require a '?' even if they have a default value. No parameter
decoration (type constraints, access traits, etc.) is supported
yet. The following forms do work:

:($x:)
:($x)
:($x: $y, $z)
:($x: $y, $z? = 42)
:($x: $y?, $z) # correctly raises a parse error

Location:

src/Pugs

Files:

• AST.hs (modified) (1 diff)
• AST/Internals.hs (modified) (4 diffs)
• AST/Internals/Instances.hs (modified) (2 diffs)
• CodeGen/PIR.hs (modified) (1 diff)
• Eval.hs (modified) (1 diff)
• Monads.hs (modified) (1 diff)
• Parser.hs (modified) (4 diffs)
• Parser/Operator.hs (modified) (2 diffs)
• Parser/Util.hs (modified) (3 diffs)
• Val.hs (modified) (1 diff)
• Val/Code.hs (modified) (2 diffs)

src/Pugs/AST.hs

@@ -39 +39 @@
 import Pugs.AST.SIO
 import Pugs.AST.Pad
-import Pugs.Val (val, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed)
+import Pugs.Val (val, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed, Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..))
 
 {-|

src/Pugs/AST/Internals.hs

@@ -778 +778 @@
 
 These represent declared parameters; don't confuse them with actual parameter 
-values.
--}
-data Param = MkParam
+values, which are henceforth termed "arguments".
+-}
+data Param = MkOldParam -- "Old" because Pugs.Val.Code defined a new one
     { isInvocant    :: !Bool        -- ^ Is it in invocant slot?
     , isOptional    :: !Bool        -- ^ Is it optional?
@@ -797 +797 @@
 type Params     = [Param]
 
-paramToValParam :: Param -> Val.Param
+paramToValParam :: Param -> Val.SigParam
 paramToValParam param = ret
     where 
@@ -809 +809 @@
         , Val.p_slots       = Map.empty
         , Val.p_hasAccess   = case param of
-                                  MkParam { isLValue = True, isWritable = False } -> Val.AccessRO
-                                  MkParam { isLValue = True, isWritable = True }  -> Val.AccessRW
-                                  MkParam { isLValue = False }                    -> Val.AccessCopy
+                                  MkOldParam { isLValue = True, isWritable = False } -> Val.AccessRO
+                                  MkOldParam { isLValue = True, isWritable = True }  -> Val.AccessRW
+                                  MkOldParam { isLValue = False }                    -> Val.AccessCopy
         , Val.p_isRef       = Val.p_hasAccess ret == Val.AccessRW
         , Val.p_isLazy      = isLazy param
@@ -1087 +1087 @@
            -> Exp    -- ^ Expression for the param's default value
            -> Param
-buildParam typ sigil name e = MkParam
+buildParam typ sigil name e = MkOldParam
     { isInvocant    = False
     , isOptional    = '?' `elem` sigil

src/Pugs/AST/Internals/Instances.hs

@@ -400 +400 @@
 instance YAML Param where
     fromYAML MkNode{n_tag=Just t, n_elem=e} | 't':'a':'g':':':'h':'s':':':tag <- unpackBuf t = case tag of
-        "MkParam" -> do
+        "MkOldParam" -> do
             let liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do
                 {x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; x6 <- m6; x7 <- m7; x8 <- m8; x9 <- m9; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9)}
             let ESeq [aa, ab, ac, ad, ae, af, ag, ah, ai] = e
-            liftM9 MkParam (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) (fromYAML ag) (fromYAML ah) (fromYAML ai)
-        _ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkParam"] ++ " in node " ++ show e
-    fromYAML _ = fail "no tag found"
-    asYAML (MkParam aa ab ac ad ae af ag ah ai) = asYAMLseq "MkParam"
+            liftM9 MkOldParam (fromYAML aa) (fromYAML ab) (fromYAML ac) (fromYAML ad) (fromYAML ae) (fromYAML af) (fromYAML ag) (fromYAML ah) (fromYAML ai)
+        _ -> fail $ "unhandled tag: " ++ show t ++ ", expecting " ++ show ["MkOldParam"] ++ " in node " ++ show e
+    fromYAML _ = fail "no tag found"
+    asYAML (MkOldParam aa ab ac ad ae af ag ah ai) =
+           asYAMLseq "MkOldParam"
            [asYAML aa, asYAML ab, asYAML ac, asYAML ad, asYAML ae, asYAML af,
             asYAML ag, asYAML ah, asYAML ai]
 
 instance Perl5 Param where
-    showPerl5 (MkParam aa ab ac ad ae af ag ah ai) =
-              showP5HashObj "MkParam"
+    showPerl5 (MkOldParam aa ab ac ad ae af ag ah ai) =
+              showP5HashObj "MkOldParam"
               [("isInvocant", showPerl5 aa) , ("isOptional", showPerl5 ab) ,
                ("isNamed", showPerl5 ac) , ("isLValue", showPerl5 ad) ,
@@ -421 +422 @@
 
 instance JSON Param where
-    showJSON (MkParam aa ab ac ad ae af ag ah ai) =
-             showJSHashObj "MkParam"
+    showJSON (MkOldParam aa ab ac ad ae af ag ah ai) =
+             showJSHashObj "MkOldParam"
              [("isInvocant", showJSON aa), ("isOptional", showJSON ab),
               ("isNamed", showJSON ac), ("isLValue", showJSON ad),

src/Pugs/CodeGen/PIR.hs

@@ -15 +15 @@
 module Pugs.CodeGen.PIR (genPIR, genPIR_YAML) where
 import Pugs.Internals
-import Pugs.AST
+import Pugs.AST hiding (Sig)
 import Pugs.Types
 import Pugs.PIL1

src/Pugs/Eval.hs

@@ -1148 +1148 @@
         return (syms', ApplyArg var val coll:restArgs)
     expToVal :: Param -> Exp -> Eval (Val, Bool)
-    expToVal MkParam{ isLazy = thunk, isLValue = lv, paramContext = cxt, paramName = var, isWritable = rw } exp = do
+    expToVal MkOldParam{ isLazy = thunk, isLValue = lv, paramContext = cxt, paramName = var, isWritable = rw } exp = do
         env <- ask -- freeze environment at this point for thunks
         let eval = local (const env{ envLValue = lv }) $ do

src/Pugs/Monads.hs

@@ -295 +295 @@
 makeParams :: Env -> [Param]
 makeParams MkEnv{ envContext = cxt, envLValue = lv }
-    = [ MkParam
+    = [ MkOldParam
         { isInvocant = False
         , isOptional = False

src/Pugs/Parser.hs

@@ -29 +29 @@
 import Pugs.Internals
 import Pugs.AST
+import qualified Pugs.Exp as Exp
 import Pugs.Types
 import Pugs.Version (versnum)
@@ -42 +43 @@
 import Pugs.Parser.Util
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 -- Lexical units --------------------------------------------------
@@ -1291 +1293 @@
     term <- choice
         [ ruleDereference
+        , ruleSignatureVal  -- must come before ruleTypeVar
         , ruleVarDecl
         , ruleVar
@@ -1312 +1315 @@
             fs <- many s_postTerm
             return $! combine (reverse fs) term
+
+ruleSignatureVal :: RuleParser Exp
+ruleSignatureVal = do
+    between (symbol ":(") (symbol ")") ruleSignature
+
+data Paramdec = MkParamdec
+    { p_param      :: SigParam
+    , p_isNamed    :: Bool
+    , p_isRequired :: Bool
+    }
+    deriving (Show)
+
+ruleSignature :: RuleParser Exp
+ruleSignature = rule "Signature" $ do
+    inv     <- option Nothing $ try $ fmap (Just . p_param) $ followedBy ruleParam (symbol ":")
+    params  <- ruleParam `sepEndBy` (symbol ",")
+    reqPosC <- validateRequired True params
+    let reqNms   = Set.fromAscList $ sort $ map (p_label . p_param) $ filter p_isRequired params
+        posLs    = map p_param $ filter (not . p_isNamed) params
+        nmSt     = Map.fromList $ map (\p -> (p_label $ p_param p, p_param p)) $ filter p_isNamed params
+        slpScLs  = []
+        slpArrLs = Nothing
+        slpHsh   = Nothing
+        slpCd    = Nothing
+        slpCapt  = Nothing
+    return $ Val $ VV $ val $ case inv of
+        Nothing -> SigSubSingle    reqPosC reqNms posLs nmSt slpScLs slpArrLs slpHsh slpCd slpCapt
+        Just i  -> SigMethSingle i reqPosC reqNms posLs nmSt slpScLs slpArrLs slpHsh slpCd slpCapt
+    where
+        validateRequired _     []     = return 0
+        validateRequired False (x:_)
+            | isReqPos x              = fail $ "Required parameter cannot come after optional ones: " ++ show x
+        validateRequired _     (x:xs) = do
+            next <- validateRequired (isReqPos x) xs
+            return $ (fromEnum $ isReqPos x) + next
+        isReqPos x = p_isRequired x && (not $ p_isNamed x)
+
+{-
+        { s_requiredPositionalCount   :: Int
+        , s_requiredNames             :: Set ID
+        , s_positionalList            :: [Param]
+        , s_namedSet                  :: Map.Map ID Param
+        , s_slurpyScalarList          :: [Param]
+        , s_slurpyArray               :: Maybe Param
+        , s_slurpyHash                :: Maybe Param
+        , s_slurpyCode                :: Maybe Param
+        , s_slurpyCapture             :: Maybe Param
+
+data Param = MkParam
+    { p_variable    :: ID            -- ^ E.g. $m above
+    , p_types       :: [Types.Type]  -- ^ Static pieces of inferencer-food
+                                     --   E.g. Elk above
+    , p_constraints :: [Code]        -- ^ Dynamic pieces of runtime-mood
+                                     --   E.g. where {...} above
+    , p_unpacking   :: Maybe PureSig -- ^ E.g. BinTree $t (Left $l, Right $r)
+    , p_default     :: ParamDefault  -- ^ E.g. $answer? = 42
+    , p_label       :: ID            -- ^ The external name for the param ('m' above)
+    , p_slots       :: Table         -- ^ Any additional attrib not
+                                     --   explicitly mentioned below
+    , p_hasAccess   :: ParamAccess   -- ^ is ro, is rw, is copy
+    , p_isRef       :: Bool          -- ^ must be true if hasAccess = AccessRW
+    , p_isLazy      :: Bool
+    }
+-}
+
+-- we start with basic param parsing only - this'll grow.
+ruleParam :: RuleParser Paramdec
+ruleParam = rule "paramater" $ do
+    name@(s:lab) <- regularVarName
+    def          <- option Nothing $ do
+        symbol "?"
+        fmap Just $ option DNil $ do
+            symbol "="
+            fmap (DExp . Exp.EE . Exp.MkExpEmeritus) parseTerm
+    access       <- option AccessRO $ try $ do -- XXX: expand this to do arbitrary traits, in any order
+        traits   <- ruleTrait ["is"]
+        case traits of
+            ("is", "ro")   -> return AccessRO
+            ("is", "rw")   -> return AccessRW
+            ("is", "copy") -> return AccessCopy
+            _              -> fail $ "unhandled trait: " ++ show traits
+    let p = MkParam (cast name) [] [] Nothing (maybe DNil id def) (cast lab) Map.empty access False False
+    return $ MkParamdec{ p_param = p, p_isRequired = isNothing def, p_isNamed = False }
+
+
 
 ruleTypeVar :: RuleParser Exp

src/Pugs/Parser/Operator.hs

@@ -275 +275 @@
 matchUnary :: CurrentFunction -> Bool
 matchUnary MkCurrentFunction
-    { f_assoc = ANil, f_params = [MkParam
+    { f_assoc = ANil, f_params = [MkOldParam
         { paramContext = CxtItem{}, isNamed = False }] } = True
 matchUnary _ = False
@@ -288 +288 @@
     { f_params = (_:_:_) } = True
 matchSlurpy MkCurrentFunction
-    { f_params = [MkParam
+    { f_params = [MkOldParam
         { paramContext = CxtSlurpy{}, paramName = MkVar{ v_sigil = sig } }] }
             = sig == SArray || sig == SArrayMulti

src/Pugs/Parser/Util.hs

@@ -115 +115 @@
 
 nameToParam :: Var -> Param
-nameToParam name = MkParam
+nameToParam name = MkOldParam
     { isInvocant    = False
     , isOptional    = False
@@ -151 +151 @@
 -- | A Param representing the default (unnamed) invocant of a method on the given type.
 selfParam :: Type -> Param
-selfParam typ = MkParam
+selfParam typ = MkOldParam
     { isInvocant    = True
     , isOptional    = False
@@ -223 +223 @@
     isBreakingSpace _       = False
 
-tryFollowedBy :: RuleParser a -> RuleParser b -> RuleParser a
-tryFollowedBy rule after = try $ do
+followedBy, tryFollowedBy :: RuleParser a -> RuleParser b -> RuleParser a
+followedBy rule after = do
     rv <- rule
     after
     return rv
 
+tryFollowedBy = (try .) . followedBy

src/Pugs/Val.hs

@@ -18 +18 @@
 
     -- From Code
-        Sig(..), Param(..), ParamAccess(..), ParamDefault(..),
+        Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..),
     Capt(..), Feed(..), emptyFeed, Code(..),
     ValCapt, ValFeed,

src/Pugs/Val/Code.hs

@@ -97 +97 @@
 values.
 -}
-data Param = MkParam
+data SigParam = MkParam
     { p_variable    :: ID            -- ^ E.g. $m above
     , p_types       :: [Types.Type]  -- ^ Static pieces of inferencer-food
@@ -113 +113 @@
     }
     deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
+
+type Param = SigParam -- to get around name clashes in Pugs.AST :(
 
 newtype CodeBody = MkCodeBody [Stmt]