{-
- {-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
module Pugs.Val.Code where
import Pugs.Internals
import Pugs.Types
import {-# SOURCE #-} Pugs.Val
--import {-# SOURCE #-} Pugs.Val.Sig
-}
-- | AST for a primitive Code object
data Code
= CodePerl
{ c_signature :: Sig
, c_precedence :: Rational
, c_assoc :: CodeAssoc
, c_isRW :: Bool
, c_isSafe :: Bool
, c_isCached :: Bool
, c_body :: CodeBody -- ^ AST of "do" block
, c_pad :: Pad -- ^ Storage for lexical vars
, c_traits :: Table -- ^ Any additional trait not
-- explicitly mentioned below
, c_preBlocks :: [Code] -- ^ DBC hooks: pre(\$args --> Bool)
, c_postBlocks :: [Code]
, c_enterBlocks :: [Code] -- ^ AOPish hooks
, c_leaveBlocks :: [CodeLeave]
, c_firstBlocks :: [Code]
, c_lastBlocks :: [Code]
, c_nextBlocks :: [Code]
, c_catchBlock :: Maybe Code
, c_controlBlock :: Maybe Code
}
| CodePrim
{ c_signature :: Sig
, c_precedence :: Rational
, c_assoc :: CodeAssoc
, c_isRW :: Bool
, c_isSafe :: Bool
}
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
-- | Block exit traits may be interleaved, so tag them by type
data CodeLeave
= LeaveNormal Code -- ^ LEAVE block
| LeaveKeep Code -- ^ KEEP block
| LeaveUndo Code -- ^ UNDO block
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
-- | Function associtivity
data CodeAssoc
= AssLeft
| AssRight
| AssNon
| AssChain
| AssList
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
--------------------------------------------------------------------------------------
-- | AST for function signature. Separated to method and function variants
-- for ease of pattern matching.
data Sig
= SigMethSingle
{ s_invocant :: Param
, 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
}
| SigSubSingle
{ 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
}
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
type PureSig = Sig
-- | Single parameter for a function/method, e.g.:
-- Elk $m where { $m.antlers ~~ Velvet }
{-|
A formal parameter of a sub (or other callable).
These represent declared parameters; don't confuse them with actual argument
values.
-}
data SigParam = MkParam
{ p_variable :: Var -- ^ 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_isContext :: Bool -- ^ "is context"
, p_isLazy :: Bool
}
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]
deriving (Typeable)
newtype ParamDefault = MkParamDefault { unDefault :: Maybe Exp }
deriving (Typeable)
instance Eq ParamDefault where _ == _ = True
instance Ord ParamDefault where compare _ _ = EQ
instance Show ParamDefault where
show MkParamDefault{ unDefault = Nothing } = "<ParamDefault:Nothing>"
show _ = "<ParamDefault:Just<Exp>>"
instance Eq CodeBody where _ == _ = True
instance Ord CodeBody where compare _ _ = EQ
instance Show CodeBody where show _ = "<Code.Body>"
data ParamAccess
= AccessRO
| AccessRW
| AccessCopy
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
instance ICoercible P Sig where
asStr = return . cast . render . purePretty
instance Pure Sig where
purePretty s = colon <> (parens $ prettySig s)
prettySig :: Sig -> Doc
prettySig s@(SigMethSingle {}) = invocant <> colon `invSpace` (prettySubSig s)
where
invocant = if (v_name $ p_variable $ s_invocant s) == nullID then text "$ " else prettyParam (s_invocant s) True True
invSpace :: Doc -> Doc -> Doc
invSpace = if (isEmpty $ prettySubSig s) then (<>) else (<+>)
prettySig s = prettySubSig s
prettySubSig :: Sig -> Doc
prettySubSig s = sep $ punctuate comma $ concat [posParams, namedParams]
where
posParams = [prettyParam p r True | p <- (s_positionalList s) | r <- (replicate (s_requiredPositionalCount s) True) ++ repeat False]
namedParams = [prettyParam p (isReqNamed n) False | (n, p) <- Map.toList $ s_namedSet s]
isReqNamed n = Set.member n $ s_requiredNames s
prettyParam :: Param -> Bool -> Bool -> Doc
prettyParam p isReq isPos = sep [ staticTypes, varDecl, defaultVal, traits, unpacking, constraints, debugDump ]
where
varDecl = varName <> defaultHint
varName
| isPos = text (cast $ p_variable p)
| v_name (p_variable p) == p_label p = text $ ":" ++ (cast $ p_variable p)
| otherwise = text ":" <> text (cast p_label p) <> (parens $ text (cast p_variable p))
staticTypes = hsep $ map (text . Types.showType) $ p_types p
defaultHint = if not isReq && not haveDefault then text "?" else empty
defaultExp = fromJust . unDefault $ p_default p
haveDefault = isJust . unDefault $ p_default p
defaultVal = if haveDefault then equals <+> prettyExp defaultExp else empty
traits = sep [acc, ref, lazy, slots]
unpacking = case p_unpacking p of
(Just s) -> purePretty s
_ -> empty
acc = case p_hasAccess p of
AccessRO -> empty
AccessRW -> text "is rw"
AccessCopy -> text "is copy"
ref = if p_isRef p then text "is ref" else empty
lazy = if p_isLazy p then text "is lazy" else empty
-- slots = hsep [text ("is " ++ (cast aux)) <+> text "..." | (aux, val) <- Map.toList $ p_slots p] XXX: for when traits have args
slots = hsep [text ("is " ++ (cast $ fst trait)) | trait <- Map.toList $ p_slots p]
constraints = hsep $ replicate (length $ p_constraints p) (text "where {...}")
debugDump = if True then empty else braces $ text $ show p -- XXX delme
--------------------------------------------------------------------------------------
-- | a Capture is a frozen version of the arguments to an application.
data Capt a
= CaptMeth
{ c_invocant :: a
, c_feeds :: [Feed a]
}
| CaptSub
{ c_feeds :: [Feed a]
}
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
-- | non-invocant arguments.
data Feed a = MkFeed
{ f_positionals :: [a]
, f_nameds :: Map.Map ID [a] -- ^ maps to [a] and not a since if the Sig stipulates
-- @x, "x => 1, x => 2" constructs @x = (1, 2).
}
deriving (Show, Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-}
instance Monoid (Feed a) where
mempty = MkFeed mempty mempty
mappend (MkFeed x1 x2) (MkFeed y1 y2) = MkFeed (mappend x1 y1) (mappend x2 y2)
mconcat xs = MkFeed (mconcat (map f_positionals xs)) (mconcat (map f_nameds xs))
emptyFeed :: Feed a
emptyFeed = MkFeed [] Map.empty
-- | Runtime Capture with dynamic Exp for leaves
--type ExpCapt = Capt Exp
-- | Static Capture with Val for leaves
type ValCapt = Capt Val
type ValFeed = Feed Val
instance ICoercible P ValCapt where
asStr _ = return (cast "<capt>") -- XXX