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

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


{- |
   Needs 'IdSupply'.
-}
module RenameLib(module RenameLib
        ,ImportState,NT,NewType,IE,Either,Info
        ,Maybe,Flags) where

import List
import TokenId(TokenId(..),t_Tuple,ensureM,mkQual2,visible,mkQual3,mkQualD
              ,rpsPrelude,forceM)
import Syntax hiding (TokenId)
import Scc
import NT
import Util.Extra
import Maybe

import qualified Data.Map as Map
import ImportState hiding (TokenId)
import IntState(checkNT)
import IExtract(fixOne,fixFun)
import State
import IdKind
import PreImp(sExp,sQual,sLG,sFix)
import SysDeps(PackedString,unpackPS,trace)
import Info hiding (TokenId)
import SyntaxPos
import TokenInt
import Util.OsOnly(isPrelude)
import Flags
import Overlap          -- added in H98
import Id
import Error

-- | Should be a record ... but should its field names be exported?
data RenameState =
      RenameState
        Flags                           -- flags
        Id                              -- unique
        (Id,PackedString)               -- modid
        [Map.Map (TokenId,IdKind) Id]   -- stack of rename (name -> unique)
        (Map.Map (TokenId,IdKind) Id)   -- active rename (name  -> unique)
        (Map.Map Id Info)               -- symboltable (unique -> info)
        [(Id,[(Pos,Id)])]               -- derived   [(con,[(pos,cls)])]
        (Maybe [Id])                    -- defaults
        [Error]                         -- errors
        [Id]                            -- type Synonyms

instance IdSupply RenameState where
    getUniqueId _ (RenameState flags unique rps rts rt st derived
                               defaults errors needCheck)
        = (unique, RenameState flags (succ unique) rps rts rt st derived
                               defaults errors needCheck)

--- The selectors for (qualFun,expFun,fixity) are defined
--- in PreImp and used here and in Fixity

{- Used several times: -}
type RenameToken = (PackedString -> Id -> TokenId -> TokenId
                   ,TokenId -> TokenId
                   ,TokenId -> IdKind -> IE
                   ,TokenId -> (InfixClass TokenId, Int)
                   ) 
type RenameToken2 = (PackedString -> Id -> TokenId -> TokenId
                   ,TokenId -> TokenId
                   ,TokenId -> IdKind -> IE
                   ) 
type RenameMonad  a      = State  RenameToken RenameState a RenameState
type RenameRMonad a b    = State  a           RenameState b RenameState
type RenameMonadEmpty    = State0 RenameToken RenameState RenameState
type RenameRMonadEmpty a = State0 a           RenameState RenameState

{- |
Destruct rename state to obtain all its elements we are interested in.
Additionally checks some properties of types.
-}
keepRS :: RenameState 
       -> (Id
          ,((TokenId,IdKind) -> Id,(TokenId,IdKind) -> Maybe Id)
          ,(Id,PackedString)
          ,Map.Map Id Info     -- the symbol table
          ,[(Id,[(Pos,Id)])]  -- derived
          ,Maybe [Id]          -- user defined defaults for Num classes
          ,[Error])            -- errors

keepRS (RenameState flags unique rps rts rt st derived
                    defaults errors needCheck) =
  case checkTypes st needCheck of
    Right st ->
      (unique,getInts (lookupAll (rt:rts)),rps,st,derived,defaults,errors)
    Left x ->
      (unique,getInts (lookupAll (rt:rts)),rps,st,derived,defaults,errors ++ x)
  where
  checkTypes :: Map.Map Id Info -> [Id] -> Either [Error] (Map.Map Id Info)
  checkTypes st needCheck =
    case foldls (checkPrep st) ([],[]) needCheck of   
      -- !!! Do these checks at defining site only !!!
      (synType,newType) -> -- first look for error in type synonym defs
        let keep = map fst synType
            sccSyn = sccDepend 
                       (map ( \ (u,d) -> (u,filter (`elem` keep) d)) synType)
        in
          case (filter isRec sccSyn) of
            x@(_:_) -> Left (map (err2 st) x)
            [] -> -- now look for error in newtype defs
              case foldls ( \ (st,err) (u,c) -> 
                                case isUnBoxedNT st newType [u] c of
                                  Just unboxed -> 
                                    (Map.update (Just . updNewType unboxed) u st,err)  
                                    -- WORKING ON
                                  Nothing -> 
                                    (Map.update (Just . updNewType False) u st 
                                    ,(ErrorCircularNewtype
                                      ((show . tidI . fromJust . flip Map.lookup st) u))
                                       : err)
                          ) (st,[]) newType of
                (st,err@(_:_)) -> Left err
                (st,[]) -> Right (snd (foldls fixDepth (0::Int,st) sccSyn))

  fixDepth (d,st) (NoRec u) =
    let unboxed = isUnBoxedTS st u
        d' = 1 + max d (minDepth st u) 
    in unboxed `seq` d' `seq` (d',Map.update (Just . updTypeSynonym unboxed d') u st)

  minDepth st c = -- called for type synonyms only
    case (ntI . fromJust . flip Map.lookup st) c of
      (NewType _ [] _ [nt]) ->
        (maximum . (0:) -- Ensures maximum works
                 . map (safeDepthI . fromJust . flip Map.lookup st) . consNT) nt

  safeDepthI info =
    case depthI info of
      Nothing -> 0
      Just d  -> d


  {- |
  Determines for given newtype type constructor, if the renamed type
  is unboxed. Returns Nothing if definition is circular.
  -}
  isUnBoxedNT :: Map.Map Id Info -- ^ symboltable
              -> [(Id,Id)]  -- ^ for every newtype type constructor 
                            -- the top type constructor of the renamed type
              -> [Id]       -- ^ accumulates newtype type constructors
                            -- that have already been visited to recognise
                            -- circularity.
              -> Id         -- ^ newtype type constructor that is tested
              -> Maybe Bool

  isUnBoxedNT st nt ac u =
    if u `elem` ac then -- already been here, so circular defn.
      Nothing
    else
    case Map.lookup u st of
      Just info ->
        if isRealData info then -- got the answer!
          Just (isDataUnBoxed info)
        else
          case depthI info of
            Just _ ->  -- type synonym, so follow the chain
              case ntI info of
                (NewType free [] ctx [NTcons u' _ _]) ->
                  isUnBoxedNT st nt (u:ac) u'         
            Nothing -> -- newtype, so follow the chain
              case lookup u nt of
                Just u' -> isUnBoxedNT st nt (u:ac) u'  -- defn in this module
                Nothing ->      -- defn in an imported module
                  -- error ("nhc98 needs a fix here, but I don't know how")
                  case constrsI info of
                    (coni:_) ->
                      case (ntI . fromJust . flip Map.lookup st) coni of
                        (NewType _ _ _ [NTcons u' _ _,_]) ->
                          isUnBoxedNT st nt (u:ac) u'
                        _ -> -- strace 
                      -- ("Warning: renaming newtype of imported newtype:\n"++
                      --  "  Real type of "++show(tidI info)++
                      --                                  " is not visible.\n"++
                      --  "  I might get boxed/unboxed info wrong.")
                          (Just False)
                    [] -> -- strace 
                 --  ("Warning: when renaming newtype of imported newtype:\n"++
                 --   "  Real type of "++show(tidI info)++" is not visible.\n"++
                 --   "  I might get boxed/unboxed info wrong.")
                     (Just False)
      Nothing -> Nothing        -- possibly not circular at all

  isUnBoxedTS st u = -- No circular dependency when this function is called
    case Map.lookup u st of
      Nothing -> -- FAKE This is a BUG but unboxed is not used anyway
        False
      Just info ->
        case depthI info of
          Just _ ->  -- type synonym
            case ntI info of
              (NewType free [] ctx [NTcons u' _ _]) ->
                isUnBoxedTS st u'             
              _ ->  -- FAKE This is a BUG but unboxed is not used anyway
                False
          Nothing ->
            isDataUnBoxed info

  {- |
  Add some information about given type constructor to list,
  either to list about type synonyms or list about newtypes.
  Type constructor must be for type synonym or newtype.
  -}
  checkPrep :: Map.Map Id Info -- ^ symboltable
            -> ([(Id,[Id])],[(Id,Id)]) 
               -- ^
               -- > 1 synonym list: type constructor, type cons occuring in rhs
               -- > 2 newtype list: type constructor, top type constructor
               -- >     of renamed type (eg. [] in newtype T = T [Int])
            -> Id -- ^ type constructor 
            -> ([(Id,[Id])],[(Id,Id)])
               -- ^ same format as argument

  checkPrep st (synType,newType) u =
    case Map.lookup u st of
      Just info ->
        case depthI info of
          Just _ ->  -- Only typeSyn has depth
            case ntI info of
              (NewType _ [] _ [nt]) ->
                ((u,consNT nt):synType,newType)
          Nothing -> -- If it isn't a typeSyn then it must be a newType 
            case constrsI info of
              (coni:_) ->
                 case (ntI . fromJust . flip Map.lookup st ) coni of
                   (NewType _ [] _ [NTcons c _ _,res]) -> (synType,(u,c):newType)
                   (NewType _ [] _ [NTvar v _,res]) -> (synType,      newType)
                   (NewType _ [] _ [NTapp v1 v2,res]) -> (synType,newType)
                        -- MW hack: omits potential circularity check!
                   (NewType _ [] _ (_:_:_)) ->
                        error ("Invalid rhs of newtype: " ++
                               show (tidI info)++
                               "\nA newtype can rename only one type.")
                   _ -> error ("Couldn't find rhs of newtype: " ++
                               show (tidI info)++
                               "\nTwo conflicting newtype definitions?")
              [] -> (synType,newType) -- !!! Not a good solution !!!
      Nothing -> error ("Couldn't find definition for newtype "++show u)

  err2 ts (Rec xs) = ErrorCircularType (map (show . tidI . fromJust . flip Map.lookup ts) xs)


-- | Only important that it works for data, class, type and newtype
thisModule :: PackedString -> TokenId -> Bool
thisModule rps (TupleId _) = rps == rpsPrelude
thisModule rps (Visible _) = False
thisModule rps (Qualified rps' _) = rps == rps'
thisModule rps (Qualified2 _ _ _) = False                -- FIXME: ??
thisModule rps (Qualified3 _ _ _ _) = False


{- |
Basically transform the importState into a renameState
-}
is2rs :: Flags 
      -> PackedString 
      -> (TokenId -> [TokenId]) 
      -> ((TokenId->Bool) -> a {- TokenId -> IdKind -> IE -}) 
      -> Overlap
      -> ImportState 
      -> Either [Error] 
                (TokenId -> TokenId
                ,a
                ,RenameState
                ,Map.Map (TokenId, IdKind) (Either [Pos] [Id])
                )

is2rs flags mrps qualFun expFun overlap 
  (ImportState visible unique orps rps needI irt st insts fixity errors) =
--case treeMapList undef irt of
--  [] ->
--    case foldls reorderFun (treeMap ( \ (k,Right (v:_)) -> (k,v)) irt
--                           ,addAT initAT ignore unique minfo)
--                           (listAT st) of
--      (rt,ts) ->
--          Right (qualFun
--                ,expFun (\_->False)
--                ,RenameState flags (unique+1) (unique,pmrps) [] rt ts []
--                   Nothing errors []
--                ,irt)
--  xs -> Left (map err1 xs)
  case deAlias qualFun overlap irt of
    ([],qf) ->
      case foldls reorderFun 
             (Map.map deRight irt,Map.singleton unique minfo) 
             (Map.toList st) of
        (rt,ts) ->
            Right (qf
                  ,expFun (\_->False)
                  ,RenameState flags (succ unique) (unique,pmrps) [] rt ts [] 
                     Nothing errors []
                  ,irt)
    (xs,_) -> Left $ map ErrorRaw xs
 where
  deRight (Right (v:_)) = v
  deRight (Left _)      = error ("Tripped over aliased identifier")
  pmrps = if (isPrelude . reverse . unpackPS) mrps then rpsPrelude else mrps
  mtid = Visible pmrps
  minfo = InfoName unique mtid 0 mtid False --PHtprof

  reorderFun (rt,at) (key,info) =
    let u = uniqueI info
        rt' = if thisModule rps (fst key) then
                Map.insertWith ignore key u rt
              else
                rt
    in seq rt' (rt',Map.insertWith ignore u info at)

  ignore a b = b  -- Happens due to mutally recursive modules

--  undef (key,Left poss) err = Left (key,poss) : err
--  undef (key,Right [x]) err = err
--  undef (key,Right (x:xs)) err =
--      if all (x==) xs then  --- Tuples are entered twice
--          err
--      else
--        Right (key,x:xs) : err
--
--  err1 (Left ((tid,Method),poss)) =
--      "The identifier " ++ show tid ++ " instantiated at " ++
--       mix "," (map strPos poss) ++ " does not belong to this class."
--  err1 (Left ((tid,kind),poss)) =
--      show kind ++ ' ':show tid ++ " used at " ++
--      mix "," (map strPos poss) ++ " is not defined."
--  err1 (Right ((tid,kind),xs)) =
--      show kind ++ ' ':show tid ++
--      " defined " ++ show (length xs) ++ " times."


--fixFixityRS ::
--    RenameState ->
--    [(InfixClass TokenId, Int, [FixId TokenId])] ->
--    (TokenId -> (InfixClass TokenId, Int), RenameState)
--
--fixFixityRS (RenameState flags unique irps@(_,rps) rts rt st
--        derived defaults errors needCheck) fixdecls =
-- case foldr (fixOne rps) (initAT,[]) fixdecls of
--  (fixAT,err) -> (fixFun fixAT
--                 ,RenameState flags unique irps rts rt st
--                      derived defaults (err++errors) needCheck)

-- Changed in H98 to:
fixFixityRS ::
    (TokenId -> (InfixClass TokenId, Int)) ->
    RenameState ->
    [(InfixClass TokenId, Int, [FixId TokenId])] ->
    (TokenId -> (InfixClass TokenId, Int), RenameState)

fixFixityRS oldfix rs [] = (oldfix,rs)
fixFixityRS oldfix (RenameState flags unique irps@(_,rps) rts rt st
        derived defaults errors needCheck) fixdecls =
 case foldr (fixOne rps) (Map.empty,[]) fixdecls of
  (fixAT,err) -> (fixFun fixAT oldfix
                 ,RenameState flags unique irps rts rt st
                      derived defaults (err++errors) needCheck)

--------------------  End duplication


getSymbolTableRS :: RenameState -> Map.Map Id Info
getSymbolTableRS (RenameState flags unique rps rts rt st
                              derived defaults errors needCheck) =
  st


getErrorsRS :: RenameState -> (RenameState,[Error])
getErrorsRS (RenameState flags unique rps rts rt st
                         derived defaults errors needCheck) =
  (RenameState flags unique rps rts rt st derived defaults [] needCheck
  ,errors)


pushScope :: a -> RenameState -> RenameState
pushScope _ (RenameState flags unique rps rts rt st
                         derived defaults errors needCheck) =
  RenameState flags unique rps (rt:rts) Map.empty st derived
              defaults errors needCheck


popScope :: a -> (b,RenameState) -> (b,RenameState)
popScope _ (res, RenameState flags unique rps (rt:rts) _ st
                             derived defaults errors needCheck) =
  (res
  ,RenameState flags unique rps rts rt st derived defaults errors needCheck)


renameError :: Error -> a -> RenameMonad a
renameError err r fix (RenameState flags unique rps rst rt st
                                   derived defaults errors needCheck) =
  (r
  ,RenameState flags unique rps rst rt st derived
               defaults (err:errors) needCheck)


{- |
Looks up identifier (given as token,kind) in list of trees.
Returns first entry found.
-}
lookupAll :: [Map.Map (TokenId,IdKind) Id] -> (TokenId,IdKind) -> Maybe Id
lookupAll [] key = Nothing
lookupAll (t:ts) key =
  case Map.lookup key t of
    Nothing -> lookupAll ts key
    just -> just


{- |
Looks up id in rename table for identifier given through its kind and token.
If no entry exists, new id is created but appropriate error message added to
rename state.
-}
uniqueTid :: Pos -> IdKind -> TokenId -> RenameMonad Id
uniqueTid pos kind tid down 
          renameState@(RenameState flags unique rps rts rt st derived defaults 
                                   errors needCheck) =
  let key =  (sQual down tid,kind)
  in case lookupAll (rt:rts) key of 
       Just u -> (u,renameState)
       Nothing -> (unique, RenameState flags (succ unique) rps rts
                             (Map.insert key unique rt)
                             st derived defaults
                             ((ErrorRaw $ "Unbound " ++ show kind ++ " " ++ show tid ++ 
                               " at " ++ strPos pos ++ "\n\n" ++ 
                               show (rt:rts)) : errors)
                             needCheck)


fixTid :: IdKind -> TokenId -> RenameMonad (InfixClass TokenId,Int)
fixTid kind tid down 
       renameState@(RenameState flags unique rps rts rt st derived defaults 
                                errors needCheck) =
  let key =  (sQual down tid,kind)  --- !!! check if real name !!!
  in case lookupAll (rt:rts) key of
       Just u ->
         case Map.lookup u st of
           Nothing ->
               (sFix down (ensureM (snd rps) (fst key)),renameState) -- hack
               -- old code    ((InfixL,9::Int),renameState) 
               -- It's an argument, and I have lost the fixity information :-(
           Just info ->  (fixityI info,renameState)
       Nothing   ->
               (sFix down (ensureM (snd rps) (fst key)),renameState) -- hack
               -- old code    ((InfixL,9::Int),renameState)
        

{- |
Adds the the given identifier (position, kind of id, token with name)
to the active names in renameState.
Adds error to renameState, if identifier is already an active name,
that is, redefinition occurred.
-}
bindTid :: Pos -> IdKind -> TokenId -> a -> RenameState -> RenameState
bindTid pos kind tid _ 
        renameState@(RenameState flags unique irps@(_,rps) rts rt st derived 
                                 defaults errors needCheck) =
  let key =  (tid,kind)
      redefinedGlobal [rt] = Map.lookup (forceM rps tid,kind) rt
      redefinedGlobal _ = Nothing
  in case Map.lookup key rt of 
       Just u -> 
          (RenameState flags unique irps rts rt st derived defaults
             ((ErrorRaw $ "Redefinition of " ++ show kind ++ " " ++ show tid
               ++ " at " ++ strPos pos) : errors)
             needCheck)
       Nothing   ->
         case redefinedGlobal rts of
           Nothing ->
             (RenameState flags (succ unique) irps rts
                          (Map.insert key unique rt)
                          st derived defaults errors needCheck)
           Just u -> 
             (if sRedefine flags 
                then id 
                else
                  strace ("Warning: " ++ show tid 
                          ++ " is both imported and defined")) $
                  (RenameState flags unique irps rts
                               (Map.insert key u rt) -- catch same scope redef
                               (Map.update (Just . clearI) u st) derived defaults
                               errors needCheck)


bindNK :: Pos -> RenameMonad TokenId
bindNK pos _ renameState@(RenameState flags unique irps@(_,rps) rts rt st
                                      derived defaults errors needCheck) =
  let tid = visible (show unique)
      key = (tid,Var)
  in if sNplusK flags then
       case lookupAll (rt:rts) key of
         Nothing-> (tid
                   ,RenameState flags (succ unique) irps rts
                                (Map.insert key unique rt)
                                st
                                -- (addAT st (\a b->b) unique
                                --     (InfoUsed unique [(Var,tid,rps,pos)]))
                                -- (addAT st (\a b->b) unique
                                --     (InfoName unique tid 0 tid))
                                -- (addAT st (\a b->b) unique
                                --     (InfoVar unique tid IEall (InfixDef,9)
                                --              (NewType [] [] [] [NTany 0])
                                --              (Just 0)))
                                derived defaults errors needCheck)
         Just u -> (tid
                   ,RenameState flags (succ unique) irps rts
                                (Map.insert key unique rt)
                                st derived defaults
                                ((ErrorRaw $ "Binding (n+k) pattern to new unique "++
                                  "identifier at "++strPos pos): errors)
				needCheck)
     else (tid
          ,RenameState flags (succ unique) irps rts
		       (Map.insert key unique rt)
		       st derived defaults
                       ((ErrorRaw $ "(n+k) patterns are disabled - pattern at "++
                         strPos pos): errors)
		       needCheck)

checkPuns :: Pos -> t -> RenameState -> RenameState
checkPuns pos down renameState@(RenameState flags unique irps rts rt st
                                   derived defaults errors needCheck) =
  if sPuns flags then
    renameState
  else
    RenameState flags unique irps rts rt st derived defaults
                ((ErrorRaw $ "Named field puns are not Haskell'98 - used at "++
                  strPos pos):errors)
                needCheck


{- |
Checks if given identifier (kind, token) is already known as active name.
It is used to check if a field have already been included in the bindings
-}
checkTid :: Pos -> IdKind -> TokenId -> RenameRMonad a Bool
checkTid pos kind tid _ renameState@(RenameState flags unique rps rts rt st
                                        derived defaults errors needCheck) =
  let key =  (tid,kind)
  in  case Map.lookup key rt of 
        Just u -> (True,renameState)
        Nothing -> (False,renameState)

---- =================

{- |
This function makes use of the ability of NewType to contain several types.
-}
transTypes :: [(TokenId,Id)] 
           -> [Id] 
           -> [Context TokenId] 
           -> [Type TokenId]
           -> RenameMonad NewType

transTypes al free ctxs ts =
  unitS (NewType free []) =>>> 
  mapS (transContext al) ctxs =>>> 
  mapS (transType al) ts

transTVar :: Pos
             -> [(TokenId, Id)]
             -> TokenId
             -> RenameMonad NT
transTVar pos al v =
  unitS mkNTvar =>>> uniqueTVar pos al v        -- no KIND inference

uniqueTVar :: (Eq a, Show a) =>
              Pos
              -> [(a, Id)]
              -> a
              -> RenameMonad Id
uniqueTVar pos al v =
  case lookup v al of
    Just v -> unitS v
    Nothing -> renameError (ErrorRaw $ "Unbound type variable " ++ show v ++ " at " 
                            ++ strPos pos) undefined

transContext :: [(TokenId,Id)] -> Context TokenId -> RenameMonad (Id, Id)
transContext al (Context pos cid [(vpos,vid)]) = 
  unitS pair =>>> uniqueTid pos TClass cid =>>> uniqueTVar vpos al vid


transType :: [(TokenId,Id)] -> Type TokenId -> RenameMonad NT

transType al (TypeApp  t1 t2) = 
  unitS NTapp =>>> transType al t1 =>>> transType al t2
transType al (TypeCons  pos hs types) = 
  unitS mkNTcons =>>> uniqueTid pos TCon hs =>>> mapS (transType al) types
transType al (TypeVar   pos v) = transTVar pos al v
transType al (TypeStrict pos t) = unitS NTstrict =>>> transType al t

----- ==================================

{- |
Adds list of default types to RenameState.
Checks for illegal types and redefinition, 
extending error messages appropriately.
-}
defineDefault :: [Type Id] -> a -> RenameState -> RenameState
defineDefault types down (RenameState flags unique rps rts rt st
                                      derived Nothing errors needCheck) =
    case partition (\nt-> case nt of TypeCons _ _ [] -> True
                                     TypeApp _ _ -> True
                                     _ -> False) 
                   types of
      (cs,[]) -> 
        RenameState flags unique rps rts rt st derived 
          (Just (map getCon types)) errors needCheck
      (_,es) ->  
        RenameState flags unique rps rts rt st derived Nothing
          ((ErrorRaw ("Illegal type in default at " ++ strPos (getPos es))):errors) 
          needCheck
    where
    getCon (TypeCons _ con _) = con
    getCon (TypeApp tf ta) = getCon tf  -- not really sure about this.
defineDefault types down (RenameState flags unique rps rts rt st
                                      derived defaults errors needCheck) =
    RenameState flags unique rps rts rt st derived defaults 
      ((ErrorRaw ("Redefinition of defaults at " ++ strPos (getPos types))) :errors) 
      needCheck

{- |
Add a type synonym to symboltable. (It must be already in renaming table.)
-}
defineType :: TokenId      {- ^ type synonym -}
           -> NewType      {- ^ the type it is defined to denote -}
           -> RenameMonad Id  -- ^ id of the type synonym

defineType tid nt down (RenameState flags unique irps@(_,rps) rts rt st
                                    derived defaults errors needCheck) =
  let realtid = ensureM rps tid
      key = (tid,TSyn)
  in case Map.lookup key rt of
       Just u -> (u, RenameState flags unique irps rts rt
                         (Map.insertWith combInfo u {-(realtid,TSyn)-} 
                            (InfoData u realtid (sExp down tid TSyn) nt 
                               (DataTypeSynonym False 0)) st)
                         derived defaults errors (u:needCheck))


{- |
Add a class to symboltable. 
(It must be already in renaming table.)
Also checks for duplicate predicates in context (=> extend error messages)
-}
defineClass :: Pos
            -> TokenId 
            -> NewType  {- ^ pseudo type built from class and type variable
                           (type of dictionary?) -}
            -> [(Id,Id)] {- ^ (type info for method, default info for method) -}
            -> RenameToken
            -> RenameState 
            -> RenameState

defineClass pos tid nt mds down (RenameState flags unique irps@(_,rps)
                                             rts rt st derived defaults errors 
                                             needCheck) =
  let realtid = ensureM rps tid
      key = (tid,TClass)
      (ms,ds) = unzip mds
  in case Map.lookup key rt of
       Just u ->
        let newst = Map.insertWith combInfo u {-(realtid,TClass)-} 
                     (InfoClass u realtid (sExp down tid TSyn) nt ms ds Map.empty) st
        in case checkNT pos (strAT st) nt of
          Nothing -> 
            RenameState flags unique irps rts rt newst derived defaults 
              errors needCheck
          Just err -> 
             RenameState flags unique irps rts rt newst derived defaults 
               (ErrorRaw err:errors) needCheck


defineDataPrim :: TokenId -> NewType -> Int -> RenameMonad Id 
defineDataPrim tid nt size down (RenameState flags unique irps@(_,rps)
                                             rts rt st derived defaults errors 
                                             needCheck) =
  let realtid = ensureM rps tid
      key = (tid,TCon)
  in case Map.lookup key rt of
       Just u -> (u,RenameState flags unique irps rts rt 
                      (Map.insertWith combInfo u {-(realtid,TCon)-} 
                         (InfoData u realtid (sExp down tid TCon) nt 
                            (DataPrimitive size)) st)
                      derived defaults errors needCheck
                 )

{- |
   Add entry for data or newtype declaration to symboltable.
-}
defineData :: Maybe Bool {- ^ @Nothing@: newtype, @Just False@: data unboxed,
                            @Just True@: data (boxed) -}
           -> TokenId    {- ^ type constructor -}
           -> NewType    {- ^ defined type (coded with type variables) -}
           -> [Id]       {- ^ data constructors -} 
           -> RenameMonad Id

defineData d tid nt cs down (RenameState flags unique irps@(_,rps) rts rt st
                                     derived defaults errors needCheck)  =
  let realtid = ensureM rps tid
      key = (tid,TCon)
  in case Map.lookup key rt of
       Just u ->
         let (needCheck',dk,patch) =
                case d of
                  Just unboxed -> (needCheck,   Data unboxed cs,      id)
                  Nothing -> (u:needCheck, DataNewType False cs, patchIE)
                              -- unboxed fixed by keepRS
         in (u,RenameState flags unique irps rts rt 
                 (Map.insertWith combInfo u {-(realtid,TCon)-} 
                    (InfoData u realtid (patch (sExp down tid TCon)) nt dk) st)
                 derived defaults errors needCheck')


{- |
   Add entry for type declaration of given method to symboltable.
   Return identifier for this entry.
-}
defineMethod :: Pos     {- ^ position of type declaration -}
             -> TokenId {- ^ method id -} 
             -> NewType {- ^ method type -}
             -> Int     {- ^ method arity -} 
             -> Id      {- ^ class to which method belongs -} 
             -> TokenId {- ^ class name -} 
             -> RenameMonad Id

defineMethod pos tid nt arity classId ctid down
             (RenameState flags unique irps@(_,rps) rts rt st derived defaults 
                          errors needCheck) =
  let realtid = ensureM rps tid
      key = (tid,Method)
      rex = case sExp down ctid TClass of
                IEall -> IEsel
                IEabs -> IEnone
                _     -> sExp down tid Method
  in case Map.lookup key rt of
       Just u ->
         let newst = Map.insertWith combInfo u {-(realtid,Method)-} 
                       (InfoMethod u realtid rex (sFix down realtid) nt 
                         (Just arity) classId) st
         in case checkMNT nt of
              Nothing ->
                (u,RenameState flags unique irps rts rt newst derived defaults
                     errors needCheck)
              Just err ->
                (u,RenameState flags unique irps rts rt newst derived defaults
                     (ErrorRaw err:errors) needCheck)
  where
  checkMNT nt@(NewType free@(cv:_) [] ctxs nts) =
    case filter ((cv==) . snd) ctxs of
      [] -> checkNT pos (strAT st) nt
      [x] -> Just ("Illegal restriction " ++ strAT st (fst x) ++ 
                   " for type variable in type signature at " ++ strPos pos)
      xs -> Just ("Illegal restriction " ++ 
                  mixCommaAnd (map (strAT st . fst) xs) ++ 
                  " for type variable in type signature at " ++ strPos pos)



defineConstr :: TokenId -> TokenId -> NewType -> [Maybe Id] -> Id
             -> RenameMonad Id 
defineConstr typtid tid nt fields bt down
             (RenameState flags unique irps@(_,rps) rts rt st derived
                          defaults errors needCheck) = 
  let realtid = ensureM rps tid
      key = (tid,Con)
      rex = case sExp down typtid TCon of
                IEall -> IEsel
                IEabs -> IEnone
                _     -> sExp down tid Con
  in case Map.lookup key rt of
       Just u -> (u,RenameState flags unique irps rts rt
                         (Map.insertWith combInfo u {-(realtid,Con)-}
                             (InfoConstr u realtid rex (sFix down realtid)
                                         nt fields bt) st)
                         derived defaults errors needCheck)

defineField :: TokenId -> Id -> Id
               -> ((Maybe (Pos, TokenId, c), b), Int)
               -> (a, b1, TokenId -> IdKind -> IE, TokenId -> (InfixClass TokenId, Int))
               -> RenameState 
               -> (Maybe (Pos, Id, Id), RenameState)
defineField typtid bt c ((Nothing,_),_) down up = (Nothing,up)
defineField typtid bt c ((Just (p,tid,_),_),i) down
                        up@(RenameState flags unique irps@(_,rps) rts rt st
                                    derived defaults errors needCheck) = 
  let realtid = ensureM rps tid
      key = (tid,Field)
  in
    case Map.lookup key rt of
      Just u ->
        case Map.lookup u st of
          Just (InfoField u' realtid' ie cis' bt' iSel') ->
            if bt == bt'
            then (Nothing,RenameState flags unique irps rts rt
                             (Map.insertWith fstOf u' {-(realtid,Field)-}
                                 (InfoField u' realtid' ie
                                     ((c,i):cis') bt' iSel') st)
                             derived defaults errors needCheck)
            else (Nothing,RenameState flags unique irps rts rt st
                              derived defaults
                              ((ErrorRaw $ "Field " ++ show tid ++ " at " ++ strPos p ++
                                " is already defined"):errors)
                              needCheck)
          Just u -> (Nothing,up)
          Nothing ->
            case Map.lookup (tid,Var) rt of
              Just selu ->
                ( Just (p,u,selu)
                , RenameState flags unique irps rts rt
                              (Map.insertWith 
                                     combInfo selu
                                     (InfoVar selu realtid
                                          (case sExp down typtid TCon of
                                              IEall -> IEsel
                                           -- IEsome -> sExp down tid Field
                                           -- IEabs -> sExp down tid Var
                                              _     -> sExp down tid Var)
                                          (sFix down realtid)
                                          NoType (Just 1))
                                     (Map.insertWith combInfo u {-(realtid,Field)-}
                                          (InfoField u realtid IEnone
                                              -- Var gives true IEinfo
                                              [(c,i)] bt selu) st)                                          
                              )
                              derived defaults errors needCheck)


{- | Creates token for instance methods for tuple type?
   Another nonsensicle application of tuple tokens...
   "gone wierd"
 -} 
localTid :: PackedString -> Id -> TokenId -> TokenId
localTid rps id tid = mkQual3 rps (Visible rps) (t_Tuple (fromEnum id)) tid


{- | if token is not qualified make it qualified with given module name -}
globalTid :: PackedString -> Id -> TokenId -> TokenId
globalTid rps id tid = ensureM rps tid


defineVar :: TokenId -> RenameMonad Id
defineVar tid  down (RenameState flags unique irps@(_,rps) rts rt st
                                 derived defaults errors needCheck) = 
  let key = (tid,Var)
  in case Map.lookup key rt of
       Just u ->
         let realtid = sLG down rps u tid
         in  (u,RenameState flags unique irps rts rt
                        (Map.insertWith combInfo u {-(realtid,Var)-}
                            (InfoVar u realtid (sExp down tid Var)
                                (sFix down (ensureM rps tid)) NoType Nothing) st)
                        derived defaults errors needCheck)


defineDefaultMethod :: TokenId -> RenameMonad Id
defineDefaultMethod tid  down (RenameState flags unique irps@(_,rps)
                                           rts rt st derived defaults
                                           errors needCheck) = 
  let realtid = mkQualD rps tid
      skey = (tid,Method)
  in case Map.lookup skey rt of
        Nothing -> error ("***defineDefaultMethod(1) " ++
                           show skey ++ "\n" ++ show rt)
        Just u ->
         case Map.lookup u st of 
           Nothing -> error ("***defineDefaultMethod(1) " ++
                              show skey ++ " " ++ show u ++ "\n" ++ show rt)
           Just (InfoMethod _ _ _ fix nt annot iClass) ->
             (unique,RenameState flags (succ unique) irps rts rt
                         (Map.insertWith combInfo  unique
                                {-(realtid,MethodDefault)-}
                                (InfoDMethod unique realtid nt annot iClass) st)
                         derived defaults errors needCheck)
           Just _ -> (unique
                     ,RenameState flags (succ unique) irps rts rt st derived
                       defaults 
                       ((ErrorRaw $ "Default method declared outside class: " ++ show tid)
                       :errors) needCheck)


defineInstMethod :: TokenId -> RenameMonad Id
defineInstMethod tid  down (RenameState flags unique irps@(_,rps)
                                        rts rt st derived defaults
                                        errors needCheck) = 
  let realtid = mkQual2 rps (t_Tuple (fromEnum unique)) (ensureM rps tid)
                -- this is obscure! why a tuple with the size of unique?
                -- FIXME: this does in fact make no sense! --SamB
  in (unique,RenameState flags (succ unique) irps rts rt
                 (Map.insertWith combInfo  unique {-(realtid,MethodInstance)-}
                        (InfoIMethod unique realtid NoType Nothing (toEnum 0::Id)) st)
                 derived defaults errors needCheck)


defineDerived :: Id -> [(Pos,Id)] -> a -> RenameState -> RenameState
defineDerived con posis down (RenameState flags unique rps rts rt st
                                   derived defaults errors needCheck) = 
  RenameState flags unique rps rts rt st ((con,posis):derived)
              defaults errors needCheck

strAT :: Ord a => Map.Map a Info -> a -> String
strAT st i = (show . tidI . fromJust . flip Map.lookup st) i


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.