diff options
Diffstat (limited to 'src/HSVIS/Typecheck/Solve.hs')
| -rw-r--r-- | src/HSVIS/Typecheck/Solve.hs | 22 |
1 files changed, 11 insertions, 11 deletions
diff --git a/src/HSVIS/Typecheck/Solve.hs b/src/HSVIS/Typecheck/Solve.hs index 250d7e7..7b91585 100644 --- a/src/HSVIS/Typecheck/Solve.hs +++ b/src/HSVIS/Typecheck/Solve.hs @@ -84,7 +84,7 @@ solveConstraints reduce frees subst detect size = \tupcs -> in trace ("[solver] Solving:" ++ concat ["\n- " ++ pretty a ++ " == " ++ pretty b ++ " {" ++ pretty r ++ "}" | Constr a b r <- cs]) $ trace ("[solver] Result: (with " ++ show (length errs'') ++ " errors)" ++ concat ["\n- " ++ show v ++ " = " ++ pretty t | (v, t) <- Map.assocs asg'] ++ - "\n... errors: " ++ intercalate ", " (map summariseUE (toList errs''))) + "\n... errors: [" ++ intercalate ", " (map summariseUE (toList errs'')) ++ "]") (asg', errs'') where reduce' :: Constr t t -> (Bag (Constr v t), Bag (Constr t t)) @@ -92,14 +92,14 @@ solveConstraints reduce frees subst detect size = \tupcs -> loop :: Map v (Bag (RConstr t)) -> [(v, t)] -> (Bag (UnifyErr v t), Map v t) loop m eqlog = do - traceM $ "[solver] Step:" ++ concat - [case toList rhss of - [] -> "\n- " ++ show v ++ " <no RHSs>" - RConstr t r : rest -> - "\n- " ++ show v ++ " == " ++ pretty t ++ " {" ++ pretty r ++ "}" ++ - concat ["\n " ++ replicate (length (show v)) ' ' ++ " == " ++ pretty t' ++ " {" ++ pretty r' ++ "}" - | RConstr t' r' <- rest] - | (v, rhss) <- Map.assocs m] + -- traceM $ "[solver] Step:" ++ concat + -- [case toList rhss of + -- [] -> "\n- " ++ show v ++ " <no RHSs>" + -- RConstr t r : rest -> + -- "\n- " ++ show v ++ " == " ++ pretty t ++ " {" ++ pretty r ++ "}" ++ + -- concat ["\n " ++ replicate (length (show v)) ' ' ++ " == " ++ pretty t' ++ " {" ++ pretty r' ++ "}" + -- | RConstr t' r' <- rest] + -- | (v, rhss) <- Map.assocs m] m' <- Map.traverseWithKey (\v rhss -> @@ -120,10 +120,10 @@ solveConstraints reduce frees subst detect size = \tupcs -> case msmallestvar of Nothing -> do - traceM $ "[solver] Log = [" ++ intercalate ", " [show v ++ " = " ++ pretty t | (v, t) <- eqlog] ++ "]" + -- traceM $ "[solver] Log = [" ++ intercalate ", " [show v ++ " = " ++ pretty t | (v, t) <- eqlog] ++ "]" return $ applyLog eqlog mempty Just (var, RConstr smallrhs _) -> do - traceM $ "[solver] Retiring " ++ show var ++ " = " ++ pretty smallrhs + -- traceM $ "[solver] Retiring " ++ show var ++ " = " ++ pretty smallrhs let (_, otherrhss) = bagPartition (guard . (== smallrhs) . rconType) (m' Map.! var) let (newcs, errs) = foldMap (reduce' . unsplitConstr smallrhs) (dedupRCs (toList otherrhss)) (fmap constrUnequal errs, ()) -- write the errors |