{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fno-warn-missing-methods #-} module Pugs.Val.Code where import Pugs.Internals import Pugs.Types -- import Pugs.Val.Base -- import Pugs.Val.Capture import Pugs.Class import Text.PrettyPrint import Data.Monoid import qualified Data.Map as Map import qualified Data.Set as Set import qualified Pugs.Types as Types import {-# SOURCE #-} Pugs.Exp type Code = () type Table = Map ID Val {- -- | 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 = MkSig { s_invocant :: Maybe 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 } deriving (Eq, Ord, Typeable) {-!derive: YAML_Pos, Perl6Class, MooseClass!-} type PureSig = Sig -- | Single parameter for a function or 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 :( paramWhatever :: Param paramWhatever = MkParam { p_variable = varNullScalar , p_types = [] , p_constraints = [] , p_unpacking = Nothing , p_default = MkParamDefault Nothing , p_label = nullID , p_slots = Map.empty , p_hasAccess = AccessRO , p_isRef = False , p_isContext = False , p_isLazy = False } instance Monoid Sig where mempty = sigEmpty mappend = sigAppend sigEmpty, sigWhatever :: Sig sigEmpty = MkSig { s_invocant = Nothing , s_requiredPositionalCount = 0 , s_requiredNames = Set.empty , s_positionalList = [] , s_namedSet = Map.empty , s_slurpyScalarList = [] , s_slurpyArray = Nothing , s_slurpyHash = Nothing , s_slurpyCode = Nothing , s_slurpyCapture = Nothing } sigWhatever = sigEmpty{ s_slurpyCapture = Just paramWhatever } sigAppend :: Sig -> Sig -> Sig sigAppend x y | x == y = x | sigIsMethod x `xor` sigIsMethod y = orz -- "incompatible Signature: method and nonmenthod" | s_requiredPositionalCount x /= s_requiredPositionalCount y = orz -- "incompatible Signature: arity mismatch: positionals" -- XXX WRONG: ?-floating | (Set.size . s_requiredNames) x /= (Set.size . s_requiredNames) y = orz -- "incompatible Signature: arity mismatch: nameds" where orz = sigWhatever xor True False = True xor False True = True xor _ _ = False sigIsMethod :: Sig -> Bool sigIsMethod MkSig{ s_invocant = Nothing } = False sigIsMethod _ = True 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 } = "" show _ = ">" instance Eq CodeBody where _ == _ = True instance Ord CodeBody where compare _ _ = EQ instance Show CodeBody where show _ = "" 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 -} instance Show Sig where show = render . (colon <>) . parens . prettySig prettySig :: Sig -> Doc prettySig s@MkSig{s_invocant = Just i} = invocant <> colon `invSpace` (prettySubSig s) where invocant = if (v_name $ p_variable $ i) == nullID then text "$ " else prettyParam i 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) -> prettySig 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 -------------------------------------------------------------------------------------- -- | 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