From 4cf0b6c492fc8fe718f53817638773818046d6cb Mon Sep 17 00:00:00 2001 From: Camil Staps Date: Sat, 20 Aug 2016 13:45:57 +0200 Subject: [PATCH] Combine all FunctionLocation, ClassLocation etc. into one Location --- backend/CloogleServer.icl | 82 +++++++++++------------ backend/TypeDB.dcl | 94 +++++++++++++------------- backend/TypeDB.icl | 134 ++++++++++++++++---------------------- backend/builddb.icl | 88 ++++++++++++------------- 4 files changed, 182 insertions(+), 216 deletions(-) diff --git a/backend/CloogleServer.icl b/backend/CloogleServer.icl index dbfff66..ab8f921 100644 --- a/backend/CloogleServer.icl +++ b/backend/CloogleServer.icl @@ -70,14 +70,14 @@ import Levenshtein } :: ClassResult :== (BasicResult, ClassResultExtras) -:: ClassResultExtras = { class_name :: String - , class_heading :: String - , class_funs :: [String] +:: ClassResultExtras = { class_name :: String + , class_heading :: String + , class_funs :: [String] , class_instances :: [String] } :: MacroResult :== (BasicResult, MacroResultExtras) -:: MacroResultExtras = { macro_name :: String +:: MacroResultExtras = { macro_name :: String , macro_representation :: String } @@ -114,9 +114,9 @@ where where basic :: Result -> BasicResult basic (FunctionResult (br,_)) = br - basic (TypeResult (br,_)) = br - basic (ClassResult (br,_)) = br - basic (MacroResult (br,_)) = br + basic (TypeResult (br,_)) = br + basic (ClassResult (br,_)) = br + basic (MacroResult (br,_)) = br err :: Int String -> Response err c m = { return = c @@ -126,12 +126,12 @@ err c m = { return = c , suggestions = Nothing } -E_NORESULTS :== 127 +E_NORESULTS :== 127 E_INVALIDINPUT :== 128 -E_INVALIDNAME :== 129 -E_INVALIDTYPE :== 130 +E_INVALIDNAME :== 129 +E_INVALIDTYPE :== 130 -MAX_RESULTS :== 15 +MAX_RESULTS :== 15 Start w # (io, w) = stdio w @@ -203,45 +203,42 @@ where // Search normal functions # filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType , (\n loc _ -> isNameMatch (size n-2) n loc) <$> name - , isModMatchF <$> modules + , (\mods loc _ -> isModMatch mods loc) <$> modules ] # funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db // Search macros # macros = case name of Nothing = [] - (Just n) = findMacro` (\(ML lib mod m _) _ -> isNameMatch (size n-2) n (FL lib mod m Nothing)) db + (Just n) = findMacro` (\loc _ -> isNameMatch (size n-2) n loc) db # macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros // Search class members # filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType - , (\n (CL lib mod _ _) _ _ f _ -> isNameMatch - (size n-2) n (FL lib mod f Nothing)) <$> name - , isModMatchC <$> modules + , (\n (Location lib mod _ _) _ _ f _ -> isNameMatch + (size n-2) n (Location lib mod Nothing f)) <$> name + , (\mods loc _ _ _ _ -> isModMatch mods loc) <$> modules ] # members = findClassMembers`` filts db - # members = map (\(CL lib mod cls line,vs,_,f,et) -> makeFunctionResult name mbType - (Just {cls_name=cls,cls_vars=vs}) (FL lib mod f line,et) db) members + # members = map (\(Location lib mod line cls,vs,_,f,et) -> makeFunctionResult name mbType + (Just {cls_name=cls,cls_vars=vs}) (Location lib mod line f,et) db) members // Search types - # lcTypeName = if (isJust mbType && isType (fromJust mbType)) + # lcName = if (isJust mbType && isType (fromJust mbType)) (let (Type name _) = fromJust mbType in Just $ toLowerCase name) (toLowerCase <$> name) - # types = case lcTypeName of + # types = case lcName of (Just n) = findType` (\tl _ -> toLowerCase (getName tl) == n) db Nothing = [] # types = map (\(tl,td) -> makeTypeResult name tl td) types // Search classes # classes = case (isNothing mbType, toLowerCase <$> name) of (True, Just c) = map (flip makeClassResult db) $ - findClass` (\(CL _ _ c` _) _ _ _ -> toLowerCase c` == c) db + findClass` (\(Location _ _ _ c`) _ _ _ -> toLowerCase c` == c) db _ = [] // Merge results = sort $ funs ++ members ++ types ++ classes ++ macros - where - getName (TL _ _ t _) = t - getName (TL_Builtin t) = t - makeClassResult :: (ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)]) + makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)]) TypeDB -> Result - makeClassResult (CL lib mod cls line, vars, cc, funs) db + makeClassResult (Location lib mod line cls, vars, cc, funs) db = ClassResult ( { library = lib , filename = modToFilename mod @@ -259,8 +256,8 @@ where } ) - makeTypeResult :: (Maybe String) TypeLocation TypeDef -> Result - makeTypeResult mbName (TL lib mod t line) td + makeTypeResult :: (Maybe String) Location TypeDef -> Result + makeTypeResult mbName (Location lib mod line t) td = TypeResult ( { library = lib , filename = modToFilename mod @@ -272,7 +269,7 @@ where } , { type = concat $ print False td } ) - makeTypeResult mbName (TL_Builtin t) td + makeTypeResult mbName (Builtin t) td = TypeResult ( { library = "" , filename = "" @@ -285,8 +282,8 @@ where , { type = concat $ print False td } ) - makeMacroResult :: (Maybe String) MacroLocation Macro -> Result - makeMacroResult mbName (ML lib mod m line) mac + makeMacroResult :: (Maybe String) Location Macro -> Result + makeMacroResult mbName (Location lib mod line m) mac = MacroResult ( { library = lib , filename = modToFilename mod @@ -302,7 +299,7 @@ where ) makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult) - (FunctionLocation, ExtendedType) TypeDB -> Result + (Location, ExtendedType) TypeDB -> Result makeFunctionResult orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db = FunctionResult @@ -331,8 +328,8 @@ where ) where (lib,mod,fname,line,builtin) = case fl of - (FL l m f ln) = (l, m, f,ln, Nothing) - (FL_Builtin f) = ("","",f,Nothing,Just True) + (Location l m ln f) = (l, m, f, ln, Nothing) + (Builtin f) = ("", "", f, Nothing, Just True) toStrUnifier :: Unifier -> StrUnifier toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2) @@ -368,21 +365,16 @@ where isUnifiable :: Type ExtendedType -> Bool isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2)) - isNameMatch :: !Int !String FunctionLocation -> Bool - isNameMatch maxdist n1 fl - # (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName fl}) + isNameMatch :: !Int !String Location -> Bool + isNameMatch maxdist n1 loc + # (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName loc}) = n1 == "" || indexOf n1 n2 <> -1 || levenshtein n1 n2 <= maxdist - where - getName (FL _ _ n _) = n; getName (FL_Builtin n) = n - - isModMatchF :: ![String] FunctionLocation ExtendedType -> Bool - isModMatchF mods (FL _ mod _ _) _ = isMember mod mods - isModMatchC :: ![String] ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool - isModMatchC mods (CL _ mod _ _) _ _ _ _ = isMember mod mods + isModMatch :: ![String] Location -> Bool + isModMatch mods (Location _ mod _ _) = isMember mod mods log :: (LogMessage (Maybe Request) Response) IPAddress *World - -> *(IPAddress, *World) + -> *(IPAddress, *World) log msg s w | not needslog = (newS msg s, w) # (tm,w) = localTime w diff --git a/backend/TypeDB.dcl b/backend/TypeDB.dcl index 7bee932..9ba8ce1 100644 --- a/backend/TypeDB.dcl +++ b/backend/TypeDB.dcl @@ -29,20 +29,13 @@ from Type import ::Type, ::TypeVar, ::TVAssignment, ::TypeDef, class print(..), , macro_extras :: TypeExtras } -:: FunctionLocation = FL Library Module FunctionName LineNr - | FL_Builtin FunctionName -:: MacroLocation = ML Library Module MacroName LineNr -:: ClassLocation = CL Library Module Class LineNr -:: TypeLocation = TL Library Module TypeName LineNr - | TL_Builtin TypeName +:: Location = Location Library Module LineNr Name + | Builtin Name +:: Name :== String :: Library :== String :: Module :== String -:: FunctionName :== String -:: MacroName :== String :: Class :== String -:: GenericName :== String -:: TypeName :== String :: LineNr :== Maybe Int derive gEq TypeDB @@ -51,52 +44,53 @@ instance zero TypeDB instance zero TypeExtras instance print TE_Priority -instance print (FunctionName, ExtendedType) - -getFunction :: FunctionLocation TypeDB -> Maybe ExtendedType -putFunction :: FunctionLocation ExtendedType TypeDB -> TypeDB -putFunctions :: [(FunctionLocation, ExtendedType)] TypeDB -> TypeDB -findFunction :: FunctionName TypeDB -> [(FunctionLocation, ExtendedType)] -findFunction` :: (FunctionLocation ExtendedType -> Bool) TypeDB - -> [(FunctionLocation, ExtendedType)] -findFunction`` :: [(FunctionLocation ExtendedType -> Bool)] TypeDB - -> [(FunctionLocation, ExtendedType)] - -getMacro :: MacroLocation TypeDB -> Maybe Macro -putMacro :: MacroLocation Macro TypeDB -> TypeDB -putMacros :: [(MacroLocation, Macro)] TypeDB -> TypeDB -findMacro` :: (MacroLocation Macro -> Bool) TypeDB -> [(MacroLocation, Macro)] +instance print (Name, ExtendedType) + +getName :: Location -> Name + +getFunction :: Location TypeDB -> Maybe ExtendedType +putFunction :: Location ExtendedType TypeDB -> TypeDB +putFunctions :: [(Location, ExtendedType)] TypeDB -> TypeDB +findFunction :: Name TypeDB -> [(Location, ExtendedType)] +findFunction` :: (Location ExtendedType -> Bool) TypeDB + -> [(Location, ExtendedType)] +findFunction`` :: [(Location ExtendedType -> Bool)] TypeDB + -> [(Location, ExtendedType)] + +getMacro :: Location TypeDB -> Maybe Macro +putMacro :: Location Macro TypeDB -> TypeDB +putMacros :: [(Location, Macro)] TypeDB -> TypeDB +findMacro` :: (Location Macro -> Bool) TypeDB -> [(Location, Macro)] getInstances :: Class TypeDB -> [Type] putInstance :: Class Type TypeDB -> TypeDB putInstances :: Class [Type] TypeDB -> TypeDB putInstancess :: [(Class, [Type])] TypeDB -> TypeDB -getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],ClassContext,[(FunctionName,ExtendedType)]) -putClass :: ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] TypeDB -> TypeDB -putClasses :: [(ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])] TypeDB -> TypeDB -findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])] -findClass` :: (ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] -> Bool) TypeDB - -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])] - -findClassMembers` :: (ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool) TypeDB - -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)] -findClassMembers`` :: [ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool] - TypeDB -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)] - -getType :: TypeLocation TypeDB -> Maybe TypeDef -putType :: TypeLocation TypeDef TypeDB -> TypeDB -putTypes :: [(TypeLocation, TypeDef)] TypeDB -> TypeDB -findType :: TypeName TypeDB -> [(TypeLocation, TypeDef)] -findType` :: (TypeLocation TypeDef -> Bool) TypeDB - -> [(TypeLocation, TypeDef)] - -getDerivations :: GenericName TypeDB -> [Type] -putDerivation :: GenericName Type TypeDB -> TypeDB -putDerivations :: GenericName [Type] TypeDB -> TypeDB -putDerivationss :: [(GenericName, [Type])] TypeDB -> TypeDB - -searchExact :: Type TypeDB -> [(FunctionLocation, ExtendedType)] +getClass :: Location TypeDB -> Maybe ([TypeVar],ClassContext,[(Name,ExtendedType)]) +putClass :: Location [TypeVar] ClassContext [(Name,ExtendedType)] TypeDB -> TypeDB +putClasses :: [(Location, [TypeVar], ClassContext, [(Name,ExtendedType)])] TypeDB -> TypeDB +findClass :: Class TypeDB -> [(Location, [TypeVar], ClassContext, [(Name, ExtendedType)])] +findClass` :: (Location [TypeVar] ClassContext [(Name,ExtendedType)] -> Bool) TypeDB + -> [(Location, [TypeVar], ClassContext, [(Name, ExtendedType)])] + +findClassMembers` :: (Location [TypeVar] ClassContext Name ExtendedType -> Bool) TypeDB + -> [(Location, [TypeVar], ClassContext, Name, ExtendedType)] +findClassMembers`` :: [Location [TypeVar] ClassContext Name ExtendedType -> Bool] + TypeDB -> [(Location, [TypeVar], ClassContext, Name, ExtendedType)] + +getType :: Location TypeDB -> Maybe TypeDef +putType :: Location TypeDef TypeDB -> TypeDB +putTypes :: [(Location, TypeDef)] TypeDB -> TypeDB +findType :: Name TypeDB -> [(Location, TypeDef)] +findType` :: (Location TypeDef -> Bool) TypeDB -> [(Location, TypeDef)] + +getDerivations :: Name TypeDB -> [Type] +putDerivation :: Name Type TypeDB -> TypeDB +putDerivations :: Name [Type] TypeDB -> TypeDB +putDerivationss :: [(Name, [Type])] TypeDB -> TypeDB + +searchExact :: Type TypeDB -> [(Location, ExtendedType)] newDb :: TypeDB openDb :: *File -> *(Maybe TypeDB, *File) diff --git a/backend/TypeDB.icl b/backend/TypeDB.icl index eccd4c3..02b22b2 100644 --- a/backend/TypeDB.icl +++ b/backend/TypeDB.icl @@ -13,12 +13,12 @@ import Text.JSON import Type :: TypeDB - = { functionmap :: Map FunctionLocation ExtendedType - , macromap :: Map MacroLocation Macro - , classmap :: Map ClassLocation ([TypeVar],ClassContext,[(FunctionName, ExtendedType)]) + = { functionmap :: Map Location ExtendedType + , macromap :: Map Location Macro + , classmap :: Map Location ([TypeVar],ClassContext,[(Name, ExtendedType)]) , instancemap :: Map Class [Type] - , typemap :: Map TypeLocation TypeDef - , derivemap :: Map GenericName [Type] + , typemap :: Map Location TypeDef + , derivemap :: Map Name [Type] } printersperse :: Bool a [b] -> [String] | print a & print b @@ -27,15 +27,14 @@ printersperse ia a bs = intercalate (print False a) (map (print ia) bs) (--) infixr 5 :: a b -> [String] | print a & print b (--) a b = print False a ++ print False b -derive gEq ClassOrGeneric, FunctionLocation, ClassLocation, Type, TypeDB, - TypeExtras, TE_Priority, ExtendedType, TypeDef, TypeLocation, TypeDefRhs, - RecordField, Constructor, Kind, MacroLocation, Macro -derive JSONEncode ClassOrGeneric, FunctionLocation, ClassLocation, Type, - TypeDB, TypeExtras, TE_Priority, ExtendedType, TypeDef, TypeLocation, - TypeDefRhs, RecordField, Constructor, Kind, MacroLocation, Macro -derive JSONDecode ClassOrGeneric, FunctionLocation, ClassLocation, Type, - TypeDB, TypeExtras, TE_Priority, ExtendedType, TypeDef, TypeLocation, - TypeDefRhs, RecordField, Constructor, Kind, MacroLocation, Macro +derive gEq ClassOrGeneric, Location, Type, TypeDB, TypeExtras, TE_Priority, + ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor, Kind, Macro +derive JSONEncode ClassOrGeneric, Location, Type, TypeDB, TypeExtras, + TE_Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor, + Kind, Macro +derive JSONDecode ClassOrGeneric, Location, Type, TypeDB, TypeExtras, + TE_Priority, ExtendedType, TypeDef, TypeDefRhs, RecordField, Constructor, + Kind, Macro instance zero TypeDB where @@ -47,35 +46,18 @@ where , derivemap = newMap } -instance < (a,b,c,d) | Ord a & Ord b & Ord c & Ord d -where - (<) (a,b,c,d) (e,f,g,h) = ((a,b),(c,d)) < ((e,f),(g,h)) - instance < (Maybe a) | < a where (<) (Just a) (Just b) = a < b (<) (Just _) Nothing = True (<) Nothing _ = False -instance < FunctionLocation +instance < Location where - (<) (FL a b c d) (FL e f g h) = (a,b,c,d) < (e,f,g,h) - (<) (FL_Builtin a) (FL_Builtin b) = a < b - (<) (FL_Builtin _) _ = True - (<) _ _ = False - -instance < MacroLocation -where (<) (ML a b c d) (ML e f g h) = (a,b,c,d) < (e,f,g,h) - -instance < ClassLocation -where (<) (CL a b c d) (CL e f g h) = (a,b,c,d) < (e,f,g,h) - -instance < TypeLocation -where - (<) (TL a b c d) (TL e f g h) = (a,b,c,d) < (e,f,g,h) - (<) (TL_Builtin a) (TL_Builtin b) = a < b - (<) (TL_Builtin _) _ = True - (<) _ _ = False + (<) (Location a b c d) (Location e f g h) = ((a,b),(c,d)) < ((e,f),(g,h)) + (<) (Location _ _ _ _) (Builtin _) = True + (<) (Builtin _) (Location _ _ _ _) = False + (<) (Builtin a) (Builtin b) = a < b instance zero TypeExtras where @@ -97,7 +79,7 @@ where print _ (RightAssoc i) = "infixr " -- i print _ (NoAssoc i) = "infix " -- i -instance print (FunctionName, ExtendedType) +instance print (Name, ExtendedType) where print _ (f, (ET t e)) = gen -- fname -- " " -- e -- " :: " -- t @@ -108,40 +90,41 @@ where | e.te_isrecordfield = "." +++ f | otherwise = f -getFunction :: FunctionLocation TypeDB -> Maybe ExtendedType +getName :: Location -> Name +getName (Location _ _ _ name) = name +getName (Builtin name) = name + +getFunction :: Location TypeDB -> Maybe ExtendedType getFunction loc {functionmap} = get loc functionmap -putFunction :: FunctionLocation ExtendedType TypeDB -> TypeDB +putFunction :: Location ExtendedType TypeDB -> TypeDB putFunction fl t tdb=:{functionmap} = { tdb & functionmap = put fl t functionmap } -putFunctions :: [(FunctionLocation, ExtendedType)] TypeDB -> TypeDB +putFunctions :: [(Location, ExtendedType)] TypeDB -> TypeDB putFunctions ts tdb = foldr (\(loc,t) db -> putFunction loc t db) tdb ts -findFunction :: FunctionName TypeDB -> [(FunctionLocation, ExtendedType)] +findFunction :: Name TypeDB -> [(Location, ExtendedType)] findFunction f db=:{functionmap} = toList $ filterWithKey (\fl _-> f == getName fl) functionmap -where - getName (FL _ _ f _) = f - getName (FL_Builtin f) = f -findFunction` :: (FunctionLocation ExtendedType -> Bool) TypeDB - -> [(FunctionLocation, ExtendedType)] +findFunction` :: (Location ExtendedType -> Bool) TypeDB + -> [(Location, ExtendedType)] findFunction` f {functionmap} = toList $ filterWithKey f functionmap -findFunction`` :: [(FunctionLocation ExtendedType -> Bool)] TypeDB - -> [(FunctionLocation, ExtendedType)] +findFunction`` :: [(Location ExtendedType -> Bool)] TypeDB + -> [(Location, ExtendedType)] findFunction`` fs {functionmap} = toList $ foldr filterWithKey functionmap fs -getMacro :: MacroLocation TypeDB -> Maybe Macro +getMacro :: Location TypeDB -> Maybe Macro getMacro loc {macromap} = get loc macromap -putMacro :: MacroLocation Macro TypeDB -> TypeDB +putMacro :: Location Macro TypeDB -> TypeDB putMacro ml m db=:{macromap} = { db & macromap = put ml m macromap } -putMacros :: [(MacroLocation, Macro)] TypeDB -> TypeDB +putMacros :: [(Location, Macro)] TypeDB -> TypeDB putMacros ms db = foldr (\(loc,m) db -> putMacro loc m db) db ms -findMacro` :: (MacroLocation Macro -> Bool) TypeDB -> [(MacroLocation, Macro)] +findMacro` :: (Location Macro -> Bool) TypeDB -> [(Location, Macro)] findMacro` f {macromap} = toList $ filterWithKey f macromap getInstances :: Class TypeDB -> [Type] @@ -158,71 +141,68 @@ putInstances c ts db = foldr (\t db -> putInstance c t db) db ts putInstancess :: [(Class, [Type])] TypeDB -> TypeDB putInstancess is db = foldr (\(c,ts) db -> putInstances c ts db) db is -getClass :: ClassLocation TypeDB -> Maybe ([TypeVar],ClassContext,[(FunctionName,ExtendedType)]) +getClass :: Location TypeDB -> Maybe ([TypeVar],ClassContext,[(Name,ExtendedType)]) getClass loc {classmap} = get loc classmap -putClass :: ClassLocation [TypeVar] ClassContext [(FunctionName, ExtendedType)] TypeDB -> TypeDB +putClass :: Location [TypeVar] ClassContext [(Name, ExtendedType)] TypeDB -> TypeDB putClass cl tvs cc fs db=:{classmap} = {db & classmap = put cl (tvs,cc,fs) classmap} -putClasses :: [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])] TypeDB -> TypeDB +putClasses :: [(Location, [TypeVar], ClassContext, [(Name, ExtendedType)])] TypeDB -> TypeDB putClasses cs db = foldr (\(cl,tvs,cc,fs) db -> putClass cl tvs cc fs db) db cs -findClass :: Class TypeDB -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName, ExtendedType)])] +findClass :: Class TypeDB -> [(Location, [TypeVar], ClassContext, [(Name, ExtendedType)])] findClass c {classmap} = map (\(k,(x,y,z))->(k,x,y,z)) results -where results = toList $ filterWithKey (\(CL _ _ c` _) _->c==c`) classmap +where results = toList $ filterWithKey (\(Location _ _ _ c`) _->c==c`) classmap -findClass` :: (ClassLocation [TypeVar] ClassContext [(FunctionName,ExtendedType)] -> Bool) TypeDB - -> [(ClassLocation, [TypeVar], ClassContext, [(FunctionName,ExtendedType)])] +findClass` :: (Location [TypeVar] ClassContext [(Name,ExtendedType)] -> Bool) TypeDB + -> [(Location, [TypeVar], ClassContext, [(Name,ExtendedType)])] findClass` f {classmap} = map (\(k,(x,y,z))->(k,x,y,z)) results where results = toList $ filterWithKey (\cl (vs,cc,fs)->f cl vs cc fs) classmap -findClassMembers` :: (ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool) TypeDB - -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)] +findClassMembers` :: (Location [TypeVar] ClassContext Name ExtendedType -> Bool) TypeDB + -> [(Location, [TypeVar], ClassContext, Name, ExtendedType)] findClassMembers` f {classmap} = filter (app5 f) $ flatten members where members = map (\(cl,(vs,cc,fs))->[(cl,vs,cc,f,t) \\ (f,t)<-fs]) $ toList classmap -findClassMembers`` :: [(ClassLocation [TypeVar] ClassContext FunctionName ExtendedType -> Bool)] - TypeDB -> [(ClassLocation, [TypeVar], ClassContext, FunctionName, ExtendedType)] +findClassMembers`` :: [(Location [TypeVar] ClassContext Name ExtendedType -> Bool)] + TypeDB -> [(Location, [TypeVar], ClassContext, Name, ExtendedType)] findClassMembers`` fs {classmap} = foldr (filter o app5) all_members fs where all_members = [(cl,vs,cc,f,t) \\ (cl,(vs,cc,fs)) <- toList classmap, (f,t) <- fs] -getType :: TypeLocation TypeDB -> Maybe TypeDef +getType :: Location TypeDB -> Maybe TypeDef getType loc {typemap} = get loc typemap -putType :: TypeLocation TypeDef TypeDB -> TypeDB +putType :: Location TypeDef TypeDB -> TypeDB putType tl td db=:{typemap} = {db & typemap = put tl td typemap} -putTypes :: [(TypeLocation, TypeDef)] TypeDB -> TypeDB +putTypes :: [(Location, TypeDef)] TypeDB -> TypeDB putTypes ts db = foldr (\(loc,td) -> putType loc td) db ts -findType :: TypeName TypeDB -> [(TypeLocation, TypeDef)] +findType :: Name TypeDB -> [(Location, TypeDef)] findType t db=:{typemap} = toList $ filterWithKey (\tl _ -> getName tl == t) typemap -where - getName (TL _ _ t _) = t - getName (TL_Builtin t) = t -findType` :: (TypeLocation TypeDef -> Bool) TypeDB - -> [(TypeLocation, TypeDef)] +findType` :: (Location TypeDef -> Bool) TypeDB + -> [(Location, TypeDef)] findType` f {typemap} = toList $ filterWithKey f typemap -getDerivations :: GenericName TypeDB -> [Type] +getDerivations :: Name TypeDB -> [Type] getDerivations gen {derivemap} = if (isNothing ts) [] (fromJust ts) where ts = get gen derivemap -putDerivation :: GenericName Type TypeDB -> TypeDB +putDerivation :: Name Type TypeDB -> TypeDB putDerivation gen t db=:{derivemap} = {db & derivemap=put gen ts derivemap} where ts = removeDup [t : getDerivations gen db] -putDerivations :: GenericName [Type] TypeDB -> TypeDB +putDerivations :: Name [Type] TypeDB -> TypeDB putDerivations gen ts db = foldr (\t db -> putDerivation gen t db) db ts -putDerivationss :: [(GenericName, [Type])] TypeDB -> TypeDB +putDerivationss :: [(Name, [Type])] TypeDB -> TypeDB putDerivationss ds db = foldr (\(g,ts) db -> putDerivations g ts db) db ds -searchExact :: Type TypeDB -> [(FunctionLocation, ExtendedType)] +searchExact :: Type TypeDB -> [(Location, ExtendedType)] searchExact t db = filter ((\(ET t` _)->t==t`) o snd) $ toList db.functionmap newDb :: TypeDB diff --git a/backend/builddb.icl b/backend/builddb.icl index bc3f5e3..43d3a40 100644 --- a/backend/builddb.icl +++ b/backend/builddb.icl @@ -23,7 +23,6 @@ import CoclUtils import CleanPrettyPrint // frontend -//import Heap, compile, parse, predef import Heap from hashtable import ::HashTable, ::QualifiedIdents(NoQualifiedIdents), ::IdentClass(IC_Module), ::BoxedIdent{..}, putIdentInHashTable @@ -101,16 +100,16 @@ Start w # (ok, w) = case parseCLI (tl args) of (Left e) = fclose (f <<< e) w (Right cli) - | cli.help = fclose (f <<< USAGE) w + | cli.help = fclose (f <<< USAGE) w | cli.version = fclose (f <<< VERSION) w - # (modss, w) = mapSt (\l -> findModules cli.exclude cli.root l "") cli.libs w - # mods = flatten modss - # (st, w) = init_identifiers newHeap w - # cache = empty_cache st - # (db, w) = loop cli.root mods 'DB'.newDb cache w - # db = 'DB'.putFunctions predefFunctions db - # db = 'DB'.putTypes predefTypes db - # f = 'DB'.saveDb db f + # (modss, w) = mapSt (\l -> findModules cli.exclude cli.root l "") cli.libs w + # mods = flatten modss + # (st, w) = init_identifiers newHeap w + # cache = empty_cache st + # (db, w) = loop cli.root mods 'DB'.newDb cache w + # db = 'DB'.putFunctions predefFunctions db + # db = 'DB'.putTypes predefTypes db + # f = 'DB'.saveDb db f = fclose f w | not ok = abort "Couldn't close stdio" = w @@ -119,6 +118,7 @@ where loop _ [] db _ w = (db,w) loop root [(lib,mod):list] db cache w # (db, cache, w) = getModuleTypes root mod lib cache db w + # w = snd (fclose (stderr <<< lib <<< ": " <<< mod <<< "\n") w) = loop root list db cache w parseCLI :: [String] -> Either String CLI @@ -132,16 +132,16 @@ where ("-l", [x:xs]) = (\c->{c & libs=[x:c.libs]}) <$> parseCLI xs (x, _) = Left $ "Unknown option '" +++ x +++ "'" -predefFunctions :: [('DB'.FunctionLocation, 'DB'.ExtendedType)] +predefFunctions :: [('DB'.Location, 'DB'.ExtendedType)] predefFunctions - = [ ( 'DB'.FL_Builtin "if" + = [ ( 'DB'.Builtin "if" , 'DB'.ET ('T'.Func ['T'.Type "Bool" [], 'T'.Var "a", 'T'.Var "a"] ('T'.Var "a") []) zero ) ] -predefTypes :: [('DB'.TypeLocation, 'T'.TypeDef)] +predefTypes :: [('DB'.Location, 'T'.TypeDef)] predefTypes - = [ ( 'DB'.TL_Builtin "Bool" + = [ ( 'DB'.Builtin "Bool" , { deft & 'Type'.td_name = "Bool" , 'Type'.td_rhs = 'T'.TDRCons False @@ -150,15 +150,15 @@ predefTypes ] } ) - , ( 'DB'.TL_Builtin "Int", { deft & 'Type'.td_name = "Int" } ) - , ( 'DB'.TL_Builtin "Real", { deft & 'Type'.td_name = "Real" } ) - , ( 'DB'.TL_Builtin "Char", { deft & 'Type'.td_name = "Char" } ) - , ( 'DB'.TL_Builtin "String", { deft & 'Type'.td_name = "String", - 'Type'.td_rhs = 'T'.TDRSynonym ('T'.Type "{#Char}" []) } ) - , ( 'DB'.TL_Builtin "Dynamic", { deft & 'Type'.td_name = "Dynamic" } ) - , ( 'DB'.TL_Builtin "File", { deft & 'Type'.td_name = "File" } ) - , ( 'DB'.TL_Builtin "World", { deft & 'Type'.td_name = "World", - 'Type'.td_uniq = True } ) + , ( 'DB'.Builtin "Int", { deft & 'Type'.td_name = "Int" } ) + , ( 'DB'.Builtin "Real", { deft & 'Type'.td_name = "Real" } ) + , ( 'DB'.Builtin "Char", { deft & 'Type'.td_name = "Char" } ) + , ( 'DB'.Builtin "String", { deft & 'Type'.td_name = "String", + 'Type'.td_rhs = 'T'.TDRSynonym ('T'.Type "{#Char}" []) } ) + , ( 'DB'.Builtin "Dynamic", { deft & 'Type'.td_name = "Dynamic" } ) + , ( 'DB'.Builtin "File", { deft & 'Type'.td_name = "File" } ) + , ( 'DB'.Builtin "World", { deft & 'Type'.td_name = "World", + 'Type'.td_uniq = True } ) ] where deft = {'Type'.td_name="", 'Type'.td_uniq=False, 'Type'.td_args=[], 'Type'.td_rhs='T'.TDRAbstract} @@ -226,9 +226,9 @@ where = take (length lib - length mod - 1) lib = lib - pd_macros :: String String [ParsedDefinition] -> [('DB'.MacroLocation, 'DB'.Macro)] + pd_macros :: String String [ParsedDefinition] -> [('DB'.Location, 'DB'.Macro)] pd_macros lib mod pds - = [( 'DB'.ML lib mod id.id_name (toLine pos) + = [( 'DB'.Location lib mod (toLine pos) id.id_name , { macro_as_string = priostring id +++ cpp pd , macro_extras = {zero & te_priority = findPrio id >>= toPrio} } @@ -248,22 +248,22 @@ where | id`.id_name == id.id_name = Just pd findTypeSpec id [_:pds] = findTypeSpec id pds - pd_derivations :: [ParsedDefinition] -> [('DB'.GenericName, ['DB'.Type])] + pd_derivations :: [ParsedDefinition] -> [('DB'.Name, ['DB'.Type])] pd_derivations pds = [(id.id_name, ['T'.toType gc_type]) \\ PD_Derive gcdefs <- pds, {gc_type,gc_gcf=GCF id _} <- gcdefs] pd_generics :: String String [ParsedDefinition] - -> [('DB'.FunctionLocation, 'DB'.ExtendedType)] + -> [('DB'.Location, 'DB'.ExtendedType)] pd_generics lib mod pds - = [( 'DB'.FL lib mod id_name (toLine gen_pos) + = [( 'DB'.Location lib mod (toLine gen_pos) id_name , 'DB'.ET ('T'.toType gen_type) {zero & te_generic_vars=Just $ map 'T'.toTypeVar gen_vars} ) \\ PD_Generic {gen_ident={id_name},gen_pos,gen_type,gen_vars} <- pds] pd_typespecs :: String String [ParsedDefinition] - -> [('DB'.FunctionLocation, 'DB'.ExtendedType)] + -> [('DB'.Location, 'DB'.ExtendedType)] pd_typespecs lib mod pds - = [( 'DB'.FL lib mod id_name (toLine pos) + = [( 'DB'.Location lib mod (toLine pos) id_name , 'DB'.ET ('T'.toType t) {zero & te_priority=toPrio p} ) \\ PD_TypeSpec pos id=:{id_name} p (Yes t) funspecs <- pds] @@ -273,32 +273,32 @@ where \\ PD_Instance {pim_pi={pi_ident,pi_types}} <- pds] pd_classes :: String String [ParsedDefinition] - -> [('DB'.ClassLocation, ['T'.TypeVar], 'T'.ClassContext, - [('DB'.FunctionName, 'DB'.ExtendedType)])] + -> [('DB'.Location, ['T'.TypeVar], 'T'.ClassContext, + [('DB'.Name, 'DB'.ExtendedType)])] pd_classes lib mod pds # pds = filter (\pd->case pd of (PD_Class _ _)=True; _=False) pds = map (\(PD_Class {class_ident={id_name},class_pos,class_args,class_context} pds) -> let typespecs = pd_typespecs lib mod pds - in ('DB'.CL lib mod id_name (toLine class_pos), map 'T'.toTypeVar class_args, + in ('DB'.Location lib mod (toLine class_pos) id_name, map 'T'.toTypeVar class_args, flatten $ map 'T'.toClassContext class_context, - [(f,et) \\ ('DB'.FL _ _ f _, et) <- typespecs])) pds + [(f,et) \\ ('DB'.Location _ _ _ f, et) <- typespecs])) pds pd_types :: String String [ParsedDefinition] - -> [('DB'.TypeLocation, 'DB'.TypeDef)] + -> [('DB'.Location, 'DB'.TypeDef)] pd_types lib mod pds - = [('DB'.TL lib mod ('T'.td_name td) (toLine ptd.td_pos), td) + = [('DB'.Location lib mod (toLine ptd.td_pos) ('T'.td_name td), td) \\ PD_Type ptd <- pds, td <- ['T'.toTypeDef ptd]] - constructor_functions :: ('DB'.TypeLocation, 'DB'.TypeDef) - -> [('DB'.FunctionLocation, 'DB'.ExtendedType)] - constructor_functions ('DB'.TL lib mod _ line, td) - = [('DB'.FL lib mod c line, 'DB'.ET f {zero & te_isconstructor=True}) + constructor_functions :: ('DB'.Location, 'DB'.TypeDef) + -> [('DB'.Location, 'DB'.ExtendedType)] + constructor_functions ('DB'.Location lib mod line _, td) + = [('DB'.Location lib mod line c, 'DB'.ET f {zero & te_isconstructor=True}) \\ (c,f) <- 'T'.constructorsToFunctions td] - record_functions :: ('DB'.TypeLocation, 'DB'.TypeDef) - -> [('DB'.FunctionLocation, 'DB'.ExtendedType)] - record_functions ('DB'.TL lib mod _ line, td) - = [('DB'.FL lib mod f line, 'DB'.ET t {zero & te_isrecordfield=True}) + record_functions :: ('DB'.Location, 'DB'.TypeDef) + -> [('DB'.Location, 'DB'.ExtendedType)] + record_functions ('DB'.Location lib mod line _, td) + = [('DB'.Location lib mod line f, 'DB'.ET t {zero & te_isrecordfield=True}) \\ (f,t) <- 'T'.recordsToFunctions td] toPrio :: Priority -> Maybe 'DB'.TE_Priority -- GitLab