module EvaluateTypes where import Evaluation.DocTypes import DocTypes_Generated import DocumentEdit_Generated import DocUtils_Generated import Common.CommonTypes import Common.DebugLevels import System.IO.Unsafe -- evaluate has IO, so the unsafePerformIO is only temporary import Char import Maybe import qualified Data.Map as Map import Evaluation.DocumentEdit import UHA_Syntax --import qualified ExtractImportDecls (sem_Module) --import qualified StaticAnalysis (sem_Module) import CompileHelium import Utils --import SAMessages import StaticErrors import TypeErrors import Top.Types --import MyAssocList import UHA_Utils import UHA_Range import HeliumMessages import qualified UHA_Pretty (sem_Module, sem_Declarations) ppUHADoc :: Document -> String ppUHADoc doc = show . UHA_Pretty.sem_Module . uhaFromDoc $ doc ppDeclarations :: Declarations -> String ppDeclarations decls = show $ UHA_Pretty.sem_Declarations decls readM :: Read a => String -> Maybe a readM s = case [x | (x,t) <- reads s, ("","") <- lex t] of [x] -> Just x _ -> Nothing pathFromRange :: Range -> PathDoc pathFromRange (Range_Range (Position_Position pathStr@(_:_) _ _) _) = case readM pathStr of Just path -> PathD path -- Nothing is when identifier is from other module Nothing -> {-debug Err ("EvaluateTypes.pathFromRange Incorrect range "++show pathStr)-} NoPathD pathFromRange _ = NoPathD evaluate :: Document -> ([HeliumMessage], [(PathDoc,String)], [(String,String)]) evaluate doc = henk2 . uhaFromDoc $ doc -- The path info is the path in Proxima's Document. It is stored in the filename string of range, -- so ranges from UHA can be mapped back onto Proxima Document locations uhaFromDoc :: Document -> Module uhaFromDoc (RootDoc (Root _ list_decl)) = Module_Module (range [0]) MaybeName_Nothing MaybeExports_Nothing (Body_Body (range []) [] (uhaFromList_Decl [0,0] list_decl)) uhaFromList_Decl :: [Int] -> List_Decl -> [Declaration] uhaFromList_Decl pth (List_Decl consList) = concat [ uhaFromDecl (pth++[i]) dcl | (dcl,i) <- zip (fromConsList_Decl consList) [0..] ] uhaFromList_Decl _ _ = [] uhaFromDecl :: [Int] -> Decl -> [Declaration] -- return type is List so wrong Decl's can return a [] uhaFromDecl pth (Decl _ _ _ _ _ _ ident exp) = [ Declaration_FunctionBindings (range pth) [ FunctionBinding_FunctionBinding (range pth) (LeftHandSide_Function (range (pth++[2])) (uhaFromIdent (pth++[2]) ident) []) (RightHandSide_Expression (range (pth++[3])) (uhaFromExp (pth++[3]) exp) MaybeDeclarations_Nothing) ] ] uhaFromDecl pth (PPPresentationDecl _ _ pppres) = uhaFromPPPresentation (pth++[0]) pppres uhaFromDecl _ _ = [] uhaFromIdent :: [Int] -> Ident -> Name uhaFromIdent pth (Ident _ _ nm) = (Name_Identifier (range pth) [] nm) uhaFromIdent pth _ = (Name_Identifier (range pth) [] "x") uhaFromExp :: [Int] -> Exp -> Expression uhaFromExp pth (PlusExp _ exp1 exp2) = mkInfixApp pth "+" exp1 exp2 uhaFromExp pth (TimesExp _ exp1 exp2) = mkInfixApp pth "*" exp1 exp2 uhaFromExp pth (DivExp _ exp1 exp2) = mkInfixApp pth "div" exp1 exp2 uhaFromExp pth (PowerExp _ exp1 exp2) = mkInfixApp pth "^" exp1 exp2 uhaFromExp pth (BoolExp _ bool) = Expression_Constructor (range pth) $ Name_Special (range pth) [] (show $ bool) uhaFromExp pth (IntExp _ int) = Expression_Literal (range pth) $ Literal_Int (range pth) (show $ int) uhaFromExp pth (LamExp _ _ ident exp) = Expression_Lambda (range pth) [Pattern_Variable (range (pth++[0])) (uhaFromIdent (pth++[0]) ident) ] (uhaFromExp (pth++[1]) exp) uhaFromExp pth (CaseExp _ _ exp list_alt) = Expression_Case (range pth) (uhaFromExp (pth++[0]) exp) (uhaFromList_Alt (pth++[1]) list_alt) uhaFromExp pth (LetExp _ _ list_decl exp) = Expression_Let (range pth) (uhaFromList_Decl (pth++[0]) list_decl) (uhaFromExp (pth++[1]) exp) uhaFromExp pth (AppExp exp1 exp2) = Expression_NormalApplication (range pth) (uhaFromExp (pth++[0]) exp1) [uhaFromExp (pth++[1]) exp2] uhaFromExp pth (IdentExp ident) = Expression_Variable (range pth) $ uhaFromIdent (pth++[0]) ident uhaFromExp pth (IfExp _ _ _ exp1 exp2 exp3) = Expression_If (range pth) (uhaFromExp (pth++[0]) exp1) (uhaFromExp (pth++[1]) exp2) (uhaFromExp (pth++[2]) exp3) uhaFromExp pth (ParenExp _ _ exp) = Expression_Parenthesized (range pth) $ uhaFromExp (pth++[0]) exp uhaFromExp pth (ListExp _ _ _ list_exp) = Expression_List (range pth) $ uhaFromList_Exp (pth++[0]) list_exp uhaFromExp pth (ProductExp _ _ _ list_exp) = Expression_Tuple (range pth) $ uhaFromList_Exp (pth++[0]) list_exp uhaFromExp pth HoleExp = Expression_Variable (range pth) $ Name_Identifier (range pth) [] "undefined" uhaFromExp pth (ParseErrExp _) = Expression_Variable (range pth) $ Name_Identifier (range pth) [] "undefined" uhaFromExp pth _ = Expression_Variable (range pth) $ Name_Identifier (range pth) [] "undefined" uhaFromList_Exp :: [Int] -> List_Exp -> [Expression] uhaFromList_Exp pth (List_Exp consList) = [ uhaFromExp (pth++[i]) dcl | (dcl,i) <- zip (fromConsList_Exp consList) [0..] ] uhaFromList_Exp _ _ = [] uhaFromList_Alt :: [Int] -> List_Alt -> [Alternative] uhaFromList_Alt pth (List_Alt consList) = concat [ uhaFromAlt (pth++[i]) dcl | (dcl,i) <- zip (fromConsList_Alt consList) [0..] ] uhaFromList_Alt _ _ = [] uhaFromAlt :: [Int] -> Alt -> [Alternative] -- return type is List so wrong Alt's can return a [] uhaFromAlt pth (Alt _ _ ident exp) = [ Alternative_Alternative (range pth) (Pattern_Variable (range (pth++[0])) (uhaFromIdent (pth++[0]) ident)) (RightHandSide_Expression (range (pth++[1])) (uhaFromExp (pth++[1]) exp) MaybeDeclarations_Nothing) ] uhaFromAlt _ _ = [] -- collect the expressions in helium items and bind them to unique function names uhaFromPPPresentation pth (PPPresentation vwtype list_slide) = uhaFromList_Slide (pth++[1]) list_slide uhaFromPPPresentation _ _ = [] uhaFromList_Slide :: [Int] -> List_Slide -> [Declaration] uhaFromList_Slide pth (List_Slide consList) = concat [ uhaFromSlide (pth++[i]) dcl | (dcl,i) <- zip (fromConsList_Slide consList) [0..] ] uhaFromList_Slide _ _ = [] uhaFromSlide pth (Slide _ itemlist) = uhaFromItemList (pth++[1]) itemlist uhaFromSlide _ _ = [] uhaFromItemList pth (ItemList lsttype list_item) = uhaFromList_Item (pth++[1]) list_item uhaFromItemList _ _ = [] uhaFromList_Item :: [Int] -> List_Item -> [Declaration] uhaFromList_Item pth (List_Item consList) = concat [ uhaFromItem (pth++[i]) dcl | (dcl,i) <- zip (fromConsList_Item consList) [0..] ] uhaFromList_Item _ _ = [] uhaFromItem pth (HeliumItem exp) = [ Declaration_FunctionBindings noRange [ FunctionBinding_FunctionBinding noRange (LeftHandSide_Function noRange (Name_Identifier noRange [] ("HeliumItem"++uniqueName pth)) []) (RightHandSide_Expression noRange (uhaFromExp (pth++[0]) exp) MaybeDeclarations_Nothing) ] ] uhaFromItem _ _ = [] uniqueName pth = [ if isDigit c then c else '_' | c <- show pth ] -- infix op does not correspond to tree path, so [-1] mkInfixApp pth op exp1 exp2 = Expression_InfixApplication (range pth) (MaybeExpression_Just $ uhaFromExp (pth++[0]) exp1) (Expression_Variable (range [-1]) (Name_Operator (range [-1]) [] op)) (MaybeExpression_Just $ uhaFromExp (pth++[1]) exp2) range :: [Int] -> Range range pth = Range_Range (Position_Position (show pth) (-1) (-1)) Position_Unknown -- errors type env toplevel env henk2 :: Module -> ([HeliumMessage], [(PathDoc,String)], [(String,String)]) henk2 mod = case unsafePerformIO $ do { debugLnIO Prs "Helium compiler start type check" ; errs <- compileHelium mod ; debugLnIO Prs "Helium compiler finish type check" ; return errs } of Left errs -> debug Prs (show (map showMessage errs)) (map hErrFromErr errs, [], []) Right (types,typeEnvRange) -> let typeEnv =[ (pathFromRange r, show t) | (r,t)<- typeEnvRange ] lhsTypeEnv = [ (PathD (init pth ++ [2]), t) | (PathD (pth@(_:_)),t) <- typeEnv , last pth == 3 && isNothing (lookup (PathD $ init pth ++ [2]) typeEnv) ] toplvlEnv = [ (getNameName nm,show tp) | (nm,tp) <- Map.toList types ] in ( [], typeEnv++lhsTypeEnv, toplvlEnv ) hErrFromErr = either hErrFromStaticErr hErrFromTypeErr hErrFromStaticErr e@(NoFunDef entity name names) = HError (lines $ showMessage e) [] (pathFromName name : map (pathFromName) names) [] hErrFromStaticErr e@(Undefined entity name names hints) = debug Prs (show names) $ HError (lines $ showMessage e) [pathFromName name] (map (pathFromName) names) [] hErrFromStaticErr e@(Duplicated entity names) = HError (lines $ showMessage e) (map (pathFromName) names) [] [] hErrFromStaticErr e@(LastStatementNotExpr range) = HError (lines $ showMessage e) [pathFromRange range] [] [] hErrFromStaticErr e@(WrongFileName string string' range) = HError (lines $ showMessage e) [pathFromRange range] [] [] hErrFromStaticErr e@(TypeVarApplication name) = HError (lines $ showMessage e) [pathFromName name] [] [] hErrFromStaticErr e@(ArityMismatch entity name int int') = HError (lines $ showMessage e) [pathFromName name] [] [] hErrFromStaticErr e@(DefArityMismatch name maybeint range) = HError (lines$ showMessage e) [pathFromName name] [pathFromRange range] [] hErrFromStaticErr e@(RecursiveTypeSynonyms names) = HError (lines $ showMessage e) (map (pathFromName) names) [] [] hErrFromStaticErr e@(PatternDefinesNoVars range) = HError (lines $ showMessage e) [pathFromRange range] [] [] hErrFromStaticErr err = HError ("Unknown Static Error" : lines (showMessage err)) [] [] [] --TypeError = TypeError Bool String Range SourceDocs (Maybe (Bool,TpScheme),Tp,Tp) Hint -- | NotGeneralEnough TpScheme TpScheme (Tree,Range) deriving Show hErrFromTypeErr e@(TypeError ranges _ _ _) = HError (lines $ showMessage e) [] [] (map pathFromRange ranges) hErrFromTypeErr err = HError ("Unhandled Type Error" : lines (showMessage err)) [] [] [] pathFromName = pathFromRange . getNameRange