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 -- ==========================================================--