-- | Needs 'IdSupply' badly!
module IExtract
( countArrows, defFixity, defFixFun, fixFun, fixOne, freeType
, iextractClass
, iextractData, iextractDataPrim, iextractInstance, iextractType
, iextractVarsType
, addPreludeTupleInstances
, needFixity, tvrPosTids, tvPosTids, tvTids
-- re-exported from ImportState
, getNeedIS,putModidIS
) where
import List
import TokenId(TokenId(..),t_Arrow,ensureM,dropM,forceM,rpsPrelude
,tEq,tOrd,tBounded,tRead,tShow,visible,tUnknown,tunknown)
import State
import IdKind
import Util.Extra
import qualified Data.Map as Map
import qualified Data.Set as Set
import SysDeps(PackedString,packString)
import NT
import Syntax hiding (TokenId)
import ImportState hiding (TokenId)
import Id
import Maybe
import Error
--import PrettyLib -- debugging output only
--import PrettySyntax -- debugging output only
-- The spike doesn't disappear if rt' is forced, instead memory usage increases!
-- ===========================
needFixity :: [(InfixClass TokenId, Int, [FixId TokenId])] -> ImportState -> ImportState
needFixity inf (ImportState visible unique orpsl rpsl needI rt st
insts fixity errors) =
case foldr (fixOne orpsl) (Map.empty,[]) 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 :: Map.Map TokenId (InfixClass TokenId,Int)
-> (TokenId -> (InfixClass TokenId,Int))
-> (TokenId -> (InfixClass TokenId,Int))
fixFun fixAT f key =
case Map.lookup key fixAT of
Just fix -> fix
Nothing -> f key
defFixFun :: t -> (InfixClass a, Int)
defFixFun key = defFixity
defFixity :: (InfixClass a, Int)
defFixity = (InfixDef,9::Int)
fixOne :: (Show b, Eq b) =>
PackedString
-> (InfixClass TokenId, b, [FixId TokenId])
-> (Map.Map TokenId (InfixClass TokenId, b), [Error])
-> (Map.Map TokenId (InfixClass TokenId, b), [Error])
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)
fixTid :: PackedString -> FixId TokenId -> TokenId
fixTid rps (FixCon _ tid) = ensureM rps tid
fixTid rps (FixVar _ tid) = ensureM rps tid
fixAdd :: (Ord k, Eq a, Show k, Show a) =>
a -> k -> (Map.Map k a, [Error]) -> (Map.Map k a, [Error])
fixAdd fl tid fix_err@(fix,err) =
case Map.lookup tid fix of
Nothing -> (Map.insert tid fl fix,err)
Just fl' ->
if fl' == fl
then fix_err
else (fix,(ErrorConflictFixities (show tid) (show fl) (show fl') :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 down
importState@(ImportState { uniqueIS = unique,
sectionRpsIS = rps,
needIS = needI,
symtabIS = st }) =
let key = (ensureM rps tid,kind)
in case Map.lookup key st of
Just info -> (uniqueI info,importState)
Nothing -> (addNeedIS (fst key) >>>
addSymbolIS key (InfoUsed unique [(kind,tid,rps,pos)]) >>>
getUniqueId) down importState
{- | 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 Map.lookup key st of
Just info -> (True,importState)
Nothing -> (False,importState)
-- return nothing
importData :: (TokenId->Bool) -> TokenId -> IE -> NewType -> DataKind
-> State0 a ImportState ImportState
importData 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 Map.lookup key st of
Just (InfoUsed u _) ->
(addRT_IS visible q u tid orps TCon >>>
addSymbolIS key (InfoData u realtid exp nt dk))
Just info@(InfoData u tid exp' nt (Data unboxed []))
| case dk of {Data _ (_:_) -> True; _ -> False} ->
(addRT_IS visible q u tid orps TCon >>>
addSymbolIS key (InfoData u tid (combIE exp exp') nt dk))
Just info@(InfoData u tid exp' nt (DataNewType unboxed []))
| case dk of {DataNewType _ (_:_) -> True; _ -> False} ->
(addRT_IS visible q u tid orps TCon >>>
addSymbolIS key (InfoData u tid (combIE exp exp') nt dk))
Just info@(InfoData u' tid' exp' nt' dk') ->
(addRT_IS' visible q u' tid orps TCon >>>
addSymbolIS key (InfoData u' tid' (combIE exp exp') nt' dk'))
_ ->
(getUniqueId >>>= \ uid ->
addRT_IS visible q uid tid orps TCon >>>
addSymbolIS key (InfoData uid realtid exp nt dk))
) () importState
importClass :: (TokenId->Bool) -> TokenId -> IE -> NewType -> [Id]
-> State0 a ImportState ImportState
importClass 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 Map.lookup key st of
Just (InfoUsed u _) ->
(addRT_IS visible q u tid orps TClass >>>
addSymbolIS key (InfoClass u realtid exp nt ms [] Map.empty))
Just (InfoUsedClass u _ inst) ->
(addRT_IS visible q u tid orps TClass >>>
addSymbolIS key (InfoClass u realtid exp nt ms [] inst))
Just (InfoClass u tid' exp' nt' [] [] inst') ->
-- might be due to interface files
(addRT_IS visible q u tid orps TClass >>>
addSymbolIS key (InfoClass u realtid (combIE exp exp') nt ms [] inst'))
Just info ->
(addRT_IS' visible q (uniqueI info) tid orps TClass)
_ ->
(addRT_IS visible q unique tid orps TClass >>>
getUniqueId >>>= \ uid ->
addSymbolIS key (InfoClass uid realtid exp nt ms [] Map.empty))
) () importState
importField :: (TokenId->Bool)
-> [Id] -- ^ free type variables
-> [(Id,Id)] -- ^ type context (predicates)
-> Id -- ^ type constructor
-> Id -- ^ data constructor
-> ((Maybe (a,TokenId,b),NT),Int)
-> State0 c ImportState ImportState
importField q free ctxs bt c ((Nothing,_),nt) down importState = importState
importField 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 Map.lookup key st of
Just (InfoUsed u _) -> -- Selectors can never be InfoUsed
(getUniqueId >>>= \ uid ->
addRT_IS visible q uid tid orps Var >>>
addRT_IS visible q u tid orps Field >>>
addSymbolIS key (InfoField u realtid IEnone [(c,i)] bt uid) >>>
addSymbolIS (realtid,Var) (InfoVar unique realtid IEnone (fixity realtid)
(NewType free [] ctxs [mkNTcons bt (map mkNTvar free),nt])
(Just 1)))
() importState
Just (InfoField u' realtid' ie 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'
(Map.insertWith fstOf key -- update field name
(InfoField u' realtid' ie ((c,i):cis') bt' sel') st)
insts fixity errors))
_ ->
(getUniqueId >>>= \ fieldId ->
getUniqueId >>>= \ varId ->
addRT_IS visible q fieldId tid orps Field >>>
addRT_IS visible q varId tid orps Var >>>
addSymbolIS key (InfoField fieldId realtid IEnone [(c,i)] bt varId) >>>
addSymbolIS (realtid,Var) (InfoVar varId realtid IEnone (fixity realtid)
(NewType free [] ctxs [mkNTcons bt (map mkNTvar free),nt])
(Just 1)))
() importState
importVar :: (TokenId->Bool) -> TokenId -> IE -> NewType -> Maybe Int
-> State0 a ImportState ImportState
importVar 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 Map.lookup key st of
Just (InfoUsed u _) ->
let rt' = addRT visible q u tid orps Var rt
in addFixityNeed key fix
(ImportState visible unique orps rps needI rt'
(Map.insertWith combInfo key
(InfoVar u realtid exp fix nt
annots) st)
insts fixity errors)
Just info ->
let rt' = addRT visible 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 q unique tid orps Var rt
in addFixityNeed key fix
(ImportState visible (succ unique) orps rps needI rt'
(Map.insertWith combInfo key
(InfoVar unique realtid exp
fix nt annots) st)
insts fixity errors)
addFixityNeed :: (TokenId, IdKind) -> (InfixClass TokenId, b) -> ImportState -> ImportState
addFixityNeed key (InfixPre tid,_)
importState@(ImportState visible unique orps rps needI rt st
insts fixity errors) =
case Map.lookup key rt of -- We use this identifier
Just u ->
let irealtid = ensureM rps tid
ikey = (irealtid,snd key)
in
case Map.lookup ikey rt of -- so ensure that its replacement also exists,
-- and force the need for it, nice if we had
-- the real position but we don't.
Just u -> ImportState visible unique orps rps (Set.insert (fst ikey) needI)
rt st insts fixity errors
Nothing -> ImportState visible unique orps rps (Set.insert (fst ikey) needI)
(Map.insertWith fstOf ikey (Left [noPos]) rt)
st insts fixity errors
Nothing -> importState
addFixityNeed key inf importState = importState
--- returns unique int
importConstr :: (TokenId -> Bool)
-> TokenId -> NewType -> [Maybe Id] -> Id
-> IE
-> State t ImportState Id ImportState
importConstr q tid nt fields bt rex _
importState@(ImportState visible unique orps rps needI rt st
insts fixity errors) =
let realtid = ensureM rps tid
key = (realtid,Con)
in (case Map.lookup key st of
Just (InfoUsed u _) ->
addRT_IS visible q u tid orps Con >>>
addSymbolIS key (InfoConstr u realtid IEnone (fixity realtid)
nt fields bt) >>>
unitS u
Just info ->
let u = uniqueI info
in addRT_IS' visible q u tid orps Con >>>
unitS u
_ ->
getUniqueId >>>= \ uid ->
addRT_IS visible q uid tid orps Con >>>
addSymbolIS key (InfoConstr uid realtid rex
(fixity realtid) nt
fields bt) >>>
unitS uid
) () importState
importMethod :: (TokenId -> Bool)
-> TokenId -> NewType -> IE -> Maybe Int
-> Id -> t -> ImportState
-> (Id, ImportState)
importMethod q tid nt rex 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 Map.lookup key st of
Just (InfoUsed u _) ->
let rt' = addRT visible q u tid orps Method rt
in (u,addFixityNeed key fix
(ImportState visible unique orps rps needI rt'
(Map.insertWith combInfo key
(InfoMethod u realtid IEnone
fix nt annots bt) st)
insts fixity errors))
Just info ->
let u = uniqueI info
rt' = addRT visible 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 q unique tid orps Method rt
in (unique,addFixityNeed key fix
(ImportState visible (succ unique) orps rps
needI rt'
(Map.insertWith combInfo key
(InfoMethod unique realtid
rex fix nt
annots bt) st)
insts fixity errors))
importInstance :: Show a =>
a -> TokenId -> Id -> [Id] -> [(Id, Id)] -> t -> ImportState -> ImportState
importInstance mod cls con free ctxs _
importState@(ImportState visible unique orps rps needI rt st
insts fixity errors) =
let realtid = ensureM rps cls
key = (realtid,TClass)
mi = (packString . reverse . show) mod
in case Map.lookup key st of
Just info ->
case Map.insertWith fstOf key (addInstanceI con mi free ctxs info) st of
st' -> seq st' (ImportState visible unique orps rps needI rt st'
insts fixity errors)
storeInstance :: [(TokenId, Id)] -> TokenId -> TokenId -> TokenId
-> [Context TokenId] -> t
-> ImportState -> ImportState
storeInstance al mod cls con ctxs _
importState@(ImportState visible unique orps rps needI rt st
insts fixity errors) =
--strace ("storeInstance:\n "++prettyPrintSimple 70 ppContexts ctxs
-- ++"\n "++show cls
-- ++"\n "++show con) $
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 $ ErrorUnboundTypeInstance (strPos vpos) (show vid)
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
( (mod,realcls,realcon,map snd al,map dropRight qctxs)
:insts)
fixity errors
checkInstanceCls :: TokenId -> t -> ImportState
-> ([(TokenId, TokenId, TokenId, [Id], [(Pos, TokenId, Id)])], ImportState)
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 (mod,cls,con,free,ctxs) = (cls == realcls) && isJust (Map.lookup (con,TCon) st)
checkInstanceCon :: TokenId -> t -> ImportState
-> ([(TokenId, TokenId, TokenId, [Id], [(Pos, TokenId, Id)])], ImportState)
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 (mod,cls,con,free,ctxs) = (con == realcon)
-- if we need the type constructor, then we might need this instance
-- && isJust (Map.lookup (cls,TClass) st)
-- | Pseudo-monadic variant of 'addRT'
addRT_IS :: Bool -- ^ interface exports it?
-> (TokenId->Bool) -- ^ must it be imported qualified?
-> Id
-> TokenId
-> PackedString
-> IdKind
-> State0 a ImportState ImportState
addRT_IS iexports mustQualify u tid rps kind _ is =
is { renameIS = addRT iexports mustQualify u tid rps kind (renameIS is) }
-- | Strict version of 'addRT_IS'
addRT_IS' :: Bool -- ^ interface exports it?
-> (TokenId->Bool) -- ^ must it be imported qualified?
-> Id
-> TokenId
-> PackedString
-> IdKind
-> State0 a ImportState ImportState
addRT_IS' iexports mustQualify u tid rps kind _ is =
let rt = addRT iexports mustQualify u tid rps kind (renameIS is)
in rt `seq` is { renameIS = rt }
-- | Add (or not) an imported identifier to the renaming table.
addRT :: Bool -- ^ interface exports it?
-> (TokenId->Bool) -- ^ must it be imported qualified?
-> b
-> TokenId
-> PackedString
-> IdKind
-> Map.Map (TokenId,IdKind) (Either c [b])
-> Map.Map (TokenId,IdKind) (Either c [b])
addRT False _ _ tid _ _ rt = rt
addRT True mustQualify u tid rps kind rt
| mustQualify tid = qrt
| otherwise = Map.update (Just . combRT u) (dropM tid,kind) qrt
where
qrt = Map.update (Just . combRT u) (forceM rps tid,kind) rt
combRT u (Left _) = Right [u]
combRT u (Right us) = Right (u:us)
---- ==================================================
iextractType :: IE -> (Int,Bool) -> (TokenId->Bool) -> a -> TokenId
-> [(Pos,TokenId)] -> Type TokenId
-> State0 () ImportState ImportState
iextractType expInfo (depth,unboxed) q pos tid tvs typ =
let al = tvPosTids tvs
in transTypes al (map snd al) [] [typ] >>>= \ nt ->
importData 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 -> (TokenId->Bool) -> Either Bool Bool -> [Context TokenId]
-> Pos -> TokenId -> [(Pos,TokenId)] -> [Constr TokenId]
-> [TokenId] -> State0 () ImportState ImportState
iextractData expInfo q attr ctxs pos tid tvs constrs needs =
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 q al free ctxs needs (last nts)) constrs >>>= \cs ->
importData q tid -- expInfo nt
((case attr of
Left _ -> patchIE
_ -> id) expInfo)
nt
(case attr of
Right unboxed -> Data unboxed cs
Left unboxed -> DataNewType unboxed cs) >>>
checkInstanceCon tid >>>= \ newinsts ->
mapS0 newInstance newinsts
iextractDataPrim :: IE -> (TokenId->Bool) -> Pos -> TokenId -> Int
-> a -> ImportState -> ImportState
iextractDataPrim expInfo q pos tid size =
transTid pos TCon tid >>>= \ i ->
importData q tid expInfo (NewType [] [] [] [mkNTcons i []])
(DataPrimitive size) >>>
checkInstanceCon tid >>>= \ newinsts ->
mapS0 newInstance newinsts
iextractClass :: IE -> (TokenId->Bool) -> Pos -> [Context TokenId]
-> TokenId -> TokenId
-> [([((a,TokenId),b)],[Context TokenId],Type TokenId)]
-> [TokenId] -> () -> ImportState -> ImportState
iextractClass expInfo q pos ctxs tid tvar methods needs =
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 q tvar ctx needs) methods >>>= \ms ->
importClass q tid expInfo nt (concat ms) >>>
checkInstanceCls tid >>>= \ newinsts ->
mapS0 newInstance newinsts
newInstance :: (TokenId,TokenId,TokenId,[Id],[(Pos,TokenId,Id)])
-> a -> ImportState -> ImportState
newInstance (mod,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 mod realcls con free ctxs
iextractInstance :: TokenId -> [Context TokenId] -> a -> TokenId -> Type TokenId
-> () -> ImportState -> ImportState
-- iextractInstance ctxs pos cls typ@(TypeCons _ con _) =
iextractInstance mod ctxs pos cls typ =
let con = case typ of (TypeCons _ con _) -> con; (TypeVar _ con) -> con
in
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]
>>>= \nt->
case nt of
(NewType free [] ctxs [NTcons c _ nts]) ->
importInstance mod cls c free {- (map (\ (NTvar v _)->v) nts) -} ctxs
(NewType free [] ctxs [NTvar v _]) ->
importInstance mod cls v free ctxs
else
storeInstance al mod cls con ctxs -- otherwise save the instance for later
-- | @addPreludeTupleInstances@ is an efficiency hack.
-- It takes a long time to parse the Prelude.hi file, and adding large
-- numbers of tuple instances to the .hi file increases compile-times
-- by 30% or more.
-- Omitting them from the .hi file and adding them by hand here, therefore
-- gives a big time saving.
addPreludeTupleInstances :: () -> ImportState -> ImportState
addPreludeTupleInstances =
let mkCtx c v = Context noPos c [(noPos,v)]
tuple cls n = let vars = map (visible.(:[])) (take n ['a'..]) in
storeInstance (tvTids vars)
(Visible rpsPrelude)
cls
(TupleId n)
(map (mkCtx cls) vars)
in
mapS0 (tuple tEq) [2..15] >>>
mapS0 (tuple tOrd) [2..15] >>>
mapS0 (tuple tBounded) [2..15] >>>
mapS0 (tuple tRead) [2..15] >>>
mapS0 (tuple tShow) [2..15]
---
iextractVarsType :: ((TokenId -> Bool) -> TokenId -> IdKind -> IE)
-> (TokenId -> Bool)
-> [((a, TokenId), Maybe Int)]
-> [Context TokenId]
-> Type TokenId
-> State0 () ImportState ImportState
iextractVarsType expFun q postidanots ctxs typ =
let al = tvTids (snub (freeType typ))
in transTypes al (map snd al) ctxs [typ] >>>= \ nt ->
mapS0 (\((pos,tid),annots) ->
importVar q tid (expFun q tid Var) nt annots)
postidanots
---
transMethod :: (TokenId->Bool) -> TokenId -> (Id,Id) -> [TokenId]
-> ([((b,TokenId),c)],[Context TokenId],Type TokenId)
-> () -> ImportState -> ([Id],ImportState)
transMethod q tvar ctx@(c,tv) needed (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) ->
let (tid',rex) = if tid `elem` needed then (tid,IEsel)
else (tunknown,IEnone)
in importMethod q tid' nt rex (Just arity) c)
postidanots)
---
transConstr :: (TokenId->Bool) -> [(TokenId,Id)] -> [Id] -> [(Id,Id)]
-> [TokenId] -> NT -> Constr TokenId
-> () -> ImportState -> (Id,ImportState)
transConstr q al free ctxs needed 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
(cid',rex) = if cid `elem` needed then (cid, IEsel)
else (tUnknown bt, IEnone)
in
importConstr q cid' (NewType free [] ctxs (nts++[resType])) ifs bt rex
>>>= \c->
mapS0 (importField q free ctxs bt c) (zip all [ 1:: Int ..]) >>>
unitS c
transConstr q al free ctxs needed 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 [toEnum (1 + length al) .. ]
rex = if cid `elem` needed then IEsel else IEnone
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 q cid (NewType (map snd al ++ exist) exist ctxs
(map (\(c,v) -> NTcontext c v) ectxs
++ nts ++ [resType]))
ifs bt rex
>>>= \ c ->
mapS0 (importField q free ctxs bt c) (zip all [ 1:: Int ..]) >>>
unitS c
---
transFieldType :: [(TokenId,Id)] -> (Maybe [(Pos,TokenId)],Type TokenId)
-> () -> ImportState
-> ([(Maybe (Pos,TokenId,Id),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,Id)] -> [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,Id)] -> TokenId
-> () -> ImportState -> (NT,ImportState)
transTVar pos al v =
unitS mkNTvar =>>> uniqueTVar pos al v -- no KIND inference?
{- | transform syntactic type variable ('TokenId') into internal type variable
-- ('Id'), using the given mapping
-}
uniqueTVar :: Pos -> [(TokenId,Id)] -> TokenId
-> () -> ImportState -> (Id,ImportState)
uniqueTVar pos al v =
case lookup v al of
Just v -> unitS v
Nothing -> importError
(ErrorRaw $ "Unbound type variable " ++ show v ++ " at " ++ strPos pos)
(toEnum 0::Id)
{- | transform syntactic context into internal context -}
transContext :: [(TokenId,Id)] -> 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,Id)] -> 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 mkNTcons =>>> 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 [toEnum 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 [toEnum 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
----- ==================================
|
