gerrit.simantics Code Review - simantics/platform.git/blob

   1 package org.simantics.scl.compiler.elaboration.expressions;
   2
   3 import org.simantics.scl.compiler.common.exceptions.InternalCompilerError;
   4 import org.simantics.scl.compiler.compilation.CompilationContext;
   5 import org.simantics.scl.compiler.elaboration.contexts.SimplificationContext;
   6 import org.simantics.scl.compiler.elaboration.contexts.TranslationContext;
   7 import org.simantics.scl.compiler.elaboration.contexts.TypingContext;
   8 import org.simantics.scl.compiler.elaboration.modules.SCLValue;
   9 import org.simantics.scl.compiler.errors.Locations;
  10 import org.simantics.scl.compiler.internal.codegen.references.IVal;
  11 import org.simantics.scl.compiler.internal.codegen.writer.CodeWriter;
  12 import org.simantics.scl.compiler.types.Type;
  13 import org.simantics.scl.compiler.types.Types;
  14 import org.simantics.scl.compiler.types.exceptions.MatchException;
  15 import org.simantics.scl.compiler.types.exceptions.UnificationException;
  16 import org.simantics.scl.compiler.types.kinds.Kinds;
  17
  18 import gnu.trove.map.hash.TObjectIntHashMap;
  19 import gnu.trove.set.hash.THashSet;
  20 import gnu.trove.set.hash.TIntHashSet;
  21
  22 public class EBind extends SimplifiableExpression {
  23     public Expression pattern;
  24     public Expression value;
  25     public Expression in;
  26     private EVariable monadEvidence;
  27     SCLValue bindFunction;
  28     Type monadType;
  29     Type valueContentType;
  30     Type inContentType;
  31
  32     public EBind(long loc, Expression pattern, Expression value, Expression in) {
  33         super(loc);
  34         this.pattern = pattern;
  35         this.value = value;
  36         this.in = in;
  37     }
  38
  39     public EBind(long loc, Expression pattern, Expression value, Expression in,
  40             SCLValue bindFunction) {
  41         super(loc);
  42         this.pattern = pattern;
  43         this.value = value;
  44         this.in = in;
  45     }
  46
  47     @Override
  48     public void collectRefs(final TObjectIntHashMap<Object> allRefs, final TIntHashSet refs) {
  49         value.collectRefs(allRefs, refs);
  50         in.collectRefs(allRefs, refs);
  51     }
  52
  53     @Override
  54     public void collectVars(TObjectIntHashMap<Variable> allVars,
  55             TIntHashSet vars) {
  56         value.collectVars(allVars, vars);
  57         in.collectVars(allVars, vars);
  58     }
  59
  60     @Override
  61     protected void updateType() throws MatchException {
  62         setType(in.getType());
  63     }
  64
  65     @Override
  66     public Expression checkBasicType(TypingContext context, Type requiredType) {
  67         monadType = Types.metaVar(Kinds.STAR_TO_STAR);
  68         inContentType = Types.metaVar(Kinds.STAR);
  69         Type monadContent = Types.apply(monadType, inContentType);
  70         try {
  71             Types.unify(requiredType, monadContent);
  72         } catch (UnificationException e) {
  73             context.typeError(location, requiredType, monadContent);
  74             return this;
  75         }
  76
  77         Variable variable = new Variable("monadEvidence");
  78         variable.setType(Types.pred(Types.MONAD, monadType));
  79         monadEvidence = new EVariable(getLocation(), variable);
  80         monadEvidence.setType(variable.getType());
  81         context.addConstraintDemand(monadEvidence);
  82
  83         pattern = pattern.checkTypeAsPattern(context, Types.metaVar(Kinds.STAR));
  84         valueContentType = pattern.getType();
  85         value = value.checkType(context, Types.apply(monadType, valueContentType));
  86         in = in.checkType(context, requiredType);
  87         Type inType = in.getType();
  88         setType(inType);
  89         return this;
  90     }
  91
  92     @Override
  93     public IVal toVal(CompilationContext context, CodeWriter w) {
  94         throw new InternalCompilerError("EBind should be eliminated.");
  95     }
  96
  97     /**
  98      * Splits let
  99      */
 100     @Override
 101     public Expression simplify(SimplificationContext context) {
 102         value = value.simplify(context);
 103         in = in.simplify(context);
 104         pattern = pattern.simplify(context);
 105
 106         long loc = getLocation();
 107         Expression simplified = new EApply(loc,
 108                 new EConstant(loc, bindFunction, Types.canonical(monadType), Types.canonical(valueContentType), Types.canonical(inContentType)),
 109                 monadEvidence,
 110                 value,
 111                 new ELambda(loc, new Case[] {
 112                     new Case(new Expression[] { pattern }, in)
 113                 }));
 114         simplified.setType(getType());
 115
 116         return simplified.simplify(context);
 117     }
 118
 119     @Override
 120     public void collectFreeVariables(THashSet<Variable> vars) {
 121         in.collectFreeVariables(vars);
 122         value.collectFreeVariables(vars);
 123         pattern.removeFreeVariables(vars);
 124     }
 125
 126     @Override
 127     public Expression resolve(TranslationContext context) {
 128         value = value.resolve(context);
 129
 130         context.pushFrame();
 131         pattern = pattern.resolveAsPattern(context);
 132         in = in.resolve(context);
 133         context.popFrame();
 134
 135         bindFunction = context.getBindFunction();
 136
 137         return this;
 138     }
 139
 140     @Override
 141     public void collectEffects(THashSet<Type> effects) {
 142         pattern.collectEffects(effects);
 143         value.collectEffects(effects);
 144         in.collectEffects(effects);
 145     }
 146
 147     @Override
 148     public void setLocationDeep(long loc) {
 149         if(location == Locations.NO_LOCATION) {
 150             location = loc;
 151             pattern.setLocationDeep(loc);
 152             value.setLocationDeep(loc);
 153             in.setLocationDeep(loc);
 154         }
 155     }
 156
 157     @Override
 158     public void accept(ExpressionVisitor visitor) {
 159         visitor.visit(this);
 160     }
 161
 162     @Override
 163     public void forVariables(VariableProcedure procedure) {
 164         pattern.forVariables(procedure);
 165         value.forVariables(procedure);
 166         if(monadEvidence != null)
 167             monadEvidence.forVariables(procedure);
 168     }
 169
 170     @Override
 171     public Expression accept(ExpressionTransformer transformer) {
 172         return transformer.transform(this);
 173     }
 174
 175 }