root/src/Pugs/AST.hs

Revision 20058, 16.3 kB (checked in by gbacon, 7 months ago)

Build the library, but the executable still doesn't link. Why aren't we building an Executable with cabal?
  • Property svn:mime-type set to text/plain; charset=UTF-8
  • Property svn:eol-style set to native
Line 
1{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -funbox-strict-fields -fallow-overlapping-instances -fparr #-}
2
3{-|
4    Abstract syntax tree.
5
6>   Tall ships and tall kings
7>   Three times three.
8>   What brought they from the foundered land
9>   Over the flowing sea?
10>   Seven stars and seven stones
11>   And one white tree.
12-}
13
14module Pugs.AST (
15    evalExp, evalExp_, readCodesFromRef,
16    genSym, genMultiSym, genSymScoped, genPadEntryScoped, mkPadMutator,
17    strRangeInf, strRange, strInc,
18    mergeStmts, isEmptyParams, isCompileTime,
19    newPackage, newType, newMetaType, typeMacro, isScalarLValue,
20    filterPrim, filterUserDefinedPad, typeOfParam, listVal, isImmediateMatchContext,
21    (./), defaultScalarPad, envPosStack,
22
23    module Pugs.AST.Internals,
24    module Pugs.AST.Prag,
25    module Pugs.AST.Pos,
26    module Pugs.AST.Scope,
27    module Pugs.AST.SIO,
28    module Pugs.AST.Pad,
29    module Pugs.Val,
30    module Pugs.Class
31) where
32import Pugs.Internals
33import Pugs.Types
34import qualified Data.Map as Map
35import qualified Data.Set as Set
36import Pugs.AST.Internals.Instances ()
37import Pugs.AST.Internals
38import Pugs.AST.Prag
39import Pugs.AST.Pos
40import Pugs.AST.Scope
41import Pugs.AST.SIO
42import Pugs.AST.Pad
43import Pugs.Val hiding (Val, Param, listVal) -- (val, castVal, formatVal, PureBit, PureBool, PureStr, PureInt, PureNum, Capt(..), ValCapt, Feed(..), ValFeed, emptyFeed, Sig(..), SigParam(..), ParamAccess(..), ParamDefault(..))
44import qualified Pugs.Val as Val
45import Pugs.Meta ()
46import Pugs.Class (Boxable(..), ResponderInterface(..), Invocant(..), AnyResponder(..), MethodInvocation(..), ivDispatch)
47
48instance Value (Val.Val) where
49    fromVV = return
50    fromSV = return . mkVal
51    fromVal v = case v of
52        VV x@(MkInvocant x' _) -> case fromTypeable x' of
53            Just v  -> fromVal v
54            _       -> return x
55        VUndef      -> return . mkVal $ UUndef
56        VBool x     -> return . mkVal $ ((cast x) :: Val.PureBit)
57        VInt x      -> return . mkVal $ ((cast x) :: Val.PureInt)
58        VNum x      -> return . mkVal $ ((cast x) :: Val.PureNum)
59        VRat x      -> return . mkVal $ ((cast x) :: Val.PureNum)
60        VStr x      -> return . mkVal $ ((cast x) :: Val.PureStr)
61        PerlSV x    -> return . mkVal $ x
62        _           -> return . mkVal $ v
63    doCast = fromVal
64    castV  = VV
65
66data OldValResponder = OldValResponder deriving Typeable
67instance ResponderInterface Eval OldValResponder where
68    dispatch _          = dispatchOldVal
69    fromMethodList _    = return OldValResponder
70
71instance Boxable Val where
72    mkVal sv = MkInvocant sv (MkResponder (return OldValResponder))
73
74dispatchOldVal :: Val.Val -> Call -> Eval Val.Val
75dispatchOldVal inv call
76    | meth == nullID = do
77        typ <- evalValType =<< castVal inv
78        (fromVal =<<) . evalExp $ _Var (':':'*':showType typ)
79    | otherwise      = do
80        inv' <- castVal inv
81        (fromVal =<<) . evalExp $ App
82            (_Var ('&':cast meth))
83            (Just $ Val inv')
84            [Syn "|" [Val . VV . mkVal $ mi_arguments call]]
85    where
86    meth = mi_name call
87
88{-|
89Return an infinite (lazy) Haskell list of the given string and its
90successors. 'strInc' is used to determine what the \'next\' string is.
91
92Used to implement the @...@ infinite-range operator on strings.
93-}
94strRangeInf :: String -> [String]
95strRangeInf s = (s:strRangeInf (strInc s))
96
97{-|
98Return a range of strings from the first argument to the second, inclusive
99(as a Haskell list). 'strInc' is used to determine what the \'next\' string
100is.
101
102Used to implement the @..@ range operator on strings.
103-}
104strRange :: String -> String -> [String]
105strRange s1 s2
106    | s1 == s2              = [s2]
107    | length s1 > length s2 = []
108    | length s1 < length s2 = (s1:strRange (strInc s1) s2)
109    | s1 >  s2              = []
110    | otherwise             = (s1:strRange (strInc s1) s2)
111
112{-|
113Find the successor of a string (i.e. the next string \'after\' it).
114Special rules are used to handle wraparound for strings ending in an
115alphanumeric character; otherwise the last character is simply incremented
116using 'succ'.
117-}
118strInc :: String -> String
119strInc []       = "1"
120strInc "z"      = "aa"
121strInc "Z"      = "AA"
122strInc "9"      = "10"
123strInc str
124    | x == 'z'  = strInc xs ++ "a"
125    | x == 'Z'  = strInc xs ++ "A"
126    | x == '9'  = strInc xs ++ "0"
127    | otherwise = xs ++ [succ x]
128    where
129    x   = last str
130    xs  = init str
131
132{-|
133Evaluate the given expression, using the currently active evaluator
134(as given by the 'envEval' slot of the current 'Env').
135-}
136evalExp :: Exp -> Eval Val
137evalExp exp = do
138    evl <- asks envEval
139    evl exp
140
141evalExp_ :: Exp -> Eval ()
142evalExp_ exp = do
143    evalExp exp
144    return ()
145
146genMultiSym :: MonadSTM m => Var -> VRef -> EntryFlags -> m PadMutator
147genMultiSym var = case v_sigil var of
148    SCode -> \ref flags -> do
149        case ref of
150            MkRef (ICode c) -> do
151                let var' = var{ v_longname = _cast (cast (code_params c)) }
152                genSymScoped SMy var' ref flags
153            _               -> die "Cannot generate multi variants of non-code object" ref
154    _           -> const $ die "Cannot generate multi variants of variable" var
155
156isStaticScope :: Scope -> Bool
157isStaticScope SOur    = True
158isStaticScope SState  = True
159isStaticScope _       = False
160
161genPadEntryScoped :: MonadSTM m => Scope -> VRef -> EntryFlags -> m PadEntry
162genPadEntryScoped scope ref flags
163    | SConstant <- scope = do
164        return (PEConstant typ ref flags)
165    | isStaticScope scope = stm $ do
166        tvar    <- newTVar ref
167        return (PEStatic typ ref flags tvar)
168    | otherwise = stm $ do
169        tvar    <- newTVar ref
170        return (PELexical typ ref flags tvar)
171    where
172    typ = refType ref
173
174{-# NOINLINE genSymScoped #-}
175genSymScoped :: MonadSTM m => Scope -> Var -> VRef -> EntryFlags -> m PadMutator
176genSymScoped scope var ref flags = do
177    entry <- genPadEntryScoped scope ref flags
178    return (mkPadMutator var entry ref)
179
180mkPadMutator :: Var -> PadEntry -> VRef -> PadMutator
181mkPadMutator var entry ref (MkPad map)
182    | v_longname var /= nullID, MkRef (ICode c) <- ref
183    = let   var'        = var{ v_longname = nullID }
184            protoEntry  = PEConstant
185                { pe_type  = pe_type entry
186                , pe_proto = MkRef (ICode protoCode)
187                , pe_flags = pe_flags entry
188                }
189            protoCode = MkMultiCode
190                { mc_type       = pe_type entry
191                , mc_subtype    = code_type c
192                , mc_assoc      = code_assoc c
193                , mc_signature  = code_params c
194                , mc_variants   = Set.singleton var
195                }
196            merge _ old = case old of
197                PEConstant{ pe_proto = MkRef (ICode oldCV) }
198                    | Just (mc :: VMultiCode) <- fromTypeable oldCV -> protoEntry
199                        { pe_proto = MkRef . ICode $ protoCode
200                            { mc_assoc      = code_assoc c `mappend` code_assoc mc
201                            , mc_variants   = Set.insert var (mc_variants mc)
202                            , mc_signature  = if length (mc_signature mc) == length (code_params c)
203                                then code_params c
204                                else [defaultArrayParam]
205                            }
206                        }
207                _ -> old -- sub overrides multi -- XXX - error?
208       in MkPad (Map.insertWith' merge var' protoEntry (Map.insert var entry map))
209    | otherwise = MkPad (Map.insert var entry map)
210
211{-|
212Create a lexical 'Pad'-transforming transaction that will install a symbol
213mapping from a name to a thing, in the 'Pad' it is applied to.
214-}
215genSym :: MonadSTM m => Var -> VRef -> m PadMutator
216genSym var ref = genSymScoped scope var ref $! case v_twigil var of
217    TMagical    -> mempty{ ef_isContext = True }
218    _           -> mempty
219    where
220    scope = case v_twigil var of
221        TMagical -> SConstant
222        _        -> SMy
223
224{-|
225Tests whether an expression is /simple/, per the definition of S03.
226On the LHS of assignment, those expressions incurs a scalar context.
227-}
228isScalarLValue :: Exp -> Bool
229isScalarLValue x = case x of
230    Ann Parens _    -> False
231    Var var | SScalar <- v_sigil var -> True
232    Syn "${}" _     -> True -- XXX - Change tp App("&prefix:<$>") later
233    Syn "$::()" _   -> True
234    _               -> False
235
236opSet :: VarCateg -> [String] -> Set Var
237opSet cat posts = Set.fromList $ map doMakeVar posts
238    where
239    doMakeVar name = MkVar
240        { v_sigil   = SCode
241        , v_twigil  = TNil
242        , v_package = emptyPkg
243        , v_categ   = cat
244        , v_name    = cast name
245        , v_meta    = MNil
246        , v_longname= nullID
247        }
248
249coercePrefixOps, simplePrefixOps, simplePostfixOps, simpleInfixOps :: Set Var
250coercePrefixOps = opSet C_prefix [ "!","+","-","~","?","$" ]
251simplePrefixOps = opSet C_prefix
252    [ "++","--"
253    , "$","&","+^","~^","?^","\\","^","="
254    ]
255simplePostfixOps = opSet C_postfix ["++", "--"]
256simpleInfixOps = opSet C_infix
257    [ "**"
258    , "**="
259    , "*","/","%","x","+&","+<","+>","~&","~<","~>"
260    , "*=","/=","%=","x=","+&=","+<=","+>=","~&=","~<=","~>="
261    , "+","-","~","+|","+^","~|","~^"
262    , "+=","-=","~=","+|=","+^=","~|=","~^="
263    ]
264
265
266
267
268-- Stmt is essentially a cons cell
269-- Stmt (Stmt ...) is illegal
270mergeStmts :: Exp -> Exp -> Exp
271mergeStmts (Stmts x1 x2) y = mergeStmts x1 (mergeStmts x2 y)
272mergeStmts Noop y@(Stmts _ _) = y
273mergeStmts (Sym scope name flag init x) y = Sym scope name flag init (mergeStmts x y)
274mergeStmts (Syn "package" [kind, pkg@(Val (VStr _))]) y =
275    Syn "namespace" [kind, pkg, y]
276mergeStmts x@(Ann ann (Syn syn _)) y | isImplicitTopic syn =
277    mergeStmts (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", x])) y
278mergeStmts x y@(Ann ann (Syn syn _)) | isImplicitTopic syn =
279    mergeStmts x (Ann ann (App (_Var "&infix:~~") Nothing [_Var "$_", y]))
280mergeStmts x@(Ann _ (Syn "sub" [Val (VCode sub)])) y | subType sub == SubBlock =
281    -- bare Block in statement level; annul all its parameters and run it!
282    mergeStmts (Syn "block" [x]) y
283mergeStmts x y@(Ann _ (Syn "sub" [Val (VCode sub)])) | subType sub == SubBlock =
284    -- bare Block in statement level; annul all its parameters and run it!
285    mergeStmts x (Syn "block" [y])
286mergeStmts x (Stmts y Noop) = mergeStmts x y
287mergeStmts x (Stmts Noop y) = mergeStmts x y
288mergeStmts x y = Stmts x y
289
290isImplicitTopic :: String -> Bool
291isImplicitTopic "subst" = True
292isImplicitTopic "match" = True
293isImplicitTopic "trans" = True
294isImplicitTopic "//"    = True
295isImplicitTopic _       = False
296
297isEmptyParams :: [Param] -> Bool
298isEmptyParams [] = True
299isEmptyParams [x]
300    | var <- paramName x
301    , _underscore == v_name var
302    , emptyPkg    == v_package var
303    , TNil        == v_twigil var
304    = True
305isEmptyParams _ = False
306
307_underscore :: ID
308_underscore = cast "_"
309
310newPackage :: String -> String -> [String] -> [String] -> Exp
311newPackage cls name classes roles = Stmts metaObj (newType name)
312    where
313    metaObj = _Sym SOur (':':'*':name) mempty (
314        App (_Var "&HOW::new")
315            (Just $ Val (VType $ mkType cls))
316            [ Syn "named"
317                [ Val (VStr "is")
318                , Val (VList $ map VStr classes)
319                ]
320            , Syn "named"
321                [ Val (VStr "does")
322                , Val (VList $ map VStr roles)
323                ]
324            , Syn "named"
325                [ Val (VStr "name")
326                , Val (VStr name)
327                ]
328            , Syn "named"
329                [ Val (VStr "attrs")
330                , Syn "\\{}" [Noop]
331                ]
332            ]
333            ) Noop
334
335newType :: String -> Exp
336newType name = _Sym SOur ('&':'*':termName) mempty (typeMacro name (Val . VType . mkType $ name)) Noop
337    where
338    termName = "term:" ++ name
339
340
341newMetaType :: String -> Exp
342newMetaType name = _Sym SOur ('&':'*':termName) mempty (typeMacro name (_Var (':':'*':name))) Noop
343    where
344    termName = "term:" ++ name
345
346typeMacro :: String -> Exp -> Exp
347typeMacro name exp = Syn "sub" . (:[]) . Val . VCode $ MkCode
348    { isMulti       = True
349    , subName       = cast name
350    , subOuterPads  = []
351    , subInnerPad   = emptyPad
352--  , subLexical    = emptyPad
353    , subStarted    = Nothing
354    , subPackage    = emptyPkg
355    , subType       = SubMacro
356    , subAssoc      = ANil
357    , subReturns    = typ
358    , subLValue     = False
359    , subParams     = [ defaultArrayParam, defaultHashParam ]
360    , subBindings   = []
361    , subSlurpLimit = []
362    , subBody       = Prim $ \v -> do
363        list <- mapM fromVals v :: Eval [VList]
364        case concat list of
365            []  -> expToEvalVal $ exp
366            xs  -> die ("Cannot coerce to " ++ name) xs
367    , subCont          = Nothing
368    , subTraitBlocks   = emptyTraitBlocks
369    }
370    where
371    typ = mkType name
372
373{- utilities for filtering out primitives from an environmet, useful for
374 - CodeGen and Pugs::Internals::emit_yaml -}
375
376filterPrim :: MPad -> Eval Pad
377filterPrim glob = do
378    MkPad pad   <- readMPad glob
379    fmap (MkPad . Map.fromAscList . catMaybes) . mapM checkPrim $ Map.toAscList pad
380
381checkPrim :: (Var, PadEntry) -> Eval (Maybe (Var, PadEntry))
382checkPrim e@(var, entry)
383    | SType <- v_sigil var, isGlobalVar var = return Nothing
384    | otherwise = do
385        rv <- isPrim =<< readPadEntry entry
386        return (if rv then Nothing else Just e)
387
388isPrim :: VRef -> Eval Bool
389isPrim vref = do
390    case vref of
391        MkRef (ICode cv)    -> fmap (isPrimVal . VCode) (code_fetch cv)
392        MkRef (IScalar sv)  -> fmap isPrimVal (scalar_fetch sv)
393        _                   -> return False
394    where
395    isPrimVal (VCode MkCode{ subBody = Prim _ }) = True
396    isPrimVal _ = False
397
398{-|
399Filter out reserved symbols from the specified Pad.
400-}
401filterUserDefinedPad :: Pad -> Pad
402filterUserDefinedPad (MkPad pad) = MkPad $ Map.filterWithKey doFilter pad
403    where
404    doFilter key _ = (not . Set.member key) _reserved
405
406{-|
407Symbols which are reserved for the current interpreter or compiler instance and
408should not be set from the preamble or other sources. See @filterUserDefinedPad@.
409-}
410_reserved :: Set Var
411_reserved = Set.fromList . cast . words $
412    "@*ARGS @*INC %*INC $*PUGS_HAS_HSPLUGINS $*EXECUTABLE_NAME " ++
413    "$*PROGRAM_NAME $*PID $*UID $*EUID $*GID $*EGID @*CHECK @*INIT $*IN " ++
414    "$*OUT $*ERR $*ARGS $/ %*ENV $*CWD @=POD $=POD $?PUGS_VERSION " ++
415    "$*OS %?CONFIG $*_ $*AUTOLOAD $*PUGS_VERSION $*BASETIME"
416
417typeOfParam :: Param -> Type
418typeOfParam p = case v_sigil (paramName p) of
419    SScalar -> typeOfCxt (paramContext p)
420    s       -> typeOfSigil s
421
422listVal :: Val -> [Val]
423listVal (VList xs)  = xs
424listVal x           = [x]
425
426isImmediateMatchContext :: Eval Bool
427isImmediateMatchContext = do
428    env <- ask
429    let cxt = envContext env
430        typ = typeOfCxt cxt
431    return (cxt == CxtVoid || (any (\x -> isaType x typ) ["Bool", "Num", "Str"]))
432
433(./) :: ((:>:) Call a) => Val -> a -> Eval Val
434(VV vv) ./ y = vvToVal =<< ivDispatch vv (cast y)
435x ./ y       = do
436    vv <- fromVal x
437    vvToVal =<< ivDispatch vv (cast y)
438
439instance ((:>:) Call) Cxt where
440    cast CxtSlurpy{} = __LIST__
441    cast _           = __ITEM__
442
443__LIST__ :: Call
444__LIST__ = cast "LIST"
445
446__ITEM__ :: Call
447__ITEM__ = cast "ITEM"
448
449readCodesFromRef :: VRef -> Eval [VCode]
450readCodesFromRef (MkRef (ICode c))
451    | Just (mc :: VMultiCode) <- fromTypeable c = do
452        let names@(pivot:_) = Set.elems (mc_variants mc)
453        rvs <- fmap concat . forM names $ \var -> do
454            ref  <- fromVal =<< readVar var
455            readCodesFromRef ref
456        if not (isLexicalVar pivot) then return rvs else do
457            -- Lexical multis must also include global variants.
458            cvGlobal <- readVar (toGlobalVar pivot{ v_longname = nullID })
459            if not (defined cvGlobal) then return rvs else do
460                rvsGlobal <- readCodesFromRef =<< fromVal cvGlobal
461                return (rvsGlobal ++ rvs)
462    | Just (cv :: VCode) <- fromTypeable c = return [cv]
463readCodesFromRef ref = do
464    code <- fromVal =<< readRef ref
465    readCodesFromRef (MkRef (ICode (code :: VCode)))
466
467isCompileTime :: Env -> Bool
468isCompileTime = isJust . envCompPad
469
470
471{-# NOINLINE defaultScalarPadStore #-}
472defaultScalarPadStore :: TVar VRef
473defaultScalarPadStore = unsafePerformIO (newTVarIO defaultScalarRef)
474
475defaultScalarRef :: VRef
476defaultScalarRef = scalarRef undef
477
478defaultScalarPad :: Pad
479defaultScalarPad = mkPad [(varTopic, PELexical anyType defaultScalarRef mempty defaultScalarPadStore)]
480
481envPosStack :: Env -> [Pos]
482envPosStack env = envPos env : maybe [] envPosStack (envCaller env)
Note: See TracBrowser for help on using the browser.