IExtract

Plain source file: IExtract.hs (Jul 24, 2002)

IExtract is imported by: Export, Extract, FFITrans, Import, Main, PreImport, Rename, RenameLib. 

module IExtract
  ( countArrows, defFixity, defFixFun, fixFun, fixOne, freeType
  , iextractClass
  , iextractData, iextractDataPrim, iextractInstance, iextractType
  , iextractVarsType
  , needFixity, tvrPosTids, tvPosTids, tvTids
    -- re-exported from ImportState
  , getNeedIS,putModidIS
  ) where

import List
import TokenId(TokenId(..),t_Arrow,t_Tuple,ensureM,dropM,forceM,rpsPrelude)
import State
import IdKind
import Syntax
import Extra
import NeedLib
import AssocTree
import Memo
import PackedString(PackedString,packString,unpackPS)
import NT
import Syntax
import OsOnly(isPrelude)
import ImportState
import Id(Id)

-- The spike doesn't disappear if rt' is forced, instead memory usage increases!
--- ===========================
needFixity inf (ImportState visible unique orpsl rpsl needI rt st
                            insts fixity errors)  =
  case foldr (fixOne orpsl) (initAT,[]) inf of
			 -- fixity only at the beginning of interface file
    (fixAT,err) ->
	 ImportState visible unique orpsl rpsl needI rt st
                     insts (fixFun fixAT defFixFun) (err++errors)


---- fixFun :: AssocTree TokenId (InfixClass TokenId,Int) -> (TokenId -> (InfixClass TokenId,Int))
--fixFun fixAT key =  -- ensureM also done in fixOne dine
--  case lookupAT fixAT key of
--    Just fix -> fix
--    Nothing  -> defFixity

-- Changed in H98 to:
-- fixFun :: AssocTree TokenId (InfixClass TokenId,Int) ->
--                (TokenId -> (InfixClass TokenId,Int)) ->
--                (TokenId -> (InfixClass TokenId,Int))
fixFun fixAT f key =
  case lookupAT fixAT key of
    Just fix -> fix
    Nothing  -> f key

defFixFun key = defFixity
defFixity = (InfixDef,9::Int)


fixOne rps (InfixPre var,level,[fixid]) fix_err@(fix,err) =
					  -- ensureM also done in fixFun
  let fl = (InfixPre (ensureM rps var),level)
  in fixAdd fl (fixTid rps fixid) fix_err
fixOne rps (fixClass,level,ids) fixity_err =
  let fl = (fixClass,level)
  in foldr  (fixAdd fl) fixity_err (map (fixTid rps) ids)

changeType Infix = Infix
changeType InfixDef = InfixDef
changeType InfixL = InfixL
changeType InfixR = InfixR

fixTid rps (FixCon _ tid) = ensureM rps tid
fixTid rps (FixVar _ tid) = ensureM rps tid

fixAdd fl tid fix_err@(fix,err) =
 case lookupAT fix tid of
   Nothing -> (addAT fix sndOf tid fl,err)
   Just fl' ->
	if fl' == fl 
	then fix_err
	else (fix,(show tid ++ " has conflicting fixities (" ++ show fl
                   ++ " and " ++ show fl' ++ ")\n"):err)

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

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


{- Return Id for given token of given kind. If no Id exists then 
   create new Id -}

transTid :: Pos -> IdKind -> TokenId 
         -> a -> ImportState -> (Id,ImportState)

transTid pos kind tid _  
  importState@(ImportState visible unique orps rps needI rt st insts 
                 fixity errors) =
  let key =  (ensureM rps tid,kind)
  in  case lookupAT st key of 
        Just info -> (uniqueI info,importState)
        Nothing -> (unique, ImportState visible (unique+1) orps rps 
                              (addM needI key)
			      rt
			      (addAT st combInfo key 
                                (InfoUsed unique [(kind,tid,rps,pos)]))
                              insts fixity errors)



{- Test if Id for given token of given kind exists -}

existTid :: IdKind -> TokenId -> a -> ImportState -> (Bool,ImportState)

existTid kind tid _  
  importState@(ImportState visible unique orps rps needI rt st insts 
                 fixity errors) =
  let key =  (ensureM rps tid,kind)
  in  case lookupAT st key of 
        Just info -> (True,importState)
        Nothing   -> (False,importState)
	  

--  return nothing

importData :: Bool -> Bool -> TokenId -> IE -> NewType -> DataKind 
  -> a -> ImportState -> ImportState

importData v q tid expIn nt dk _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,TCon)
      exp = if visible then expIn else IEnone
  in case lookupAT st key of
       Just (InfoUsed u _) ->
	 let rt' = addRT visible v q u tid orps TCon rt
	 in (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoData u realtid exp nt dk)) insts fixity errors)
       Just info@(InfoData u tid exp' nt (Data unboxed [])) | case dk of {Data _ (_:_) -> True; _ -> False} ->
	 let rt' = addRT visible v q u tid orps TCon rt
	 in ImportState visible  unique orps rps needI rt' (addAT st combInfo key (InfoData u tid (combIE exp exp') nt dk)) insts fixity errors
       Just info@(InfoData u tid exp' nt (DataNewType unboxed [])) | case dk of {DataNewType _ (_:_) -> True; _ -> False} ->
	 let rt' = addRT visible v q u tid orps TCon rt
	 in ImportState visible  unique orps rps needI rt' (addAT st combInfo key (InfoData u tid (combIE exp exp') nt dk)) insts fixity errors
       Just info@(InfoData u' tid' exp' nt' dk') ->
	 let rt' = addRT visible v q u' tid orps TCon rt
	 in  seq rt' (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoData u' tid' (combIE exp exp') nt' dk')) insts fixity errors)
       _ -> 
	 let rt' = addRT visible v q unique tid orps TCon rt
	 in (ImportState visible (unique+1) orps rps needI rt'
			(addAT st combInfo key (InfoData unique realtid exp nt dk)) insts fixity errors)


importClass :: Bool -> Bool -> TokenId -> IE -> NewType -> [Id] 
            -> a -> ImportState -> ImportState

importClass v q tid expIn nt ms _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,TClass)
      exp = if visible then expIn else IEnone
  in case lookupAT st key of
       Just (InfoUsed u _) ->
	 let rt' = addRT visible v q u tid orps TClass rt
	 in (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoClass u realtid exp nt ms [] initAT)) insts fixity errors)
       Just (InfoUsedClass u _ inst) ->
	 let rt' = addRT visible v q u tid orps TClass rt
	 in (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoClass u realtid exp nt ms [] inst)) insts fixity errors)
       Just (InfoClass u tid' exp' nt' [] [] inst') -> -- might be due to interface files
	 let rt' = addRT visible v q u tid orps TClass rt
	 in (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoClass u realtid (combIE exp exp') nt ms [] inst')) insts fixity errors)
       Just info ->
	 let rt' = addRT visible v q (uniqueI info) tid orps TClass rt
	 in  seq rt' (ImportState visible unique orps rps needI rt' st insts fixity errors)
       _ ->
	 let rt' = addRT visible v q unique tid orps TClass rt
	 in (ImportState visible (unique+1) orps rps needI rt'
			(addAT st combInfo key (InfoClass unique realtid exp nt ms [] initAT)) insts fixity errors)


importField :: Bool -> Bool 
            -> [Id] -- free type variables 
            -> [(Id,Id)]  -- type context (predicates)
            -> Id  -- type constructor 
            -> Id  -- data constructor
            -> ((Maybe (a,TokenId,b),NT),Int) 
            -> c -> ImportState -> ImportState

importField v q free ctxs bt c ((Nothing,_),nt) down importState = importState
importField v q free ctxs bt c ((Just (p,tid,_),nt),i) down 
  importState@(ImportState visible unique orps rps needI rt st insts 
                 fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,Field)
  in case lookupAT st key of
       Just (InfoUsed u _) -> -- Selectors can never be InfoUsed
	 let rt' = addRT visible v q unique tid orps Var 
                     (addRT visible v q u tid orps Field rt)
	 in (ImportState visible (unique+1) orps rps needI rt' 
              (addAT -- add field name
                (addAT st combInfo (realtid,Var) -- add selector
		  (InfoVar  unique realtid (fixity realtid) IEnone 
                    (NewType free [] ctxs [NTcons bt (map NTvar free),nt]) 
                    (Just 1)))
		combInfo key (InfoField u realtid [(c,i)] bt unique)) 
              insts fixity errors)
       Just (InfoField u' realtid' cis' bt' sel') -> 
	 let rt' =  rt
	 in  seq rt' ( -- $ here doesn't work, there is an error somwhere !!!
	   if (c,i) `elem` cis'
	   then (ImportState visible unique orps rps needI rt' st insts 
                  fixity errors)  -- unchanged, just a bit strict
	   else (ImportState visible unique orps rps needI rt' 
                  (addAT st fstOf key -- update field name 
                    (InfoField u' realtid' ((c,i):cis') bt' sel')) 
                    insts fixity errors))
       _ -> 
	 let rt' = addRT visible v q (unique+1) tid orps Var 
                     (addRT visible v q unique tid orps Field rt)
	 in (ImportState visible (unique+2) orps rps needI rt'
	      (addAT -- add field name
                (addAT st combInfo (realtid,Var) -- add selector
		  (InfoVar  (unique+1) realtid (fixity realtid) IEnone 
                    (NewType free [] ctxs [NTcons bt (map NTvar free),nt]) 
                    (Just 1)))
		combInfo key (InfoField unique realtid [(c,i)] bt (unique+1)))
              insts fixity errors)


importVar :: Bool -> Bool -> TokenId -> IE -> NewType -> Maybe Int 
          -> a -> ImportState -> ImportState

importVar v q tid exp nt annots _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,Var)
      fix = fixity realtid
  in case lookupAT st key of
       Just (InfoUsed u _) ->
	 let rt' = addRT visible v q u tid orps Var rt
	 in addFixityNeed key fix (ImportState visible unique orps rps needI rt' 
		(addAT st combInfo key (InfoVar  u realtid fix exp nt annots)) insts fixity errors)
       Just info ->
	 let rt' = addRT visible v q (uniqueI info) tid orps Var rt
	 in  seq rt' (ImportState visible unique orps rps needI rt' st insts fixity errors)
       _ ->  
	 let rt' = addRT visible v q unique tid orps Var rt
	 in addFixityNeed key fix (ImportState visible (unique+1) orps rps needI rt'
		(addAT st combInfo key (InfoVar  unique realtid fix exp nt annots)) insts fixity errors)


addFixityNeed key (InfixPre tid,_) importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  case lookupAT rt key of  -- We use this identifier
    Just u ->
      let irealtid = ensureM rps tid
	  ikey = (irealtid,snd key)
      in
	case lookupAT rt ikey of -- so ensure that it's replacement also exist, and force the need for it, nice if we had the real position but we don't
          Just u -> ImportState visible unique orps rps (addM needI ikey) rt st insts fixity errors
          Nothing -> ImportState visible unique orps rps (addM needI ikey) (addAT rt fstOf ikey (Left [noPos])) st insts fixity errors
    Nothing -> importState
addFixityNeed key inf importState = importState

--- returns unique int

importConstr v q tid nt fields bt _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,Con)
  in case lookupAT st key of
       Just (InfoUsed u _) ->
	 let rt' = addRT visible v q u tid orps Con rt
	 in (u,ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoConstr  u realtid (fixity realtid) nt fields bt)) insts fixity errors)
       Just info ->
	 let u = uniqueI info
	     rt' = addRT visible v q u tid orps Con rt
	 in  seq rt' (u,ImportState visible unique orps rps needI rt' st insts fixity errors)
       _ -> 
	 let rt' = addRT visible v q unique tid orps Con rt
	 in (unique,ImportState visible (unique+1) orps rps needI rt'
				(addAT st combInfo key (InfoConstr unique realtid (fixity realtid) nt fields bt)) insts fixity errors)

importMethod v q tid nt annots bt _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps tid
      key = (realtid,Method)
      fix = fixity realtid
  in case lookupAT st key of
       Just (InfoUsed u _) ->
	 let rt' = addRT visible v q u tid orps Method rt
	 in (u,addFixityNeed key fix (ImportState visible unique orps rps needI rt' (addAT st combInfo key (InfoMethod u realtid fix nt annots bt)) insts fixity errors))
       Just info ->
	 let u = uniqueI info
	     rt' = addRT visible v q u tid orps Method rt
	 in  seq rt' (u,ImportState visible unique orps rps needI rt' st insts fixity errors)
       _ ->
	 let rt' = addRT visible v q unique tid orps Method rt
	 in (unique,addFixityNeed key fix (ImportState visible (unique+1) orps rps needI rt'
				(addAT st combInfo key (InfoMethod unique realtid fix nt annots bt)) insts fixity errors))

importInstance cls con free ctxs _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realtid = ensureM rps cls
      key = (realtid,TClass)
  in  case lookupAT st key of
	Just info -> 
	   case addAT st fstOf key (addInstanceI con free ctxs info) of
	      st' -> seq st' (ImportState visible unique orps rps needI rt st' insts fixity errors)

storeInstance al cls con ctxs _ importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  let realcls = ensureM rps cls
      realcon = ensureM rps con
      same (realcls',realcon',_,_) = realcls == realcls' && realcon == realcon'
      trans (Context pos cid (vpos,vid)) =
	case lookup vid al of
	  Just tvar -> Right (pos,ensureM rps cid,tvar)
	  Nothing -> Left ("Unbound type variable " ++ show vid ++ " in instance at " ++ strPos vpos)
  in if any same insts 
     then importState
     else
       let qctxs = map trans ctxs
       in if any isLeft qctxs
	  then ImportState visible unique orps rps needI rt st insts fixity ((map dropLeft . filter isLeft ) qctxs ++ errors) 
	  else ImportState visible unique orps rps needI rt st ((realcls,realcon,map snd al,map dropRight qctxs):insts) fixity errors

checkInstanceCls tid down importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  case partition pred insts of
   (used,unused) -> (used,ImportState visible unique orps rps needI rt st unused fixity errors)
 where  
  realcls = ensureM rps tid
  pred (cls,con,free,ctxs) = (cls == realcls) && isJust (lookupAT st (con,TCon))

checkInstanceCon tid down importState@(ImportState visible unique orps rps needI rt st insts fixity errors) =
  case partition pred insts of
   (used,unused) -> (used,ImportState visible unique orps rps needI rt st unused fixity errors)
 where  
  realcon = ensureM rps tid
  pred (cls,con,free,ctxs) = (con == realcon) -- if we need the type constructor, then we might need this instance --  && isJust (lookupAT st (cls,TClass))



 --   visible
 --        imported
 --              imported qualified 

addRT False _    _     _ _   _   _    rt = rt
addRT True False False u tid rps kind rt = rt
addRT True False True  u tid rps kind rt = updateAT rt (forceM rps tid,kind) (combRT u)
addRT True True  False u tid rps kind rt = updateAT rt (dropM tid     ,kind) (combRT u)
addRT True True  True  u tid rps kind rt = updateAT (updateAT rt (forceM rps tid,kind) (combRT u)) (dropM tid     ,kind) (combRT u)

combRT u (Left _) = Right [u]
combRT u (Right us) =  Right (u:us)


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

iextractType :: IE -> (Int,Bool) -> Bool -> Bool -> a -> TokenId 
             -> [(Pos,TokenId)] -> Type TokenId 
             -> () -> ImportState -> ImportState

iextractType expInfo (depth,unboxed) v q pos tid tvs typ = 
  let al = tvPosTids tvs
  in transTypes al (map snd al) [] [typ] >>>= \ nt ->
     importData v q tid expInfo nt (DataTypeSynonym unboxed depth)



{- extend importState by a new data type;
   the information about the data type comes from an interface file -}

iextractData :: IE -> Bool -> Bool -> Either Bool Bool -> [Context TokenId] 
             -> Int -> TokenId -> [(Pos,TokenId)] -> [Constr TokenId] 
             -> () -> ImportState -> ImportState

iextractData  expInfo v q attr ctxs pos tid tvs constrs = --- !!!!
  let al = tvPosTids tvs 
      free = map snd al
  in transTypes al free ctxs (map (uncurry TypeVar) tvs ++ [TypeCons pos tid (map (uncurry TypeVar) tvs)]) >>>= \ nt@(NewType free [] ctxs nts) ->
     mapS (transConstr v q al free ctxs (last nts)) constrs >>>= \cs ->
     importData v q tid expInfo nt 
       (case attr of
	  Right unboxed -> Data unboxed cs
	  Left  unboxed -> DataNewType unboxed cs) >>>
     checkInstanceCon tid >>>= \ newinsts ->
     mapS0 newInstance newinsts


iextractDataPrim :: IE -> Bool -> Bool -> Int -> TokenId -> Int 
                 -> a -> ImportState -> ImportState

iextractDataPrim expInfo v q pos tid size =
     transTid pos TCon tid >>>= \ i ->
     importData v q tid expInfo (NewType [] [] [] [NTcons i []]) (DataPrimitive size) >>>
     checkInstanceCon tid >>>= \ newinsts ->
     mapS0 newInstance newinsts


iextractClass :: IE -> Bool -> Bool -> Int -> [Context TokenId] 
              -> TokenId -> TokenId 
              -> [([((a,TokenId),b)],[Context TokenId],Type TokenId)] 
              -> () -> ImportState -> ImportState

iextractClass  expInfo v q pos ctxs tid tvar methods =
  let al = tvTids [tvar] 
  in transTypes al (map snd al) ctxs [TypeCons pos tid [TypeVar pos tvar]] >>>= \ nt -> 
     transContext al (Context pos tid (pos,tvar)) >>>= \ctx -> 
     mapS (transMethod v q tvar ctx) methods >>>= \ms ->
     importClass v q tid expInfo nt (concat ms) >>>
     checkInstanceCls tid >>>= \ newinsts ->
     mapS0 newInstance newinsts


newInstance :: (TokenId,TokenId,[Int],[(Int,TokenId,Int)]) 
            -> a -> ImportState -> ImportState

newInstance (realcls,realcon,free,ctxs) =
  mapS (\ (pos,cls,tvar) -> transTid pos TClass cls >>>= \ cls -> unitS (cls,tvar)) ctxs >>>= \ ctxs ->
  transTid noPos TCon realcon >>>= \ con ->
  transTid noPos TClass realcls >>>= \ _ ->  -- Only to ensure class exists!!
  importInstance realcls con free ctxs


iextractInstance :: [Context TokenId] -> a -> TokenId -> Type TokenId 
                 -> () -> ImportState -> ImportState

iextractInstance ctxs pos cls typ@(TypeCons _ con _) =
  existTid TClass cls >>>= \qcls ->
  existTid TCon con >>>= \qcon ->
  let al = tvTids (snub (freeType typ))
  in 
    if qcls -- || qcon    -- If both type class and data type exist, then add the instance to the type class
    then
      transTypes al (map snd al) ctxs [typ] >>>= \ (NewType free [] ctxs [NTcons c nts]) ->
      importInstance cls c free {- (map ( \ (NTvar v) -> v) nts) -} ctxs
    else
      storeInstance al cls con ctxs -- otherwise save the instance for later

iextractVarsType  expFun v q postidanots ctxs typ =
   let al = tvTids (snub (freeType typ))
   in transTypes al (map snd al) ctxs [typ] >>>= \ nt ->
      mapS0 ( \ ((pos,tid),annots) -> importVar v q tid (expFun v q tid Var) nt annots) postidanots




---

transMethod :: Bool -> Bool -> TokenId -> (Int,a) 
            -> ([((b,TokenId),c)],[Context TokenId],Type TokenId) 
            -> () -> ImportState -> ([Int],ImportState)

transMethod v q tvar ctx@(c,tv) (postidanots,ctxs,typ) =
   let al = tvTids (snub (tvar:freeType typ))
       arity = countArrows typ
   in mapS (transContext al) ctxs >>>= \ ctxs ->
      transType al typ >>>= \ typ ->
      let free = map snd al
	  nt = NewType free [] ctxs [anyNT [head free] typ]  -- The class context is not included in the type
      in seq arity  ( -- $ here doesn't work, there is an error somwhere !!!
		 mapS ( \ ((pos,tid),annot) -> importMethod v q tid nt (Just arity) c) postidanots)

---


transConstr :: Bool -> Bool -> [(TokenId,Int)] -> [Int] -> [(Id,Id)] 
            -> NT -> Constr TokenId 
            -> () -> ImportState -> (Int,ImportState)

transConstr v q al free ctxs resType@(NTcons bt _) (Constr pos cid types) = 
  mapS (transFieldType al) types >>>= \ntss ->
  let all = concat ntss
      nts = map snd all
      ifs = map 
              ((\ v -> case v of Just (p,tid,i) -> Just i; _ -> Nothing) . fst)
              all
  in
  importConstr v q cid (NewType free [] ctxs (nts++[resType])) ifs bt 
    >>>= \ c ->
  mapS0 (importField v q free ctxs bt c) (zip all [ 1:: Int ..]) >>>
  unitS c
transConstr v q al free ctxs resType@(NTcons bt _) 
  (ConstrCtx forall' ectxs' pos cid types) = 
  let ce = map ( \( Context _ _ (_,v)) -> v) ectxs'
      e =  map snd forall'
-- filter (`notElem` (map fst al)) $ snub $  (ce ++) $ concat $ map (freeType . snd) types
      es = zip e [1 + length al .. ]
  in
  mapS (transFieldType (es++al)) types >>>= \ntss ->
  let all = concat ntss
      nts = map snd all
      ifs = map 
              ((\ v -> case v of Just (p,tid,i) -> Just i; _ -> Nothing) . fst)
              all
      exist = map snd es
  in
  mapS (transContext (es++al)) ectxs' >>>= \ ectxs ->
  importConstr v q cid 
    (NewType (map snd al ++ exist) exist ctxs 
      (map ( \ (c,v) -> NTcontext c v) ectxs ++ nts++[resType])) ifs bt 
    >>>= \ c ->
  mapS0 (importField v q free ctxs bt c) (zip all [ 1:: Int ..]) >>>
  unitS c

---

transFieldType :: [(TokenId,Int)] -> (Maybe [(Int,TokenId)],Type TokenId) 
               -> () -> ImportState 
               -> ([(Maybe (Int,TokenId,Int),NT)],ImportState)

transFieldType al (Nothing,typ) =
  transType al typ >>>= \ typ -> unitS [(Nothing,typ)]
transFieldType al (Just posidents,typ) =
  transType al typ >>>= \ typ ->
  mapS ( \ (p,v) -> transTid p Field v >>>= \ i -> 
                    unitS (Just (p,v,i),typ))  posidents



{- transform a syntactic type with context into an internal NewType -}

transTypes :: [(TokenId,Int)] -> [Id] -> [Context TokenId] -> [Type TokenId] 
           -> () -> ImportState -> (NewType,ImportState)

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



{- transform a syntactic type variable (TokenId) into an internal type variable
   (NT), using the given mapping -}

transTVar :: Pos -> [(TokenId,Pos)] -> TokenId 
          -> () -> ImportState -> (NT,ImportState)

transTVar pos al v =
  unitS NTvar =>>> uniqueTVar pos al v



{- transform syntactic type variable (TokenId) into internal type variable
   (Id), using the given mapping -}

uniqueTVar :: Pos -> [(TokenId,Pos)] -> TokenId 
           -> () -> ImportState -> (Id,ImportState)

uniqueTVar pos al v =
  case lookup v al of
    Just v -> unitS v
    Nothing -> importError 
                 ("Unbound type variable " ++ show v ++ " at " ++ strPos pos) 
                 (0::Int)



{- transform syntactic context into internal context -}

transContext :: [(TokenId,Pos)] -> Context TokenId 
             -> () -> ImportState -> ((Id,Id),ImportState)

transContext al (Context pos cid (vpos,vid)) = 
  unitS pair =>>> transTid pos TClass cid =>>> uniqueTVar vpos al vid


countArrows :: Type TokenId -> Int

countArrows (TypeCons pos tid [a,f]) =
  if tid == t_Arrow 
  then 1 + countArrows f
  else 0
countArrows _ = 0::Int



{- transform a syntactic type into an internal NT type -}

transType :: [(TokenId,Int)] -> Type TokenId 
          -> () -> ImportState -> (NT,ImportState)

transType free (TypeApp  t1 t2) = 
  unitS NTapp =>>> transType free t1 =>>> transType free t2
transType free (TypeCons  pos hs types) = 
  unitS NTcons =>>> transTid pos TCon hs =>>> mapS (transType free) types
transType free (TypeVar   pos v)    = transTVar pos free v
transType free (TypeStrict pos typ) = unitS NTstrict =>>>  transType free typ

-----


{- 
Number the identifiers, beginning with 1.;
return the renaming mapping and the renamed list 
-}


tvrPosTids :: [(Pos,TokenId)] -> ([(TokenId,Id)], [(Pos, Id)])
tvrPosTids tv = (tvTids tokens, zip positions [1..])
  where
  (positions, tokens) = unzip tv



{- Number the identifiers, beginning with 1. First drop positions. -}

tvPosTids :: [(Pos,TokenId)] -> [(TokenId,Id)]
tvPosTids tv = tvTids (map snd tv)



{- Number the identifiers, beginning with 1. -}

tvTids :: [TokenId] -> [(TokenId,Id)]
tvTids tv = zip tv [1..] 

-----


{- Return a list of type variables occurring in the type. -}

freeType :: Type a -> [a]
freeType (TypeApp  t1 t2) =  freeType t1 ++ freeType t2
freeType (TypeCons  pos hs types) = concatMap freeType types
freeType (TypeVar   pos v)        = [v]
freeType (TypeStrict pos typ) = freeType typ


----- ==================================
Index

(HTML for this module was generated on May 15, 2003. About the conversion tool.)