Commit 488a1c07 authored by Camil Staps's avatar Camil Staps 🚀

Type search POC

parent 75875d16
......@@ -8,3 +8,8 @@ StdEnv
StdLib
TCPIP
clean-platform
Clean System Files/
search
builddb
types.db
[submodule "CleanTypeUnifier"]
path = CleanTypeUnifier
url = https://github.com/camilstaps/CleanTypeUnifier
Subproject commit 8de758c44d0cafccfe150ea4e8028161577c4e82
definition module TypeDB
// Standard libraries
from StdOverloaded import class <, class zero
from StdClass import class Ord
from Data.Map import ::Map
from Data.Maybe import ::Maybe
from GenEq import generic gEq
// CleanTypeUnifier
from Type import ::Type, ::TypeVar, ::TypeVarAssignment, class print(..)
:: TypeDB
instance zero TypeDB
derive gEq TypeDB
:: FunctionLocation = FL Library Module FunctionName
instance < FunctionLocation
instance print FunctionLocation
:: Library :== String
:: Module :== String
:: FunctionName :== String
:: Class :== String
getType :: FunctionLocation TypeDB -> Maybe Type
putType :: FunctionLocation Type TypeDB -> TypeDB
putTypes :: [(FunctionLocation, Type)] TypeDB -> TypeDB
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchUnifiable :: Type TypeDB -> [(FunctionLocation, Type, [TypeVarAssignment], [TypeVarAssignment])]
newDb :: TypeDB
openDb :: *File -> *(Maybe TypeDB, *File)
saveDb :: TypeDB *File -> *File
implementation module TypeDB
// Standard libraries
import StdEnv
from Data.Func import $
import Data.Map
import Data.Maybe
import Text.JSON
// CleanTypeUnifier
import Type
:: TypeDB = { typemap :: Map FunctionLocation Type
, instancemap :: Map Class Type
}
(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b
instance zero TypeDB where zero = {typemap=newMap, instancemap=newMap}
derive gEq ClassOrGeneric, ArrayKind, Strict, SpineStrictness, ListKind,
FunctionLocation, Type, TypeDB
derive JSONEncode ClassOrGeneric, ArrayKind, Strict, SpineStrictness, ListKind,
FunctionLocation, Type, TypeDB
derive JSONDecode ClassOrGeneric, ArrayKind, Strict, SpineStrictness, ListKind,
FunctionLocation, Type, TypeDB
instance < FunctionLocation where (<) (FL a b c) (FL d e f) = (a,b,c) < (d,e,f)
instance print FunctionLocation
where print (FL lib mod fn) = fn <+ " in " <+ mod <+ " in " <+ lib
getType :: FunctionLocation TypeDB -> Maybe Type
getType loc {typemap} = get loc typemap
putType :: FunctionLocation Type TypeDB -> TypeDB
putType fl t tdb=:{typemap} = { tdb & typemap = put fl t typemap }
putTypes :: [(FunctionLocation, Type)] TypeDB -> TypeDB
putTypes ts tdb = foldr (\(loc,t) db=:{typemap} -> {db & typemap=put loc t typemap}) tdb ts
searchExact :: Type TypeDB -> [(FunctionLocation, Type)]
searchExact t db = filter ((==)t o snd) $ toList db.typemap
searchUnifiable :: Type TypeDB -> [(FunctionLocation, Type, [TypeVarAssignment], [TypeVarAssignment])]
searchUnifiable t db = search` $ toList db.typemap
where
search` :: [(FunctionLocation,Type)] -> [(FunctionLocation,Type,[TypeVarAssignment],[TypeVarAssignment])]
search` [] = []
search` [(l,t`):list]
# tvas = unify t t`
| isNothing tvas = search` list
# (tvas1,tvas2) = fromJust tvas
= [(l,t`,tvas1,tvas2):search` list]
newDb :: TypeDB
newDb = zero
openDb :: *File -> *(Maybe TypeDB, *File)
openDb f
# (data, f) = freadline f
= (fromJSON $ fromString data, f)
saveDb :: TypeDB *File -> *File
saveDb db f = fwrites (toString $ toJSON db) f
db = { zero & typemap = put (FL "a" "b" "somefunc") (Var "x") newMap }
module builddb
// Project libraries
import qualified TypeDB as DB
from TypeDB import instance print FunctionLocation
// Standard libraries
import StdArray, StdBool, StdFile, StdList, StdMisc, StdString, StdFunc, StdTuple
import Data.Maybe, Text
import System.Directory, Data.Error, Data.Func, Data.Tuple
import GenEq
// CleanTypeUnifier
import Type
import CoclUtils
// frontend
//import Heap, compile, parse, predef
import Heap
from hashtable import ::HashTable, ::QualifiedIdents(NoQualifiedIdents), ::IdentClass(IC_Module), ::BoxedIdent{..}, putIdentInHashTable
from predef import init_identifiers
from compile import empty_cache, ::DclCache{hash_table}
from general import ::Optional(..)
from syntax import ::SymbolTable, ::SymbolTableEntry, ::Ident{..}, ::SymbolPtr, ::Position(NoPos), ::Module{mod_defs}, ::ParsedDefinition(PD_TypeSpec), ::FunSpecials, ::Priority, ::ParsedModule, ::SymbolType
from parse import wantModule
CLEAN_LIB :== "/opt/clean/lib/"
libraries :== [
"StdEnv"
, "StdLib"
, "ArgEnv"
, "Directory"
, "Dynamics"
, "Gast"
, "Generics"
, "MersenneTwister"
, "TCPIP"
, "clean-platform/OS-Independent"
, "clean-platform/OS-Linux"
, "clean-platform/OS-Linux-32"
, "clean-platform/OS-Linux-64"
, "clean-platform/OS-Mac"
, "clean-platform/OS-Posix"
, "clean-platform/OS-Windows"
, "clean-platform/OS-Windows-32"
, "clean-platform/OS-Windows-64"
]
Start w
# (mods, w) = findModules` libraries w //libraries w
# (st, w) = init_identifiers newHeap w
# cache = empty_cache st
# (db, w) = loop mods 'DB'.newDb cache w
# (ok, f, w) = fopen "types.db" FReadText w
| not ok = abort "Couldn't open types.db for reading\n"
# (db`, f) = 'DB'.openDb f
| isNothing db` = abort "types.db does not contain a TypeDB\n"
# db` = fromJust db`
# msg = if (db===db`) "databases are equal" "databases are not equal"
# (ok, f) = freopen f FWriteText
| not ok = abort "Couldn't open types.db for writing\n"
# f = 'DB'.saveDb db f
# (ok, w) = fclose f w
| not ok = abort "Couldn't close types.db after writing\n"
= (msg, ok)
where
loop :: [(String,String)] 'DB'.TypeDB *DclCache *World -> *('DB'.TypeDB, *World)
loop [] db _ w = (db,w)
loop [(lib,mod):list] db cache w
# (sts, cache, w) = getModuleTypes mod lib cache w
# (io, w) = stdio w
| isEmpty sts
# io = fwrites (line +++ "\nSkipping " +++ mod +++ " in " +++ lib +++ " (no function types found)\n") io
= loop list db cache (snd (fclose io w))
# io = fwrites (line +++ "\nParsing " +++ mod +++ " in " +++ lib +++ "\n" +++ line +++ "\n") io
# io = fwrites (concat (join "\n" [alignl 42 (concat (print t)) <+ "\t" <+ n \\ ('DB'.FL _ _ n, t) <- sts]) +++ "\n") io
# (ok, w) = fclose io w
| not ok = abort "Couldn't close stdio\n"
# db = 'DB'.putTypes sts db
= loop list db cache w
line = {c \\ c <- repeatn 80 '-'}
// Libraries Library Module
findModules` :: ![String] !*World -> *(![(String,String)], !*World)
findModules` [] w = ([], w)
findModules` [lib:libs] w
#! (mods, w) = findModules lib w
#! (moremods, w) = findModules` libs w
= (removeDup (mods ++ moremods), w)
findModules :: !String !*World -> *(![(String,String)], !*World)
findModules lib w
#! (fps, w) = readDirectory (CLEAN_LIB +++ lib) w
| isError fps = ([], w)
#! fps = fromOk fps
#! mods = map (tuple lib) $ map (\s->s%(0,size s-5)) $ filter isDclModule fps
#! (moremods, w) = findModules` (map ((+++) (lib+++"/")) (filter isDirectory fps)) w
= (removeDup (mods ++ moremods), w)
where
isDclModule :: String -> Bool
isDclModule s = s % (size s - 4, size s - 1) == ".dcl" && s.[0] <> '_'
isDirectory :: String -> Bool
isDirectory s = not $ isMember '.' $ fromString s
getModuleTypes :: String String *DclCache *World -> *([('DB'.FunctionLocation,Type)], *DclCache, *World)
getModuleTypes mod lib cache w
# filename = CLEAN_LIB +++ lib +++ "/" +++ mkdir mod +++ ".dcl"
# (ok,f,w) = fopen filename FReadText w
| not ok = abort ("Couldn't open file " +++ filename +++ ".\n")
# (mod_id, ht) = putIdentInHashTable mod (IC_Module NoQualifiedIdents) cache.hash_table
cache = {cache & hash_table=ht}
# ((b1,b2,pm,ht,f),w) = accFiles (wantModule` f "" False mod_id.boxed_ident NoPos True cache.hash_table stderr) w
cache = {cache & hash_table=ht}
# (ok,w) = fclose f w
| not ok = abort ("Couldn't close file " +++ filename +++ ".\n")
# pds = filter (\pd->case pd of (PD_TypeSpec _ _ _ _ _)=True; _=False) pm.mod_defs
# sts = map (\(PD_TypeSpec pos id prio st funspecs) -> ('DB'.FL lib mod id.id_name,st)) pds
# sts = filter (\st->case st of (_,(Yes _))=True; _=False) sts
# sts = map (\(loc,Yes x)->(loc,toType x)) sts
= (sts,cache,w)
where
mkdir :: String -> String
mkdir s = toString (map (\c.case c of '.'='/'; c=c) (fromString s))
unigroups :: (Type Type -> Bool) [(a,Type)] -> [([a],Type)]
unigroups f ts = unigroups` ts []
where
unigroups` [] groups = groups
unigroups` [(a,t):ts] [] = unigroups` ts [([a],t)]
unigroups` [(a,t):ts] [(ns,ut):groups]
| f t ut = unigroups` ts [([a:ns],ut):groups]
| otherwise = unigroups` ts [(ns,ut):unigroups` [(a,t)] groups]
(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b
join :: a [b] -> [String] | print a & print b
join _ [] = []
join a [b:[]] = print b
join a [b:bs] = b <+ a <+ join a bs
alignl :: Int a -> [String] | print a
alignl i s
# s = print s
# len = sum (map size s)
| len >= i = s
| otherwise = s ++ [{' ' \\ i <- [0..i-len]}]
wantModule` :: !*File !{#Char} !Bool !Ident !Position !Bool !*HashTable !*File !*Files
-> ((!Bool,!Bool,!ParsedModule, !*HashTable, !*File), !*Files)
wantModule` f s b1 i p b2 ht io fs
# (b1,b2,pm,ht,f,fs) = wantModule f s b1 i p b2 ht io fs
= ((b1,b2,pm,ht,f),fs)
This diff is collapsed.
module search
import TypeDB
import Type
import StdArray, StdBool, StdFile, StdList, StdOrdList, StdMisc, StdString
import Data.Maybe
import Text
Start w
# (ok, f, w) = fopen "types.db" FReadText w
| not ok = abort "Couldn't open types.db for reading\n"
# (db, f) = openDb f
| isNothing db = abort "types.db does not contain a TypeDB\n"
# db = fromJust db
# types = searchUnifiable (Func [Var "a"] (Type "Int" []) []) db
# types = sortBy (\(_,_,a,b)(_,_,x,y)->length (a++b) < length (x++y)) types
# (io, w) = stdio w
# io = fwrites (concat (join "\n" [alignl 42 (concat (print t)) <+ "\t" <+ n \\ (FL _ _ n, t, _, _) <- types]) +++ "\n") io
# (ok, w) = fclose io w
= w
(<+) infixr 5 :: a b -> [String] | print a & print b
(<+) a b = print a ++ print b
join :: a [b] -> [String] | print a & print b
join _ [] = []
join a [b:[]] = print b
join a [b:bs] = b <+ a <+ join a bs
alignl :: Int a -> [String] | print a
alignl i s
# s = print s
# len = sum (map size s)
| len >= i = s
| otherwise = s ++ [{' ' \\ i <- [0..i-len]}]
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment