1 2 -- ==========================================================-- 3 -- === Turn type expressions into domain expressions. ===-- 4 -- === TExpr2DExpr.hs ===-- 5 -- ==========================================================-- 6 7 module TExpr2DExpr where 8 import BaseDefs 9 import Utils 10 import MyUtils 11 import DomainExpr 12 import MakeDomains 13 import TypeCheck5 14 15 import List(nub) -- 1.3 16 17 -- ==========================================================-- 18 -- This may need fixing up if we start instantiating domain 19 -- variables to expressions which contain other domain 20 -- variables within them. 21 -- 4 Feb: solved the above problem by replacing the offending 22 -- domain variables with 2. 23 -- 5 Feb: fixed to curry domains properly, if necessary. 24 -- 25 txGetInstantiations :: DExpr -> 26 DExpr -> 27 AList Naam Domain 28 29 txGetInstantiations simplest usage 30 = consistent [] (gi simplest usage) 31 where 32 gi (DXVar v) dexpr = [(v, dxApplyDSubst_2 dexpr)] 33 gi DXTwo DXTwo = [] 34 gi (DXLift1 dxs1) (DXLift1 dxs2) = concat (myZipWith2 gi dxs1 dxs2) 35 gi (DXLift2 dxs1) (DXLift2 dxs2) = concat (myZipWith2 gi dxs1 dxs2) 36 gi (DXFunc dxss1 dxt1) (DXFunc dxss2 dxt2) 37 = let basis_arity = length dxss1 38 usage_arity = length dxss2 39 (new_dxss2, new_dxt2) = 40 if usage_arity > basis_arity 41 then (take basis_arity dxss2, 42 DXFunc (drop basis_arity dxss2) dxt2) 43 else (dxss2, dxt2) 44 in gi dxt1 new_dxt2 ++ concat (myZipWith2 gi dxss1 new_dxss2) 45 46 consistent acc [] = acc 47 consistent acc ((v,dx):rest) 48 = case utLookup acc v of 49 Nothing -> consistent ((v,dx):acc) rest 50 Just dy -> if dx == dy 51 then consistent acc rest 52 else panic "txGetInstantiations" 53 54 55 -- ==========================================================-- 56 -- 57 tx2dxAnnTree :: TypeDependancy -> 58 AnnExpr Naam TExpr -> 59 AnnExpr Naam DExpr 60 61 tx2dxAnnTree td tree = tcMapAnnExpr (tx2dx td) tree 62 63 64 -- ==========================================================-- 65 -- 66 tx2dx :: TypeDependancy -> TExpr -> DExpr 67 68 tx2dx td texpr 69 = let typeVars = sort (nub (tcTvars_in texpr)) 70 dVarEnv = zip typeVars [[x] | x <- "abcdefghijklmnopqrstuvwxyz"] 71 in if length typeVars > 26 72 then panic "tx2dx" 73 else dxNormaliseDExpr (tx2dx_aux td dVarEnv texpr) 74 75 tx2dx_aux td env (TVar v) 76 = DXVar (utSureLookup env "tx2dx_aux(1)" v) 77 tx2dx_aux td env (TCons "int" []) 78 = DXTwo 79 tx2dx_aux td env (TCons "char" []) 80 = DXTwo 81 tx2dx_aux td env (TArr t1 t2) 82 = DXFunc [tx2dx_aux td env t1] (tx2dx_aux td env t2) 83 tx2dx_aux td env (TCons tname targs) 84 = if mdIsRecursiveType td tname 85 then DXLift2 (map (tx2dx_aux td env) targs) 86 else DXLift1 (map (tx2dx_aux td env) targs) 87 88 -- ==========================================================-- 89 -- === end TExpr2DExpr.hs ===-- 90 -- ==========================================================--