{- --------------------------------------------------------------------------- extract: Adds arity of all defined variables to symbol table of internal state. Adds type of variables from type declarations and primitive and foreign function definitions to symbol table of internal state (but not type declarations from classes). Tests that there are not conflicting arities. Tests for instance definition: is it illegally made for a type synonym? does class require instances for superclasses which are not present? (Adds appropriate error message to internal state). type2NT transforms type from syntax tree into interal type. -} module Extract(IntState,Decls,extract,type2NT) where import Syntax(Type(..),Decls(..),Decl(..),Fun(..),Rhs(..),Exp(..),Stmt(..) ,Alt(..),Field(..),Qual(..)) import IntState(IntState,lookupIS,depthI,strIS,addError,superclassesI ,instancesI,updVarArity,updVarNT) import NT(NT(..),NewType(..),mkNTvar,mkNTcons) import Reduce(Reduce,mapR,unitR,(>>>)) import Rename(ctxs2NT) import IExtract(freeType) import Util.Extra(snub,strPos,mixLine,mixCommaAnd) import Bind(identPat) import SyntaxPos(Pos,HasPos(getPos)) import qualified Data.Map as Map import Id(Id) import Maybe {- transform type from syntax tree into internal type -} type2NT :: Type Id -> NT type2NT (TypeApp t1 t2) = NTapp (type2NT t1) (type2NT t2) type2NT (TypeCons _ ci ts) = mkNTcons ci (map type2NT ts) type2NT (TypeStrict _ t) = NTstrict (type2NT t) type2NT (TypeVar _ v) = mkNTvar v -- No KIND inference yet! {- -} extract :: Decls Id -> IntState -> IntState extract = extractDecls extractDecls :: Decls Id -> IntState -> IntState extractDecls (DeclsParse decls) = mapR extractDecl decls extractDecl :: Decl Id -> Reduce IntState IntState extractDecl (DeclInstance pos ctxs cls [instanceType@(TypeCons poscon con _)] instmethods) = (\ state -> if (isJust . depthI . fromJust . lookupIS state) con then addError state ("Instance declaration of type synonym is illegal (" ++ strIS state con ++ " at " ++ strPos poscon ++ ")") else case (filter (isNothing.snd) . map ( \ cls -> (cls,(Map.lookup con . instancesI . fromJust . lookupIS state) cls) ) . superclassesI . fromJust . lookupIS state) cls of [] -> state clss -> addError state ("Instance declaration for the class " ++ strIS state cls ++ " at " ++ strPos pos ++ " needs instance(s) of " ++ mixCommaAnd (map (strIS state . fst) clss) ++ " according to class declaration.") ) >>> extractDecls instmethods -- error if we find any type signatures extractDecl (DeclClass pos tctxs tClass tTVars fundeps (DeclsParse decls)) = mapR extractDecl' decls extractDecl (DeclPrimitive pos ident arity typ) = let nt = NewType (snub (freeType typ)) [] [] [type2NT typ] in updVarNT pos ident nt >>> updVarArity pos ident arity extractDecl (DeclForeignImp pos _ _ ident arity cast typ _) = unitR -- type extraction for ffi is now done earlier in FFITrans phase extractDecl (DeclForeignExp pos _ _ ident typ) = unitR -- type extraction for ffi is now done earlier in FFITrans phase --let nt = NewType (snub (freeType typ)) [] (ctxs2NT []) [type2NT typ] --in updVarNT pos ident nt extractDecl (DeclVarsType posidents ctxs typ) = let nt = NewType (snub (freeType typ)) [] (ctxs2NT ctxs) [type2NT typ] in mapR ( \ (pos,i) -> updVarNT pos i nt) posidents extractDecl (DeclPat alt) = extractDeclAlt alt extractDecl (DeclFun pos fun funs) = updFunArity pos fun funs >>> mapR extractFun funs extractDecl d = unitR {- extractDecl' is used in class declarations as we don't want to use top level signatures there why are the declared types not added to the symbol table? (OC) -} extractDecl' :: Decl Id -> Reduce IntState IntState extractDecl' (DeclPat alt) = extractDeclAlt alt extractDecl' (DeclFun pos fun funs) = updFunArity pos fun funs >>> mapR extractFun funs extractDecl' d = unitR {- Adds arity of defined variable to symbol table of internal state (any old arity is overwritten). Assumes that variable is already in symbol table. Adds error message, if equations of definition suggest different arities. -} updFunArity :: Pos -> Id -> [Fun a] -> Reduce IntState IntState updFunArity pos fun funs = case map fA funs of (a:xs) -> if all (a==) xs then updVarArity pos fun a else \ state -> addError state ("Multiple arities for " ++ strIS state fun ++ ": " ++ mixLine (map (\ (pos,a) -> " arity " ++ show a ++ " at " ++ strPos pos) (map fPA funs))) where fA (Fun args gdexps decls) = (length args) fPA (Fun args gdexps decls) = (getPos args,length args) extractFun :: Fun Id -> Reduce IntState IntState extractFun (Fun pats rhs decls) = extractRhs rhs >>> extractDecls decls extractRhs :: Rhs Id -> Reduce IntState IntState extractRhs (Unguarded exp) = extractExp exp extractRhs (PatGuard gdExps) = mapR extractPatGuardExp gdExps extractPatGuardExp :: ([Qual Id],Exp Id) -> Reduce IntState IntState extractPatGuardExp (quals,exp) = mapR extractQual quals >>> extractExp exp extractDeclAlt :: Alt Id -> IntState -> IntState extractDeclAlt (Alt pat rhs decls) = mapR ( \ (pos,ident) -> updVarArity pos ident 0) (identPat pat) >>> extractRhs rhs >>> extractDecls decls extractAlt :: Alt Id -> IntState -> IntState extractAlt (Alt pat rhs decls) = extractRhs rhs >>> extractDecls decls extractExp :: Exp Id -> Reduce IntState IntState extractExp (ExpScc str exp) = extractExp exp extractExp (ExpLambda pos pats exp) = extractExp exp extractExp (ExpLet pos decls exp) = extractExp exp >>> extractDecls decls extractExp (ExpDo pos stmts) = mapR extractStmt stmts extractExp (ExpCase pos exp alts) = extractExp exp >>> mapR extractAlt alts extractExp (ExpIf pos expC expT expE) = extractExp expC >>> extractExp expT >>> extractExp expE extractExp (ExpType pos exp ctxs typ) = extractExp exp --- Above only in expressions extractExp (ExpApplication pos exps) = mapR extractExp exps extractExp (ExpList pos exps) = mapR extractExp exps extractExp (ExpRecord exp fields)= extractExp exp >>> mapR extractField fields extractExp e = unitR extractField :: Field Id -> Reduce IntState IntState extractField (FieldExp _ _ exp) = extractExp exp extractField (FieldPun _ _) = unitR extractStmt :: Stmt Id -> Reduce IntState IntState extractStmt (StmtExp exp) = extractExp exp extractStmt (StmtBind pat exp) = mapR ( \ (pos,ident) -> updVarArity pos ident 0) (identPat pat) >>> extractExp exp extractStmt (StmtLet decls) = extractDecls decls extractQual :: Qual Id -> Reduce IntState IntState extractQual (QualExp exp) = extractExp exp extractQual (QualPatExp pat exp) = mapR ( \ (pos,ident) -> updVarArity pos ident 0) (identPat pat) >>> extractExp exp extractQual (QualLet decls) = extractDecls decls {- End Module Extract -------------------------------------------------------}