Plan 9 from Bell Labs’s /usr/web/sources/contrib/fernan/nhc98/src/compiler98/Bind.hs

Copyright © 2021 Plan 9 Foundation.
Distributed under the MIT License.
Download the Plan 9 distribution.


{- --------------------------------------------------------------------------- -}
{- |
The 'bindDecls' and 'bindPat' function are used by "Rename".

The ident* functions collect all identifiers bound within the respective
syntactic construct.
They are used by several modules.
-}
module Bind(Pos,Decls,Decl,Exp,bindDecls,bindPat,identDecl,identPat) where

import State((>>>),(>>>=),mapS0,unitS0)
import IdKind(IdKind(..))
import Util.Extra(strPos)
import TokenId(TokenId)
import Syntax(Decls(..),Decl(..),Exp(..),Constr(..),Field(..),Simple(..)
             ,Alt(..),Fun(..))
import SyntaxPos(Pos,HasPos(getPos))
import RenameLib(RenameRMonadEmpty,bindTid,checkTid)


------------------------

{- |
Add all identifiers (variables, type constructors, class ids, 
data constructors,...) that are bound\/defined in the syntactic construct
to the active names in renameState.
Does not look at local declarations of variable definitions 
(different scope) but at methods of classes and instances.
Adds error message to renameState in case of redefinition of an identifier.
-}

bindDecls :: Decls TokenId -> RenameRMonadEmpty a

bindDecls (DeclsParse decls) =  mapS0 bindDecl decls


bindDecl :: Decl TokenId -> RenameRMonadEmpty a

bindDecl  (DeclType (Simple pos tid tvs) typ) =
    bindTid pos TSyn tid
bindDecl  (DeclDataPrim pos tid size) = 
    bindTid pos TCon tid
bindDecl  (DeclData d ctxs (Simple pos tid tvs) constrs posidents) =
    bindTid pos TCon tid >>> mapS0 bindConstr constrs
bindDecl  (DeclClass pos ctxs tid tvarIdents fundeps methods) =
    bindTid pos TClass tid >>> bindMethods methods
bindDecl  (DeclInstance pos ctx classIdent instanceTypes methods) =
    unitS0
bindDecl  (DeclDefault types) =
    unitS0
bindDecl  (DeclPrimitive pos tid arity typ) =
    bindTid pos Var tid
bindDecl  (DeclForeignImp pos _ _ tid arity cast typ _) = -- foreign import
    bindTid pos Var tid
bindDecl  (DeclForeignExp pos _ _ tid typ) =            -- foreign export
    unitS0
bindDecl  (DeclVarsType posidents ctxs typ) =
    unitS0
bindDecl  (DeclPat (Alt pat guaredExps decls)) =
    bindPat Var pat
bindDecl  (DeclFun pos tid funs) =
    bindTid pos Var tid
bindDecl  (DeclFixity fix) =
    unitS0

--     Used for unimplemented things
bindDecl  (DeclIgnore str)     = unitS0
bindDecl  (DeclError str)      = unitS0
bindDecl  (DeclAnnot decl str) = error "DeclAnnot"

---- =====


bindMethods :: Decls TokenId -> RenameRMonadEmpty a

bindMethods (DeclsParse decls) =  mapS0 bindMethod decls


bindMethod :: Decl TokenId -> RenameRMonadEmpty a

bindMethod (DeclVarsType posidents ctxs typ) =  
  mapS0 ( \ (pos,tid) -> bindTid pos Method tid) posidents
bindMethod _ = unitS0

-- bindAlt kind 

-----------------


bindConstr :: Constr TokenId -> RenameRMonadEmpty a

bindConstr (Constr                pos tid fieldtypes) = 
  bindTid pos  Con tid >>> mapS0 (bindFieldVar . fst) fieldtypes
bindConstr (ConstrCtx forAll ctxs pos tid fieldtypes) = 
  bindTid pos  Con tid >>> mapS0 (bindFieldVar . fst) fieldtypes


bindFieldVar :: Maybe [(Pos,TokenId)] -> RenameRMonadEmpty a

bindFieldVar Nothing = unitS0
bindFieldVar (Just posidents) = 
  mapS0 ( \ (p,v) -> checkTid p Field v >>>= \ exist -> 
         if exist then unitS0 else bindTid p Field v >>> bindTid p Var v)
        posidents

{-
bindPat does not bind Constr!
-}
bindPat :: IdKind -> Exp TokenId -> RenameRMonadEmpty a

bindPat kind (ExpScc            str exp) = error "ExpScc in bindPat!"
bindPat kind (ExpLambda         pos pats exp) = error "ExpLambda in bindPat!"
bindPat kind (ExpLet            pos decls exp) = error "ExpLet in bindPat!"
bindPat kind (ExpCase           pos exp alts) = error "ExpCase in bindPat!"
bindPat kind (ExpIf             pos expCond expThen expElse) = 
  error "ExpIf in bindPat!"
bindPat kind (ExpType           pos exp ctxs typ) = error "ExpType in bindPat!"
--- Above only in expressions
bindPat kind (ExpBrack		pos pat) = bindPat kind pat
bindPat kind (ExpRecord		pos fields) = mapS0 bindField fields
bindPat kind (ExpApplication    pos pats) = mapS0 (bindPat kind) pats
bindPat kind (ExpInfixList      pos (ExpVarOp _ _:pats)) = 
  mapS0 (bindPat kind) pats -- prefix operator, only - is legal
bindPat kind (ExpInfixList      pos pats) = mapS0 (bindPat kind) pats
bindPat kind (ExpVar            pos tid) = bindTid pos kind tid
bindPat kind (ExpCon            pos tid) = unitS0
bindPat kind (ExpVarOp          pos tid) = bindTid pos kind tid
bindPat kind (ExpConOp          pos tid) = unitS0
bindPat kind (ExpLit            pos lit) = unitS0
-- bindPat kind (ExpTuple          pos pats) = mapS0 (bindPat kind) pats
bindPat kind (ExpList           pos pats) = mapS0 (bindPat kind) pats
--- Below only in patterns
bindPat kind (PatAs             pos tid pat) = 
  bindTid pos kind tid >>> bindPat kind pat
bindPat kind (PatWildcard       pos) = unitS0
bindPat kind (PatIrrefutable    pos pat) = bindPat kind pat
bindPat kind (PatNplusK         pos tid tid' int _ _) = bindTid pos kind tid


{- |
Binds variables bound in field expression.
Does not bind field names.
-}
bindField :: Field TokenId -> RenameRMonadEmpty a

bindField (FieldExp pos tid pat) = {- bindTid pos Var tid >>> -} bindPat Var pat
bindField (FieldPun pos tid)     = bindTid pos Var tid
--bindField (FieldPun pos tid)   = bindTid pos Var tid  -- H98 removes


{- ident* , collection of bound variable identifiers ------------------------}

{- |
Collect all variable identifiers that are bound\/defined 
by the declaration in a list.
Does not look at local declarations and not at methods of class or instance
definitions.
-}
identDecl :: Decl a -> [a]

identDecl (DeclPat (Alt pat gdexps decls)) = map snd (identPat pat)
identDecl (DeclFun pos fun (Fun args gdexps decls:_)) = [fun]
identDecl (DeclPrimitive pos fun arity t) = [fun]
identDecl (DeclForeignImp pos _ _ fun arity cast t _) = [fun]
identDecl (DeclForeignExp pos _ _ fun t) = []
identDecl _ = []


{- Add given position and identifier to list -}
addIdent :: Pos -> a -> b -> [(Pos,a)] -> [(Pos,a)]
addIdent pos ident _ env = (pos,ident):env


{- |
Collect all variable identifiers that are bound by the pattern together
with their positions in a list.
Argument must be a pattern, not an arbitrary expression.
-}
identPat :: Exp a -> [(Pos,a)]
identPat pat = identPat' pat () []

identPat' :: Exp a -> b -> [(Pos,a)] -> [(Pos,a)]

identPat' (ExpScc            str exp) = 
  error ("ExpScc in identPat'" ++ show (getPos exp))
identPat' (ExpLambda         pos pats exp) = 
  error ("ExpLambda in identPat'" ++ show pos)
identPat' (ExpLet            pos decls exp) = 
  error ("ExpLet in identPat'" ++ show pos)
identPat' (ExpDo             pos stmts) = 
  error ("ExpDo in identPat'" ++ show pos)
identPat' (ExpCase           pos exp alts) = 
  error ("ExpCase in identPat'" ++ show pos)
identPat' (ExpIf             pos expCond expThen expElse) = 
  error ("ExpIf in identPat'" ++ show pos)
identPat' (ExpType           pos exp ctxs typ) = 
  error ("ExpType in identPat'" ++ show pos)
--- Above only in expressions, not in patterns
identPat' (ExpBrack          pos pat) = identPat' pat
identPat' (ExpRecord         pos fields) = mapS0 identField fields
identPat' (ExpApplication    pos (ExpVar _ _:pats)) = 
  mapS0 identPat' pats -- ignore negate!! (only variable that can be here)
identPat' (ExpApplication    pos pats) = mapS0 identPat' pats
identPat' (ExpInfixList      pos (ExpVarOp _ _:pats)) = 
  mapS0 identPat' pats -- ignore negate!! (only variable that can be here)
identPat' (ExpInfixList      pos pats)  = mapS0 identPat' pats
identPat' (ExpVar            pos ident) = addIdent pos ident
identPat' (ExpCon            pos ident) = unitS0
identPat' (ExpVarOp          pos ident) = addIdent pos ident
identPat' (ExpConOp          pos ident) = unitS0
identPat' (ExpLit            pos lit) = unitS0
--identPat' (ExpTuple          pos pats) = mapS0 identPat' pats
identPat' (ExpList           pos pats) = mapS0 identPat' pats
identPat' (Exp2 pos tid1 tid2) = unitS0 
  -- addIdent noPos tid1 >>> addIdent noPos tid2
--- Below only in patterns
identPat' (PatAs             pos ident pat) 
  = addIdent pos ident >>> identPat' pat
identPat' (PatWildcard       pos) = unitS0
identPat' (PatIrrefutable    pos pat) = identPat' pat
identPat' (PatNplusK         pos n n' k _ _) 
  = addIdent pos n >>> addIdent pos n'
identPat' (ExpDict               pat) = identPat' pat
identPat' p = error ("No match in identPat' at " ++ strPos (getPos p))


identField :: Field a -> b -> [(Pos,a)] -> [(Pos,a)]
identField (FieldExp pos ident pat) = identPat' pat
--identField (FieldPun  pos ident) = addIdent pos ident	-- H98 removes

{- End Module Bind ----------------------------------------------------------}

Bell Labs OSI certified Powered by Plan 9

(Return to Plan 9 Home Page)

Copyright © 2021 Plan 9 Foundation. All Rights Reserved.
Comments to webmaster@9p.io.