{- ---------------------------------------------------------------------------
Perform "need" analysis (which imported entities are required?)
-}
module Need(Flags,Module,TokenId,NeedTable,HideDeclIds,PackedString,IdKind
,needProg) where
import qualified Data.Map as Map
import qualified Data.Set as Set
import Reduce
import NeedLib(NeedLib,initNeed,needit,popNeed,pushNeed,bindTid,needTid
,NeedTable,needQualify)
import Syntax
import IdKind
import PreImport(HideDeclIds,qualRename,preImport)
import TokenId
import TokenInt
import Flags(Flags)
import SyntaxPos
import Util.Extra
import SyntaxUtil(infixFun)
import Overlap(Overlap)
import Info(IE)
import SysDeps(PackedString)
needProg :: Flags
-> Module TokenId
-> ( NeedTable
, TokenId -> [TokenId]
, Overlap
, Either [Char]
( (TokenId->Bool) -> TokenId -> IdKind -> IE
, [ ( PackedString
, (PackedString, PackedString, Set.Set TokenId)
-> [[TokenId]] -> Bool
, HideDeclIds
)
]
)
)
needProg flags n@(Module pos modidl exports impdecls fixdecls topdecls) =
let qualFun = qualRename modidl impdecls
in case needit (needModule n) qualFun (initNeed (modidl == tMain)) of
(need,overlap) -> ( need
, qualFun
, overlap
, preImport flags modidl
(Set.fromList [i | ((i,_),_) <- Map.toList need])
exports impdecls
)
needModule :: Module TokenId -> NeedLib -> NeedLib
needModule (Module pos modid exports imports fixdecls topdecls) =
pushNeed >>>
bindDataDecls topdecls >>>
bindDecls topdecls >>>
pushNeed >>>
bindTid Modid modid >>>
mapR bindImport imports >>>
( case exports of
Nothing -> unitR
Just exps -> mapR needExport exps ) >>>
popNeed >>>
mapR needImport imports >>>
mapR needFixDecl fixdecls >>>
needDecls topdecls >>>
popNeed
-- ------------------------------
needExport :: Export TokenId -> NeedLib -> NeedLib
needExport (ExportEntity pos entity) =
needEntity id entity
needExport (ExportModid pos hs) =
needTid pos Modid hs
needEntity :: (TokenId->TokenId) -> Entity TokenId -> NeedLib -> NeedLib
needEntity q (EntityVar pos hs) = -- varid
needTid pos Var (q hs)
needEntity q (EntityConClsAll pos hs) = -- TyCon(..) | TyCls(..)
needTid pos TC (q hs)
needEntity q (EntityConClsSome pos hs posidents) = -- TC | TC(id0,id1,...)
needTid pos TC (q hs)
>>> needPosIdents q posidents
needPosIdents :: (TokenId->TokenId) -> [(Pos,TokenId)] -> NeedLib -> NeedLib
needPosIdents q posidents =
if any (isTidCon.snd) posidents then
mapR (\(pos,tid) -> if isTidCon tid then needTid pos Con (q tid)
else needTid pos Field (q tid))
posidents
else mapR (\(pos,tid) -> needTid pos Method (q tid)) posidents
-- could really be Method or Field.
-----------------------------------
--needImport (Import (pos,tid) impspec) =
-- {- needTid pos Modid tid >>> -} needImpSpec impspec
--needImport (ImportQ (pos,tid)) =
-- unitR -- needTid pos Modid tid
--needImport (ImportQas (pos,tid) (pos2,tid2)) =
-- unitR -- needTid pos Modid tid
needImport :: ImpDecl TokenId -> NeedLib -> NeedLib
needImport (Import (pos,tid) impspec) = needImpSpec id impspec
needImport (Importas (pos,tid) (pos2,tid2) impspec) = needImpSpec id impspec
needImport (ImportQ (pos,tid) impspec) =
needImpSpec (ensureM (extractV tid)) impspec
needImport (ImportQas (pos,tid) (pos2,tid2) impspec) =
needImpSpec (ensureM (extractV tid)) impspec
needImpSpec :: (TokenId->TokenId) -> ImpSpec TokenId -> NeedLib -> NeedLib
needImpSpec q (NoHiding entities) = mapR (needEntity q) entities
needImpSpec q (Hiding entities) = unitR
-----------------------------------
needFixDecl :: (InfixClass TokenId,a,[FixId TokenId]) -> NeedLib -> NeedLib
needFixDecl (InfixPre tid,level,posidents) =
needTid (getPos (head posidents)) Var tid >>> mapR needFixId posidents
needFixDecl (typeClass,level,posidents) =
mapR needFixId posidents
needFixId :: FixId TokenId -> NeedLib -> NeedLib
needFixId (FixCon pos tid) = needTid pos Con tid
needFixId (FixVar pos tid) = needTid pos Var tid
-----------------------------------
needDecls (DeclsParse decls) = mapR needDecl decls
-- type simple = type
needDecl (DeclType simple typ) =
pushNeed
>>> needSimple TSyn simple
>>> needType typ
>>> popNeed
-- data primitive type = size
needDecl (DeclDataPrim pos tid size) =
unitR
-- data context => simple = constrs deriving (tycls)
needDecl (DeclData b ctxs simple constrs posidents) =
mapR needCtx ctxs
>>> mapR needConstr constrs
>>> mapR needDeriving posidents
>>> unitR -- needTids (getPos simple) tokenEval
-- class context => class where { csign; valdef }
needDecl (DeclClass pos tctxs tClass tTVars fundeps (DeclsParse decls)) =
pushNeed
>>> mapR (bindTid TVar) tTVars
>>> mapR needCtx tctxs
>>> mapR needClassInst decls
>>> popNeed
-- instance context => tycls inst where { valdef }
needDecl (DeclInstance pos ctxs tClass insts (DeclsParse decls)) =
mapR needCtx ctxs
>>> mapR needType insts
>>> mapR needClassInst (map (needQualify tClass) decls)
>>> needTid pos TClass tClass
-- default (type,..)
needDecl (DeclDefault types) =
mapR needType types
-- vars :: context => type
needDecl (DeclVarsType posidents ctxs typ) =
mapR (\ (pos,tid) -> needTid pos Var tid) posidents
>>> mapR needCtx ctxs
>>> needType typ
needDecl (DeclPat (Alt pat@(ExpInfixList pos pats) rhs decls)) =
pushNeed
>>> bindPat pat -- Also generate need for constructors
>>> needExp pat
>>> bindDecls decls
>>> needRhs rhs
>>> needDecls decls
>>> popNeed
needDecl (DeclPat (Alt pat rhs decls)) =
needExp pat
>>> bindDecls decls
>>> needRhs rhs
>>> needDecls decls
needDecl (DeclFun pos hs funs) =
mapR needFun funs
needDecl (DeclPrimitive pos hs arity t) =
needType t
needDecl (DeclForeignImp pos _ _ hs arity cast t _) =
needType t
>>> needTids pos tokenFFI
needDecl (DeclForeignExp pos _ _ hs typ) =
needTid pos Var hs
>>> needType typ
>>> needTids pos tokenFFI
-- error ("\nAt "++ strPos pos ++ ", foreign export not supported.")
needDecl (DeclFixity f) =
needFixDecl f
-- Used for unimplemented things
needDecl d@(DeclIgnore str) = unitR
needDecl d@(DeclError str) = unitR
needDecl (DeclAnnot decl annots) = unitR
needDeriving (pos,tid)
| (ensureM rpsPrelude tid) == tBounded =
needTid pos TClass tid >>> needTids pos tokenBounded
| (ensureM rpsPrelude tid) == tEnum =
needTid pos TClass tid >>> needTids pos tokenEnum
| (ensureM rpsPrelude tid) == tEq =
needTid pos TClass tid >>> needTids pos tokenEq
| (ensureM rpsIx tid) == tIx =
needTid pos TClass tid >>> needTids pos tokenIx
| (ensureM rpsPrelude tid) == tOrd =
needTid pos TClass tid >>> needTids pos tokenOrd
| (ensureM rpsPrelude tid) == tRead =
needTid pos TClass tid >>> needTids pos tokenRead
| (ensureM rpsPrelude tid) == tShow =
needTid pos TClass tid >>> needTids pos tokenShow
| (ensureM rpsBinary tid) == tBinary =
needTid pos TClass tid >>> needTids pos tokenBinary
| True = strace ("Warning: Don't know what is needed to derive "
++ show tid ++ " at " ++ strPos pos ++"\n")
(needTid pos TClass tid)
needClassInst (DeclVarsType posidents ctxs typ) =
mapR needCtx ctxs
>>> needType typ
needClassInst (DeclPat (Alt (ExpVar pos fun) rhs decls)) =
needTid pos Method fun
>>> needFun (Fun [] rhs decls)
needClassInst (DeclPat (Alt (ExpInfixList pos es) rhs decls)) =
case infixFun es of
Just (pat1,pos',fun',pat2) ->
needTid pos Method fun'
>>> pushNeed
>>> bindPat pat1 >>> bindPat pat2
>>> bindDecls decls
>>> needExp pat1 >>> needExp pat2
>>> needRhs rhs
>>> needDecls decls
>>> popNeed
Nothing ->
error ("Sorry (infix) lhs-patterns doesn't work in instances " ++ strPos pos)
needClassInst (DeclPat (Alt pat gdexps decls)) =
error ("Sorry lhs-patterns doesn't work in instances " ++ strPos (getPos pat))
needClassInst (DeclFun pos fun funs) =
needTid pos Method fun
>>> mapR needFun funs
needClassInst (DeclAnnot decl annots) =
needClassInst decl
needClassInst (DeclFixity fixdecl) =
needFixDecl fixdecl
needFun (Fun pats rhs decls) =
pushNeed
>>> mapR bindPat pats -- Also generate need for constructors
>>> bindDecls decls
>>> needRhs rhs
>>> needDecls decls
>>> popNeed
needRhs (Unguarded exp) = needExp exp
needRhs (PatGuard gdexps) = mapR needPatGdExp gdexps
needPatGdExp (quals,exp) = needQuals quals >>> needExp exp
needAlt (Alt pat rhs decls) =
pushNeed
>>> bindPat pat -- Also generate need for constructors
>>> bindDecls decls
>>> needExp pat
>>> needRhs rhs
>>> needDecls decls
>>> popNeed
needType (TypeApp t1 t2) = needType t1 >>> needType t2
needType (TypeCons pos hs types) = needTid pos TCon hs >>> mapR needType types
needType (TypeVar pos hs) = unitR
needType (TypeStrict pos typ) = needType typ
needSimple kind (Simple pos hs posidents) = needTid pos kind hs -- posidents are typevariables!
needCtx (Context pos hs _) = needTid pos TClass hs
needConstr (Constr pos hs types) = mapR needFieldType types
needConstr (ConstrCtx forAll ctxs pos hs types) = mapR needCtx ctxs >>> mapR needFieldType types
needFieldType (_,typ) = needType typ
needStmts [] = unitR
needStmts (StmtExp exp:[]) = needExp exp
needStmts (StmtExp exp:r) = needTid (getPos exp) Var t_gtgt >>> needExp exp >>> needStmts r
needStmts (StmtBind pat exp:r) = needTid (getPos pat) Var t_gtgteq >>> needExp exp >>> pushNeed >>> bindPat pat >>> needStmts r >>> popNeed
needStmts (StmtLet decls :r) = pushNeed >>> bindDecls decls >>> needDecls decls >>> needStmts r >>> popNeed
-- for list comprehensions and pattern guards
needQuals [] = unitR
needQuals (QualExp exp:r) = needExp exp >>> needQuals r
needQuals (QualPatExp pat exp:r) =
needExp exp >>> bindPat pat >>> needExp pat >>> needQuals r
needQuals (QualLet decls :r) =
bindDecls decls >>> needDecls decls >>> needQuals r
needField (FieldExp pos var exp) = needTid pos Field var >>> needExp exp
needField (FieldPun pos var) = needTid pos Field var >>> needTid pos Var var
--needField (FieldPun pos var) = error ("\nAt "++ strPos pos ++ ", token: "++
-- show var ++
-- "\nPunning of named fields has been removed from the Haskell language."++
-- "\nUse "++show var++"="++show var++" instead.")
needExp :: Exp TokenId -> NeedLib -> NeedLib
needExp (ExpScc str exp) = needExp exp
needExp (ExpLambda pos pats exp) =
pushNeed >>> mapR bindPat pats >>> needExp exp >>> popNeed
needExp (ExpDo pos stmts) = needTids pos tokenMonad >>> needStmts stmts
needExp (ExpLet pos decls exp) =
pushNeed >>> bindDecls decls >>> needDecls decls >>> needExp exp >>> popNeed
needExp (ExpCase pos exp alts) = needExp exp >>> mapR needAlt alts
needExp (ExpIf pos expCond expThen expElse) =
needExp expCond >>> needExp expThen >>> needExp expElse
needExp (ExpRecord exp fields) = needExp exp >>> mapR needField fields
needExp (ExpType pos exp ctxs typ) =
needExp exp >>> mapR needCtx ctxs >>> needType typ
needExp (ExpListComp pos exp quals) =
needTids pos tokenComprehension >>>
pushNeed >>> needQuals quals >>> needExp exp >>> popNeed
needExp (ExpListEnum pos eFrom meThen meTo) =
needTids pos tokenEnum >>>
needExp eFrom >>> maybe unitR needExp meThen >>> maybe unitR needExp meTo
needExp (ExpBrack pos exp) = needExp exp
--- Above only in expressions
needExp (ExpApplication pos exps) = mapR needExp exps
needExp (ExpInfixList pos exps) = mapR needExp exps
needExp (ExpVar pos tid) = needTid pos Var tid
needExp (ExpCon pos tid) = needTid pos Con tid
needExp (ExpVarOp pos tid) = needTid pos Var tid
needExp (ExpConOp pos tid) = needTid pos Con tid
needExp e@(ExpLit pos (LitInteger _ _)) = needTids pos tokenInteger
needExp e@(ExpLit pos (LitRational _ _)) = needTids pos tokenRational
needExp e@(ExpLit pos lit) = unitR
needExp (ExpList pos exps) = mapR needExp exps
--- Below only in patterns
needExp (PatAs pos hs pat) = needTid pos Var hs >>> needExp pat
needExp (PatWildcard pos) = unitR
needExp (PatIrrefutable pos pat) = needExp pat
needExp (PatNplusK pos tid _ _ _ _) = needTid pos Var tid >>>
needTids pos tokenNplusK
----------- ========================
bindImport :: ImpDecl TokenId -> NeedLib -> NeedLib
bindImport (Import (pos,tid) impspec) =
bindTid Modid tid
bindImport (ImportQ (pos,tid) impspec) =
bindTid Modid tid
bindImport (ImportQas (pos,tid) (pos2,tid2) impspec) =
bindTid Modid tid >>> bindTid Modid tid2
bindImport (Importas (pos,tid) (pos2,tid2) impspec) =
bindTid Modid tid >>> bindTid Modid tid2
-- Hack to enforce that constructors are bound before need is checked
bindDataDecls :: Decls TokenId -> NeedLib -> NeedLib
bindDataDecls (DeclsParse decls) = mapR bindDataDecl decls
bindDataDecl (DeclType (Simple pos tid posidents) typ) = bindTid TSyn tid
bindDataDecl (DeclDataPrim pos tid size) = bindTid TCon tid
bindDataDecl (DeclData b ctxs (Simple pos tid posidents) constrs _) =
bindTid TCon tid >>> mapR bindConstr constrs
bindDataDecl _ = unitR
{-
Binds defined class identifiers and term variables,
not type constructors or data constructors, that is,
stores them in a memo inside needLib.
Used both in renaming and need analysis phase.
-}
bindDecls :: Decls TokenId -> NeedLib -> NeedLib
bindDecls (DeclsParse decls) = mapR bindDecl decls
bindDecl :: Decl TokenId -> Reduce NeedLib NeedLib
bindDecl (DeclType (Simple pos tid posidents) typ) = unitR
-- ABOVE: bindTid TSyn tid
bindDecl (DeclDataPrim pos tid size) = unitR -- bindTid TCon tid
bindDecl (DeclData b ctxs (Simple pos tid posidents) constrs _) = unitR
-- ABOVE: bindTid TCon tid >>> mapR bindConstr constrs
bindDecl (DeclClass pos tctxs tClass tTVars fundeps (DeclsParse decls)) =
bindTid TClass tClass >>> mapR bindClass decls
bindDecl (DeclInstance pos ctxs tClass inst (DeclsParse decls)) = unitR
bindDecl (DeclDefault types) = unitR
bindDecl (DeclVarsType posidents ctxs typ) = unitR
bindDecl (DeclPat (Alt pat@(ExpInfixList pos pats) _ _)) =
case filter isVarOp pats of
[ExpVarOp pos tid] -> bindTid Var tid
[] -> bindPat pat
_ -> error (show pos ++ ": (n+k) patterns are not supported\n")
bindDecl (DeclPat (Alt pat gdexps decls)) = bindPat pat
-- ABOVE: Also generate need for constructors
bindDecl (DeclPrimitive pos tid arity t) = bindTid Var tid
bindDecl (DeclForeignImp pos _ _ tid arity cast t _) = bindTid Var tid
bindDecl (DeclForeignExp pos _ _ tid t) = unitR
bindDecl (DeclFun pos tid funs) = bindTid Var tid
bindDecl d@(DeclIgnore str) = unitR
bindDecl d@(DeclError str) = unitR
bindDecl (DeclAnnot decl annots) = unitR
bindDecl (DeclFixity f) = unitR
bindConstr :: Constr TokenId -> NeedLib -> NeedLib
bindConstr (Constr pos hs ftypes) =
bindTid Con hs >>> mapR bindFieldType ftypes
bindConstr (ConstrCtx forAll ctxs pos hs ftypes) =
bindTid Con hs >>> mapR bindFieldType ftypes
bindFieldType (Nothing,_) = unitR
bindFieldType (Just posidents,_) =
mapR ( \ (p,v) -> bindTid Var v >>> bindTid Field v) posidents
bindClass :: Decl TokenId -> NeedLib -> NeedLib
bindClass (DeclVarsType posidents ctxs typ) =
mapR (bindTid Method . snd) posidents
bindClass _ = unitR
bindField :: Field TokenId -> NeedLib -> NeedLib
bindField (FieldExp pos var pat) =
needTid pos Field var >>> needTid pos Var var >>> bindPat pat
bindField (FieldPun pos var) = needTid pos Field var >>> bindTid Var var
--bindField (FieldPun pos var) = error ("\nAt "++ strPos pos ++ ", token: "++
-- show var ++
-- "\nPunning of named fields has been removed from the Haskell language."++
-- "\nUse "++show var++"="++show var++" instead.")
--- Above only in expressions
bindPat :: Exp TokenId -> NeedLib -> NeedLib
bindPat (ExpBrack pos exp) = bindPat exp
bindPat (ExpApplication pos exps) = mapR bindPat exps
bindPat (ExpInfixList pos (ExpVarOp _ op:pats)) = -- must be prefix -
needTid pos Var op >>> mapR bindPat pats
bindPat (ExpInfixList pos exps) = mapR bindPat exps
bindPat (ExpVar pos tid) = bindTid Var tid
bindPat (ExpCon pos tid) = needTid pos Con tid
bindPat (ExpVarOp pos tid) = bindTid Var tid
bindPat (ExpConOp pos tid) = needTid pos Con tid
bindPat e@(ExpLit pos (LitInteger _ _)) =
needTid pos Var t_equalequal >>> needTids pos tokenInteger
bindPat e@(ExpLit pos (LitRational _ _)) =
needTid pos Var t_equalequal >>> needTids pos tokenRational
bindPat e@(ExpLit pos lit) = unitR
bindPat (ExpList pos exps) = mapR bindPat exps
bindPat (ExpRecord pat fields) =
bindPat pat >>> mapR bindField fields -- pat is alwasy ExpCon
--- Below only in patterns
bindPat (PatAs pos hs pat) = bindTid Var hs >>> bindPat pat
bindPat (PatWildcard pos) = unitR
bindPat (PatIrrefutable pos pat) = bindPat pat
bindPat (PatNplusK pos tid _ _ _ _) = bindTid Var tid >>>
needTids pos tokenNplusK
bindPat pat = error ("Need.hs:bindPat @ "++show (getPos pat))
------
needTids :: Pos -> [(IdKind,TokenId)] -> NeedLib -> NeedLib
needTids pos kindtids = mapR (uncurry (needTid pos)) kindtids
isVarOp :: Exp a -> Bool
isVarOp (ExpVarOp _ _) = True
isVarOp _ = False
|
